git.iko.soy/squeal
on 1ac00ca help sign in
ddc9847
swap
0 ahead, 665 behind
53 files changed+4232−12226
since splitsnapshots
unifiedsplit
.circleci/config.yml+2−3 README.md+126−177 RELEASE NOTES.md+1−1084 scrap-your-nils.md−60 squeal-postgresql/README.md+219−1 squeal-postgresql/exe/Example.hs+54−51 squeal-postgresql/squeal-postgresql.cabal+12−75 squeal-postgresql/src/Squeal/PostgreSQL.hs+222−233 squeal-postgresql/src/Squeal/PostgreSQL/Alias.hs−249 squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+119−690 squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+607−29 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hs−238 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hs−159 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hs−96 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hs−500 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table/Constraint.hs−339 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hs−229 squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hs−104 squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+1095−364 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hs−462 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hs−169 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs−206 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hs−462 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Literal.hs−87 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs−105 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs−100 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hs−104 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hs−80 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hs−230 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Set.hs−139 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hs−85 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hs−120 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs−64 squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs−157 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs−192 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs−446 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Window.hs−284 squeal-postgresql/src/Squeal/PostgreSQL/List.hs−112 squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+361−427 squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+220−350 squeal-postgresql/src/Squeal/PostgreSQL/PG.hs−388 squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+216−319 squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+81−70 squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+442−726 squeal-postgresql/src/Squeal/PostgreSQL/Render.hs+6−76 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+348−375 squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+82−102 squeal-postgresql/test/Doc.hs−6 squeal-postgresql/test/DocTest.hs+18 squeal-postgresql/test/Property.hs−166 squeal-postgresql/test/Spec.hs−136 squeal-presentation-raveline.md−794 stack.yaml+1−6
.circleci/config.yml+2−3
@@ -2,10 +2,9 @@ version: 2
22jobs:
33 build:
44 docker:
5− - image: haskell:8.6.5
5+ - image: haskell:latest
66 - image: circleci/postgres:latest
77 environment:
8− POSTGRES_USER: root
98 POSTGRES_DB: exampledb
109 steps:
1110 - checkout
@@ -14,7 +13,7 @@ jobs:
1413 - dependency-cache
1514 - run: apt-get update && apt-get install -y libpq-dev xz-utils make
1615 - run: stack upgrade && stack update
17− - run: stack build --fast
16+ - run: stack build
1817 - run: stack test
1918 - run: stack haddock
2019 - save_cache:
README.md+126−177
@@ -10,80 +10,25 @@
1010
1111[Stackage](https://www.stackage.org/package/squeal-postgresql)
1212
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−
5513## installation
5614
5715`stack install squeal-postgresql`
5816
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−
7117## usage
7218
73−Let's see an example!
74−
19+Squeal is a deep embedding of PostgreSQL in Haskell. Let's see an example!
7520First, we need some language extensions because Squeal uses modern GHC
7621features.
77−
78−```Haskell
79−>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts
80−>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs
22+```haskell
23+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
24+>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators
8125```
8226
8327We'll need some imports.
8428
85−```Haskell
86−>>> import Control.Monad.IO.Class (liftIO)
29+```haskell
30+>>> import Control.Monad (void)
31+>>> import Control.Monad.Base (liftBase)
8732>>> import Data.Int (Int32)
8833>>> import Data.Text (Text)
8934>>> import Squeal.PostgreSQL
@@ -91,163 +36,165 @@ We'll need some imports.
9136
9237We'll use generics to easily convert between Haskell and PostgreSQL values.
9338
94−```Haskell
39+```haskell
9540>>> import qualified Generics.SOP as SOP
9641>>> import qualified GHC.Generics as GHC
9742```
9843
9944The first step is to define the schema of our database. This is where
100−we use `DataKinds` and `TypeOperators`.
101−
102−```Haskell
45+we use `DataKinds` and `TypeOperators`. The schema consists of a type-level
46+list of tables, a `:::` pairing of a type level string or
47+`Symbol` and a list a columns, itself a `:::` pairing of a
48+`Symbol` and a `ColumnType`. The `ColumnType` describes the
49+PostgreSQL type of the column as well as whether or not it may contain
50+`NULL` and whether or not inserts and updates can use a `DEFAULT`. For our
51+schema, we'll define two tables, a users table and an emails table.
52+
53+```haskell
10354>>> :{
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"] ]
11555type Schema =
116− '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns)
117− , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ]
118−type Schemas = Public Schema
56+ '[ "users" :::
57+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
58+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
59+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
60+ ]
61+ , "emails" :::
62+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
63+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
64+ ] :=>
65+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
66+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
67+ , "email" ::: 'NoDef :=> 'Null 'PGtext
68+ ]
69+ ]
11970:}
12071```
12172
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−
13273Next, 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
74+Squeal, a `Definition` is a `createTable`, `alterTable` or `dropTable`
75+command and has two type parameters, corresponding to the schema
76+before being run and the schema after. We can compose definitions using
77+`>>>`. Here and in the rest of our commands we make use of overloaded
13778labels to refer to named tables and columns in our schema.
13879
139−```Haskell
80+```haskell
14081>>> :{
14182let
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 )
83+ setup :: Definition '[] Schema
84+ setup =
85+ createTable #users
86+ ( serial `As` #id :*
87+ (text & notNull) `As` #name :* Nil )
88+ ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>>
89+ createTable #emails
90+ ( serial `As` #id :*
91+ (int & notNull) `As` #user_id :*
92+ text `As` #email :* Nil )
93+ ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
94+ foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
95+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
15596:}
15697```
15798
158−We can easily see the generated SQL is unsurprising looking.
99+We can easily see the generated SQL is unsuprising looking.
159100
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);
101+```haskell
102+>>> renderDefinition setup
103+"CREATE TABLE users (id serial, name text NOT NULL, CONSTRAINT pk_users PRIMARY KEY (id)); CREATE TABLE emails (id serial, user_id int NOT NULL, email text, CONSTRAINT pk_emails PRIMARY KEY (id), CONSTRAINT fk_user_id FOREIGN KEY (user_id) REFERENCES rs (id) ON DELETE CASCADE ON UPDATE CASCADE);"
164104```
165105
166106Notice that `setup` starts with an empty schema `'[]` and produces `Schema`.
167107In our `createTable` commands we included `TableConstraint`s to define
168−primary and foreign keys, making them somewhat complex. Our `teardown`
108+primary and foreign keys, making them somewhat complex. Our tear down
169109`Definition` is simpler.
170110
171−```Haskell
111+```haskell
172112>>> :{
173113let
174− teardown :: Definition Schemas (Public '[])
114+ teardown :: Definition Schema '[]
175115 teardown = dropTable #emails >>> dropTable #users
176116:}
177−
178−>>> printSQL teardown
179−DROP TABLE "emails";
180−DROP TABLE "users";
117+>>> renderDefinition teardown
118+"DROP TABLE emails; DROP TABLE users;"
181119```
182120
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
121+Next, we'll write `Manipulation`s to insert data into our two tables.
122+A `Manipulation` is a `insertInto`, `update` or `deleteFrom` command and
123+has three type parameters, the schema it refers to, a list of parameters
124+it can take as input, and a list of columns it produces as output. When
196125we 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
126+field but not for the `id` field. Since it's optional, we can use a default
198127value. However, since the emails table refers to the users table, we will
199128need 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.
129+the emails table. Take a careful look at the type and definition of both
130+of our inserts.
202131
203−```Haskell
132+```haskell
204133>>> :{
205134let
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))
135+ insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ]
136+ '[ "fromOnly" ::: 'NotNull 'PGint4 ]
137+ insertUser = insertRow #users
138+ (Default `As` #id :* Set (param `1) `As` #name :* Nil)
139+ OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
215140:}
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"
141+>>> :{
142+let
143+ insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
144+ insertEmail = insertRow #emails
145+ ( Default `As` #id :*
146+ Set (param `1) `As` #user_id :*
147+ Set (param `2) `As` #email :* Nil )
148+ OnConflictDoNothing (Returning Nil)
149+:}
150+>>> renderManipulation insertUser
151+"INSERT INTO users (id, name) VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING URNING id AS fromOnly;"
152+>>> renderManipulation insertEmail
153+"INSERT INTO emails (id, user_id, email) VALUES (DEFAULT, ($1 :: int4), ($2 :: text)N CONFLICT DO NOTHING;"
219154```
220155
221−Next we write a `Query_` to retrieve users from the database. We're not
156+Next we write a `Query` to retrieve users from the database. We're not
222157interested 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.
158+need to use an inner join to get the right result. A `Query` is like a
159+`Manipulation` with the same kind of type parameters.
225160
226−```Haskell
161+```haskell
227162>>> :{
228163let
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))
164+ getUsers :: Query Schema '[]
165+ '[ "userName" ::: 'NotNull 'PGtext
166+ , "userEmail" ::: 'Null 'PGtext ]
167+ getUsers = select
168+ (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)
169+ ( from (table (#users `As` #u)
170+ & innerJoin (table (#emails `As` #e))
234171 (#u ! #id .== #e ! #user_id)) )
235172:}
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")
173+>>> renderQuery getUsers
174+"SELECT u.name AS userName, e.email AS userEmail FROM users AS u INNER JOIN emails e ON (u.id = e.user_id)"
175+```
176+Now that we've defined the SQL side of things, we'll need a Haskell type
177+for users. We give the type `Generics.SOP.Generic` and
178+`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows
179+we receive when we run `getUsers`. Notice that the record fields of the
180+`User` type match the column names of `getUsers`.
181+
182+```haskell
183+>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, .Generic)
184+>>> instance SOP.Generic User
185+>>> instance SOP.HasDatatypeInfo User
239186```
240187
241−Let's create some users to add to the database.
188+Let's also create some users to add to the database.
242189
243−```Haskell
190+```haskell
244191>>> :{
245192let
246193 users :: [User]
247− users =
248− [ User "Alice" (Just "alice@gmail.com")
194+ users =
195+ [ User "Alice" (Just "alice`gmail.com")
249196 , User "Bob" Nothing
250− , User "Carole" (Just "carole@hotmail.com")
197+ , User "Carole" (Just "carole`hotmail.com")
251198 ]
252199:}
253200```
@@ -260,21 +207,23 @@ the changing schema information through by using the indexed `PQ` monad
260207transformer and when the schema doesn't change we can use `Monad` and
261208`MonadPQ` functionality.
262209
263−```Haskell
210+```haskell
264211>>> :{
265212let
266− session :: PQ Schemas Schemas IO ()
213+ session :: PQ Schema Schema IO ()
267214 session = do
268− _ <- traversePrepared_ insertUser users
215+ idResults <- traversePrepared insertUser (Only . userName <$> users)
216+ ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults
217+ traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
269218 usersResult <- runQuery getUsers
270219 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)
220+ liftBase $ print (usersRows :: [User])
221+:}
222+>>> :{
223+void . withConnection "host=localhost port=5432 dbname=exampledb" $
224+ define setup
225+ & pqThen session
226+ & thenDefine teardown
277227:}
278−[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
279−-}
228+[User {userName = "Alice", userEmail = Just "alice`gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just role`hotmail.com"}]
280229```
RELEASE NOTES.md+1−1084
@@ -1,1089 +1,6 @@
11## RELEASE NOTES
22
3−### Version 0.5
4−
5−Version 0.5 makes a number of large changes and additions to Squeal.
6−I want to thank folks who contributed issues and pull requests;
7−Raveline, rimmington, ilyakooo0, chshersh, reygoch, and more.
8−
9−**Multi-schema support**
10−
11−Previous versions of Squeal only supported definitions in the "public"
12−schema. Squeal 0.5 adds support for multiple schemas with the new kind
13−
14−```Haskell
15−type SchemasType = [(Symbol,SchemaType)]
16−```
17−
18−In order to upgrade your queries, manipulations and definitions from
19−Squeal 0.4, you will have to apply the `Public` type family, which indicates
20−that your only schema is the "public" schema.
21−
22−```Haskell
23−-- Squeal 0.4
24−setup :: Definition '[] Schema
25−
26−-- Squeal 0.5
27−setup :: Definition (Public '[]) (Public Schema)
28−```
29−
30−You can create non-public schemas using `createSchema` and inversely
31−remove them using `dropSchema`. There is also an idempotent
32−`createSchemaIfNotExists`.
33−
34−In order to handle aliases which may refer to non-public schemas, Squeal 0.5
35−introduces `QualifiedAlias`es. A `QualifiedAlias` can be referred to using
36−the `(!)` operator from the `IsQualified` typeclass; but if you want to refer
37−to an alias from the "public" schema, you can continue to use a single
38−overloaded label, no need to write `#public ! #tab`, just write `#tab`.
39−
40−**Top-level statements**
41−
42−As a consequence of multi-schema support, common table expressions that
43−a `Query` or `Manipulation` may refer to had to be broken into a new parameter.
44−Additionally, `Query` gained another new parameter for its outer scope which
45−will be discussed in the next section.
46−
47−To simplify type signatures that you have to write for top-level queries
48−and manipulations, Squeal 0.5 introduces the `Query_` and `Manipulation_`
49−type families.
50−
51−```
52−type family Query_
53− (schemas :: SchemasType)
54− (parameters :: Type)
55− (row :: Type) where
56− Query_ schemas params row =
57− Query '[] '[] schemas (TuplePG params) (RowPG row)
58−```
59−
60−As you see, a top-level `Query_` has no outer scope and no common
61−table expressions in scope, they are empty `'[]`. Moreover,
62−its parameters and row parameters are now `Type`s, which are
63−converted to corresponding Postgres types using the `TuplePG`
64−and `RowPG` type families. This means you can write the type signatures
65−for your top-level statements using the Haskell types that you
66−intend to input and retrieve when running the statements. Similar
67−to `Query_`, there is a `Manipulation_` type, the only difference
68−being that a general `Manipulation` doesn't have an outer scope,
69−only a scope for common table expressions.
70−
71−**Subquery expressions**
72−
73−Previous versions of Squeal offered subquery expression support
74−but there were issues. The common use case of using the `IN` operator
75−from SQL was overly complex. There was a proliferation of subquery
76−functions to handle different comparison operators, each with two versions
77−for comparing `ALL` or `ANY` of the query rows. And, most confoundedly,
78−there was no way to support the `EXISTS` subquery because the "outer scope"
79−for a query was not available.
80−
81−Squeal adds an outer scope to the `Query` type.
82−
83−```Haskell
84−newtype Query
85− (outer :: FromType)
86− (commons :: FromType)
87− (schemas :: SchemasType)
88− (params :: [NullityType])
89− (row :: RowType)
90− = UnsafeQuery { renderQuery :: ByteString }
91−```
92−
93−This enables a well-typed `exists` function.
94−
95−```Haskell
96−exists
97− :: Query (Join outer from) commons schemas params row
98− -> Condition outer commons grp schemas params from
99−```
100−
101−The `in_` and `notIn` functions were simplified to handle the most
102−common use case of comparing to a list of values.
103−
104−```Haskell
105−in_
106− :: Expression outer commons grp schemas params from ty -- ^ expression
107− -> [Expression outer commons grp schemas params from ty]
108− -> Condition outer commons grp schemas params from
109−```
110−
111−Finally, general subquery comparisons were abstracted to work with
112−any comparison operators, using the `Operator` type which will be discussed in
113−the next section.
114−
115−```Haskell
116−subAll
117− :: Expression outer commons grp schemas params from ty1
118− -> Operator ty1 ty2 ('Null 'PGbool)
119− -> Query (Join outer from) commons schemas params '[col ::: ty2]
120− -> Condition outer commons grp schemas params from
121−
122−subAny
123− :: Expression outer commons grp schemas params from ty1
124− -> Operator ty1 ty2 ('Null 'PGbool)
125− -> Query (Join outer from) commons schemas params '[col ::: ty2]
126− -> Condition outer commons grp schemas params from
127−```
128−
129−**Expression RankNTypes**
130−
131−Squeal 0.5 introduces RankNType type synonyms for common expression patterns.
132−The simplest example is the `Expr` type, a type for "closed" expressions
133−that cannot reference any aliases or parameters.
134−
135−```Haskell
136−type Expr x
137− = forall outer commons grp schemas params from
138− . Expression outer commons grp schemas params from x
139−```
140−
141−There is also a function type `(-->)`, which is a subtype of the usual Haskell function
142−type `(->)`.
143−
144−```Haskell
145−type (-->) x y
146− = forall outer commons grp schemas params from
147− . Expression outer commons grp schemas params from x
148− -> Expression outer commons grp schemas params from y
149−```
150−
151−We saw in the subquery section that there is an `Operator` type.
152−
153−```Haskell
154−type Operator x1 x2 y
155− = forall outer commons grp schemas params from
156− . Expression outer commons grp schemas params from x1
157− -> Expression outer commons grp schemas params from x2
158− -> Expression outer commons grp schemas params from y
159−```
160−
161−There are also types `FunctionN` and `FunctionVar` for n-ary functions
162−and variadic functions.
163−
164−```
165−type FunctionN xs y
166− = forall outer commons grp schemas params from
167− . NP (Expression outer commons grp schemas params from) xs
168− -> Expression outer commons grp schemas params from y
169−```
170−
171−An n-ary function takes an `NP` list of `Expression`s as its argument.
172−Squeal 0.5 adds a helpful operator `(*:)`, to help scrap your `Nil`s.
173−You can construct an `NP` list now by using the operator `(:*)`,
174−until your last element, using `(*:)` there. For instance, the function
175−`atan2_` takes two arguments, `atan2_ (pi *: 2)`.
176−
177−**Selections**
178−
179−Previously, Squeal provided a couple versions of `SELECT` depending
180−on whether you wanted to select all columns of a unique table
181−in the from clause, i.e. `*`, all columns of a particular table
182−in the from clause, i.e. `.*`, or a list of columns from the from clause.
183−
184−Squeal 0.5 refactors this pattern into a `Selection` GADT type, allowing
185−for abstraction and combinations that were not possible before.
186−
187−```Haskell
188−data Selection outer commons grp schemas params from row where
189− Star
190− :: HasUnique tab from row
191− => Selection outer commons 'Ungrouped schemas params from row
192− DotStar
193− :: Has tab from row
194− => Alias tab
195− -> Selection outer commons 'Ungrouped schemas params from row
196− List
197− :: SListI row
198− => NP (Aliased (Expression outer commons grp schemas params from)) row
199− -> Selection outer commons grp schemas params from row
200− Over
201− :: SListI row
202− => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
203− -> WindowDefinition outer commons grp schemas params from
204− -> Selection outer commons grp schemas params from row
205− Also
206− :: Selection outer commons grp schemas params from right
207− -> Selection outer commons grp schemas params from left
208− -> Selection outer commons grp schemas params from (Join left right)
209−```
210−
211−In addition to the `Star`, `DotStar` and `List` constructors, there is an
212−`Also` constructor combinator, which enables users to combine `Selection`s.
213−Additionally, there is an `Over` constructor that is used to enable
214−window functions, described in the next section.
215−
216−To upgrade from Squeal 0.4, you will replace `selectStar` with `select Star`,
217−replace `selectDotStar #tab` with `select (DotStar #tab)`. The `List`
218−selection is such a common use case that there is a function `select_` which
219−automatically applies it, so to upgrade from Squeal 0.4, replace `select`
220−with `select_`. There are also independent `selectDistinct` and `selectDistinct_`
221−functions to filter out duplicate rows.
222−
223−**Query clauses**
224−
225−Previously, Squeal provided a couple versions of `INSERT` depending
226−on whether you wanted to insert `VALUES` or a query.
227−
228−Squeal 0.5 refactors this pattern into a `QueryClause` GADT.
229−
230−```
231−-- Squeal 0.4
232−insertRow_ #tab (Set 2 `as` #col1 :* Default `as` #col2)
233−insertQuery_ #tab (selectStar (from (table #other_tab)))
234−
235−-- Squeal 0.5
236−insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))
237−insertInto_ #tab (Subquery (select Star (from (table #other_tab))))
238−```
239−
240−**Window functions and aggregation**
241−
242−Previous versions of Squeal provided no support for window functions.
243−Squeal 0.5 adds support for window functions. We saw `Over` in the
244−previous section.
245−
246−```Haskell
247−Over
248− :: SListI row
249− => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
250− -> WindowDefinition outer commons grp schemas params from
251− -> Selection outer commons grp schemas params from row
252−```
253−
254−`Over` combines window functions with window definitions. A `WindowDefinition`
255−is constructed using the `partitionBy` function, optionally with an `orderBy`
256−clause. For example,
257−
258−```Haskell
259−query :: Query_ (Public Schema) () (Row Int32 Int32)
260−query = select
261− (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
262− (from (table #tab))
263−```
264−
265−Here the `rank` function is a `WindowFunction`
266−
267−```Haskell
268−rank :: WinFun0 ('NotNull 'PGint8)
269−rank = UnsafeWindowFunction "rank()"
270−```
271−
272−`WinFun0` is a RankNType, like `Expr` was, used for no argument window functions.
273−Similarly, there are also `WinFun1` and `WinFunN` types for
274−window functions and n-ary window functions.
275−
276−In order to use the same syntax for certain window functions and aggregate functions,
277−a new typeclass `Aggregate` was introduced. So for instance, `sum_` can be
278−either a `Distinction` `Expression` or a `WindowFunction`, used either with
279−a `groupBy` or with a `partitionBy` in the appropriate way.
280−
281−```
282−data Distinction (expr :: kind -> Type) (ty :: kind)
283− = All (expr ty)
284− | Distinct (expr ty)
285−```
286−
287−Aggregate functions can be run over all rows or only over distinct rows,
288−while window functions bear no such distinction.
289−
290−**Migrations**
291−
292−Thanks to [https://github.com/Raveline](Raveline) Squeal 0.5 introduces
293−a function `defaultMain` to easily create a command line program to
294−run or rewind your migrations.
295−
296−Previously, Squeal's migrations were impure, allowing in addition to
297−running `Definition`s to run arbitrary `IO` operations, such as inserting
298−data into the database or printing out status messages. In order to
299−provide compatibility with other migration systems, Squeal 0.5 introduces
300−pure migrations, that is migrations that are only `Definition`s.
301−
302−```Haskell
303−data Migration p schemas0 schemas1 = Migration
304− { name :: Text -- ^ The `name` of a `Migration`.
305− -- Each `name` in a `Migration` should be unique.
306− , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.
307− , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.
308− } deriving (GHC.Generic)
309−```
310−
311−A pure migration is a `Migration Definition`, a pair of inverse
312−`Definition`s with a unique name. To recover impure migrations, Squeal 0.5
313−introduces the `Terminally` type.
314−
315−```Haskell
316−newtype Terminally trans monad x0 x1 = Terminally
317− { runTerminally :: trans x0 x1 monad () }
318−```
319−
320−`Terminally` applies the indexed monad transformer and the monad it transforms
321−to the unit type `()`, thereby turning an indexed monad into a `Category`. An
322−impure migration is a `Migration (Terminally PQ IO)`. You can always cast
323−a pure migration into an impure migration with the functor, `pureMigration`.
324−
325−```Haskell
326−pureMigration
327− :: Migration Definition schemas0 schemas1
328− -> Migration (Terminally PQ IO) schemas0 schemas1
329−```
330−
331−To run either pure or impure migrations, Squeal 0.5 introduces
332−a typeclass, `Migratory`.
333−
334−```
335−class Category p => Migratory p where
336−
337− migrateUp
338− :: AlignedList (Migration p) schemas0 schemas1
339− -> PQ schemas0 schemas1 IO ()
340−
341− migrateDown
342− :: AlignedList (Migration p) schemas0 schemas1
343− -> PQ schemas1 schemas0 IO ()
344−```
345−
346−The signatures of `migrateUp` and `migrateDown` have been changed
347−to make them easier to compose with other `PQ` actions.
348−
349−**Transactions**
350−
351−You can now run transactions `ephemerally`, guaranteed to roll back,
352−but return the result or throw the exception that the transaction
353−would have generated. This is useful for testing. You can also
354−`transactionallyRetry` computations, retrying the transaction if
355−a [serialization failure](https://www.postgresql.org/docs/11/transaction-iso.html#XACT-REPEATABLE-READ) occurs.
356−
357−**Types**
358−
359−Squeal now supports money via a `Money` Haskell `Type` and a `'PGmoney`
360−`PGType`. Squeal 0.5 also adds support for creating domain types
361−with `createDomain`.
362−
363−**Time**
364−
365−Squeal 0.5 adds support for new functions; `now`, `makeDate`, `makeTime`,
366−, `makeTimestamp`, and `makeTimestamptz`, a function `interval_` for
367−constructing time intervals out multiples of `TimeUnit`s, and a new
368−`TimeOp` class, defining affine space operators for time types and their
369−differences.
370−
371−**Literals**
372−
373−Squeal allows you to include Haskell values in your statements using
374−out of line `parameter`s, but often you want to include them inline,
375−as a SQL `literal`. Squeal 0.5 enables this using the `Literal` class.
376−
377−**Set returning functions**
378−
379−Squeal 0.5 adds support for set returning functions such as `unnest`,
380−with the `RankNType` `SetOfFunction`, which can be used as as a `FromClause`.
381−
382−**Text search**
383−
384−Squeal 0.5 adds extensive support for text search types, functions and operators.
385−
386−**Much more**
387−
388−Lots more changes went into and under the hood of the new version.
389−The `Expression` module was split into coherent submodules since it
390−had grown to immense proportions. New modules `Alias`, `PG` and `List`
391−were added to relieve some of the burden that the `Schema` module
392−had been carrying. Rendering has been better unified with a new
393−`RenderSQL` typeclass. Type level list concatenation with the `Additional`
394−typeclass has been added. `Manipulation`s `update` and `delete`
395−were upgraded, so you can leave out fields you don't want to update and
396−use `USING` clauses in deletes. Upserts which were previously broken
397−now work. The `IO` typeclass hierarchy was changed from `MonadBase`
398−and `MonadBaseControl` to `MonadIO` and `MonadUnliftIO`. A new
399−`withRecursive` `Manipulation` was added. `SquealException`s were
400−refactored and a `trySqueal` function added. Arrays were refactored.
401−And there was probably more I've forgotten.
402−
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
3+### Version 0.2 - March 24, 2018
10874
10885**Changes**
10896- **Constraints** - Type level table constraints like primary and foreign keys and column constraints like having `DEFAULT`.
scrap-your-nils.mddeleted−60
@@ -1,60 +0,0 @@
1−## Scrap your Nils
2−
3−One of the most useful types I've come across in Haskell is the type of
4−"heterogeneous lists". This is the same as the [Rec](http://hackage.haskell.org/package/vinyl-0.8.1.1/docs/Data-Vinyl-Core.html)
5−datatype from the [vinyl](http://hackage.haskell.org/package/vinyl) library.
6−It's also the same as the [NP](http://hackage.haskell.org/package/generics-sop-0.3.2.0/docs/Generics-SOP-NP.html)
7−datatype from the [generics-sop](http://hackage.haskell.org/package/generics-sop) library.
8−Squeal makes heavy use of this type.
9−
10−```Haskell
11−>>> import Generics.SOP (NP(..))
12−>>> :i NP
13−type role NP representational nominal
14−data NP (a :: k -> *) (b :: [k]) where
15− Nil :: forall k (a :: k -> *). NP a '[]
16− (:*) :: forall k (a :: k -> *) (x :: k) (xs :: [k]).
17− (a x) -> (NP a xs) -> NP a (x : xs)
18− -- Defined in ‘Generics.SOP.NP’
19−```
20−
21−This type allows us to construct "product" types, where the types of the individual
22−"terms" are hosted at the type level.
23−
24−```Haskell
25−>>> :set -XDataKinds
26−>>> import Generics.SOP (I(..))
27−>>> let example = I "foo" :* I pi :* Nil :: NP I '[String, Double]
28−>>> example
29−I "foo" :* I 3.141592653589793 :* Nil
30−```
31−
32−One thing Squeal uses `NP` for is to form lists of aliases,
33−using GHC's `OverloadedLabels` extension, hosting the names
34−of the aliases themselves at the type level.
35−
36−```Haskell
37−>>> :set -XKindSignatures -XOverloadedLabels -XFlexibleInstances -XMultiParamTypeClasses
38−>>> import GHC.TypeLits
39−>>> import GHC.OverloadedLabels
40−>>> data Alias (alias :: Symbol) = Alias deriving (Eq,Ord,Show)
41−>>> instance IsLabel label (Alias label) where fromLabel = Alias
42−>>> let aliases = #foo :* #bar :* Nil :: NP Alias '["foo", "bar"]
43−```
44−
45−However, it's very ugly to have to end every list with `:* Nil`.
46−When I announced the release of Squeal, people rightly [complained](https://www.reddit.com/r/haskell/comments/6yr5v6/announcing_squeal_a_deep_embedding_of_sql_in/dmq8vvn)
47−about the syntactic noise. Luckily, there's a neat trick we can use to get rid of it.
48−Making an `IsLabel` instance not only for elements of our list
49−but also for lists of length 1, we can ask GHC to interpret
50−the last label as a list.
51−
52−```Haskell
53−>>> instance IsLabel label (NP Alias '[label]) where fromLabel = Alias :* Nil
54−>>> let aliases' = #foo :* #bar :: NP Alias '["foo", "bar"]
55−```
56−
57−Version 0.3.1 of Squeal enables the "Scrap your Nils" trick for
58−heterogeneous lists of `Alias`es, `Aliased` expressions, `PGlabel`s and `By`s
59−with the typeclasses `IsLabel`, `IsQualified`, `IsPGlabel`,
60−and the new `Aliasable` typeclass, to eliminate all need of using `Nil` in a list.
squeal-postgresql/README.md+219−1
@@ -1,4 +1,4 @@
1−# squeal-postgresql
1+# squeal
22
33![squeal-icon](http://www.emoticonswallpapers.com/emotion/cute-big-pig/cute-pig-smiley-046.gif)
44
@@ -9,3 +9,221 @@
99[Hackage](https://hackage.haskell.org/package/squeal-postgresql)
1010
1111[Stackage](https://www.stackage.org/package/squeal-postgresql)
12+
13+## installation
14+
15+`stack install squeal-postgresql`
16+
17+## usage
18+
19+Squeal is a deep embedding of PostgreSQL in Haskell. Let's see an example!
20+First, we need some language extensions because Squeal uses modern GHC
21+features.
22+```haskell
23+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
24+>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators
25+```
26+
27+We'll need some imports.
28+
29+```haskell
30+>>> import Control.Monad (void)
31+>>> import Control.Monad.Base (liftBase)
32+>>> import Data.Int (Int32)
33+>>> import Data.Text (Text)
34+>>> import Squeal.PostgreSQL
35+```
36+
37+We'll use generics to easily convert between Haskell and PostgreSQL values.
38+
39+```haskell
40+>>> import qualified Generics.SOP as SOP
41+>>> import qualified GHC.Generics as GHC
42+```
43+
44+The first step is to define the schema of our database. This is where
45+we use `DataKinds` and `TypeOperators`. The schema consists of a type-level
46+list of tables, a `:::` pairing of a type level string or
47+`Symbol` and a list a columns, itself a `:::` pairing of a
48+`Symbol` and a `ColumnType`. The `ColumnType` describes the
49+PostgreSQL type of the column as well as whether or not it may contain
50+`NULL` and whether or not inserts and updates can use a `DEFAULT`. For our
51+schema, we'll define two tables, a users table and an emails table.
52+
53+```haskell
54+>>> :{
55+type Schema =
56+ '[ "users" :::
57+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
58+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
59+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
60+ ]
61+ , "emails" :::
62+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
63+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
64+ ] :=>
65+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
66+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
67+ , "email" ::: 'NoDef :=> 'Null 'PGtext
68+ ]
69+ ]
70+:}
71+```
72+
73+Next, we'll write `Definition`s to set up and tear down the schema. In
74+Squeal, a `Definition` is a `createTable`, `alterTable` or `dropTable`
75+command and has two type parameters, corresponding to the schema
76+before being run and the schema after. We can compose definitions using
77+`>>>`. Here and in the rest of our commands we make use of overloaded
78+labels to refer to named tables and columns in our schema.
79+
80+```haskell
81+>>> :{
82+let
83+ setup :: Definition '[] Schema
84+ setup =
85+ createTable #users
86+ ( serial `As` #id :*
87+ (text & notNull) `As` #name :* Nil )
88+ ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>>
89+ createTable #emails
90+ ( serial `As` #id :*
91+ (int & notNull) `As` #user_id :*
92+ text `As` #email :* Nil )
93+ ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
94+ foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
95+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
96+:}
97+```
98+
99+We can easily see the generated SQL is unsuprising looking.
100+
101+```haskell
102+>>> renderDefinition setup
103+"CREATE TABLE users (id serial, name text NOT NULL, CONSTRAINT pk_users PRIMARY KEY (id)); CREATE TABLE emails (id serial, user_id int NOT NULL, email text, CONSTRAINT pk_emails PRIMARY KEY (id), CONSTRAINT fk_user_id FOREIGN KEY (user_id) REFERENCES rs (id) ON DELETE CASCADE ON UPDATE CASCADE);"
104+```
105+
106+Notice that `setup` starts with an empty schema `'[]` and produces `Schema`.
107+In our `createTable` commands we included `TableConstraint`s to define
108+primary and foreign keys, making them somewhat complex. Our tear down
109+`Definition` is simpler.
110+
111+```haskell
112+>>> :{
113+let
114+ teardown :: Definition Schema '[]
115+ teardown = dropTable #emails >>> dropTable #users
116+:}
117+>>> renderDefinition teardown
118+"DROP TABLE emails; DROP TABLE users;"
119+```
120+
121+Next, we'll write `Manipulation`s to insert data into our two tables.
122+A `Manipulation` is a `insertInto`, `update` or `deleteFrom` command and
123+has three type parameters, the schema it refers to, a list of parameters
124+it can take as input, and a list of columns it produces as output. When
125+we insert into the users table, we will need a parameter for the `name`
126+field but not for the `id` field. Since it's optional, we can use a default
127+value. However, since the emails table refers to the users table, we will
128+need to retrieve the user id that the insert generates and insert it into
129+the emails table. Take a careful look at the type and definition of both
130+of our inserts.
131+
132+```haskell
133+>>> :{
134+let
135+ insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ]
136+ '[ "fromOnly" ::: 'NotNull 'PGint4 ]
137+ insertUser = insertRow #users
138+ (Default `As` #id :* Set (param `1) `As` #name :* Nil)
139+ OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
140+:}
141+>>> :{
142+let
143+ insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
144+ insertEmail = insertRow #emails
145+ ( Default `As` #id :*
146+ Set (param `1) `As` #user_id :*
147+ Set (param `2) `As` #email :* Nil )
148+ OnConflictDoNothing (Returning Nil)
149+:}
150+>>> renderManipulation insertUser
151+"INSERT INTO users (id, name) VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING URNING id AS fromOnly;"
152+>>> renderManipulation insertEmail
153+"INSERT INTO emails (id, user_id, email) VALUES (DEFAULT, ($1 :: int4), ($2 :: text)N CONFLICT DO NOTHING;"
154+```
155+
156+Next we write a `Query` to retrieve users from the database. We're not
157+interested in the ids here, just the usernames and email addresses. We
158+need to use an inner join to get the right result. A `Query` is like a
159+`Manipulation` with the same kind of type parameters.
160+
161+```haskell
162+>>> :{
163+let
164+ getUsers :: Query Schema '[]
165+ '[ "userName" ::: 'NotNull 'PGtext
166+ , "userEmail" ::: 'Null 'PGtext ]
167+ getUsers = select
168+ (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)
169+ ( from (table (#users `As` #u)
170+ & innerJoin (table (#emails `As` #e))
171+ (#u ! #id .== #e ! #user_id)) )
172+:}
173+>>> renderQuery getUsers
174+"SELECT u.name AS userName, e.email AS userEmail FROM users AS u INNER JOIN emails e ON (u.id = e.user_id)"
175+```
176+Now that we've defined the SQL side of things, we'll need a Haskell type
177+for users. We give the type `Generics.SOP.Generic` and
178+`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows
179+we receive when we run `getUsers`. Notice that the record fields of the
180+`User` type match the column names of `getUsers`.
181+
182+```haskell
183+>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, .Generic)
184+>>> instance SOP.Generic User
185+>>> instance SOP.HasDatatypeInfo User
186+```
187+
188+Let's also create some users to add to the database.
189+
190+```haskell
191+>>> :{
192+let
193+ users :: [User]
194+ users =
195+ [ User "Alice" (Just "alice`gmail.com")
196+ , User "Bob" Nothing
197+ , User "Carole" (Just "carole`hotmail.com")
198+ ]
199+:}
200+```
201+
202+Now we can put together all the pieces into a program. The program
203+connects to the database, sets up the schema, inserts the user data
204+(using prepared statements as an optimization), queries the user
205+data and prints it out and finally closes the connection. We can thread
206+the changing schema information through by using the indexed `PQ` monad
207+transformer and when the schema doesn't change we can use `Monad` and
208+`MonadPQ` functionality.
209+
210+```haskell
211+>>> :{
212+let
213+ session :: PQ Schema Schema IO ()
214+ session = do
215+ idResults <- traversePrepared insertUser (Only . userName <$> users)
216+ ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults
217+ traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
218+ usersResult <- runQuery getUsers
219+ usersRows <- getRows usersResult
220+ liftBase $ print (usersRows :: [User])
221+:}
222+>>> :{
223+void . withConnection "host=localhost port=5432 dbname=exampledb" $
224+ define setup
225+ & pqThen session
226+ & thenDefine teardown
227+:}
228+[User {userName = "Alice", userEmail = Just "alice`gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just role`hotmail.com"}]
229+```
squeal-postgresql/exe/Example.hs+54−51
@@ -11,7 +11,8 @@
1111
1212module Main (main, main2) where
1313
14−import Control.Monad.IO.Class (MonadIO (..))
14+import Control.Monad (void)
15+import Control.Monad.Base (liftBase, MonadBase)
1516import Data.Int (Int16, Int32)
1617import Data.Monoid ((<>))
1718import Data.Text (Text)
@@ -24,84 +25,86 @@ import qualified Generics.SOP as SOP
2425import qualified GHC.Generics as GHC
2526
2627type Schema =
27− '[ "users" ::: 'Table (
28+ '[ "users" :::
2829 '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
2930 '[ "id" ::: 'Def :=> 'NotNull 'PGint4
3031 , "name" ::: 'NoDef :=> 'NotNull 'PGtext
31− , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))
32− ])
33− , "emails" ::: 'Table (
32+ , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2)
33+ ]
34+ , "emails" :::
3435 '[ "pk_emails" ::: 'PrimaryKey '["id"]
3536 , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
3637 ] :=>
3738 '[ "id" ::: 'Def :=> 'NotNull 'PGint4
3839 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
3940 , "email" ::: 'NoDef :=> 'Null 'PGtext
40− ])
41− , "positive" ::: 'Typedef 'PGfloat4
41+ ]
4242 ]
4343
44−type Schemas = Public Schema
45−
46−setup :: Definition (Public '[]) Schemas
47−setup =
44+setup :: Definition '[] Schema
45+setup =
4846 createTable #users
49− ( serial `as` #id :*
50− (text & notNullable) `as` #name :*
51− (vararray int2 & notNullable) `as` #vec )
52− ( primaryKey #id `as` #pk_users )
47+ ( serial `As` #id :*
48+ (text & notNull) `As` #name :*
49+ (vararray int2 & notNull) `As` #vec :* Nil )
50+ ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil )
5351 >>>
5452 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))
53+ ( serial `As` #id :*
54+ (int & notNull) `As` #user_id :*
55+ text `As` #email :* Nil )
56+ ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
57+ foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
58+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
59+
60+teardown :: Definition Schema '[]
61+teardown = dropTable #emails >>> dropTable #users
62+
63+insertUser :: Manipulation Schema '[ 'NotNull 'PGtext, 'NotNull ('PGvararray 'PGint2)]
64+ '[ "fromOnly" ::: 'NotNull 'PGint4 ]
65+insertUser = insertRows #users
66+ (Default `As` #id :* Set (param @1) `As` #name :* Set (param @2) `As` #vec :* Nil) []
67+ OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
68+
69+insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
70+insertEmail = insertRows #emails
71+ ( Default `As` #id :*
72+ Set (param @1) `As` #user_id :*
73+ Set (param @2) `As` #email :* Nil ) []
74+ OnConflictDoNothing (Returning Nil)
75+
76+getUsers :: Query Schema '[]
77+ '[ "userName" ::: 'NotNull 'PGtext
78+ , "userEmail" ::: 'Null 'PGtext
79+ , "userVec" ::: 'NotNull ('PGvararray 'PGint2)]
80+getUsers = select
81+ (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* #u ! #vec `As` #userVec :* Nil)
82+ ( from (table (#users `As` #u)
83+ & innerJoin (table (#emails `As` #e))
8184 (#u ! #id .== #e ! #user_id)) )
8285
83−data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: VarArray (Vector (Maybe Int16)) }
86+data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: Vector (Maybe Int16) }
8487 deriving (Show, GHC.Generic)
8588instance SOP.Generic User
8689instance SOP.HasDatatypeInfo User
8790
8891users :: [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])
92+users =
93+ [ User "Alice" (Just "alice@gmail.com") [Nothing, Just 1]
94+ , User "Bob" Nothing [Just 2, Nothing]
95+ , User "Carole" (Just "carole@hotmail.com") [Just 3]
9396 ]
9497
95−session :: (MonadIO pq, MonadPQ Schemas pq) => pq ()
98+session :: (MonadBase IO pq, MonadPQ Schema pq) => pq ()
9699session = do
97− liftIO $ Char8.putStrLn "manipulating"
100+ liftBase $ Char8.putStrLn "manipulating"
98101 idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])
99102 ids <- traverse (fmap fromOnly . getRow 0) idResults
100103 traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
101− liftIO $ Char8.putStrLn "querying"
104+ liftBase $ Char8.putStrLn "querying"
102105 usersResult <- runQuery getUsers
103106 usersRows <- getRows usersResult
104− liftIO $ print (usersRows :: [User])
107+ liftBase $ print (usersRows :: [User])
105108
106109main :: IO ()
107110main = do
@@ -119,7 +122,7 @@ main = do
119122
120123main2 :: IO ()
121124main2 =
122− withConnection "host=localhost port=5432 dbname=exampledb" $
125+ void . withConnection "host=localhost port=5432 dbname=exampledb" $
123126 define setup
124127 & pqThen session
125128 & pqThen (define teardown)
squeal-postgresql/squeal-postgresql.cabal+12−75
@@ -1,5 +1,5 @@
11name: squeal-postgresql
2−version: 0.5.1.0
2+version: 0.2
33synopsis: Squeal PostgreSQL Library
44description: Squeal is a type-safe embedding of PostgreSQL in Haskell
55homepage: https://github.com/morphismtech/squeal
@@ -22,126 +22,63 @@ library
2222 hs-source-dirs: src
2323 exposed-modules:
2424 Squeal.PostgreSQL
25− Squeal.PostgreSQL.Alias
2625 Squeal.PostgreSQL.Binary
2726 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
3527 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
5528 Squeal.PostgreSQL.Manipulation
5629 Squeal.PostgreSQL.Migration
5730 Squeal.PostgreSQL.Pool
58− Squeal.PostgreSQL.PG
5931 Squeal.PostgreSQL.PQ
6032 Squeal.PostgreSQL.Render
6133 Squeal.PostgreSQL.Query
6234 Squeal.PostgreSQL.Schema
6335 Squeal.PostgreSQL.Transaction
6436 default-language: Haskell2010
65− ghc-options: -Wall
37+ ghc-options: -Wall -fprint-explicit-kinds
6638 build-depends:
6739 aeson >= 1.2.4.0
68− , base >= 4.11.1.0 && < 5.0
69− , binary-parser >= 0.5.5
40+ , base >= 4.10.1.0
7041 , bytestring >= 0.10.8.2
71− , bytestring-strict-builder >= 0.4.5
7242 , deepseq >= 1.4.3.0
73− , free-categories >= 0.1.0.0
74− , generics-sop >= 0.3.2.0 && < 0.5.0.0
43+ , generics-sop >= 0.3.2.0
44+ , lifted-base >= 0.2.3.12
7545 , mmorph >= 1.1.1
46+ , monad-control >= 1.0.2.3
7647 , mtl >= 2.2.2
7748 , network-ip >= 0.3.0.2
7849 , postgresql-binary >= 0.12.1
7950 , postgresql-libpq >= 0.9.4.1
80− , records-sop >= 0.1.0.0
8151 , resource-pool >= 0.2.3.2
8252 , scientific >= 0.3.5.3
8353 , text >= 1.2.3.0
8454 , time >= 1.8.0.2
8555 , transformers >= 0.5.2.0
86− , unliftio >= 0.2.10
87− , unliftio-pool >= 0.2.1.0
56+ , transformers-base >= 0.4.4
8857 , uuid-types >= 1.0.3
8958 , vector >= 0.12.0.1
9059
91−test-suite doctest
60+test-suite squeal-postgresql-doctest
9261 default-language: Haskell2010
9362 type: exitcode-stdio-1.0
9463 hs-source-dirs: test
9564 ghc-options: -Wall
96− main-is: Doc.hs
65+ main-is: DocTest.hs
9766 build-depends:
9867 base >= 4.10.0.0
9968 , 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
11669
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
70+executable squeal-postgresql-example
13571 default-language: Haskell2010
13672 hs-source-dirs: exe
13773 ghc-options: -Wall
13874 main-is: Example.hs
13975 build-depends:
140− base >= 4.10.0.0 && < 5.0
76+ base >= 4.10.0.0
14177 , bytestring >= 0.10.8.2
14278 , generics-sop >= 0.3.1.0
14379 , mtl >= 2.2.1
14480 , squeal-postgresql
14581 , text >= 1.2.2.2
14682 , transformers >= 0.5.2.0
83+ , transformers-base >= 0.4.4
14784 , vector >= 0.12.0.1
squeal-postgresql/src/Squeal/PostgreSQL.hs+222−233
@@ -1,233 +1,222 @@
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
1+-- | Module: Squeal.PostgreSQL
2+-- Description: Squeel export module
3+-- Copyright: (c) Eitan Chatav, 2017
4+-- Maintainer: eitan@morphism.tech
5+-- Stability: experimental
6+--
7+-- Squeal is a deep embedding of [PostgreSQL](https://www.postgresql.org) in Haskell.
8+-- Let's see an example!
9+--
10+-- First, we need some language extensions because Squeal uses modern GHC
11+-- features.
12+--
13+-- >>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
14+-- >>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators
15+--
16+-- We'll need some imports.
17+--
18+-- >>> import Control.Monad (void)
19+-- >>> import Control.Monad.Base (liftBase)
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 Schema =
34+-- '[ "users" :::
35+-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
36+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
37+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext
38+-- ]
39+-- , "emails" :::
40+-- '[ "pk_emails" ::: 'PrimaryKey '["id"]
41+-- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
42+-- ] :=>
43+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
44+-- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
45+-- , "email" ::: 'NoDef :=> 'Null 'PGtext
46+-- ]
47+-- ]
48+-- :}
49+--
50+-- Notice the use of type operators. `:::` is used
51+-- to pair an alias `Symbol` with either a `TableType` or a `ColumnType`.
52+-- `:=>` is used to pair a `TableConstraint`s with a `ColumnsType`,
53+-- yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,
54+-- yielding a `ColumnType`.
55+--
56+-- Next, we'll write `Definition`s to set up and tear down the schema. In
57+-- Squeal, a `Definition` is a `createTable`, `alterTable` or `dropTable`
58+-- command and has two type parameters, corresponding to the schema
59+-- before being run and the schema after. We can compose definitions using
60+-- `>>>`. Here and in the rest of our commands we make use of overloaded
61+-- labels to refer to named tables and columns in our schema.
62+--
63+-- >>> :{
64+-- let
65+-- setup :: Definition '[] Schema
66+-- setup =
67+-- createTable #users
68+-- ( serial `As` #id :*
69+-- (text & notNull) `As` #name :* Nil )
70+-- ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>>
71+-- createTable #emails
72+-- ( serial `As` #id :*
73+-- (int & notNull) `As` #user_id :*
74+-- text `As` #email :* Nil )
75+-- ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
76+-- foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
77+-- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
78+-- :}
79+--
80+-- We can easily see the generated SQL is unsuprising looking.
81+--
82+-- >>> renderDefinition setup
83+-- "CREATE TABLE users (id serial, name text NOT NULL, CONSTRAINT pk_users PRIMARY KEY (id)); CREATE TABLE emails (id serial, user_id int NOT NULL, email text, CONSTRAINT pk_emails PRIMARY KEY (id), CONSTRAINT fk_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE CASCADE ON UPDATE CASCADE);"
84+--
85+-- Notice that @setup@ starts with an empty schema @'[]@ and produces @Schema@.
86+-- In our `createTable` commands we included `TableConstraint`s to define
87+-- primary and foreign keys, making them somewhat complex. Our tear down
88+-- `Definition` is simpler.
89+--
90+-- >>> :{
91+-- let
92+-- teardown :: Definition Schema '[]
93+-- teardown = dropTable #emails >>> dropTable #users
94+-- :}
95+--
96+-- >>> renderDefinition teardown
97+-- "DROP TABLE emails; DROP TABLE users;"
98+--
99+-- Next, we'll write `Manipulation`s to insert data into our two tables.
100+-- A `Manipulation` is an `insertRow` (or other inserts), `update`
101+-- or `deleteFrom` command and
102+-- has three type parameters, the schema it refers to, a list of parameters
103+-- it can take as input, and a list of columns it produces as output. When
104+-- we insert into the users table, we will need a parameter for the @name@
105+-- field but not for the @id@ field. Since it's optional, we can use a default
106+-- value. However, since the emails table refers to the users table, we will
107+-- need to retrieve the user id that the insert generates and insert it into
108+-- the emails table. Take a careful look at the type and definition of both
109+-- of our inserts.
110+--
111+-- >>> :{
112+-- let
113+-- insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ]
114+-- insertUser = insertRow #users
115+-- (Default `As` #id :* Set (param @1) `As` #name :* Nil)
116+-- OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
117+-- :}
118+--
119+-- >>> :{
120+-- let
121+-- insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
122+-- insertEmail = insertRow #emails
123+-- ( Default `As` #id :*
124+-- Set (param @1) `As` #user_id :*
125+-- Set (param @2) `As` #email :* Nil )
126+-- OnConflictDoNothing (Returning Nil)
127+-- :}
128+--
129+-- >>> renderManipulation insertUser
130+-- "INSERT INTO users (id, name) VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING id AS fromOnly;"
131+-- >>> renderManipulation insertEmail
132+-- "INSERT INTO emails (id, user_id, email) VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING;"
133+--
134+-- Next we write a `Query` to retrieve users from the database. We're not
135+-- interested in the ids here, just the usernames and email addresses. We
136+-- need to use an inner join to get the right result. A `Query` is like a
137+-- `Manipulation` with the same kind of type parameters.
138+--
139+-- >>> :{
140+-- let
141+-- getUsers :: Query Schema '[]
142+-- '[ "userName" ::: 'NotNull 'PGtext
143+-- , "userEmail" ::: 'Null 'PGtext ]
144+-- getUsers = select
145+-- (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)
146+-- ( from (table (#users `As` #u)
147+-- & innerJoin (table (#emails `As` #e))
148+-- (#u ! #id .== #e ! #user_id)) )
149+-- :}
150+--
151+-- >>> renderQuery getUsers
152+-- "SELECT u.name AS userName, e.email AS userEmail FROM users AS u INNER JOIN emails AS e ON (u.id = e.user_id)"
153+--
154+-- Now that we've defined the SQL side of things, we'll need a Haskell type
155+-- for users. We give the type `Generics.SOP.Generic` and
156+-- `Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows
157+-- we receive when we run @getUsers@. Notice that the record fields of the
158+-- @User@ type match the column names of @getUsers@.
159+--
160+-- >>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
161+-- >>> instance SOP.Generic User
162+-- >>> instance SOP.HasDatatypeInfo User
163+--
164+-- Let's also create some users to add to the database.
165+--
166+-- >>> :{
167+-- let
168+-- users :: [User]
169+-- users =
170+-- [ User "Alice" (Just "alice@gmail.com")
171+-- , User "Bob" Nothing
172+-- , User "Carole" (Just "carole@hotmail.com")
173+-- ]
174+-- :}
175+--
176+-- Now we can put together all the pieces into a program. The program
177+-- connects to the database, sets up the schema, inserts the user data
178+-- (using prepared statements as an optimization), queries the user
179+-- data and prints it out and finally closes the connection. We can thread
180+-- the changing schema information through by using the indexed `PQ` monad
181+-- transformer and when the schema doesn't change we can use `Monad` and
182+-- `MonadPQ` functionality.
183+--
184+-- >>> :{
185+-- let
186+-- session :: PQ Schema Schema IO ()
187+-- session = do
188+-- idResults <- traversePrepared insertUser (Only . userName <$> users)
189+-- ids <- traverse (fmap fromOnly . getRow 0) idResults
190+-- traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
191+-- usersResult <- runQuery getUsers
192+-- usersRows <- getRows usersResult
193+-- liftBase $ print (usersRows :: [User])
194+-- :}
195+--
196+-- >>> :{
197+-- void . withConnection "host=localhost port=5432 dbname=exampledb" $
198+-- define setup
199+-- & pqThen session
200+-- & pqThen (define teardown)
201+-- :}
202+-- [User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
203+
204+module Squeal.PostgreSQL
205+ ( module Squeal.PostgreSQL.Binary
206+ , module Squeal.PostgreSQL.Definition
207+ , module Squeal.PostgreSQL.Expression
208+ , module Squeal.PostgreSQL.Manipulation
209+ , module Squeal.PostgreSQL.PQ
210+ , module Squeal.PostgreSQL.Query
211+ , module Squeal.PostgreSQL.Schema
212+ , module Squeal.PostgreSQL.Transaction
213+ ) where
214+
215+import Squeal.PostgreSQL.Binary
216+import Squeal.PostgreSQL.Definition
217+import Squeal.PostgreSQL.Expression
218+import Squeal.PostgreSQL.Manipulation
219+import Squeal.PostgreSQL.PQ
220+import Squeal.PostgreSQL.Query
221+import Squeal.PostgreSQL.Schema
222+import Squeal.PostgreSQL.Transaction
squeal-postgresql/src/Squeal/PostgreSQL/Alias.hsdeleted−249
@@ -1,249 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Alias
3−Description: Aliases
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−This module embeds Postgres's alias system in Haskell in
9−a typesafe fashion. Thanks to GHC's @OverloadedLabels@ extension,
10−Squeal can reference aliases by prepending with a @#@.
11−-}
12−
13−{-# LANGUAGE
14− AllowAmbiguousTypes
15− , ConstraintKinds
16− , DeriveAnyClass
17− , DeriveGeneric
18− , FlexibleContexts
19− , FlexibleInstances
20− , FunctionalDependencies
21− , GADTs
22− , LambdaCase
23− , OverloadedStrings
24− , QuantifiedConstraints
25− , RankNTypes
26− , ScopedTypeVariables
27− , StandaloneDeriving
28− , TypeApplications
29− , TypeFamilyDependencies
30− , TypeInType
31− , TypeOperators
32− , UndecidableInstances
33− , UndecidableSuperClasses
34−#-}
35−
36−module Squeal.PostgreSQL.Alias
37− ( (:::)
38− , Alias (..)
39− , IsLabel (..)
40− , Aliased (As)
41− , Aliasable (as)
42− , renderAliased
43− , Has
44− , HasUnique
45− , HasAll
46− , HasIn
47− , QualifiedAlias (..)
48− , IsQualified (..)
49− -- * Grouping
50− , Grouping (..)
51− , GroupedBy
52− ) where
53−
54−import Control.DeepSeq
55−import Data.ByteString (ByteString)
56−import Data.String (fromString)
57−import GHC.OverloadedLabels
58−import GHC.TypeLits
59−
60−import qualified Generics.SOP as SOP
61−import qualified GHC.Generics as GHC
62−
63−import Squeal.PostgreSQL.List
64−import Squeal.PostgreSQL.Render
65−
66−-- $setup
67−-- >>> import Squeal.PostgreSQL
68−
69−-- | The alias operator `:::` is like a promoted version of `As`,
70−-- a type level pair between an alias and some type.
71−type (:::) (alias :: Symbol) ty = '(alias,ty)
72−infixr 6 :::
73−
74−
75−-- | `Grouping` is an auxiliary namespace, created by
76−-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
77−-- for typesafe aggregation
78−data Grouping
79− = Ungrouped -- ^ no aggregation permitted
80− | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped
81−
82−{- | A `GroupedBy` constraint indicates that a table qualified column is
83−a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,
84−may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.
85−-}
86−class (KnownSymbol table, KnownSymbol column)
87− => GroupedBy table column bys where
88−instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
89− => GroupedBy table column ('(table,column) ': bys)
90−instance {-# OVERLAPPABLE #-}
91− ( KnownSymbol table
92− , KnownSymbol column
93− , GroupedBy table column bys
94− ) => GroupedBy table column (tabcol ': bys)
95−
96−-- | `Alias`es are proxies for a type level string or `Symbol`
97−-- and have an `IsLabel` instance so that with @-XOverloadedLabels@
98−--
99−-- >>> :set -XOverloadedLabels
100−-- >>> #foobar :: Alias "foobar"
101−-- Alias
102−data Alias (alias :: Symbol) = Alias
103− deriving (Eq,GHC.Generic,Ord,Show,NFData)
104−instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
105− fromLabel = Alias
106−instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where
107− fromLabel = fromLabel SOP.:* Nil
108−-- | >>> printSQL (#jimbob :: Alias "jimbob")
109−-- "jimbob"
110−instance KnownSymbol alias => RenderSQL (Alias alias) where
111− renderSQL = doubleQuoted . fromString . symbolVal
112−
113−-- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"])
114−-- "jimbob", "kandi"
115−instance SOP.All KnownSymbol aliases => RenderSQL (NP Alias aliases) where
116− renderSQL
117− = commaSeparated
118− . SOP.hcollapse
119− . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderSQL)
120−
121−-- | The `As` operator is used to name an expression. `As` is like a demoted
122−-- version of `:::`.
123−--
124−-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)
125−-- As (Just "hello") Alias
126−data Aliased expression aliased where
127− As
128− :: KnownSymbol alias
129− => expression ty
130− -> Alias alias
131− -> Aliased expression (alias ::: ty)
132−deriving instance Show (expression ty)
133− => Show (Aliased expression (alias ::: ty))
134−deriving instance Eq (expression ty)
135− => Eq (Aliased expression (alias ::: ty))
136−deriving instance Ord (expression ty)
137− => Ord (Aliased expression (alias ::: ty))
138−instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)
139− => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where
140− fromLabel = fromLabel @alias2 `As` fromLabel @alias1
141−
142−-- | The `Aliasable` class provides a way to scrap your `Nil`s
143−-- in an `NP` list of `Aliased` expressions.
144−class KnownSymbol alias => Aliasable alias expression aliased
145− | aliased -> expression
146− , aliased -> alias
147− where as :: expression -> Alias alias -> aliased
148−instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias
149− (expression ty)
150− (Aliased expression aliased)
151− where
152− as = As
153−instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias
154− (expression ty)
155− (NP (Aliased expression) tys)
156− where
157− expression `as` alias = expression `As` alias SOP.:* Nil
158−
159−-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")
160−-- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)
161−-- "Just AS \"an_int\""
162−renderAliased
163− :: (forall ty. expression ty -> ByteString)
164− -> Aliased expression aliased
165− -> ByteString
166−renderAliased render (expression `As` alias) =
167− render expression <> " AS " <> renderSQL alias
168−
169−-- | @HasUnique alias fields field@ is a constraint that proves that
170−-- @fields@ is a singleton of @alias ::: field@.
171−type HasUnique alias fields field = fields ~ '[alias ::: field]
172−
173−-- | @Has alias fields field@ is a constraint that proves that
174−-- @fields@ has a field of @alias ::: field@, inferring @field@
175−-- from @alias@ and @fields@.
176−class KnownSymbol alias =>
177− Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
178− | alias fields -> field where
179−instance {-# OVERLAPPING #-} KnownSymbol alias
180− => Has alias (alias ::: field ': fields) field
181−instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)
182− => Has alias (field' ': fields) field
183−
184−{-| @HasIn fields (alias ::: field)@ is a constraint that proves that
185−@fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to
186−choose which subfields to update.
187−-}
188−class HasIn fields field where
189−instance (Has alias fields field) => HasIn fields (alias ::: field) where
190−
191−-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer
192−-- a list of @subfields@.
193−class
194− ( SOP.All KnownSymbol aliases
195− ) => HasAll
196− (aliases :: [Symbol])
197− (fields :: [(Symbol,kind)])
198− (subfields :: [(Symbol,kind)])
199− | aliases fields -> subfields where
200−instance {-# OVERLAPPING #-} HasAll '[] fields '[]
201−instance {-# OVERLAPPABLE #-}
202− (Has alias fields field, HasAll aliases fields subfields)
203− => HasAll (alias ': aliases) fields (alias ::: field ': subfields)
204−
205−-- | Analagous to `IsLabel`, the constraint
206−-- `IsQualified` defines `!` for a column alias qualified
207−-- by a table alias.
208−class IsQualified table column expression where
209− (!) :: Alias table -> Alias column -> expression
210− infixl 9 !
211−instance IsQualified table column (Alias table, Alias column) where (!) = (,)
212−
213−{-| `QualifiedAlias`es enables multi-schema support by allowing a reference
214−to a `Squeal.PostgreSQL.Schema.Table`, `Squeal.PostgreSQL.Schema.Typedef`
215−or `Squeal.PostgreSQL.Schema.View` to be qualified by their schemas. By default,
216−a qualifier of @public@ is provided.
217−
218−>>> :{
219−let
220− alias1 :: QualifiedAlias "sch" "tab"
221− alias1 = #sch ! #tab
222− alias2 :: QualifiedAlias "public" "vw"
223− alias2 = #vw
224−in printSQL alias1 >> printSQL alias2
225−:}
226−"sch"."tab"
227−"vw"
228−-}
229−data QualifiedAlias (qualifier :: Symbol) (alias :: Symbol) = QualifiedAlias
230− deriving (Eq,GHC.Generic,Ord,Show,NFData)
231−instance (q ~ q', a ~ a') => IsQualified q a (QualifiedAlias q' a') where
232− _!_ = QualifiedAlias
233−instance (q' ~ "public", a ~ a') => IsLabel a (QualifiedAlias q' a') where
234− fromLabel = QualifiedAlias
235−instance (q0 ~ q1, a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
236− IsQualified q0 a0 (Aliased (QualifiedAlias q1) (a1 ::: a2)) where
237− _!_ = QualifiedAlias `As` Alias
238−instance (q ~ "public", a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
239− IsLabel a0 (Aliased (QualifiedAlias q) (a1 ::: a2)) where
240− fromLabel = QualifiedAlias `As` Alias
241−
242−instance (KnownSymbol q, KnownSymbol a)
243− => RenderSQL (QualifiedAlias q a) where
244− renderSQL _ =
245− let
246− qualifier = renderSQL (Alias @q)
247− alias = renderSQL (Alias @a)
248− in
249− if qualifier == "\"public\"" then alias else qualifier <> "." <> alias
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+119−690
@@ -5,192 +5,22 @@ Copyright: (c) Eitan Chatav, 2017
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
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
8+Binary encoding and decoding between Haskell and PostgreSQL types.
1799-}
18010
18111{-# LANGUAGE
182− AllowAmbiguousTypes
12+ ConstraintKinds
13+ , DataKinds
14+ , DefaultSignatures
18315 , DeriveFoldable
18416 , DeriveFunctor
18517 , DeriveGeneric
18618 , DeriveTraversable
187− , DefaultSignatures
18819 , FlexibleContexts
18920 , FlexibleInstances
190− , FunctionalDependencies
19121 , GADTs
19222 , LambdaCase
193− , OverloadedStrings
23+ , KindSignatures
19424 , MultiParamTypeClasses
19525 , ScopedTypeVariables
19626 , TypeApplications
@@ -198,33 +28,22 @@ True
19828 , TypeInType
19929 , TypeOperators
20030 , UndecidableInstances
201− , UndecidableSuperClasses
20231#-}
20332
20433module Squeal.PostgreSQL.Binary
20534 ( -- * Encoding
20635 ToParam (..)
36+ , ToColumnParam (..)
20737 , ToParams (..)
208− , ToNullityParam (..)
209− , ToField (..)
210− , ToFixArray (..)
21138 -- * Decoding
21239 , FromValue (..)
40+ , FromColumnValue (..)
21341 , FromRow (..)
214− , FromField (..)
215− , FromFixArray (..)
21642 -- * Only
21743 , Only (..)
218− -- * Oid
219− , OidOf (..)
220− , OidOfParam (..)
221− , OidOfField (..)
22244 ) where
22345
224−import BinaryParser
225−import ByteString.StrictBuilder (builderLength, int32BE, int64BE, word32BE)
226−import Control.Arrow (left)
227−import Control.Monad
46+import Data.Aeson hiding (Null)
22847import Data.Int
22948import Data.Kind
23049import Data.Scientific
@@ -232,28 +51,19 @@ import Data.Time
23251import Data.UUID.Types
23352import Data.Vector (Vector)
23453import Data.Word
235−import Foreign.C.Types (CUInt(CUInt))
23654import Generics.SOP
237−import Generics.SOP.Record
23855import GHC.TypeLits
23956import Network.IP.Addr
24057
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
58+import qualified Data.ByteString.Lazy as Lazy
59+import qualified Data.ByteString as Strict hiding (unpack)
60+import qualified Data.Text.Lazy as Lazy
61+import qualified Data.Text as Strict
24862import qualified Data.Vector as Vector
249−import qualified Database.PostgreSQL.LibPQ as LibPQ
25063import qualified GHC.Generics as GHC
25164import qualified PostgreSQL.Binary.Decoding as Decoding
25265import qualified PostgreSQL.Binary.Encoding as Encoding
25366
254−import Squeal.PostgreSQL.Alias
255−import Squeal.PostgreSQL.List
256−import Squeal.PostgreSQL.PG
25767import Squeal.PostgreSQL.Schema
25868
25969-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into
@@ -277,20 +87,19 @@ class ToParam (x :: Type) (pg :: PGType) where
27787 toParam :: x -> K Encoding.Encoding pg
27888instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
27989instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
90+instance ToParam Word16 'PGint2 where toParam = K . Encoding.int2_word16
28091instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
92+instance ToParam Word32 'PGint4 where toParam = K . Encoding.int4_word32
28193instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
282−instance ToParam Oid 'PGoid where toParam = K . Encoding.int4_word32 . getOid
94+instance ToParam Word64 'PGint8 where toParam = K . Encoding.int8_word64
28395instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
28496instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
28597instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
286−instance ToParam Money 'PGmoney where toParam = K . Encoding.int8_int64 . cents
28798instance ToParam UUID 'PGuuid where toParam = K . Encoding.uuid
28899instance ToParam (NetAddr IP) 'PGinet where toParam = K . Encoding.inet
289100instance ToParam Char ('PGchar 1) where toParam = K . Encoding.char_utf8
290101instance ToParam Strict.Text 'PGtext where toParam = K . Encoding.text_strict
291102instance 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
294103instance ToParam Strict.ByteString 'PGbytea where
295104 toParam = K . Encoding.bytea_strict
296105instance ToParam Lazy.ByteString 'PGbytea where
@@ -304,256 +113,34 @@ instance ToParam LocalTime 'PGtimestamp where
304113instance ToParam UTCTime 'PGtimestamptz where
305114 toParam = K . Encoding.timestamptz_int
306115instance 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
116+instance ToParam Value 'PGjson where toParam = K . Encoding.json_ast
117+instance ToParam Value 'PGjsonb where toParam = K . Encoding.jsonb_ast
118+instance (HasOid pg, ToParam x pg)
119+ => ToParam (Vector (Maybe x)) ('PGvararray pg) where
120+ toParam = K . Encoding.nullableArray_vector
121+ (oid @pg) (unK . toParam @x @pg)
122+
123+-- | A `ToColumnParam` constraint lifts the `ToParam` encoding
124+-- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should
125+-- not define instances of `ToColumnParam`, just use the provided instances.
126+class ToColumnParam (x :: Type) (ty :: NullityType) where
127+ -- | >>> toColumnParam @Int16 @('NotNull 'PGint2) 0
128+ -- K (Just "\NUL\NUL")
129+ --
130+ -- >>> toColumnParam @(Maybe Int16) @('Null 'PGint2) (Just 0)
131+ -- K (Just "\NUL\NUL")
132+ --
133+ -- >>> toColumnParam @(Maybe Int16) @('Null 'PGint2) Nothing
134+ -- K Nothing
135+ toColumnParam :: x -> K (Maybe Strict.ByteString) ty
136+instance ToParam x pg => ToColumnParam x ('NotNull pg) where
137+ toColumnParam = K . Just . Encoding.encodingBytes . unK . toParam @x @pg
138+instance ToParam x pg => ToColumnParam (Maybe x) ('Null pg) where
139+ toColumnParam = K . fmap (Encoding.encodingBytes . unK . toParam @x @pg)
553140
554141-- | A `ToParams` constraint generically sequences the encodings of `Type`s
555142-- 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
143+-- not define instances of `ToParams`. Instead define `Generic` instances
557144-- which in turn provide `ToParams` instances.
558145class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where
559146 -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2]
@@ -565,257 +152,115 @@ class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where
565152 -- >>> instance Generic Tuple
566153 -- >>> toParams @Tuple @Params (Tuple False (Just 0))
567154 -- 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)
155+ toParams :: x -> NP (K (Maybe Strict.ByteString)) tys
156+instance (SListI tys, IsProductType x xs, AllZip ToColumnParam xs tys)
570157 => ToParams x tys where
571158 toParams
572− = htrans (Proxy @ToNullityParam) (toNullityParam . unI)
159+ = htrans (Proxy @ToColumnParam) (toColumnParam . unI)
573160 . unZ . unSOP . from
574161
575162-- | A `FromValue` constraint gives a parser from the binary format of
576163-- a PostgreSQL `PGType` into a Haskell `Type`.
577164class FromValue (pg :: PGType) (y :: Type) where
578165 -- | >>> 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
166+ -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue
167+ fromValue :: proxy pg -> Decoding.Value y
168+instance FromValue 'PGbool Bool where fromValue _ = Decoding.bool
169+instance FromValue 'PGint2 Int16 where fromValue _ = Decoding.int
170+instance FromValue 'PGint4 Int32 where fromValue _ = Decoding.int
171+instance FromValue 'PGint8 Int64 where fromValue _ = Decoding.int
172+instance FromValue 'PGfloat4 Float where fromValue _ = Decoding.float4
173+instance FromValue 'PGfloat8 Double where fromValue _ = Decoding.float8
174+instance FromValue 'PGnumeric Scientific where fromValue _ = Decoding.numeric
175+instance FromValue 'PGuuid UUID where fromValue _ = Decoding.uuid
176+instance FromValue 'PGinet (NetAddr IP) where fromValue _ = Decoding.inet
177+instance FromValue ('PGchar 1) Char where fromValue _ = Decoding.char
178+instance FromValue 'PGtext Strict.Text where fromValue _ = Decoding.text_strict
179+instance FromValue 'PGtext Lazy.Text where fromValue _ = Decoding.text_lazy
597180instance FromValue 'PGbytea Strict.ByteString where
598− fromValue = Decoding.bytea_strict
181+ fromValue _ = Decoding.bytea_strict
599182instance 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
183+ fromValue _ = Decoding.bytea_lazy
184+instance FromValue 'PGdate Day where fromValue _ = Decoding.date
185+instance FromValue 'PGtime TimeOfDay where fromValue _ = Decoding.time_int
603186instance FromValue 'PGtimetz (TimeOfDay, TimeZone) where
604− fromValue = Decoding.timetz_int
187+ fromValue _ = Decoding.timetz_int
605188instance FromValue 'PGtimestamp LocalTime where
606− fromValue = Decoding.timestamp_int
189+ fromValue _ = Decoding.timestamp_int
607190instance FromValue 'PGtimestamptz UTCTime where
608− fromValue = Decoding.timestamptz_int
191+ fromValue _ = Decoding.timestamptz_int
609192instance 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`,
193+ fromValue _ = Decoding.interval_int
194+instance FromValue 'PGjson Value where fromValue _ = Decoding.json_ast
195+instance FromValue 'PGjsonb Value where fromValue _ = Decoding.jsonb_ast
196+instance FromValue pg y => FromValue ('PGvararray pg) (Vector (Maybe y)) where
197+ fromValue _ = Decoding.array
198+ (Decoding.dimensionArray Vector.replicateM
199+ (Decoding.nullableValueArray (fromValue (Proxy @pg))))
200+instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where
201+ fromValue _ = Decoding.array
202+ (Decoding.dimensionArray Vector.replicateM
203+ (Decoding.nullableValueArray (fromValue (Proxy @pg))))
204+
205+-- | A `FromColumnValue` constraint lifts the `FromValue` parser
206+-- to a decoding of a @(Symbol, ColumnType)@ to a `Type`,
705207-- 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
208+-- `FromColumnValue`, just use the provided instances.
209+class FromColumnValue (colty :: (Symbol,NullityType)) (y :: Type) where
210+ -- | >>> :set -XTypeOperators -XOverloadedStrings
211+ -- >>> newtype Id = Id { getId :: Int16 } deriving Show
212+ -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue
213+ -- >>> fromColumnValue @("col" ::: 'NotNull 'PGint2) @Id (K (Just "\NUL\SOH"))
214+ -- Id {getId = 1}
215+ --
216+ -- >>> fromColumnValue @("col" ::: 'Null 'PGint2) @(Maybe Id) (K (Just "\NUL\SOH"))
217+ -- Just (Id {getId = 1})
218+ fromColumnValue :: K (Maybe Strict.ByteString) colty -> y
711219instance 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
220+ => FromColumnValue (column ::: ('NotNull pg)) y where
221+ fromColumnValue = \case
222+ K Nothing -> error "fromColumnValue: saw NULL when expecting NOT NULL"
223+ K (Just bytes) ->
224+ let
225+ errOrValue =
226+ Decoding.valueParser (fromValue @pg @y Proxy) bytes
227+ err str = error $ "fromColumnValue: " ++ Strict.unpack str
228+ in
229+ either err id errOrValue
717230instance 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)
231+ => FromColumnValue (column ::: ('Null pg)) (Maybe y) where
232+ fromColumnValue (K nullOrBytes)
233+ = either err id
234+ . Decoding.valueParser (fromValue @pg @y Proxy)
235+ <$> nullOrBytes
236+ where
237+ err str = error $ "fromColumnValue: " ++ Strict.unpack str
745238
746239-- | A `FromRow` constraint generically sequences the parsings of the columns
747−-- of a `RowType` into the fields of a record `Type` provided they have
240+-- of a `RelationType` into the fields of a record `Type` provided they have
748241-- the same field names. You should not define instances of `FromRow`.
749−-- Instead define `SOP.Generic` and `SOP.HasDatatypeInfo` instances which in turn
242+-- Instead define `Generic` and `HasDatatypeInfo` instances which in turn
750243-- provide `FromRow` instances.
751−class SListI result => FromRow (result :: RowType) y where
244+class SListI results => FromRow (results :: RelationType) y where
752245 -- | >>> :set -XOverloadedStrings
753246 -- >>> import Data.Text
754247 -- >>> newtype UserId = UserId { getUserId :: Int16 } deriving Show
755− -- >>> instance FromValue 'PGint2 UserId where fromValue = UserId <$> fromValue @'PGint2
248+ -- >>> instance FromValue 'PGint2 UserId where fromValue = fmap UserId . fromValue
756249 -- >>> data UserRow = UserRow { userId :: UserId, userName :: Maybe Text } deriving (Show, GHC.Generic)
757250 -- >>> instance Generic UserRow
758251 -- >>> instance HasDatatypeInfo UserRow
759252 -- >>> type User = '["userId" ::: 'NotNull 'PGint2, "userName" ::: 'Null 'PGtext]
760253 -- >>> 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
254+ -- UserRow {userId = UserId {getUserId = 1}, userName = Just "bloodninja"}
255+ fromRow :: NP (K (Maybe Strict.ByteString)) results -> y
763256instance
764− ( SListI result
765− , IsRecord y ys
766− , AllZip FromField result ys
767− ) => FromRow result y where
257+ ( SListI results
258+ , IsProductType y ys
259+ , AllZip FromColumnValue results ys
260+ , SameFields (DatatypeInfoOf y) results
261+ ) => FromRow results y where
768262 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)
263+ = to . SOP . Z . htrans (Proxy @FromColumnValue) (I . fromColumnValue)
819264
820265-- | `Only` is a 1-tuple type, useful for encoding a single parameter with
821266-- `toParams` or decoding a single value with `fromRow`.
@@ -825,24 +270,8 @@ instance
825270-- K (Just "foo") :* Nil
826271--
827272-- >>> fromRow @'["fromOnly" ::: 'Null 'PGtext] @(Only (Maybe Text)) (K (Just "bar") :* Nil)
828−-- Right (Only {fromOnly = Just "bar"})
273+-- Only {fromOnly = Just "bar"}
829274newtype Only x = Only { fromOnly :: x }
830275 deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)
831276instance Generic (Only x)
832277instance HasDatatypeInfo (Only x)
833−
834−foldlN
835− :: All ((~) x) xs
836− => (z -> x -> z) -> z -> NP I xs -> z
837−foldlN f z = \case
838− Nil -> z
839− I x :* xs -> let z' = f z x in seq z' $ foldlN f z' xs
840−
841−replicateMN
842− :: forall x xs m. (All ((~) x) xs, Monad m, SListI xs)
843− => m x -> m (NP I xs)
844−replicateMN mx = hsequence' $
845− hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx))
846−
847−getOid :: LibPQ.Oid -> Word32
848−getOid (LibPQ.Oid (CUInt oid)) = oid
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+607−29
@@ -9,74 +9,652 @@ Squeal data definition language.
99-}
1010
1111{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
12+ ConstraintKinds
13+ , DataKinds
14+ , DeriveDataTypeable
1515 , DeriveGeneric
16− , DerivingStrategies
1716 , FlexibleContexts
1817 , FlexibleInstances
1918 , GADTs
19+ , GeneralizedNewtypeDeriving
20+ , KindSignatures
2021 , LambdaCase
2122 , MultiParamTypeClasses
22− , OverloadedLabels
2323 , OverloadedStrings
2424 , RankNTypes
2525 , ScopedTypeVariables
26+ , StandaloneDeriving
2627 , TypeApplications
2728 , TypeInType
2829 , TypeOperators
29− , UndecidableSuperClasses
30− , UndecidableInstances
3130#-}
3231
3332module Squeal.PostgreSQL.Definition
34− ( -- * Definition
35− Definition (..)
33+ ( -- * Definition
34+ Definition (UnsafeDefinition, renderDefinition)
3635 , (>>>)
37− , manipDefinition
36+ -- * Create
37+ , createTable
38+ , createTableIfNotExists
39+ , TableConstraintExpression (..)
40+ , Column (..)
41+ , check
42+ , unique
43+ , primaryKey
44+ , foreignKey
45+ , ForeignKeyed
46+ , OnDeleteClause (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade)
47+ , renderOnDeleteClause
48+ , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)
49+ , renderOnUpdateClause
50+ -- * Drop
51+ , dropTable
52+ -- * Alter
53+ , alterTable
54+ , alterTableRename
55+ , AlterTable (UnsafeAlterTable, renderAlterTable)
56+ , addConstraint
57+ , dropConstraint
58+ , AddColumn (addColumn)
59+ , dropColumn
60+ , renameColumn
61+ , alterColumn
62+ , AlterColumn (UnsafeAlterColumn, renderAlterColumn)
63+ , setDefault
64+ , dropDefault
65+ , setNotNull
66+ , dropNotNull
67+ , alterType
3868 ) where
3969
4070import Control.Category
4171import Control.DeepSeq
4272import Data.ByteString
4373import Data.Monoid
74+import GHC.TypeLits
4475import Prelude hiding ((.), id)
4576
77+import qualified Generics.SOP as SOP
4678import qualified GHC.Generics as GHC
4779
48−import Squeal.PostgreSQL.Manipulation
80+import Squeal.PostgreSQL.Expression
4981import Squeal.PostgreSQL.Render
5082import Squeal.PostgreSQL.Schema
5183
52−-- $setup
53−-- >>> import Squeal.PostgreSQL
54−
5584{-----------------------------------------
5685statements
5786-----------------------------------------}
5887
59−-- | A `Definition` is a statement that changes the schemas of the
88+-- | A `Definition` is a statement that changes the schema of the
6089-- database, like a `createTable`, `dropTable`, or `alterTable` command.
6190-- `Definition`s may be composed using the `>>>` operator.
6291newtype Definition
63− (schemas0 :: SchemasType)
64− (schemas1 :: SchemasType)
92+ (schema0 :: TablesType)
93+ (schema1 :: TablesType)
6594 = UnsafeDefinition { renderDefinition :: ByteString }
6695 deriving (GHC.Generic,Show,Eq,Ord,NFData)
6796
68−instance RenderSQL (Definition schemas0 schemas1) where
69− renderSQL = renderDefinition
70−
7197instance Category Definition where
7298 id = UnsafeDefinition ";"
7399 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
100+ renderDefinition ddl0 <+> renderDefinition ddl1
101+
102+{-----------------------------------------
103+CREATE statements
104+-----------------------------------------}
105+
106+-- | `createTable` adds a table to the schema.
107+--
108+-- >>> :set -XOverloadedLabels
109+-- >>> :{
110+-- renderDefinition $
111+-- createTable #tab (int `As` #a :* real `As` #b :* Nil) Nil
112+-- :}
113+-- "CREATE TABLE tab (a int, b real);"
114+createTable
115+ :: ( KnownSymbol table
116+ , columns ~ (col ': cols)
117+ , SOP.SListI columns
118+ , SOP.SListI constraints )
119+ => Alias table -- ^ the name of the table to add
120+ -> NP (Aliased TypeExpression) columns
121+ -- ^ the names and datatype of each column
122+ -> NP (Aliased (TableConstraintExpression schema columns)) constraints
123+ -- ^ constraints that must hold for the table
124+ -> Definition schema (Create table (constraints :=> columns) schema)
125+createTable table columns constraints = UnsafeDefinition $
126+ "CREATE TABLE" <+> renderCreation table columns constraints
127+
128+-- | `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
129+-- Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
130+-- `createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in the `Category` `Definition`.
131+--
132+-- >>> :set -XOverloadedLabels -XTypeApplications
133+-- >>> type Table = '[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGfloat4]
134+-- >>> type Schema = '["tab" ::: Table]
135+-- >>> :{
136+-- renderDefinition
137+-- (createTableIfNotExists #tab (int `As` #a :* real `As` #b :* Nil) Nil :: Definition Schema Schema)
138+-- :}
139+-- "CREATE TABLE IF NOT EXISTS tab (a int, b real);"
140+createTableIfNotExists
141+ :: ( Has table schema (constraints :=> columns)
142+ , SOP.SListI columns
143+ , SOP.SListI constraints )
144+ => Alias table -- ^ the name of the table to add
145+ -> NP (Aliased TypeExpression) columns
146+ -- ^ the names and datatype of each column
147+ -> NP (Aliased (TableConstraintExpression schema columns)) constraints
148+ -- ^ constraints that must hold for the table
149+ -> Definition schema schema
150+createTableIfNotExists table columns constraints = UnsafeDefinition $
151+ "CREATE TABLE IF NOT EXISTS"
152+ <+> renderCreation table columns constraints
153+
154+-- helper function for `createTable` and `createTableIfNotExists`
155+renderCreation
156+ :: ( KnownSymbol table
157+ , SOP.SListI columns
158+ , SOP.SListI constraints )
159+ => Alias table -- ^ the name of the table to add
160+ -> NP (Aliased TypeExpression) columns
161+ -- ^ the names and datatype of each column
162+ -> NP (Aliased (TableConstraintExpression schema columns)) constraints
163+ -- ^ constraints that must hold for the table
164+ -> ByteString
165+renderCreation table columns constraints = renderAlias table
166+ <+> parenthesized
167+ ( renderCommaSeparated renderColumnDef columns
168+ <> ( case constraints of
169+ Nil -> ""
170+ _ -> ", " <>
171+ renderCommaSeparated renderConstraint constraints ) )
172+ <> ";"
173+ where
174+ renderColumnDef :: Aliased TypeExpression x -> ByteString
175+ renderColumnDef (ty `As` column) =
176+ renderAlias column <+> renderTypeExpression ty
177+ renderConstraint
178+ :: Aliased (TableConstraintExpression schema columns) constraint
179+ -> ByteString
180+ renderConstraint (constraint `As` alias) =
181+ "CONSTRAINT" <+> renderAlias alias <+> renderTableConstraintExpression constraint
182+
183+-- | Data types are a way to limit the kind of data that can be stored in a
184+-- table. For many applications, however, the constraint they provide is
185+-- too coarse. For example, a column containing a product price should
186+-- probably only accept positive values. But there is no standard data type
187+-- that accepts only positive numbers. Another issue is that you might want
188+-- to constrain column data with respect to other columns or rows.
189+-- For example, in a table containing product information,
190+-- there should be only one row for each product number.
191+-- `TableConstraint`s give you as much control over the data in your tables
192+-- as you wish. If a user attempts to store data in a column that would
193+-- violate a constraint, an error is raised. This applies
194+-- even if the value came from the default value definition.
195+newtype TableConstraintExpression
196+ (schema :: TablesType)
197+ (columns :: ColumnsType)
198+ (tableConstraint :: TableConstraint)
199+ = UnsafeTableConstraintExpression
200+ { renderTableConstraintExpression :: ByteString }
201+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
202+
203+-- | @Column columns column@ is a witness that `column` is in `columns`.
204+data Column
205+ (columns :: ColumnsType)
206+ (column :: (Symbol,ColumnType))
207+ where
208+ Column
209+ :: Has column columns ty
210+ => Alias column
211+ -> Column columns (column ::: ty)
212+
213+-- | Render a `Column`.
214+renderColumn :: Column columns column -> ByteString
215+renderColumn (Column column) = renderAlias column
216+
217+-- | A `check` constraint is the most generic `TableConstraint` type.
218+-- It allows you to specify that the value in a certain column must satisfy
219+-- a Boolean (truth-value) expression.
220+--
221+-- >>> :{
222+-- renderDefinition $
223+-- createTable #tab
224+-- ( (int & notNull) `As` #a :*
225+-- (int & notNull) `As` #b :* Nil )
226+-- ( check (Column #a :* Column #b :* Nil) (#a .> #b) `As` #inequality :* Nil )
227+-- :}
228+-- "CREATE TABLE tab (a int NOT NULL, b int NOT NULL, CONSTRAINT inequality CHECK ((a > b)));"
229+check
230+ :: NP (Column columns) subcolumns
231+ -> Condition '[table ::: ColumnsToRelation subcolumns] 'Ungrouped '[]
232+ -- ^ condition to check
233+ -> TableConstraintExpression schema columns ('Check (AliasesOf subcolumns))
234+check _cols condition = UnsafeTableConstraintExpression $
235+ "CHECK" <+> parenthesized (renderExpression condition)
236+
237+-- | A `unique` constraint ensure that the data contained in a column,
238+-- or a group of columns, is unique among all the rows in the table.
239+--
240+-- >>> :{
241+-- renderDefinition $
242+-- createTable #tab
243+-- ( int `As` #a :*
244+-- int `As` #b :* Nil )
245+-- ( unique (Column #a :* Column #b :* Nil) `As` #uq_a_b :* Nil )
246+-- :}
247+-- "CREATE TABLE tab (a int, b int, CONSTRAINT uq_a_b UNIQUE (a, b));"
248+unique
249+ :: SOP.SListI subcolumns
250+ => NP (Column columns) subcolumns
251+ -- ^ unique column or group of columns
252+ -> TableConstraintExpression schema columns ('Unique (AliasesOf subcolumns))
253+unique columns = UnsafeTableConstraintExpression $
254+ "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)
255+
256+-- | A `primaryKey` constraint indicates that a column, or group of columns,
257+-- can be used as a unique identifier for rows in the table.
258+-- This requires that the values be both unique and not null.
259+--
260+-- >>> :{
261+-- renderDefinition $
262+-- createTable #tab
263+-- ( serial `As` #id :*
264+-- (text & notNull) `As` #name :* Nil )
265+-- ( primaryKey (Column #id :* Nil) `As` #pk_id :* Nil )
266+-- :}
267+-- "CREATE TABLE tab (id serial, name text NOT NULL, CONSTRAINT pk_id PRIMARY KEY (id));"
268+primaryKey
269+ :: (SOP.SListI subcolumns, AllNotNull subcolumns)
270+ => NP (Column columns) subcolumns
271+ -- ^ identifying column or group of columns
272+ -> TableConstraintExpression schema columns ('PrimaryKey (AliasesOf subcolumns))
273+primaryKey columns = UnsafeTableConstraintExpression $
274+ "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
275+
276+-- | A `foreignKey` specifies that the values in a column
277+-- (or a group of columns) must match the values appearing in some row of
278+-- another table. We say this maintains the referential integrity
279+-- between two related tables.
280+--
281+-- >>> :{
282+-- type Schema =
283+-- '[ "users" :::
284+-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
285+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
286+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext
287+-- ]
288+-- , "emails" :::
289+-- '[ "pk_emails" ::: 'PrimaryKey '["id"]
290+-- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
291+-- ] :=>
292+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
293+-- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
294+-- , "email" ::: 'NoDef :=> 'Null 'PGtext
295+-- ]
296+-- ]
297+-- :}
298+--
299+-- >>> :{
300+-- let
301+-- setup :: Definition '[] Schema
302+-- setup =
303+-- createTable #users
304+-- ( serial `As` #id :*
305+-- (text & notNull) `As` #name :* Nil )
306+-- ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>>
307+-- createTable #emails
308+-- ( serial `As` #id :*
309+-- (int & notNull) `As` #user_id :*
310+-- text `As` #email :* Nil )
311+-- ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
312+-- foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
313+-- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
314+-- in renderDefinition setup
315+-- :}
316+-- "CREATE TABLE users (id serial, name text NOT NULL, CONSTRAINT pk_users PRIMARY KEY (id)); CREATE TABLE emails (id serial, user_id int NOT NULL, email text, CONSTRAINT pk_emails PRIMARY KEY (id), CONSTRAINT fk_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE CASCADE ON UPDATE CASCADE);"
317+foreignKey
318+ :: ForeignKeyed schema table reftable subcolumns refsubcolumns
319+ => NP (Column columns) subcolumns
320+ -- ^ column or columns in the table
321+ -> Alias table
322+ -- ^ reference table
323+ -> NP (Column (TableToColumns reftable)) refsubcolumns
324+ -- ^ reference column or columns in the reference table
325+ -> OnDeleteClause
326+ -- ^ what to do when reference is deleted
327+ -> OnUpdateClause
328+ -- ^ what to do when reference is updated
329+ -> TableConstraintExpression schema columns
330+ ('ForeignKey (AliasesOf subcolumns) table (AliasesOf refsubcolumns))
331+foreignKey columns reftable refcolumns onDelete onUpdate =
332+ UnsafeTableConstraintExpression $
333+ "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
334+ <+> "REFERENCES" <+> renderAlias reftable
335+ <+> parenthesized (renderCommaSeparated renderColumn refcolumns)
336+ <+> renderOnDeleteClause onDelete
337+ <+> renderOnUpdateClause onUpdate
338+
339+-- | A type synonym for constraints on a table with a foreign key.
340+type ForeignKeyed schema table reftable subcolumns refsubcolumns
341+ = ( Has table schema reftable
342+ , SameTypes subcolumns refsubcolumns
343+ , AllNotNull subcolumns
344+ , SOP.SListI subcolumns
345+ , SOP.SListI refsubcolumns )
346+
347+-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
348+data OnDeleteClause
349+ = OnDeleteNoAction
350+ -- ^ if any referencing rows still exist when the constraint is checked,
351+ -- an error is raised
352+ | OnDeleteRestrict -- ^ prevents deletion of a referenced row
353+ | OnDeleteCascade
354+ -- ^ specifies that when a referenced row is deleted,
355+ -- row(s) referencing it should be automatically deleted as well
356+ deriving (GHC.Generic,Show,Eq,Ord)
357+instance NFData OnDeleteClause
358+
359+-- | Render `OnDeleteClause`.
360+renderOnDeleteClause :: OnDeleteClause -> ByteString
361+renderOnDeleteClause = \case
362+ OnDeleteNoAction -> "ON DELETE NO ACTION"
363+ OnDeleteRestrict -> "ON DELETE RESTRICT"
364+ OnDeleteCascade -> "ON DELETE CASCADE"
365+
366+-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
367+-- when a referenced column is changed (updated).
368+data OnUpdateClause
369+ = OnUpdateNoAction
370+ -- ^ if any referencing rows has not changed when the constraint is checked,
371+ -- an error is raised
372+ | OnUpdateRestrict -- ^ prevents update of a referenced row
373+ | OnUpdateCascade
374+ -- ^ the updated values of the referenced column(s) should be copied
375+ -- into the referencing row(s)
376+ deriving (GHC.Generic,Show,Eq,Ord)
377+instance NFData OnUpdateClause
378+
379+-- | Render `OnUpdateClause`.
380+renderOnUpdateClause :: OnUpdateClause -> ByteString
381+renderOnUpdateClause = \case
382+ OnUpdateNoAction -> "ON UPDATE NO ACTION"
383+ OnUpdateRestrict -> "ON UPDATE RESTRICT"
384+ OnUpdateCascade -> "ON UPDATE CASCADE"
385+
386+{-----------------------------------------
387+DROP statements
388+-----------------------------------------}
389+
390+-- | `dropTable` removes a table from the schema.
391+--
392+-- >>> renderDefinition $ dropTable #muh_table
393+-- "DROP TABLE muh_table;"
394+dropTable
395+ :: KnownSymbol table
396+ => Alias table -- ^ table to remove
397+ -> Definition schema (Drop table schema)
398+dropTable table = UnsafeDefinition $ "DROP TABLE" <+> renderAlias table <> ";"
399+
400+{-----------------------------------------
401+ALTER statements
402+-----------------------------------------}
403+
404+-- | `alterTable` changes the definition of a table from the schema.
405+alterTable
406+ :: Has tab schema table0
407+ => Alias tab -- ^ table to alter
408+ -> AlterTable schema table0 table1 -- ^ alteration to perform
409+ -> Definition schema (Alter tab schema table1)
410+alterTable table alteration = UnsafeDefinition $
411+ "ALTER TABLE"
412+ <+> renderAlias table
413+ <+> renderAlterTable alteration
414+ <> ";"
415+
416+-- | `alterTableRename` changes the name of a table from the schema.
417+--
418+-- >>> renderDefinition $ alterTableRename #foo #bar
419+-- "ALTER TABLE foo RENAME TO bar;"
420+alterTableRename
421+ :: (KnownSymbol table0, KnownSymbol table1)
422+ => Alias table0 -- ^ table to rename
423+ -> Alias table1 -- ^ what to rename it
424+ -> Definition schema (Rename table0 table1 schema)
425+alterTableRename table0 table1 = UnsafeDefinition $
426+ "ALTER TABLE" <+> renderAlias table0
427+ <+> "RENAME TO" <+> renderAlias table1 <> ";"
428+
429+-- | An `AlterTable` describes the alteration to perform on the columns
430+-- of a table.
431+newtype AlterTable
432+ (schema :: TablesType)
433+ (table0 :: TableType)
434+ (table1 :: TableType) =
435+ UnsafeAlterTable {renderAlterTable :: ByteString}
436+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
437+
438+-- | An `addConstraint` adds a table constraint.
439+--
440+-- >>> :{
441+-- let
442+-- definition :: Definition
443+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
444+-- '["tab" ::: '["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
445+-- definition = alterTable #tab (addConstraint #positive (check (Column #col :* Nil) (#col .> 0)))
446+-- in renderDefinition definition
447+-- :}
448+-- "ALTER TABLE tab ADD CONSTRAINT positive CHECK ((col > 0));"
449+addConstraint
450+ :: KnownSymbol alias
451+ => Alias alias
452+ -> TableConstraintExpression schema columns constraint
453+ -- ^ constraint to add
454+ -> AlterTable schema (constraints :=> columns)
455+ (Create alias constraint constraints :=> columns)
456+addConstraint alias constraint = UnsafeAlterTable $
457+ "ADD" <+> "CONSTRAINT" <+> renderAlias alias
458+ <+> renderTableConstraintExpression constraint
459+
460+-- | A `dropConstraint` drops a table constraint.
461+--
462+-- >>> :{
463+-- let
464+-- definition :: Definition
465+-- '["tab" ::: '["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
466+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
467+-- definition = alterTable #tab (dropConstraint #positive)
468+-- in renderDefinition definition
469+-- :}
470+-- "ALTER TABLE tab DROP CONSTRAINT positive;"
471+dropConstraint
472+ :: KnownSymbol constraint
473+ => Alias constraint
474+ -- ^ constraint to drop
475+ -> AlterTable schema
476+ (constraints :=> columns)
477+ (Drop constraint constraints :=> columns)
478+dropConstraint constraint = UnsafeAlterTable $
479+ "DROP" <+> "CONSTRAINT" <+> renderAlias constraint
480+
481+-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
482+class AddColumn ty where
483+ -- | `addColumn` adds a new column, initially filled with whatever
484+ -- default value is given or with @NULL@.
485+ --
486+ -- >>> :{
487+ -- let
488+ -- definition :: Definition
489+ -- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]]
490+ -- '["tab" ::: '[] :=>
491+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
492+ -- , "col2" ::: 'Def :=> 'Null 'PGtext ]]
493+ -- definition = alterTable #tab (addColumn #col2 (text & default_ "foo"))
494+ -- in renderDefinition definition
495+ -- :}
496+ -- "ALTER TABLE tab ADD COLUMN col2 text DEFAULT E'foo';"
497+ --
498+ -- >>> :{
499+ -- let
500+ -- definition :: Definition
501+ -- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]]
502+ -- '["tab" ::: '[] :=>
503+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
504+ -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ]]
505+ -- definition = alterTable #tab (addColumn #col2 text)
506+ -- in renderDefinition definition
507+ -- :}
508+ -- "ALTER TABLE tab ADD COLUMN col2 text;"
509+ addColumn
510+ :: KnownSymbol column
511+ => Alias column -- ^ column to add
512+ -> TypeExpression ty -- ^ type of the new column
513+ -> AlterTable schema (constraints :=> columns)
514+ (constraints :=> Create column ty columns)
515+ addColumn column ty = UnsafeAlterTable $
516+ "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
517+instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
518+instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
519+
520+-- | A `dropColumn` removes a column. Whatever data was in the column
521+-- disappears. Table constraints involving the column are dropped, too.
522+-- However, if the column is referenced by a foreign key constraint of
523+-- another table, PostgreSQL will not silently drop that constraint.
524+--
525+-- >>> :{
526+-- let
527+-- definition :: Definition
528+-- '["tab" ::: '[] :=>
529+-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
530+-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ]]
531+-- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]]
532+-- definition = alterTable #tab (dropColumn #col2)
533+-- in renderDefinition definition
534+-- :}
535+-- "ALTER TABLE tab DROP COLUMN col2;"
536+dropColumn
537+ :: KnownSymbol column
538+ => Alias column -- ^ column to remove
539+ -> AlterTable schema
540+ (constraints :=> columns)
541+ (DropIfConstraintsInvolve column constraints :=> Drop column columns)
542+dropColumn column = UnsafeAlterTable $
543+ "DROP COLUMN" <+> renderAlias column
544+
545+-- | A `renameColumn` renames a column.
546+--
547+-- >>> :{
548+-- let
549+-- definition :: Definition
550+-- '["tab" ::: '[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4]]
551+-- '["tab" ::: '[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4]]
552+-- definition = alterTable #tab (renameColumn #foo #bar)
553+-- in renderDefinition definition
554+-- :}
555+-- "ALTER TABLE tab RENAME COLUMN foo TO bar;"
556+renameColumn
557+ :: (KnownSymbol column0, KnownSymbol column1)
558+ => Alias column0 -- ^ column to rename
559+ -> Alias column1 -- ^ what to rename the column
560+ -> AlterTable schema (constraints :=> columns)
561+ (constraints :=> Rename column0 column1 columns)
562+renameColumn column0 column1 = UnsafeAlterTable $
563+ "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1
564+
565+-- | An `alterColumn` alters a single column.
566+alterColumn
567+ :: (KnownSymbol column, Has column columns ty0)
568+ => Alias column -- ^ column to alter
569+ -> AlterColumn ty0 ty1 -- ^ alteration to perform
570+ -> AlterTable schema (constraints :=> columns)
571+ (constraints :=> Alter column columns ty1)
572+alterColumn column alteration = UnsafeAlterTable $
573+ "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration
574+
575+-- | An `AlterColumn` describes the alteration to perform on a single column.
576+newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) =
577+ UnsafeAlterColumn {renderAlterColumn :: ByteString}
578+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
579+
580+-- | A `setDefault` sets a new default for a column. Note that this doesn't
581+-- affect any existing rows in the table, it just changes the default for
582+-- future insert and update commands.
583+--
584+-- >>> :{
585+-- let
586+-- definition :: Definition
587+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
588+-- '["tab" ::: '[] :=> '["col" ::: 'Def :=> 'Null 'PGint4]]
589+-- definition = alterTable #tab (alterColumn #col (setDefault 5))
590+-- in renderDefinition definition
591+-- :}
592+-- "ALTER TABLE tab ALTER COLUMN col SET DEFAULT 5;"
593+setDefault
594+ :: Expression '[] 'Ungrouped '[] ty -- ^ default value to set
595+ -> AlterColumn (constraint :=> ty) ('Def :=> ty)
596+setDefault expression = UnsafeAlterColumn $
597+ "SET DEFAULT" <+> renderExpression expression
598+
599+-- | A `dropDefault` removes any default value for a column.
600+--
601+-- >>> :{
602+-- let
603+-- definition :: Definition
604+-- '["tab" ::: '[] :=> '["col" ::: 'Def :=> 'Null 'PGint4]]
605+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
606+-- definition = alterTable #tab (alterColumn #col dropDefault)
607+-- in renderDefinition definition
608+-- :}
609+-- "ALTER TABLE tab ALTER COLUMN col DROP DEFAULT;"
610+dropDefault :: AlterColumn ('Def :=> ty) ('NoDef :=> ty)
611+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
612+
613+-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
614+-- The constraint will be checked immediately, so the table data must satisfy
615+-- the constraint before it can be added.
616+--
617+-- >>> :{
618+-- let
619+-- definition :: Definition
620+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
621+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
622+-- definition = alterTable #tab (alterColumn #col setNotNull)
623+-- in renderDefinition definition
624+-- :}
625+-- "ALTER TABLE tab ALTER COLUMN col SET NOT NULL;"
626+setNotNull
627+ :: AlterColumn (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
628+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
629+
630+-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
631+--
632+-- >>> :{
633+-- let
634+-- definition :: Definition
635+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
636+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
637+-- definition = alterTable #tab (alterColumn #col dropNotNull)
638+-- in renderDefinition definition
639+-- :}
640+-- "ALTER TABLE tab ALTER COLUMN col DROP NOT NULL;"
641+dropNotNull
642+ :: AlterColumn (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
643+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
644+
645+-- | An `alterType` converts a column to a different data type.
646+-- This will succeed only if each existing entry in the column can be
647+-- converted to the new type by an implicit cast.
648+--
649+-- >>> :{
650+-- let
651+-- definition :: Definition
652+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
653+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric]]
654+-- definition =
655+-- alterTable #tab (alterColumn #col (alterType (numeric & notNull)))
656+-- in renderDefinition definition
657+-- :}
658+-- "ALTER TABLE tab ALTER COLUMN col TYPE numeric NOT NULL;"
659+alterType :: TypeExpression ty -> AlterColumn ty0 ty
660+alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderTypeExpression ty
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hsdeleted−238
@@ -1,238 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Function
3−Description: Create and drop function and operator definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop function and operator definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Function
33− ( createFunction
34− , createOrReplaceFunction
35− , createSetFunction
36− , createOrReplaceSetFunction
37− , createBinaryOp
38− , createLeftOp
39− , createRightOp
40− , dropFunction
41− , dropFunctionIfExists
42− , dropOperator
43− , dropOperatorIfExists
44− , FunctionDefinition(..)
45− , languageSqlExpr
46− , languageSqlQuery
47− ) where
48−
49−import Control.DeepSeq
50−import Data.ByteString
51−import GHC.TypeLits
52−
53−import qualified Generics.SOP as SOP
54−import qualified GHC.Generics as GHC
55−
56−import Squeal.PostgreSQL.Alias
57−import Squeal.PostgreSQL.Definition
58−import Squeal.PostgreSQL.Expression
59−import Squeal.PostgreSQL.Expression.Type
60−import Squeal.PostgreSQL.List
61−import Squeal.PostgreSQL.Query
62−import Squeal.PostgreSQL.Render
63−import Squeal.PostgreSQL.Schema
64−
65−-- $setup
66−-- >>> import Squeal.PostgreSQL
67−
68−createFunction
69− :: ( Has sch schemas schema
70− , KnownSymbol fun
71− , SOP.SListI args )
72− => QualifiedAlias sch fun
73− -> NP (TypeExpression schemas) args
74− -> TypeExpression schemas ret
75− -> FunctionDefinition schemas args ('Returns ret)
76− -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'Returns ret)) schema) schemas)
77−createFunction fun args ret fundef = UnsafeDefinition $
78− "CREATE" <+> "FUNCTION" <+> renderSQL fun
79− <+> parenthesized (renderCommaSeparated renderSQL args)
80− <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
81−
82−createOrReplaceFunction
83− :: ( Has sch schemas schema
84− , KnownSymbol fun
85− , SOP.SListI args )
86− => QualifiedAlias sch fun
87− -> NP (TypeExpression schemas) args
88− -> TypeExpression schemas ret
89− -> FunctionDefinition schemas args ('Returns ret)
90− -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'Returns ret)) schema) schemas)
91−createOrReplaceFunction fun args ret fundef = UnsafeDefinition $
92− "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
93− <+> parenthesized (renderCommaSeparated renderSQL args)
94− <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
95−
96−languageSqlExpr
97− :: Expression '[] '[] 'Ungrouped schemas args '[] ret
98− -> FunctionDefinition schemas args ('Returns ret)
99−languageSqlExpr expr = UnsafeFunctionDefinition $
100− "language sql as"
101− <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$"
102−
103−languageSqlQuery
104− :: Query '[] '[] schemas args rets
105− -> FunctionDefinition schemas args ('ReturnsTable rets)
106−languageSqlQuery qry = UnsafeFunctionDefinition $
107− "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"
108−
109−createSetFunction
110− :: ( Has sch schemas schema
111− , KnownSymbol fun
112− , SOP.SListI args
113− , SOP.SListI rets )
114− => QualifiedAlias sch fun
115− -> NP (TypeExpression schemas) args
116− -> NP (Aliased (TypeExpression schemas)) rets
117− -> FunctionDefinition schemas args ('ReturnsTable rets)
118− -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
119−createSetFunction fun args rets fundef = UnsafeDefinition $
120− "CREATE" <+> "FUNCTION" <+> renderSQL fun
121− <+> parenthesized (renderCommaSeparated renderSQL args)
122− <+> "RETURNS" <+> "TABLE"
123− <+> parenthesized (renderCommaSeparated renderRet rets)
124− <+> renderSQL fundef <> ";"
125− where
126− renderRet :: Aliased (TypeExpression s) r -> ByteString
127− renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
128−
129−createOrReplaceSetFunction
130− :: ( Has sch schemas schema
131− , KnownSymbol fun
132− , SOP.SListI args
133− , SOP.SListI rets )
134− => QualifiedAlias sch fun
135− -> NP (TypeExpression schemas) args
136− -> NP (Aliased (TypeExpression schemas)) rets
137− -> FunctionDefinition schemas args ('ReturnsTable rets)
138− -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
139−createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $
140− "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
141− <+> parenthesized (renderCommaSeparated renderSQL args)
142− <+> "RETURNS" <+> "TABLE"
143− <+> parenthesized (renderCommaSeparated renderRet rets)
144− <+> renderSQL fundef <> ";"
145− where
146− renderRet :: Aliased (TypeExpression s) r -> ByteString
147− renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
148−
149−createBinaryOp
150− :: forall op fun sch schemas schema x y z.
151− ( Has sch schemas schema
152− , Has fun schema ('Function ('[x,y] :=> 'Returns z))
153− , KnownSymbol op )
154− => QualifiedAlias sch fun
155− -> TypeExpression schemas x
156− -> TypeExpression schemas y
157− -> Definition schemas
158− (Alter sch (Create op ('Operator ('BinaryOp x y z)) schema) schemas)
159−createBinaryOp fun x y = UnsafeDefinition $
160− "CREATE" <+> "OPERATOR" <+> renderSymbol @op
161− <+> parenthesized (commaSeparated opdef)
162− where
163− opdef =
164− [ "FUNCTION" <+> "=" <+> renderSQL fun
165− , "LEFTARG" <+> "=" <+> renderSQL x
166− , "RIGHTARG" <+> "=" <+> renderSQL y ]
167−
168−createLeftOp
169− :: forall op fun sch schemas schema x y.
170− ( Has sch schemas schema
171− , Has fun schema ('Function ('[x] :=> 'Returns y))
172− , KnownSymbol op )
173− => QualifiedAlias sch fun
174− -> TypeExpression schemas x
175− -> Definition schemas
176− (Alter sch (Create op ('Operator ('LeftOp x y)) schema) schemas)
177−createLeftOp fun x = UnsafeDefinition $
178− "CREATE" <+> "OPERATOR" <+> renderSymbol @op
179− <+> parenthesized (commaSeparated opdef)
180− where
181− opdef =
182− [ "FUNCTION" <+> "=" <+> renderSQL fun
183− , "RIGHTARG" <+> "=" <+> renderSQL x ]
184−
185−createRightOp
186− :: forall op fun sch schemas schema x y.
187− ( Has sch schemas schema
188− , Has fun schema ('Function ('[x] :=> 'Returns y))
189− , KnownSymbol op )
190− => QualifiedAlias sch fun
191− -> TypeExpression schemas x
192− -> Definition schemas
193− (Alter sch (Create op ('Operator ('RightOp x y)) schema) schemas)
194−createRightOp fun x = UnsafeDefinition $
195− "CREATE" <+> "OPERATOR" <+> renderSymbol @op
196− <+> parenthesized (commaSeparated opdef)
197− where
198− opdef =
199− [ "FUNCTION" <+> "=" <+> renderSQL fun
200− , "LEFTARG" <+> "=" <+> renderSQL x ]
201−
202−dropFunction
203− :: (Has sch schemas schema, KnownSymbol fun)
204− => QualifiedAlias sch fun
205− -- ^ name of the user defined function
206− -> Definition schemas (Alter sch (DropSchemum fun 'Function schema) schemas)
207−dropFunction fun = UnsafeDefinition $
208− "DROP" <+> "FUNCTION" <+> renderSQL fun <> ";"
209−
210−dropFunctionIfExists
211− :: (Has sch schemas schema, KnownSymbol fun)
212− => QualifiedAlias sch fun
213− -- ^ name of the user defined function
214− -> Definition schemas (Alter sch (DropSchemumIfExists fun 'Function schema) schemas)
215−dropFunctionIfExists fun = UnsafeDefinition $
216− "DROP FUNCTION IF EXISTS" <+> renderSQL fun <> ";"
217−
218−dropOperator
219− :: (Has sch schemas schema, KnownSymbol op)
220− => QualifiedAlias sch op
221− -- ^ name of the user defined operator
222− -> Definition schemas (Alter sch (DropSchemum op 'Operator schema) schemas)
223−dropOperator op = UnsafeDefinition $
224− "DROP" <+> "OPERATOR" <+> renderSQL op <> ";"
225−
226−dropOperatorIfExists
227− :: (Has sch schemas schema, KnownSymbol op)
228− => QualifiedAlias sch op
229− -- ^ name of the user defined operator
230− -> Definition schemas (Alter sch (DropSchemumIfExists op 'Operator schema) schemas)
231−dropOperatorIfExists op = UnsafeDefinition $
232− "DROP OPERATOR IF EXISTS" <+> renderSQL op <> ";"
233−
234−newtype FunctionDefinition schemas args ret = UnsafeFunctionDefinition
235− { renderFunctionDefinition :: ByteString }
236− deriving (Eq,Show,GHC.Generic,NFData)
237−instance RenderSQL (FunctionDefinition schemas args ret) where
238− renderSQL = renderFunctionDefinition
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hsdeleted−159
@@ -1,159 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Index
3−Description: Create and drop index definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop index definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Index
33− ( createIndex
34− , createIndexIfNotExists
35− , dropIndex
36− , dropIndexIfExists
37− , IndexMethod (..)
38− , btree
39− , hash
40− , gist
41− , spgist
42− , gin
43− , brin
44− ) where
45−
46−import Data.ByteString
47−import GHC.TypeLits
48−
49−import qualified GHC.Generics as GHC
50−
51−import Squeal.PostgreSQL.Alias
52−import Squeal.PostgreSQL.Definition
53−import Squeal.PostgreSQL.Expression.Sort
54−import Squeal.PostgreSQL.Render
55−import Squeal.PostgreSQL.Schema
56−
57−-- $setup
58−-- >>> import Squeal.PostgreSQL
59−
60−{- |
61−>>> :{
62−type Table = '[] :=>
63− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
64− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
65−:}
66−
67−>>> :{
68−let
69− setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree])
70− setup =
71− createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>>
72− createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast]
73−in printSQL setup
74−:}
75−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
76−CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST);
77−-}
78−createIndex
79− :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
80− => Alias ix
81− -> QualifiedAlias sch tab
82− -> IndexMethod method
83− -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
84− -> Definition schemas (Alter sch (Create ix ('Index method) schema) schemas)
85−createIndex ix tab method cols = UnsafeDefinition $
86− "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab
87− <+> "USING" <+> renderSQL method
88− <+> parenthesized (commaSeparated (renderIndex <$> cols))
89− <> ";"
90− where
91− renderIndex = \case
92− Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
93− Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
94− AscNullsFirst expression -> parenthesized (renderSQL expression)
95− <+> "ASC NULLS FIRST"
96− DescNullsFirst expression -> parenthesized (renderSQL expression)
97− <+> "DESC NULLS FIRST"
98− AscNullsLast expression -> parenthesized (renderSQL expression)
99− <+> "ASC NULLS LAST"
100− DescNullsLast expression -> parenthesized (renderSQL expression)
101− <+> "DESC NULLS LAST"
102−
103−createIndexIfNotExists
104− :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
105− => Alias ix
106− -> QualifiedAlias sch tab
107− -> IndexMethod method
108− -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
109− -> Definition schemas (Alter sch (CreateIfNotExists ix ('Index method) schema) schemas)
110−createIndexIfNotExists ix tab method cols = UnsafeDefinition $
111− "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab
112− <+> "USING" <+> renderSQL method
113− <+> parenthesized (commaSeparated (renderIndex <$> cols))
114− <> ";"
115− where
116− renderIndex = \case
117− Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
118− Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
119− AscNullsFirst expression -> parenthesized (renderSQL expression)
120− <+> "ASC NULLS FIRST"
121− DescNullsFirst expression -> parenthesized (renderSQL expression)
122− <+> "DESC NULLS FIRST"
123− AscNullsLast expression -> parenthesized (renderSQL expression)
124− <+> "ASC NULLS LAST"
125− DescNullsLast expression -> parenthesized (renderSQL expression)
126− <+> "DESC NULLS LAST"
127−
128−newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString}
129− deriving stock (Eq, Ord, Show, GHC.Generic)
130−instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod
131−btree :: IndexMethod 'Btree
132−btree = UnsafeIndexMethod "btree"
133−hash :: IndexMethod 'Hash
134−hash = UnsafeIndexMethod "hash"
135−gist :: IndexMethod 'Gist
136−gist = UnsafeIndexMethod "gist"
137−spgist :: IndexMethod 'Spgist
138−spgist = UnsafeIndexMethod "spgist"
139−gin :: IndexMethod 'Gin
140−gin = UnsafeIndexMethod "gin"
141−brin :: IndexMethod 'Brin
142−brin = UnsafeIndexMethod "brin"
143−
144−-- |
145−-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[]))
146−-- DROP INDEX "ix";
147−dropIndex
148− :: (Has sch schemas schema, KnownSymbol ix)
149− => QualifiedAlias sch ix
150− -- ^ name of the user defined index
151− -> Definition schemas (Alter sch (DropSchemum ix 'Index schema) schemas)
152−dropIndex ix = UnsafeDefinition $ "DROP" <+> "INDEX" <+> renderSQL ix <> ";"
153−
154−dropIndexIfExists
155− :: (Has sch schemas schema, KnownSymbol ix)
156− => QualifiedAlias sch ix
157− -- ^ name of the user defined index
158− -> Definition schemas (Alter sch (DropSchemumIfExists ix 'Index schema) schemas)
159−dropIndexIfExists ix = UnsafeDefinition $ "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hsdeleted−96
@@ -1,96 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Schema
3−Description: Create and drop schema definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop schema definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Schema
33− ( createSchema
34− , createSchemaIfNotExists
35− , dropSchema
36− , dropSchemaIfExists
37− ) where
38−
39−import GHC.TypeLits
40−
41−import Squeal.PostgreSQL.Alias
42−import Squeal.PostgreSQL.Definition
43−import Squeal.PostgreSQL.Render
44−import Squeal.PostgreSQL.Schema
45−
46−-- $setup
47−-- >>> import Squeal.PostgreSQL
48−
49−{- |
50−`createSchema` enters a new schema into the current database.
51−The schema name must be distinct from the name of any existing schema
52−in the current database.
53−
54−A schema is essentially a namespace: it contains named objects
55−(tables, data types, functions, and operators) whose names
56−can duplicate those of other objects existing in other schemas.
57−Named objects are accessed by `QualifiedAlias`es with the schema
58−name as a prefix.
59−-}
60−createSchema
61− :: KnownSymbol sch
62− => Alias sch
63− -> Definition schemas (Create sch '[] schemas)
64−createSchema sch = UnsafeDefinition $
65− "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
66−
67−{- | Idempotent version of `createSchema`. -}
68−createSchemaIfNotExists
69− :: (KnownSymbol sch, Has sch schemas schema)
70− => Alias sch
71− -> Definition schemas (CreateIfNotExists sch '[] schemas)
72−createSchemaIfNotExists sch = UnsafeDefinition $
73− "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
74− <+> renderSQL sch <> ";"
75−
76−-- | >>> :{
77−-- let
78−-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
79−-- definition = dropSchema #muh_schema
80−-- :}
81−--
82−-- >>> printSQL definition
83−-- DROP SCHEMA "muh_schema";
84−dropSchema
85− :: KnownSymbol sch
86− => Alias sch
87− -- ^ user defined schema
88− -> Definition schemas (Drop sch schemas)
89−dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
90−
91−dropSchemaIfExists
92− :: KnownSymbol sch
93− => Alias sch
94− -- ^ user defined schema
95− -> Definition schemas (DropIfExists sch schemas)
96−dropSchemaIfExists sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hsdeleted−500
@@ -1,500 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Table
3−Description: Create, drop and alter table definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create, drop and alter table definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Table
33− ( createTable
34− , createTableIfNotExists
35− , dropTable
36− , dropTableIfExists
37− , alterTable
38− , alterTableIfExists
39− , alterTableRename
40− , alterTableIfExistsRename
41− , AlterTable (..)
42− , addConstraint
43− , dropConstraint
44− , AddColumn (..)
45− , dropColumn
46− , renameColumn
47− , alterColumn
48− , AlterColumn (..)
49− , setDefault
50− , dropDefault
51− , setNotNull
52− , dropNotNull
53− , alterType
54− ) where
55−
56−import Control.DeepSeq
57−import Data.ByteString
58−import GHC.TypeLits
59−
60−import qualified Generics.SOP as SOP
61−import qualified GHC.Generics as GHC
62−
63−import Squeal.PostgreSQL.Alias
64−import Squeal.PostgreSQL.Definition
65−import Squeal.PostgreSQL.Definition.Table.Constraint
66−import Squeal.PostgreSQL.Expression
67−import Squeal.PostgreSQL.Expression.Type
68−import Squeal.PostgreSQL.List
69−import Squeal.PostgreSQL.Render
70−import Squeal.PostgreSQL.Schema
71−
72−-- $setup
73−-- >>> import Squeal.PostgreSQL
74−
75−{- | `createTable` adds a table to the schema.
76−
77−>>> :set -XOverloadedLabels
78−>>> :{
79−type Table = '[] :=>
80− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
81− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
82−:}
83−
84−>>> :{
85−let
86− setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
87− setup = createTable #tab
88− (nullable int `as` #a :* nullable real `as` #b) Nil
89−in printSQL setup
90−:}
91−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
92−-}
93−createTable
94− :: ( KnownSymbol sch
95− , KnownSymbol tab
96− , columns ~ (col ': cols)
97− , SOP.SListI columns
98− , SOP.SListI constraints
99− , Has sch schemas0 schema0
100− , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
101− => QualifiedAlias sch tab -- ^ the name of the table to add
102− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
103− -- ^ the names and datatype of each column
104− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
105− -- ^ constraints that must hold for the table
106− -> Definition schemas0 schemas1
107−createTable tab columns constraints = UnsafeDefinition $
108− "CREATE TABLE" <+> renderCreation tab columns constraints
109−
110−{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
111−Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
112−`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
113−the `Category` of `Definition`s.
114−
115−>>> :set -XOverloadedLabels -XTypeApplications
116−>>> :{
117−type Table = '[] :=>
118− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
119− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
120−:}
121−
122−>>> type Schemas = Public '["tab" ::: 'Table Table]
123−
124−>>> :{
125−let
126− setup :: Definition Schemas Schemas
127− setup = createTableIfNotExists #tab
128− (nullable int `as` #a :* nullable real `as` #b) Nil
129−in printSQL setup
130−:}
131−CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
132−-}
133−createTableIfNotExists
134− :: ( KnownSymbol sch
135− , KnownSymbol tab
136− , columns ~ (col ': cols)
137− , SOP.SListI columns
138− , SOP.SListI constraints
139− , Has sch schemas0 schema0
140− , schemas1 ~ Alter sch (CreateIfNotExists tab ('Table (constraints :=> columns)) schema0) schemas0 )
141− => QualifiedAlias sch tab -- ^ the name of the table to add
142− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
143− -- ^ the names and datatype of each column
144− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
145− -- ^ constraints that must hold for the table
146− -> Definition schemas0 schemas1
147−createTableIfNotExists tab columns constraints = UnsafeDefinition $
148− "CREATE TABLE IF NOT EXISTS"
149− <+> renderCreation tab columns constraints
150−
151−-- helper function for `createTable` and `createTableIfNotExists`
152−renderCreation
153− :: ( KnownSymbol sch
154− , KnownSymbol tab
155− , SOP.SListI columns
156− , SOP.SListI constraints )
157− => QualifiedAlias sch tab -- ^ the name of the table to add
158− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
159− -- ^ the names and datatype of each column
160− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
161− -- ^ constraints that must hold for the table
162− -> ByteString
163−renderCreation tab columns constraints = renderSQL tab
164− <+> parenthesized
165− ( renderCommaSeparated renderColumnDef columns
166− <> ( case constraints of
167− Nil -> ""
168− _ -> ", " <>
169− renderCommaSeparated renderConstraint constraints ) )
170− <> ";"
171− where
172− renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
173− renderColumnDef (ty `As` column) =
174− renderSQL column <+> renderColumnTypeExpression ty
175− renderConstraint
176− :: Aliased (TableConstraintExpression sch tab schemas) constraint
177− -> ByteString
178− renderConstraint (constraint `As` alias) =
179− "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
180−
181−-- | `dropTable` removes a table from the schema.
182−--
183−-- >>> :{
184−-- let
185−-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
186−-- definition = dropTable #muh_table
187−-- :}
188−--
189−-- >>> printSQL definition
190−-- DROP TABLE "muh_table";
191−dropTable
192− :: ( Has sch schemas schema
193− , KnownSymbol tab )
194− => QualifiedAlias sch tab -- ^ table to remove
195− -> Definition schemas (Alter sch (DropSchemum tab 'Table schema) schemas)
196−dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
197−
198−dropTableIfExists
199− :: ( Has sch schemas schema
200− , KnownSymbol tab)
201− => QualifiedAlias sch tab -- ^ table to remove
202− -> Definition schemas (Alter sch (DropSchemumIfExists tab 'Table schema) schemas)
203−dropTableIfExists tab = UnsafeDefinition $ "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";"
204−
205−-- | `alterTable` changes the definition of a table from the schema.
206−alterTable
207− :: (Has sch schemas schema, KnownSymbol tab)
208− => QualifiedAlias sch tab -- ^ table to alter
209− -> AlterTable sch tab schemas table -- ^ alteration to perform
210− -> Definition schemas (Alter sch (Alter tab ('Table table) schema) schemas)
211−alterTable tab alteration = UnsafeDefinition $
212− "ALTER TABLE"
213− <+> renderSQL tab
214− <+> renderAlterTable alteration
215− <> ";"
216−
217−-- | `alterTable` changes the definition of a table from the schema.
218−alterTableIfExists
219− :: (Has sch schemas schema, KnownSymbol tab)
220− => QualifiedAlias sch tab -- ^ table to alter
221− -> AlterTable sch tab schemas table -- ^ alteration to perform
222− -> Definition schemas (Alter sch (AlterIfExists tab ('Table table) schema) schemas)
223−alterTableIfExists tab alteration = UnsafeDefinition $
224− "ALTER TABLE IF EXISTS"
225− <+> renderSQL tab
226− <+> renderAlterTable alteration
227− <> ";"
228−
229−-- | `alterTableRename` changes the name of a table from the schema.
230−--
231−-- >>> printSQL $ alterTableRename #foo #bar
232−-- ALTER TABLE "foo" RENAME TO "bar";
233−alterTableRename
234− :: (KnownSymbol tab0, KnownSymbol tab1)
235− => Alias tab0 -- ^ table to rename
236− -> Alias tab1 -- ^ what to rename it
237− -> Definition schema (Rename tab0 tab1 schema)
238−alterTableRename tab0 tab1 = UnsafeDefinition $
239− "ALTER TABLE" <+> renderSQL tab0
240− <+> "RENAME TO" <+> renderSQL tab1 <> ";"
241−
242−alterTableIfExistsRename
243− :: (KnownSymbol tab0, KnownSymbol tab1)
244− => Alias tab0 -- ^ table to rename
245− -> Alias tab1 -- ^ what to rename it
246− -> Definition schema (RenameIfExists tab0 tab1 schema)
247−alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $
248− "ALTER TABLE IF EXISTS" <+> renderSQL tab0
249− <+> "RENAME TO" <+> renderSQL tab1 <> ";"
250−
251−-- | An `AlterTable` describes the alteration to perform on the columns
252−-- of a table.
253−newtype AlterTable
254− (sch :: Symbol)
255− (tab :: Symbol)
256− (schemas :: SchemasType)
257− (table :: TableType) =
258− UnsafeAlterTable {renderAlterTable :: ByteString}
259− deriving (GHC.Generic,Show,Eq,Ord,NFData)
260−
261−-- | An `addConstraint` adds a table constraint.
262−--
263−-- >>> :{
264−-- let
265−-- definition :: Definition
266−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
267−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
268−-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
269−-- in printSQL definition
270−-- :}
271−-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
272−addConstraint
273− :: ( KnownSymbol alias
274− , Has sch schemas schema
275− , Has tab schema ('Table table0)
276− , table0 ~ (constraints :=> columns)
277− , table1 ~ (Create alias constraint constraints :=> columns) )
278− => Alias alias
279− -> TableConstraintExpression sch tab schemas constraint
280− -- ^ constraint to add
281− -> AlterTable sch tab schemas table1
282−addConstraint alias constraint = UnsafeAlterTable $
283− "ADD" <+> "CONSTRAINT" <+> renderSQL alias
284− <+> renderSQL constraint
285−
286−-- | A `dropConstraint` drops a table constraint.
287−--
288−-- >>> :{
289−-- let
290−-- definition :: Definition
291−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
292−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
293−-- definition = alterTable #tab (dropConstraint #positive)
294−-- in printSQL definition
295−-- :}
296−-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
297−dropConstraint
298− :: ( KnownSymbol constraint
299− , Has sch schemas schema
300− , Has tab schema ('Table table0)
301− , table0 ~ (constraints :=> columns)
302− , table1 ~ (Drop constraint constraints :=> columns) )
303− => Alias constraint
304− -- ^ constraint to drop
305− -> AlterTable sch tab schemas table1
306−dropConstraint constraint = UnsafeAlterTable $
307− "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
308−
309−-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
310−class AddColumn ty where
311− -- | `addColumn` adds a new column, initially filled with whatever
312− -- default value is given or with @NULL@.
313− --
314− -- >>> :{
315− -- let
316− -- definition :: Definition
317− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
318− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
319− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
320− -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
321− -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
322− -- in printSQL definition
323− -- :}
324− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
325− --
326− -- >>> :{
327− -- let
328− -- definition :: Definition
329− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
330− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
331− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
332− -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
333− -- definition = alterTable #tab (addColumn #col2 (text & nullable))
334− -- in printSQL definition
335− -- :}
336− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
337− addColumn
338− :: ( KnownSymbol column
339− , Has sch schemas schema
340− , Has tab schema ('Table table0)
341− , table0 ~ (constraints :=> columns) )
342− => Alias column -- ^ column to add
343− -> ColumnTypeExpression schemas ty -- ^ type of the new column
344− -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
345− addColumn column ty = UnsafeAlterTable $
346− "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
347−instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
348−instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
349−
350−-- | A `dropColumn` removes a column. Whatever data was in the column
351−-- disappears. Table constraints involving the column are dropped, too.
352−-- However, if the column is referenced by a foreign key constraint of
353−-- another table, PostgreSQL will not silently drop that constraint.
354−--
355−-- >>> :{
356−-- let
357−-- definition :: Definition
358−-- '["public" ::: '["tab" ::: 'Table ('[] :=>
359−-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
360−-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
361−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
362−-- definition = alterTable #tab (dropColumn #col2)
363−-- in printSQL definition
364−-- :}
365−-- ALTER TABLE "tab" DROP COLUMN "col2";
366−dropColumn
367− :: ( KnownSymbol column
368− , Has sch schemas schema
369− , Has tab schema ('Table table0)
370− , table0 ~ (constraints :=> columns)
371− , table1 ~ (constraints :=> Drop column columns) )
372− => Alias column -- ^ column to remove
373− -> AlterTable sch tab schemas table1
374−dropColumn column = UnsafeAlterTable $
375− "DROP COLUMN" <+> renderSQL column
376−
377−-- | A `renameColumn` renames a column.
378−--
379−-- >>> :{
380−-- let
381−-- definition :: Definition
382−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
383−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
384−-- definition = alterTable #tab (renameColumn #foo #bar)
385−-- in printSQL definition
386−-- :}
387−-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
388−renameColumn
389− :: ( KnownSymbol column0
390− , KnownSymbol column1
391− , Has sch schemas schema
392− , Has tab schema ('Table table0)
393− , table0 ~ (constraints :=> columns)
394− , table1 ~ (constraints :=> Rename column0 column1 columns) )
395− => Alias column0 -- ^ column to rename
396− -> Alias column1 -- ^ what to rename the column
397− -> AlterTable sch tab schemas table1
398−renameColumn column0 column1 = UnsafeAlterTable $
399− "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
400−
401−-- | An `alterColumn` alters a single column.
402−alterColumn
403− :: ( KnownSymbol column
404− , Has sch schemas schema
405− , Has tab schema ('Table table0)
406− , table0 ~ (constraints :=> columns)
407− , Has column columns ty0
408− , table1 ~ (constraints :=> Alter column ty1 columns))
409− => Alias column -- ^ column to alter
410− -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
411− -> AlterTable sch tab schemas table1
412−alterColumn column alteration = UnsafeAlterTable $
413− "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
414−
415−-- | An `AlterColumn` describes the alteration to perform on a single column.
416−newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
417− UnsafeAlterColumn {renderAlterColumn :: ByteString}
418− deriving (GHC.Generic,Show,Eq,Ord,NFData)
419−
420−-- | A `setDefault` sets a new default for a column. Note that this doesn't
421−-- affect any existing rows in the table, it just changes the default for
422−-- future insert and update commands.
423−--
424−-- >>> :{
425−-- let
426−-- definition :: Definition
427−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
428−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
429−-- definition = alterTable #tab (alterColumn #col (setDefault 5))
430−-- in printSQL definition
431−-- :}
432−-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
433−setDefault
434− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
435− -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
436−setDefault expression = UnsafeAlterColumn $
437− "SET DEFAULT" <+> renderExpression expression
438−
439−-- | A `dropDefault` removes any default value for a column.
440−--
441−-- >>> :{
442−-- let
443−-- definition :: Definition
444−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
445−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
446−-- definition = alterTable #tab (alterColumn #col dropDefault)
447−-- in printSQL definition
448−-- :}
449−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
450−dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
451−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
452−
453−-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
454−-- The constraint will be checked immediately, so the table data must satisfy
455−-- the constraint before it can be added.
456−--
457−-- >>> :{
458−-- let
459−-- definition :: Definition
460−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
461−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
462−-- definition = alterTable #tab (alterColumn #col setNotNull)
463−-- in printSQL definition
464−-- :}
465−-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
466−setNotNull
467− :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
468−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
469−
470−-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
471−--
472−-- >>> :{
473−-- let
474−-- definition :: Definition
475−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
476−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
477−-- definition = alterTable #tab (alterColumn #col dropNotNull)
478−-- in printSQL definition
479−-- :}
480−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
481−dropNotNull
482− :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
483−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
484−
485−-- | An `alterType` converts a column to a different data type.
486−-- This will succeed only if each existing entry in the column can be
487−-- converted to the new type by an implicit cast.
488−--
489−-- >>> :{
490−-- let
491−-- definition :: Definition
492−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
493−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
494−-- definition =
495−-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
496−-- in printSQL definition
497−-- :}
498−-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
499−alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
500−alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table/Constraint.hsdeleted−339
@@ -1,339 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Table.Constraint
3−Description: Table constraint expressions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Table constraint expressions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Table.Constraint
33− ( TableConstraintExpression (..)
34− , check
35− , unique
36− , primaryKey
37− , foreignKey
38− , ForeignKeyed
39− , OnDeleteClause (..)
40− , OnUpdateClause (..)
41− ) where
42−
43−import Control.DeepSeq
44−import Data.ByteString
45−import GHC.TypeLits
46−
47−import qualified Generics.SOP as SOP
48−import qualified GHC.Generics as GHC
49−
50−import Squeal.PostgreSQL.Alias
51−import Squeal.PostgreSQL.Expression.Logic
52−import Squeal.PostgreSQL.List
53−import Squeal.PostgreSQL.Render
54−import Squeal.PostgreSQL.Schema
55−
56−-- $setup
57−-- >>> import Squeal.PostgreSQL
58−
59−-- | Data types are a way to limit the kind of data that can be stored in a
60−-- table. For many applications, however, the constraint they provide is
61−-- too coarse. For example, a column containing a product price should
62−-- probably only accept positive values. But there is no standard data type
63−-- that accepts only positive numbers. Another issue is that you might want
64−-- to constrain column data with respect to other columns or rows.
65−-- For example, in a table containing product information,
66−-- there should be only one row for each product number.
67−-- `TableConstraint`s give you as much control over the data in your tables
68−-- as you wish. If a user attempts to store data in a column that would
69−-- violate a constraint, an error is raised. This applies
70−-- even if the value came from the default value definition.
71−newtype TableConstraintExpression
72− (sch :: Symbol)
73− (tab :: Symbol)
74− (schemas :: SchemasType)
75− (constraint :: TableConstraint)
76− = UnsafeTableConstraintExpression
77− { renderTableConstraintExpression :: ByteString }
78− deriving (GHC.Generic,Show,Eq,Ord,NFData)
79−instance RenderSQL
80− (TableConstraintExpression sch tab schemas constraint) where
81− renderSQL = renderTableConstraintExpression
82−
83−{-| A `check` constraint is the most generic `TableConstraint` type.
84−It allows you to specify that the value in a certain column must satisfy
85−a Boolean (truth-value) expression.
86−
87−>>> :{
88−type Schema = '[
89− "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
90− "a" ::: 'NoDef :=> 'NotNull 'PGint4,
91− "b" ::: 'NoDef :=> 'NotNull 'PGint4
92− ])]
93−:}
94−
95−>>> :{
96−let
97− definition :: Definition (Public '[]) (Public Schema)
98− definition = createTable #tab
99− ( (int & notNullable) `as` #a :*
100− (int & notNullable) `as` #b )
101− ( check (#a :* #b) (#a .> #b) `as` #inequality )
102−:}
103−
104−>>> printSQL definition
105−CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
106−-}
107−check
108− :: ( Has sch schemas schema
109− , Has tab schema ('Table table)
110− , HasAll aliases (TableToRow table) subcolumns )
111− => NP Alias aliases
112− -- ^ specify the subcolumns which are getting checked
113− -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
114− -- ^ a closed `Condition` on those subcolumns
115− -> TableConstraintExpression sch tab schemas ('Check aliases)
116−check _cols condition = UnsafeTableConstraintExpression $
117− "CHECK" <+> parenthesized (renderSQL condition)
118−
119−{-| A `unique` constraint ensure that the data contained in a column,
120−or a group of columns, is unique among all the rows in the table.
121−
122−>>> :{
123−type Schema = '[
124− "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
125− "a" ::: 'NoDef :=> 'Null 'PGint4,
126− "b" ::: 'NoDef :=> 'Null 'PGint4
127− ])]
128−:}
129−
130−>>> :{
131−let
132− definition :: Definition (Public '[]) (Public Schema)
133− definition = createTable #tab
134− ( (int & nullable) `as` #a :*
135− (int & nullable) `as` #b )
136− ( unique (#a :* #b) `as` #uq_a_b )
137−:}
138−
139−>>> printSQL definition
140−CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
141−-}
142−unique
143− :: ( Has sch schemas schema
144− , Has tab schema('Table table)
145− , HasAll aliases (TableToRow table) subcolumns )
146− => NP Alias aliases
147− -- ^ specify subcolumns which together are unique for each row
148− -> TableConstraintExpression sch tab schemas ('Unique aliases)
149−unique columns = UnsafeTableConstraintExpression $
150− "UNIQUE" <+> parenthesized (renderSQL columns)
151−
152−{-| A `primaryKey` constraint indicates that a column, or group of columns,
153−can be used as a unique identifier for rows in the table.
154−This requires that the values be both unique and not null.
155−
156−>>> :{
157−type Schema = '[
158− "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
159− "id" ::: 'Def :=> 'NotNull 'PGint4,
160− "name" ::: 'NoDef :=> 'NotNull 'PGtext
161− ])]
162−:}
163−
164−>>> :{
165−let
166− definition :: Definition (Public '[]) (Public Schema)
167− definition = createTable #tab
168− ( serial `as` #id :*
169− (text & notNullable) `as` #name )
170− ( primaryKey #id `as` #pk_id )
171−:}
172−
173−>>> printSQL definition
174−CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
175−-}
176−primaryKey
177− :: ( Has sch schemas schema
178− , Has tab schema ('Table table)
179− , HasAll aliases (TableToColumns table) subcolumns
180− , AllNotNull subcolumns )
181− => NP Alias aliases
182− -- ^ specify the subcolumns which together form a primary key.
183− -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
184−primaryKey columns = UnsafeTableConstraintExpression $
185− "PRIMARY KEY" <+> parenthesized (renderSQL columns)
186−
187−{-| A `foreignKey` specifies that the values in a column
188−(or a group of columns) must match the values appearing in some row of
189−another table. We say this maintains the referential integrity
190−between two related tables.
191−
192−>>> :{
193−type Schema =
194− '[ "users" ::: 'Table (
195− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
196− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
197− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
198− ])
199− , "emails" ::: 'Table (
200− '[ "pk_emails" ::: 'PrimaryKey '["id"]
201− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
202− ] :=>
203− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
204− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
205− , "email" ::: 'NoDef :=> 'Null 'PGtext
206− ])
207− ]
208−:}
209−
210−>>> :{
211−let
212− setup :: Definition (Public '[]) (Public Schema)
213− setup =
214− createTable #users
215− ( serial `as` #id :*
216− (text & notNullable) `as` #name )
217− ( primaryKey #id `as` #pk_users ) >>>
218− createTable #emails
219− ( serial `as` #id :*
220− (int & notNullable) `as` #user_id :*
221− (text & nullable) `as` #email )
222− ( primaryKey #id `as` #pk_emails :*
223− foreignKey #user_id #users #id
224− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
225−in printSQL setup
226−:}
227−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
228−CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
229−
230−A `foreignKey` can even be a table self-reference.
231−
232−>>> :{
233−type Schema =
234− '[ "employees" ::: 'Table (
235− '[ "employees_pk" ::: 'PrimaryKey '["id"]
236− , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
237− ] :=>
238− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
239− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
240− , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
241− ])
242− ]
243−:}
244−
245−>>> :{
246−let
247− setup :: Definition (Public '[]) (Public Schema)
248− setup =
249− createTable #employees
250− ( serial `as` #id :*
251− (text & notNullable) `as` #name :*
252− (integer & nullable) `as` #employer_id )
253− ( primaryKey #id `as` #employees_pk :*
254− foreignKey #employer_id #employees #id
255− OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
256−in printSQL setup
257−:}
258−CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
259−-}
260−foreignKey
261− :: (ForeignKeyed schemas sch schema child parent
262− table reftable
263− columns refcolumns
264− constraints cols
265− reftys tys )
266− => NP Alias columns
267− -- ^ column or columns in the table
268− -> Alias parent
269− -- ^ reference table
270− -> NP Alias refcolumns
271− -- ^ reference column or columns in the reference table
272− -> OnDeleteClause
273− -- ^ what to do when reference is deleted
274− -> OnUpdateClause
275− -- ^ what to do when reference is updated
276− -> TableConstraintExpression sch child schemas
277− ('ForeignKey columns parent refcolumns)
278−foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
279− "FOREIGN KEY" <+> parenthesized (renderSQL keys)
280− <+> "REFERENCES" <+> renderSQL parent
281− <+> parenthesized (renderSQL refs)
282− <+> renderSQL ondel
283− <+> renderSQL onupd
284−
285−-- | A constraint synonym between types involved in a foreign key constraint.
286−type ForeignKeyed schemas
287− sch
288− schema
289− child parent
290− table reftable
291− columns refcolumns
292− constraints cols
293− reftys tys =
294− ( Has sch schemas schema
295− , Has child schema ('Table table)
296− , Has parent schema ('Table reftable)
297− , HasAll columns (TableToColumns table) tys
298− , reftable ~ (constraints :=> cols)
299− , HasAll refcolumns cols reftys
300− , SOP.AllZip SamePGType tys reftys
301− , Uniquely refcolumns constraints )
302−
303−-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
304−data OnDeleteClause
305− = OnDeleteNoAction
306− -- ^ if any referencing rows still exist when the constraint is checked,
307− -- an error is raised
308− | OnDeleteRestrict -- ^ prevents deletion of a referenced row
309− | OnDeleteCascade
310− -- ^ specifies that when a referenced row is deleted,
311− -- row(s) referencing it should be automatically deleted as well
312− deriving (GHC.Generic,Show,Eq,Ord)
313−instance NFData OnDeleteClause
314−-- | Render `OnDeleteClause`.
315−instance RenderSQL OnDeleteClause where
316− renderSQL = \case
317− OnDeleteNoAction -> "ON DELETE NO ACTION"
318− OnDeleteRestrict -> "ON DELETE RESTRICT"
319− OnDeleteCascade -> "ON DELETE CASCADE"
320−
321−-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
322−-- when a referenced column is changed (updated).
323−data OnUpdateClause
324− = OnUpdateNoAction
325− -- ^ if any referencing rows has not changed when the constraint is checked,
326− -- an error is raised
327− | OnUpdateRestrict -- ^ prevents update of a referenced row
328− | OnUpdateCascade
329− -- ^ the updated values of the referenced column(s) should be copied
330− -- into the referencing row(s)
331− deriving (GHC.Generic,Show,Eq,Ord)
332−instance NFData OnUpdateClause
333−
334−-- | Render `OnUpdateClause`.
335−instance RenderSQL OnUpdateClause where
336− renderSQL = \case
337− OnUpdateNoAction -> "ON UPDATE NO ACTION"
338− OnUpdateRestrict -> "ON UPDATE RESTRICT"
339− OnUpdateCascade -> "ON UPDATE CASCADE"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hsdeleted−229
@@ -1,229 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Type
3−Description: Create and drop type definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop type definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Type
33− ( createTypeEnum
34− , createTypeEnumFrom
35− , createTypeComposite
36− , createTypeCompositeFrom
37− , createTypeRange
38− , createDomain
39− , dropType
40− , dropTypeIfExists
41− ) where
42−
43−import Data.ByteString
44−import Data.Monoid
45−import GHC.TypeLits
46−import Prelude hiding ((.), id)
47−
48−import qualified Generics.SOP as SOP
49−
50−import Squeal.PostgreSQL.Alias
51−import Squeal.PostgreSQL.Expression.Logic
52−import Squeal.PostgreSQL.Expression.Type
53−import Squeal.PostgreSQL.Definition
54−import Squeal.PostgreSQL.List
55−import Squeal.PostgreSQL.PG
56−import Squeal.PostgreSQL.Render
57−import Squeal.PostgreSQL.Schema
58−
59−-- $setup
60−-- >>> import Squeal.PostgreSQL
61−-- >>> import qualified GHC.Generics as GHC
62−-- >>> import qualified Generics.SOP as SOP
63−
64−-- | Enumerated types are created using the `createTypeEnum` command, for example
65−--
66−-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
67−-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
68−createTypeEnum
69− :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
70− => QualifiedAlias sch enum
71− -- ^ name of the user defined enumerated type
72− -> NP PGlabel labels
73− -- ^ labels of the enumerated type
74− -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
75−createTypeEnum enum labels = UnsafeDefinition $
76− "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
77− parenthesized (renderSQL labels) <> ";"
78−
79−-- | Enumerated types can also be generated from a Haskell type, for example
80−--
81−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
82−-- >>> instance SOP.Generic Schwarma
83−-- >>> instance SOP.HasDatatypeInfo Schwarma
84−-- >>> :{
85−-- let
86−-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
87−-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
88−-- in
89−-- printSQL createSchwarma
90−-- :}
91−-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
92−createTypeEnumFrom
93− :: forall hask sch enum schemas schema.
94− ( SOP.Generic hask
95− , SOP.All KnownSymbol (LabelsPG hask)
96− , KnownSymbol enum
97− , Has sch schemas schema )
98− => QualifiedAlias sch enum
99− -- ^ name of the user defined enumerated type
100− -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
101−createTypeEnumFrom enum = createTypeEnum enum
102− (SOP.hpure label :: NP PGlabel (LabelsPG hask))
103−
104−{- | `createTypeComposite` creates a composite type. The composite type is
105−specified by a list of attribute names and data types.
106−
107−>>> :{
108−type PGcomplex = 'PGcomposite
109− '[ "real" ::: 'NotNull 'PGfloat8
110− , "imaginary" ::: 'NotNull 'PGfloat8 ]
111−:}
112−
113−>>> :{
114−let
115− setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
116− setup = createTypeComposite #complex
117− (float8 `as` #real :* float8 `as` #imaginary)
118−in printSQL setup
119−:}
120−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
121−-}
122−createTypeComposite
123− :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
124− => QualifiedAlias sch ty
125− -- ^ name of the user defined composite type
126− -> NP (Aliased (TypeExpression schemas)) fields
127− -- ^ list of attribute names and data types
128− -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
129−createTypeComposite ty fields = UnsafeDefinition $
130− "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
131− (renderCommaSeparated renderField fields) <> ";"
132− where
133− renderField :: Aliased (TypeExpression schemas) x -> ByteString
134− renderField (typ `As` alias) =
135− renderSQL alias <+> renderSQL typ
136−
137−-- | Composite types can also be generated from a Haskell type, for example
138−--
139−-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
140−-- >>> instance SOP.Generic Complex
141−-- >>> instance SOP.HasDatatypeInfo Complex
142−-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
143−-- >>> :{
144−-- let
145−-- createComplex :: Definition (Public '[]) (Public Schema)
146−-- createComplex = createTypeCompositeFrom @Complex #complex
147−-- in
148−-- printSQL createComplex
149−-- :}
150−-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
151−createTypeCompositeFrom
152− :: forall hask sch ty schemas schema.
153− ( SOP.All (FieldTyped schemas) (RowPG hask)
154− , KnownSymbol ty
155− , Has sch schemas schema )
156− => QualifiedAlias sch ty
157− -- ^ name of the user defined composite type
158− -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
159−createTypeCompositeFrom ty = createTypeComposite ty
160− (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
161− :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
162−
163−{-|
164−`createDomain` creates a new domain. A domain is essentially a data type
165−with constraints (restrictions on the allowed set of values).
166−
167−Domains are useful for abstracting common constraints on fields
168−into a single location for maintenance. For example, several tables might
169−contain email address columns, all requiring the same `check` constraint
170−to verify the address syntax. Define a domain rather than setting up
171−each table's constraint individually.
172−
173−>>> :{
174−let
175− createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
176− createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
177−in printSQL createPositive
178−:}
179−CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
180−-}
181−createDomain
182− :: (Has sch schemas schema, KnownSymbol dom)
183− => QualifiedAlias sch dom
184− -> (forall null. TypeExpression schemas (null ty))
185− -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
186− -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)
187−createDomain dom ty condition =
188− UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
189− <+> "AS" <+> renderTypeExpression ty
190− <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
191−
192−{- |
193−>>> :{
194−let
195− createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)])
196− createSmallIntRange = createTypeRange #int2range int2
197−in printSQL createSmallIntRange
198−:}
199−CREATE TYPE "int2range" AS RANGE (subtype = int2);
200−-}
201−createTypeRange
202− :: (Has sch schemas schema, KnownSymbol range)
203− => QualifiedAlias sch range
204− -> (forall null. TypeExpression schemas (null ty))
205− -> Definition schemas (Alter sch (Create range ('Typedef ('PGrange ty)) schema) schemas)
206−createTypeRange range ty = UnsafeDefinition $
207− "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>
208− parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";"
209−
210−-- | Drop a type.
211−--
212−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
213−-- >>> instance SOP.Generic Schwarma
214−-- >>> instance SOP.HasDatatypeInfo Schwarma
215−-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
216−-- DROP TYPE "schwarma";
217−dropType
218− :: (Has sch schemas schema, KnownSymbol td)
219− => QualifiedAlias sch td
220− -- ^ name of the user defined type
221− -> Definition schemas (Alter sch (DropSchemum td 'Typedef schema) schemas)
222−dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
223−
224−dropTypeIfExists
225− :: (Has sch schemas schema, KnownSymbol td)
226− => QualifiedAlias sch td
227− -- ^ name of the user defined type
228− -> Definition schemas (Alter sch (DropSchemumIfExists td 'Typedef schema) schemas)
229−dropTypeIfExists tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.View
3−Description: Create and drop view definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop view definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.View
33− ( createView
34− , createOrReplaceView
35− , dropView
36− , dropViewIfExists
37− ) where
38−
39−import GHC.TypeLits
40−
41−import Squeal.PostgreSQL.Alias
42−import Squeal.PostgreSQL.Definition
43−import Squeal.PostgreSQL.Query
44−import Squeal.PostgreSQL.Render
45−import Squeal.PostgreSQL.Schema
46−
47−-- $setup
48−-- >>> import Squeal.PostgreSQL
49−
50−{- | Create a view.
51−>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
52−>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
53−>>> :{
54−let
55− definition :: Definition
56− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
57− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
58− definition =
59− createView #bc (select_ (#b :* #c) (from (table #abc)))
60−in printSQL definition
61−:}
62−CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
63−-}
64−createView
65− :: (Has sch schemas schema, KnownSymbol vw)
66− => QualifiedAlias sch vw -- ^ the name of the view to add
67− -> Query '[] '[] schemas '[] view -- ^ query
68− -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
69−createView alias query = UnsafeDefinition $
70− "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
71− <+> renderQuery query <> ";"
72−
73−createOrReplaceView
74− :: (Has sch schemas schema, KnownSymbol vw)
75− => QualifiedAlias sch vw -- ^ the name of the view to add
76− -> Query '[] '[] schemas '[] view -- ^ query
77− -> Definition schemas (Alter sch (CreateOrReplace vw ('View view) schema) schemas)
78−createOrReplaceView alias query = UnsafeDefinition $
79− "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS"
80− <+> renderQuery query <> ";"
81−
82−-- | Drop a view.
83−--
84−-- >>> :{
85−-- let
86−-- definition :: Definition
87−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
88−-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
89−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
90−-- definition = dropView #bc
91−-- in printSQL definition
92−-- :}
93−-- DROP VIEW "bc";
94−dropView
95− :: (Has sch schemas schema, KnownSymbol vw)
96− => QualifiedAlias sch vw -- ^ view to remove
97− -> Definition schemas (Alter sch (DropSchemum vw 'View schema) schemas)
98−dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
99−
100−dropViewIfExists
101− :: (Has sch schemas schema, KnownSymbol vw)
102− => QualifiedAlias sch vw -- ^ view to remove
103− -> Definition schemas (Alter sch (DropIfExists vw schema) schemas)
104−dropViewIfExists vw = UnsafeDefinition $ "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+1095−364
@@ -1,17 +1,19 @@
11{-|
2−Module: Squeal.PostgreSQL.Expression
2+Module: Squeal.PostgreSQL.Query
33Description: Squeal expressions
4−Copyright: (c) Eitan Chatav, 2019
4+Copyright: (c) Eitan Chatav, 2017
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
88Squeal expressions are the atoms used to build statements.
99-}
1010
11+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
1112{-# LANGUAGE
1213 AllowAmbiguousTypes
13− , ConstraintKinds
14+ , DataKinds
1415 , DeriveGeneric
16+ , DeriveDataTypeable
1517 , FlexibleContexts
1618 , FlexibleInstances
1719 , FunctionalDependencies
@@ -20,6 +22,8 @@ Squeal expressions are the atoms used to build statements.
2022 , LambdaCase
2123 , MagicHash
2224 , OverloadedStrings
25+ , PolyKinds
26+ , RankNTypes
2327 , ScopedTypeVariables
2428 , StandaloneDeriving
2529 , TypeApplications
@@ -27,356 +31,364 @@ Squeal expressions are the atoms used to build statements.
2731 , TypeInType
2832 , TypeOperators
2933 , UndecidableInstances
30− , RankNTypes
3134#-}
3235
33−module Squeal.PostgreSQL.Expression
36+module Squeal.PostgreSQL.Expression
3437 ( -- * 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
38+ Expression (UnsafeExpression, renderExpression)
39+ , HasParameter (param)
40+ -- ** Null
41+ , null_
42+ , unNull
43+ , coalesce
44+ , fromNull
45+ , isNull
46+ , isn'tNull
47+ , matchNull
48+ , nullIf
49+ -- ** Arrays
50+ , array
51+ -- ** Functions
4752 , unsafeBinaryOp
48− , binaryOp
49− , FunctionVar
50− , unsafeFunctionVar
51− , type (--->)
52− , FunctionNDB
53− , unsafeFunctionN
54− , functionN
55− , PGSubset (..)
56− , PGIntersect (..)
53+ , unsafeUnaryOp
54+ , unsafeFunction
55+ , atan2_
56+ , cast
57+ , quot_
58+ , rem_
59+ , trunc
60+ , round_
61+ , ceiling_
62+ , greatest
63+ , least
64+ -- ** Conditions
65+ , Condition
66+ , true
67+ , false
68+ , not_
69+ , (.&&)
70+ , (.||)
71+ , caseWhenThenElse
72+ , ifThenElse
73+ , (.==)
74+ , (./=)
75+ , (.>=)
76+ , (.<)
77+ , (.<=)
78+ , (.>)
79+ -- ** Time
80+ , currentDate
81+ , currentTime
82+ , currentTimestamp
83+ , localTime
84+ , localTimestamp
85+ -- ** Text
86+ , lower
87+ , upper
88+ , charLength
89+ , like
90+ -- ** Aggregation
91+ , unsafeAggregate, unsafeAggregateDistinct
92+ , sum_, sumDistinct
93+ , PGAvg (avg, avgDistinct)
94+ , bitAnd, bitOr, boolAnd, boolOr
95+ , bitAndDistinct, bitOrDistinct, boolAndDistinct, boolOrDistinct
96+ , countStar
97+ , count, countDistinct
98+ , every, everyDistinct
99+ , max_, maxDistinct, min_, minDistinct
100+ -- * Tables
101+ , Table (UnsafeTable, renderTable)
102+ -- * Types
103+ , TypeExpression (UnsafeTypeExpression, renderTypeExpression)
104+ , PGTyped (pgtype)
105+ , bool
106+ , int2
107+ , smallint
108+ , int4
109+ , int
110+ , integer
111+ , int8
112+ , bigint
113+ , numeric
114+ , float4
115+ , real
116+ , float8
117+ , doublePrecision
118+ , serial2
119+ , smallserial
120+ , serial4
121+ , serial
122+ , serial8
123+ , bigserial
124+ , text
125+ , char
126+ , character
127+ , varchar
128+ , characterVarying
129+ , bytea
130+ , timestamp
131+ , timestampWithTimeZone
132+ , date
133+ , time
134+ , timeWithTimeZone
135+ , interval
136+ , uuid
137+ , inet
138+ , json
139+ , jsonb
140+ , vararray
141+ , fixarray
142+ , notNull
143+ , default_
57144 -- * Re-export
58145 , (&)
59− , K (..)
60− , unK
146+ , NP ((:*), Nil)
61147 ) where
62148
63149import Control.Category
64150import Control.DeepSeq
65151import Data.ByteString (ByteString)
66152import Data.Function ((&))
67−import Data.Semigroup hiding (All)
153+import Data.Monoid hiding (All)
154+import Data.Ratio
68155import Data.String
69−import Generics.SOP hiding (All, from)
156+import Generics.SOP hiding (from)
70157import GHC.OverloadedLabels
71158import GHC.TypeLits
72−import Numeric
73159import Prelude hiding (id, (.))
74160
75161import qualified GHC.Generics as GHC
76162
77−import Squeal.PostgreSQL.Alias
78−import Squeal.PostgreSQL.List
79163import Squeal.PostgreSQL.Render
80164import Squeal.PostgreSQL.Schema
81165
82−-- $setup
83−-- >>> import Squeal.PostgreSQL
84−
85166{-----------------------------------------
86167column expressions
87168-----------------------------------------}
88169
89170{- | `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.
171+such as in the target list of the `select` command,
172+as new column values in `insertInto` or `update`,
173+or in search `Condition`s in a number of commands.
95174
96175The expression syntax allows the calculation of
97176values from primitive expression using arithmetic, logical,
98177and 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`.
113178-}
114179newtype Expression
115− (outer :: FromType)
116− (commons :: FromType)
117− (grp :: Grouping)
118− (schemas :: SchemasType)
180+ (relations :: RelationsType)
181+ (grouping :: Grouping)
119182 (params :: [NullityType])
120− (from :: FromType)
121183 (ty :: NullityType)
122184 = UnsafeExpression { renderExpression :: ByteString }
123185 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)
186+
187+{- | A `HasParameter` constraint is used to indicate a value that is
188+supplied externally to a SQL statement.
189+`Squeal.PostgreSQL.PQ.manipulateParams`,
190+`Squeal.PostgreSQL.PQ.queryParams` and
191+`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values
192+separately from the SQL command string, in which case `param`s are used to
193+refer to the out-of-line data values.
210194-}
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
195+class (PGTyped (PGTypeOf ty), KnownNat n) => HasParameter
196+ (n :: Nat)
197+ (params :: [NullityType])
198+ (ty :: NullityType)
199+ | n params -> ty where
200+ param :: Expression relations grouping params ty
201+ param = UnsafeExpression $ parenthesized $
202+ "$" <> renderNat (Proxy @n) <+> "::"
203+ <+> renderTypeExpression (pgtype @(PGTypeOf ty))
204+instance {-# OVERLAPPING #-} PGTyped (PGTypeOf ty1)
205+ => HasParameter 1 (ty1:tys) ty1
206+instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
207+ => HasParameter n (ty' : params) ty
245208
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
209+instance (HasUnique relation relations columns, Has column columns ty)
210+ => IsLabel column (Expression relations 'Ungrouped params ty) where
211+ fromLabel = UnsafeExpression $ renderAlias (Alias @column)
277212
213+instance (Has relation relations columns, Has column columns ty)
214+ => IsQualified relation column (Expression relations 'Ungrouped params ty) where
215+ relation ! column = UnsafeExpression $
216+ renderAlias relation <> "." <> renderAlias column
217+
278218instance
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
219+ ( HasUnique relation relations columns
220+ , Has column columns ty
221+ , GroupedBy relation column bys
222+ ) => IsLabel column
223+ (Expression relations ('Grouped bys) params ty) where
224+ fromLabel = UnsafeExpression $ renderAlias (Alias @column)
225+
294226instance
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
227+ ( Has relation relations columns
228+ , Has column columns ty
229+ , GroupedBy relation column bys
230+ ) => IsQualified relation column
231+ (Expression relations ('Grouped bys) params ty) where
232+ relation ! column = UnsafeExpression $
233+ renderAlias relation <> "." <> renderAlias column
234+
235+-- | analagous to `Nothing`
236+--
237+-- >>> renderExpression $ null_
238+-- "NULL"
239+null_ :: Expression relations grouping params ('Null ty)
240+null_ = UnsafeExpression "NULL"
241+
242+-- | analagous to `Just`
243+--
244+-- >>> renderExpression $ unNull true
245+-- "TRUE"
246+unNull
247+ :: Expression relations grouping params ('NotNull ty)
248+ -- ^ not @NULL@
249+ -> Expression relations grouping params ('Null ty)
250+unNull = UnsafeExpression . renderExpression
251+
252+-- | return the leftmost value which is not NULL
253+--
254+-- >>> renderExpression $ coalesce [null_, unNull true] false
255+-- "COALESCE(NULL, TRUE, FALSE)"
256+coalesce
257+ :: [Expression relations grouping params ('Null ty)]
258+ -- ^ @NULL@s may be present
259+ -> Expression relations grouping params ('NotNull ty)
260+ -- ^ @NULL@ is absent
261+ -> Expression relations grouping params ('NotNull ty)
262+coalesce nullxs notNullx = UnsafeExpression $
263+ "COALESCE" <> parenthesized (commaSeparated
264+ ((renderExpression <$> nullxs) <> [renderExpression notNullx]))
265+
266+-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@
267+--
268+-- >>> renderExpression $ fromNull true null_
269+-- "COALESCE(NULL, TRUE)"
270+fromNull
271+ :: Expression relations grouping params ('NotNull ty)
272+ -- ^ what to convert @NULL@ to
273+ -> Expression relations grouping params ('Null ty)
274+ -> Expression relations grouping params ('NotNull ty)
275+fromNull notNullx nullx = coalesce [nullx] notNullx
276+
277+-- | >>> renderExpression $ null_ & isNull
278+-- "NULL IS NULL"
279+isNull
280+ :: Expression relations grouping params ('Null ty)
281+ -- ^ possibly @NULL@
282+ -> Condition relations grouping params
283+isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL"
284+
285+-- | >>> renderExpression $ null_ & isn'tNull
286+-- "NULL IS NOT NULL"
287+isn'tNull
288+ :: Expression relations grouping params ('Null ty)
289+ -- ^ possibly @NULL@
290+ -> Condition relations grouping params
291+isn'tNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL"
292+
293+-- | analagous to `maybe` using @IS NULL@
294+--
295+-- >>> renderExpression $ matchNull true not_ null_
296+-- "CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END"
297+matchNull
298+ :: Expression relations grouping params (nullty)
299+ -- ^ what to convert @NULL@ to
300+ -> ( Expression relations grouping params ('NotNull ty)
301+ -> Expression relations grouping params (nullty) )
302+ -- ^ function to perform when @NULL@ is absent
303+ -> Expression relations grouping params ('Null ty)
304+ -> Expression relations grouping params (nullty)
305+matchNull y f x = ifThenElse (isNull x) y
306+ (f (UnsafeExpression (renderExpression x)))
307+
308+-- | right inverse to `fromNull`, if its arguments are equal then
309+-- `nullIf` gives @NULL@.
310+--
311+-- >>> :set -XTypeApplications -XDataKinds
312+-- >>> renderExpression @_ @_ @'[_] $ fromNull false (nullIf false (param @1))
313+-- "COALESCE(NULL IF (FALSE, ($1 :: bool)), FALSE)"
314+nullIf
315+ :: Expression relations grouping params ('NotNull ty)
316+ -- ^ @NULL@ is absent
317+ -> Expression relations grouping params ('NotNull ty)
318+ -- ^ @NULL@ is absent
319+ -> Expression relations grouping params ('Null ty)
320+nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized
321+ (renderExpression x <> ", " <> renderExpression y)
322+
323+-- | >>> renderExpression $ array [null_, unNull false, unNull true]
324+-- "ARRAY[NULL, FALSE, TRUE]"
325+array
326+ :: [Expression relations grouping params ('Null ty)]
327+ -- ^ array elements
328+ -> Expression relations grouping params (nullity ('PGvararray ty))
329+array xs = UnsafeExpression $
330+ "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]"
331+
332+instance Monoid
333+ (Expression relations grouping params (nullity ('PGvararray ty))) where
334+ mempty = array []
335+ mappend = unsafeBinaryOp "||"
336+
337+-- | >>> renderExpression @_ @_ @'[_] $ greatest currentTimestamp [param @1]
338+-- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))"
339+greatest
340+ :: Expression relations grouping params (nullty)
341+ -- ^ needs at least 1 argument
342+ -> [Expression relations grouping params (nullty)]
343+ -- ^ or more
344+ -> Expression relations grouping params (nullty)
345+greatest x xs = UnsafeExpression $ "GREATEST("
346+ <> commaSeparated (renderExpression <$> (x:xs)) <> ")"
347+
348+-- | >>> renderExpression $ least currentTimestamp [null_]
349+-- "LEAST(CURRENT_TIMESTAMP, NULL)"
350+least
351+ :: Expression relations grouping params (nullty)
352+ -- ^ needs at least 1 argument
353+ -> [Expression relations grouping params (nullty)]
354+ -- ^ or more
355+ -> Expression relations grouping params (nullty)
356+least x xs = UnsafeExpression $ "LEAST("
357+ <> commaSeparated (renderExpression <$> (x:xs)) <> ")"
358+
359+-- | >>> renderExpression $ unsafeBinaryOp "OR" true false
360+-- "(TRUE OR FALSE)"
361+unsafeBinaryOp
362+ :: ByteString
363+ -- ^ operator
364+ -> Expression relations grouping params (ty0)
365+ -> Expression relations grouping params (ty1)
366+ -> Expression relations grouping params (ty2)
318367unsafeBinaryOp 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
368+ renderExpression x <+> op <+> renderExpression y
369+
370+-- | >>> renderExpression $ unsafeUnaryOp "NOT" true
371+-- "(NOT TRUE)"
372+unsafeUnaryOp
373+ :: ByteString
374+ -- ^ operator
375+ -> Expression relations grouping params (ty0)
376+ -> Expression relations grouping params (ty1)
377+unsafeUnaryOp op x = UnsafeExpression $ parenthesized $
378+ op <+> renderExpression x
379+
380+-- | >>> renderExpression $ unsafeFunction "f" true
381+-- "f(TRUE)"
382+unsafeFunction
383+ :: ByteString
384+ -- ^ function
385+ -> Expression relations grouping params (xty)
386+ -> Expression relations grouping params (yty)
355387unsafeFunction 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
388+ fun <> parenthesized (renderExpression x)
389+
390+instance PGNum ty
391+ => Num (Expression relations grouping params (nullity ty)) where
380392 (+) = unsafeBinaryOp "+"
381393 (-) = unsafeBinaryOp "-"
382394 (*) = unsafeBinaryOp "*"
@@ -387,24 +399,19 @@ instance ty `In` PGNum
387399 . fromString
388400 . show
389401
390−instance (ty `In` PGNum, ty `In` PGFloating) => Fractional
391− (Expression outer commons grp schemas params from (null ty)) where
402+instance (PGNum ty, PGFloating ty) => Fractional
403+ (Expression relations grouping params (nullity ty)) where
392404 (/) = unsafeBinaryOp "/"
393− fromRational
394− = UnsafeExpression
395− . fromString
396− . ($ "")
397− . showFFloat Nothing
398− . fromRat @Double
405+ fromRational x = fromInteger (numerator x) / fromInteger (denominator x)
399406
400−instance (ty `In` PGNum, ty `In` PGFloating) => Floating
401− (Expression outer commons grp schemas params from (null ty)) where
407+instance (PGNum ty, PGFloating ty) => Floating
408+ (Expression relations grouping params (nullity ty)) where
402409 pi = UnsafeExpression "pi()"
403410 exp = unsafeFunction "exp"
404411 log = unsafeFunction "ln"
405412 sqrt = unsafeFunction "sqrt"
406413 b ** x = UnsafeExpression $
407− "power(" <> renderSQL b <> ", " <> renderSQL x <> ")"
414+ "power(" <> renderExpression b <> ", " <> renderExpression x <> ")"
408415 logBase b y = log y / log b
409416 sin = unsafeFunction "sin"
410417 cos = unsafeFunction "cos"
@@ -419,54 +426,778 @@ instance (ty `In` PGNum, ty `In` PGFloating) => Floating
419426 acosh x = log (x + sqrt (x*x - 1))
420427 atanh x = log ((1 + x) / (1 - x)) / 2
421428
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)
429+-- | >>> :{
430+-- let
431+-- expression :: Expression relations grouping params (nullity 'PGfloat4)
432+-- expression = atan2_ pi 2
433+-- in renderExpression expression
434+-- :}
435+-- "atan2(pi(), 2)"
436+atan2_
437+ :: PGFloating float
438+ => Expression relations grouping params (nullity float)
439+ -- ^ numerator
440+ -> Expression relations grouping params (nullity float)
441+ -- ^ denominator
442+ -> Expression relations grouping params (nullity float)
443+atan2_ y x = UnsafeExpression $
444+ "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"
445+
446+-- When a `cast` is applied to an `Expression` of a known type, it
447+-- represents a run-time type conversion. The cast will succeed only if a
448+-- suitable type conversion operation has been defined.
449+--
450+-- | >>> renderExpression $ true & cast int4
451+-- "(TRUE :: int4)"
452+cast
453+ :: TypeExpression ('NoDef :=> 'Null ty1)
454+ -- ^ type to cast as
455+ -> Expression relations grouping params (nullity ty0)
456+ -- ^ value to convert
457+ -> Expression relations grouping params (nullity ty1)
458+cast ty x = UnsafeExpression $ parenthesized $
459+ renderExpression x <+> "::" <+> renderTypeExpression ty
460+
461+-- | integer division, truncates the result
462+--
463+-- >>> :{
464+-- let
465+-- expression :: Expression relations grouping params (nullity 'PGint2)
466+-- expression = 5 `quot_` 2
467+-- in renderExpression expression
468+-- :}
469+-- "(5 / 2)"
470+quot_
471+ :: PGIntegral int
472+ => Expression relations grouping params (nullity int)
473+ -- ^ numerator
474+ -> Expression relations grouping params (nullity int)
475+ -- ^ denominator
476+ -> Expression relations grouping params (nullity int)
477+quot_ = unsafeBinaryOp "/"
478+
479+-- | remainder upon integer division
480+--
481+-- >>> :{
482+-- let
483+-- expression :: Expression relations grouping params (nullity 'PGint2)
484+-- expression = 5 `rem_` 2
485+-- in renderExpression expression
486+-- :}
487+-- "(5 % 2)"
488+rem_
489+ :: PGIntegral int
490+ => Expression relations grouping params (nullity int)
491+ -- ^ numerator
492+ -> Expression relations grouping params (nullity int)
493+ -- ^ denominator
494+ -> Expression relations grouping params (nullity int)
495+rem_ = unsafeBinaryOp "%"
496+
497+-- | >>> :{
498+-- let
499+-- expression :: Expression relations grouping params (nullity 'PGfloat4)
500+-- expression = trunc pi
501+-- in renderExpression expression
502+-- :}
503+-- "trunc(pi())"
504+trunc
505+ :: PGFloating frac
506+ => Expression relations grouping params (nullity frac)
507+ -- ^ fractional number
508+ -> Expression relations grouping params (nullity frac)
509+trunc = unsafeFunction "trunc"
510+
511+-- | >>> :{
512+-- let
513+-- expression :: Expression relations grouping params (nullity 'PGfloat4)
514+-- expression = round_ pi
515+-- in renderExpression expression
516+-- :}
517+-- "round(pi())"
518+round_
519+ :: PGFloating frac
520+ => Expression relations grouping params (nullity frac)
521+ -- ^ fractional number
522+ -> Expression relations grouping params (nullity frac)
523+round_ = unsafeFunction "round"
524+
525+-- | >>> :{
526+-- let
527+-- expression :: Expression relations grouping params (nullity 'PGfloat4)
528+-- expression = ceiling_ pi
529+-- in renderExpression expression
530+-- :}
531+-- "ceiling(pi())"
532+ceiling_
533+ :: PGFloating frac
534+ => Expression relations grouping params (nullity frac)
535+ -- ^ fractional number
536+ -> Expression relations grouping params (nullity frac)
537+ceiling_ = unsafeFunction "ceiling"
538+
539+-- | A `Condition` is a boolean valued `Expression`. While SQL allows
540+-- conditions to have @NULL@, Squeal instead chooses to disallow @NULL@,
541+-- forcing one to handle the case of @NULL@ explicitly to produce
542+-- a `Condition`.
543+type Condition relations grouping params =
544+ Expression relations grouping params ('NotNull 'PGbool)
545+
546+-- | >>> renderExpression true
547+-- "TRUE"
548+true :: Condition relations grouping params
549+true = UnsafeExpression "TRUE"
550+
551+-- | >>> renderExpression false
552+-- "FALSE"
553+false :: Condition relations grouping params
554+false = UnsafeExpression "FALSE"
555+
556+-- | >>> renderExpression $ not_ true
557+-- "(NOT TRUE)"
558+not_
559+ :: Condition relations grouping params
560+ -> Condition relations grouping params
561+not_ = unsafeUnaryOp "NOT"
562+
563+-- | >>> renderExpression $ true .&& false
564+-- "(TRUE AND FALSE)"
565+(.&&)
566+ :: Condition relations grouping params
567+ -> Condition relations grouping params
568+ -> Condition relations grouping params
569+(.&&) = unsafeBinaryOp "AND"
570+
571+-- | >>> renderExpression $ true .|| false
572+-- "(TRUE OR FALSE)"
573+(.||)
574+ :: Condition relations grouping params
575+ -> Condition relations grouping params
576+ -> Condition relations grouping params
577+(.||) = unsafeBinaryOp "OR"
578+
579+-- | >>> :{
580+-- let
581+-- expression :: Expression relations grouping params (nullity 'PGint2)
582+-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3
583+-- in renderExpression expression
584+-- :}
585+-- "CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END"
586+caseWhenThenElse
587+ :: [ ( Condition relations grouping params
588+ , Expression relations grouping params (ty)
589+ ) ]
590+ -- ^ whens and thens
591+ -> Expression relations grouping params (ty)
592+ -- ^ else
593+ -> Expression relations grouping params (ty)
594+caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
595+ [ "CASE"
596+ , mconcat
597+ [ mconcat
598+ [ " WHEN ", renderExpression when_
599+ , " THEN ", renderExpression then_
600+ ]
601+ | (when_,then_) <- whenThens
602+ ]
603+ , " ELSE ", renderExpression else_
604+ , " END"
605+ ]
606+
607+-- | >>> :{
608+-- let
609+-- expression :: Expression relations grouping params (nullity 'PGint2)
610+-- expression = ifThenElse true 1 0
611+-- in renderExpression expression
612+-- :}
613+-- "CASE WHEN TRUE THEN 1 ELSE 0 END"
614+ifThenElse
615+ :: Condition relations grouping params
616+ -> Expression relations grouping params (ty) -- ^ then
617+ -> Expression relations grouping params (ty) -- ^ else
618+ -> Expression relations grouping params (ty)
619+ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
620+
621+-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`
622+-- will produce @NULL@s if one of their arguments is @NULL@.
623+--
624+-- >>> renderExpression $ unNull true .== null_
625+-- "(TRUE = NULL)"
626+(.==)
627+ :: Expression relations grouping params (nullity ty) -- ^ lhs
628+ -> Expression relations grouping params (nullity ty) -- ^ rhs
629+ -> Expression relations grouping params (nullity 'PGbool)
630+(.==) = unsafeBinaryOp "="
631+infix 4 .==
632+
633+-- | >>> renderExpression $ unNull true ./= null_
634+-- "(TRUE <> NULL)"
635+(./=)
636+ :: Expression relations grouping params (nullity ty) -- ^ lhs
637+ -> Expression relations grouping params (nullity ty) -- ^ rhs
638+ -> Expression relations grouping params (nullity 'PGbool)
639+(./=) = unsafeBinaryOp "<>"
640+infix 4 ./=
641+
642+-- | >>> renderExpression $ unNull true .>= null_
643+-- "(TRUE >= NULL)"
644+(.>=)
645+ :: Expression relations grouping params (nullity ty) -- ^ lhs
646+ -> Expression relations grouping params (nullity ty) -- ^ rhs
647+ -> Expression relations grouping params (nullity 'PGbool)
648+(.>=) = unsafeBinaryOp ">="
649+infix 4 .>=
650+
651+-- | >>> renderExpression $ unNull true .< null_
652+-- "(TRUE < NULL)"
653+(.<)
654+ :: Expression relations grouping params (nullity ty) -- ^ lhs
655+ -> Expression relations grouping params (nullity ty) -- ^ rhs
656+ -> Expression relations grouping params (nullity 'PGbool)
657+(.<) = unsafeBinaryOp "<"
658+infix 4 .<
659+
660+-- | >>> renderExpression $ unNull true .<= null_
661+-- "(TRUE <= NULL)"
662+(.<=)
663+ :: Expression relations grouping params (nullity ty) -- ^ lhs
664+ -> Expression relations grouping params (nullity ty) -- ^ rhs
665+ -> Expression relations grouping params (nullity 'PGbool)
666+(.<=) = unsafeBinaryOp "<="
667+infix 4 .<=
668+
669+-- | >>> renderExpression $ unNull true .> null_
670+-- "(TRUE > NULL)"
671+(.>)
672+ :: Expression relations grouping params (nullity ty) -- ^ lhs
673+ -> Expression relations grouping params (nullity ty) -- ^ rhs
674+ -> Expression relations grouping params (nullity 'PGbool)
675+(.>) = unsafeBinaryOp ">"
676+infix 4 .>
677+
678+-- | >>> renderExpression currentDate
679+-- "CURRENT_DATE"
680+currentDate
681+ :: Expression relations grouping params (nullity 'PGdate)
682+currentDate = UnsafeExpression "CURRENT_DATE"
683+
684+-- | >>> renderExpression currentTime
685+-- "CURRENT_TIME"
686+currentTime
687+ :: Expression relations grouping params (nullity 'PGtimetz)
688+currentTime = UnsafeExpression "CURRENT_TIME"
689+
690+-- | >>> renderExpression currentTimestamp
691+-- "CURRENT_TIMESTAMP"
692+currentTimestamp
693+ :: Expression relations grouping params (nullity 'PGtimestamptz)
694+currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"
695+
696+-- | >>> renderExpression localTime
697+-- "LOCALTIME"
698+localTime
699+ :: Expression relations grouping params (nullity 'PGtime)
700+localTime = UnsafeExpression "LOCALTIME"
701+
702+-- | >>> renderExpression localTimestamp
703+-- "LOCALTIMESTAMP"
704+localTimestamp
705+ :: Expression relations grouping params (nullity 'PGtimestamp)
706+localTimestamp = UnsafeExpression "LOCALTIMESTAMP"
707+
708+{-----------------------------------------
709+text
710+-----------------------------------------}
438711
439712instance IsString
440− (Expression outer commons grp schemas params from (null 'PGtext)) where
713+ (Expression relations grouping params (nullity 'PGtext)) where
441714 fromString str = UnsafeExpression $
442715 "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 "||"
716+ where
717+ escape = \case
718+ '\NUL' -> "\\0"
719+ '\'' -> "''"
720+ '"' -> "\\\""
721+ '\b' -> "\\b"
722+ '\n' -> "\\n"
723+ '\r' -> "\\r"
724+ '\t' -> "\\t"
725+ '\\' -> "\\\\"
726+ c -> [c]
464727
465728instance 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
729+ (Expression relations grouping params (nullity 'PGtext)) where
471730 mempty = fromString ""
472− mappend = (<>)
731+ mappend = unsafeBinaryOp "||"
732+
733+-- | >>> renderExpression $ lower "ARRRGGG"
734+-- "lower(E'ARRRGGG')"
735+lower
736+ :: Expression relations grouping params (nullity 'PGtext)
737+ -- ^ string to lower case
738+ -> Expression relations grouping params (nullity 'PGtext)
739+lower = unsafeFunction "lower"
740+
741+-- | >>> renderExpression $ upper "eeee"
742+-- "upper(E'eeee')"
743+upper
744+ :: Expression relations grouping params (nullity 'PGtext)
745+ -- ^ string to upper case
746+ -> Expression relations grouping params (nullity 'PGtext)
747+upper = unsafeFunction "upper"
748+
749+-- | >>> renderExpression $ charLength "four"
750+-- "char_length(E'four')"
751+charLength
752+ :: Expression relations grouping params (nullity 'PGtext)
753+ -- ^ string to measure
754+ -> Expression relations grouping params (nullity 'PGint4)
755+charLength = unsafeFunction "char_length"
756+
757+-- | The `like` expression returns true if the @string@ matches
758+-- the supplied @pattern@. If @pattern@ does not contain percent signs
759+-- or underscores, then the pattern only represents the string itself;
760+-- in that case `like` acts like the equals operator. An underscore (_)
761+-- in pattern stands for (matches) any single character; a percent sign (%)
762+-- matches any sequence of zero or more characters.
763+--
764+-- >>> renderExpression $ "abc" `like` "a%"
765+-- "(E'abc' LIKE E'a%')"
766+like
767+ :: Expression relations grouping params (nullity 'PGtext)
768+ -- ^ string
769+ -> Expression relations grouping params (nullity 'PGtext)
770+ -- ^ pattern
771+ -> Expression relations grouping params (nullity 'PGbool)
772+like = unsafeBinaryOp "LIKE"
773+
774+{-----------------------------------------
775+aggregation
776+-----------------------------------------}
777+
778+-- | escape hatch to define aggregate functions
779+unsafeAggregate
780+ :: ByteString -- ^ aggregate function
781+ -> Expression relations 'Ungrouped params (xty)
782+ -> Expression relations ('Grouped bys) params (yty)
783+unsafeAggregate fun x = UnsafeExpression $ mconcat
784+ [fun, "(", renderExpression x, ")"]
785+
786+-- | escape hatch to define aggregate functions over distinct values
787+unsafeAggregateDistinct
788+ :: ByteString -- ^ aggregate function
789+ -> Expression relations 'Ungrouped params (xty)
790+ -> Expression relations ('Grouped bys) params (yty)
791+unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat
792+ [fun, "(DISTINCT ", renderExpression x, ")"]
793+
794+-- | >>> :{
795+-- let
796+-- expression :: Expression '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric)
797+-- expression = sum_ #col
798+-- in renderExpression expression
799+-- :}
800+-- "sum(col)"
801+sum_
802+ :: PGNum ty
803+ => Expression relations 'Ungrouped params (nullity ty)
804+ -- ^ what to sum
805+ -> Expression relations ('Grouped bys) params (nullity ty)
806+sum_ = unsafeAggregate "sum"
807+
808+-- | >>> :{
809+-- let
810+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric)
811+-- expression = sumDistinct #col
812+-- in renderExpression expression
813+-- :}
814+-- "sum(DISTINCT col)"
815+sumDistinct
816+ :: PGNum ty
817+ => Expression relations 'Ungrouped params (nullity ty)
818+ -- ^ what to sum
819+ -> Expression relations ('Grouped bys) params (nullity ty)
820+sumDistinct = unsafeAggregateDistinct "sum"
821+
822+-- | A constraint for `PGType`s that you can take averages of and the resulting
823+-- `PGType`.
824+class PGAvg ty avg | ty -> avg where
825+ avg, avgDistinct
826+ :: Expression relations 'Ungrouped params (nullity ty)
827+ -- ^ what to average
828+ -> Expression relations ('Grouped bys) params (nullity avg)
829+ avg = unsafeAggregate "avg"
830+ avgDistinct = unsafeAggregateDistinct "avg"
831+instance PGAvg 'PGint2 'PGnumeric
832+instance PGAvg 'PGint4 'PGnumeric
833+instance PGAvg 'PGint8 'PGnumeric
834+instance PGAvg 'PGnumeric 'PGnumeric
835+instance PGAvg 'PGfloat4 'PGfloat8
836+instance PGAvg 'PGfloat8 'PGfloat8
837+instance PGAvg 'PGinterval 'PGinterval
838+
839+-- | >>> :{
840+-- let
841+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
842+-- expression = bitAnd #col
843+-- in renderExpression expression
844+-- :}
845+-- "bit_and(col)"
846+bitAnd
847+ :: PGIntegral int
848+ => Expression relations 'Ungrouped params (nullity int)
849+ -- ^ what to aggregate
850+ -> Expression relations ('Grouped bys) params (nullity int)
851+bitAnd = unsafeAggregate "bit_and"
852+
853+-- | >>> :{
854+-- let
855+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
856+-- expression = bitOr #col
857+-- in renderExpression expression
858+-- :}
859+-- "bit_or(col)"
860+bitOr
861+ :: PGIntegral int
862+ => Expression relations 'Ungrouped params (nullity int)
863+ -- ^ what to aggregate
864+ -> Expression relations ('Grouped bys) params (nullity int)
865+bitOr = unsafeAggregate "bit_or"
866+
867+-- | >>> :{
868+-- let
869+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
870+-- expression = bitAndDistinct #col
871+-- in renderExpression expression
872+-- :}
873+-- "bit_and(DISTINCT col)"
874+bitAndDistinct
875+ :: PGIntegral int
876+ => Expression relations 'Ungrouped params (nullity int)
877+ -- ^ what to aggregate
878+ -> Expression relations ('Grouped bys) params (nullity int)
879+bitAndDistinct = unsafeAggregateDistinct "bit_and"
880+
881+-- | >>> :{
882+-- let
883+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
884+-- expression = bitOrDistinct #col
885+-- in renderExpression expression
886+-- :}
887+-- "bit_or(DISTINCT col)"
888+bitOrDistinct
889+ :: PGIntegral int
890+ => Expression relations 'Ungrouped params (nullity int)
891+ -- ^ what to aggregate
892+ -> Expression relations ('Grouped bys) params (nullity int)
893+bitOrDistinct = unsafeAggregateDistinct "bit_or"
894+
895+-- | >>> :{
896+-- let
897+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
898+-- expression = boolAnd #col
899+-- in renderExpression expression
900+-- :}
901+-- "bool_and(col)"
902+boolAnd
903+ :: Expression relations 'Ungrouped params (nullity 'PGbool)
904+ -- ^ what to aggregate
905+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)
906+boolAnd = unsafeAggregate "bool_and"
907+
908+-- | >>> :{
909+-- let
910+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
911+-- expression = boolOr #col
912+-- in renderExpression expression
913+-- :}
914+-- "bool_or(col)"
915+boolOr
916+ :: Expression relations 'Ungrouped params (nullity 'PGbool)
917+ -- ^ what to aggregate
918+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)
919+boolOr = unsafeAggregate "bool_or"
920+
921+-- | >>> :{
922+-- let
923+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
924+-- expression = boolAndDistinct #col
925+-- in renderExpression expression
926+-- :}
927+-- "bool_and(DISTINCT col)"
928+boolAndDistinct
929+ :: Expression relations 'Ungrouped params (nullity 'PGbool)
930+ -- ^ what to aggregate
931+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)
932+boolAndDistinct = unsafeAggregateDistinct "bool_and"
933+
934+-- | >>> :{
935+-- let
936+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
937+-- expression = boolOrDistinct #col
938+-- in renderExpression expression
939+-- :}
940+-- "bool_or(DISTINCT col)"
941+boolOrDistinct
942+ :: Expression relations 'Ungrouped params (nullity 'PGbool)
943+ -- ^ what to aggregate
944+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)
945+boolOrDistinct = unsafeAggregateDistinct "bool_or"
946+
947+-- | A special aggregation that does not require an input
948+--
949+-- >>> renderExpression countStar
950+-- "count(*)"
951+countStar
952+ :: Expression relations ('Grouped bys) params ('NotNull 'PGint8)
953+countStar = UnsafeExpression $ "count(*)"
954+
955+-- | >>> :{
956+-- let
957+-- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)
958+-- expression = count #col
959+-- in renderExpression expression
960+-- :}
961+-- "count(col)"
962+count
963+ :: Expression relations 'Ungrouped params ty
964+ -- ^ what to count
965+ -> Expression relations ('Grouped bys) params ('NotNull 'PGint8)
966+count = unsafeAggregate "count"
967+
968+-- | >>> :{
969+-- let
970+-- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)
971+-- expression = countDistinct #col
972+-- in renderExpression expression
973+-- :}
974+-- "count(DISTINCT col)"
975+countDistinct
976+ :: Expression relations 'Ungrouped params ty
977+ -- ^ what to count
978+ -> Expression relations ('Grouped bys) params ('NotNull 'PGint8)
979+countDistinct = unsafeAggregateDistinct "count"
980+
981+-- | synonym for `boolAnd`
982+--
983+-- >>> :{
984+-- let
985+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
986+-- expression = every #col
987+-- in renderExpression expression
988+-- :}
989+-- "every(col)"
990+every
991+ :: Expression relations 'Ungrouped params (nullity 'PGbool)
992+ -- ^ what to aggregate
993+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)
994+every = unsafeAggregate "every"
995+
996+-- | synonym for `boolAndDistinct`
997+--
998+-- >>> :{
999+-- let
1000+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
1001+-- expression = everyDistinct #col
1002+-- in renderExpression expression
1003+-- :}
1004+-- "every(DISTINCT col)"
1005+everyDistinct
1006+ :: Expression relations 'Ungrouped params (nullity 'PGbool)
1007+ -- ^ what to aggregate
1008+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)
1009+everyDistinct = unsafeAggregateDistinct "every"
1010+
1011+-- | minimum and maximum aggregation
1012+max_, min_, maxDistinct, minDistinct
1013+ :: Expression relations 'Ungrouped params (nullity ty)
1014+ -- ^ what to aggregate
1015+ -> Expression relations ('Grouped bys) params (nullity ty)
1016+max_ = unsafeAggregate "max"
1017+min_ = unsafeAggregate "min"
1018+maxDistinct = unsafeAggregateDistinct "max"
1019+minDistinct = unsafeAggregateDistinct "min"
1020+
1021+{-----------------------------------------
1022+tables
1023+-----------------------------------------}
1024+
1025+-- | A `Table` from a table expression is a way
1026+-- to call a table reference by its alias.
1027+newtype Table
1028+ (schema :: TablesType)
1029+ (columns :: RelationType)
1030+ = UnsafeTable { renderTable :: ByteString }
1031+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
1032+instance
1033+ ( Has alias schema table
1034+ , relation ~ ColumnsToRelation (TableToColumns table)
1035+ ) => IsLabel alias (Table schema relation) where
1036+ fromLabel = UnsafeTable $ renderAlias (Alias @alias)
1037+
1038+{-----------------------------------------
1039+type expressions
1040+-----------------------------------------}
1041+
1042+-- | `TypeExpression`s are used in `cast`s and `createTable` commands.
1043+newtype TypeExpression (ty :: ColumnType)
1044+ = UnsafeTypeExpression { renderTypeExpression :: ByteString }
1045+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
1046+
1047+-- | logical Boolean (true/false)
1048+bool :: TypeExpression ('NoDef :=> 'Null 'PGbool)
1049+bool = UnsafeTypeExpression "bool"
1050+-- | signed two-byte integer
1051+int2, smallint :: TypeExpression ('NoDef :=> 'Null 'PGint2)
1052+int2 = UnsafeTypeExpression "int2"
1053+smallint = UnsafeTypeExpression "smallint"
1054+-- | signed four-byte integer
1055+int4, int, integer :: TypeExpression ('NoDef :=> 'Null 'PGint4)
1056+int4 = UnsafeTypeExpression "int4"
1057+int = UnsafeTypeExpression "int"
1058+integer = UnsafeTypeExpression "integer"
1059+-- | signed eight-byte integer
1060+int8, bigint :: TypeExpression ('NoDef :=> 'Null 'PGint8)
1061+int8 = UnsafeTypeExpression "int8"
1062+bigint = UnsafeTypeExpression "bigint"
1063+-- | arbitrary precision numeric type
1064+numeric :: TypeExpression ('NoDef :=> 'Null 'PGnumeric)
1065+numeric = UnsafeTypeExpression "numeric"
1066+-- | single precision floating-point number (4 bytes)
1067+float4, real :: TypeExpression ('NoDef :=> 'Null 'PGfloat4)
1068+float4 = UnsafeTypeExpression "float4"
1069+real = UnsafeTypeExpression "real"
1070+-- | double precision floating-point number (8 bytes)
1071+float8, doublePrecision :: TypeExpression ('NoDef :=> 'Null 'PGfloat8)
1072+float8 = UnsafeTypeExpression "float8"
1073+doublePrecision = UnsafeTypeExpression "double precision"
1074+-- | not a true type, but merely a notational convenience for creating
1075+-- unique identifier columns with type `'PGint2`
1076+serial2, smallserial
1077+ :: TypeExpression ('Def :=> 'NotNull 'PGint2)
1078+serial2 = UnsafeTypeExpression "serial2"
1079+smallserial = UnsafeTypeExpression "smallserial"
1080+-- | not a true type, but merely a notational convenience for creating
1081+-- unique identifier columns with type `'PGint4`
1082+serial4, serial
1083+ :: TypeExpression ('Def :=> 'NotNull 'PGint4)
1084+serial4 = UnsafeTypeExpression "serial4"
1085+serial = UnsafeTypeExpression "serial"
1086+-- | not a true type, but merely a notational convenience for creating
1087+-- unique identifier columns with type `'PGint8`
1088+serial8, bigserial
1089+ :: TypeExpression ('Def :=> 'NotNull 'PGint8)
1090+serial8 = UnsafeTypeExpression "serial8"
1091+bigserial = UnsafeTypeExpression "bigserial"
1092+-- | variable-length character string
1093+text :: TypeExpression ('NoDef :=> 'Null 'PGtext)
1094+text = UnsafeTypeExpression "text"
1095+-- | fixed-length character string
1096+char, character
1097+ :: (KnownNat n, 1 <= n)
1098+ => proxy n
1099+ -> TypeExpression ('NoDef :=> 'Null ('PGchar n))
1100+char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"
1101+character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"
1102+-- | variable-length character string
1103+varchar, characterVarying
1104+ :: (KnownNat n, 1 <= n)
1105+ => proxy n
1106+ -> TypeExpression ('NoDef :=> 'Null ('PGvarchar n))
1107+varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"
1108+characterVarying p = UnsafeTypeExpression $
1109+ "character varying(" <> renderNat p <> ")"
1110+-- | binary data ("byte array")
1111+bytea :: TypeExpression ('NoDef :=> 'Null 'PGbytea)
1112+bytea = UnsafeTypeExpression "bytea"
1113+-- | date and time (no time zone)
1114+timestamp :: TypeExpression ('NoDef :=> 'Null 'PGtimestamp)
1115+timestamp = UnsafeTypeExpression "timestamp"
1116+-- | date and time, including time zone
1117+timestampWithTimeZone :: TypeExpression ('NoDef :=> 'Null 'PGtimestamptz)
1118+timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
1119+-- | calendar date (year, month, day)
1120+date :: TypeExpression ('NoDef :=> 'Null 'PGdate)
1121+date = UnsafeTypeExpression "date"
1122+-- | time of day (no time zone)
1123+time :: TypeExpression ('NoDef :=> 'Null 'PGtime)
1124+time = UnsafeTypeExpression "time"
1125+-- | time of day, including time zone
1126+timeWithTimeZone :: TypeExpression ('NoDef :=> 'Null 'PGtimetz)
1127+timeWithTimeZone = UnsafeTypeExpression "time with time zone"
1128+-- | time span
1129+interval :: TypeExpression ('NoDef :=> 'Null 'PGinterval)
1130+interval = UnsafeTypeExpression "interval"
1131+-- | universally unique identifier
1132+uuid :: TypeExpression ('NoDef :=> 'Null 'PGuuid)
1133+uuid = UnsafeTypeExpression "uuid"
1134+-- | IPv4 or IPv6 host address
1135+inet :: TypeExpression ('NoDef :=> 'Null 'PGinet)
1136+inet = UnsafeTypeExpression "inet"
1137+-- | textual JSON data
1138+json :: TypeExpression ('NoDef :=> 'Null 'PGjson)
1139+json = UnsafeTypeExpression "json"
1140+-- | binary JSON data, decomposed
1141+jsonb :: TypeExpression ('NoDef :=> 'Null 'PGjsonb)
1142+jsonb = UnsafeTypeExpression "jsonb"
1143+-- | variable length array
1144+vararray
1145+ :: TypeExpression ('NoDef :=> 'Null pg)
1146+ -> TypeExpression ('NoDef :=> 'Null ('PGvararray pg))
1147+vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"
1148+-- | fixed length array
1149+--
1150+-- >>> renderTypeExpression (fixarray (Proxy @2) json)
1151+-- "json[2]"
1152+fixarray
1153+ :: KnownNat n
1154+ => proxy n
1155+ -> TypeExpression ('NoDef :=> 'Null pg)
1156+ -> TypeExpression ('NoDef :=> 'Null ('PGfixarray n pg))
1157+fixarray p ty = UnsafeTypeExpression $
1158+ renderTypeExpression ty <> "[" <> renderNat p <> "]"
1159+
1160+-- | used in `createTable` commands as a column constraint to ensure
1161+-- @NULL@ is not present
1162+notNull
1163+ :: TypeExpression (def :=> 'Null ty)
1164+ -> TypeExpression (def :=> 'NotNull ty)
1165+notNull ty = UnsafeTypeExpression $ renderTypeExpression ty <+> "NOT NULL"
1166+
1167+-- | used in `createTable` commands as a column constraint to give a default
1168+default_
1169+ :: Expression '[] 'Ungrouped '[] ty
1170+ -> TypeExpression ('NoDef :=> ty)
1171+ -> TypeExpression ('Def :=> ty)
1172+default_ x ty = UnsafeTypeExpression $
1173+ renderTypeExpression ty <+> "DEFAULT" <+> renderExpression x
1174+
1175+-- | `pgtype` is a demoted version of a `PGType`
1176+class PGTyped (ty :: PGType) where
1177+ pgtype :: TypeExpression ('NoDef :=> 'Null ty)
1178+instance PGTyped 'PGbool where pgtype = bool
1179+instance PGTyped 'PGint2 where pgtype = int2
1180+instance PGTyped 'PGint4 where pgtype = int4
1181+instance PGTyped 'PGint8 where pgtype = int8
1182+instance PGTyped 'PGnumeric where pgtype = numeric
1183+instance PGTyped 'PGfloat4 where pgtype = float4
1184+instance PGTyped 'PGfloat8 where pgtype = float8
1185+instance PGTyped 'PGtext where pgtype = text
1186+instance (KnownNat n, 1 <= n)
1187+ => PGTyped ('PGchar n) where pgtype = char (Proxy @n)
1188+instance (KnownNat n, 1 <= n)
1189+ => PGTyped ('PGvarchar n) where pgtype = varchar (Proxy @n)
1190+instance PGTyped 'PGbytea where pgtype = bytea
1191+instance PGTyped 'PGtimestamp where pgtype = timestamp
1192+instance PGTyped 'PGtimestamptz where pgtype = timestampWithTimeZone
1193+instance PGTyped 'PGdate where pgtype = date
1194+instance PGTyped 'PGtime where pgtype = time
1195+instance PGTyped 'PGtimetz where pgtype = timeWithTimeZone
1196+instance PGTyped 'PGinterval where pgtype = interval
1197+instance PGTyped 'PGuuid where pgtype = uuid
1198+instance PGTyped 'PGjson where pgtype = json
1199+instance PGTyped 'PGjsonb where pgtype = jsonb
1200+instance PGTyped ty => PGTyped ('PGvararray ty) where
1201+ pgtype = vararray (pgtype @ty)
1202+instance (KnownNat n, PGTyped ty) => PGTyped ('PGfixarray n ty) where
1203+ pgtype = fixarray (Proxy @n) (pgtype @ty)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hsdeleted−462
@@ -1,462 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Aggregate
3−Description: Aggregate functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Aggregate functions
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , DeriveGeneric
14− , FlexibleContexts
15− , FlexibleInstances
16− , FunctionalDependencies
17− , LambdaCase
18− , MultiParamTypeClasses
19− , OverloadedStrings
20− , PolyKinds
21− , TypeFamilies
22− , TypeOperators
23− , UndecidableInstances
24−#-}
25−
26−module Squeal.PostgreSQL.Expression.Aggregate
27− ( Aggregate (..)
28− , Distinction (..)
29− , PGSum
30− , PGAvg
31− ) where
32−
33−import Control.DeepSeq
34−import Data.ByteString (ByteString)
35−import Data.Kind
36−import GHC.TypeLits
37−
38−import qualified GHC.Generics as GHC
39−import qualified Generics.SOP as SOP
40−
41−import Squeal.PostgreSQL.Alias
42−import Squeal.PostgreSQL.Expression
43−import Squeal.PostgreSQL.List
44−import Squeal.PostgreSQL.Render
45−import Squeal.PostgreSQL.Schema
46−
47−-- $setup
48−-- >>> import Squeal.PostgreSQL
49−
50−{- |
51−`Aggregate` functions compute a single result from a set of input values.
52−`Aggregate` functions can be used as `GroupedBy` `Expression`s as well
53−as `Squeal.PostgreSQL.Expression.Window.WindowFunction`s.
54−-}
55−class Aggregate expr1 exprN aggr
56− | aggr -> expr1, aggr -> exprN where
57−
58− -- | A special aggregation that does not require an input
59− --
60− -- >>> :{
61− -- let
62− -- expression :: Expression '[] commons ('Grouped bys) schemas params from ('NotNull 'PGint8)
63− -- expression = countStar
64− -- in printSQL expression
65− -- :}
66− -- count(*)
67− countStar :: aggr ('NotNull 'PGint8)
68−
69− -- | >>> :{
70− -- let
71− -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null ty]] ('NotNull 'PGint8)
72− -- expression = count (All #col)
73− -- in printSQL expression
74− -- :}
75− -- count(ALL "col")
76− count
77− :: expr1 ty
78− -- ^ what to count
79− -> aggr ('NotNull 'PGint8)
80−
81− -- | >>> :{
82− -- let
83− -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric)
84− -- expression = sum_ (Distinct #col)
85− -- in printSQL expression
86− -- :}
87− -- sum(DISTINCT "col")
88− sum_
89− :: expr1 (null ty)
90− -> aggr ('Null (PGSum ty))
91−
92− -- | input values, including nulls, concatenated into an array
93− arrayAgg
94− :: expr1 ty
95− -> aggr ('Null ('PGvararray ty))
96−
97− -- | aggregates values as a JSON array
98− jsonAgg
99− :: expr1 ty
100− -> aggr ('Null 'PGjson)
101−
102− -- | aggregates values as a JSON array
103− jsonbAgg
104− :: expr1 ty
105− -> aggr ('Null 'PGjsonb)
106−
107− {- |
108− the bitwise AND of all non-null input values, or null if none
109−
110− >>> :{
111− let
112− expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)
113− expression = bitAnd (Distinct #col)
114− in printSQL expression
115− :}
116− bit_and(DISTINCT "col")
117− -}
118− bitAnd
119− :: int `In` PGIntegral
120− => expr1 (null int)
121− -- ^ what to aggregate
122− -> aggr ('Null int)
123−
124− {- |
125− the bitwise OR of all non-null input values, or null if none
126−
127− >>> :{
128− let
129− expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)
130− expression = bitOr (All #col)
131− in printSQL expression
132− :}
133− bit_or(ALL "col")
134− -}
135− bitOr
136− :: int `In` PGIntegral
137− => expr1 (null int)
138− -- ^ what to aggregate
139− -> aggr ('Null int)
140−
141− {- |
142− true if all input values are true, otherwise false
143−
144− >>> :{
145− let
146− winFun :: WindowFunction '[] commons 'Ungrouped schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)
147− winFun = boolAnd #col
148− in printSQL winFun
149− :}
150− bool_and("col")
151− -}
152− boolAnd
153− :: expr1 (null 'PGbool)
154− -- ^ what to aggregate
155− -> aggr ('Null 'PGbool)
156−
157− {- |
158− true if at least one input value is true, otherwise false
159−
160− >>> :{
161− let
162− expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)
163− expression = boolOr (All #col)
164− in printSQL expression
165− :}
166− bool_or(ALL "col")
167− -}
168− boolOr
169− :: expr1 (null 'PGbool)
170− -- ^ what to aggregate
171− -> aggr ('Null 'PGbool)
172−
173− {- |
174− equivalent to `boolAnd`
175−
176− >>> :{
177− let
178− expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)
179− expression = every (Distinct #col)
180− in printSQL expression
181− :}
182− every(DISTINCT "col")
183− -}
184− every
185− :: expr1 (null 'PGbool)
186− -- ^ what to aggregate
187− -> aggr ('Null 'PGbool)
188−
189− {- |maximum value of expression across all input values-}
190− max_
191− :: expr1 (null ty)
192− -- ^ what to maximize
193− -> aggr ('Null ty)
194−
195− -- | minimum value of expression across all input values
196− min_
197− :: expr1 (null ty)
198− -- ^ what to minimize
199− -> aggr ('Null ty)
200−
201− -- | the average (arithmetic mean) of all input values
202− avg
203− :: expr1 (null ty)
204− -- ^ what to average
205− -> aggr ('Null (PGAvg ty))
206−
207− {- | correlation coefficient
208−
209− >>> :{
210− let
211− expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
212− expression = corr (All (#y *: #x))
213− in printSQL expression
214− :}
215− corr(ALL "y", "x")
216− -}
217− corr
218− :: exprN '[null 'PGfloat8, null 'PGfloat8]
219− -> aggr ('Null 'PGfloat8)
220−
221− {- | population covariance
222−
223− >>> :{
224− let
225− expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
226− expression = covarPop (All (#y *: #x))
227− in printSQL expression
228− :}
229− covar_pop(ALL "y", "x")
230− -}
231− covarPop
232− :: exprN '[null 'PGfloat8, null 'PGfloat8]
233− -> aggr ('Null 'PGfloat8)
234−
235− {- | sample covariance
236−
237− >>> :{
238− let
239− winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
240− winFun = covarSamp (#y *: #x)
241− in printSQL winFun
242− :}
243− covar_samp("y", "x")
244− -}
245− covarSamp
246− :: exprN '[null 'PGfloat8, null 'PGfloat8]
247− -> aggr ('Null 'PGfloat8)
248−
249− {- | average of the independent variable (sum(X)/N)
250−
251− >>> :{
252− let
253− expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
254− expression = regrAvgX (All (#y *: #x))
255− in printSQL expression
256− :}
257− regr_avgx(ALL "y", "x")
258− -}
259− regrAvgX
260− :: exprN '[null 'PGfloat8, null 'PGfloat8]
261− -> aggr ('Null 'PGfloat8)
262−
263− {- | average of the dependent variable (sum(Y)/N)
264−
265− >>> :{
266− let
267− winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
268− winFun = regrAvgY (#y *: #x)
269− in printSQL winFun
270− :}
271− regr_avgy("y", "x")
272− -}
273− regrAvgY
274− :: exprN '[null 'PGfloat8, null 'PGfloat8]
275− -> aggr ('Null 'PGfloat8)
276−
277− {- | number of input rows in which both expressions are nonnull
278−
279− >>> :{
280− let
281− winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGint8)
282− winFun = regrCount (#y *: #x)
283− in printSQL winFun
284− :}
285− regr_count("y", "x")
286− -}
287− regrCount
288− :: exprN '[null 'PGfloat8, null 'PGfloat8]
289− -> aggr ('Null 'PGint8)
290−
291− {- | y-intercept of the least-squares-fit linear equation determined by the (X, Y) pairs
292− >>> :{
293− let
294− expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
295− expression = regrIntercept (All (#y *: #x))
296− in printSQL expression
297− :}
298− regr_intercept(ALL "y", "x")
299− -}
300− regrIntercept
301− :: exprN '[null 'PGfloat8, null 'PGfloat8]
302− -> aggr ('Null 'PGfloat8)
303−
304− -- | @regr_r2(Y, X)@, square of the correlation coefficient
305− regrR2
306− :: exprN '[null 'PGfloat8, null 'PGfloat8]
307− -> aggr ('Null 'PGfloat8)
308−
309− -- | @regr_slope(Y, X)@, slope of the least-squares-fit linear equation
310− -- determined by the (X, Y) pairs
311− regrSlope
312− :: exprN '[null 'PGfloat8, null 'PGfloat8]
313− -> aggr ('Null 'PGfloat8)
314−
315− -- | @regr_sxx(Y, X)@, sum(X^2) - sum(X)^2/N
316− -- (“sum of squares” of the independent variable)
317− regrSxx
318− :: exprN '[null 'PGfloat8, null 'PGfloat8]
319− -> aggr ('Null 'PGfloat8)
320−
321− -- | @regr_sxy(Y, X)@, sum(X*Y) - sum(X) * sum(Y)/N
322− -- (“sum of products” of independent times dependent variable)
323− regrSxy
324− :: exprN '[null 'PGfloat8, null 'PGfloat8]
325− -> aggr ('Null 'PGfloat8)
326−
327− -- | @regr_syy(Y, X)@, sum(Y^2) - sum(Y)^2/N
328− -- (“sum of squares” of the dependent variable)
329− regrSyy
330− :: exprN '[null 'PGfloat8, null 'PGfloat8]
331− -> aggr ('Null 'PGfloat8)
332−
333− -- | historical alias for `stddevSamp`
334− stddev
335− :: expr1 (null ty)
336− -> aggr ('Null (PGAvg ty))
337−
338− -- | population standard deviation of the input values
339− stddevPop
340− :: expr1 (null ty)
341− -> aggr ('Null (PGAvg ty))
342−
343− -- | sample standard deviation of the input values
344− stddevSamp
345− :: expr1 (null ty)
346− -> aggr ('Null (PGAvg ty))
347−
348− -- | historical alias for `varSamp`
349− variance
350− :: expr1 (null ty)
351− -> aggr ('Null (PGAvg ty))
352−
353− -- | population variance of the input values
354− -- (square of the population standard deviation)
355− varPop
356− :: expr1 (null ty)
357− -> aggr ('Null (PGAvg ty))
358−
359− -- | sample variance of the input values
360− -- (square of the sample standard deviation)
361− varSamp
362− :: expr1 (null ty)
363− -> aggr ('Null (PGAvg ty))
364−
365−{- |
366−`Distinction`s are used for the input of `Aggregate` `Expression`s.
367−`All` invokes the aggregate once for each input row.
368−`Distinct` invokes the aggregate once for each distinct value of the expression
369−(or distinct set of values, for multiple expressions) found in the input
370−-}
371−data Distinction (expr :: kind -> Type) (ty :: kind)
372− = All (expr ty)
373− | Distinct (expr ty)
374− deriving (GHC.Generic,Show,Eq,Ord)
375−instance NFData (Distinction (Expression outer commons grp schemas params from) ty)
376−instance RenderSQL (Distinction (Expression outer commons grp schemas params from) ty) where
377− renderSQL = \case
378− All x -> "ALL" <+> renderSQL x
379− Distinct x -> "DISTINCT" <+> renderSQL x
380−instance SOP.SListI tys => RenderSQL
381− (Distinction (NP (Expression outer commons grp schemas params from)) tys) where
382− renderSQL = \case
383− All xs -> "ALL" <+> renderCommaSeparated renderSQL xs
384− Distinct xs -> "DISTINCT" <+> renderCommaSeparated renderSQL xs
385−
386−instance Aggregate
387− (Distinction (Expression outer commons 'Ungrouped schemas params from))
388− (Distinction (NP (Expression outer commons 'Ungrouped schemas params from)))
389− (Expression outer commons ('Grouped bys) schemas params from) where
390− countStar = UnsafeExpression "count(*)"
391− count = unsafeAggregate1 "count"
392− sum_ = unsafeAggregate1 "sum"
393− arrayAgg = unsafeAggregate1 "array_agg"
394− jsonAgg = unsafeAggregate1 "json_agg"
395− jsonbAgg = unsafeAggregate1 "jsonb_agg"
396− bitAnd = unsafeAggregate1 "bit_and"
397− bitOr = unsafeAggregate1 "bit_or"
398− boolAnd = unsafeAggregate1 "bool_and"
399− boolOr = unsafeAggregate1 "bool_or"
400− every = unsafeAggregate1 "every"
401− max_ = unsafeAggregate1 "max"
402− min_ = unsafeAggregate1 "min"
403− avg = unsafeAggregate1 "avg"
404− corr = unsafeAggregateN "corr"
405− covarPop = unsafeAggregateN "covar_pop"
406− covarSamp = unsafeAggregateN "covar_samp"
407− regrAvgX = unsafeAggregateN "regr_avgx"
408− regrAvgY = unsafeAggregateN "regr_avgy"
409− regrCount = unsafeAggregateN "regr_count"
410− regrIntercept = unsafeAggregateN "regr_intercept"
411− regrR2 = unsafeAggregateN "regr_r2"
412− regrSlope = unsafeAggregateN "regr_slope"
413− regrSxx = unsafeAggregateN "regr_sxx"
414− regrSxy = unsafeAggregateN "regr_sxy"
415− regrSyy = unsafeAggregateN "regr_syy"
416− stddev = unsafeAggregate1 "stddev"
417− stddevPop = unsafeAggregate1 "stddev_pop"
418− stddevSamp = unsafeAggregate1 "stddev_samp"
419− variance = unsafeAggregate1 "variance"
420− varPop = unsafeAggregate1 "var_pop"
421− varSamp = unsafeAggregate1 "var_samp"
422−
423−-- | escape hatch to define aggregate functions
424−unsafeAggregate1
425− :: ByteString -- ^ aggregate function
426− -> Distinction (Expression outer commons 'Ungrouped schemas params from) x
427− -> Expression outer commons ('Grouped bys) schemas params from y
428−unsafeAggregate1 fun x = UnsafeExpression $ fun <> parenthesized (renderSQL x)
429−
430−unsafeAggregateN
431− :: SOP.SListI xs
432− => ByteString -- ^ function
433− -> Distinction (NP (Expression outer commons 'Ungrouped schemas params from)) xs
434− -> Expression outer commons ('Grouped bys) schemas params from y
435−unsafeAggregateN fun xs = UnsafeExpression $ fun <> parenthesized (renderSQL xs)
436−
437−-- | A type family that calculates `PGSum``PGType` of
438−-- a given argument `PGType`.
439−type family PGSum ty where
440− PGSum 'PGint2 = 'PGint8
441− PGSum 'PGint4 = 'PGint8
442− PGSum 'PGint8 = 'PGnumeric
443− PGSum 'PGfloat4 = 'PGfloat4
444− PGSum 'PGfloat8 = 'PGfloat8
445− PGSum 'PGnumeric = 'PGnumeric
446− PGSum 'PGinterval = 'PGinterval
447− PGSum 'PGmoney = 'PGmoney
448− PGSum pg = TypeError
449− ( 'Text "Squeal type error: Cannot sum with argument type "
450− ':<>: 'ShowType pg )
451−
452−-- | A type family that calculates `PGAvg` type of a `PGType`.
453−type family PGAvg ty where
454− PGAvg 'PGint2 = 'PGnumeric
455− PGAvg 'PGint4 = 'PGnumeric
456− PGAvg 'PGint8 = 'PGnumeric
457− PGAvg 'PGnumeric = 'PGnumeric
458− PGAvg 'PGfloat4 = 'PGfloat8
459− PGAvg 'PGfloat8 = 'PGfloat8
460− PGAvg 'PGinterval = 'PGinterval
461− PGAvg pg = TypeError
462− ('Text "Squeal type error: No average for " ':<>: 'ShowType pg)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hsdeleted−169
@@ -1,169 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Collection
3−Description: Array and composite functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Array and composite functions
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DataKinds
14− , FlexibleContexts
15− , FlexibleInstances
16− , MultiParamTypeClasses
17− , OverloadedLabels
18− , OverloadedStrings
19− , RankNTypes
20− , ScopedTypeVariables
21− , TypeApplications
22− , TypeFamilies
23− , TypeOperators
24− , UndecidableInstances
25−#-}
26−
27−module Squeal.PostgreSQL.Expression.Collection
28− ( array
29− , array1
30− , array2
31− , cardinality
32− , index
33− , unnest
34− , row
35− , field
36− ) where
37−
38−import Data.String
39−import Data.Word (Word64)
40−
41−import qualified Generics.SOP as SOP
42−
43−import Squeal.PostgreSQL.Alias
44−import Squeal.PostgreSQL.Expression
45−import Squeal.PostgreSQL.Expression.Set
46−import Squeal.PostgreSQL.List
47−import Squeal.PostgreSQL.Render
48−import Squeal.PostgreSQL.Schema
49−
50−-- $setup
51−-- >>> import Squeal.PostgreSQL
52−
53−-- | >>> printSQL $ array [null_, false, true]
54−-- ARRAY[NULL, FALSE, TRUE]
55−array
56− :: [Expression outer commons grp schemas params from ty]
57− -- ^ array elements
58− -> Expression outer commons grp schemas params from (null ('PGvararray ty))
59−array xs = UnsafeExpression $ "ARRAY" <>
60− bracketed (commaSeparated (renderSQL <$> xs))
61−
62−{- | construct a 1-dimensional fixed length array
63−
64−>>> printSQL $ array1 (null_ :* false *: true)
65−ARRAY[NULL, FALSE, TRUE]
66−
67−>>> :type array1 (null_ :* false *: true)
68−array1 (null_ :* false *: true)
69− :: Expression
70− outer
71− commons
72− grp
73− schemas
74− params
75− from
76− (null ('PGfixarray '[3] ('Null 'PGbool)))
77−-}
78−array1
79− :: (n ~ Length tys, SOP.All ((~) ty) tys)
80− => NP (Expression outer commons grp schemas params from) tys
81− -> Expression outer commons grp schemas params from (null ('PGfixarray '[n] ty))
82−array1 xs = UnsafeExpression $ "ARRAY" <>
83− bracketed (renderCommaSeparated renderSQL xs)
84−
85−{- | construct a 2-dimensional fixed length array
86−
87−>>> printSQL $ array2 ((null_ :* false *: true) *: (false :* null_ *: true))
88−ARRAY[[NULL, FALSE, TRUE], [FALSE, NULL, TRUE]]
89−
90−>>> :type array2 ((null_ :* false *: true) *: (false :* null_ *: true))
91−array2 ((null_ :* false *: true) *: (false :* null_ *: true))
92− :: Expression
93− outer
94− commons
95− grp
96− schemas
97− params
98− from
99− (null ('PGfixarray '[2, 3] ('Null 'PGbool)))
100−-}
101−array2
102− :: ( SOP.All ((~) tys) tyss
103− , SOP.All SOP.SListI tyss
104− , Length tyss ~ n1
105− , SOP.All ((~) ty) tys
106− , Length tys ~ n2 )
107− => NP (NP (Expression outer commons grp schemas params from)) tyss
108− -> Expression outer commons grp schemas params from (null ('PGfixarray '[n1,n2] ty))
109−array2 xss = UnsafeExpression $ "ARRAY" <>
110− bracketed (renderCommaSeparatedConstraint @SOP.SListI (bracketed . renderCommaSeparated renderSQL) xss)
111−
112−-- | >>> printSQL $ cardinality (array [null_, false, true])
113−-- cardinality(ARRAY[NULL, FALSE, TRUE])
114−cardinality :: null ('PGvararray ty) --> null 'PGint8
115−cardinality = unsafeFunction "cardinality"
116−
117−-- | >>> printSQL $ array [null_, false, true] & index 2
118−-- (ARRAY[NULL, FALSE, TRUE])[2]
119−index
120− :: Word64 -- ^ index
121− -> null ('PGvararray ty) --> NullifyType ty
122−index n expr = UnsafeExpression $
123− parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"
124−
125−-- | Expand an array to a set of rows
126−unnest :: SetFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
127−unnest = unsafeSetFunction
128−
129−-- | A row constructor is an expression that builds a row value
130−-- (also called a composite value) using values for its member fields.
131−--
132−-- >>> :{
133−-- type Complex = 'PGcomposite
134−-- '[ "real" ::: 'NotNull 'PGfloat8
135−-- , "imaginary" ::: 'NotNull 'PGfloat8 ]
136−-- :}
137−--
138−-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer commons grp schemas params from ('NotNull Complex)
139−-- >>> printSQL i
140−-- ROW(0, 1)
141−row
142− :: SOP.SListI row
143− => NP (Aliased (Expression outer commons grp schemas params from)) row
144− -- ^ zero or more expressions for the row field values
145− -> Expression outer commons grp schemas params from (null ('PGcomposite row))
146−row exprs = UnsafeExpression $ "ROW" <> parenthesized
147− (renderCommaSeparated (\ (expr `As` _) -> renderSQL expr) exprs)
148−
149−-- | >>> :{
150−-- type Complex = 'PGcomposite
151−-- '[ "real" ::: 'NotNull 'PGfloat8
152−-- , "imaginary" ::: 'NotNull 'PGfloat8 ]
153−-- type Schema = '["complex" ::: 'Typedef Complex]
154−-- :}
155−--
156−-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer '[] grp (Public Schema) from params ('NotNull Complex)
157−-- >>> printSQL $ i & field #complex #imaginary
158−-- (ROW(0, 1)::"complex")."imaginary"
159−field
160− :: ( Has sch schemas schema
161− , Has tydef schema ('Typedef ('PGcomposite row))
162− , Has field row ty)
163− => QualifiedAlias sch tydef -- ^ row type
164− -> Alias field -- ^ field name
165− -> Expression outer commons grp schemas params from ('NotNull ('PGcomposite row))
166− -> Expression outer commons grp schemas params from ty
167−field td fld expr = UnsafeExpression $
168− parenthesized (renderSQL expr <> "::" <> renderSQL td)
169− <> "." <> renderSQL fld
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hsdeleted−206
@@ -1,206 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Comparison
3−Description: Comparison expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Comparison functions and operators
9−-}
10−
11−{-# LANGUAGE
12− OverloadedStrings
13− , RankNTypes
14− , TypeInType
15− , TypeOperators
16−#-}
17−
18−module Squeal.PostgreSQL.Expression.Comparison
19− ( (.==)
20− , (./=)
21− , (.>=)
22− , (.<)
23− , (.<=)
24− , (.>)
25− , greatest
26− , least
27− , BetweenExpr
28− , between
29− , notBetween
30− , betweenSymmetric
31− , notBetweenSymmetric
32− , isDistinctFrom
33− , isNotDistinctFrom
34− , isTrue
35− , isNotTrue
36− , isFalse
37− , isNotFalse
38− , isUnknown
39− , isNotUnknown
40− ) where
41−
42−import Data.ByteString
43−
44−import Squeal.PostgreSQL.Expression
45−import Squeal.PostgreSQL.Expression.Logic
46−import Squeal.PostgreSQL.Render
47−import Squeal.PostgreSQL.Schema
48−
49−-- $setup
50−-- >>> import Squeal.PostgreSQL
51−
52−-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`
53−-- will produce @NULL@s if one of their arguments is @NULL@.
54−--
55−-- >>> printSQL $ true .== null_
56−-- (TRUE = NULL)
57−(.==) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
58−(.==) = unsafeBinaryOp "="
59−infix 4 .==
60−
61−-- | >>> printSQL $ true ./= null_
62−-- (TRUE <> NULL)
63−(./=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
64−(./=) = unsafeBinaryOp "<>"
65−infix 4 ./=
66−
67−-- | >>> printSQL $ true .>= null_
68−-- (TRUE >= NULL)
69−(.>=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
70−(.>=) = unsafeBinaryOp ">="
71−infix 4 .>=
72−
73−-- | >>> printSQL $ true .< null_
74−-- (TRUE < NULL)
75−(.<) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
76−(.<) = unsafeBinaryOp "<"
77−infix 4 .<
78−
79−-- | >>> printSQL $ true .<= null_
80−-- (TRUE <= NULL)
81−(.<=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
82−(.<=) = unsafeBinaryOp "<="
83−infix 4 .<=
84−
85−-- | >>> printSQL $ true .> null_
86−-- (TRUE > NULL)
87−(.>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
88−(.>) = unsafeBinaryOp ">"
89−infix 4 .>
90−
91−-- | >>> let expr = greatest [param @1] currentTimestamp :: Expression outer commons grp schemas '[ 'NotNull 'PGtimestamptz] from ('NotNull 'PGtimestamptz)
92−-- >>> printSQL expr
93−-- GREATEST(($1 :: timestamp with time zone), CURRENT_TIMESTAMP)
94−greatest :: FunctionVar ty ty ty
95−greatest = unsafeFunctionVar "GREATEST"
96−
97−-- | >>> printSQL $ least [null_] currentTimestamp
98−-- LEAST(NULL, CURRENT_TIMESTAMP)
99−least :: FunctionVar ty ty ty
100−least = unsafeFunctionVar "LEAST"
101−
102−{- |
103−A @RankNType@ for comparison expressions like `between`.
104−-}
105−type BetweenExpr
106− = forall outer commons grp schemas params from ty
107− . Expression outer commons grp schemas params from ty
108− -> ( Expression outer commons grp schemas params from ty
109− , Expression outer commons grp schemas params from ty ) -- ^ bounds
110− -> Condition outer commons grp schemas params from
111−
112−unsafeBetweenExpr :: ByteString -> BetweenExpr
113−unsafeBetweenExpr fun a (x,y) = UnsafeExpression $
114− renderSQL a <+> fun <+> renderSQL x <+> "AND" <+> renderSQL y
115−
116−{- | >>> printSQL $ true `between` (null_, false)
117−TRUE BETWEEN NULL AND FALSE
118−-}
119−between :: BetweenExpr
120−between = unsafeBetweenExpr "BETWEEN"
121−
122−{- | >>> printSQL $ true `notBetween` (null_, false)
123−TRUE NOT BETWEEN NULL AND FALSE
124−-}
125−notBetween :: BetweenExpr
126−notBetween = unsafeBetweenExpr "NOT BETWEEN"
127−
128−{- | between, after sorting the comparison values
129−
130−>>> printSQL $ true `betweenSymmetric` (null_, false)
131−TRUE BETWEEN SYMMETRIC NULL AND FALSE
132−-}
133−betweenSymmetric :: BetweenExpr
134−betweenSymmetric = unsafeBetweenExpr "BETWEEN SYMMETRIC"
135−
136−{- | not between, after sorting the comparison values
137−
138−>>> printSQL $ true `notBetweenSymmetric` (null_, false)
139−TRUE NOT BETWEEN SYMMETRIC NULL AND FALSE
140−-}
141−notBetweenSymmetric :: BetweenExpr
142−notBetweenSymmetric = unsafeBetweenExpr "NOT BETWEEN SYMMETRIC"
143−
144−{- | not equal, treating null like an ordinary value
145−
146−>>> printSQL $ true `isDistinctFrom` null_
147−(TRUE IS DISTINCT FROM NULL)
148−-}
149−isDistinctFrom :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
150−isDistinctFrom = unsafeBinaryOp "IS DISTINCT FROM"
151−
152−{- | equal, treating null like an ordinary value
153−
154−>>> printSQL $ true `isNotDistinctFrom` null_
155−(TRUE IS NOT DISTINCT FROM NULL)
156−-}
157−isNotDistinctFrom :: Operator (null0 ty) (null1 ty) ('NotNull 'PGbool)
158−isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"
159−
160−{- | is true
161−
162−>>> printSQL $ true & isTrue
163−(TRUE IS TRUE)
164−-}
165−isTrue :: null0 'PGbool --> null1 'PGbool
166−isTrue = unsafeRightOp "IS TRUE"
167−
168−{- | is false or unknown
169−
170−>>> printSQL $ true & isNotTrue
171−(TRUE IS NOT TRUE)
172−-}
173−isNotTrue :: null0 'PGbool --> null1 'PGbool
174−isNotTrue = unsafeRightOp "IS NOT TRUE"
175−
176−{- | is false
177−
178−>>> printSQL $ true & isFalse
179−(TRUE IS FALSE)
180−-}
181−isFalse :: null0 'PGbool --> null1 'PGbool
182−isFalse = unsafeRightOp "IS FALSE"
183−
184−{- | is true or unknown
185−
186−>>> printSQL $ true & isNotFalse
187−(TRUE IS NOT FALSE)
188−-}
189−isNotFalse :: null0 'PGbool --> null1 'PGbool
190−isNotFalse = unsafeRightOp "IS NOT FALSE"
191−
192−{- | is unknown
193−
194−>>> printSQL $ true & isUnknown
195−(TRUE IS UNKNOWN)
196−-}
197−isUnknown :: null0 'PGbool --> null1 'PGbool
198−isUnknown = unsafeRightOp "IS UNKNOWN"
199−
200−{- | is true or false
201−
202−>>> printSQL $ true & isNotUnknown
203−(TRUE IS NOT UNKNOWN)
204−-}
205−isNotUnknown :: null0 'PGbool --> null1 'PGbool
206−isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hsdeleted−462
@@ -1,462 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Json
3−Description: Json and Jsonb functions and operators
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Json and Jsonb functions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , FlexibleContexts
14− , FlexibleInstances
15− , GADTs
16− , OverloadedLabels
17− , OverloadedStrings
18− , PolyKinds
19− , RankNTypes
20− , ScopedTypeVariables
21− , TypeApplications
22− , TypeOperators
23− , UndecidableInstances
24− , UndecidableSuperClasses
25−#-}
26−
27−module Squeal.PostgreSQL.Expression.Json
28− ( -- * Json and Jsonb operators
29− (.->)
30− , (.->>)
31− , (.#>)
32− , (.#>>)
33− -- * Jsonb operators
34− , (.?)
35− , (.?|)
36− , (.?&)
37− , (.-.)
38− , (#-.)
39− -- * Json and Jsonb functions
40− , toJson
41− , toJsonb
42− , arrayToJson
43− , rowToJson
44− , jsonBuildArray
45− , jsonbBuildArray
46− , JsonBuildObject (..)
47− , jsonObject
48− , jsonbObject
49− , jsonZipObject
50− , jsonbZipObject
51− , jsonArrayLength
52− , jsonbArrayLength
53− , jsonTypeof
54− , jsonbTypeof
55− , jsonStripNulls
56− , jsonbStripNulls
57− , jsonbSet
58− , jsonbInsert
59− , jsonbPretty
60− -- * Json and Jsonb set returning functions
61− , jsonEach
62− , jsonbEach
63− , jsonEachText
64− , jsonbEachText
65− , jsonObjectKeys
66− , jsonbObjectKeys
67− , JsonPopulateFunction
68− , jsonPopulateRecord
69− , jsonbPopulateRecord
70− , jsonPopulateRecordSet
71− , jsonbPopulateRecordSet
72− , JsonToRecordFunction
73− , jsonToRecord
74− , jsonbToRecord
75− , jsonToRecordSet
76− , jsonbToRecordSet
77− ) where
78−
79−import Data.ByteString (ByteString)
80−import GHC.TypeLits
81−
82−import Squeal.PostgreSQL.Alias
83−import Squeal.PostgreSQL.Expression
84−import Squeal.PostgreSQL.Expression.Set
85−import Squeal.PostgreSQL.Expression.Type
86−import Squeal.PostgreSQL.List
87−import Squeal.PostgreSQL.Query
88−import Squeal.PostgreSQL.Render
89−import Squeal.PostgreSQL.Schema
90−
91−import qualified Generics.SOP as SOP
92−
93−-- $setup
94−-- >>> import Squeal.PostgreSQL
95−-- >>> import Data.Aeson
96−
97−{-----------------------------------------
98− -- json and jsonb support
99−
100−See https://www.postgresql.org/docs/10/static/functions-json.html -- most
101−comments lifted directly from this page.
102−
103−Table 9.44: json and jsonb operators
104−-----------------------------------------}
105−
106−-- | Get JSON value (object field or array element) at a key.
107−(.->)
108− :: (json `In` PGJsonType, key `In` PGJsonKey)
109− => Operator (null json) (null key) ('Null json)
110−infixl 8 .->
111−(.->) = unsafeBinaryOp "->"
112−
113−-- | Get JSON value (object field or array element) at a key, as text.
114−(.->>)
115− :: (json `In` PGJsonType, key `In` PGJsonKey)
116− => Operator (null json) (null key) ('Null 'PGtext)
117−infixl 8 .->>
118−(.->>) = unsafeBinaryOp "->>"
119−
120−-- | Get JSON value at a specified path.
121−(.#>)
122− :: json `In` PGJsonType
123− => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null json)
124−infixl 8 .#>
125−(.#>) = unsafeBinaryOp "#>"
126−
127−-- | Get JSON value at a specified path as text.
128−(.#>>)
129− :: json `In` PGJsonType
130− => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null 'PGtext)
131−infixl 8 .#>>
132−(.#>>) = unsafeBinaryOp "#>>"
133−
134−-- Additional jsonb operators
135−
136−-- | Does the string exist as a top-level key within the JSON value?
137−(.?) :: Operator (null 'PGjsonb) (null 'PGtext) ('Null 'PGbool)
138−infixl 9 .?
139−(.?) = unsafeBinaryOp "?"
140−
141−-- | Do any of these array strings exist as top-level keys?
142−(.?|) :: Operator
143− (null 'PGjsonb)
144− (null ('PGvararray ('NotNull 'PGtext)))
145− ('Null 'PGbool)
146−infixl 9 .?|
147−(.?|) = unsafeBinaryOp "?|"
148−
149−-- | Do all of these array strings exist as top-level keys?
150−(.?&) :: Operator
151− (null 'PGjsonb)
152− (null ('PGvararray ('NotNull 'PGtext)))
153− ('Null 'PGbool)
154−infixl 9 .?&
155−(.?&) = unsafeBinaryOp "?&"
156−
157−-- | Delete a key or keys from a JSON object, or remove an array element.
158−--
159−-- If the right operand is
160−--
161−-- @ text @: Delete key / value pair or string element from left operand.
162−-- Key / value pairs are matched based on their key value,
163−--
164−-- @ text[] @: Delete multiple key / value pairs or string elements
165−-- from left operand. Key / value pairs are matched based on their key value,
166−--
167−-- @ integer @: Delete the array element with specified index (Negative integers
168−-- count from the end). Throws an error if top level container is not an array.
169−(.-.)
170− :: key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]
171− => Operator (null 'PGjsonb) (null key) (null 'PGjsonb)
172−infixl 6 .-.
173−(.-.) = unsafeBinaryOp "-"
174−
175−-- | Delete the field or element with specified path (for JSON arrays, negative
176−-- integers count from the end)
177−(#-.) :: Operator (null 'PGjsonb) (null ('PGvararray ('NotNull 'PGtext))) (null 'PGjsonb)
178−infixl 6 #-.
179−(#-.) = unsafeBinaryOp "#-"
180−
181−{-----------------------------------------
182−Table 9.45: JSON creation functions
183−-----------------------------------------}
184−
185−-- | Returns the value as json. Arrays and composites are converted
186−-- (recursively) to arrays and objects; otherwise, if there is a cast from the
187−-- type to json, the cast function will be used to perform the conversion;
188−-- otherwise, a scalar value is produced. For any scalar type other than a
189−-- number, a Boolean, or a null value, the text representation will be used, in
190−-- such a fashion that it is a valid json value.
191−toJson :: null ty --> null 'PGjson
192−toJson = unsafeFunction "to_json"
193−
194−-- | Returns the value as jsonb. Arrays and composites are converted
195−-- (recursively) to arrays and objects; otherwise, if there is a cast from the
196−-- type to json, the cast function will be used to perform the conversion;
197−-- otherwise, a scalar value is produced. For any scalar type other than a
198−-- number, a Boolean, or a null value, the text representation will be used, in
199−-- such a fashion that it is a valid jsonb value.
200−toJsonb :: null ty --> null 'PGjsonb
201−toJsonb = unsafeFunction "to_jsonb"
202−
203−-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
204−-- becomes a JSON array of arrays.
205−arrayToJson :: null ('PGvararray ty) --> null 'PGjson
206−arrayToJson = unsafeFunction "array_to_json"
207−
208−-- | Returns the row as a JSON object.
209−rowToJson :: null ('PGcomposite ty) --> null 'PGjson
210−rowToJson = unsafeFunction "row_to_json"
211−
212−-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
213−-- argument list.
214−jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson
215−jsonBuildArray = unsafeFunctionN "json_build_array"
216−
217−-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
218−-- variadic argument list.
219−jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb
220−jsonbBuildArray = unsafeFunctionN "jsonb_build_array"
221−
222−-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
223−-- argument list. The elements of the argument list must alternate between text
224−-- and values.
225−class SOP.SListI tys => JsonBuildObject tys where
226−
227− jsonBuildObject :: tys ---> null 'PGjson
228− jsonBuildObject = unsafeFunctionN "json_build_object"
229−
230− jsonbBuildObject :: tys ---> null 'PGjsonb
231− jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
232−
233−instance JsonBuildObject '[]
234−instance (JsonBuildObject tys, key `In` PGJsonKey)
235− => JsonBuildObject ('NotNull key ': value ': tys)
236−
237−-- | Builds a JSON object out of a text array.
238−-- The array must have two dimensions
239−-- such that each inner array has exactly two elements,
240−-- which are taken as a key/value pair.
241−jsonObject
242− :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
243− --> null 'PGjson
244−jsonObject = unsafeFunction "json_object"
245−
246−-- | Builds a binary JSON object out of a text array.
247−-- The array must have two dimensions
248−-- such that each inner array has exactly two elements,
249−-- which are taken as a key/value pair.
250−jsonbObject
251− :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
252− --> null 'PGjsonb
253−jsonbObject = unsafeFunction "jsonb_object"
254−
255−-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
256−-- keys and one for values, that are zipped pairwise to create a JSON object.
257−jsonZipObject ::
258− '[ null ('PGvararray ('NotNull 'PGtext))
259− , null ('PGvararray ('NotNull 'PGtext)) ]
260− ---> null 'PGjson
261−jsonZipObject = unsafeFunctionN "json_object"
262−
263−-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for
264−-- keys and one for values, that are zipped pairwise to create a binary JSON
265−-- object.
266−jsonbZipObject ::
267− '[ null ('PGvararray ('NotNull 'PGtext))
268− , null ('PGvararray ('NotNull 'PGtext)) ]
269− ---> null 'PGjsonb
270−jsonbZipObject = unsafeFunctionN "jsonb_object"
271−
272−{-----------------------------------------
273−Table 9.46: JSON processing functions
274−-----------------------------------------}
275−
276−-- | Returns the number of elements in the outermost JSON array.
277−jsonArrayLength :: null 'PGjson --> null 'PGint4
278−jsonArrayLength = unsafeFunction "json_array_length"
279−
280−-- | Returns the number of elements in the outermost binary JSON array.
281−jsonbArrayLength :: null 'PGjsonb --> null 'PGint4
282−jsonbArrayLength = unsafeFunction "jsonb_array_length"
283−
284−-- | Returns the type of the outermost JSON value as a text string. Possible
285−-- types are object, array, string, number, boolean, and null.
286−jsonTypeof :: null 'PGjson --> null 'PGtext
287−jsonTypeof = unsafeFunction "json_typeof"
288−
289−-- | Returns the type of the outermost binary JSON value as a text string.
290−-- Possible types are object, array, string, number, boolean, and null.
291−jsonbTypeof :: null 'PGjsonb --> null 'PGtext
292−jsonbTypeof = unsafeFunction "jsonb_typeof"
293−
294−-- | Returns its argument with all object fields that have null values omitted.
295−-- Other null values are untouched.
296−jsonStripNulls :: null 'PGjson --> null 'PGjson
297−jsonStripNulls = unsafeFunction "json_strip_nulls"
298−
299−-- | Returns its argument with all object fields that have null values omitted.
300−-- Other null values are untouched.
301−jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb
302−jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
303−
304−-- | @ jsonbSet target path new_value create_missing @
305−--
306−-- Returns target with the section designated by path replaced by @new_value@,
307−-- or with @new_value@ added if create_missing is
308−-- `Squeal.PostgreSQL.Expression.Logic.true` and the
309−-- item designated by path does not exist. As with the path orientated
310−-- operators, negative integers that appear in path count from the end of JSON
311−-- arrays.
312−jsonbSet ::
313− '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
314− , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
315−jsonbSet = unsafeFunctionN "jsonbSet"
316−
317−-- | @ jsonbInsert target path new_value insert_after @
318−--
319−-- Returns target with @new_value@ inserted. If target section designated by
320−-- path is in a JSONB array, @new_value@ will be inserted before target or after
321−-- if @insert_after@ is `Squeal.PostgreSQL.Expression.Logic.true`.
322−-- If target section designated by
323−-- path is in JSONB object, @new_value@ will be inserted only if target does not
324−-- exist. As with the path orientated operators, negative integers that appear
325−-- in path count from the end of JSON arrays.
326−jsonbInsert ::
327− '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
328− , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
329−jsonbInsert = unsafeFunctionN "jsonb_insert"
330−
331−-- | Returns its argument as indented JSON text.
332−jsonbPretty :: null 'PGjsonb --> null 'PGtext
333−jsonbPretty = unsafeFunction "jsonb_pretty"
334−
335−{- | Expands the outermost JSON object into a set of key/value pairs.
336−
337−>>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
338−SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))
339−-}
340−jsonEach :: SetFunction "json_each" (null 'PGjson)
341− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
342−jsonEach = unsafeSetFunction
343−
344−{- | Expands the outermost binary JSON object into a set of key/value pairs.
345−
346−>>> printSQL (select Star (from (jsonbEach (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))
347−SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))
348−-}
349−jsonbEach
350− :: SetFunction "jsonb_each" (nullity 'PGjsonb)
351− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
352−jsonbEach = unsafeSetFunction
353−
354−{- | Expands the outermost JSON object into a set of key/value pairs.
355−
356−>>> printSQL (select Star (from (jsonEachText (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
357−SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))
358−-}
359−jsonEachText
360− :: SetFunction "json_each_text" (null 'PGjson)
361− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
362−jsonEachText = unsafeSetFunction
363−
364−{- | Expands the outermost binary JSON object into a set of key/value pairs.
365−
366−>>> printSQL (select Star (from (jsonbEachText (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))
367−SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))
368−-}
369−jsonbEachText
370− :: SetFunction "jsonb_each_text" (null 'PGjsonb)
371− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
372−jsonbEachText = unsafeSetFunction
373−
374−{- | Returns set of keys in the outermost JSON object.
375−
376−>>> printSQL (jsonObjectKeys (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))
377−json_object_keys(('{"a":"foo","b":"bar"}' :: json))
378−-}
379−jsonObjectKeys
380− :: SetFunction "json_object_keys" (nullity 'PGjson)
381− '["json_object_keys" ::: 'NotNull 'PGtext]
382−jsonObjectKeys = unsafeSetFunction
383−
384−{- | Returns set of keys in the outermost JSON object.
385−
386−>>> printSQL (jsonbObjectKeys (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))
387−jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))
388−-}
389−jsonbObjectKeys
390− :: SetFunction "jsonb_object_keys" (null 'PGjsonb)
391− '["jsonb_object_keys" ::: 'NotNull 'PGtext]
392−jsonbObjectKeys = unsafeSetFunction
393−
394−-- | Build rows from Json types.
395−type JsonPopulateFunction fun json
396− = forall schemas row outer commons params
397− . json `In` PGJsonType
398− => TypeExpression schemas ('NotNull ('PGcomposite row)) -- ^ row type
399− -> Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)
400− -- ^ json type
401− -> FromClause outer commons schemas params '[fun ::: row]
402−
403−unsafePopulateFunction
404− :: forall fun ty
405− . KnownSymbol fun => Alias fun -> JsonPopulateFunction fun ty
406−unsafePopulateFunction _fun ty expr = UnsafeFromClause $ renderSymbol @fun
407− <> parenthesized ("null::" <> renderSQL ty <> ", " <> renderSQL expr)
408−
409−-- | Expands the JSON expression to a row whose columns match the record
410−-- type defined by the given table.
411−jsonPopulateRecord :: JsonPopulateFunction "json_populate_record" 'PGjson
412−jsonPopulateRecord = unsafePopulateFunction #json_populate_record
413−
414−-- | Expands the binary JSON expression to a row whose columns match the record
415−-- type defined by the given table.
416−jsonbPopulateRecord :: JsonPopulateFunction "jsonb_populate_record" 'PGjsonb
417−jsonbPopulateRecord = unsafePopulateFunction #jsonb_populate_record
418−
419−-- | Expands the outermost array of objects in the given JSON expression to a
420−-- set of rows whose columns match the record type defined by the given table.
421−jsonPopulateRecordSet :: JsonPopulateFunction "json_populate_record_set" 'PGjson
422−jsonPopulateRecordSet = unsafePopulateFunction #json_populate_record_set
423−
424−-- | Expands the outermost array of objects in the given binary JSON expression
425−-- to a set of rows whose columns match the record type defined by the given
426−-- table.
427−jsonbPopulateRecordSet :: JsonPopulateFunction "jsonb_populate_record_set" 'PGjsonb
428−jsonbPopulateRecordSet = unsafePopulateFunction #jsonb_populate_record_set
429−
430−-- | Build rows from Json types.
431−type JsonToRecordFunction json
432− = forall outer commons schemas params tab row
433− . (SOP.SListI row, json `In` PGJsonType)
434− => Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)
435− -- ^ json type
436− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: row)
437− -- ^ row type
438− -> FromClause outer commons schemas params '[tab ::: row]
439−
440−unsafeRecordFunction :: ByteString -> JsonToRecordFunction json
441−unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $
442− fun <> parenthesized (renderSQL expr) <+> "AS" <+> renderSQL tab
443− <> parenthesized (renderCommaSeparated renderTy types)
444− where
445− renderTy :: Aliased (TypeExpression schemas) ty -> ByteString
446− renderTy (ty `As` alias) = renderSQL alias <+> renderSQL ty
447−
448−-- | Builds an arbitrary record from a JSON object.
449−jsonToRecord :: JsonToRecordFunction 'PGjson
450−jsonToRecord = unsafeRecordFunction "json_to_record"
451−
452−-- | Builds an arbitrary record from a binary JSON object.
453−jsonbToRecord :: JsonToRecordFunction 'PGjsonb
454−jsonbToRecord = unsafeRecordFunction "jsonb_to_record"
455−
456−-- | Builds an arbitrary set of records from a JSON array of objects.
457−jsonToRecordSet :: JsonToRecordFunction 'PGjson
458−jsonToRecordSet = unsafeRecordFunction "json_to_record_set"
459−
460−-- | Builds an arbitrary set of records from a binary JSON array of objects.
461−jsonbToRecordSet :: JsonToRecordFunction 'PGjsonb
462−jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Literal.hsdeleted−87
@@ -1,87 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Literal
3−Description: Literal expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Literal expressions
9−-}
10−
11−{-# LANGUAGE
12− FlexibleContexts
13− , FlexibleInstances
14− , LambdaCase
15− , OverloadedStrings
16− , RankNTypes
17− , ScopedTypeVariables
18− , TypeApplications
19− , TypeSynonymInstances
20− , UndecidableInstances
21−#-}
22−
23−module Squeal.PostgreSQL.Expression.Literal (Literal (..)) where
24−
25−import ByteString.StrictBuilder (builderBytes)
26−import Data.ByteString.Lazy (toStrict)
27−import Data.Int
28−import Data.String
29−import Data.Text (Text)
30−
31−import qualified Data.Aeson as JSON
32−import qualified Data.Text as Text
33−import qualified Data.Text.Lazy as Lazy (Text)
34−import qualified Data.Text.Lazy as Lazy.Text
35−
36−import Squeal.PostgreSQL.Binary
37−import Squeal.PostgreSQL.Expression
38−import Squeal.PostgreSQL.Expression.Logic
39−import Squeal.PostgreSQL.PG
40−import Squeal.PostgreSQL.Render
41−
42−{- |
43−The `Literal` class allows embedding a Haskell value directly
44−as an `Expression` using `literal`.
45−
46−>>> printSQL (literal 'a')
47−E'a'
48−
49−>>> printSQL (literal (1 :: Double))
50−1.0
51−
52−>>> printSQL (literal (Json [1 :: Double, 2]))
53−('[1.0,2.0]' :: json)
54−
55−>>> printSQL (literal (Enumerated GT))
56−'GT'
57−-}
58−class Literal hask where literal :: hask -> Expr (null (PG hask))
59−instance Literal Bool where
60− literal = \case
61− True -> true
62− False -> false
63−instance JSON.ToJSON hask => Literal (Json hask) where
64− literal = UnsafeExpression . parenthesized . (<> " :: json")
65− . singleQuotedUtf8 . toStrict . JSON.encode . getJson
66−instance JSON.ToJSON hask => Literal (Jsonb hask) where
67− literal = UnsafeExpression . parenthesized . (<> " :: jsonb")
68− . singleQuotedUtf8 . toStrict . JSON.encode . getJsonb
69−instance Literal Char where
70− literal chr = UnsafeExpression $
71− "E\'" <> fromString (escape chr) <> "\'"
72−instance Literal String where literal = fromString
73−instance Literal Int16 where literal = fromIntegral
74−instance Literal Int32 where literal = fromIntegral
75−instance Literal Int64 where literal = fromIntegral
76−instance Literal Float where literal = fromRational . toRational
77−instance Literal Double where literal = fromRational . toRational
78−instance Literal Text where literal = fromString . Text.unpack
79−instance Literal Lazy.Text where literal = fromString . Lazy.Text.unpack
80−instance ToParam (Enumerated enum) (PG (Enumerated enum))
81− => Literal (Enumerated enum) where
82− literal
83− = UnsafeExpression
84− . singleQuotedUtf8
85− . builderBytes
86− . unK
87− . toParam @(Enumerated enum) @(PG (Enumerated enum))
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hsdeleted−105
@@ -1,105 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Logic
3−Description: Logical expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Logical expressions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , TypeOperators
15−#-}
16−
17−module Squeal.PostgreSQL.Expression.Logic
18− ( Condition
19− , true
20− , false
21− , not_
22− , (.&&)
23− , (.||)
24− , caseWhenThenElse
25− , ifThenElse
26− ) where
27−
28−import Squeal.PostgreSQL.Expression
29−import Squeal.PostgreSQL.Render
30−import Squeal.PostgreSQL.Schema
31−
32−-- | A `Condition` is an `Expression`, which can evaluate
33−-- to `true`, `false` or `Squeal.PostgreSQL.Null.null_`. This is because SQL uses
34−-- a three valued logic.
35−type Condition outer commons grp schemas params from =
36− Expression outer commons grp schemas params from ('Null 'PGbool)
37−
38−-- | >>> printSQL true
39−-- TRUE
40−true :: Expr (null 'PGbool)
41−true = UnsafeExpression "TRUE"
42−
43−-- | >>> printSQL false
44−-- FALSE
45−false :: Expr (null 'PGbool)
46−false = UnsafeExpression "FALSE"
47−
48−-- | >>> printSQL $ not_ true
49−-- (NOT TRUE)
50−not_ :: null 'PGbool --> null 'PGbool
51−not_ = unsafeLeftOp "NOT"
52−
53−-- | >>> printSQL $ true .&& false
54−-- (TRUE AND FALSE)
55−(.&&) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)
56−infixr 3 .&&
57−(.&&) = unsafeBinaryOp "AND"
58−
59−-- | >>> printSQL $ true .|| false
60−-- (TRUE OR FALSE)
61−(.||) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)
62−infixr 2 .||
63−(.||) = unsafeBinaryOp "OR"
64−
65−-- | >>> :{
66−-- let
67−-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
68−-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3
69−-- in printSQL expression
70−-- :}
71−-- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END
72−caseWhenThenElse
73− :: [ ( Condition outer commons grp schemas params from
74− , Expression outer commons grp schemas params from ty
75− ) ]
76− -- ^ whens and thens
77− -> Expression outer commons grp schemas params from ty
78− -- ^ else
79− -> Expression outer commons grp schemas params from ty
80−caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
81− [ "CASE"
82− , mconcat
83− [ mconcat
84− [ " WHEN ", renderSQL when_
85− , " THEN ", renderSQL then_
86− ]
87− | (when_,then_) <- whenThens
88− ]
89− , " ELSE ", renderSQL else_
90− , " END"
91− ]
92−
93−-- | >>> :{
94−-- let
95−-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
96−-- expression = ifThenElse true 1 0
97−-- in printSQL expression
98−-- :}
99−-- CASE WHEN TRUE THEN 1 ELSE 0 END
100−ifThenElse
101− :: Condition outer commons grp schemas params from
102− -> Expression outer commons grp schemas params from ty -- ^ then
103− -> Expression outer commons grp schemas params from ty -- ^ else
104− -> Expression outer commons grp schemas params from ty
105−ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hsdeleted−100
@@ -1,100 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Math
3−Description: Math expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Mathematical functions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , TypeOperators
15−#-}
16−
17−module Squeal.PostgreSQL.Expression.Math
18− ( atan2_
19− , quot_
20− , rem_
21− , trunc
22− , round_
23− , ceiling_
24− ) where
25−
26−import Squeal.PostgreSQL.Expression
27−import Squeal.PostgreSQL.List
28−import Squeal.PostgreSQL.Schema
29−
30−-- $setup
31−-- >>> import Squeal.PostgreSQL
32−
33−-- | >>> :{
34−-- let
35−-- expression :: Expr (null 'PGfloat4)
36−-- expression = atan2_ (pi *: 2)
37−-- in printSQL expression
38−-- :}
39−-- atan2(pi(), 2)
40−atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float
41−atan2_ = unsafeFunctionN "atan2"
42−
43−
44−-- | integer division, truncates the result
45−--
46−-- >>> :{
47−-- let
48−-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
49−-- expression = 5 `quot_` 2
50−-- in printSQL expression
51−-- :}
52−-- (5 / 2)
53−quot_
54− :: int `In` PGIntegral
55− => Operator (null int) (null int) (null int)
56−quot_ = unsafeBinaryOp "/"
57−
58−-- | remainder upon integer division
59−--
60−-- >>> :{
61−-- let
62−-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
63−-- expression = 5 `rem_` 2
64−-- in printSQL expression
65−-- :}
66−-- (5 % 2)
67−rem_
68− :: int `In` PGIntegral
69− => Operator (null int) (null int) (null int)
70−rem_ = unsafeBinaryOp "%"
71−
72−-- | >>> :{
73−-- let
74−-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)
75−-- expression = trunc pi
76−-- in printSQL expression
77−-- :}
78−-- trunc(pi())
79−trunc :: frac `In` PGFloating => null frac --> null frac
80−trunc = unsafeFunction "trunc"
81−
82−-- | >>> :{
83−-- let
84−-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)
85−-- expression = round_ pi
86−-- in printSQL expression
87−-- :}
88−-- round(pi())
89−round_ :: frac `In` PGFloating => null frac --> null frac
90−round_ = unsafeFunction "round"
91−
92−-- | >>> :{
93−-- let
94−-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)
95−-- expression = ceiling_ pi
96−-- in printSQL expression
97−-- :}
98−-- ceiling(pi())
99−ceiling_ :: frac `In` PGFloating => null frac --> null frac
100−ceiling_ = unsafeFunction "ceiling"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Null
3−Description: Null
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Null values and null handling functions
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , TypeOperators
15−#-}
16−
17−module Squeal.PostgreSQL.Expression.Null
18− ( null_
19− , notNull
20− , coalesce
21− , fromNull
22− , isNull
23− , isNotNull
24− , matchNull
25− , nullIf
26− ) where
27−
28−import Squeal.PostgreSQL.Expression
29−import Squeal.PostgreSQL.Expression.Logic
30−import Squeal.PostgreSQL.Render
31−import Squeal.PostgreSQL.Schema
32−
33−-- $setup
34−-- >>> import Squeal.PostgreSQL
35−
36−-- | analagous to `Nothing`
37−--
38−-- >>> printSQL null_
39−-- NULL
40−null_ :: Expr ('Null ty)
41−null_ = UnsafeExpression "NULL"
42−
43−-- | analagous to `Just`
44−--
45−-- >>> printSQL $ notNull true
46−-- TRUE
47−notNull :: 'NotNull ty --> 'Null ty
48−notNull = UnsafeExpression . renderSQL
49−
50−-- | return the leftmost value which is not NULL
51−--
52−-- >>> printSQL $ coalesce [null_, true] false
53−-- COALESCE(NULL, TRUE, FALSE)
54−coalesce :: FunctionVar ('Null ty) ('NotNull ty) ('NotNull ty)
55−coalesce nullxs notNullx = UnsafeExpression $
56− "COALESCE" <> parenthesized (commaSeparated
57− ((renderSQL <$> nullxs) <> [renderSQL notNullx]))
58−
59−-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@
60−--
61−-- >>> printSQL $ fromNull true null_
62−-- COALESCE(NULL, TRUE)
63−fromNull
64− :: Expression outer commons grp schemas params from ('NotNull ty)
65− -- ^ what to convert @NULL@ to
66− -> Expression outer commons grp schemas params from ('Null ty)
67− -> Expression outer commons grp schemas params from ('NotNull ty)
68−fromNull notNullx nullx = coalesce [nullx] notNullx
69−
70−-- | >>> printSQL $ null_ & isNull
71−-- NULL IS NULL
72−isNull :: 'Null ty --> null 'PGbool
73−isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"
74−
75−-- | >>> printSQL $ null_ & isNotNull
76−-- NULL IS NOT NULL
77−isNotNull :: 'Null ty --> null 'PGbool
78−isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"
79−
80−-- | analagous to `maybe` using @IS NULL@
81−--
82−-- >>> printSQL $ matchNull true not_ null_
83−-- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END
84−matchNull
85− :: Expression outer commons grp schemas params from (nullty)
86− -- ^ what to convert @NULL@ to
87− -> ( Expression outer commons grp schemas params from ('NotNull ty)
88− -> Expression outer commons grp schemas params from (nullty) )
89− -- ^ function to perform when @NULL@ is absent
90− -> Expression outer commons grp schemas params from ('Null ty)
91− -> Expression outer commons grp schemas params from (nullty)
92−matchNull y f x = ifThenElse (isNull x) y
93− (f (UnsafeExpression (renderSQL x)))
94−
95−{-| right inverse to `fromNull`, if its arguments are equal then
96−`nullIf` gives @NULL@.
97−
98−>>> :set -XTypeApplications -XDataKinds
99−>>> let expr = nullIf (false *: param @1) :: Expression outer commons grp schemas '[ 'NotNull 'PGbool] from ('Null 'PGbool)
100−>>> printSQL expr
101−NULLIF(FALSE, ($1 :: bool))
102−-}
103−nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty
104−nullIf = unsafeFunctionN "NULLIF"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hsdeleted−80
@@ -1,80 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Parameter
3−Description: Parameters
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Parameters, out-of-line data values
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DataKinds
14− , FlexibleContexts
15− , FlexibleInstances
16− , FunctionalDependencies
17− , KindSignatures
18− , MultiParamTypeClasses
19− , OverloadedStrings
20− , RankNTypes
21− , ScopedTypeVariables
22− , TypeApplications
23− , TypeOperators
24− , UndecidableInstances
25−#-}
26−
27−module Squeal.PostgreSQL.Expression.Parameter
28− ( HasParameter (parameter)
29− , param
30− ) where
31−
32−import GHC.TypeLits
33−
34−import Squeal.PostgreSQL.Expression
35−import Squeal.PostgreSQL.Expression.Type
36−import Squeal.PostgreSQL.Render
37−import Squeal.PostgreSQL.Schema
38−
39−-- $setup
40−-- >>> import Squeal.PostgreSQL
41−
42−{- | A `HasParameter` constraint is used to indicate a value that is
43−supplied externally to a SQL statement.
44−`Squeal.PostgreSQL.PQ.manipulateParams`,
45−`Squeal.PostgreSQL.PQ.queryParams` and
46−`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values
47−separately from the SQL command string, in which case `param`s are used to
48−refer to the out-of-line data values.
49−-}
50−class KnownNat n => HasParameter
51− (n :: Nat)
52− (params :: [NullityType])
53− (ty :: NullityType)
54− | n params -> ty where
55− -- | `parameter` takes a `Nat` using type application and a `TypeExpression`.
56− --
57− -- >>> let expr = parameter @1 int4 :: Expression outer '[] grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)
58− -- >>> printSQL expr
59− -- ($1 :: int4)
60− parameter
61− :: TypeExpression schemas ty
62− -> Expression outer commons grp schemas params from ty
63− parameter ty = UnsafeExpression $ parenthesized $
64− "$" <> renderNat @n <+> "::"
65− <+> renderSQL ty
66−instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1
67−instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
68− => HasParameter n (ty' : params) ty
69−
70−-- | `param` takes a `Nat` using type application and for basic types,
71−-- infers a `TypeExpression`.
72−--
73−-- >>> let expr = param @1 :: Expression outer commons grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)
74−-- >>> printSQL expr
75−-- ($1 :: int4)
76−param
77− :: forall n outer commons schemas params from grp ty
78− . (PGTyped schemas ty, HasParameter n params ty)
79− => Expression outer commons grp schemas params from ty -- ^ param
80−param = parameter @n (pgtype @schemas)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hsdeleted−230
@@ -1,230 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Range
3−Description: range types and functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Range types and functions
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DataKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DeriveFoldable
17− , DerivingStrategies
18− , DeriveTraversable
19− , FlexibleContexts
20− , FlexibleInstances
21− , LambdaCase
22− , MultiParamTypeClasses
23− , OverloadedLabels
24− , OverloadedStrings
25− , PatternSynonyms
26− , RankNTypes
27− , ScopedTypeVariables
28− , TypeApplications
29− , TypeFamilies
30− , TypeOperators
31− , UndecidableInstances
32−#-}
33−
34−module Squeal.PostgreSQL.Expression.Range
35− ( range
36− , Range (..)
37− , (<=..<=), (<..<), (<=..<), (<..<=)
38− , moreThan, atLeast, lessThan, atMost
39− , singleton, whole
40− , Bound (..)
41− , (.<@)
42− , (@>.)
43− , (<<@)
44− , (@>>)
45− , (&<)
46− , (&>)
47− , (-|-)
48− , (@+)
49− , (@*)
50− , (@-)
51− , lowerBound
52− , upperBound
53− , isEmpty
54− , lowerInc
55− , lowerInf
56− , upperInc
57− , upperInf
58− , rangeMerge
59− ) where
60−
61−import BinaryParser
62−import ByteString.StrictBuilder
63−import Data.Bits
64−import qualified GHC.Generics as GHC
65−import qualified Generics.SOP as SOP
66−import qualified PostgreSQL.Binary.Decoding as Decoding
67−
68−import Squeal.PostgreSQL.Binary
69−import Squeal.PostgreSQL.Expression
70−import Squeal.PostgreSQL.Expression.Type hiding (bool)
71−import Squeal.PostgreSQL.PG
72−import Squeal.PostgreSQL.Render
73−import Squeal.PostgreSQL.Schema
74−
75−-- $setup
76−-- >>> import Squeal.PostgreSQL
77−
78−-- | Construct a `range`
79−--
80−-- >>> printSQL $ range tstzrange (atLeast now)
81−-- tstzrange(now(), NULL, '[)')
82−-- >>> printSQL $ range numrange (0 <=..< 2*pi)
83−-- numrange(0, (2 * pi()), '[)')
84−-- >>> printSQL $ range int4range Empty
85−-- ('empty' :: int4range)
86−range
87− :: TypeExpression schemas (null ('PGrange ty))
88− -> Range (Expression outer commons grp schemas params from ('NotNull ty))
89− -> Expression outer commons grp schemas params from (null ('PGrange ty))
90−range ty = \case
91− Empty -> UnsafeExpression $ parenthesized
92− (emp <+> "::" <+> renderSQL ty)
93− NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized
94− (commaSeparated (args l u))
95− where
96− emp = singleQuote <> "empty" <> singleQuote
97− args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote]
98− singleQuote = "\'"
99− arg = \case
100− Infinite -> "NULL"; Closed x -> renderSQL x; Open x -> renderSQL x
101− bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "("
102− ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")"
103−
104−data Bound x = Infinite | Closed x | Open x
105− deriving
106− ( Eq, Ord, Show, Read, GHC.Generic
107− , Functor, Foldable, Traversable )
108−
109−data Range x = Empty | NonEmpty (Bound x) (Bound x)
110− deriving
111− ( Eq, Ord, Show, Read, GHC.Generic
112− , Functor, Foldable, Traversable )
113− deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
114−type instance PG (Range x) = 'PGrange (PG x)
115−instance ToParam x pg => ToParam (Range x) ('PGrange pg) where
116− toParam rng = K $
117− word8 (setFlags rng 0) <>
118− case rng of
119− Empty -> mempty
120− NonEmpty lower upper -> putBound lower <> putBound upper
121− where
122− putBound = \case
123− Infinite -> mempty
124− Closed value -> putValue (unK (toParam @x @pg value))
125− Open value -> putValue (unK (toParam @x @pg value))
126− putValue value = int32BE (fromIntegral (builderLength value)) <> value
127− setFlags = \case
128− Empty -> (`setBit` 0)
129− NonEmpty lower upper ->
130− setLowerFlags lower . setUpperFlags upper
131− setLowerFlags = \case
132− Infinite -> (`setBit` 3)
133− Closed _ -> (`setBit` 1)
134− Open _ -> id
135− setUpperFlags = \case
136− Infinite -> (`setBit` 4)
137− Closed _ -> (`setBit` 2)
138− Open _ -> id
139−instance FromValue pg y => FromValue ('PGrange pg) (Range y) where
140− fromValue = do
141− flag <- byte
142− if testBit flag 0 then return Empty else do
143− lower <-
144− if testBit flag 3
145− then return Infinite
146− else do
147− len <- sized 4 Decoding.int
148− l <- sized len (fromValue @pg)
149− return $ if testBit flag 1 then Closed l else Open l
150− upper <-
151− if testBit flag 4
152− then return Infinite
153− else do
154− len <- sized 4 Decoding.int
155− l <- sized len (fromValue @pg)
156− return $ if testBit flag 2 then Closed l else Open l
157− return $ NonEmpty lower upper
158−
159−(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x
160−infix 4 <=..<=, <..<, <=..<, <..<=
161−x <=..<= y = NonEmpty (Closed x) (Closed y)
162−x <..< y = NonEmpty (Open x) (Open y)
163−x <=..< y = NonEmpty (Closed x) (Open y)
164−x <..<= y = NonEmpty (Open x) (Closed y)
165−
166−moreThan, atLeast, lessThan, atMost :: x -> Range x
167−moreThan x = NonEmpty (Open x) Infinite
168−atLeast x = NonEmpty (Closed x) Infinite
169−lessThan x = NonEmpty Infinite (Open x)
170−atMost x = NonEmpty Infinite (Closed x)
171−
172−singleton :: x -> Range x
173−singleton x = x <=..<= x
174−
175−whole :: Range x
176−whole = NonEmpty Infinite Infinite
177−
178−(.<@) :: Operator ('NotNull ty) (null ('PGrange ty)) ('Null 'PGbool)
179−(.<@) = unsafeBinaryOp "<@"
180−
181−(@>.) :: Operator (null ('PGrange ty)) ('NotNull ty) ('Null 'PGbool)
182−(@>.) = unsafeBinaryOp "<@"
183−
184−(<<@) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
185−(<<@) = unsafeBinaryOp "<<"
186−
187−(@>>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
188−(@>>) = unsafeBinaryOp ">>"
189−
190−(&<) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
191−(&<) = unsafeBinaryOp "&<"
192−
193−(&>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
194−(&>) = unsafeBinaryOp "&>"
195−
196−(-|-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
197−(-|-) = unsafeBinaryOp "-|-"
198−
199−(@+) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
200−(@+) = unsafeBinaryOp "+"
201−
202−(@*) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
203−(@*) = unsafeBinaryOp "*"
204−
205−(@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
206−(@-) = unsafeBinaryOp "-"
207−
208−lowerBound :: null ('PGrange ty) --> 'Null ty
209−lowerBound = unsafeFunction "lower"
210−
211−upperBound :: null ('PGrange ty) --> 'Null ty
212−upperBound = unsafeFunction "upper"
213−
214−isEmpty :: null ('PGrange ty) --> 'Null 'PGbool
215−isEmpty = unsafeFunction "isempty"
216−
217−lowerInc :: null ('PGrange ty) --> 'Null 'PGbool
218−lowerInc = unsafeFunction "lower_inc"
219−
220−lowerInf :: null ('PGrange ty) --> 'Null 'PGbool
221−lowerInf = unsafeFunction "lower_inf"
222−
223−upperInc :: null ('PGrange ty) --> 'Null 'PGbool
224−upperInc = unsafeFunction "upper_inc"
225−
226−upperInf :: null ('PGrange ty) --> 'Null 'PGbool
227−upperInf = unsafeFunction "upper_inf"
228−
229−rangeMerge :: '[null ('PGrange ty), null ('PGrange ty)] ---> null ('PGrange ty)
230−rangeMerge = unsafeFunctionN "range_merge"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Set.hsdeleted−139
@@ -1,139 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Set
3−Description: Set returning functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Set returning functions
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DataKinds
14− , FlexibleContexts
15− , OverloadedStrings
16− , PolyKinds
17− , RankNTypes
18− , ScopedTypeVariables
19− , TypeApplications
20− , TypeOperators
21−#-}
22−
23−module Squeal.PostgreSQL.Expression.Set
24− ( generateSeries
25− , generateSeriesStep
26− , generateSeriesTimestamp
27− , SetFunction
28− , unsafeSetFunction
29− , SetFunctionDB
30− , setFunction
31− , SetFunctionN
32− , unsafeSetFunctionN
33− , SetFunctionNDB
34− , setFunctionN
35− ) where
36−
37−import GHC.TypeLits
38−
39−import qualified Generics.SOP as SOP
40−
41−import Squeal.PostgreSQL.Alias
42−import Squeal.PostgreSQL.Expression
43−import Squeal.PostgreSQL.List
44−import Squeal.PostgreSQL.Render
45−import Squeal.PostgreSQL.Query
46−import Squeal.PostgreSQL.Schema
47−
48−{- |
49−A @RankNType@ for set returning functions with 1 argument.
50−-}
51−type SetFunction fun ty row
52− = forall outer commons schemas params
53− . Expression outer commons 'Ungrouped schemas params '[] ty
54− -- ^ input
55− -> FromClause outer commons schemas params '[fun ::: row]
56− -- ^ output
57−
58−type SetFunctionDB fun schemas ty row
59− = forall outer commons params
60− . Expression outer commons 'Ungrouped schemas params '[] ty
61− -- ^ input
62− -> FromClause outer commons schemas params '[fun ::: row]
63− -- ^ output
64−
65−-- | Escape hatch for a set returning function with 1 argument.
66−unsafeSetFunction
67− :: forall fun ty row. KnownSymbol fun
68− => SetFunction fun ty row -- ^ set returning function
69−unsafeSetFunction x = UnsafeFromClause $
70− renderSymbol @fun <> parenthesized (renderSQL x)
71−
72−setFunction
73− :: ( Has sch schemas schema
74− , Has fun schema ('Function ('[ty] :=> 'ReturnsTable row)) )
75− => QualifiedAlias sch fun
76− -> SetFunctionDB fun schemas ty row
77−setFunction _ = unsafeSetFunction
78−
79−{- |
80−A @RankNType@ for set returning functions with multiple argument.
81−-}
82−type SetFunctionN fun tys row
83− = forall outer commons schemas params
84− . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
85− -- ^ inputs
86− -> FromClause outer commons schemas params '[fun ::: row]
87− -- ^ output
88−
89−-- | Escape hatch for a set returning function with multiple argument.
90−unsafeSetFunctionN
91− :: forall fun tys row. (SOP.SListI tys, KnownSymbol fun)
92− => SetFunctionN fun tys row -- ^ set returning function
93−unsafeSetFunctionN xs = UnsafeFromClause $
94− renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)
95−
96−type SetFunctionNDB fun schemas tys row
97− = forall outer commons params
98− . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
99− -- ^ inputs
100− -> FromClause outer commons schemas params '[fun ::: row]
101− -- ^ output
102−
103−setFunctionN
104− :: ( Has sch schemas schema
105− , Has fun schema ('Function (tys :=> 'ReturnsTable row))
106− , SOP.SListI tys )
107− => QualifiedAlias sch fun
108− -> SetFunctionNDB fun schemas tys row
109−setFunctionN _ = unsafeSetFunctionN
110−
111−{- | @generateSeries (start *: stop)@
112−
113−Generate a series of values, from @start@ to @stop@ with a step size of one
114−-}
115−generateSeries
116− :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
117− => SetFunctionN "generate_series" '[ null ty, null ty]
118− '["generate_series" ::: null ty] -- ^ set returning function
119−generateSeries = unsafeSetFunctionN
120−
121−{- | @generateSeries (start :* stop *: step)@
122−
123−Generate a series of values, from @start@ to @stop@ with a step size of @step@
124−-}
125−generateSeriesStep
126− :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
127− => SetFunctionN "generate_series" '[null ty, null ty, null ty]
128− '["generate_series" ::: null ty] -- ^ set returning function
129−generateSeriesStep = unsafeSetFunctionN
130−
131−{- | @generateSeries (start :* stop *: step)@
132−
133−Generate a series of values, from @start@ to @stop@ with a step size of @step@
134−-}
135−generateSeriesTimestamp
136− :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]
137− => SetFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]
138− '["generate_series" ::: null ty] -- ^ set returning function
139−generateSeriesTimestamp = unsafeSetFunctionN
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hsdeleted−85
@@ -1,85 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Sort
3−Description: Sort expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Sort expressions
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , GADTs
14− , LambdaCase
15− , OverloadedStrings
16− , StandaloneDeriving
17−#-}
18−
19−module Squeal.PostgreSQL.Expression.Sort
20− ( SortExpression (..)
21− , OrderBy (..)
22− ) where
23−
24−import Squeal.PostgreSQL.Expression
25−import Squeal.PostgreSQL.Render
26−import Squeal.PostgreSQL.Schema
27−
28−-- | `SortExpression`s are used by `orderBy` to optionally sort the results
29−-- of a `Squeal.PostgreSQL.Query.Query`. `Asc` or `Desc`
30−-- set the sort direction of a `NotNull` result
31−-- column to ascending or descending. Ascending order puts smaller values
32−-- first, where "smaller" is defined in terms of the
33−-- `Squeal.PostgreSQL.Expression.Comparison..<` operator. Similarly,
34−-- descending order is determined with the
35−-- `Squeal.PostgreSQL.Expression.Comparison..>` operator. `AscNullsFirst`,
36−-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to
37−-- determine whether nulls appear before or after non-null values in the sort
38−-- ordering of a `Null` result column.
39−data SortExpression outer commons grp schemas params from where
40− Asc
41− :: Expression outer commons grp schemas params from ('NotNull ty)
42− -> SortExpression outer commons grp schemas params from
43− Desc
44− :: Expression outer commons grp schemas params from ('NotNull ty)
45− -> SortExpression outer commons grp schemas params from
46− AscNullsFirst
47− :: Expression outer commons grp schemas params from ('Null ty)
48− -> SortExpression outer commons grp schemas params from
49− AscNullsLast
50− :: Expression outer commons grp schemas params from ('Null ty)
51− -> SortExpression outer commons grp schemas params from
52− DescNullsFirst
53− :: Expression outer commons grp schemas params from ('Null ty)
54− -> SortExpression outer commons grp schemas params from
55− DescNullsLast
56− :: Expression outer commons grp schemas params from ('Null ty)
57− -> SortExpression outer commons grp schemas params from
58−deriving instance Show (SortExpression outer commons grp schemas params from)
59−instance RenderSQL (SortExpression outer commons grp schemas params from) where
60− renderSQL = \case
61− Asc expression -> renderSQL expression <+> "ASC"
62− Desc expression -> renderSQL expression <+> "DESC"
63− AscNullsFirst expression -> renderSQL expression
64− <+> "ASC NULLS FIRST"
65− DescNullsFirst expression -> renderSQL expression
66− <+> "DESC NULLS FIRST"
67− AscNullsLast expression -> renderSQL expression <+> "ASC NULLS LAST"
68− DescNullsLast expression -> renderSQL expression <+> "DESC NULLS LAST"
69−
70−{- |
71−The `orderBy` clause causes the result rows of a `Squeal.PostgreSQL.Query.TableExpression`
72−to be sorted according to the specified `SortExpression`(s).
73−If two rows are equal according to the leftmost expression,
74−they are compared according to the next expression and so on.
75−If they are equal according to all specified expressions,
76−they are returned in an implementation-dependent order.
77−
78−You can also control the order in which rows are processed by window functions
79−using `orderBy` within `Squeal.PostgreSQL.Query.Over`.
80−-}
81−class OrderBy expr where
82− orderBy
83− :: [SortExpression outer commons grp schemas params from]
84− -> expr outer commons grp schemas params from
85− -> expr outer commons grp schemas params from
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hsdeleted−120
@@ -1,120 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Subquery
3−Description: Subquery expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Subquery expressions
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , RankNTypes
15− , TypeOperators
16−#-}
17−
18−module Squeal.PostgreSQL.Expression.Subquery
19− ( exists
20− , in_
21− , notIn
22− , subAll
23− , subAny
24− ) where
25−
26−import Squeal.PostgreSQL.Alias
27−import Squeal.PostgreSQL.Expression
28−import Squeal.PostgreSQL.Expression.Logic
29−import Squeal.PostgreSQL.List
30−import Squeal.PostgreSQL.Query
31−import Squeal.PostgreSQL.Render
32−import Squeal.PostgreSQL.Schema
33−
34−-- $setup
35−-- >>> import Squeal.PostgreSQL
36−
37−{- |
38−The argument of `exists` is an arbitrary subquery. The subquery is evaluated
39−to determine whether it returns any rows. If it returns at least one row,
40−the result of `exists` is `true`; if the subquery returns no rows,
41−the result of `exists` is `false`.
42−
43−The subquery can refer to variables from the surrounding query,
44−which will act as constants during any one evaluation of the subquery.
45−
46−The subquery will generally only be executed long enough to determine whether
47−at least one row is returned, not all the way to completion.
48−-}
49−exists
50− :: Query (Join outer from) commons schemas params row
51− -> Condition outer commons grp schemas params from
52−exists query = UnsafeExpression $ "EXISTS" <+> parenthesized (renderSQL query)
53−
54−{- |
55−The right-hand side is a parenthesized subquery, which must return
56−exactly one column. The left-hand expression is evaluated and compared to each
57−row of the subquery result using the given `Operator`,
58−which must yield a Boolean result. The result of `subAll` is `true`
59−if all rows yield true (including the case where the subquery returns no rows).
60−The result is `false` if any `false` result is found.
61−The result is `Squeal.PostgreSQL.Expression.Null.null_` if
62− no comparison with a subquery row returns `false`,
63−and at least one comparison returns `Squeal.PostgreSQL.Expression.Null.null_`.
64−
65−>>> printSQL $ subAll true (.==) (values_ (true `as` #foo))
66−(TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo")))
67−-}
68−subAll
69− :: Expression outer commons grp schemas params from ty1 -- ^ expression
70− -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator
71− -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery
72− -> Condition outer commons grp schemas params from
73−subAll expr (?) qry = expr ?
74− (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL qry))
75−
76−{- |
77−The right-hand side is a parenthesized subquery, which must return exactly one column.
78−The left-hand expression is evaluated and compared to each row of the subquery result
79−using the given `Operator`, which must yield a Boolean result. The result of `subAny` is `true`
80−if any `true` result is obtained. The result is `false` if no true result is found
81−(including the case where the subquery returns no rows).
82−
83−>>> printSQL $ subAny "foo" like (values_ ("foobar" `as` #foo))
84−(E'foo' LIKE ANY (SELECT * FROM (VALUES (E'foobar')) AS t ("foo")))
85−-}
86−subAny
87− :: Expression outer commons grp schemas params from ty1 -- ^ expression
88− -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator
89− -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery
90− -> Condition outer commons grp schemas params from
91−subAny expr (?) qry = expr ?
92− (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL qry))
93−
94−{- |
95−The result is `true` if the left-hand expression's result is equal
96−to any of the right-hand expressions.
97−
98−>>> printSQL $ true `in_` [true, false, null_]
99−TRUE IN (TRUE, FALSE, NULL)
100−-}
101−in_
102− :: Expression outer commons grp schemas params from ty -- ^ expression
103− -> [Expression outer commons grp schemas params from ty]
104− -> Condition outer commons grp schemas params from
105−expr `in_` exprs = UnsafeExpression $ renderSQL expr <+> "IN"
106− <+> parenthesized (commaSeparated (renderSQL <$> exprs))
107−
108−{- |
109−The result is `true` if the left-hand expression's result is not equal
110−to any of the right-hand expressions.
111−
112−>>> printSQL $ true `notIn` [false, null_]
113−TRUE NOT IN (FALSE, NULL)
114−-}
115−notIn
116− :: Expression outer commons grp schemas params from ty -- ^ expression
117− -> [Expression outer commons grp schemas params from ty]
118− -> Condition outer commons grp schemas params from
119−expr `notIn` exprs = UnsafeExpression $ renderSQL expr <+> "NOT IN"
120− <+> parenthesized (commaSeparated (renderSQL <$> exprs))
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hsdeleted−64
@@ -1,64 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Text
3−Description: Text expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−String functions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , TypeOperators
15−#-}
16−
17−module Squeal.PostgreSQL.Expression.Text
18− ( lower
19− , upper
20− , charLength
21− , like
22− , ilike
23− ) where
24−
25−import Squeal.PostgreSQL.Expression
26−import Squeal.PostgreSQL.Schema
27−
28−-- $setup
29−-- >>> import Squeal.PostgreSQL
30−
31−-- | >>> printSQL $ lower "ARRRGGG"
32−-- lower(E'ARRRGGG')
33−lower :: null 'PGtext --> null 'PGtext
34−lower = unsafeFunction "lower"
35−
36−-- | >>> printSQL $ upper "eeee"
37−-- upper(E'eeee')
38−upper :: null 'PGtext --> null 'PGtext
39−upper = unsafeFunction "upper"
40−
41−-- | >>> printSQL $ charLength "four"
42−-- char_length(E'four')
43−charLength :: null 'PGtext --> null 'PGint4
44−charLength = unsafeFunction "char_length"
45−
46−-- | The `like` expression returns true if the @string@ matches
47−-- the supplied @pattern@. If @pattern@ does not contain percent signs
48−-- or underscores, then the pattern only represents the string itself;
49−-- in that case `like` acts like the equals operator. An underscore (_)
50−-- in pattern stands for (matches) any single character; a percent sign (%)
51−-- matches any sequence of zero or more characters.
52−--
53−-- >>> printSQL $ "abc" `like` "a%"
54−-- (E'abc' LIKE E'a%')
55−like :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)
56−like = unsafeBinaryOp "LIKE"
57−
58−-- | The key word ILIKE can be used instead of LIKE to make the
59−-- match case-insensitive according to the active locale.
60−--
61−-- >>> printSQL $ "abc" `ilike` "a%"
62−-- (E'abc' ILIKE E'a%')
63−ilike :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)
64−ilike = unsafeBinaryOp "ILIKE"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hsdeleted−157
@@ -1,157 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.TextSearch
3−Description: Text search expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Text search functions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , TypeOperators
15−#-}
16−
17−module Squeal.PostgreSQL.Expression.TextSearch
18− ( (@@)
19− , (.&)
20− , (.|)
21− , (.!)
22− , (<->)
23− , arrayToTSvector
24− , tsvectorLength
25− , numnode
26− , plainToTSquery
27− , phraseToTSquery
28− , websearchToTSquery
29− , queryTree
30− , toTSquery
31− , toTSvector
32− , setWeight
33− , strip
34− , jsonToTSvector
35− , jsonbToTSvector
36− , tsDelete
37− , tsFilter
38− , tsHeadline
39− ) where
40−
41−import Squeal.PostgreSQL.Expression
42−import Squeal.PostgreSQL.List
43−import Squeal.PostgreSQL.Schema
44−
45−-- | `Squeal.PostgreSQL.Expression.Type.tsvector` matches tsquery ?
46−(@@) :: Operator (null 'PGtsvector) (null 'PGtsquery) ('Null 'PGbool)
47−(@@) = unsafeBinaryOp "@@"
48−
49−-- | AND `Squeal.PostgreSQL.Expression.Type.tsquery`s together
50−(.&) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
51−(.&) = unsafeBinaryOp "&&"
52−
53−-- | OR `Squeal.PostgreSQL.Expression.Type.tsquery`s together
54−(.|) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
55−(.|) = unsafeBinaryOp "||"
56−
57−-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`
58−(.!) :: null 'PGtsquery --> null 'PGtsquery
59−(.!) = unsafeLeftOp "!!"
60−
61−-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by
62−-- `Squeal.PostgreSQL.Expression.Type.tsquery`
63−(<->) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
64−(<->) = unsafeBinaryOp "<->"
65−
66−-- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector`
67−arrayToTSvector
68− :: null ('PGvararray ('NotNull 'PGtext))
69− --> null 'PGtsvector
70−arrayToTSvector = unsafeFunction "array_to_tsvector"
71−
72−-- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`
73−tsvectorLength :: null 'PGtsvector --> null 'PGint4
74−tsvectorLength = unsafeFunction "length"
75−
76−-- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`
77−numnode :: null 'PGtsquery --> null 'PGint4
78−numnode = unsafeFunction "numnode"
79−
80−-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation
81−plainToTSquery :: null 'PGtext --> null 'PGtsquery
82−plainToTSquery = unsafeFunction "plainto_tsquery"
83−
84−-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase,
85−-- ignoring punctuation
86−phraseToTSquery :: null 'PGtext --> null 'PGtsquery
87−phraseToTSquery = unsafeFunction "phraseto_tsquery"
88−
89−-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query
90−websearchToTSquery :: null 'PGtext --> null 'PGtsquery
91−websearchToTSquery = unsafeFunction "websearch_to_tsquery"
92−
93−-- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`
94−queryTree :: null 'PGtsquery --> null 'PGtext
95−queryTree = unsafeFunction "query_tree"
96−
97−-- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`
98−toTSquery :: null 'PGtext --> null 'PGtsquery
99−toTSquery = unsafeFunction "to_tsquery"
100−
101−-- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector`
102−toTSvector
103− :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
104− => null ty --> null 'PGtsvector
105−toTSvector = unsafeFunction "to_tsvector"
106−
107−-- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`
108−setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector
109−setWeight = unsafeFunctionN "set_weight"
110−
111−-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
112−strip :: null 'PGtsvector --> null 'PGtsvector
113−strip = unsafeFunction "strip"
114−
115−-- | @jsonToTSvector (document *: filter)@
116−-- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,
117−-- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.
118−-- filter is a `Squeal.PostgreSQL.Expression.Type.json` array, that enumerates what kind of elements
119−-- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.
120−-- Possible values for filter are "string" (to include all string values),
121−-- "numeric" (to include all numeric values in the string format),
122−-- "boolean" (to include all Boolean values in the string format "true"/"false"),
123−-- "key" (to include all keys) or "all" (to include all above).
124−-- These values can be combined together to include, e.g. all string and numeric values.
125−jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector
126−jsonToTSvector = unsafeFunctionN "json_to_tsvector"
127−
128−-- | @jsonbToTSvector (document *: filter)@
129−-- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,
130−-- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.
131−-- filter is a `Squeal.PostgreSQL.Expression.Type.jsonb` array, that enumerates what kind of elements
132−-- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.
133−-- Possible values for filter are "string" (to include all string values),
134−-- "numeric" (to include all numeric values in the string format),
135−-- "boolean" (to include all Boolean values in the string format "true"/"false"),
136−-- "key" (to include all keys) or "all" (to include all above).
137−-- These values can be combined together to include, e.g. all string and numeric values.
138−jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector
139−jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"
140−
141−-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`
142−tsDelete ::
143− '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]
144− ---> null 'PGtsvector
145−tsDelete = unsafeFunctionN "ts_delete"
146−
147−-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
148−tsFilter ::
149− '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]
150− ---> null 'PGtsvector
151−tsFilter = unsafeFunctionN "ts_filter"
152−
153−-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match
154−tsHeadline
155− :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
156− => '[null document, null 'PGtsquery] ---> null 'PGtext
157−tsHeadline = unsafeFunctionN "ts_headline"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hsdeleted−192
@@ -1,192 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Time
3−Description: Date/Time expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Date/Time functions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , DeriveGeneric
14− , FunctionalDependencies
15− , LambdaCase
16− , MultiParamTypeClasses
17− , OverloadedStrings
18− , PolyKinds
19− , RankNTypes
20− , TypeOperators
21−#-}
22−
23−module Squeal.PostgreSQL.Expression.Time
24− ( TimeOp (..)
25− , currentDate
26− , currentTime
27− , currentTimestamp
28− , localTime
29− , localTimestamp
30− , now
31− , makeDate
32− , makeTime
33− , makeTimestamp
34− , makeTimestamptz
35− , interval_
36− , TimeUnit (..)
37− ) where
38−
39−import Data.String
40−
41−import qualified GHC.Generics as GHC
42−import qualified Generics.SOP as SOP
43−
44−import Squeal.PostgreSQL.Expression
45−import Squeal.PostgreSQL.Render
46−import Squeal.PostgreSQL.Schema
47−
48−-- $setup
49−-- >>> import Squeal.PostgreSQL
50−
51−-- | >>> printSQL currentDate
52−-- CURRENT_DATE
53−currentDate :: Expr (null 'PGdate)
54−currentDate = UnsafeExpression "CURRENT_DATE"
55−
56−-- | >>> printSQL currentTime
57−-- CURRENT_TIME
58−currentTime :: Expr (null 'PGtimetz)
59−currentTime = UnsafeExpression "CURRENT_TIME"
60−
61−-- | >>> printSQL currentTimestamp
62−-- CURRENT_TIMESTAMP
63−currentTimestamp :: Expr (null 'PGtimestamptz)
64−currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"
65−
66−-- | >>> printSQL localTime
67−-- LOCALTIME
68−localTime :: Expr (null 'PGtime)
69−localTime = UnsafeExpression "LOCALTIME"
70−
71−-- | >>> printSQL localTimestamp
72−-- LOCALTIMESTAMP
73−localTimestamp :: Expr (null 'PGtimestamp)
74−localTimestamp = UnsafeExpression "LOCALTIMESTAMP"
75−
76−-- | Current date and time (equivalent to `currentTimestamp`)
77−--
78−-- >>> printSQL now
79−-- now()
80−now :: Expr (null 'PGtimestamptz)
81−now = UnsafeExpression "now()"
82−
83−{-|
84−Create date from year, month and day fields
85−
86−>>> printSQL (makeDate (1984 :* 7 *: 3))
87−make_date(1984, 7, 3)
88−-}
89−makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate
90−makeDate = unsafeFunctionN "make_date"
91−
92−{-|
93−Create time from hour, minute and seconds fields
94−
95−>>> printSQL (makeTime (8 :* 15 *: 23.5))
96−make_time(8, 15, 23.5)
97−-}
98−makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime
99−makeTime = unsafeFunctionN "make_time"
100−
101−{-|
102−Create timestamp from year, month, day, hour, minute and seconds fields
103−
104−>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
105−make_timestamp(2013, 7, 15, 8, 15, 23.5)
106−-}
107−makeTimestamp ::
108− '[ null 'PGint4, null 'PGint4, null 'PGint4
109− , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp
110−makeTimestamp = unsafeFunctionN "make_timestamp"
111−
112−{-|
113−Create timestamp with time zone from
114−year, month, day, hour, minute and seconds fields;
115−the current time zone is used
116−
117−>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
118−make_timestamptz(2013, 7, 15, 8, 15, 23.5)
119−-}
120−makeTimestamptz ::
121− '[ null 'PGint4, null 'PGint4, null 'PGint4
122− , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz
123−makeTimestamptz = unsafeFunctionN "make_timestamptz"
124−
125−{-|
126−Affine space operations on time types.
127−-}
128−class TimeOp time diff | time -> diff where
129− {-|
130− >>> printSQL (makeDate (1984 :* 7 *: 3) !+ 365)
131− (make_date(1984, 7, 3) + 365)
132− -}
133− (!+) :: Operator (null time) (null diff) (null time)
134− (!+) = unsafeBinaryOp "+"
135− {-|
136− >>> printSQL (365 +! makeDate (1984 :* 7 *: 3))
137− (365 + make_date(1984, 7, 3))
138− -}
139− (+!) :: Operator (null diff) (null time) (null time)
140− (+!) = unsafeBinaryOp "+"
141− {-|
142− >>> printSQL (makeDate (1984 :* 7 *: 3) !- 365)
143− (make_date(1984, 7, 3) - 365)
144− -}
145− (!-) :: Operator (null time) (null diff) (null time)
146− (!-) = unsafeBinaryOp "-"
147− {-|
148− >>> printSQL (makeDate (1984 :* 7 *: 3) !-! currentDate)
149− (make_date(1984, 7, 3) - CURRENT_DATE)
150− -}
151− (!-!) :: Operator (null time) (null time) (null diff)
152− (!-!) = unsafeBinaryOp "-"
153−instance TimeOp 'PGtimestamp 'PGinterval
154−instance TimeOp 'PGtimestamptz 'PGinterval
155−instance TimeOp 'PGtime 'PGinterval
156−instance TimeOp 'PGtimetz 'PGinterval
157−instance TimeOp 'PGinterval 'PGinterval
158−instance TimeOp 'PGdate 'PGint4
159−infixl 6 !+
160−infixl 6 +!
161−infixl 6 !-
162−infixl 6 !-!
163−
164−-- | A `TimeUnit` to use in `interval_` construction.
165−data TimeUnit
166− = Years | Months | Weeks | Days
167− | Hours | Minutes | Seconds
168− | Microseconds | Milliseconds
169− | Decades | Centuries | Millennia
170− deriving (Eq, Ord, Show, Read, Enum, GHC.Generic)
171−instance SOP.Generic TimeUnit
172−instance SOP.HasDatatypeInfo TimeUnit
173−instance RenderSQL TimeUnit where
174− renderSQL = \case
175− Years -> "years"
176− Months -> "months"
177− Weeks -> "weeks"
178− Days -> "days"
179− Hours -> "hours"
180− Minutes -> "minutes"
181− Seconds -> "seconds"
182− Microseconds -> "microseconds"
183− Milliseconds -> "milliseconds"
184− Decades -> "decades"
185− Centuries -> "centuries"
186− Millennia -> "millennia"
187−
188−-- | >>> printSQL $ interval_ 7 Days
189−-- (INTERVAL '7.0 days')
190−interval_ :: Double -> TimeUnit -> Expr (null 'PGinterval)
191−interval_ num unit = UnsafeExpression . parenthesized $ "INTERVAL" <+>
192− "'" <> fromString (show num) <+> renderSQL unit <> "'"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hsdeleted−446
@@ -1,446 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression
3−Description: Type expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Type expressions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DataKinds
14− , DeriveGeneric
15− , FlexibleContexts
16− , FlexibleInstances
17− , GADTs
18− , GeneralizedNewtypeDeriving
19− , KindSignatures
20− , MultiParamTypeClasses
21− , OverloadedStrings
22− , RankNTypes
23− , ScopedTypeVariables
24− , TypeApplications
25− , TypeOperators
26− , UndecidableInstances
27−#-}
28−
29−module Squeal.PostgreSQL.Expression.Type
30− ( -- * type casting
31− cast
32− , astype
33− , inferredtype
34− -- * type expressions
35− , TypeExpression (..)
36− , typedef
37− , typetable
38− , typeview
39− , bool
40− , int2
41− , smallint
42− , int4
43− , int
44− , integer
45− , int8
46− , bigint
47− , numeric
48− , float4
49− , real
50− , float8
51− , doublePrecision
52− , money
53− , text
54− , char
55− , character
56− , varchar
57− , characterVarying
58− , bytea
59− , timestamp
60− , timestampWithTimeZone
61− , timestamptz
62− , date
63− , time
64− , timeWithTimeZone
65− , timetz
66− , interval
67− , uuid
68− , inet
69− , json
70− , jsonb
71− , vararray
72− , fixarray
73− , tsvector
74− , tsquery
75− , oid
76− , int4range
77− , int8range
78− , numrange
79− , tsrange
80− , tstzrange
81− , daterange
82− -- * column type definitions
83− , ColumnTypeExpression (..)
84− , nullable
85− , notNullable
86− , default_
87− , serial2
88− , smallserial
89− , serial4
90− , serial
91− , serial8
92− , bigserial
93− , hask
94− -- * type inference
95− , PGTyped (..)
96− , PGNullityTyped (..)
97− , FieldTyped (..)
98− ) where
99−
100−import Control.DeepSeq
101−import Data.ByteString
102−import Data.String
103−import GHC.TypeLits
104−
105−import qualified Data.ByteString as ByteString
106−import qualified GHC.Generics as GHC
107−import qualified Generics.SOP as SOP
108−
109−import Squeal.PostgreSQL.Alias
110−import Squeal.PostgreSQL.Expression
111−import Squeal.PostgreSQL.PG
112−import Squeal.PostgreSQL.Render
113−import Squeal.PostgreSQL.Schema
114−
115−-- $setup
116−-- >>> import Squeal.PostgreSQL
117−
118−-- When a `cast` is applied to an `Expression` of a known type, it
119−-- represents a run-time type conversion. The cast will succeed only if a
120−-- suitable type conversion operation has been defined.
121−--
122−-- | >>> printSQL $ true & cast int4
123−-- (TRUE :: int4)
124−cast
125− :: TypeExpression schemas ty1
126− -- ^ type to cast as
127− -> Expression outer commons grp schemas params from ty0
128− -- ^ value to convert
129− -> Expression outer commons grp schemas params from ty1
130−cast ty x = UnsafeExpression $ parenthesized $
131− renderSQL x <+> "::" <+> renderSQL ty
132−
133−-- | A safe version of `cast` which just matches a value with its type.
134−--
135−-- >>> printSQL (1 & astype int)
136−-- (1 :: int)
137−astype
138− :: TypeExpression schemas ty
139− -- ^ type to specify as
140− -> Expression outer commons grp schemas params from ty
141− -- ^ value
142− -> Expression outer commons grp schemas params from ty
143−astype = cast
144−
145−-- | `inferredtype` will add a type annotation to an `Expression`
146−-- which can be useful for fixing the storage type of a value.
147−--
148−-- >>> printSQL (inferredtype true)
149−-- (TRUE :: bool)
150−inferredtype
151− :: PGTyped schemas ty
152− => Expression outer common grp schemas params from ty
153− -- ^ value
154− -> Expression outer common grp schemas params from ty
155−inferredtype = astype pgtype
156−
157−{-----------------------------------------
158−type expressions
159−-----------------------------------------}
160−
161−-- | `TypeExpression`s are used in `cast`s and
162−-- `Squeal.PostgreSQL.Definition.createTable` commands.
163−newtype TypeExpression (schemas :: SchemasType) (ty :: NullityType)
164− = UnsafeTypeExpression { renderTypeExpression :: ByteString }
165− deriving (GHC.Generic,Show,Eq,Ord,NFData)
166−instance RenderSQL (TypeExpression schemas ty) where
167− renderSQL = renderTypeExpression
168−
169−-- | The enum or composite type in a `Typedef` can be expressed by its alias.
170−typedef
171− :: (Has sch schemas schema, Has td schema ('Typedef ty))
172− => QualifiedAlias sch td
173− -- ^ type alias
174− -> TypeExpression schemas (null ty)
175−typedef = UnsafeTypeExpression . renderSQL
176−
177−-- | The composite type corresponding to a `Table` definition can be expressed
178−-- by its alias.
179−typetable
180− :: (Has sch schemas schema, Has tab schema ('Table table))
181− => QualifiedAlias sch tab
182− -- ^ table alias
183− -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))
184−typetable = UnsafeTypeExpression . renderSQL
185−
186−-- | The composite type corresponding to a `View` definition can be expressed
187−-- by its alias.
188−typeview
189− :: (Has sch schemas schema, Has vw schema ('View view))
190− => QualifiedAlias sch vw
191− -- ^ view alias
192− -> TypeExpression schemas (null ('PGcomposite view))
193−typeview = UnsafeTypeExpression . renderSQL
194−
195−-- | logical Boolean (true/false)
196−bool :: TypeExpression schemas (null 'PGbool)
197−bool = UnsafeTypeExpression "bool"
198−-- | signed two-byte integer
199−int2, smallint :: TypeExpression schemas (null 'PGint2)
200−int2 = UnsafeTypeExpression "int2"
201−smallint = UnsafeTypeExpression "smallint"
202−-- | signed four-byte integer
203−int4, int, integer :: TypeExpression schemas (null 'PGint4)
204−int4 = UnsafeTypeExpression "int4"
205−int = UnsafeTypeExpression "int"
206−integer = UnsafeTypeExpression "integer"
207−-- | signed eight-byte integer
208−int8, bigint :: TypeExpression schemas (null 'PGint8)
209−int8 = UnsafeTypeExpression "int8"
210−bigint = UnsafeTypeExpression "bigint"
211−-- | arbitrary precision numeric type
212−numeric :: TypeExpression schemas (null 'PGnumeric)
213−numeric = UnsafeTypeExpression "numeric"
214−-- | single precision floating-point number (4 bytes)
215−float4, real :: TypeExpression schemas (null 'PGfloat4)
216−float4 = UnsafeTypeExpression "float4"
217−real = UnsafeTypeExpression "real"
218−-- | double precision floating-point number (8 bytes)
219−float8, doublePrecision :: TypeExpression schemas (null 'PGfloat8)
220−float8 = UnsafeTypeExpression "float8"
221−doublePrecision = UnsafeTypeExpression "double precision"
222−-- | currency amount
223−money :: TypeExpression schema (null 'PGmoney)
224−money = UnsafeTypeExpression "money"
225−-- | variable-length character string
226−text :: TypeExpression schemas (null 'PGtext)
227−text = UnsafeTypeExpression "text"
228−-- | fixed-length character string
229−char, character
230− :: forall n schemas null. (KnownNat n, 1 <= n)
231− => TypeExpression schemas (null ('PGchar n))
232−char = UnsafeTypeExpression $ "char(" <> renderNat @n <> ")"
233−character = UnsafeTypeExpression $ "character(" <> renderNat @n <> ")"
234−-- | variable-length character string
235−varchar, characterVarying
236− :: forall n schemas null. (KnownNat n, 1 <= n)
237− => TypeExpression schemas (null ('PGvarchar n))
238−varchar = UnsafeTypeExpression $ "varchar(" <> renderNat @n <> ")"
239−characterVarying = UnsafeTypeExpression $
240− "character varying(" <> renderNat @n <> ")"
241−-- | binary data ("byte array")
242−bytea :: TypeExpression schemas (null 'PGbytea)
243−bytea = UnsafeTypeExpression "bytea"
244−-- | date and time (no time zone)
245−timestamp :: TypeExpression schemas (null 'PGtimestamp)
246−timestamp = UnsafeTypeExpression "timestamp"
247−-- | date and time, including time zone
248−timestampWithTimeZone, timestamptz :: TypeExpression schemas (null 'PGtimestamptz)
249−timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
250−timestamptz = UnsafeTypeExpression "timestamptz"
251−-- | calendar date (year, month, day)
252−date :: TypeExpression schemas (null 'PGdate)
253−date = UnsafeTypeExpression "date"
254−-- | time of day (no time zone)
255−time :: TypeExpression schemas (null 'PGtime)
256−time = UnsafeTypeExpression "time"
257−-- | time of day, including time zone
258−timeWithTimeZone, timetz :: TypeExpression schemas (null 'PGtimetz)
259−timeWithTimeZone = UnsafeTypeExpression "time with time zone"
260−timetz = UnsafeTypeExpression "timetz"
261−-- | time span
262−interval :: TypeExpression schemas (null 'PGinterval)
263−interval = UnsafeTypeExpression "interval"
264−-- | universally unique identifier
265−uuid :: TypeExpression schemas (null 'PGuuid)
266−uuid = UnsafeTypeExpression "uuid"
267−-- | IPv4 or IPv6 host address
268−inet :: TypeExpression schemas (null 'PGinet)
269−inet = UnsafeTypeExpression "inet"
270−-- | textual JSON data
271−json :: TypeExpression schemas (null 'PGjson)
272−json = UnsafeTypeExpression "json"
273−-- | binary JSON data, decomposed
274−jsonb :: TypeExpression schemas (null 'PGjsonb)
275−jsonb = UnsafeTypeExpression "jsonb"
276−-- | variable length array
277−vararray
278− :: TypeExpression schemas pg
279− -> TypeExpression schemas (null ('PGvararray pg))
280−vararray ty = UnsafeTypeExpression $ renderSQL ty <> "[]"
281−-- | fixed length array
282−--
283−-- >>> renderSQL (fixarray @'[2] json)
284−-- "json[2]"
285−fixarray
286− :: forall dims schemas null pg. SOP.All KnownNat dims
287− => TypeExpression schemas pg
288− -> TypeExpression schemas (null ('PGfixarray dims pg))
289−fixarray ty = UnsafeTypeExpression $
290− renderSQL ty <> renderDims @dims
291− where
292− renderDims :: forall ns. SOP.All KnownNat ns => ByteString
293− renderDims =
294− ("[" <>)
295− . (<> "]")
296− . ByteString.intercalate "]["
297− . SOP.hcollapse
298− $ SOP.hcmap (SOP.Proxy @KnownNat)
299− (K . fromString . show . natVal)
300− (SOP.hpure SOP.Proxy :: SOP.NP SOP.Proxy ns)
301−-- | text search query
302−tsvector :: TypeExpression schemas (null 'PGtsvector)
303−tsvector = UnsafeTypeExpression "tsvector"
304−-- | text search document
305−tsquery :: TypeExpression schemas (null 'PGtsquery)
306−tsquery = UnsafeTypeExpression "tsquery"
307−-- | Object identifiers (OIDs) are used internally by PostgreSQL
308−-- as primary keys for various system tables.
309−oid :: TypeExpression schemas (null 'PGoid)
310−oid = UnsafeTypeExpression "oid"
311−-- | Range of integer
312−int4range :: TypeExpression schemas (null ('PGrange 'PGint4))
313−int4range = UnsafeTypeExpression "int4range"
314−-- | Range of bigint
315−int8range :: TypeExpression schemas (null ('PGrange 'PGint8))
316−int8range = UnsafeTypeExpression "int8range"
317−-- | Range of numeric
318−numrange :: TypeExpression schemas (null ('PGrange 'PGnumeric))
319−numrange = UnsafeTypeExpression "numrange"
320−-- | Range of timestamp without time zone
321−tsrange :: TypeExpression schemas (null ('PGrange 'PGtimestamp))
322−tsrange = UnsafeTypeExpression "tsrange"
323−-- | Range of timestamp with time zone
324−tstzrange :: TypeExpression schemas (null ('PGrange 'PGtimestamptz))
325−tstzrange = UnsafeTypeExpression "tstzrange"
326−-- | Range of date
327−daterange :: TypeExpression schemas (null ('PGrange 'PGdate))
328−daterange = UnsafeTypeExpression "daterange"
329−
330−-- | `pgtype` is a demoted version of a `PGType`
331−class PGTyped schemas (ty :: NullityType) where
332− pgtype :: TypeExpression schemas ty
333−instance PGTyped schemas (null 'PGbool) where pgtype = bool
334−instance PGTyped schemas (null 'PGint2) where pgtype = int2
335−instance PGTyped schemas (null 'PGint4) where pgtype = int4
336−instance PGTyped schemas (null 'PGint8) where pgtype = int8
337−instance PGTyped schemas (null 'PGnumeric) where pgtype = numeric
338−instance PGTyped schemas (null 'PGfloat4) where pgtype = float4
339−instance PGTyped schemas (null 'PGfloat8) where pgtype = float8
340−instance PGTyped schemas (null 'PGmoney) where pgtype = money
341−instance PGTyped schemas (null 'PGtext) where pgtype = text
342−instance (KnownNat n, 1 <= n)
343− => PGTyped schemas (null ('PGchar n)) where pgtype = char @n
344−instance (KnownNat n, 1 <= n)
345− => PGTyped schemas (null ('PGvarchar n)) where pgtype = varchar @n
346−instance PGTyped schemas (null 'PGbytea) where pgtype = bytea
347−instance PGTyped schemas (null 'PGtimestamp) where pgtype = timestamp
348−instance PGTyped schemas (null 'PGtimestamptz) where pgtype = timestampWithTimeZone
349−instance PGTyped schemas (null 'PGdate) where pgtype = date
350−instance PGTyped schemas (null 'PGtime) where pgtype = time
351−instance PGTyped schemas (null 'PGtimetz) where pgtype = timeWithTimeZone
352−instance PGTyped schemas (null 'PGinterval) where pgtype = interval
353−instance PGTyped schemas (null 'PGuuid) where pgtype = uuid
354−instance PGTyped schemas (null 'PGjson) where pgtype = json
355−instance PGTyped schemas (null 'PGjsonb) where pgtype = jsonb
356−instance PGTyped schemas ty
357− => PGTyped schemas (null ('PGvararray ty)) where
358− pgtype = vararray (pgtype @schemas @ty)
359−instance (SOP.All KnownNat dims, PGTyped schemas ty)
360− => PGTyped schemas (null ('PGfixarray dims ty)) where
361− pgtype = fixarray @dims (pgtype @schemas @ty)
362−instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector
363−instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery
364−instance PGTyped schemas (null 'PGoid) where pgtype = oid
365−instance PGTyped schemas (null ('PGrange 'PGint4)) where pgtype = int4range
366−instance PGTyped schemas (null ('PGrange 'PGint8)) where pgtype = int8range
367−instance PGTyped schemas (null ('PGrange 'PGnumeric)) where pgtype = numrange
368−instance PGTyped schemas (null ('PGrange 'PGtimestamp)) where pgtype = tsrange
369−instance PGTyped schemas (null ('PGrange 'PGtimestamptz)) where pgtype = tstzrange
370−instance PGTyped schemas (null ('PGrange 'PGdate)) where pgtype = daterange
371−
372−-- | Lift `PGTyped` to a field
373−class FieldTyped schemas ty where
374− fieldtype :: Aliased (TypeExpression schemas) ty
375−instance (KnownSymbol alias, PGTyped schemas ty)
376− => FieldTyped schemas (alias ::: ty) where
377− fieldtype = pgtype `As` Alias
378−
379−-- | `ColumnTypeExpression`s are used in `createTable` commands.
380−newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
381− = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
382− deriving (GHC.Generic,Show,Eq,Ord,NFData)
383−instance RenderSQL (ColumnTypeExpression schemas ty) where
384− renderSQL = renderColumnTypeExpression
385−
386−-- | used in `createTable` commands as a column constraint to note that
387−-- @NULL@ may be present in a column
388−nullable
389− :: TypeExpression schemas (nullity ty)
390− -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
391−nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
392−
393−-- | used in `createTable` commands as a column constraint to ensure
394−-- @NULL@ is not present in a column
395−notNullable
396− :: TypeExpression schemas (nullity ty)
397− -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
398−notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
399−
400−-- | used in `createTable` commands as a column constraint to give a default
401−default_
402− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
403− -> ColumnTypeExpression schemas ('NoDef :=> ty)
404− -> ColumnTypeExpression schemas ('Def :=> ty)
405−default_ x ty = UnsafeColumnTypeExpression $
406− renderSQL ty <+> "DEFAULT" <+> renderExpression x
407−
408−-- | not a true type, but merely a notational convenience for creating
409−-- unique identifier columns with type `PGint2`
410−serial2, smallserial
411− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
412−serial2 = UnsafeColumnTypeExpression "serial2"
413−smallserial = UnsafeColumnTypeExpression "smallserial"
414−-- | not a true type, but merely a notational convenience for creating
415−-- unique identifier columns with type `PGint4`
416−serial4, serial
417− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
418−serial4 = UnsafeColumnTypeExpression "serial4"
419−serial = UnsafeColumnTypeExpression "serial"
420−-- | not a true type, but merely a notational convenience for creating
421−-- unique identifier columns with type `PGint8`
422−serial8, bigserial
423− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
424−serial8 = UnsafeColumnTypeExpression "serial8"
425−bigserial = UnsafeColumnTypeExpression "bigserial"
426−
427−-- | Like @PGTyped@ but also accounts for nullity.
428−class PGNullityTyped schemas (nullty :: NullityType) where
429− pgNullityType :: ColumnTypeExpression schemas ('NoDef :=> nullty)
430−
431−instance PGTyped schemas ('Null ty) => PGNullityTyped schemas ('Null ty) where
432− pgNullityType = nullable (pgtype @_ @('Null ty))
433−
434−instance PGTyped schemas ('NotNull ty) => PGNullityTyped schemas ('NotNull ty) where
435− pgNullityType = notNullable (pgtype @_ @('NotNull ty))
436−
437−-- | Allow you to specify pg column types in relation to haskell types.
438−-- >>> printSQL $ hask @(Maybe String)
439−-- text NULL
440−--
441−-- >>> printSQL $ hask @Double
442−-- float8 NOT NULL
443−hask
444− :: forall hask schemas. PGNullityTyped schemas (NullPG hask)
445− => ColumnTypeExpression schemas ('NoDef :=> NullPG hask)
446−hask = pgNullityType
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Window.hsdeleted−284
@@ -1,284 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Window
3−Description: Window functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Window functions and definitions
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , DeriveGeneric
14− , FlexibleContexts
15− , FlexibleInstances
16− , GADTs
17− , GeneralizedNewtypeDeriving
18− , LambdaCase
19− , MultiParamTypeClasses
20− , OverloadedStrings
21− , RankNTypes
22− , KindSignatures
23−#-}
24−
25−module Squeal.PostgreSQL.Expression.Window
26− ( -- * functions
27− partitionBy
28− , rank
29− , rowNumber
30− , denseRank
31− , percentRank
32− , cumeDist
33− , ntile
34− , lag
35− , lead
36− , firstValue
37− , lastValue
38− , nthValue
39− , unsafeWindowFunction1
40− , unsafeWindowFunctionN
41− -- * types
42− , WindowFunction (..)
43− , WindowDefinition (..)
44− , WinFun0
45− , WinFun1
46− , WinFunN
47− ) where
48−
49−import Control.DeepSeq
50−import Data.ByteString
51−
52−import qualified GHC.Generics as GHC
53−import qualified Generics.SOP as SOP
54−
55−import Squeal.PostgreSQL.Alias
56−import Squeal.PostgreSQL.Expression
57−import Squeal.PostgreSQL.Expression.Aggregate
58−import Squeal.PostgreSQL.Expression.Sort
59−import Squeal.PostgreSQL.List
60−import Squeal.PostgreSQL.Render
61−import Squeal.PostgreSQL.Schema
62−
63−instance Aggregate
64− (Expression outer commons grp schemas params from)
65− (NP (Expression outer commons grp schemas params from))
66− (WindowFunction outer commons grp schemas params from) where
67− countStar = UnsafeWindowFunction "count(*)"
68− count = unsafeWindowFunction1 "count"
69− sum_ = unsafeWindowFunction1 "sum"
70− arrayAgg = unsafeWindowFunction1 "array_agg"
71− jsonAgg = unsafeWindowFunction1 "json_agg"
72− jsonbAgg = unsafeWindowFunction1 "jsonb_agg"
73− bitAnd = unsafeWindowFunction1 "bit_and"
74− bitOr = unsafeWindowFunction1 "bit_or"
75− boolAnd = unsafeWindowFunction1 "bool_and"
76− boolOr = unsafeWindowFunction1 "bool_or"
77− every = unsafeWindowFunction1 "every"
78− max_ = unsafeWindowFunction1 "max"
79− min_ = unsafeWindowFunction1 "min"
80− avg = unsafeWindowFunction1 "avg"
81− corr = unsafeWindowFunctionN "corr"
82− covarPop = unsafeWindowFunctionN "covar_pop"
83− covarSamp = unsafeWindowFunctionN "covar_samp"
84− regrAvgX = unsafeWindowFunctionN "regr_avgx"
85− regrAvgY = unsafeWindowFunctionN "regr_avgy"
86− regrCount = unsafeWindowFunctionN "regr_count"
87− regrIntercept = unsafeWindowFunctionN "regr_intercept"
88− regrR2 = unsafeWindowFunctionN "regr_r2"
89− regrSlope = unsafeWindowFunctionN "regr_slope"
90− regrSxx = unsafeWindowFunctionN "regr_sxx"
91− regrSxy = unsafeWindowFunctionN "regr_sxy"
92− regrSyy = unsafeWindowFunctionN "regr_syy"
93− stddev = unsafeWindowFunction1 "stddev"
94− stddevPop = unsafeWindowFunction1 "stddev_pop"
95− stddevSamp = unsafeWindowFunction1 "stddev_samp"
96− variance = unsafeWindowFunction1 "variance"
97− varPop = unsafeWindowFunction1 "var_pop"
98− varSamp = unsafeWindowFunction1 "var_samp"
99−
100−-- | A `WindowDefinition` is a set of table rows that are somehow related
101−-- to the current row
102−data WindowDefinition outer commons grp schemas params from where
103− WindowDefinition
104− :: SOP.SListI bys
105− => NP (Expression outer commons grp schemas params from) bys
106− -- ^ `partitionBy` clause
107− -> [SortExpression outer commons grp schemas params from]
108− -- ^ `Squeal.PostgreSQL.Expression.Sort.orderBy` clause
109− -> WindowDefinition outer commons grp schemas params from
110−
111−instance OrderBy WindowDefinition where
112− orderBy sortsR (WindowDefinition parts sortsL)
113− = WindowDefinition parts (sortsL ++ sortsR)
114−
115−instance RenderSQL (WindowDefinition outer commons schemas from grp params) where
116− renderSQL (WindowDefinition part ord) =
117− renderPartitionByClause part <> renderOrderByClause ord
118− where
119− renderPartitionByClause = \case
120− Nil -> ""
121− parts -> "PARTITION" <+> "BY" <+> renderCommaSeparated renderExpression parts
122− renderOrderByClause = \case
123− [] -> ""
124− srts -> " ORDER" <+> "BY"
125− <+> commaSeparated (renderSQL <$> srts)
126−
127−{- |
128−The `partitionBy` clause within `Squeal.PostgreSQL.Query.Over` divides the rows into groups,
129−or partitions, that share the same values of the `partitionBy` `Expression`(s).
130−For each row, the window function is computed across the rows that fall into
131−the same partition as the current row.
132−-}
133−partitionBy
134− :: SOP.SListI bys
135− => NP (Expression outer commons grp schemas params from) bys -- ^ partitions
136− -> WindowDefinition outer commons grp schemas params from
137−partitionBy bys = WindowDefinition bys []
138−
139−{- |
140−A window function performs a calculation across a set of table rows
141−that are somehow related to the current row. This is comparable to the type
142−of calculation that can be done with an aggregate function.
143−However, window functions do not cause rows to become grouped into a single
144−output row like non-window aggregate calls would.
145−Instead, the rows retain their separate identities.
146−Behind the scenes, the window function is able to access more than
147−just the current row of the query result.
148−-}
149−newtype WindowFunction
150− (outer :: FromType)
151− (commons :: FromType)
152− (grp :: Grouping)
153− (schemas :: SchemasType)
154− (params :: [NullityType])
155− (from :: FromType)
156− (ty :: NullityType)
157− = UnsafeWindowFunction { renderWindowFunction :: ByteString }
158− deriving (GHC.Generic,Show,Eq,Ord,NFData)
159−
160−instance RenderSQL (WindowFunction outer commons grp schemas params from ty) where
161− renderSQL = renderWindowFunction
162−
163−{- |
164−A @RankNType@ for window functions with no arguments.
165−-}
166−type WinFun0 x
167− = forall outer commons grp schemas params from
168− . WindowFunction outer commons grp schemas params from x
169− -- ^ cannot reference aliases
170−
171−{- |
172−A @RankNType@ for window functions with 1 argument.
173−-}
174−type WinFun1 x y
175− = forall outer commons grp schemas params from
176− . Expression outer commons grp schemas params from x
177− -- ^ input
178− -> WindowFunction outer commons grp schemas params from y
179− -- ^ output
180−
181−{- | A @RankNType@ for window functions with a fixed-length
182−list of heterogeneous arguments.
183−Use the `*:` operator to end your argument lists.
184−-}
185−type WinFunN xs y
186− = forall outer commons grp schemas params from
187− . NP (Expression outer commons grp schemas params from) xs
188− -- ^ inputs
189− -> WindowFunction outer commons grp schemas params from y
190− -- ^ output
191−
192−-- | escape hatch for defining window functions
193−unsafeWindowFunction1 :: ByteString -> WinFun1 x y
194−unsafeWindowFunction1 fun x
195− = UnsafeWindowFunction $ fun <> parenthesized (renderSQL x)
196−
197−-- | escape hatch for defining multi-argument window functions
198−unsafeWindowFunctionN :: SOP.SListI xs => ByteString -> WinFunN xs y
199−unsafeWindowFunctionN fun xs = UnsafeWindowFunction $ fun <>
200− parenthesized (renderCommaSeparated renderSQL xs)
201−
202−{- | rank of the current row with gaps; same as `rowNumber` of its first peer
203−
204−>>> printSQL rank
205−rank()
206−-}
207−rank :: WinFun0 ('NotNull 'PGint8)
208−rank = UnsafeWindowFunction "rank()"
209−
210−{- | number of the current row within its partition, counting from 1
211−
212−>>> printSQL rowNumber
213−row_number()
214−-}
215−rowNumber :: WinFun0 ('NotNull 'PGint8)
216−rowNumber = UnsafeWindowFunction "row_number()"
217−
218−{- | rank of the current row without gaps; this function counts peer groups
219−
220−>>> printSQL denseRank
221−dense_rank()
222−-}
223−denseRank :: WinFun0 ('NotNull 'PGint8)
224−denseRank = UnsafeWindowFunction "dense_rank()"
225−
226−{- | relative rank of the current row: (rank - 1) / (total partition rows - 1)
227−
228−>>> printSQL percentRank
229−percent_rank()
230−-}
231−percentRank :: WinFun0 ('NotNull 'PGfloat8)
232−percentRank = UnsafeWindowFunction "percent_rank()"
233−
234−{- | cumulative distribution: (number of partition rows
235−preceding or peer with current row) / total partition rows
236−
237−>>> printSQL cumeDist
238−cume_dist()
239−-}
240−cumeDist :: WinFun0 ('NotNull 'PGfloat8)
241−cumeDist = UnsafeWindowFunction "cume_dist()"
242−
243−{- | integer ranging from 1 to the argument value,
244−dividing the partition as equally as possible
245−
246−>>> printSQL $ ntile 5
247−ntile(5)
248−-}
249−ntile :: WinFun1 ('NotNull 'PGint4) ('NotNull 'PGint4)
250−ntile = unsafeWindowFunction1 "ntile"
251−
252−{- | returns value evaluated at the row that is offset rows before the current
253−row within the partition; if there is no such row, instead return default
254−(which must be of the same type as value). Both offset and default are
255−evaluated with respect to the current row.
256−-}
257−lag :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty
258−lag = unsafeWindowFunctionN "lag"
259−
260−{- | returns value evaluated at the row that is offset rows after the current
261−row within the partition; if there is no such row, instead return default
262−(which must be of the same type as value). Both offset and default are
263−evaluated with respect to the current row.
264−-}
265−lead :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty
266−lead = unsafeWindowFunctionN "lead"
267−
268−{- | returns value evaluated at the row that is the
269−first row of the window frame
270−-}
271−firstValue :: WinFun1 ty ty
272−firstValue = unsafeWindowFunction1 "first_value"
273−
274−{- | returns value evaluated at the row that is the
275−last row of the window frame
276−-}
277−lastValue :: WinFun1 ty ty
278−lastValue = unsafeWindowFunction1 "last_value"
279−
280−{- | returns value evaluated at the row that is the nth
281−row of the window frame (counting from 1); null if no such row
282−-}
283−nthValue :: WinFunN '[null ty, 'NotNull 'PGint4] ('Null ty)
284−nthValue = unsafeWindowFunctionN "nth_value"
squeal-postgresql/src/Squeal/PostgreSQL/List.hsdeleted−112
@@ -1,112 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.List
3−Description: List related types and functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Haskell singly-linked lists are very powerful. This module
9−provides functionality for type-level lists, heterogeneous
10−lists and type aligned lists.
11−-}
12−
13−{-# LANGUAGE
14− DataKinds
15− , FlexibleContexts
16− , GADTs
17− , LambdaCase
18− , MultiParamTypeClasses
19− , OverloadedStrings
20− , PolyKinds
21− , QuantifiedConstraints
22− , RankNTypes
23− , ScopedTypeVariables
24− , TypeApplications
25− , TypeFamilies
26− , TypeOperators
27− , UndecidableInstances
28−#-}
29−
30−module Squeal.PostgreSQL.List
31− ( SOP.NP (..)
32− , (*:)
33− , Join
34− , disjoin
35− , Additional (..)
36− , Path (..)
37− , CFunctor (..)
38− , CFoldable (..)
39− , CFree (..)
40− , Elem
41− , In
42− , Length
43− ) where
44−
45−import Control.Category.Free
46−import Data.Function ((&))
47−import Data.Kind
48−import Data.Type.Bool
49−import GHC.TypeLits
50−
51−import Generics.SOP as SOP
52−
53−-- | `Join` is simply promoted `++` and is used in @JOIN@s in
54−-- `Squeal.PostgreSQL.Query.FromClause`s.
55−type family Join xs ys where
56− Join '[] ys = ys
57− Join (x ': xs) ys = x ': Join xs ys
58−
59−-- | `disjoin` is a utility function for splitting an `NP` list into pieces.
60−disjoin
61− :: forall xs ys expr. SListI xs
62− => NP expr (Join xs ys)
63− -> (NP expr xs, NP expr ys)
64−disjoin = case sList @xs of
65− SNil -> \ys -> (Nil, ys)
66− SCons -> \(x :* xsys) ->
67− case disjoin xsys of (xs,ys) -> (x :* xs, ys)
68−
69−-- | The `Additional` class is for appending
70−-- type-level list parameterized constructors such as `NP`,
71−-- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`.
72−class Additional expr where
73− also :: expr ys -> expr xs -> expr (Join xs ys)
74−instance Additional (NP expr) where
75− also ys = \case
76− Nil -> ys
77− x :* xs -> x :* (xs & also ys)
78−
79−-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
80−(*:) :: f x -> f y -> NP f '[x,y]
81−x *: y = x :* y :* Nil
82−infixl 9 *:
83−
84−-- | @Elem@ is a promoted `Data.List.elem`.
85−type family Elem x xs where
86− Elem x '[] = 'False
87− Elem x (x ': _) = 'True
88− Elem x (_ ': x ': _) = 'True
89− Elem x (_ ': _ ': x ': _) = 'True
90− Elem x (_ ': _ ': _ ': x ': _) = 'True
91− Elem x (_ ': _ ': _ ': _ ': x ': _) = 'True
92− Elem x (_ ': _ ': _ ': _ ': _ ': x ': _) = 'True
93− Elem x (_ ': xs) = Elem x xs
94−
95−-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
96−type family In x xs :: Constraint where
97− In x xs = If (Elem x xs) (() :: Constraint)
98− (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs))
99−
100−{- | Calculate the `Length` of a type level list
101−
102−>>> :kind! Length '[Char,String,Bool,Double]
103−Length '[Char,String,Bool,Double] :: Nat
104−= 4
105−-}
106−type family Length (xs :: [k]) :: Nat where
107− Length (_ ': _ ': _ ': _ ': _ : xs) = 5 + Length xs
108− Length (_ ': _ ': _ ': _ : xs) = 4 + Length xs
109− Length (_ ': _ ': _ : xs) = 3 + Length xs
110− Length (_ ': _ : xs) = 2 + Length xs
111− Length (_ : xs) = 1 + Length xs
112− Length '[] = 0
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+361−427
@@ -9,371 +9,316 @@ Squeal data manipulation language.
99-}
1010
1111{-# LANGUAGE
12− DeriveGeneric
12+ DataKinds
13+ , DeriveDataTypeable
14+ , DeriveGeneric
1315 , FlexibleContexts
14− , FlexibleInstances
1516 , GADTs
1617 , GeneralizedNewtypeDeriving
18+ , KindSignatures
1719 , LambdaCase
18− , MultiParamTypeClasses
1920 , OverloadedStrings
20− , PatternSynonyms
21− , QuantifiedConstraints
2221 , RankNTypes
23− , ScopedTypeVariables
24− , TypeApplications
25− , TypeFamilies
22+ , StandaloneDeriving
2623 , TypeInType
2724 , TypeOperators
28− , UndecidableInstances
2925#-}
3026
3127module Squeal.PostgreSQL.Manipulation
3228 ( -- * Manipulation
33− Manipulation_
34− , Manipulation (..)
29+ Manipulation (UnsafeManipulation, renderManipulation)
3530 , queryStatement
31+ , ColumnValue (..)
32+ , ReturningClause (ReturningStar, Returning)
33+ , ConflictClause (OnConflictDoRaise, OnConflictDoNothing, OnConflictDoUpdate)
3634 -- * Insert
37− , insertInto
38− , insertInto_
35+ , insertRows
36+ , insertRow
37+ , insertRows_
38+ , insertRow_
39+ , insertQuery
40+ , insertQuery_
41+ , renderReturningClause
42+ , renderConflictClause
3943 -- * Update
4044 , update
4145 , update_
4246 -- * Delete
4347 , deleteFrom
4448 , deleteFrom_
45− -- * Clauses
46− , Optional (..)
47− , QueryClause (..)
48− , pattern Values_
49− , ReturningClause (..)
50− , pattern Returning_
51− , ConflictClause (..)
52− , ConflictTarget (..)
53− , ConflictAction (..)
54− , UsingClause (..)
49+ -- * With
50+ , with
5551 ) where
5652
5753import Control.DeepSeq
5854import Data.ByteString hiding (foldr)
59−import Data.Kind (Type)
55+import Data.Monoid
6056
57+import qualified Data.ByteString as ByteString
6158import qualified Generics.SOP as SOP
6259import qualified GHC.Generics as GHC
6360
64−import Squeal.PostgreSQL.Alias
6561import Squeal.PostgreSQL.Expression
66−import Squeal.PostgreSQL.Expression.Logic
67−import Squeal.PostgreSQL.List
68−import Squeal.PostgreSQL.PG
6962import Squeal.PostgreSQL.Render
7063import Squeal.PostgreSQL.Query
7164import Squeal.PostgreSQL.Schema
7265
73−-- $setup
74−-- >>> import Squeal.PostgreSQL
75−-- >>> import Data.Int
76−-- >>> import Data.Time
77−
7866{- |
7967A `Manipulation` is a statement which may modify data in the database,
80−but does not alter its schemas. Examples are inserts, updates and deletes.
68+but does not alter the schema. Examples are inserts, updates and deletes.
8169A `Query` is also considered a `Manipulation` even though it does not modify data.
8270
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−
12571simple insert:
12672
127−>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]
128−>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
12973>>> :{
13074let
131− manipulation :: Manipulation_ (Public Schema) () ()
75+ manipulation :: Manipulation
76+ '[ "tab" ::: '[] :=>
77+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
78+ , "col2" ::: 'Def :=> 'NotNull 'PGint4 ]] '[] '[]
13279 manipulation =
133− insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))
134−in printSQL manipulation
80+ insertRow_ #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil)
81+in renderManipulation manipulation
13582:}
136−INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)
83+"INSERT INTO tab (col1, col2) VALUES (2, DEFAULT);"
13784
13885parameterized insert:
13986
140−>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]
141−>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
14287>>> :{
14388let
144− manipulation :: Manipulation_ (Public Schema) (Int32, Int32) ()
89+ manipulation :: Manipulation
90+ '[ "tab" ::: '[] :=>
91+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
92+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]
93+ '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]
14594 manipulation =
146− insertInto_ #tab (Values_ (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2))
147−in printSQL manipulation
95+ insertRow_ #tab
96+ (Set (param @1) `As` #col1 :* Set (param @2) `As` #col2 :* Nil)
97+in renderManipulation manipulation
14898:}
149−INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))
99+"INSERT INTO tab (col1, col2) VALUES (($1 :: int4), ($2 :: int4));"
150100
151101returning insert:
152102
153103>>> :{
154104let
155− manipulation :: Manipulation_ (Public Schema) () (Only Int32)
105+ manipulation :: Manipulation
106+ '[ "tab" ::: '[] :=>
107+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
108+ , "col2" ::: 'Def :=> 'NotNull 'PGint4 ]] '[]
109+ '["fromOnly" ::: 'NotNull 'PGint4]
156110 manipulation =
157− insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2))
158− OnConflictDoRaise (Returning (#col1 `as` #fromOnly))
159−in printSQL manipulation
111+ insertRow #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil)
112+ OnConflictDoRaise (Returning (#col1 `As` #fromOnly :* Nil))
113+in renderManipulation manipulation
160114:}
161−INSERT INTO "tab" ("col1", "col2") VALUES (2, 3) RETURNING "col1" AS "fromOnly"
115+"INSERT INTO tab (col1, col2) VALUES (2, DEFAULT) RETURNING col1 AS fromOnly;"
162116
163117upsert:
164118
165−>>> type CustomersColumns = '["name" ::: 'NoDef :=> 'NotNull 'PGtext, "email" ::: 'NoDef :=> 'NotNull 'PGtext]
166−>>> type CustomersConstraints = '["uq" ::: 'Unique '["name"]]
167−>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)]
168119>>> :{
169120let
170− manipulation :: Manipulation_ (Public CustomersSchema) () ()
121+ manipulation :: Manipulation
122+ '[ "tab" ::: '[] :=>
123+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
124+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]
125+ '[] '[ "sum" ::: 'NotNull 'PGint4]
171126 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
127+ insertRows #tab
128+ (Set 2 `As` #col1 :* Set 4 `As` #col2 :* Nil)
129+ [Set 6 `As` #col1 :* Set 8 `As` #col2 :* Nil]
130+ (OnConflictDoUpdate
131+ (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
132+ [#col1 .== #col2])
133+ (Returning $ (#col1 + #col2) `As` #sum :* Nil)
134+in renderManipulation manipulation
178135:}
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"))
136+"INSERT INTO tab (col1, col2) VALUES (2, 4), (6, 8) ON CONFLICT DO UPDATE SET col1 = 2 WHERE (col1 = col2) RETURNING (col1 + col2) AS sum;"
180137
181138query insert:
182139
183140>>> :{
184141let
185− manipulation :: Manipulation_ (Public Schema) () ()
186− manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab))))
187−in printSQL manipulation
142+ manipulation :: Manipulation
143+ '[ "tab" ::: '[] :=>
144+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
145+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4
146+ ]
147+ , "other_tab" ::: '[] :=>
148+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
149+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4
150+ ]
151+ ] '[] '[]
152+ manipulation =
153+ insertQuery_ #tab
154+ (selectStar (from (table (#other_tab `As` #t))))
155+in renderManipulation manipulation
188156:}
189−INSERT INTO "tab" SELECT * FROM "tab" AS "tab"
157+"INSERT INTO tab SELECT * FROM other_tab AS t;"
190158
191159update:
192160
193161>>> :{
194162let
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) () ()
163+ manipulation :: Manipulation
164+ '[ "tab" ::: '[] :=>
165+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
166+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[] '[]
223167 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
168+ update_ #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
169+ (#col1 ./= #col2)
170+in renderManipulation manipulation
229171:}
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"))
172+"UPDATE tab SET col1 = 2 WHERE (col1 <> col2);"
231173
232−with manipulation:
174+delete:
233175
234−>>> type ProductsColumns = '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]
235−>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]
236176>>> :{
237177let
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
178+ manipulation :: Manipulation
179+ '[ "tab" ::: '[] :=>
180+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
181+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[]
182+ '[ "col1" ::: 'NotNull 'PGint4
183+ , "col2" ::: 'NotNull 'PGint4 ]
184+ manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar
185+in renderManipulation manipulation
243186:}
244−WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del"
187+"DELETE FROM tab WHERE (col1 = col2) RETURNING *;"
245188-}
246−type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type) where
247− Manipulation_ schemas params row = Manipulation '[] schemas (TuplePG params) (RowPG row)
189+newtype Manipulation
190+ (schema :: TablesType)
191+ (params :: [NullityType])
192+ (columns :: RelationType)
193+ = UnsafeManipulation { renderManipulation :: ByteString }
194+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
248195
249196-- | Convert a `Query` into a `Manipulation`.
250197queryStatement
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
198+ :: Query schema params columns
199+ -> Manipulation schema params columns
200+queryStatement q = UnsafeManipulation $ renderQuery q <> ";"
255201
256202{-----------------------------------------
257203INSERT statements
258204-----------------------------------------}
259205
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
206+-- | Insert multiple rows.
207+--
208+-- When a table is created, it contains no data. The first thing to do
209+-- before a database can be of much use is to insert data. Data is
210+-- conceptually inserted one row at a time. Of course you can also insert
211+-- more than one row, but there is no way to insert less than one row.
212+-- Even if you know only some column values, a complete row must be created.
213+insertRows
214+ :: ( SOP.SListI columns
215+ , SOP.SListI results
216+ , Has tab schema table
217+ , columns ~ TableToColumns table )
218+ => Alias tab -- ^ table to insert into
219+ -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert
220+ -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert
221+ -> ConflictClause columns params
222+ -- ^ what to do in case of constraint conflict
223+ -> ReturningClause columns params results -- ^ results to return
224+ -> Manipulation schema params results
225+insertRows tab row rows conflict returning = UnsafeManipulation $
226+ "INSERT" <+> "INTO" <+> renderAlias tab
227+ <+> parenthesized (renderCommaSeparated renderAliasPart row)
228+ <+> "VALUES"
229+ <+> commaSeparated
230+ ( parenthesized
231+ . renderCommaSeparated renderColumnValuePart <$> row:rows )
232+ <> renderConflictClause conflict
233+ <> renderReturningClause returning
340234 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
235+ renderAliasPart, renderColumnValuePart
236+ :: Aliased (ColumnValue '[] params) ty -> ByteString
237+ renderAliasPart (_ `As` name) = renderAlias name
238+ renderColumnValuePart (value `As` _) = case value of
239+ Default -> "DEFAULT"
240+ Set expression -> renderExpression expression
241+
242+-- | Insert a single row.
243+insertRow
244+ :: ( SOP.SListI columns
245+ , SOP.SListI results
246+ , Has tab schema table
247+ , columns ~ TableToColumns table )
248+ => Alias tab -- ^ table to insert into
249+ -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert
250+ -> ConflictClause columns params
251+ -- ^ what to do in case of constraint conflict
252+ -> ReturningClause columns params results -- ^ results to return
253+ -> Manipulation schema params results
254+insertRow tab row = insertRows tab row []
255+
256+-- | Insert multiple rows returning `Nil` and raising an error on conflicts.
257+insertRows_
258+ :: ( SOP.SListI columns
259+ , Has tab schema table
260+ , columns ~ TableToColumns table )
261+ => Alias tab -- ^ table to insert into
262+ -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert
263+ -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert
264+ -> Manipulation schema params '[]
265+insertRows_ tab row rows =
266+ insertRows tab row rows OnConflictDoRaise (Returning Nil)
267+
268+-- | Insert a single row returning `Nil` and raising an error on conflicts.
269+insertRow_
270+ :: ( SOP.SListI columns
271+ , Has tab schema table
272+ , columns ~ TableToColumns table )
273+ => Alias tab -- ^ table to insert into
274+ -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert
275+ -> Manipulation schema params '[]
276+insertRow_ tab row = insertRow tab row OnConflictDoRaise (Returning Nil)
277+
278+-- | Insert a `Query`.
279+insertQuery
280+ :: ( SOP.SListI columns
281+ , SOP.SListI results
282+ , Has tab schema table
283+ , columns ~ TableToColumns table )
284+ => Alias tab -- ^ table to insert into
285+ -> Query schema params (ColumnsToRelation columns)
286+ -> ConflictClause columns params
287+ -- ^ what to do in case of constraint conflict
288+ -> ReturningClause columns params results -- ^ results to return
289+ -> Manipulation schema params results
290+insertQuery tab query conflict returning = UnsafeManipulation $
291+ "INSERT" <+> "INTO" <+> renderAlias tab
292+ <+> renderQuery query
293+ <> renderConflictClause conflict
294+ <> renderReturningClause returning
295+
296+-- | Insert a `Query` returning `Nil` and raising an error on conflicts.
297+insertQuery_
298+ :: ( SOP.SListI columns
299+ , Has tab schema table
300+ , columns ~ TableToColumns table )
301+ => Alias tab -- ^ table to insert into
302+ -> Query schema params (ColumnsToRelation columns)
303+ -> Manipulation schema params '[]
304+insertQuery_ tab query =
305+ insertQuery tab query OnConflictDoRaise (Returning Nil)
306+
307+-- | `ColumnValue`s are values to insert or update in a row
308+-- `Same` updates with the same value.
309+-- `Default` inserts or updates with the @DEFAULT@ value
310+-- `Set` a value to be an `Expression`, relative to the given
311+-- row for an update, and closed for an insert.
312+data ColumnValue
313+ (columns :: RelationType)
314+ (params :: [NullityType])
315+ (ty :: ColumnType)
316+ where
317+ Same :: ColumnValue (column ': columns) params ty
318+ Default :: ColumnValue columns params ('Def :=> ty)
319+ Set
320+ :: (forall table. Expression '[table ::: columns] 'Ungrouped params ty)
321+ -> ColumnValue columns params (constraint :=> ty)
377322
378323-- | A `ReturningClause` computes and return value(s) based
379324-- on each row actually inserted, updated or deleted. This is primarily
@@ -381,100 +326,71 @@ instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where
381326-- serial sequence number. However, any expression using the table's columns
382327-- is allowed. Only rows that were successfully inserted or updated or
383328-- 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
329+-- but not updated because an `OnConflictDoUpdate` condition was not satisfied,
330+-- the row will not be returned. `ReturningStar` will return all columns
331+-- in the row. Use @Returning Nil@ in the common case where no return
387332-- 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)
333+data ReturningClause
334+ (columns :: ColumnsType)
335+ (params :: [NullityType])
336+ (results :: RelationType)
337+ where
338+ ReturningStar
339+ :: results ~ ColumnsToRelation columns
340+ => ReturningClause columns params results
341+ Returning
342+ :: rel ~ ColumnsToRelation columns
343+ => NP (Aliased (Expression '[table ::: rel] 'Ungrouped params)) results
344+ -> ReturningClause columns params results
345+
346+-- | Render a `ReturningClause`.
347+renderReturningClause
348+ :: SOP.SListI results
349+ => ReturningClause params columns results
350+ -> ByteString
351+renderReturningClause = \case
352+ ReturningStar -> " RETURNING *;"
353+ Returning Nil -> ";"
354+ Returning results -> " RETURNING"
355+ <+> renderCommaSeparated (renderAliasedAs renderExpression) results <> ";"
403356
404357-- | A `ConflictClause` specifies an action to perform upon a constraint
405358-- 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
359+-- `OnConflictDoNothing` simply avoids inserting a row.
360+-- `OnConflictDoUpdate` updates the existing row that conflicts with the row
408361-- 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)
362+data ConflictClause (columns :: ColumnsType) params where
363+ OnConflictDoRaise :: ConflictClause columns params
364+ OnConflictDoNothing :: ConflictClause columns params
365+ OnConflictDoUpdate
366+ :: NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns
367+ -> [Condition '[table ::: ColumnsToRelation columns] 'Ungrouped params]
368+ -> ConflictClause columns params
417369
418370-- | 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
371+renderConflictClause
372+ :: SOP.SListI columns
373+ => ConflictClause columns params
463374 -> 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
375+renderConflictClause = \case
376+ OnConflictDoRaise -> ""
377+ OnConflictDoNothing -> " ON CONFLICT DO NOTHING"
378+ OnConflictDoUpdate updates whs'
379+ -> " ON CONFLICT DO UPDATE SET"
380+ <+> renderCommaSeparatedMaybe renderUpdate updates
381+ <> case whs' of
382+ [] -> ""
383+ wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)
384+ where
385+ renderUpdate
386+ :: Aliased (ColumnValue columns params) column
387+ -> Maybe ByteString
388+ renderUpdate = \case
389+ Same `As` _ -> Nothing
390+ Default `As` column -> Just $
391+ renderAlias column <+> "=" <+> "DEFAULT"
392+ Set expression `As` column -> Just $
393+ renderAlias column <+> "=" <+> renderExpression expression
478394
479395{-----------------------------------------
480396UPDATE statements
@@ -484,95 +400,113 @@ UPDATE statements
484400-- in all rows that satisfy the condition.
485401update
486402 :: ( 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
403+ , SOP.SListI results
404+ , Has tab schema table
405+ , columns ~ TableToColumns table )
406+ => Alias tab -- ^ table to update
407+ -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns
496408 -- ^ modified values to replace old values
497− -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]
409+ -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params
498410 -- ^ 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
411+ -> ReturningClause columns params results -- ^ results to return
412+ -> Manipulation schema params results
501413update tab columns wh returning = UnsafeManipulation $
502414 "UPDATE"
503− <+> renderSQL tab
415+ <+> renderAlias tab
504416 <+> "SET"
505− <+> renderCommaSeparated renderUpdate columns
506− <+> "WHERE" <+> renderSQL wh
507− <> renderSQL returning
417+ <+> renderCommaSeparatedMaybe renderUpdate columns
418+ <+> "WHERE" <+> renderExpression wh
419+ <> renderReturningClause returning
420+ where
421+ renderUpdate
422+ :: Aliased (ColumnValue columns params) column
423+ -> Maybe ByteString
424+ renderUpdate = \case
425+ Same `As` _ -> Nothing
426+ Default `As` column -> Just $
427+ renderAlias column <+> "=" <+> "DEFAULT"
428+ Set expression `As` column -> Just $
429+ renderAlias column <+> "=" <+> renderExpression expression
508430
509431-- | Update a row returning `Nil`.
510432update_
511433 :: ( 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
434+ , Has tab schema table
435+ , columns ~ TableToColumns table )
436+ => Alias tab -- ^ table to update
437+ -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns
520438 -- ^ modified values to replace old values
521− -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]
439+ -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params
522440 -- ^ 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)
441+ -> Manipulation schema params '[]
442+update_ tab columns wh = update tab columns wh (Returning Nil)
525443
526444{-----------------------------------------
527445DELETE statements
528446-----------------------------------------}
529447
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.
448+-- | Delete rows of a table.
547449deleteFrom
548− :: ( SOP.SListI row1
549− , Has sch schemas schema
550− , Has tab schema ('Table table)
551− , row0 ~ TableToRow table
450+ :: ( SOP.SListI results
451+ , Has tab schema table
552452 , 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)
453+ => Alias tab -- ^ table to delete from
454+ -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params
556455 -- ^ 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
456+ -> ReturningClause columns params results -- ^ results to return
457+ -> Manipulation schema params results
458+deleteFrom tab wh returning = UnsafeManipulation $
459+ "DELETE FROM" <+> renderAlias tab
460+ <+> "WHERE" <+> renderExpression wh
461+ <> renderReturningClause returning
567462
568463-- | Delete rows returning `Nil`.
569464deleteFrom_
570− :: ( Has sch schemas schema
571− , Has tab schema ('Table table)
572− , row ~ TableToRow table
465+ :: ( Has tab schema table
573466 , columns ~ TableToColumns table )
574− => QualifiedAlias sch tab -- ^ table to delete from
575− -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]
467+ => Alias tab -- ^ table to delete from
468+ -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params
576469 -- ^ condition under which to delete a row
577− -> Manipulation commons schemas params '[]
578−deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil)
470+ -> Manipulation schema params '[]
471+deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil)
472+
473+{-----------------------------------------
474+WITH statements
475+-----------------------------------------}
476+
477+-- | `with` provides a way to write auxiliary statements for use in a larger statement.
478+-- These statements, which are often referred to as Common Table Expressions or CTEs,
479+-- can be thought of as defining temporary tables that exist just for one statement.
480+--
481+-- >>> type ProductsTable = '[] :=> '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]
482+--
483+-- >>> :{
484+-- let
485+-- manipulation :: Manipulation '["products" ::: ProductsTable, "products_deleted" ::: ProductsTable] '[ 'NotNull 'PGdate] '[]
486+-- manipulation = with
487+-- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rows :* Nil)
488+-- (insertQuery_ #products_deleted (selectStar (from (table (#deleted_rows `As` #t)))))
489+-- in renderManipulation manipulation
490+-- :}
491+-- "WITH deleted_rows AS (DELETE FROM products WHERE (date < ($1 :: date)) RETURNING *) INSERT INTO products_deleted SELECT * FROM deleted_rows AS t;"
492+with
493+ :: SOP.SListI commons
494+ => NP (Aliased (Manipulation schema params)) commons
495+ -- ^ common table expressions
496+ -> Manipulation (Join (RelationsToTables commons) schema) params results
497+ -> Manipulation schema params results
498+with commons manipulation = UnsafeManipulation $
499+ "WITH" <+> renderCommaSeparated renderCommon commons
500+ <+> renderManipulation manipulation
501+ where
502+ renderCommon
503+ :: Aliased (Manipulation schema params) common
504+ -> ByteString
505+ renderCommon (common `As` alias) =
506+ renderAlias alias <+> "AS" <+>
507+ let
508+ str = renderManipulation common
509+ len = ByteString.length str
510+ str' = ByteString.take (len - 1) str -- remove ';'
511+ in
512+ parenthesized str'
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+220−350
@@ -8,13 +8,8 @@ Stability: experimental
88This module defines a `Migration` type to safely
99change the schema of your database over time. Let's see an example!
1010
11−First turn on some extensions.
12−
1311>>> :set -XDataKinds -XOverloadedLabels
1412>>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators
15−
16−Next, let's define our `TableType`s.
17−
1813>>> :{
1914type UsersTable =
2015 '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
@@ -25,7 +20,7 @@ type UsersTable =
2520
2621>>> :{
2722type EmailsTable =
28− '[ "pk_emails" ::: 'PrimaryKey '["id"]
23+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
2924 , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
3025 ] :=>
3126 '[ "id" ::: 'Def :=> 'NotNull 'PGint4
@@ -34,293 +29,250 @@ type EmailsTable =
3429 ]
3530:}
3631
37−Now we can define some `Migration`s to make our tables.
38−
3932>>> :{
4033let
41− makeUsers :: Migration Definition (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]]
34+ makeUsers :: Migration IO '[] '["users" ::: UsersTable]
4235 makeUsers = Migration
4336 { 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
37+ , up = void . define $
38+ createTable #users
39+ ( serial `As` #id :*
40+ (text & notNull) `As` #name :* Nil )
41+ ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil )
42+ , down = void . define $ dropTable #users
4943 }
5044:}
5145
5246>>> :{
5347let
54− makeEmails :: Migration Definition '["public" ::: '["users" ::: 'Table UsersTable]]
55− '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]]
48+ makeEmails :: Migration IO '["users" ::: UsersTable]
49+ '["users" ::: UsersTable, "emails" ::: EmailsTable]
5650 makeEmails = Migration
5751 { 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
52+ , up = void . define $
53+ createTable #emails
54+ ( serial `As` #id :*
55+ (int & notNull) `As` #user_id :*
56+ text `As` #email :* Nil )
57+ ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
58+ foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
59+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
60+ , down = void . define $ dropTable #emails
6661 }
6762:}
6863
69−Now that we have a couple migrations we can chain them together into a `Path`.
64+Now that we have a couple migrations we can chain them together.
7065
7166>>> let migrations = makeUsers :>> makeEmails :>> Done
7267
73−Now run the migrations.
68+>>> :{
69+let
70+ numMigrations
71+ :: Has "schema_migrations" schema MigrationsTable
72+ => PQ schema schema IO ()
73+ numMigrations = do
74+ result <- runQuery (selectStar (from (table (#schema_migrations `As` #m))))
75+ num <- ntuples result
76+ liftBase $ print num
77+:}
7478
75−>>> import Control.Monad.IO.Class
7679>>> :{
7780withConnection "host=localhost port=5432 dbname=exampledb" $
7881 manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
7982 -- suppress notices
80− & pqThen (liftIO (putStrLn "Migrate"))
8183 & pqThen (migrateUp migrations)
82− & pqThen (liftIO (putStrLn "Rollback"))
84+ & pqThen numMigrations
8385 & pqThen (migrateDown migrations)
86+ & pqThen numMigrations
8487:}
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.
88+Row 2
89+Row 0
12290-}
12391
12492{-# LANGUAGE
125− DataKinds
126− , DeriveGeneric
127− , FlexibleContexts
128− , FlexibleInstances
93+ ScopedTypeVariables
94+ , OverloadedStrings
95+ , DataKinds
12996 , GADTs
13097 , LambdaCase
131− , OverloadedLabels
132− , OverloadedStrings
13398 , PolyKinds
134− , QuantifiedConstraints
135− , RankNTypes
99+ , OverloadedLabels
136100 , TypeApplications
101+ , FlexibleContexts
137102 , TypeOperators
138103#-}
139104
140105module Squeal.PostgreSQL.Migration
141106 ( -- * Migration
142107 Migration (..)
143− , Migratory (..)
144− , Terminally (..)
145− , terminally
146− , pureMigration
108+ , migrateUp
109+ , migrateDown
110+ -- * Aligned lists
111+ , AlignedList (..)
112+ , single
113+ -- * Migration table
147114 , MigrationsTable
148− , defaultMain
115+ , createMigrations
116+ , insertMigration
117+ , deleteMigration
118+ , selectMigration
149119 ) where
150120
151121import Control.Category
152122import Control.Monad
153−import Data.ByteString (ByteString)
154−import Data.Foldable (traverse_)
123+import Control.Monad.Base
124+import Control.Monad.Trans.Control
125+import Data.Monoid
126+import Generics.SOP (K(..))
155127import Data.Function ((&))
156−import Data.List ((\\))
157128import Data.Text (Text)
158−import Data.Time (UTCTime)
159−import Prelude hiding ((.), id)
160−import System.Environment
161−import UnliftIO (MonadIO (..))
129+import Prelude hiding (id, (.))
162130
163−import qualified Data.Text.IO as Text (putStrLn)
164−import qualified Generics.SOP as SOP
165−import qualified GHC.Generics as GHC
131+import Squeal.PostgreSQL
166132
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
133+-- | A `Migration` should contain an inverse pair of
134+-- `up` and `down` instructions and a unique `name`.
135+data Migration io schema0 schema1 = Migration
187136 { name :: Text -- ^ The `name` of a `Migration`.
188137 -- 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
138+ , up :: PQ schema0 schema1 io () -- ^ The `up` instruction of a `Migration`.
139+ , down :: PQ schema1 schema0 io () -- ^ The `down` instruction of a `Migration`.
260140 }
261141
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))
142+-- | An `AlignedList` is a type-aligned list or free category.
143+data AlignedList p x0 x1 where
144+ Done :: AlignedList p x x
145+ (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
146+infixr 7 :>>
147+instance Category (AlignedList p) where
148+ id = Done
149+ (.) list = \case
150+ Done -> list
151+ step :>> steps -> step :>> (steps >>> list)
152+
153+-- | A `single` step.
154+single :: p x0 x1 -> AlignedList p x0 x1
155+single step = step :>> Done
156+
157+-- | Run `Migration`s by creating the `MigrationsTable`
158+-- if it does not exist and then in a transaction, for each each `Migration`
159+-- query to see if the `Migration` is executed. If not, then
160+-- execute the `Migration` and insert its row in the `MigrationsTable`.
161+migrateUp
162+ :: MonadBaseControl IO io
163+ => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run
164+ -> PQ
165+ ("schema_migrations" ::: MigrationsTable ': schema0)
166+ ("schema_migrations" ::: MigrationsTable ': schema1)
167+ io ()
168+migrateUp migration =
169+ define createMigrations
170+ & pqBind okResult
171+ & pqThen (transactionallySchema_ (upMigrations migration))
172+ where
314173
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
174+ upMigrations
175+ :: MonadBaseControl IO io
176+ => AlignedList (Migration io) schema0 schema1
177+ -> PQ
178+ ("schema_migrations" ::: MigrationsTable ': schema0)
179+ ("schema_migrations" ::: MigrationsTable ': schema1)
180+ io ()
181+ upMigrations = \case
182+ Done -> return ()
183+ step :>> steps -> upMigration step & pqThen (upMigrations steps)
184+
185+ upMigration
186+ :: MonadBase IO io
187+ => Migration io schema0 schema1 -> PQ
188+ ("schema_migrations" ::: MigrationsTable ': schema0)
189+ ("schema_migrations" ::: MigrationsTable ': schema1)
190+ io ()
191+ upMigration step =
192+ queryExecuted step
193+ & pqBind (\ executed ->
194+ if executed == 1 -- up step has already been executed
195+ then PQ (\ _ -> return (K ())) -- unsafely switch schemas
196+ else
197+ pqEmbed (up step) -- safely switch schemas
198+ & pqThen (manipulateParams insertMigration (Only (name step)))
199+ -- insert execution record
200+ & pqBind okResult)
201+
202+ queryExecuted
203+ :: MonadBase IO io
204+ => Migration io schema0 schema1 -> PQ
205+ ("schema_migrations" ::: MigrationsTable ': schema0)
206+ ("schema_migrations" ::: MigrationsTable ': schema0)
207+ io Row
208+ queryExecuted step = do
209+ result <- runQueryParams selectMigration (Only (name step))
210+ okResult result
211+ ntuples result
212+
213+-- | Rewind `Migration`s by creating the `MigrationsTable`
214+-- if it does not exist and then in a transaction, for each each `Migration`
215+-- query to see if the `Migration` is executed. If it is, then
216+-- rewind the `Migration` and delete its row in the `MigrationsTable`.
217+migrateDown
218+ :: MonadBaseControl IO io
219+ => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind
220+ -> PQ
221+ ("schema_migrations" ::: MigrationsTable ': schema1)
222+ ("schema_migrations" ::: MigrationsTable ': schema0)
223+ io ()
224+migrateDown migrations =
225+ define createMigrations
226+ & pqBind okResult
227+ & pqThen (transactionallySchema_ (downMigrations migrations))
228+ where
321229
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
230+ downMigrations
231+ :: MonadBaseControl IO io
232+ => AlignedList (Migration io) schema0 schema1 -> PQ
233+ ("schema_migrations" ::: MigrationsTable ': schema1)
234+ ("schema_migrations" ::: MigrationsTable ': schema0)
235+ io ()
236+ downMigrations = \case
237+ Done -> return ()
238+ step :>> steps -> downMigrations steps & pqThen (downMigration step)
239+
240+ downMigration
241+ :: MonadBase IO io
242+ => Migration io schema0 schema1 -> PQ
243+ ("schema_migrations" ::: MigrationsTable ': schema1)
244+ ("schema_migrations" ::: MigrationsTable ': schema0)
245+ io ()
246+ downMigration step =
247+ queryExecuted step
248+ & pqBind (\ executed ->
249+ if executed == 0 -- up step has not been executed
250+ then PQ (\ _ -> return (K ())) -- unsafely switch schemas
251+ else
252+ pqEmbed (down step) -- safely switch schemas
253+ & pqThen (manipulateParams deleteMigration (Only (name step)))
254+ -- delete execution record
255+ & pqBind okResult)
256+
257+ queryExecuted
258+ :: MonadBase IO io
259+ => Migration io schema0 schema1 -> PQ
260+ ("schema_migrations" ::: MigrationsTable ': schema1)
261+ ("schema_migrations" ::: MigrationsTable ': schema1)
262+ io Row
263+ queryExecuted step = do
264+ result <- runQueryParams selectMigration (Only (name step))
265+ okResult result
266+ ntuples result
267+
268+okResult :: MonadBase IO io => K Result results -> PQ schema schema io ()
269+okResult result = do
270+ status <- resultStatus result
271+ when (not (status `elem` [CommandOk, TuplesOk])) $ do
272+ errorMessageMaybe <- resultErrorMessage result
273+ case errorMessageMaybe of
274+ Nothing -> error "migrateDown: unknown error"
275+ Just msg -> error ("migrationDown: " <> show msg)
324276
325277-- | The `TableType` for a Squeal migration.
326278type MigrationsTable =
@@ -329,120 +281,38 @@ type MigrationsTable =
329281 , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz
330282 ]
331283
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−
343284-- | Creates a `MigrationsTable` if it does not already exist.
344−createMigrations :: Definition MigrationsSchemas MigrationsSchemas
285+createMigrations
286+ :: Has "schema_migrations" schema MigrationsTable
287+ => Definition schema schema
345288createMigrations =
346289 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) ()
290+ ( (text & notNull) `As` #name :*
291+ (timestampWithTimeZone & notNull & default_ currentTimestamp)
292+ `As` #executed_at :* Nil )
293+ ( unique (Column #name :* Nil) `As` #migrations_unique_name :* Nil )
294+
295+-- | Inserts a `Migration` into the `MigrationsTable`
296+insertMigration
297+ :: Has "schema_migrations" schema MigrationsTable
298+ => Manipulation schema '[ 'NotNull 'PGtext] '[]
299+insertMigration = insertRow_ #schema_migrations
300+ ( Set (param @1) `As` #name :*
301+ Default `As` #executed_at :* Nil )
302+
303+-- | Deletes a `Migration` from the `MigrationsTable`
304+deleteMigration
305+ :: Has "schema_migrations" schema MigrationsTable
306+ => Manipulation schema '[ 'NotNull 'PGtext ] '[]
361307deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)
362308
363309-- | Selects a `Migration` from the `MigrationsTable`, returning
364−-- the time at which it was inserted.
310+-- the time at which it was executed.
365311selectMigration
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
312+ :: Has "schema_migrations" schema MigrationsTable
313+ => Query schema '[ 'NotNull 'PGtext ]
314+ '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]
315+selectMigration = select
316+ (#executed_at `As` #executed_at :* Nil)
317+ ( from (table (#schema_migrations `As` #m))
318+ & where_ (#name .== param @1))
squeal-postgresql/src/Squeal/PostgreSQL/PG.hsdeleted−388
@@ -1,388 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.PG
3−Description: Embedding of Haskell types into Postgres's type system
4−Copyright: (c) Eitan Chatav, 2010
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−`Squeal.PostgreSQL.PG` provides type families for turning Haskell
9−`Type`s into corresponding Postgres types.
10−-}
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DeriveAnyClass
14− , DeriveFoldable
15− , DeriveFunctor
16− , DeriveGeneric
17− , DeriveTraversable
18− , DerivingStrategies
19− , DefaultSignatures
20− , FlexibleContexts
21− , FlexibleInstances
22− , FunctionalDependencies
23− , GADTs
24− , LambdaCase
25− , MultiParamTypeClasses
26− , OverloadedStrings
27− , ScopedTypeVariables
28− , TypeApplications
29− , TypeFamilies
30− , TypeInType
31− , TypeOperators
32− , UndecidableInstances
33− , UndecidableSuperClasses
34−#-}
35−
36−module Squeal.PostgreSQL.PG
37− ( -- * PG embeddings
38− PG
39− , NullPG
40− , TuplePG
41− , RowPG
42− -- * Storage newtypes
43− , Money (..)
44− , Json (..)
45− , Jsonb (..)
46− , Composite (..)
47− , Enumerated (..)
48− , VarArray (..)
49− , FixArray (..)
50− , LibPQ.Oid (..)
51− -- * Type families
52− , LabelsPG
53− , DimPG
54− , FixPG
55− , TupleOf
56− , TupleCodeOf
57− , RowOf
58− , ConstructorsOf
59− , ConstructorNameOf
60− , ConstructorNamesOf
61− ) where
62−
63−import Data.Aeson (Value)
64−import Data.Kind (Type)
65−import Data.Int (Int16, Int32, Int64)
66−import Data.Scientific (Scientific)
67−import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
68−import Data.Vector (Vector)
69−import Data.UUID.Types (UUID)
70−import GHC.TypeLits
71−import Network.IP.Addr (NetAddr, IP)
72−
73−import qualified Data.ByteString.Lazy as Lazy (ByteString)
74−import qualified Data.ByteString as Strict (ByteString)
75−import qualified Data.Text.Lazy as Lazy (Text)
76−import qualified Data.Text as Strict (Text)
77−import qualified Database.PostgreSQL.LibPQ as LibPQ
78−import qualified GHC.Generics as GHC
79−import qualified Generics.SOP as SOP
80−import qualified Generics.SOP.Record as SOP
81−import qualified Generics.SOP.Type.Metadata as Type
82−
83−import Squeal.PostgreSQL.Alias
84−import Squeal.PostgreSQL.Schema
85−
86−-- $setup
87−-- >>> import Squeal.PostgreSQL
88−-- >>> import Data.Text (Text)
89−
90−{- | The `PG` type family embeds a subset of Haskell types
91−as Postgres types. As an open type family, `PG` is extensible.
92−
93−>>> :kind! PG LocalTime
94−PG LocalTime :: PGType
95−= 'PGtimestamp
96−
97−>>> newtype MyDouble = My Double
98−>>> :set -XTypeFamilies
99−>>> type instance PG MyDouble = 'PGfloat8
100−-}
101−type family PG (hask :: Type) :: PGType
102−-- | `PGbool`
103−type instance PG Bool = 'PGbool
104−-- | `PGint2`
105−type instance PG Int16 = 'PGint2
106−-- | `PGint4`
107−type instance PG Int32 = 'PGint4
108−-- | `PGint8`
109−type instance PG Int64 = 'PGint8
110−-- | `PGint2`
111−type instance PG LibPQ.Oid = 'PGoid
112−-- | `PGnumeric`
113−type instance PG Scientific = 'PGnumeric
114−-- | `PGfloat4`
115−type instance PG Float = 'PGfloat4
116−-- | `PGfloat8`
117−type instance PG Double = 'PGfloat8
118−-- | `PGchar` @1@
119−type instance PG Char = 'PGchar 1
120−-- | `PGtext`
121−type instance PG Strict.Text = 'PGtext
122−-- | `PGtext`
123−type instance PG Lazy.Text = 'PGtext
124−-- | `PGtext`
125−type instance PG String = 'PGtext
126−-- | `PGbytea`
127−type instance PG Strict.ByteString = 'PGbytea
128−-- | `PGbytea`
129−type instance PG Lazy.ByteString = 'PGbytea
130−-- | `PGtimestamp`
131−type instance PG LocalTime = 'PGtimestamp
132−-- | `PGtimestamptz`
133−type instance PG UTCTime = 'PGtimestamptz
134−-- | `PGdate`
135−type instance PG Day = 'PGdate
136−-- | `PGtime`
137−type instance PG TimeOfDay = 'PGtime
138−-- | `PGtimetz`
139−type instance PG (TimeOfDay, TimeZone) = 'PGtimetz
140−-- | `PGinterval`
141−type instance PG DiffTime = 'PGinterval
142−-- | `PGuuid`
143−type instance PG UUID = 'PGuuid
144−-- | `PGinet`
145−type instance PG (NetAddr IP) = 'PGinet
146−-- | `PGjson`
147−type instance PG Value = 'PGjson
148−
149−{-| The `LabelsPG` type family calculates the constructors of a
150−Haskell enum type.
151−
152−>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
153−>>> instance SOP.Generic Schwarma
154−>>> instance SOP.HasDatatypeInfo Schwarma
155−>>> :kind! LabelsPG Schwarma
156−LabelsPG Schwarma :: [Type.ConstructorName]
157−= '["Beef", "Lamb", "Chicken"]
158−-}
159−type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where
160− LabelsPG hask =
161− ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask))
162−
163−{- |
164−`RowPG` turns a Haskell `Type` into a `RowType`.
165−
166−`RowPG` may be applied to normal Haskell record types provided they
167−have `SOP.Generic` and `SOP.HasDatatypeInfo` instances;
168−
169−>>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic
170−>>> instance SOP.Generic Person
171−>>> instance SOP.HasDatatypeInfo Person
172−>>> :kind! RowPG Person
173−RowPG Person :: [(Symbol, NullityType)]
174−= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
175−-}
176−type family RowPG (hask :: Type) :: RowType where
177− RowPG hask = RowOf (SOP.RecordCodeOf hask)
178−
179−-- | `RowOf` applies `NullPG` to the fields of a list.
180−type family RowOf (record :: [(Symbol, Type)]) :: RowType where
181− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': col4 ::: ty4 ': record) =
182− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': col4 ::: NullPG ty4 ': RowOf record
183− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': record) =
184− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': RowOf record
185− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': record) =
186− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': RowOf record
187− RowOf (col ::: ty ': col1 ::: ty1 ': record) =
188− col ::: NullPG ty ': col1::: NullPG ty1 ': RowOf record
189− RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
190− RowOf '[] = '[]
191−
192−{- | `NullPG` turns a Haskell type into a `NullityType`.
193−
194−>>> :kind! NullPG Double
195−NullPG Double :: NullityType
196−= 'NotNull 'PGfloat8
197−>>> :kind! NullPG (Maybe Double)
198−NullPG (Maybe Double) :: NullityType
199−= 'Null 'PGfloat8
200−-}
201−type family NullPG (hask :: Type) :: NullityType where
202− NullPG (Maybe hask) = 'Null (PG hask)
203− NullPG hask = 'NotNull (PG hask)
204−
205−{- | `TuplePG` turns a Haskell tuple type (including record types) into
206−the corresponding list of `NullityType`s.
207−
208−>>> :kind! TuplePG (Double, Maybe Char)
209−TuplePG (Double, Maybe Char) :: [NullityType]
210−= '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)]
211−-}
212−type family TuplePG (hask :: Type) :: [NullityType] where
213− TuplePG hask = TupleOf (TupleCodeOf hask (SOP.Code hask))
214−
215−-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.
216−type family TupleOf (tuple :: [Type]) :: [NullityType] where
217− TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': hask5 ': tuple) =
218− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': NullPG hask5 ': TupleOf tuple
219− TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': tuple) =
220− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': TupleOf tuple
221− TupleOf (hask ': hask1 ': hask2 ': hask3 ': tuple) =
222− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': TupleOf tuple
223− TupleOf (hask ': hask1 ': hask2 ': tuple) =
224− NullPG hask ': NullPG hask1 ': NullPG hask2 ': TupleOf tuple
225− TupleOf (hask ': hask1 ': tuple) = NullPG hask ': NullPG hask1 ': TupleOf tuple
226− TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
227− TupleOf '[] = '[]
228−
229−-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`
230−-- and if it's a simple product returns it, otherwise giving a `TypeError`.
231−type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where
232− TupleCodeOf hask '[tuple] = tuple
233− TupleCodeOf hask '[] =
234− TypeError
235− ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."
236− ':$$: 'Text "It is a void type with no constructors."
237− )
238− TupleCodeOf hask (_ ': _ ': _) =
239− TypeError
240− ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."
241− ':$$: 'Text "It is a sum type with more than one constructor."
242− )
243−
244−-- | Calculates constructors of a datatype.
245−type family ConstructorsOf (datatype :: Type.DatatypeInfo)
246− :: [Type.ConstructorInfo] where
247− ConstructorsOf ('Type.ADT _module _datatype constructors) =
248− constructors
249− ConstructorsOf ('Type.Newtype _module _datatype constructor) =
250− '[constructor]
251−
252−-- | Calculates the name of a nullary constructor, otherwise
253−-- generates a type error.
254−type family ConstructorNameOf (constructor :: Type.ConstructorInfo)
255− :: Type.ConstructorName where
256− ConstructorNameOf ('Type.Constructor name) = name
257− ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError
258− ('Text "ConstructorNameOf error: non-nullary constructor "
259− ':<>: 'Text name)
260− ConstructorNameOf ('Type.Record name _fields) = TypeError
261− ('Text "ConstructorNameOf error: non-nullary constructor "
262− ':<>: 'Text name)
263−
264−-- | Calculate the names of nullary constructors.
265−type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])
266− :: [Type.ConstructorName] where
267− ConstructorNamesOf '[] = '[]
268− ConstructorNamesOf (constructor ': constructors) =
269− ConstructorNameOf constructor ': ConstructorNamesOf constructors
270−
271−-- | `DimPG` turns Haskell nested homogeneous tuples into a list of lengths.
272−type family DimPG (hask :: Type) :: [Nat] where
273− DimPG (x,x) = 2 ': DimPG x
274− DimPG (x,x,x) = 3 ': DimPG x
275− DimPG (x,x,x,x) = 4 ': DimPG x
276− DimPG (x,x,x,x,x) = 5 ': DimPG x
277− DimPG (x,x,x,x,x,x) = 6 ': DimPG x
278− DimPG (x,x,x,x,x,x,x) = 7 ': DimPG x
279− DimPG (x,x,x,x,x,x,x,x) = 8 ': DimPG x
280− DimPG (x,x,x,x,x,x,x,x,x) = 9 ': DimPG x
281− DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x
282− DimPG x = '[]
283−
284−-- | `FixPG` extracts `NullPG` of the base type of nested homogeneous tuples.
285−type family FixPG (hask :: Type) :: NullityType where
286− FixPG (x,x) = FixPG x
287− FixPG (x,x,x) = FixPG x
288− FixPG (x,x,x,x) = FixPG x
289− FixPG (x,x,x,x,x) = FixPG x
290− FixPG (x,x,x,x,x,x) = FixPG x
291− FixPG (x,x,x,x,x,x,x) = FixPG x
292− FixPG (x,x,x,x,x,x,x,x) = FixPG x
293− FixPG (x,x,x,x,x,x,x,x,x) = FixPG x
294− FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x
295− FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x
296− FixPG x = NullPG x
297−
298−{- | The `Money` newtype stores a monetary value in terms
299−of the number of cents, i.e. @$2,000.20@ would be expressed as
300−@Money { cents = 200020 }@.
301−
302−>>> import Control.Monad (void)
303−>>> import Control.Monad.IO.Class (liftIO)
304−>>> import Squeal.PostgreSQL
305−>>> :{
306−let
307− roundTrip :: Query_ (Public '[]) (Only Money) (Only Money)
308− roundTrip = values_ $ parameter @1 money `as` #fromOnly
309−:}
310−
311−>>> let input = Only (Money 20020)
312−
313−>>> :{
314−withConnection "host=localhost port=5432 dbname=exampledb" $ do
315− result <- runQueryParams roundTrip input
316− Just output <- firstRow result
317− liftIO . print $ input == output
318−:}
319−True
320−-}
321−newtype Money = Money { cents :: Int64 }
322− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
323− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
324−-- | `PGmoney`
325−type instance PG Money = 'PGmoney
326−
327−{- | The `Json` newtype is an indication that the Haskell
328−type it's applied to should be stored as a `PGjson`.
329−-}
330−newtype Json hask = Json {getJson :: hask}
331− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
332− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
333−-- | `PGjson`
334−type instance PG (Json hask) = 'PGjson
335−
336−{- | The `Jsonb` newtype is an indication that the Haskell
337−type it's applied to should be stored as a `PGjsonb`.
338−-}
339−newtype Jsonb hask = Jsonb {getJsonb :: hask}
340− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
341− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
342−-- | `PGjsonb`
343−type instance PG (Jsonb hask) = 'PGjsonb
344−
345−{- | The `Composite` newtype is an indication that the Haskell
346−type it's applied to should be stored as a `PGcomposite`.
347−-}
348−newtype Composite record = Composite {getComposite :: record}
349− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
350− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
351−-- | `PGcomposite` @(@`RowPG` @hask)@
352−type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
353−
354−{- | The `Enumerated` newtype is an indication that the Haskell
355−type it's applied to should be stored as a `PGenum`.
356−-}
357−newtype Enumerated enum = Enumerated {getEnumerated :: enum}
358− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
359− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
360−-- | `PGenum` @(@`LabelsPG` @hask)@
361−type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)
362−
363−{- | The `VarArray` newtype is an indication that the Haskell
364−type it's applied to should be stored as a `PGvararray`.
365−
366−>>> :kind! PG (VarArray (Vector Double))
367−PG (VarArray (Vector Double)) :: PGType
368−= 'PGvararray ('NotNull 'PGfloat8)
369−-}
370−newtype VarArray arr = VarArray {getVarArray :: arr}
371− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
372− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
373−-- | `PGvararray` @(@`NullPG` @hask)@
374−type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)
375−type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask)
376−
377−{- | The `FixArray` newtype is an indication that the Haskell
378−type it's applied to should be stored as a `PGfixarray`.
379−
380−>>> :kind! PG (FixArray ((Double, Double), (Double, Double)))
381−PG (FixArray ((Double, Double), (Double, Double))) :: PGType
382−= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)
383−-}
384−newtype FixArray arr = FixArray {getFixArray :: arr}
385− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
386− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
387−-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@
388−type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+216−319
@@ -6,12 +6,12 @@ Maintainer: eitan@morphism.tech
66Stability: experimental
77
88This module is where Squeal commands actually get executed by
9−`Database.PostgreSQL.LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing
9+`LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing
1010a `Definition` and `MonadPQ` for executing a `Manipulation` or `Query`,
1111and a `PQ` type with instances for them.
1212
1313Using Squeal in your application will come down to defining
14−the @schemas@ of your database and including @PQ schemas schemas@ in your
14+the @schema@ of your database and including @PQ schema schema@ in your
1515application's monad transformer stack, giving it an instance of `MonadPQ`.
1616
1717This module also provides functions for retrieving rows from the `LibPQ.Result`
@@ -20,11 +20,15 @@ of executing Squeal commands.
2020
2121{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
2222{-# LANGUAGE
23− DefaultSignatures
23+ DataKinds
24+ , DefaultSignatures
2425 , FunctionalDependencies
26+ , PolyKinds
27+ , DeriveFunctor
2528 , FlexibleContexts
2629 , FlexibleInstances
27− , InstanceSigs
30+ , MagicHash
31+ , MultiParamTypeClasses
2832 , OverloadedStrings
2933 , RankNTypes
3034 , ScopedTypeVariables
@@ -49,7 +53,9 @@ module Squeal.PostgreSQL.PQ
4953 , evalPQ
5054 , IndexedMonadTransPQ (..)
5155 , MonadPQ (..)
52− -- * Results
56+ , PQRun
57+ , pqliftWith
58+ -- * Result
5359 , LibPQ.Result
5460 , LibPQ.Row
5561 , ntuples
@@ -61,33 +67,22 @@ module Squeal.PostgreSQL.PQ
6167 , LibPQ.ExecStatus (..)
6268 , resultStatus
6369 , resultErrorMessage
64− , resultErrorCode
65− -- * Exceptions
66− , SquealException (..)
67− , PQState (..)
68− , okResult
69− , catchSqueal
70− , handleSqueal
71− , trySqueal
7270 ) where
7371
74−import Control.Exception (Exception, throw)
72+import Control.Exception.Lifted
73+import Control.Monad.Base
7574import Control.Monad.Except
7675import Control.Monad.Morph
77−import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try)
76+import Control.Monad.Trans.Control
7877import Data.ByteString (ByteString)
7978import Data.Foldable
8079import Data.Function ((&))
81−import Data.Functor ((<&>))
8280import Data.Kind
83−import Data.Text (pack, Text)
81+import Data.Monoid
8482import Data.Traversable
8583import Generics.SOP
86−import PostgreSQL.Binary.Encoding (encodingBytes)
8784
88−import qualified Control.Monad.Fail as Fail
8985import qualified Database.PostgreSQL.LibPQ as LibPQ
90−import qualified PostgreSQL.Binary.Encoding as Encoding
9186
9287import Squeal.PostgreSQL.Binary
9388import Squeal.PostgreSQL.Definition
@@ -100,6 +95,7 @@ import Control.Monad.Trans.Identity
10095import Control.Monad.Trans.Reader
10196import Control.Monad.Trans.Maybe
10297import Control.Monad.Trans.Cont
98+import Control.Monad.Trans.List
10399
104100import qualified Control.Monad.Trans.State.Lazy as Lazy
105101import qualified Control.Monad.Trans.State.Strict as Strict
@@ -108,9 +104,6 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict
108104import qualified Control.Monad.Trans.RWS.Lazy as Lazy
109105import qualified Control.Monad.Trans.RWS.Strict as Strict
110106
111−-- $setup
112−-- >>> import Squeal.PostgreSQL
113−
114107{- | Makes a new connection to the database server.
115108
116109This function opens a new database connection using the parameters taken
@@ -137,22 +130,22 @@ Note that, for now, squeal doesn't offer any protection from connecting
137130with the wrong schema!
138131-}
139132connectdb
140− :: forall schemas io
141− . MonadIO io
133+ :: forall schema io
134+ . MonadBase IO io
142135 => ByteString -- ^ conninfo
143− -> io (K LibPQ.Connection schemas)
144−connectdb = fmap K . liftIO . LibPQ.connectdb
136+ -> io (K LibPQ.Connection schema)
137+connectdb = fmap K . liftBase . LibPQ.connectdb
145138
146139-- | Closes the connection to the server.
147−finish :: MonadIO io => K LibPQ.Connection schemas -> io ()
148−finish = liftIO . LibPQ.finish . unK
140+finish :: MonadBase IO io => K LibPQ.Connection schema -> io ()
141+finish = liftBase . LibPQ.finish . unK
149142
150143-- | Do `connectdb` and `finish` before and after a computation.
151144withConnection
152− :: forall schemas0 schemas1 io x
153− . MonadUnliftIO io
145+ :: forall schema0 schema1 io x
146+ . MonadBaseControl IO io
154147 => ByteString
155− -> PQ schemas0 schemas1 io x
148+ -> PQ schema0 schema1 io x
156149 -> io x
157150withConnection connString action = do
158151 K x <- bracket (connectdb connString) finish (unPQ action)
@@ -160,47 +153,47 @@ withConnection connString action = do
160153
161154-- | Safely `lowerConnection` to a smaller schema.
162155lowerConnection
163− :: K LibPQ.Connection (schema ': schemas)
164− -> K LibPQ.Connection schemas
156+ :: K LibPQ.Connection (table ': schema)
157+ -> K LibPQ.Connection schema
165158lowerConnection (K conn) = K conn
166159
167160-- | We keep track of the schema via an Atkey indexed state monad transformer,
168161-- `PQ`.
169162newtype PQ
170− (schemas0 :: SchemasType)
171− (schemas1 :: SchemasType)
163+ (schema0 :: TablesType)
164+ (schema1 :: TablesType)
172165 (m :: Type -> Type)
173166 (x :: Type) =
174− PQ { unPQ :: K LibPQ.Connection schemas0 -> m (K x schemas1) }
167+ PQ { unPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }
175168
176−instance Monad m => Functor (PQ schemas0 schemas1 m) where
169+instance Monad m => Functor (PQ schema0 schema1 m) where
177170 fmap f (PQ pq) = PQ $ \ conn -> do
178171 K x <- pq conn
179172 return $ K (f x)
180173
181−-- | Run a `PQ` and keep the result and the `LibPQ.Connection`.
174+-- | Run a `PQ` and keep the result and the `Connection`.
182175runPQ
183176 :: Functor m
184− => PQ schemas0 schemas1 m x
185− -> K LibPQ.Connection schemas0
186− -> m (x, K LibPQ.Connection schemas1)
177+ => PQ schema0 schema1 m x
178+ -> K LibPQ.Connection schema0
179+ -> m (x, K LibPQ.Connection schema1)
187180runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn
188181 -- K x <- pq conn
189182 -- return (x, K (unK conn))
190183
191−-- | Execute a `PQ` and discard the result but keep the `LibPQ.Connection`.
184+-- | Execute a `PQ` and discard the result but keep the `Connection`.
192185execPQ
193186 :: Functor m
194− => PQ schemas0 schemas1 m x
195− -> K LibPQ.Connection schemas0
196− -> m (K LibPQ.Connection schemas1)
187+ => PQ schema0 schema1 m x
188+ -> K LibPQ.Connection schema0
189+ -> m (K LibPQ.Connection schema1)
197190execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn
198191
199−-- | Evaluate a `PQ` and discard the `LibPQ.Connection` but keep the result.
192+-- | Evaluate a `PQ` and discard the `Connection` but keep the result.
200193evalPQ
201194 :: Functor m
202− => PQ schemas0 schemas1 m x
203− -> K LibPQ.Connection schemas0
195+ => PQ schema0 schema1 m x
196+ -> K LibPQ.Connection schema0
204197 -> m x
205198evalPQ (PQ pq) conn = unK <$> pq conn
206199
@@ -208,56 +201,50 @@ evalPQ (PQ pq) conn = unK <$> pq conn
208201-- [enriched category](https://ncatlab.org/nlab/show/enriched+category).
209202-- An indexed monad transformer transforms a `Monad` into an indexed monad.
210203-- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that
211−-- support running `Definition`s using `define`.
204+-- support running `Definition`s using `define` and embedding a computation
205+-- in a larger schema using `pqEmbed`.
212206class IndexedMonadTransPQ pq where
213207
214208 -- | indexed analog of `<*>`
215209 pqAp
216210 :: Monad m
217− => pq schemas0 schemas1 m (x -> y)
218− -> pq schemas1 schemas2 m x
219− -> pq schemas0 schemas2 m y
211+ => pq schema0 schema1 m (x -> y)
212+ -> pq schema1 schema2 m x
213+ -> pq schema0 schema2 m y
220214
221215 -- | indexed analog of `join`
222216 pqJoin
223217 :: Monad m
224− => pq schemas0 schemas1 m (pq schemas1 schemas2 m y)
225− -> pq schemas0 schemas2 m y
226− pqJoin pq = pq & pqBind id
218+ => pq schema0 schema1 m (pq schema1 schema2 m y)
219+ -> pq schema0 schema2 m y
227220
228221 -- | indexed analog of `=<<`
229222 pqBind
230223 :: Monad m
231− => (x -> pq schemas1 schemas2 m y)
232− -> pq schemas0 schemas1 m x
233− -> pq schemas0 schemas2 m y
224+ => (x -> pq schema1 schema2 m y)
225+ -> pq schema0 schema1 m x
226+ -> pq schema0 schema2 m y
234227
235228 -- | indexed analog of flipped `>>`
236229 pqThen
237230 :: 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)
231+ => pq schema1 schema2 m y
232+ -> pq schema0 schema1 m x
233+ -> pq schema0 schema2 m y
242234
243− -- | indexed analog of `<=<`
244− pqAndThen
235+ -- | Safely embed a computation in a larger schema.
236+ pqEmbed
245237 :: 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)
238+ => pq schema0 schema1 m x
239+ -> pq (table ': schema0) (table : schema1) m x
250240
251− -- | Run a `Definition` with `LibPQ.exec`.
241+ -- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law
252242 --
253− -- It should be functorial in effect.
254− --
255− -- @define id = return ()@
256− -- @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@
243+ -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@
257244 define
258− :: MonadIO io
259− => Definition schemas0 schemas1
260− -> pq schemas0 schemas1 io ()
245+ :: MonadBase IO io
246+ => Definition schema0 schema1
247+ -> pq schema0 schema1 io (K LibPQ.Result '[])
261248
262249instance IndexedMonadTransPQ PQ where
263250
@@ -266,30 +253,34 @@ instance IndexedMonadTransPQ PQ where
266253 K x' <- x (K (unK conn))
267254 return $ K (f' x')
268255
256+ pqJoin pq = pq & pqBind id
257+
269258 pqBind f (PQ x) = PQ $ \ conn -> do
270259 K x' <- x conn
271260 unPQ (f x') (K (unK conn))
272261
262+ pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
263+
264+ pqEmbed (PQ pq) = PQ $ \ (K conn) -> do
265+ K x <- pq (K conn)
266+ return $ K x
267+
273268 define (UnsafeDefinition q) = PQ $ \ (K conn) -> do
274− resultMaybe <- liftIO $ LibPQ.exec conn q
269+ resultMaybe <- liftBase $ LibPQ.exec conn q
275270 case resultMaybe of
276− Nothing -> throw $ ResultException
271+ Nothing -> error
277272 "define: LibPQ.exec returned no results"
278− Just result -> K <$> okResult_ result
273+ Just result -> return $ K (K result)
279274
280−{- | `MonadPQ` is an @mtl@ style constraint, similar to
281−`Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` to
275+{- | `MonadPQ` is an `mtl` style constraint, similar to
276+`Control.Monad.State.Class.MonadState`, for using `LibPQ` to
282277
283278* `manipulateParams` runs a `Manipulation` with params from a type
284279 with a `ToParams` constraint. It calls `LibPQ.execParams` and
285280 doesn't afraid of anything.
286281
287−* `manipulateParams_` is like `manipulateParams` for a returning-free statement.
288−
289282* `manipulate` is like `manipulateParams` for a parameter-free statement.
290283
291−* `manipulate_` is like `manipulate` for a returning-free statement.
292−
293284* `runQueryParams` is like `manipulateParams` for query statements.
294285
295286* `runQuery` is like `runQueryParams` for a parameter-free statement.
@@ -303,11 +294,11 @@ instance IndexedMonadTransPQ PQ where
303294* `forPrepared` is a flipped `traversePrepared`
304295
305296* `traversePrepared_` is like `traversePrepared` but works on `Foldable`
306− containers for a returning-free statement.
297+ containers and returns unit.
307298
308299* `forPrepared_` is a flipped `traversePrepared_`.
309300
310−* `liftPQ` lets you lift actions from `Database.PostgreSQL.LibPQ` that require a connection
301+* `liftPQ` lets you lift actions from `LibPQ` that require a connection
311302 into your monad.
312303
313304To define an instance, you can minimally define only `manipulateParams`,
@@ -315,398 +306,304 @@ To define an instance, you can minimally define only `manipulateParams`,
315306a default instance.
316307
317308-}
318−class Monad pq => MonadPQ schemas pq | pq -> schemas where
309+class Monad pq => MonadPQ schema pq | pq -> schema where
319310 manipulateParams
320− :: (ToParams x params, All OidOfParam params)
321− => Manipulation '[] schemas params ys
322− -- ^ `insertInto`, `update` or `deleteFrom`
311+ :: ToParams x params
312+ => Manipulation schema params ys
313+ -- ^ `insertRows`, `update` or `deleteFrom`
323314 -> x -> pq (K LibPQ.Result ys)
324315 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`
316+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
317+ => ToParams x params
318+ => Manipulation schema params ys
319+ -- ^ `insertRows`, `update` or `deleteFrom`
329320 -> x -> pq (K LibPQ.Result ys)
330321 manipulateParams manipulation params = lift $
331322 manipulateParams manipulation params
332323
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)
324+ manipulate :: Manipulation schema '[] ys -> pq (K LibPQ.Result ys)
341325 manipulate statement = manipulateParams statement ()
342326
343− manipulate_ :: Manipulation '[] schemas '[] '[] -> pq ()
344− manipulate_ = void . manipulate
345−
346327 runQueryParams
347− :: (ToParams x params, All OidOfParam params)
348− => Query '[] '[] schemas params ys
328+ :: ToParams x params
329+ => Query schema params ys
349330 -- ^ `select` and friends
350331 -> x -> pq (K LibPQ.Result ys)
351332 runQueryParams = manipulateParams . queryStatement
352333
353334 runQuery
354− :: Query '[] '[] schemas '[] ys
335+ :: Query schema '[] ys
355336 -- ^ `select` and friends
356337 -> pq (K LibPQ.Result ys)
357338 runQuery q = runQueryParams q ()
358339
359340 traversePrepared
360− :: (ToParams x params, Traversable list, All OidOfParam params)
361− => Manipulation '[] schemas params ys
362− -- ^ `insertInto`, `update`, or `deleteFrom`, and friends
341+ :: (ToParams x params, Traversable list)
342+ => Manipulation schema params ys
343+ -- ^ `insertRows`, `update`, or `deleteFrom`, and friends
363344 -> list x -> pq (list (K LibPQ.Result ys))
364345 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))
346+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
347+ => (ToParams x params, Traversable list)
348+ => Manipulation schema params ys -> list x -> pq (list (K LibPQ.Result ys))
368349 traversePrepared manipulation params = lift $
369350 traversePrepared manipulation params
370351
371352 forPrepared
372− :: (ToParams x params, Traversable list, All OidOfParam params)
353+ :: (ToParams x params, Traversable list)
373354 => list x
374− -> Manipulation '[] schemas params ys
375− -- ^ `insertInto`, `update` or `deleteFrom`
355+ -> Manipulation schema params ys
356+ -- ^ `insertRows`, `update` or `deleteFrom`
376357 -> pq (list (K LibPQ.Result ys))
377358 forPrepared = flip traversePrepared
378359
379360 traversePrepared_
380− :: (ToParams x params, Foldable list, All OidOfParam params)
381− => Manipulation '[] schemas params '[]
382− -- ^ `insertInto`, `update` or `deleteFrom`
361+ :: (ToParams x params, Foldable list)
362+ => Manipulation schema params '[]
363+ -- ^ `insertRows`, `update` or `deleteFrom`
383364 -> list x -> pq ()
384365 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`
366+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
367+ => (ToParams x params, Foldable list)
368+ => Manipulation schema params '[]
369+ -- ^ `insertRows`, `update` or `deleteFrom`
389370 -> list x -> pq ()
390371 traversePrepared_ manipulation params = lift $
391372 traversePrepared_ manipulation params
392373
393374 forPrepared_
394− :: (ToParams x params, Foldable list, All OidOfParam params)
375+ :: (ToParams x params, Foldable list)
395376 => list x
396− -> Manipulation '[] schemas params '[]
397− -- ^ `insertInto`, `update` or `deleteFrom`
377+ -> Manipulation schema params '[]
378+ -- ^ `insertRows`, `update` or `deleteFrom`
398379 -> pq ()
399380 forPrepared_ = flip traversePrepared_
400381
401382 liftPQ :: (LibPQ.Connection -> IO a) -> pq a
402383 default liftPQ
403− :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
384+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
404385 => (LibPQ.Connection -> IO a) -> pq a
405386 liftPQ = lift . liftPQ
406387
407−instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
408− => MonadPQ schemas (PQ schemas0 schemas1 io) where
388+instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)
389+ => MonadPQ schema (PQ schema0 schema1 io) where
409390
410391 manipulateParams
411− (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =
392+ (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =
412393 PQ $ \ (K conn) -> do
413394 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
395+ toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)
396+ params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
397+ resultMaybe <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
427398 case resultMaybe of
428− Nothing -> throw $ ResultException
399+ Nothing -> error
429400 "manipulateParams: LibPQ.execParams returned no results"
430− Just result -> do
431− okResult_ result
432− return $ K (K result)
401+ Just result -> return $ K (K result)
433402
434403 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')
404+ (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =
405+ PQ $ \ (K conn) -> liftBase $ do
406+ let temp = "temporary_statement"
407+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing
446408 case prepResultMaybe of
447− Nothing -> throw $ ResultException
409+ Nothing -> error
448410 "traversePrepared: LibPQ.prepare returned no results"
449− Just prepResult -> okResult_ prepResult
411+ Just prepResult -> do
412+ status <- LibPQ.resultStatus prepResult
413+ unless (status == LibPQ.CommandOk) . error $
414+ "traversePrepared: LibPQ.prepare status " <> show status
450415 results <- for list $ \ params -> do
451416 let
452− toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
417+ toParam' bytes = (bytes,LibPQ.Binary)
453418 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
454419 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
455420 case resultMaybe of
456− Nothing -> throw $ ResultException
421+ Nothing -> error
457422 "traversePrepared: LibPQ.execParams returned no results"
458− Just result -> do
459− okResult_ result
460− return $ K result
423+ Just result -> return $ K result
461424 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
462425 case deallocResultMaybe of
463− Nothing -> throw $ ResultException
426+ Nothing -> error
464427 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
465− Just deallocResult -> okResult_ deallocResult
428+ Just deallocResult -> do
429+ status <- LibPQ.resultStatus deallocResult
430+ unless (status == LibPQ.CommandOk) . error $
431+ "traversePrepared: DEALLOCATE status " <> show status
466432 return (K results)
467433
468434 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')
435+ (UnsafeManipulation q :: Manipulation schema xs '[]) (list :: list x) =
436+ PQ $ \ (K conn) -> liftBase $ do
437+ let temp = "temporary_statement"
438+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing
480439 case prepResultMaybe of
481− Nothing -> throw $ ResultException
440+ Nothing -> error
482441 "traversePrepared_: LibPQ.prepare returned no results"
483− Just prepResult -> okResult_ prepResult
442+ Just prepResult -> do
443+ status <- LibPQ.resultStatus prepResult
444+ unless (status == LibPQ.CommandOk) . error $
445+ "traversePrepared: LibPQ.prepare status " <> show status
484446 for_ list $ \ params -> do
485447 let
486− toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
448+ toParam' bytes = (bytes,LibPQ.Binary)
487449 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
488450 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
489451 case resultMaybe of
490− Nothing -> throw $ ResultException
452+ Nothing -> error
491453 "traversePrepared_: LibPQ.execParams returned no results"
492− Just result -> okResult_ result
454+ Just _result -> return ()
493455 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
494456 case deallocResultMaybe of
495− Nothing -> throw $ ResultException
457+ Nothing -> error
496458 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
497− Just deallocResult -> okResult_ deallocResult
459+ Just deallocResult -> do
460+ status <- LibPQ.resultStatus deallocResult
461+ unless (status == LibPQ.CommandOk) . error $
462+ "traversePrepared: DEALLOCATE status " <> show status
498463 return (K ())
499464
500465 liftPQ pq = PQ $ \ (K conn) -> do
501− y <- liftIO $ pq conn
466+ y <- liftBase $ pq conn
502467 return (K y)
503468
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
469+instance MonadPQ schema m => MonadPQ schema (IdentityT m)
470+instance MonadPQ schema m => MonadPQ schema (ReaderT r m)
471+instance MonadPQ schema m => MonadPQ schema (Strict.StateT s m)
472+instance MonadPQ schema m => MonadPQ schema (Lazy.StateT s m)
473+instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Strict.WriterT w m)
474+instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Lazy.WriterT w m)
475+instance MonadPQ schema m => MonadPQ schema (MaybeT m)
476+instance MonadPQ schema m => MonadPQ schema (ExceptT e m)
477+instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Strict.RWST r w s m)
478+instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Lazy.RWST r w s m)
479+instance MonadPQ schema m => MonadPQ schema (ContT r m)
480+instance MonadPQ schema m => MonadPQ schema (ListT m)
481+
482+instance (Monad m, schema0 ~ schema1)
483+ => Applicative (PQ schema0 schema1 m) where
518484 pure x = PQ $ \ _conn -> pure (K x)
519485 (<*>) = pqAp
520486
521−instance (Monad m, schemas0 ~ schemas1)
522− => Monad (PQ schemas0 schemas1 m) where
487+instance (Monad m, schema0 ~ schema1)
488+ => Monad (PQ schema0 schema1 m) where
523489 return = pure
524490 (>>=) = flip pqBind
525491
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
492+instance schema0 ~ schema1 => MFunctor (PQ schema0 schema1) where
531493 hoist f (PQ pq) = PQ (f . pq)
532494
533−instance schemas0 ~ schemas1 => MonadTrans (PQ schemas0 schemas1) where
495+instance schema0 ~ schema1 => MonadTrans (PQ schema0 schema1) where
534496 lift m = PQ $ \ _conn -> do
535497 x <- m
536498 return (K x)
537499
538−instance schemas0 ~ schemas1 => MMonad (PQ schemas0 schemas1) where
500+instance schema0 ~ schema1 => MMonad (PQ schema0 schema1) where
539501 embed f (PQ pq) = PQ $ \ conn -> do
540502 evalPQ (f (pq conn)) conn
541503
542−instance (MonadIO m, schema0 ~ schema1)
543− => MonadIO (PQ schema0 schema1 m) where
544− liftIO = lift . liftIO
504+instance (MonadBase b m, schema0 ~ schema1)
505+ => MonadBase b (PQ schema0 schema1 m) where
506+ liftBase = lift . liftBase
507+
508+-- | A snapshot of the state of a `PQ` computation.
509+type PQRun schema =
510+ forall m x. Monad m => PQ schema schema m x -> m (K x schema)
511+
512+-- | Helper function in defining `MonadBaseControl` instance for `PQ`.
513+pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a
514+pqliftWith f = PQ $ \ conn ->
515+ fmap K (f $ \ pq -> unPQ pq conn)
545516
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)
517+instance (MonadBaseControl b m, schema0 ~ schema1)
518+ => MonadBaseControl b (PQ schema0 schema1 m) where
519+ type StM (PQ schema0 schema1 m) x = StM m (K x schema0)
520+ liftBaseWith f =
521+ pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
522+ restoreM = PQ . const . restoreM
554523
555524-- | Get a row corresponding to a given row number from a `LibPQ.Result`,
556525-- throwing an exception if the row number is out of bounds.
557526getRow
558− :: (FromRow columns y, MonadIO io)
527+ :: (FromRow columns y, MonadBase IO io)
559528 => LibPQ.Row
560529 -- ^ row number
561530 -> K LibPQ.Result columns
562531 -- ^ result
563532 -> io y
564−getRow r (K result :: K LibPQ.Result columns) = liftIO $ do
533+getRow r (K result :: K LibPQ.Result columns) = liftBase $ do
565534 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)
535+ when (numRows < r) $ error $
536+ "getRow: expected at least " <> show r <> "rows but only saw "
537+ <> show numRows
569538 let len = fromIntegral (lengthSList (Proxy @columns))
570539 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
571540 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
541+ Nothing -> error "getRow: found unexpected length"
542+ Just row -> return $ fromRow @columns row
576543
577544-- | Intended to be used for unfolding in streaming libraries, `nextRow`
578545-- takes a total number of rows (which can be found with `ntuples`)
579546-- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`,
580547-- otherwise returning the row along with the next row number.
581548nextRow
582− :: (FromRow columns y, MonadIO io)
549+ :: (FromRow columns y, MonadBase IO io)
583550 => LibPQ.Row -- ^ total number of rows
584551 -> K LibPQ.Result columns -- ^ result
585552 -> LibPQ.Row -- ^ row number
586553 -> io (Maybe (LibPQ.Row,y))
587554nextRow total (K result :: K LibPQ.Result columns) r
588− = liftIO $ if r >= total then return Nothing else do
555+ = liftBase $ if r >= total then return Nothing else do
589556 let len = fromIntegral (lengthSList (Proxy @columns))
590557 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
591558 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)
559+ Nothing -> error "nextRow: found unexpected length"
560+ Just row -> return $ Just (r+1, fromRow @columns row)
596561
597562-- | Get all rows from a `LibPQ.Result`.
598563getRows
599− :: (FromRow columns y, MonadIO io)
564+ :: (FromRow columns y, MonadBase IO io)
600565 => K LibPQ.Result columns -- ^ result
601566 -> io [y]
602−getRows (K result :: K LibPQ.Result columns) = liftIO $ do
567+getRows (K result :: K LibPQ.Result columns) = liftBase $ do
603568 let len = fromIntegral (lengthSList (Proxy @columns))
604569 numRows <- LibPQ.ntuples result
605570 for [0 .. numRows - 1] $ \ r -> do
606571 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
607572 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
573+ Nothing -> error "getRows: found unexpected length"
574+ Just row -> return $ fromRow @columns row
612575
613576-- | Get the first row if possible from a `LibPQ.Result`.
614577firstRow
615− :: (FromRow columns y, MonadIO io)
578+ :: (FromRow columns y, MonadBase IO io)
616579 => K LibPQ.Result columns -- ^ result
617580 -> io (Maybe y)
618−firstRow (K result :: K LibPQ.Result columns) = liftIO $ do
581+firstRow (K result :: K LibPQ.Result columns) = liftBase $ do
619582 numRows <- LibPQ.ntuples result
620583 if numRows <= 0 then return Nothing else do
621584 let len = fromIntegral (lengthSList (Proxy @columns))
622585 row' <- traverse (LibPQ.getvalue result 0) [0 .. len - 1]
623586 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
587+ Nothing -> error "firstRow: found unexpected length"
588+ Just row -> return . Just $ fromRow @columns row
628589
629590-- | Lifts actions on results from @LibPQ@.
630591liftResult
631− :: MonadIO io
592+ :: MonadBase IO io
632593 => (LibPQ.Result -> IO x)
633594 -> K LibPQ.Result results -> io x
634−liftResult f (K result) = liftIO $ f result
595+liftResult f (K result) = liftBase $ f result
635596
636597-- | Returns the number of rows (tuples) in the query result.
637−ntuples :: MonadIO io => K LibPQ.Result columns -> io LibPQ.Row
598+ntuples :: MonadBase IO io => K LibPQ.Result columns -> io LibPQ.Row
638599ntuples = liftResult LibPQ.ntuples
639600
640601-- | Returns the result status of the command.
641−resultStatus :: MonadIO io => K LibPQ.Result results -> io LibPQ.ExecStatus
602+resultStatus :: MonadBase IO io => K LibPQ.Result results -> io LibPQ.ExecStatus
642603resultStatus = liftResult LibPQ.resultStatus
643604
644605-- | Returns the error message most recently generated by an operation
645606-- on the connection.
646607resultErrorMessage
647− :: MonadIO io => K LibPQ.Result results -> io (Maybe ByteString)
608+ :: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)
648609resultErrorMessage = 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.hs+81−70
@@ -1,40 +1,18 @@
11{-|
2−Module: Squeal.PostgreSQL.Pool
3−Description: Connection pools
2+Module: Squeal.PostgreSQL.Definition
3+Description: Pooled connections
44Copyright: (c) Eitan Chatav, 2017
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
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
8+A `MonadPQ` for pooled connections.
319-}
3210
3311{-# LANGUAGE
34− DeriveFunctor
12+ DataKinds
13+ , DeriveFunctor
3514 , FlexibleContexts
3615 , FlexibleInstances
37− , InstanceSigs
3816 , MultiParamTypeClasses
3917 , RankNTypes
4018 , ScopedTypeVariables
@@ -45,24 +23,34 @@ a
4523
4624module Squeal.PostgreSQL.Pool
4725 ( -- * Pools
48− Pool
26+ PoolPQ (..)
4927 , createConnectionPool
50− , usingConnectionPool
51− , destroyConnectionPool
28+ , Pool
29+ , destroyAllResources
30+ , PoolPQRun
31+ , poolpqliftWith
5232 ) where
5333
34+import Control.Monad.Base
35+import Control.Monad.Trans
36+import Control.Monad.Trans.Control
5437import Data.ByteString
38+import Data.Pool
5539import Data.Time
56−import Generics.SOP (K(..), unK)
57−import UnliftIO (MonadUnliftIO (..))
58−import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)
40+import Generics.SOP (K(..))
5941
6042import Squeal.PostgreSQL.PQ
43+import Squeal.PostgreSQL.Schema
44+
45+-- | `PoolPQ` @schema@ should be a drop-in replacement for `PQ` @schema schema@.
46+newtype PoolPQ (schema :: TablesType) m x =
47+ PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x }
48+ deriving Functor
6149
6250-- | Create a striped pool of connections.
6351-- 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.
6452createConnectionPool
65− :: MonadUnliftIO io
53+ :: MonadBase IO io
6654 => ByteString
6755 -- ^ The passed string can be empty to use all default parameters, or it can
6856 -- contain one or more parameter settings separated by whitespace.
@@ -78,45 +66,68 @@ createConnectionPool
7866 -> Int
7967 -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1.
8068 -- 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 =
69+ -> io (Pool (K Connection schema))
70+createConnectionPool conninfo stripes idle maxResrc = liftBase $
8371 createPool (connectdb conninfo) finish stripes idle maxResrc
8472
85−{-|
86−Temporarily take a connection from a `Pool`, perform an action with it,
87−and return it to the pool afterwards.
73+-- | `Applicative` instance for `PoolPQ`.
74+instance Monad m => Applicative (PoolPQ schema m) where
75+ pure x = PoolPQ $ \ _ -> pure x
76+ PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do
77+ f' <- f pool
78+ x' <- x pool
79+ return $ f' x'
8880
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
81+-- | `Monad` instance for `PoolPQ`.
82+instance Monad m => Monad (PoolPQ schema m) where
83+ return = pure
84+ PoolPQ x >>= f = PoolPQ $ \ pool -> do
85+ x' <- x pool
86+ runPoolPQ (f x') pool
10187
102−{- |
103−Destroy all connections in all stripes in the pool.
104−Note that this will ignore any exceptions in the destroy function.
88+-- | `MonadTrans` instance for `PoolPQ`.
89+instance MonadTrans (PoolPQ schema) where
90+ lift m = PoolPQ $ \ _pool -> m
10591
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.
92+-- | `MonadBase` instance for `PoolPQ`.
93+instance MonadBase b m => MonadBase b (PoolPQ schema m) where
94+ liftBase = lift . liftBase
11295
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
96+-- | `MonadPQ` instance for `PoolPQ`.
97+instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where
98+ manipulateParams manipulation params = PoolPQ $ \ pool -> do
99+ withResource pool $ \ conn -> do
100+ (K result :: K (K Result ys) schema) <- flip unPQ conn $
101+ manipulateParams manipulation params
102+ return result
103+ traversePrepared manipulation params = PoolPQ $ \ pool ->
104+ withResource pool $ \ conn -> do
105+ (K result :: K (list (K Result ys)) schema) <- flip unPQ conn $
106+ traversePrepared manipulation params
107+ return result
108+ traversePrepared_ manipulation params = PoolPQ $ \ pool -> do
109+ withResource pool $ \ conn -> do
110+ (_ :: K () schema) <- flip unPQ conn $
111+ traversePrepared_ manipulation params
112+ return ()
113+ liftPQ m = PoolPQ $ \ pool ->
114+ withResource pool $ \ conn -> do
115+ (K result :: K result schema) <- flip unPQ conn $
116+ liftPQ m
117+ return result
118+
119+-- | A snapshot of the state of a `PoolPQ` computation.
120+type PoolPQRun schema =
121+ forall m x. Monad m => PoolPQ schema m x -> m x
122+
123+-- | Helper function in defining `MonadBaseControl` instance for `PoolPQ`.
124+poolpqliftWith :: Functor m => (PoolPQRun schema -> m a) -> PoolPQ schema m a
125+poolpqliftWith f = PoolPQ $ \ pool ->
126+ (f $ \ pq -> runPoolPQ pq pool)
127+
128+-- | `MonadBaseControl` instance for `PoolPQ`.
129+instance MonadBaseControl b m => MonadBaseControl b (PoolPQ schema m) where
130+ type StM (PoolPQ schema m) x = StM m x
131+ liftBaseWith f =
132+ poolpqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
133+ restoreM = PoolPQ . const . restoreM
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+442−726
@@ -1,7 +1,7 @@
11{-|
22Module: Squeal.PostgreSQL.Query
33Description: Squeal queries
4−Copyright: (c) Eitan Chatav, 2019
4+Copyright: (c) Eitan Chatav, 2017
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
@@ -9,81 +9,75 @@ Squeal queries.
99-}
1010
1111{-# LANGUAGE
12− ConstraintKinds
12+ DataKinds
13+ , DeriveDataTypeable
1314 , DeriveGeneric
1415 , FlexibleContexts
1516 , FlexibleInstances
1617 , GADTs
1718 , GeneralizedNewtypeDeriving
19+ , KindSignatures
1820 , LambdaCase
1921 , MultiParamTypeClasses
20− , OverloadedLabels
2122 , OverloadedStrings
22− , QuantifiedConstraints
2323 , ScopedTypeVariables
2424 , StandaloneDeriving
2525 , TypeApplications
26− , TypeFamilies
2726 , TypeInType
2827 , TypeOperators
29− , RankNTypes
3028 , UndecidableInstances
31− #-}
29+#-}
3230
3331module Squeal.PostgreSQL.Query
3432 ( -- * 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
33+ Query (UnsafeQuery, renderQuery)
4934 , union
5035 , unionAll
5136 , intersect
5237 , intersectAll
5338 , except
5439 , exceptAll
55− -- ** With
56− , With (..)
57− , CommonTableExpression (..)
58− , withRecursive
40+ -- * Select
41+ , select
42+ , selectDistinct
43+ , selectStar
44+ , selectDistinctStar
45+ , selectDotStar
46+ , selectDistinctDotStar
5947 -- * Table Expressions
6048 , TableExpression (..)
49+ , renderTableExpression
6150 , from
6251 , where_
63− , groupBy
52+ , group
6453 , having
54+ , orderBy
6555 , limit
6656 , offset
67− -- * From Clauses
57+ -- * From
6858 , FromClause (..)
6959 , table
7060 , subquery
71− , view
72− , common
7361 , crossJoin
7462 , innerJoin
7563 , leftOuterJoin
7664 , rightOuterJoin
7765 , fullOuterJoin
7866 -- * Grouping
79− , By (..)
80− , GroupByClause (..)
81− , HavingClause (..)
67+ , By (By, By2)
68+ , renderBy
69+ , GroupByClause (NoGroups, Group)
70+ , renderGroupByClause
71+ , HavingClause (NoHaving, Having)
72+ , renderHavingClause
73+ -- * Sorting
74+ , SortExpression (..)
75+ , renderSortExpression
8276 ) where
8377
8478import Control.DeepSeq
8579import Data.ByteString (ByteString)
86−import Data.Kind (Type)
80+import Data.Monoid hiding (All)
8781import Data.String
8882import Data.Word
8983import Generics.SOP hiding (from)
@@ -91,577 +85,352 @@ import GHC.TypeLits
9185
9286import qualified GHC.Generics as GHC
9387
94−import Squeal.PostgreSQL.Alias
9588import 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
10189import Squeal.PostgreSQL.Render
10290import Squeal.PostgreSQL.Schema
10391
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−
11192{- |
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−:}
93+The process of retrieving or the command to retrieve data from a database
94+is called a `Query`. The `select`, `selectStar`, `selectDotStar`,
95+`selectDistinct`, `selectDistinctStar` and `selectDistinctDotStar` commands
96+are used to specify queries.
15597
15698simple query:
15799
158−>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]
159−>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
160100>>> :{
161101let
162− query :: Query_ (Public Schema) () (Row Int32 Int32)
163− query = select Star (from (table #tab))
164−in printSQL query
102+ query :: Query
103+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
104+ '[]
105+ '["col" ::: 'Null 'PGint4]
106+ query = selectStar (from (table (#tab `As` #t)))
107+in renderQuery query
165108:}
166−SELECT * FROM "tab" AS "tab"
109+"SELECT * FROM tab AS t"
167110
168111restricted query:
169112
170113>>> :{
171114let
172− query :: Query_ (Public Schema) () (Row Int32 Int32)
173− query =
174− select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2)
175− ( from (table #tab)
115+ query :: Query
116+ '[ "tab" ::: '[] :=>
117+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
118+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]
119+ '[]
120+ '[ "sum" ::: 'NotNull 'PGint4
121+ , "col1" ::: 'NotNull 'PGint4 ]
122+ query =
123+ select
124+ ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
125+ ( from (table (#tab `As` #t))
176126 & where_ (#col1 .> #col2)
177127 & where_ (#col2 .> 0) )
178−in printSQL query
128+in renderQuery query
179129:}
180−SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))
130+"SELECT (col1 + col2) AS sum, col1 AS col1 FROM tab AS t WHERE ((col1 > col2) AND (col2 > 0))"
181131
182132subquery:
183133
184134>>> :{
185135let
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
136+ query :: Query
137+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
138+ '[]
139+ '["col" ::: 'Null 'PGint4]
140+ query =
141+ selectStar
142+ (from (subquery (selectStar (from (table (#tab `As` #t))) `As` #sub)))
143+in renderQuery query
189144:}
190−SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub"
145+"SELECT * FROM (SELECT * FROM tab AS t) AS sub"
191146
192147limits and offsets:
193148
194149>>> :{
195150let
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
151+ query :: Query
152+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
153+ '[]
154+ '["col" ::: 'Null 'PGint4]
155+ query = selectStar
156+ (from (table (#tab `As` #t)) & limit 100 & offset 2 & limit 50 & offset 2)
157+in renderQuery query
199158:}
200−SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4
159+"SELECT * FROM tab AS t LIMIT 50 OFFSET 4"
201160
202161parameterized query:
203162
204163>>> :{
205164let
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
165+ query :: Query
166+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8]]
167+ '[ 'NotNull 'PGfloat8]
168+ '["col" ::: 'NotNull 'PGfloat8]
169+ query = selectStar
170+ (from (table (#tab `As` #t)) & where_ (#col .> param @1))
171+in renderQuery query
209172:}
210−SELECT * FROM "tab" AS "tab" WHERE ("col1" > ($1 :: int4))
173+"SELECT * FROM tab AS t WHERE (col > ($1 :: float8))"
211174
212175aggregation query:
213176
214177>>> :{
215178let
216− query :: Query_ (Public Schema) () (Row Int64 Int32)
179+ query :: Query
180+ '[ "tab" ::: '[] :=>
181+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
182+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]
183+ '[]
184+ '[ "sum" ::: 'NotNull 'PGint4
185+ , "col1" ::: 'NotNull 'PGint4 ]
217186 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
187+ select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil)
188+ ( from (table (#tab `As` #table1))
189+ & group (By #col1 :* Nil)
190+ & having (#col1 + sum_ #col2 .> 1) )
191+in renderQuery query
223192:}
224−SELECT COALESCE(sum(ALL "col2"), 0) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > 1)
193+"SELECT sum(col2) AS sum, col1 AS col1 FROM tab AS table1 GROUP BY col1 HAVING ((col1 + sum(col2)) > 1)"
225194
226195sorted query:
227196
228197>>> :{
229198let
230− query :: Query_ (Public Schema) () (Row Int32 Int32)
231− query = select Star (from (table #tab) & orderBy [#col1 & Asc])
232−in printSQL query
199+ query :: Query
200+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
201+ '[]
202+ '["col" ::: 'Null 'PGint4]
203+ query = selectStar
204+ (from (table (#tab `As` #t)) & orderBy [#col & AscNullsFirst])
205+in renderQuery query
233206:}
234−SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC
207+"SELECT * FROM tab AS t ORDER BY col ASC NULLS FIRST"
235208
236209joins:
237210
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−
211+>>> :set -XFlexibleContexts
273212>>> :{
274213let
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))
214+ query :: Query
215+ '[ "orders" :::
216+ '["pk_orders" ::: PrimaryKey '["id"]
217+ ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]
218+ ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"]] :=>
219+ '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
220+ , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
221+ , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
222+ , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4
223+ ]
224+ , "customers" :::
225+ '["pk_customers" ::: PrimaryKey '["id"]] :=>
226+ '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
227+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
228+ ]
229+ , "shippers" :::
230+ '["pk_shippers" ::: PrimaryKey '["id"]] :=>
231+ '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
232+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
233+ ]
234+ ]
235+ '[]
236+ '[ "order_price" ::: 'NotNull 'PGfloat4
237+ , "customer_name" ::: 'NotNull 'PGtext
238+ , "shipper_name" ::: 'NotNull 'PGtext
239+ ]
240+ query = select
241+ ( #o ! #price `As` #order_price :*
242+ #c ! #name `As` #customer_name :*
243+ #s ! #name `As` #shipper_name :* Nil )
244+ ( from (table (#orders `As` #o)
245+ & innerJoin (table (#customers `As` #c))
282246 (#o ! #customer_id .== #c ! #id)
283− & innerJoin (table (#shippers `as` #s))
247+ & innerJoin (table (#shippers `As` #s))
284248 (#o ! #shipper_id .== #s ! #id)) )
285−in printSQL query
249+in renderQuery query
286250:}
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")
251+"SELECT o.price AS order_price, c.name AS customer_name, s.name AS shipper_name FROM orders AS o INNER JOIN customers AS c ON (o.customer_id = c.id) INNER JOIN shippers AS s ON (o.shipper_id = s.id)"
288252
289253self-join:
290254
291255>>> :{
292256let
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
257+ query :: Query
258+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
259+ '[]
260+ '["col" ::: 'Null 'PGint4]
261+ query = selectDotStar #t1
262+ (from (table (#tab `As` #t1) & crossJoin (table (#tab `As` #t2))))
263+in renderQuery query
298264:}
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")
265+"SELECT t1.* FROM tab AS t1 CROSS JOIN tab AS t2"
312266
313267set operations:
314268
315269>>> :{
316270let
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)
271+ query :: Query
272+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
273+ '[]
274+ '["col" ::: 'Null 'PGint4]
353275 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
276+ selectStar (from (table (#tab `As` #t)))
277+ `unionAll`
278+ selectStar (from (table (#tab `As` #t)))
279+in renderQuery query
359280:}
360−SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))
361−
281+"(SELECT * FROM tab AS t) UNION ALL (SELECT * FROM tab AS t)"
362282-}
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)
283+newtype Query
284+ (schema :: TablesType)
285+ (params :: [NullityType])
286+ (columns :: RelationType)
287+ = UnsafeQuery { renderQuery :: ByteString }
288+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
369289
370290-- | The results of two queries can be combined using the set operation
371−-- `union`. Duplicate rows are eliminated.
291+-- `union`. Duplicate rows are eliminated.
372292union
373− :: Query outer commons schemas params columns
374− -> Query outer commons schemas params columns
375− -> Query outer commons schemas params columns
293+ :: Query schema params columns
294+ -> Query schema params columns
295+ -> Query schema params columns
376296q1 `union` q2 = UnsafeQuery $
377− parenthesized (renderSQL q1)
297+ parenthesized (renderQuery q1)
378298 <+> "UNION"
379− <+> parenthesized (renderSQL q2)
299+ <+> parenthesized (renderQuery q2)
380300
381301-- | The results of two queries can be combined using the set operation
382302-- `unionAll`, the disjoint union. Duplicate rows are retained.
383303unionAll
384− :: Query outer commons schemas params columns
385− -> Query outer commons schemas params columns
386− -> Query outer commons schemas params columns
304+ :: Query schema params columns
305+ -> Query schema params columns
306+ -> Query schema params columns
387307q1 `unionAll` q2 = UnsafeQuery $
388− parenthesized (renderSQL q1)
308+ parenthesized (renderQuery q1)
389309 <+> "UNION" <+> "ALL"
390− <+> parenthesized (renderSQL q2)
310+ <+> parenthesized (renderQuery q2)
391311
392312-- | The results of two queries can be combined using the set operation
393313-- `intersect`, the intersection. Duplicate rows are eliminated.
394314intersect
395− :: Query outer commons schemas params columns
396− -> Query outer commons schemas params columns
397− -> Query outer commons schemas params columns
315+ :: Query schema params columns
316+ -> Query schema params columns
317+ -> Query schema params columns
398318q1 `intersect` q2 = UnsafeQuery $
399− parenthesized (renderSQL q1)
319+ parenthesized (renderQuery q1)
400320 <+> "INTERSECT"
401− <+> parenthesized (renderSQL q2)
321+ <+> parenthesized (renderQuery q2)
402322
403323-- | The results of two queries can be combined using the set operation
404324-- `intersectAll`, the intersection. Duplicate rows are retained.
405325intersectAll
406− :: Query outer commons schemas params columns
407− -> Query outer commons schemas params columns
408− -> Query outer commons schemas params columns
326+ :: Query schema params columns
327+ -> Query schema params columns
328+ -> Query schema params columns
409329q1 `intersectAll` q2 = UnsafeQuery $
410− parenthesized (renderSQL q1)
330+ parenthesized (renderQuery q1)
411331 <+> "INTERSECT" <+> "ALL"
412− <+> parenthesized (renderSQL q2)
332+ <+> parenthesized (renderQuery q2)
413333
414334-- | The results of two queries can be combined using the set operation
415335-- `except`, the set difference. Duplicate rows are eliminated.
416336except
417− :: Query outer commons schemas params columns
418− -> Query outer commons schemas params columns
419− -> Query outer commons schemas params columns
337+ :: Query schema params columns
338+ -> Query schema params columns
339+ -> Query schema params columns
420340q1 `except` q2 = UnsafeQuery $
421− parenthesized (renderSQL q1)
341+ parenthesized (renderQuery q1)
422342 <+> "EXCEPT"
423− <+> parenthesized (renderSQL q2)
343+ <+> parenthesized (renderQuery q2)
424344
425345-- | The results of two queries can be combined using the set operation
426346-- `exceptAll`, the set difference. Duplicate rows are retained.
427347exceptAll
428− :: Query outer commons schemas params columns
429− -> Query outer commons schemas params columns
430− -> Query outer commons schemas params columns
348+ :: Query schema params columns
349+ -> Query schema params columns
350+ -> Query schema params columns
431351q1 `exceptAll` q2 = UnsafeQuery $
432− parenthesized (renderSQL q1)
352+ parenthesized (renderQuery q1)
433353 <+> "EXCEPT" <+> "ALL"
434− <+> parenthesized (renderSQL q2)
354+ <+> parenthesized (renderQuery q2)
435355
436356{-----------------------------------------
437357SELECT queries
438358-----------------------------------------}
439359
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−
525360-- | the `TableExpression` in the `select` command constructs an intermediate
526361-- virtual table by possibly combining tables, views, eliminating rows,
527362-- grouping, etc. This table is finally passed on to processing by
528−-- the select list. The `Selection` determines which columns of
363+-- the select list. The select list determines which columns of
529364-- the intermediate table are actually output.
530365select
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
366+ :: SListI columns
367+ => NP (Aliased (Expression relations grouping params)) (column ': columns)
547368 -- ^ select list
548− -> TableExpression outer commons grp schemas params from
369+ -> TableExpression schema params relations grouping
549370 -- ^ intermediate virtual table
550− -> Query outer commons schemas params row
551−select_ = select . List
371+ -> Query schema params (column ': columns)
372+select list rels = UnsafeQuery $
373+ "SELECT"
374+ <+> renderCommaSeparated (renderAliasedAs renderExpression) list
375+ <+> renderTableExpression rels
552376
553377-- | After the select list has been processed, the result table can
554378-- be subject to the elimination of duplicate rows using `selectDistinct`.
555379selectDistinct
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
380+ :: SListI columns
381+ => NP (Aliased (Expression relations 'Ungrouped params)) (column ': columns)
382+ -- ^ select list
383+ -> TableExpression schema params relations 'Ungrouped
560384 -- ^ intermediate virtual table
561− -> Query outer commons schemas params columns
562−selectDistinct selection tabexpr = UnsafeQuery $
385+ -> Query schema params (column ': columns)
386+selectDistinct list rels = UnsafeQuery $
563387 "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
388+ <+> renderCommaSeparated (renderAliasedAs renderExpression) list
389+ <+> renderTableExpression rels
390+
391+-- | The simplest kind of query is `selectStar` which emits all columns
392+-- that the table expression produces.
393+selectStar
394+ :: HasUnique relation relations columns
395+ => TableExpression schema params relations 'Ungrouped
574396 -- ^ 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
397+ -> Query schema params columns
398+selectStar rels = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression rels
399+
400+-- | A `selectDistinctStar` emits all columns that the table expression
401+-- produces and eliminates duplicate rows.
402+selectDistinctStar
403+ :: HasUnique relation relations columns
404+ => TableExpression schema params relations 'Ungrouped
405+ -- ^ intermediate virtual table
406+ -> Query schema params columns
407+selectDistinctStar rels = UnsafeQuery $
408+ "SELECT DISTINCT" <+> "*" <+> renderTableExpression rels
409+
410+-- | When working with multiple tables, it can also be useful to ask
411+-- for all the columns of a particular table, using `selectDotStar`.
412+selectDotStar
413+ :: Has relation relations columns
414+ => Alias relation
415+ -- ^ particular virtual subtable
416+ -> TableExpression schema params relations 'Ungrouped
598417 -- ^ 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
418+ -> Query schema params columns
419+selectDotStar rel relations = UnsafeQuery $
420+ "SELECT" <+> renderAlias rel <> ".*" <+> renderTableExpression relations
421+
422+-- | A `selectDistinctDotStar` asks for all the columns of a particular table,
423+-- and eliminates duplicate rows.
424+selectDistinctDotStar
425+ :: Has relation relations columns
426+ => Alias relation
427+ -- ^ particular virtual table
428+ -> TableExpression schema params relations 'Ungrouped
623429 -- ^ 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 []
430+ -> Query schema params columns
431+selectDistinctDotStar rel relations = UnsafeQuery $
432+ "SELECT DISTINCT" <+> renderAlias rel <> ".*"
433+ <+> renderTableExpression relations
665434
666435{-----------------------------------------
667436Table Expressions
@@ -674,17 +443,15 @@ Table Expressions
674443-- to a table on disk, a so-called base table, but more complex expressions
675444-- can be used to modify or combine base tables in various ways.
676445data TableExpression
677− (outer :: FromType)
678− (commons :: FromType)
679− (grp :: Grouping)
680− (schemas :: SchemasType)
446+ (schema :: TablesType)
681447 (params :: [NullityType])
682− (from :: FromType)
448+ (relations :: RelationsType)
449+ (grouping :: Grouping)
683450 = TableExpression
684− { fromClause :: FromClause outer commons schemas params from
451+ { fromClause :: FromClause schema params relations
685452 -- ^ A table reference that can be a table name, or a derived table such
686453 -- as a subquery, a @JOIN@ construct, or complex combinations of these.
687− , whereClause :: [Condition outer commons 'Ungrouped schemas params from]
454+ , whereClause :: [Condition relations 'Ungrouped params]
688455 -- ^ optional search coditions, combined with `.&&`. After the processing
689456 -- of the `fromClause` is done, each row of the derived virtual table
690457 -- is checked against the search condition. If the result of the
@@ -693,20 +460,20 @@ data TableExpression
693460 -- at least one column of the table generated in the `fromClause`;
694461 -- this is not required, but otherwise the WHERE clause will
695462 -- be fairly useless.
696− , groupByClause :: GroupByClause grp from
463+ , groupByClause :: GroupByClause relations grouping
697464 -- ^ The `groupByClause` is used to group together those rows in a table
698465 -- that have the same values in all the columns listed. The order in which
699466 -- the columns are listed does not matter. The effect is to combine each
700467 -- set of rows having common values into one group row that represents all
701468 -- rows in the group. This is done to eliminate redundancy in the output
702469 -- and/or compute aggregates that apply to these groups.
703− , havingClause :: HavingClause outer commons grp schemas params from
470+ , havingClause :: HavingClause relations grouping params
704471 -- ^ If a table has been grouped using `groupBy`, but only certain groups
705472 -- are of interest, the `havingClause` can be used, much like a
706473 -- `whereClause`, to eliminate groups from the result. Expressions in the
707474 -- `havingClause` can refer both to grouped expressions and to ungrouped
708475 -- expressions (which necessarily involve an aggregate function).
709− , orderByClause :: [SortExpression outer commons grp schemas params from]
476+ , orderByClause :: [SortExpression relations grouping params]
710477 -- ^ The `orderByClause` is for optional sorting. When more than one
711478 -- `SortExpression` is specified, the later (right) values are used to sort
712479 -- rows that are equal according to the earlier (left) values.
@@ -716,69 +483,72 @@ data TableExpression
716483 -- will be returned (but possibly fewer, if the query itself yields
717484 -- fewer rows).
718485 , offsetClause :: [Word64]
719− -- ^ The `offsetClause` is combined with `Prelude.+` to give an offset count
486+ -- ^ The `offsetClause` is combined with `+` to give an offset count
720487 -- if nonempty. The offset count says to skip that many rows before
721488 -- beginning to return rows. The rows are skipped before the limit count
722489 -- is applied.
723− } deriving (GHC.Generic)
490+ }
724491
725492-- | 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))
493+renderTableExpression
494+ :: TableExpression schema params relations grouping
495+ -> ByteString
496+renderTableExpression
497+ (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat
498+ [ "FROM ", renderFromClause frm'
499+ , renderWheres whs'
500+ , renderGroupByClause grps'
501+ , renderHavingClause hvs'
502+ , renderOrderByClause srts'
503+ , renderLimits lims'
504+ , renderOffsets offs'
505+ ]
506+ where
507+ renderWheres = \case
508+ [] -> ""
509+ wh:[] -> " WHERE" <+> renderExpression wh
510+ wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)
511+ renderOrderByClause = \case
512+ [] -> ""
513+ srts -> " ORDER BY"
514+ <+> commaSeparated (renderSortExpression <$> srts)
515+ renderLimits = \case
516+ [] -> ""
517+ lims -> " LIMIT" <+> fromString (show (minimum lims))
518+ renderOffsets = \case
519+ [] -> ""
520+ offs -> " OFFSET" <+> fromString (show (sum offs))
751521
752522-- | A `from` generates a `TableExpression` from a table reference that can be
753523-- a table name, or a derived table such as a subquery, a JOIN construct,
754524-- or complex combinations of these. A `from` may be transformed by `where_`,
755−-- `groupBy`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator
525+-- `group`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator
756526-- to match the left-to-right sequencing of their placement in SQL.
757527from
758− :: FromClause outer commons schemas params from -- ^ table reference
759− -> TableExpression outer commons 'Ungrouped schemas params from
760−from tab = TableExpression tab [] noGroups NoHaving [] [] []
528+ :: FromClause schema params relations -- ^ table reference
529+ -> TableExpression schema params relations 'Ungrouped
530+from rels = TableExpression rels [] NoGroups NoHaving [] [] []
761531
762532-- | A `where_` is an endomorphism of `TableExpression`s which adds a
763533-- search condition to the `whereClause`.
764534where_
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
535+ :: Condition relations 'Ungrouped params -- ^ filtering condition
536+ -> TableExpression schema params relations grouping
537+ -> TableExpression schema params relations grouping
768538where_ wh rels = rels {whereClause = wh : whereClause rels}
769539
770−-- | A `groupBy` is a transformation of `TableExpression`s which switches
771−-- its `Grouping` from `Ungrouped` to `Grouped`. Use @groupBy Nil@ to perform
540+-- | A `group` is a transformation of `TableExpression`s which switches
541+-- its `Grouping` from `Ungrouped` to `Grouped`. Use @group Nil@ to perform
772542-- a "grand total" aggregation query.
773−groupBy
543+group
774544 :: 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
545+ => NP (By relations) bys -- ^ grouped columns
546+ -> TableExpression schema params relations 'Ungrouped
547+ -> TableExpression schema params relations ('Grouped bys)
548+group bys rels = TableExpression
779549 { fromClause = fromClause rels
780550 , whereClause = whereClause rels
781− , groupByClause = group bys
551+ , groupByClause = Group bys
782552 , havingClause = Having []
783553 , orderByClause = []
784554 , limitClause = limitClause rels
@@ -788,29 +558,34 @@ groupBy bys rels = TableExpression
788558-- | A `having` is an endomorphism of `TableExpression`s which adds a
789559-- search condition to the `havingClause`.
790560having
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
561+ :: Condition relations ('Grouped bys) params -- ^ having condition
562+ -> TableExpression schema params relations ('Grouped bys)
563+ -> TableExpression schema params relations ('Grouped bys)
794564having hv rels = rels
795565 { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) }
796566
797−instance OrderBy TableExpression where
798− orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}
567+-- | An `orderBy` is an endomorphism of `TableExpression`s which appends an
568+-- ordering to the right of the `orderByClause`.
569+orderBy
570+ :: [SortExpression relations grouping params] -- ^ sort expressions
571+ -> TableExpression schema params relations grouping
572+ -> TableExpression schema params relations grouping
573+orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}
799574
800575-- | A `limit` is an endomorphism of `TableExpression`s which adds to the
801576-- `limitClause`.
802577limit
803578 :: Word64 -- ^ limit parameter
804− -> TableExpression outer commons grp schemas params from
805− -> TableExpression outer commons grp schemas params from
579+ -> TableExpression schema params relations grouping
580+ -> TableExpression schema params relations grouping
806581limit lim rels = rels {limitClause = lim : limitClause rels}
807582
808583-- | An `offset` is an endomorphism of `TableExpression`s which adds to the
809584-- `offsetClause`.
810585offset
811586 :: Word64 -- ^ offset parameter
812− -> TableExpression outer commons grp schemas params from
813− -> TableExpression outer commons grp schemas params from
587+ -> TableExpression schema params relations grouping
588+ -> TableExpression schema params relations grouping
814589offset off rels = rels {offsetClause = off : offsetClause rels}
815590
816591{-----------------------------------------
@@ -821,76 +596,51 @@ FROM clauses
821596A `FromClause` can be a table name, or a derived table such
822597as a subquery, a @JOIN@ construct, or complex combinations of these.
823598-}
824−newtype FromClause outer commons schemas params from
599+newtype FromClause schema params relations
825600 = UnsafeFromClause { renderFromClause :: ByteString }
826601 deriving (GHC.Generic,Show,Eq,Ord,NFData)
827−instance RenderSQL (FromClause outer commons schemas params from) where
828− renderSQL = renderFromClause
829602
830−-- | A real `table` is a table from the database.
603+-- | A real `table` is a table from the schema.
831604table
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
605+ :: Aliased (Table schema) table
606+ -> FromClause schema params '[table]
607+table = UnsafeFromClause . renderAliasedAs renderTable
837608
838609-- | `subquery` derives a table from a `Query`.
839610subquery
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.
611+ :: Aliased (Query schema params) table
612+ -> FromClause schema params '[table]
613+subquery = UnsafeFromClause . renderAliasedAs (parenthesized . renderQuery)
614+
615+{- | @left & crossJoin right@. For every possible combination of rows from
616+ @left@ and @right@ (i.e., a Cartesian product), the joined table will contain
617+ a row consisting of all columns in @left@ followed by all columns in @right@.
618+ If the tables have @n@ and @m@ rows respectively, the joined table will
619+ have @n * m@ rows.
870620-}
871621crossJoin
872− :: FromClause outer commons schemas params right
622+ :: FromClause schema params right
873623 -- ^ right
874− -> FromClause outer commons schemas params left
624+ -> FromClause schema params left
875625 -- ^ left
876− -> FromClause outer commons schemas params (Join left right)
626+ -> FromClause schema params (Join left right)
877627crossJoin right left = UnsafeFromClause $
878− renderSQL left <+> "CROSS JOIN" <+> renderSQL right
628+ renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right
879629
880630{- | @left & innerJoin right on@. The joined table is filtered by
881631the @on@ condition.
882632-}
883633innerJoin
884− :: FromClause outer commons schemas params right
634+ :: FromClause schema params right
885635 -- ^ right
886− -> Condition outer commons 'Ungrouped schemas params (Join left right)
636+ -> Condition (Join left right) 'Ungrouped params
887637 -- ^ @on@ condition
888− -> FromClause outer commons schemas params left
638+ -> FromClause schema params left
889639 -- ^ left
890− -> FromClause outer commons schemas params (Join left right)
640+ -> FromClause schema params (Join left right)
891641innerJoin right on left = UnsafeFromClause $
892− renderSQL left <+> "INNER JOIN" <+> renderSQL right
893− <+> "ON" <+> renderSQL on
642+ renderFromClause left <+> "INNER JOIN" <+> renderFromClause right
643+ <+> "ON" <+> renderExpression on
894644
895645{- | @left & leftOuterJoin right on@. First, an inner join is performed.
896646 Then, for each row in @left@ that does not satisfy the @on@ condition with
@@ -898,16 +648,16 @@ innerJoin right on left = UnsafeFromClause $
898648 Thus, the joined table always has at least one row for each row in @left@.
899649-}
900650leftOuterJoin
901− :: FromClause outer commons schemas params right
651+ :: FromClause schema params right
902652 -- ^ right
903− -> Condition outer commons 'Ungrouped schemas params (Join left right)
653+ -> Condition (Join left right) 'Ungrouped params
904654 -- ^ @on@ condition
905− -> FromClause outer commons schemas params left
655+ -> FromClause schema params left
906656 -- ^ left
907− -> FromClause outer commons schemas params (Join left (NullifyFrom right))
657+ -> FromClause schema params (Join left (NullifyRelations right))
908658leftOuterJoin right on left = UnsafeFromClause $
909− renderSQL left <+> "LEFT OUTER JOIN" <+> renderSQL right
910− <+> "ON" <+> renderSQL on
659+ renderFromClause left <+> "LEFT OUTER JOIN" <+> renderFromClause right
660+ <+> "ON" <+> renderExpression on
911661
912662{- | @left & rightOuterJoin right on@. First, an inner join is performed.
913663 Then, for each row in @right@ that does not satisfy the @on@ condition with
@@ -916,16 +666,16 @@ leftOuterJoin right on left = UnsafeFromClause $
916666 have a row for each row in @right@.
917667-}
918668rightOuterJoin
919− :: FromClause outer commons schemas params right
669+ :: FromClause schema params right
920670 -- ^ right
921− -> Condition outer commons 'Ungrouped schemas params (Join left right)
671+ -> Condition (Join left right) 'Ungrouped params
922672 -- ^ @on@ condition
923− -> FromClause outer commons schemas params left
673+ -> FromClause schema params left
924674 -- ^ left
925− -> FromClause outer commons schemas params (Join (NullifyFrom left) right)
675+ -> FromClause schema params (Join (NullifyRelations left) right)
926676rightOuterJoin right on left = UnsafeFromClause $
927− renderSQL left <+> "RIGHT OUTER JOIN" <+> renderSQL right
928− <+> "ON" <+> renderSQL on
677+ renderFromClause left <+> "RIGHT OUTER JOIN" <+> renderFromClause right
678+ <+> "ON" <+> renderExpression on
929679
930680{- | @left & fullOuterJoin right on@. First, an inner join is performed.
931681 Then, for each row in @left@ that does not satisfy the @on@ condition with
@@ -935,56 +685,47 @@ rightOuterJoin right on left = UnsafeFromClause $
935685 is added.
936686-}
937687fullOuterJoin
938− :: FromClause outer commons schemas params right
688+ :: FromClause schema params right
939689 -- ^ right
940− -> Condition outer commons 'Ungrouped schemas params (Join left right)
690+ -> Condition (Join left right) 'Ungrouped params
941691 -- ^ @on@ condition
942− -> FromClause outer commons schemas params left
692+ -> FromClause schema params left
943693 -- ^ left
944− -> FromClause outer commons schemas params
945− (Join (NullifyFrom left) (NullifyFrom right))
694+ -> FromClause schema params
695+ (Join (NullifyRelations left) (NullifyRelations right))
946696fullOuterJoin right on left = UnsafeFromClause $
947− renderSQL left <+> "FULL OUTER JOIN" <+> renderSQL right
948− <+> "ON" <+> renderSQL on
697+ renderFromClause left <+> "FULL OUTER JOIN" <+> renderFromClause right
698+ <+> "ON" <+> renderExpression on
949699
950700{-----------------------------------------
951701Grouping
952702-----------------------------------------}
953703
954−-- | `By`s are used in `groupBy` to reference a list of columns which are then
704+-- | `By`s are used in `group` to reference a list of columns which are then
955705-- used to group together those rows in a table that have the same values
956706-- in all the columns listed. @By \#col@ will reference an unambiguous
957707-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table
958708-- qualified column @tab.col@.
959709data By
960− (from :: FromType)
710+ (relations :: RelationsType)
961711 (by :: (Symbol,Symbol)) where
962− By1
963− :: (HasUnique table from columns, Has column columns ty)
712+ By
713+ :: (HasUnique relation relations columns, Has column columns ty)
964714 => Alias column
965− -> By from '(table, column)
715+ -> By relations '(relation, column)
966716 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
717+ :: (Has relation relations columns, Has column columns ty)
718+ => (Alias relation, Alias column)
719+ -> By relations '(relation, column)
720+deriving instance Show (By relations by)
721+deriving instance Eq (By relations by)
722+deriving instance Ord (By relations by)
723+
724+-- | Renders a `By`.
725+renderBy :: By relations by -> ByteString
726+renderBy = \case
727+ By column -> renderAlias column
728+ By2 (rel, column) -> renderAlias rel <> "." <> renderAlias column
988729
989730-- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.
990731-- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`.
@@ -992,107 +733,82 @@ instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])
992733-- done on @NoGroups@ while all output `Expression`s must be aggregated
993734-- in @Group Nil@. In general, all output `Expression`s in the
994735-- 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'
736+data GroupByClause relations grouping where
737+ NoGroups :: GroupByClause relations 'Ungrouped
738+ Group
739+ :: SListI bys
740+ => NP (By relations) bys
741+ -> GroupByClause relations ('Grouped bys)
742+
743+-- | Renders a `GroupByClause`.
744+renderGroupByClause :: GroupByClause relations grouping -> ByteString
745+renderGroupByClause = \case
746+ NoGroups -> ""
747+ Group Nil -> ""
748+ Group bys -> " GROUP BY" <+> renderCommaSeparated renderBy bys
1009749
1010750-- | A `HavingClause` is used to eliminate groups that are not of interest.
1011751-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
1012752-- `TableExpression` must use `Having` whose conditions are combined with
1013753-- `.&&`.
1014−data HavingClause outer commons grp schemas params from where
1015− NoHaving :: HavingClause outer commons 'Ungrouped schemas params from
754+data HavingClause relations grouping params where
755+ NoHaving :: HavingClause relations 'Ungrouped params
1016756 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)
757+ :: [Condition relations ('Grouped bys) params]
758+ -> HavingClause relations ('Grouped bys) params
759+deriving instance Show (HavingClause relations grouping params)
760+deriving instance Eq (HavingClause relations grouping params)
761+deriving instance Ord (HavingClause relations grouping params)
1022762
1023763-- | 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
764+renderHavingClause :: HavingClause relations grouping params -> ByteString
765+renderHavingClause = \case
766+ NoHaving -> ""
767+ Having [] -> ""
768+ Having conditions ->
769+ " HAVING" <+> commaSeparated (renderExpression <$> conditions)
1074770
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
771+{-----------------------------------------
772+Sorting
773+-----------------------------------------}
774+
775+-- | `SortExpression`s are used by `sortBy` to optionally sort the results
776+-- of a `Query`. `Asc` or `Desc` set the sort direction of a `NotNull` result
777+-- column to ascending or descending. Ascending order puts smaller values
778+-- first, where "smaller" is defined in terms of the `.<` operator. Similarly,
779+-- descending order is determined with the `.>` operator. `AscNullsFirst`,
780+-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to
781+-- determine whether nulls appear before or after non-null values in the sort
782+-- ordering of a `Null` result column.
783+data SortExpression relations grouping params where
784+ Asc
785+ :: Expression relations grouping params ('NotNull ty)
786+ -> SortExpression relations grouping params
787+ Desc
788+ :: Expression relations grouping params ('NotNull ty)
789+ -> SortExpression relations grouping params
790+ AscNullsFirst
791+ :: Expression relations grouping params ('Null ty)
792+ -> SortExpression relations grouping params
793+ AscNullsLast
794+ :: Expression relations grouping params ('Null ty)
795+ -> SortExpression relations grouping params
796+ DescNullsFirst
797+ :: Expression relations grouping params ('Null ty)
798+ -> SortExpression relations grouping params
799+ DescNullsLast
800+ :: Expression relations grouping params ('Null ty)
801+ -> SortExpression relations grouping params
802+deriving instance Show (SortExpression relations grouping params)
803+
804+-- | Render a `SortExpression`.
805+renderSortExpression :: SortExpression relations grouping params -> ByteString
806+renderSortExpression = \case
807+ Asc expression -> renderExpression expression <+> "ASC"
808+ Desc expression -> renderExpression expression <+> "DESC"
809+ AscNullsFirst expression -> renderExpression expression
810+ <+> "ASC NULLS FIRST"
811+ DescNullsFirst expression -> renderExpression expression
812+ <+> "DESC NULLS FIRST"
813+ AscNullsLast expression -> renderExpression expression <+> "ASC NULLS LAST"
814+ DescNullsLast expression -> renderExpression expression <+> "DESC NULLS LAST"
squeal-postgresql/src/Squeal/PostgreSQL/Render.hs+6−76
@@ -9,11 +9,7 @@ Rendering helper functions.
99-}
1010
1111{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , FlexibleContexts
15− , LambdaCase
16− , MagicHash
12+ MagicHash
1713 , OverloadedStrings
1814 , PolyKinds
1915 , RankNTypes
@@ -23,67 +19,35 @@ Rendering helper functions.
2319
2420module Squeal.PostgreSQL.Render
2521 ( -- * Render
26− RenderSQL (..)
27− , printSQL
28− , escape
29− , parenthesized
30− , bracketed
22+ parenthesized
3123 , (<+>)
3224 , commaSeparated
33− , doubleQuoted
34− , singleQuotedText
35− , singleQuotedUtf8
3625 , renderCommaSeparated
37− , renderCommaSeparatedConstraint
3826 , renderCommaSeparatedMaybe
3927 , renderNat
40− , renderSymbol
4128 ) where
4229
43−import Control.Monad.IO.Class (MonadIO (..))
4430import Data.ByteString (ByteString)
45−import Data.Maybe (catMaybes)
31+import Data.Maybe
4632import Data.Monoid ((<>))
47−import Data.Text (Text)
4833import Generics.SOP
4934import GHC.Exts
50−import GHC.TypeLits hiding (Text)
35+import GHC.TypeLits
5136
52−import qualified Data.Text as Text
53−import qualified Data.Text.Encoding as Text
5437import qualified Data.ByteString as ByteString
55−import qualified Data.ByteString.Char8 as Char8
5638
5739-- | Parenthesize a `ByteString`.
5840parenthesized :: ByteString -> ByteString
5941parenthesized str = "(" <> str <> ")"
6042
61−-- | Square bracket a `ByteString`
62−bracketed :: ByteString -> ByteString
63−bracketed str = "[" <> str <> "]"
64−
6543-- | Concatenate two `ByteString`s with a space between.
6644(<+>) :: ByteString -> ByteString -> ByteString
67−infixr 7 <+>
6845str1 <+> str2 = str1 <> " " <> str2
6946
7047-- | Comma separate a list of `ByteString`s.
7148commaSeparated :: [ByteString] -> ByteString
7249commaSeparated = ByteString.intercalate ", "
7350
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−
8751-- | Comma separate the renderings of a heterogeneous list.
8852renderCommaSeparated
8953 :: SListI xs
@@ -94,16 +58,6 @@ renderCommaSeparated render
9458 . hcollapse
9559 . hmap (K . render)
9660
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−
10761-- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping
10862-- `Nothing`s.
10963renderCommaSeparatedMaybe
@@ -117,29 +71,5 @@ renderCommaSeparatedMaybe render
11771 . hmap (K . render)
11872
11973-- | 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]
74+renderNat :: KnownNat n => proxy n -> ByteString
75+renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+348−375
@@ -1,118 +1,118 @@
11{-|
22Module: Squeal.PostgreSQL.Schema
33Description: Embedding of PostgreSQL type and alias system
4−Copyright: (c) Eitan Chatav, 2019
4+Copyright: (c) Eitan Chatav, 2017
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
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.
8+A type-level DSL for kinds of PostgreSQL types, constraints, and aliases.
129-}
10+
1311{-# LANGUAGE
1412 AllowAmbiguousTypes
1513 , ConstraintKinds
14+ , DataKinds
1615 , DeriveAnyClass
16+ , DeriveDataTypeable
1717 , DeriveGeneric
1818 , FlexibleContexts
1919 , FlexibleInstances
2020 , FunctionalDependencies
2121 , GADTs
22− , LambdaCase
22+ , MagicHash
23+ , MultiParamTypeClasses
2324 , OverloadedStrings
24− , QuantifiedConstraints
25+ , PolyKinds
2526 , RankNTypes
2627 , ScopedTypeVariables
2728 , StandaloneDeriving
2829 , TypeApplications
29− , TypeFamilyDependencies
30+ , TypeFamilies
3031 , TypeInType
3132 , TypeOperators
3233 , UndecidableInstances
33− , UndecidableSuperClasses
3434#-}
3535
3636module Squeal.PostgreSQL.Schema
37− ( -- * Postgres Types
37+ ( -- * Types
3838 PGType (..)
39+ , HasOid (..)
3940 , NullityType (..)
40− , RowType
41− , FromType
42− -- * Schema Types
4341 , ColumnType
4442 , ColumnsType
43+ , RelationType
44+ , NilRelation
45+ , RelationsType
4546 , TableType
46− , SchemumType (..)
47− , IndexType (..)
48− , FunctionType
49− , OperatorType (..)
50− , ReturnsType (..)
51− , SchemaType
52− , SchemasType
53− , Public
47+ , TablesType
48+ , NilTables
49+ -- * Grouping
50+ , Grouping (..)
51+ , GroupedBy
5452 -- * Constraints
5553 , (:=>)
5654 , ColumnConstraint (..)
5755 , TableConstraint (..)
5856 , TableConstraints
59− , Uniquely
60− -- * Enumerated Labels
61− , IsPGlabel (..)
62− , PGlabel (..)
63− -- * Data Definitions
57+ , NilTableConstraints
58+ -- * Aliases
59+ , (:::)
60+ , Alias (Alias)
61+ , renderAlias
62+ , Aliased (As)
63+ , renderAliasedAs
64+ , AliasesOf
65+ , Has
66+ , HasUnique
67+ , IsLabel (..)
68+ , IsQualified (..)
69+ -- * Type Families
70+ , Join
6471 , Create
65− , CreateIfNotExists
66− , CreateOrReplace
6772 , Drop
68− , DropSchemum
69− , DropIfExists
70− , DropSchemumIfExists
7173 , Alter
72− , AlterIfExists
7374 , Rename
74− , RenameIfExists
75− , ConstraintInvolves
76− , DropIfConstraintsInvolve
77− , IsNotElem
78− , AllUnique
79− -- * Type Classifications
75+ , Elem
76+ , In
8077 , PGNum
8178 , PGIntegral
8279 , PGFloating
8380 , PGTypeOf
84− , PGJsonType
85− , PGJsonKey
86− , SamePGType
81+ , SameTypes
8782 , AllNotNull
8883 , NotAllNull
89− -- * Nullifications
9084 , NullifyType
91− , NullifyRow
92− , NullifyFrom
93− -- * Table Conversions
85+ , NullifyRelation
86+ , NullifyRelations
87+ , ColumnsToRelation
88+ , RelationToColumns
9489 , TableToColumns
95− , ColumnsToRow
96− , TableToRow
90+ , TablesToRelations
91+ , RelationsToTables
92+ , ConstraintInvolves
93+ , DropIfConstraintsInvolve
94+ -- * Generics
95+ , SameField
96+ , SameFields
9797 ) where
9898
99−import Control.Category
100−import Data.Kind
101−import Data.Monoid hiding (All)
99+import Control.DeepSeq
100+import Data.ByteString
101+import Data.Monoid
102+import Data.String
103+import Data.Word
102104import Data.Type.Bool
103−import Generics.SOP
105+import Generics.SOP (AllZip)
106+import GHC.Generics (Generic)
107+import GHC.Exts
108+import GHC.OverloadedLabels
104109import GHC.TypeLits
105−import Prelude hiding (id, (.))
106−
107−import Squeal.PostgreSQL.Alias
108−import Squeal.PostgreSQL.List
109−import Squeal.PostgreSQL.Render
110110
111−-- $setup
112−-- >>> import Squeal.PostgreSQL
111+import qualified Generics.SOP.Type.Metadata as Type
113112
114113-- | `PGType` is the promoted datakind of PostgreSQL types.
115114--
115+-- >>> import Squeal.PostgreSQL.Schema
116116-- >>> :kind 'PGbool
117117-- 'PGbool :: PGType
118118data PGType
@@ -123,7 +123,6 @@ data PGType
123123 | PGnumeric -- ^ arbitrary precision numeric type
124124 | PGfloat4 -- ^ single precision floating-point number (4 bytes)
125125 | PGfloat8 -- ^ double precision floating-point number (8 bytes)
126− | PGmoney -- ^ currency amount
127126 | PGchar Nat -- ^ fixed-length character string
128127 | PGvarchar Nat -- ^ variable-length character string
129128 | PGtext -- ^ variable-length character string
@@ -138,16 +137,38 @@ data PGType
138137 | PGinet -- ^ IPv4 or IPv6 host address
139138 | PGjson -- ^ textual JSON data
140139 | 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).
140+ | PGvararray PGType -- ^ variable length array
141+ | PGfixarray Nat PGType -- ^ fixed length array
149142 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
150143
144+-- | The object identifier of a `PGType`.
145+--
146+-- >>> :set -XTypeApplications
147+-- >>> oid @'PGbool
148+-- 16
149+class HasOid (ty :: PGType) where oid :: Word32
150+instance HasOid 'PGbool where oid = 16
151+instance HasOid 'PGint2 where oid = 21
152+instance HasOid 'PGint4 where oid = 23
153+instance HasOid 'PGint8 where oid = 20
154+instance HasOid 'PGnumeric where oid = 1700
155+instance HasOid 'PGfloat4 where oid = 700
156+instance HasOid 'PGfloat8 where oid = 701
157+instance HasOid ('PGchar n) where oid = 18
158+instance HasOid ('PGvarchar n) where oid = 1043
159+instance HasOid 'PGtext where oid = 25
160+instance HasOid 'PGbytea where oid = 17
161+instance HasOid 'PGtimestamp where oid = 1114
162+instance HasOid 'PGtimestamptz where oid = 1184
163+instance HasOid 'PGdate where oid = 1082
164+instance HasOid 'PGtime where oid = 1083
165+instance HasOid 'PGtimetz where oid = 1266
166+instance HasOid 'PGinterval where oid = 1186
167+instance HasOid 'PGuuid where oid = 2950
168+instance HasOid 'PGinet where oid = 869
169+instance HasOid 'PGjson where oid = 114
170+instance HasOid 'PGjsonb where oid = 3802
171+
151172-- | `NullityType` encodes the potential presence or definite absence of a
152173-- @NULL@ allowing operations which are sensitive to such to be well typed.
153174--
@@ -166,6 +187,14 @@ data NullityType
166187type (:=>) constraint ty = '(constraint,ty)
167188infixr 7 :=>
168189
190+-- | The alias operator `:::` is like a promoted version of `As`,
191+-- a type level pair between
192+-- an alias and some type, like a column alias and either a `ColumnType` or
193+-- `NullityType` or a table alias and either a `TableType` or a `RelationType`
194+-- or a constraint alias and a `TableConstraint`.
195+type (:::) (alias :: Symbol) ty = '(alias,ty)
196+infixr 6 :::
197+
169198-- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates.
170199-- A column can be assigned a default value.
171200-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also
@@ -207,23 +236,11 @@ data TableConstraint
207236 | PrimaryKey [Symbol]
208237 | ForeignKey [Symbol] Symbol [Symbol]
209238
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−-}
239+-- | A `TableConstraints` is a row of `TableConstraint`s.
217240type 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
241+-- | A monokinded empty `TableConstraints`.
242+type family NilTableConstraints :: TableConstraints where
243+ NilTableConstraints = '[]
227244
228245-- | `TableType` encodes a row of constraints on a table as well as the types
229246-- of its columns.
@@ -238,233 +255,302 @@ type family Uniquely
238255-- :}
239256type TableType = (TableConstraints,ColumnsType)
240257
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)]
258+-- | `TablesType` is a row of `TableType`s, thought of as a union.
259+--
260+-- >>> :{
261+-- type family Schema :: TablesType where
262+-- Schema =
263+-- '[ "users" :::
264+-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
265+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
266+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext
267+-- , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2)
268+-- ]
269+-- , "emails" :::
270+-- '[ "pk_emails" ::: 'PrimaryKey '["id"]
271+-- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
272+-- ] :=>
273+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
274+-- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
275+-- , "email" ::: 'NoDef :=> 'Null 'PGtext
276+-- ]
277+-- ]
278+-- :}
279+type TablesType = [(Symbol,TableType)]
280+-- | A monokinded empty `TablesType`.
281+type family NilTables :: TablesType where NilTables = '[]
254282
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 '[] = '[]
283+-- | `RelationType` is a row of `NullityType`
284+--
285+-- >>> :{
286+-- type family PersonRelation :: RelationType where
287+-- PersonRelation =
288+-- '[ "name" ::: 'NotNull 'PGtext
289+-- , "age" ::: 'NotNull 'PGint4
290+-- , "dateOfBirth" ::: 'Null 'PGdate
291+-- ]
292+-- :}
293+type RelationType = [(Symbol,NullityType)]
294+-- | A monokinded empty `RelationType`.
295+type family NilRelation :: RelationType where NilRelation = '[]
276296
277−-- | `TableToColumns` removes table constraints.
278−type family TableToColumns (table :: TableType) :: ColumnsType where
279− TableToColumns (constraints :=> columns) = columns
297+-- | `RelationsType` is a row of `RelationType`s, thought of as a product.
298+type RelationsType = [(Symbol,RelationType)]
280299
281−-- | Convert a table to a row type.
282−type family TableToRow (table :: TableType) :: RowType where
283− TableToRow tab = ColumnsToRow (TableToColumns tab)
300+-- | `ColumnsToRelation` removes column constraints.
301+type family ColumnsToRelation (columns :: ColumnsType) :: RelationType where
302+ ColumnsToRelation '[] = '[]
303+ ColumnsToRelation (column ::: constraint :=> ty ': columns) =
304+ column ::: ty ': ColumnsToRelation columns
284305
285−-- | Numeric Postgres types.
286−type PGNum =
287− '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
306+-- | `RelationToColumns` adds `'NoDef` column constraints.
307+type family RelationToColumns (relation :: RelationType) :: ColumnsType where
308+ RelationToColumns '[] = '[]
309+ RelationToColumns (column ::: ty ': columns) =
310+ column ::: 'NoDef :=> ty ': RelationToColumns columns
288311
289−-- | Floating Postgres types.
290−type PGFloating = '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]
312+-- | `TableToColumns` removes table constraints.
313+type family TableToColumns (table :: TableType) :: ColumnsType where
314+ TableToColumns (constraints :=> columns) = columns
291315
292−-- | Integral Postgres types.
293−type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8]
316+-- | `TablesToRelations` removes both table and column constraints.
317+type family TablesToRelations (tables :: TablesType) :: RelationsType where
318+ TablesToRelations '[] = '[]
319+ TablesToRelations (alias ::: constraint :=> columns ': tables) =
320+ alias ::: ColumnsToRelation columns ': TablesToRelations tables
321+
322+-- | `RelationsToTables` adds both trivial table and column constraints.
323+type family RelationsToTables (tables :: RelationsType) :: TablesType where
324+ RelationsToTables '[] = '[]
325+ RelationsToTables (alias ::: columns ': relations) =
326+ alias ::: '[] :=> RelationToColumns columns ': RelationsToTables relations
327+
328+-- | `Grouping` is an auxiliary namespace, created by
329+-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
330+-- for typesafe aggregation
331+data Grouping
332+ = Ungrouped -- ^ no aggregation permitted
333+ | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped
334+
335+{- | A `GroupedBy` constraint indicates that a table qualified column is
336+a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,
337+may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.
338+-}
339+class (KnownSymbol relation, KnownSymbol column)
340+ => GroupedBy relation column bys where
341+instance {-# OVERLAPPING #-} (KnownSymbol relation, KnownSymbol column)
342+ => GroupedBy relation column ('(table,column) ': bys)
343+instance {-# OVERLAPPABLE #-}
344+ ( KnownSymbol relation
345+ , KnownSymbol column
346+ , GroupedBy relation column bys
347+ ) => GroupedBy relation column (tabcol ': bys)
348+
349+-- | `Alias`es are proxies for a type level string or `Symbol`
350+-- and have an `IsLabel` instance so that with @-XOverloadedLabels@
351+--
352+-- >>> :set -XOverloadedLabels
353+-- >>> #foobar :: Alias "foobar"
354+-- Alias
355+data Alias (alias :: Symbol) = Alias
356+ deriving (Eq,Generic,Ord,Show,NFData)
357+instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
358+ fromLabel = Alias
359+
360+-- | >>> renderAlias #jimbob
361+-- "jimbob"
362+renderAlias :: KnownSymbol alias => Alias alias -> ByteString
363+renderAlias = fromString . symbolVal
364+
365+-- | The `As` operator is used to name an expression. `As` is like a demoted
366+-- version of `:::`.
367+--
368+-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)
369+-- As (Just "hello") Alias
370+data Aliased expression aliased where
371+ As
372+ :: KnownSymbol alias
373+ => expression ty
374+ -> Alias alias
375+ -> Aliased expression (alias ::: ty)
376+deriving instance Show (expression ty)
377+ => Show (Aliased expression (alias ::: ty))
378+deriving instance Eq (expression ty)
379+ => Eq (Aliased expression (alias ::: ty))
380+deriving instance Ord (expression ty)
381+ => Ord (Aliased expression (alias ::: ty))
382+
383+-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")
384+-- >>> renderAliasedAs renderMaybe (Just (3::Int) `As` #an_int)
385+-- "Just AS an_int"
386+renderAliasedAs
387+ :: (forall ty. expression ty -> ByteString)
388+ -> Aliased expression aliased
389+ -> ByteString
390+renderAliasedAs render (expression `As` alias) =
391+ render expression <> " AS " <> renderAlias alias
392+
393+-- | `AliasesOf` retains the AliasesOf in a row.
394+type family AliasesOf aliaseds where
395+ AliasesOf '[] = '[]
396+ AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys
397+
398+-- | @HasUnique alias fields field@ is a constraint that proves that
399+-- @fields@ is a singleton of @alias ::: field@.
400+type HasUnique alias fields field = fields ~ '[alias ::: field]
401+
402+-- | @Has alias fields field@ is a constraint that proves that
403+-- @fields@ has a field of @alias ::: field@.
404+class KnownSymbol alias =>
405+ Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
406+ | alias fields -> field where
407+instance {-# OVERLAPPING #-} KnownSymbol alias
408+ => Has alias (alias ::: field ': fields) field
409+instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)
410+ => Has alias (field' ': fields) field
411+
412+-- | Analagous to `IsLabel`, the constraint
413+-- `IsQualified` defines `!` for a column alias qualified
414+-- by a table alias.
415+class IsQualified table column expression where
416+ (!) :: Alias table -> Alias column -> expression
417+ infixl 9 !
418+instance IsQualified table column (Alias table, Alias column) where (!) = (,)
419+
420+-- | @Elem@ is a promoted `Data.List.elem`.
421+type family Elem x xs where
422+ Elem x '[] = 'False
423+ Elem x (x ': xs) = 'True
424+ Elem x (_ ': xs) = Elem x xs
425+
426+-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
427+type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True
428+
429+-- | `PGNum` is a constraint on `PGType` whose
430+-- `Squeal.PostgreSQL.Expression.Expression`s have a `Num` constraint.
431+type PGNum ty =
432+ In ty '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
433+
434+-- | `PGFloating` is a constraint on `PGType` whose
435+-- `Squeal.PostgreSQL.Expression.Expression`s
436+-- have `Fractional` and `Floating` constraints.
437+type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]
438+
439+-- | `PGIntegral` is a constraint on `PGType` whose
440+-- `Squeal.PostgreSQL.Expression.Expression`s
441+-- have `Squeal.PostgreSQL.Expression.div_` and
442+-- `Squeal.PostgreSQL.Expression.mod_` functions.
443+type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]
294444
295445-- | `PGTypeOf` forgets about @NULL@ and any column constraints.
296446type family PGTypeOf (ty :: NullityType) :: PGType where
297447 PGTypeOf (nullity pg) = pg
298448
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)
449+-- | `SameTypes` is a constraint that proves two `ColumnsType`s have the same
450+-- length and the same `ColumnType`s.
451+type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType)
452+ :: Constraint where
453+ SameTypes '[] '[] = ()
454+ SameTypes (column0 ::: def0 :=> ty0 ': columns0) (column1 ::: def1 :=> ty1 ': columns1)
455+ = (ty0 ~ ty1, SameTypes columns0 columns1)
305456
306457-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
307458type 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
314459 AllNotNull '[] = ()
460+ AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns
315461
316462-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
317463-- @NOT NULL@.
318464type 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`.
465+ NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()
466+ NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns
467+
468+-- | `NullifyType` is an idempotent that nullifies a `ColumnType`.
328469type family NullifyType (ty :: NullityType) :: NullityType where
329470 NullifyType ('Null ty) = 'Null ty
330471 NullifyType ('NotNull ty) = 'Null ty
331472
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`
473+-- | `NullifyRelation` is an idempotent that nullifies a `ColumnsType`.
474+type family NullifyRelation (columns :: RelationType) :: RelationType where
475+ NullifyRelation '[] = '[]
476+ NullifyRelation (column ::: ty ': columns) =
477+ column ::: NullifyType ty ': NullifyRelation columns
478+
479+-- | `NullifyRelations` is an idempotent that nullifies a `RelationsType`
349480-- used to nullify the left or right hand side of an outer join
350481-- 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 '[] = '[]
482+type family NullifyRelations (tables :: RelationsType) :: RelationsType where
483+ NullifyRelations '[] = '[]
484+ NullifyRelations (table ::: columns ': tables) =
485+ table ::: NullifyRelation columns ': NullifyRelations tables
486+
487+-- | `Join` is simply promoted `++` and is used in @JOIN@s in
488+-- `Squeal.PostgreSQL.Query.FromClause`s.
489+type family Join xs ys where
490+ Join '[] ys = ys
491+ Join (x ': xs) ys = x ': Join xs ys
365492
366493-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
367494-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
368495-- `Squeal.PostgreSQL.Definition.addColumn`.
369496type family Create alias x xs where
370497 Create alias x '[] = '[alias ::: x]
371− Create alias x (alias ::: y ': xs) = TypeError
372− ('Text "Create: alias "
373− ':<>: 'ShowType alias
374− ':<>: 'Text "already exists")
375498 Create alias y (x ': xs) = x ': Create alias y xs
376499
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−
394500-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
395501-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
396502-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
397503type 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
504+ Drop alias ((alias ::: x) ': xs) = xs
403505 Drop alias (x ': xs) = x ': Drop alias xs
404506
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`
507+-- | @Alter alias xs x@ replaces the type associated with an @alias@ in @xs@
508+-- with the type `x` and is used in `Squeal.PostgreSQL.Definition.alterTable`
439509-- 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
510+type family Alter alias xs x where
511+ Alter alias ((alias ::: x0) ': xs) x1 = (alias ::: x1) ': xs
512+ Alter alias (x0 ': xs) x1 = x0 ': Alter alias xs x1
513+
514+-- type family AddConstraint constraint ty where
515+-- AddConstraint constraint (constraints :=> ty)
516+-- = AsSet (constraint ': constraints) :=> ty
517+
518+-- type family DeleteFromList (e :: elem) (list :: [elem]) where
519+-- DeleteFromList elem '[] = '[]
520+-- DeleteFromList elem (x ': xs) =
521+-- If (Cmp elem x == 'EQ) xs (x ': DeleteFromList elem xs)
522+
523+-- type family DropConstraint constraint ty where
524+-- DropConstraint constraint (constraints :=> ty)
525+-- = (AsSet (DeleteFromList constraint constraints)) :=> ty
452526
453527-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
454528-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
455529-- `Squeal.PostgreSQL.Definition.renameColumn`.
456530type family Rename alias0 alias1 xs where
457− Rename alias0 alias1 '[] = TypeError
458− ('Text "Rename: alias "
459− ':<>: 'ShowType alias0
460− ':<>: 'Text " does not exist" )
461531 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
462532 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
463533
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
534+-- | A `SameField` constraint is an equality constraint on a
535+-- `Generics.SOP.Type.Metadata.FieldInfo` and the column alias in a `:::` pair.
536+class SameField
537+ (fieldInfo :: Type.FieldInfo) (fieldty :: (Symbol,NullityType)) where
538+instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty)
539+
540+-- | A `SameFields` constraint proves that a
541+-- `Generics.SOP.Type.Metadata.DatatypeInfo` of a record type has the same
542+-- field names as the column AliasesOf of a `ColumnsType`.
543+type family SameFields
544+ (datatypeInfo :: Type.DatatypeInfo) (columns :: RelationType)
545+ :: Constraint where
546+ SameFields
547+ ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields])
548+ columns
549+ = AllZip SameField fields columns
550+ SameFields
551+ ('Type.Newtype _module _datatype ('Type.Record _constructor fields))
552+ columns
553+ = AllZip SameField fields columns
468554
469555-- | Check if a `TableConstraint` involves a column
470556type family ConstraintInvolves column constraint where
@@ -481,116 +567,3 @@ type family DropIfConstraintsInvolve column constraints where
481567 = If (ConstraintInvolves column constraint)
482568 (DropIfConstraintsInvolve column constraints)
483569 (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.hs+82−102
@@ -1,7 +1,7 @@
11{-|
22Module: Squeal.PostgreSQL.Transaction
33Description: Squeal transaction control language
4−Copyright: (c) Eitan Chatav, 2019
4+Copyright: (c) Eitan Chatav, 2017
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
@@ -10,9 +10,14 @@ Squeal transaction control language.
1010
1111{-# LANGUAGE
1212 DataKinds
13+ , EmptyCase
1314 , FlexibleContexts
15+ , FlexibleInstances
1416 , LambdaCase
1517 , OverloadedStrings
18+ , MultiParamTypeClasses
19+ , ScopedTypeVariables
20+ , TypeFamilies
1621 , TypeInType
1722#-}
1823
@@ -20,114 +25,89 @@ module Squeal.PostgreSQL.Transaction
2025 ( -- * Transaction
2126 transactionally
2227 , transactionally_
23− , transactionallyRetry
24− , ephemerally
25− , ephemerally_
2628 , begin
2729 , commit
2830 , rollback
31+ , transactionallySchema
32+ , transactionallySchema_
2933 -- * Transaction Mode
3034 , TransactionMode (..)
3135 , defaultMode
3236 , longRunningMode
3337 , IsolationLevel (..)
38+ , renderIsolationLevel
3439 , AccessMode (..)
40+ , renderAccessMode
3541 , DeferrableMode (..)
42+ , renderDeferrableMode
3643 ) where
3744
38−import UnliftIO
45+import Control.Exception.Lifted
46+import Control.Monad.Base
47+import Control.Monad.Trans.Control
48+import Data.ByteString
49+import Data.Monoid
50+import Generics.SOP
51+
52+import qualified Database.PostgreSQL.LibPQ as LibPQ
3953
4054import Squeal.PostgreSQL.Manipulation
4155import Squeal.PostgreSQL.Render
4256import Squeal.PostgreSQL.PQ
57+import Squeal.PostgreSQL.Schema
4358
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−-}
59+-- | Run a schema invariant computation `transactionally`.
5060transactionally
51− :: (MonadUnliftIO tx, MonadPQ schemas tx)
61+ :: (MonadBaseControl IO tx, MonadPQ schema tx)
5262 => TransactionMode
5363 -> tx x -- ^ run inside a transaction
5464 -> tx x
5565transactionally mode tx = mask $ \restore -> do
56− manipulate_ $ begin mode
57− result <- restore tx `onException` (manipulate_ rollback)
58− manipulate_ commit
66+ _ <- begin mode
67+ result <- restore tx `onException` rollback
68+ _ <- commit
5969 return result
6070
61−-- | Run a computation `transactionally_`, in `defaultMode`.
71+-- | Run a schema invariant computation `transactionally_` in `defaultMode`.
6272transactionally_
63− :: (MonadUnliftIO tx, MonadPQ schemas tx)
73+ :: (MonadBaseControl IO tx, MonadPQ schema tx)
6474 => tx x -- ^ run inside a transaction
6575 -> tx x
6676transactionally_ = transactionally defaultMode
6777
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−
12078-- | @BEGIN@ a transaction.
121−begin :: TransactionMode -> Manipulation_ schemas () ()
122−begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode
79+begin :: MonadPQ schema tx => TransactionMode -> tx (K Result NilRelation)
80+begin mode = manipulate . UnsafeManipulation $
81+ "BEGIN" <+> renderTransactionMode mode <> ";"
12382
124−-- | @COMMIT@ a transaction.
125−commit :: Manipulation_ schemas () ()
126−commit = UnsafeManipulation "COMMIT"
83+-- | @COMMIT@ a schema invariant transaction.
84+commit :: MonadPQ schema tx => tx (K Result NilRelation)
85+commit = manipulate $ UnsafeManipulation "COMMIT;"
12786
128−-- | @ROLLBACK@ a transaction.
129−rollback :: Manipulation_ schemas () ()
130−rollback = UnsafeManipulation "ROLLBACK"
87+-- | @ROLLBACK@ a schema invariant transaction.
88+rollback :: MonadPQ schema tx => tx (K Result NilRelation)
89+rollback = manipulate $ UnsafeManipulation "ROLLBACK;"
90+
91+-- | Run a schema changing computation `transactionallySchema`.
92+transactionallySchema
93+ :: MonadBaseControl IO io
94+ => TransactionMode
95+ -> PQ schema0 schema1 io x
96+ -> PQ schema0 schema1 io x
97+transactionallySchema mode u = PQ $ \ conn -> mask $ \ restore -> do
98+ _ <- liftBase . LibPQ.exec (unK conn) $
99+ "BEGIN" <+> renderTransactionMode mode <> ";"
100+ x <- restore (unPQ u conn)
101+ `onException` (liftBase (LibPQ.exec (unK conn) "ROLLBACK"))
102+ _ <- liftBase $ LibPQ.exec (unK conn) "COMMIT"
103+ return x
104+
105+-- | Run a schema changing computation `transactionallySchema_` in `DefaultMode`.
106+transactionallySchema_
107+ :: MonadBaseControl IO io
108+ => PQ schema0 schema1 io x
109+ -> PQ schema0 schema1 io x
110+transactionallySchema_ = transactionallySchema defaultMode
131111
132112-- | The available transaction characteristics are the transaction `IsolationLevel`,
133113-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.
@@ -140,7 +120,7 @@ data TransactionMode = TransactionMode
140120-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
141121-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.
142122defaultMode :: TransactionMode
143−defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable
123+defaultMode = TransactionMode Serializable ReadWrite NotDeferrable
144124
145125-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
146126-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.
@@ -149,12 +129,12 @@ longRunningMode :: TransactionMode
149129longRunningMode = TransactionMode Serializable ReadOnly Deferrable
150130
151131-- | 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)
132+renderTransactionMode :: TransactionMode -> ByteString
133+renderTransactionMode mode =
134+ "ISOLATION LEVEL"
135+ <+> renderIsolationLevel (isolationLevel mode)
136+ <+> renderAccessMode (accessMode mode)
137+ <+> renderDeferrableMode (deferrableMode mode)
158138
159139-- | The SQL standard defines four levels of transaction isolation.
160140-- The most strict is `Serializable`, which is defined by the standard in a paragraph
@@ -185,32 +165,32 @@ data IsolationLevel
185165 = Serializable
186166 -- ^ Dirty read is not possible.
187167 -- Nonrepeatable read is not possible.
188− -- Phantom read is not possible.
168+ -- Phantom read is not possible.
189169 -- Serialization anomaly is not possible.
190170 | RepeatableRead
191171 -- ^ Dirty read is not possible.
192172 -- Nonrepeatable read is not possible.
193− -- Phantom read is not possible.
173+ -- Phantom read is not possible.
194174 -- Serialization anomaly is possible.
195175 | ReadCommitted
196176 -- ^ Dirty read is not possible.
197177 -- Nonrepeatable read is possible.
198− -- Phantom read is possible.
178+ -- Phantom read is possible.
199179 -- Serialization anomaly is possible.
200180 | ReadUncommitted
201181 -- ^ Dirty read is not possible.
202182 -- Nonrepeatable read is possible.
203− -- Phantom read is possible.
183+ -- Phantom read is possible.
204184 -- Serialization anomaly is possible.
205185 deriving (Show, Eq)
206186
207187-- | 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"
188+renderIsolationLevel :: IsolationLevel -> ByteString
189+renderIsolationLevel = \case
190+ Serializable -> "SERIALIZABLE"
191+ ReadCommitted -> "READ COMMITTED"
192+ ReadUncommitted -> "READ UNCOMMITTED"
193+ RepeatableRead -> "REPEATABLE READ"
214194
215195-- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`.
216196-- `ReadWrite` is the default. When a transaction is `ReadOnly`,
@@ -227,10 +207,10 @@ data AccessMode
227207 deriving (Show, Eq)
228208
229209-- | Render an `AccessMode`.
230−instance RenderSQL AccessMode where
231− renderSQL = \case
232− ReadWrite -> "READ WRITE"
233− ReadOnly -> "READ ONLY"
210+renderAccessMode :: AccessMode -> ByteString
211+renderAccessMode = \case
212+ ReadWrite -> "READ WRITE"
213+ ReadOnly -> "READ ONLY"
234214
235215-- | The `Deferrable` transaction property has no effect
236216-- unless the transaction is also `Serializable` and `ReadOnly`.
@@ -246,7 +226,7 @@ data DeferrableMode
246226 deriving (Show, Eq)
247227
248228-- | Render a `DeferrableMode`.
249−instance RenderSQL DeferrableMode where
250− renderSQL = \case
251− Deferrable -> "DEFERRABLE"
252− NotDeferrable -> "NOT DEFERRABLE"
229+renderDeferrableMode :: DeferrableMode -> ByteString
230+renderDeferrableMode = \case
231+ Deferrable -> "DEFERRABLE"
232+ NotDeferrable -> "NOT DEFERRABLE"
squeal-postgresql/test/Doc.hsdeleted−6
@@ -1,6 +0,0 @@
1−module Main (main) where
2−
3−import Test.DocTest
4−
5−main :: IO ()
6−main = doctest [ "-isrc", "src" ]
squeal-postgresql/test/DocTest.hsnew file+18
@@ -0,0 +1,18 @@
1+module Main (main) where
2+
3+import Test.DocTest
4+
5+main :: IO ()
6+main = doctest
7+ [ "-isrc"
8+ , "src/Squeal/PostgreSQL.hs"
9+ , "src/Squeal/PostgreSQL/Binary.hs"
10+ , "src/Squeal/PostgreSQL/Definition.hs"
11+ , "src/Squeal/PostgreSQL/Manipulation.hs"
12+ , "src/Squeal/PostgreSQL/Query.hs"
13+ , "src/Squeal/PostgreSQL/Expression.hs"
14+ , "src/Squeal/PostgreSQL/PQ.hs"
15+ , "src/Squeal/PostgreSQL/Migration.hs"
16+ , "src/Squeal/PostgreSQL/Transaction.hs"
17+ , "src/Squeal/PostgreSQL/Pool.hs"
18+ ]
squeal-postgresql/test/Property.hsdeleted−166
@@ -1,166 +0,0 @@
1−{-# LANGUAGE
2− DataKinds
3− , GADTs
4− , LambdaCase
5− , OverloadedLabels
6− , OverloadedStrings
7− , TypeApplications
8− , TypeOperators
9−#-}
10−
11−module Main (main) where
12−
13−import Control.Monad.Trans
14−import Data.ByteString (ByteString)
15−import Data.ByteString.Char8 (unpack)
16−import Data.Scientific (fromFloatDigits)
17−import Data.Fixed (Fixed(MkFixed), Micro, Pico)
18−import Data.String (IsString(fromString))
19−import Data.Time
20−import Squeal.PostgreSQL hiding (check, defaultMain, Group)
21−import Hedgehog hiding (Range)
22−import qualified Hedgehog.Gen as Gen
23−import qualified Hedgehog.Main as Main
24−import qualified Hedgehog.Range as Range
25−
26−main :: IO ()
27−main = Main.defaultMain [checkSequential roundtrips]
28−
29−roundtrips :: Group
30−roundtrips = Group "roundtrips"
31− [ roundtrip int2 genInt16
32− , roundtrip int4 genInt32
33− , roundtrip int8 genInt64
34− , roundtrip bool Gen.bool
35− , roundtrip numeric genScientific
36− , roundtrip float4 genFloat
37− , roundtrip float8 genDouble
38− , roundtripOn normalizeTimeOfDay time genTimeOfDay
39− -- , roundtrip timetz genTimeWithZone normalizeTimeWithZone
40− , roundtripOn normalizeLocalTime timestamp genLocalTime
41− , roundtrip timestamptz genUTCTime
42− , roundtrip date genDay
43− , roundtrip interval genDiffTime
44− , roundtripOn normalizeIntRange int4range (genRange genInt32)
45− , roundtripOn normalizeIntRange int8range (genRange genInt64)
46− , roundtrip numrange (genRange genScientific)
47− , roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime)
48− , roundtrip tstzrange (genRange genUTCTime)
49− , roundtripOn normalizeIntRange daterange (genRange genDay)
50− ]
51− where
52− genInt16 = Gen.int16 Range.exponentialBounded
53− genInt32 = Gen.int32 Range.exponentialBounded
54− genInt64 = Gen.int64 Range.exponentialBounded
55− genScientific = fromFloatDigits <$> genFloat
56− genPosFloat = Gen.float
57− (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
58− genFloat = Gen.prune $ Gen.choice
59− [ genPosFloat
60− , negate <$> genPosFloat
61− , Gen.element [0,1/0] ]
62− genPosDouble = Gen.double
63− (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
64− genDouble = Gen.prune $ Gen.choice
65− [ genPosDouble
66− , negate <$> genPosDouble
67− , Gen.element [0,1/0] ]
68− genRange gen = do
69− lb <- gen
70− ub <- Gen.filter (lb <) gen
71− Gen.element
72− [ Empty, singleton lb, whole
73− , lb <=..<= ub , lb <=..< ub, lb <..<= ub, lb <..< ub
74− , atLeast lb, moreThan lb, atMost ub, lessThan ub ]
75− genDay = do
76− y <- toInteger <$> Gen.int (Range.constant 2000 2019)
77− m <- Gen.int (Range.constant 1 12)
78− d <- Gen.int (Range.constant 1 28)
79− return $ fromGregorian y m d
80− genDiffTime = secondsToDiffTime . toInteger <$>
81− Gen.int (Range.constant 0 86401)
82− genUTCTime = UTCTime <$> genDay <*> genDiffTime
83− genTimeOfDay = do
84− h <- Gen.int (Range.constant 0 23)
85− m <- Gen.int (Range.constant 0 59)
86− s <- MkFixed . toInteger <$> Gen.int (Range.constant 0 59)
87− return $ TimeOfDay h m s
88− genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
89− -- genTimeZone = Gen.element $ map (read @TimeZone)
90− -- [ "UTC", "UT", "GMT", "EST", "EDT", "CST"
91− -- , "CDT", "MST", "MDT", "PST", "PDT" ]
92− -- genTimeWithZone = (,) <$> genTimeOfDay <*> genTimeZone
93−
94−roundtrip
95− :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)
96− => TypeExpression schemas ('NotNull ty)
97− -> Gen x
98− -> (PropertyName, Property)
99−roundtrip = roundtripOn id
100−
101−roundtripOn
102− :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)
103− => (x -> x)
104− -> TypeExpression schemas ('NotNull ty)
105− -> Gen x
106− -> (PropertyName, Property)
107−roundtripOn norm ty gen = propertyWithName $ do
108− x <- forAll gen
109− Just (Only y) <- lift . withConnection connectionString $
110− firstRow =<< runQueryParams
111− (values_ (parameter @1 ty `as` #fromOnly)) (Only x)
112− norm x === y
113− where
114− propertyWithName prop =
115− (fromString (unpack (renderSQL ty)), property prop)
116−
117−maxPosFloat :: RealFloat a => a
118−maxPosFloat = x
119− where
120− n = floatDigits x
121− b = floatRadix x
122− (_, u) = floatRange x
123− x = encodeFloat (b^n - 1) (u - n)
124−
125−minPosFloat :: RealFloat a => a
126−minPosFloat = x
127− where
128− n = floatDigits x
129− b = floatRadix x
130− (l, _) = floatRange x
131− x = encodeFloat (b^n - 1) (l - n - 1)
132−
133−connectionString :: ByteString
134−connectionString = "host=localhost port=5432 dbname=exampledb"
135−
136−normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int
137−normalizeIntRange = \case
138− Empty -> Empty
139− NonEmpty l u ->
140− let
141− l' = normalizeL l
142− u' = normalizeU u
143− in if emptyNormalized l' u' then Empty else NonEmpty l' u'
144− where
145− normalizeL = \case
146− Open l -> Closed (succ l)
147− normalized -> normalized
148− normalizeU = \case
149− Closed u -> Open (succ u)
150− normalized -> normalized
151− emptyNormalized (Closed l) (Open u) = l >= u
152− emptyNormalized _ _ = False
153−
154−normalizeTimeOfDay :: TimeOfDay -> TimeOfDay
155−normalizeTimeOfDay (TimeOfDay h m s) = TimeOfDay h m
156− . fromRational @Pico
157− . toRational @Micro
158− . fromRational @Micro
159− . toRational @Pico
160− $ s
161−
162−normalizeLocalTime :: LocalTime -> LocalTime
163−normalizeLocalTime (LocalTime d t) = LocalTime d (normalizeTimeOfDay t)
164−
165−-- normalizeTimeWithZone :: (TimeOfDay, TimeZone) -> (TimeOfDay, TimeZone)
166−-- normalizeTimeWithZone (t, z) = (normalizeTimeOfDay t, z)
squeal-postgresql/test/Spec.hsdeleted−136
@@ -1,136 +0,0 @@
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.mddeleted−794
@@ -1,794 +0,0 @@
1−# Squeal
2−
3−_A bridge between SQL and Haskell_
4−
5−by [@Raveline](https://github.com/raveline)
6−
7−---
8−
9−# Rationale
10−
11−Using `postgresql-simple` you have a typical "Trial, error, despair" workflow:
12−
13−- Write query manually or semi-automatically
14−
15−- Write haskell code using the query
16−
17−- Pray that the query syntax is correct
18−
19−- Pray that it returns what you want
20−
21−- Realize the inefficiency of prayer when it comes to SQL
22−
23−- Iterate till it works
24−
25−---
26−
27−![Can't take this anymore](http://gif.eraveline.eu/static/img/0x16e.gif)
28−
29−---
30−
31−# Use your best friend: GHC
32−
33−Squeal provides several eDSL to make your SQL typesafe:
34−
35−- Type level eDSL to express schema;
36−
37−- Value level eDSL to manipulate schema (plus migration, yeehaw !);
38−
39−- Type level eDSL to express queries;
40−
41−- Value level eDSL to perform queries
42−
43−However, it's not an ORM. There's no caching, lazy loading - you retain control over your memory. Also, joins - and mostly aggregation after joins - have to be handled manually.
44−
45−---
46−
47−# Part I. Schema & migration
48−
49−---
50−
51−# The Schema
52−
53−- The schema will be used to validate _everything_: migration, queries, etc.
54−
55−- A schema is mostly a collection of tables.
56−
57−- In this presentation, we will create a very basic database modeling a parliament. We will store _members of parliament_ and _parliamentary groups_.
58−
59−- A simple Schema to represent a Parliament could be:
60−
61−```haskell
62−type Schema = '[ "mp" ::: 'Table MemberOfParliament
63− , "groupp" ::: 'Table ParliamentGroup ]
64−```
65−
66−---
67−
68−> _note_ We need the `DataKinds` extension to be able to express heterogenous lists containing
69−> specific types like this one.
70−
71−> You can perfectly call your table "group" and not "groupp" even though it is a
72−> keyword in SQL - Squeal queries will be properly escaped.
73−
74−---
75−
76−# A small example
77−
78−```haskell
79−type ParliamentaryGroup =
80− '[ "pk_groupp" ::: 'PrimaryKey '["groupp_id"]]
81− :=>
82− '[ "groupp_id" ::: 'NoDef :=> 'NotNull 'PGuuid
83− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
84− ]
85−```
86−
87−- That's a whole simple table defined in one go.
88−
89−- `:::` lets us define a column or a constraint.
90−
91−- `:=>` associates the constraints to the column.
92−
93−- Let's split constraints and column to study the syntax a bit more.
94−
95−---
96−
97−> _note_ We are using `:::` and `:=>` to quickly express associations when writing
98−> our schema. We need the `TypeOperators` extension.]
99−
100−---
101−
102−![What does this means ?!](http://gif.eraveline.eu/static/img/0x27e.gif)
103−
104−---
105−
106−# Defining a table
107−
108−```haskell
109−type MemberOfParliament =
110− '[ "pk_mp" ::: 'PrimaryKey '["mp_id"]
111− , "fk_mp_groupp" ::: 'ForeignKey '["mp_group"] "groupp" '["groupp_id"]
112− ] :=> MpCols
113−```
114−
115−- A table is a collection of constraints associated to a collection of columns.
116−
117−- We defined a table named "mp".
118−
119−- It has a constraint named "pk_mp", defining its primary key on column "mp_id".
120−
121−- It has a constraint named "fk_mp_groupp" defining a foreign key on column "mg_group", connected to the column "groupp_id" of table "groupp".
122−
123−- These constraints will be associated to the columns defined in `MpCols`.
124−
125−---
126−
127−# Defining columns
128−
129−```haskell
130−type MpCols =
131− '[ "mp_id" ::: 'NoDef :=> 'NotNull 'PGuuid
132− , "first_name" ::: 'NoDef :=> 'NotNull 'PGtext
133− , "last_name" ::: 'NoDef :=> 'NotNull 'PGtext
134− ]
135−```
136−
137−- A listing of column associate, for each element:
138−
139− * a name;
140−
141− * the mention of an eventual default value;
142−
143− * the nullability;
144−
145− * the type (obviously).
146−
147−---
148−
149−> _note_ GHC is already helping. If I named the "mp_id" column differently,
150−> GHC would yell because I promised a primary key constraint on a column named `mp_id`, so there must be one.]
151−
152−---
153−
154−# Implementating the schema
155−
156−- We will carry this schema type pretty much everywhere.
157−
158−- But before we play with this schema, we need to implement it.
159−
160−---
161−
162−```haskell
163−setup :: Definition '[] Schema
164−setup =
165− createTable #groupp
166− ( notNullable uuid `as` #groupp_id
167− :* notNullable text `as` #name)
168− ( primaryKey #groupp_id `as` #pk_groupp )
169− >>> createTable #mp
170− ( notNullable uuid `as` #mp_id
171− :* notNullable text `as` #first_name
172− :* notNullable text `as` #last_name
173− :* notNullable text `as` #mp_group)
174− ( primaryKey #mp_id `as` #pk_mp
175− :* foreignKey #mp_group #groupp #groupp_id
176− OnDeleteCascade OnUpdateCascade
177− `as` #fk_mp_groupp)
178−```
179−
180−---
181−
182−# Damn, that's verbose
183−
184−- Yes. But you need verbosity to get type safety.
185−
186−- On the plus side, it's fairly straightforward.
187−
188−- You use `:*` to compose the element of the heterogenous list of columns.
189−
190−- You use `>>>` to compose table creation.
191−
192−> _note_ The compiler will catch any mistype between Schema and
193−> definition; wrong nullability, wrong type, wrong name, etc.
194−
195−---
196−
197−> _note_ You'll also need `OverloadedLabels`, for naming stuff.
198−> This is mostly to avoid having to write manual proxies all
199−> the time and for convenience.
200−
201−---
202−
203−# Setting up the schema
204−
205−- Squeal comes with a very good migration manager, handling _upgrades_ AND
206−_downgrades_.
207−
208−- A migration is a simple type:
209−
210−```haskell
211−Migration io schema0 schema1
212−```
213−
214−- The first parameter is a BaseMonad (typically, IO).
215−
216−- The second parameter is "the current schema of your DB".
217−
218−- The last one is "what you will migrate to".
219−
220−- The `Definition` type used to define upgrade and downgrade functions use the
221− same logic (from one schema to the other).
222−
223−---
224−
225−# Defining our first migration
226−
227−- We have the setup bit, we need the teardown:
228−
229−```haskell
230−tearDown :: Definition Schema '[]
231−tearDown = dropTable #mp >>> dropTable #groupp
232−```
233−
234−> _note_ GHC will also detect the _proper_ order of what you typed in
235−> downgrade and upgrade should there be any conflict (with foreign keys).
236−
237−```haskell
238−initDB :: Migration IO '[] Schema
239−initDB =
240− Migration { name = "Schema creation"
241− , up = void $ define setup
242− , down = void $ define tearDown }
243−```
244−
245−---
246−
247−# Simple migrator example
248−
249−```haskell
250−main :: IO ()
251−main = do
252− printSQL setup
253− void $ withConnection connectionString $
254− migrateUp $ single initDB
255−```
256−
257−- We print the migration query; you can do this for all queries generated through Squeal.
258−
259−- We use `migrateUp` to perform the migration.
260−
261−- You can run several migration at the same time, to run only one use `single`.
262−
263−---
264−
265−![That was easy](http://gif.eraveline.eu/static/img/0x47f.gif)
266−
267−---
268−
269−# Part II. Insertions
270−
271−---
272−
273−# Manipulations & Queries
274−
275−Besides the specific case of migration, you will mostly perform:
276−
277−- `Manipulation` : inserting, updating and deleting data.
278−
279−- `Query` : fetching data.
280−
281−- Both types are parametric over the same things:
282−
283− * A schema
284−
285− * Input parameters
286−
287− * Output
288−
289−- Simplified, they look like this:
290−
291−```haskell
292−Manipulation schema params columns
293−
294−Query schema params columns
295−```
296−
297−
298−---
299−
300−# Our Haskell model
301−
302−```haskell
303−type Parliament = [Group]
304−
305−data Group =
306− Group { name :: Text
307− , members :: [MemberOfParliament] }
308−
309−data MemberOfParliament =
310− MemberOfParliament { firstName :: Text
311− , lastName :: Text }
312−```
313−
314−> _note_ We didn't use anything from Squeal.
315−> The model can be entirely separated from the persistence layer.
316−
317−---
318−
319−# Inserting a Parliamentary Group
320−
321−- A group is very simple: it's a uuid and a name. Let's define our params:
322−
323−```haskell
324−type GroupInsertionParams = '[ 'NotNull 'PGuuid
325− , 'NotNull 'PGtext ]
326−```
327−
328−- Params are not named, but they are indexed. You just need nullability and type.
329−
330−---
331−
332−```haskell
333−groupInsertion :: Manipulation Schema GroupInsertionParams '[]
334−groupInsertion =
335− insertRow_ #groupp ( Set (param @1) `as` #groupp_id
336− :* Set (param @2) `as` #name )
337−```
338−
339−---
340−
341−- `TypeApplication` lets us use the index of parameters (counting from 1).
342−
343−- Once again: all this is checked by the compiler. Wrong name, wrong type... you'll get a compile error.
344−
345−- `insertRow_` is a simplified version of `insertRow`. `insertRow` lets you express a `RETURNING` clause and the expected behaviour in case of conflict.
346−
347−---
348−
349−_Inserting a Member of Parliament_
350−# Doing an INSERT INTO ... SELECT
351−
352−- We could create a naive query that takes MP uuid, first name, last name and group uuid...
353−
354−---
355−
356−- But that's boring. So let's use the `INSERT INTO ... SELECT`.
357−
358−---
359−
360−- We will build a query that will return as constants our MP's uuid, first name and last name...
361−
362−---
363−
364−- ... and fetch the uuid of a group given the name of the group.
365−
366−---
367−
368−- There's a `insertQuery` utility function for that. All we have to do is write the `select` !
369−
370−```haskell
371−mpInsertion :: Manipulation Schema MpParams '[]
372−mpInsertion =
373− insertQuery_ #mp selectGroup -- we just have to write selectGroup !
374−```
375−
376−---
377−
378−_Inserting a Member of Parliament_
379−# The query type
380−
381−- A query looks just like a `Manipulation`:
382−
383−```haskell
384−Query schema params returns
385−```
386−
387−- Returns use a special syntax, that demands names, nullability and types:
388−
389−```haskell
390−type ExampleReturnType = '[ "some_column" ::: 'NotNull 'PGuuid
391− , "other_column" ::: 'Null 'PGtext ]
392−```
393−
394−- It is not the same as the column definition we used in the schema. That one also expects that you specify, for each column, an eventual default:
395−
396−```haskell
397−type ExampleSchemaCols =
398− '[ "some_column" ::: 'NoDef :=> 'NotNull 'PGuuid
399− , "other_column" ::: 'NoDef :=> 'Null 'PGtext ]
400−```
401−
402−---
403−
404−_Inserting a Member of Parliament_
405−# Don't rewrite column definitions
406−
407−- We want our return type to be "all columns from table MP expressed as return type".
408−
409−- But we cannot reuse our neat `MpCols` alias, since the type do not match as we've just seen.
410−
411−- Hopefully, there's a neat Type Family that will let you convert any table you defined to the type of the equivalent row: `TableToRow`.
412−
413−- We finally have the signature for our SELECT query.
414−
415−```haskell
416−selectGroup :: Query Schema MpParams (TableToRow MemberOfParliament)
417−```
418−
419−---
420−
421−_Inserting a Member of Parliament_
422−# Our final Select query
423−
424−- Our intermediate query looks like this:
425−
426−```haskell
427−selectGroup =
428− select
429− ( param @1 `as` #mp_id
430− :* param @2 `as` #first_name
431− :* param @3 `as` #last_name
432− :* #groupp ! #groupp_id `as` #mp_group
433− )
434− ( from (table #groupp)
435− & where_ ( #groupp ! #name .== param @4 )
436− )
437−```
438−
439−- The first three columns are constant defined through our params;
440−
441−- ... we alias the column name using `as`...
442−
443−- ... and when we need the result from the table we use the `#table ! #column` syntax.
444−
445−- We'll go back to the "from" block later.
446−
447−---
448−
449−# Dealing with the connection context
450−
451−- Queries are runned in a connection context:
452−
453− * When dealing with a single-connection context, use the type `PQ`.
454−
455− * When dealing with a pool of connection, use the type `PoolPQ`.
456−
457−- Or get rid of the context and use `mtl` style, with the typeclass `MonadPQ`.
458−
459−- We'll use that to demonstrate how to actually run our queries.
460−
461−---
462−
463−# Inserting a whole group
464−
465−```haskell
466−insertGroup :: (MonadPQ Schema m, MonadBaseControl IO m) => Group -> m ()
467−insertGroup g@(Group name _) = do
468− uuid' <- liftBase nextRandom
469− void $ manipulateParams groupInsertion (uuid', name)
470− insertMps g
471−```
472−
473−- Remember that we defined a group as a name and a list of MPs.
474−
475−- We are in `MonadBaseControl`, so we cannot use `liftIO`, we need `liftBase`.
476−
477−- To perform a simple insertion, use `manipulateParams`. It takes into parameter
478−instances of `ToParam`, but you will typically use tuples or Generic-SOP.
479−
480−---
481−
482−# Inserting a bunch of MPs
483−
484−```haskell
485−insertMps :: (MonadPQ Schema m, MonadBaseControl IO m) => Group -> m ()
486−insertMps (Group groupName mps) =
487− let tuplify Mp{..} = (, firstName, lastName, groupName) <$> nextRandom
488− params = traverse tuplify mps
489− in void $ liftBase params >>= traversePrepared mpInsertion
490−```
491−
492−- This time, we want to do a `preparedStatement`. We'll use `traversePrepare`
493−which behaves like `manipulateParams`, but expect a list of `ToParam`
494−instances.
495−
496−- We build our tuple manually again, mostly because we want to generate UUID on
497−the fly and we don't want to have them in our model.
498−
499−---
500−
501−# Inserting a whole parliament
502−
503−```haskell
504−insertParliament ::
505− (MonadPQ Schema m, MonadBaseControl IO m) => Parliament -> m ()
506−insertParliament = traverse_ insertGroup
507−```
508−
509−- That's simple enough !
510−
511−- If we want to be a bit safer, though, we can wrap this call in a
512−`transactionally_` function, which will put all that in a transaction.
513−
514−---
515−
516−![Very simple](https://media1.tenor.com/images/0188c63209aced59f1583e1ca94e509e/tenor.gif?itemid=3550689)
517−
518−
519−---
520−
521−# Part III. Selects
522−
523−---
524−
525−# Composable queries
526−
527−- Building basic queries is easy, and is well documented.
528−
529−- However, the real interest of a tool like Squeal is in DRYness, and the documentation is still lacking in "how-to" related to composability.
530−
531−- I'll build an example showing how column selections and from clause can be factorized.
532−
533−- We want to write two queries:
534−
535− * One to get all members of a specific group.
536−
537− * One to get all the parliament.
538−
539−---
540−
541−# Decomposing a `Query`
542−
543−- A query typically stars with `select` (variants are available).
544−
545−- It then takes:
546−
547− * A heterogenous list of fields with a scary signature;
548−
549− * A virtual table (the from clause and filter clauses), called a `TableExpression`.
550−
551−- And return fields. Ours will look like this:
552−
553−```haskell
554−type GroupRowResult =
555− '[ "groupName" ::: 'NotNull 'PGtext
556− , "firstName" ::: 'NotNull 'PGtext
557− , "lastName" ::: 'NotNull 'PGtext ]
558−```
559−
560−---
561−
562−# The Table Expression
563−
564−- It necessarily contains a `fromClause` (table, view or subquery, plus optional joins).
565−
566−- You can add where, groups, "HAVING" clause, order, etc.
567−
568−- `from` creates a basic `TableExpression` that you extend through various function to add clauses.
569−
570−- For our queries, we will share a common `FromClause`.
571−
572−---
573−
574−# The From Clause
575−
576−```
577−FromClause schema params from
578−```
579−
580−- We need Schema, input parameters and a `FromType` giving the available fields of the expression.
581−
582−- In our case, we'll join the table `mp` and the table `groupp`, meaning the `from` will be all fields of these tables.
583−
584−- We can use `TableToRow` to be more DRY:
585−
586−```haskell
587−type BaseParliamentSelection =
588− '[ "g" ::: TableToRow GroupCols
589− , "m" ::: TableToRow MpCols ]
590−```
591−
592−> _note_ We've also put everything with table aliases: "g" and "m".
593−
594−---
595−
596−# Writing our from clause
597−
598−```haskell
599−baseParliamentTables ::
600− FromClause Schema (param :: [NullityType]) BaseParliamentSelection
601−baseParliamentTables =
602− table
603− (#groupp `as` #g)
604− & innerJoin
605− (table (#mp `as` #m))
606− (#m ! #mp_group .== #g ! #groupp_id)
607−```
608−
609−- When picking "from" something, you need to specify the type with a function: `table` for a table, `view` for a view, etc.
610−
611−- All joins are available. `innerJoin` is the most basic one. It takes the joined table and the joining condition.
612−
613−- We have to specifiy the type of `param` (current limitation of the lib), even though _any_ params will be compatible with this, so we can plug `where` clauses depending on params should we need to !
614−
615−---
616−
617−# Typing the common selection
618−
619−- Both our querie will need the same fields. This has to be factorized too.
620−
621−- The scary signature of selection fields:
622−
623−```haskell
624−NP (Aliased (Expression schema from grouping params)) cols
625−```
626−
627−- `NP` is for heterogenous lists ("n-ary product").
628−
629−- `from` is the virtual table type, so our `BaseParliamentSelection`.
630−
631−- `grouping` is there to make a distinction between aggregated / unaggregated queries.
632−
633−- And finally, cols is the return type.
634−
635−---
636−
637−# Our common selection
638−
639−```haskell
640−groupSelection ::
641− NP (Aliased (Expression Schema BaseParliamentSelection 'Ungrouped param))
642− GroupRowResult
643−groupSelection =
644− #g ! #name `as` #groupName
645− :* #m ! #first_name `as` #firstName
646− :* #m ! #last_name `as` #lastName
647−```
648−
649−- I hope you like big signatures.
650−
651−- But it's what let GHC checks that all alias and columns are available.
652−
653−- And that you're returning what you really intend to return.
654−
655−---
656−
657−# Putting it all together
658−
659−```haskell
660−selectParliament :: Query Schema '[] GroupRowResult
661−selectParliament =
662− select groupSelection (from baseParliamentTables)
663−```
664−
665−```haskell
666−selectGroupMembers :: Query Schema '[ 'NotNull 'PGtext] GroupRowResult
667−selectGroupMembers =
668− select groupSelection
669− (from baseParliamentTables
670− & where_ (#g ! #name .== param @1))
671−```
672−
673−- That is fairly DRY. And _entirely typesafe_.
674−
675−---
676−
677−# Actually fetching the data
678−
679−- We'll build an intermediary datatype representing our rows.
680−
681−- We'll make it match our row.
682−
683−- And we'll add generic-SOP so that we can build them from query results.
684−
685−```haskell
686−type GroupRowResult =
687− '[ "groupName" ::: 'NotNull 'PGtext
688− , "firstName" ::: 'NotNull 'PGtext
689− , "lastName" ::: 'NotNull 'PGtext ]
690−```
691−
692−```haskell
693−data GroupRow =
694− GroupRow { groupName :: Text
695− , firstName :: Text
696− , lastName :: Text }
697− deriving (Generic)
698−
699−instance SOP.Generic GroupRow
700−instance SOP.HasDatatypeInfo GroupRow
701−```
702−
703−---
704−
705−# Aggregate result logic
706−
707−- We will get tabular, SQL data.
708−
709−- Our results will be `[GroupRow]`.
710−
711−- We'll build `Groups` from this:
712−
713−```haskell
714−buildGroup :: NE.NonEmpty GroupRow -> Group
715−buildGroup grs =
716− let buildMP (GroupRow _ f l) = Mp f l
717− name = groupName . NE.head $ grs
718− members = NE.toList (buildMP <$> grs)
719− in Group{..}
720−
721−rowToGroups :: [GroupRow] -> [Group]
722−rowToGroups =
723− let grouped = fmap NE.fromList . L.groupBy ((==) `on` groupName)
724− in fmap buildGroup . grouped
725−```
726−
727−---
728−
729−# Finally calling our queries
730−
731−- Query with params will use `runQueryParams`.
732−
733−- Query without params will use `runQuery`.
734−
735−- Result is inside a `MonadPQ` and of type `K` from generic-sop.
736−
737−- You get your actual result using `getRows`. Exemple:
738−
739−```haskell
740−getParliament :: (MonadPQ Schema m, MonadBaseControl IO m) => m [Group]
741−getParliament = do
742− res <- runQuery selectParliament
743− rows <- getRows res
744− pure $ rowToGroups rows
745−```
746−
747−- In real life of course you'll write:
748−
749−```haskell
750−getParliament =
751− rowToGroups <$> (runQuery selectParliament >>= getRows)
752−```
753−
754−---
755−
756−# Our query with params
757−
758−```haskell
759−getGroupMembers ::
760− (MonadPQ Schema m, MonadBaseControl IO m) => Text -> m (Maybe Group)
761−getGroupMembers =
762− listToMaybe . rowToGroups <$>
763− (runQueryParams selectGroupMembers (Only t) >>= getRows)
764−```
765−
766−- And that's it.
767−
768−---
769−
770−![Eazy](https://media.tenor.com/images/8fc7c4077efe11b4a3a3b9ae4e643e87/tenor.gif)
771−
772−---
773−
774−# Conclusion
775−
776−---
777−
778−# Pros & Cons
779−
780−- Not everything is included: some cool stuff like array_agg and window functions are not available yet.
781−
782−- But development is _very_ active. `IN` clauses were missing but were added in the 4.0 released recently.
783−
784−- It's bleeding edge. You need latest LTS to be comfortable and psql >= 9.5.
785−
786−- It's Postgres-only but I would say that's a feature. Multi-DB tools are even more complex.
787−
788−- The author & maintainer is <3.
789−
790−- Typesafe. 'nuff said.
791−
792−---
793−
794−# Thank you !
stack.yaml+1−6
@@ -1,8 +1,3 @@
1−resolver: nightly-2019-07-14
1+resolver: lts-11.1
22packages:
33- squeal-postgresql
4−
5−extra-deps:
6−- unliftio-pool-0.2.1.0
7−- github: morphismtech/free-categories
8− commit: c0e555fbefb5c21619e532264c4dfeac556d0630