git.iko.soy/squeal
on dev help sign in
Merge pull request #33 from morphismtech/0.3
60488bdEitan Chatav
.circleci/config.yml+1−1
compare with dev
unifiedsplit
@@ -2,7 +2,7 @@ version: 2
2jobs:
2jobs:
3 build:
3 build:
4 docker:
4 docker:
5− - image: haskell:latest
5+ - image: haskell:8.2.2
6 - image: circleci/postgres:latest
6 - image: circleci/postgres:latest
7 environment:
7 environment:
8 POSTGRES_DB: exampledb
8 POSTGRES_DB: exampledb
README.md+77−66
@@ -44,6 +44,8 @@ composable and cover a large portion of SQL.
44* linear, invertible migrations
44* linear, invertible migrations
45* connection pools
45* connection pools
46* transactions
46* transactions
47+* views
48+* composite and enumerated types
47
49
48## installation
50## installation
49
51
@@ -62,24 +64,25 @@ Let's see an example!
62First, we need some language extensions because Squeal uses modern GHC
64First, we need some language extensions because Squeal uses modern GHC
63features.
65features.
64
66
65−```haskell
67+```Haskell
66>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
68>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
67>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators
69>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators
68```
70```
69
71
70We'll need some imports.
72We'll need some imports.
71
73
72−```haskell
74+```Haskell
73>>> import Control.Monad (void)
75>>> import Control.Monad (void)
74>>> import Control.Monad.Base (liftBase)
76>>> import Control.Monad.Base (liftBase)
75>>> import Data.Int (Int32)
77>>> import Data.Int (Int32)
76>>> import Data.Text (Text)
78>>> import Data.Text (Text)
77>>> import Squeal.PostgreSQL
79>>> import Squeal.PostgreSQL
80+>>> import Squeal.PostgreSQL.Render
78```
81```
79
82
80We'll use generics to easily convert between Haskell and PostgreSQL values.
83We'll use generics to easily convert between Haskell and PostgreSQL values.
81
84
82−```haskell
85+```Haskell
83>>> import qualified Generics.SOP as SOP
86>>> import qualified Generics.SOP as SOP
84>>> import qualified GHC.Generics as GHC
87>>> import qualified GHC.Generics as GHC
85```
88```
@@ -87,93 +90,99 @@ We'll use generics to easily convert between Haskell and PostgreSQL values.
87The first step is to define the schema of our database. This is where
90The first step is to define the schema of our database. This is where
88we use `DataKinds` and `TypeOperators`.
91we use `DataKinds` and `TypeOperators`.
89
92
90−```haskell
93+```Haskell
91>>> :{
94>>> :{
92type Schema =
95type Schema =
93− '[ "users" :::
96+ '[ "users" ::: 'Table (
94− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
97+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
95− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
98+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
96− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
99+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
97− ]
100+ ])
98− , "emails" :::
101+ , "emails" ::: 'Table (
99− '[ "pk_emails" ::: 'PrimaryKey '["id"]
102+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
100− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
103+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
101− ] :=>
104+ ] :=>
102− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
105+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
103− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
106+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
104− , "email" ::: 'NoDef :=> 'Null 'PGtext
107+ , "email" ::: 'NoDef :=> 'Null 'PGtext
105− ]
108+ ])
106− ]
109+ ]
107:}
110:}
108```
111```
109
112
110−Notice the use of type operators. `:::` is used
113+Notice the use of type operators.
114+
111−to pair an alias `Symbol` with either a `TableType` or a `ColumnType`.
115+`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemumType`,
112−`:=>` is used to pair a `TableConstraint`s with a `ColumnsType`,
116+a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's `::`
117+operator.
118+
119+`:=>` is used to pair `TableConstraints` with a `ColumnsType`,
113yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,
120yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,
114−yielding a `ColumnType`.
121+yielding a `ColumnType`. It is intended to connote Haskell's `=>` operator
115
122
116Next, we'll write `Definition`s to set up and tear down the schema. In
123Next, we'll write `Definition`s to set up and tear down the schema. In
117−Squeal, a `Definition` is a `createTable`, `alterTable` or `dropTable`
124+Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`
118−command and has two type parameters, corresponding to the schema
125+has two type parameters, corresponding to the schema
119−before being run and the schema after. We can compose definitions using
126+before being run and the schema after. We can compose definitions using `>>>`.
120−`>>>`. Here and in the rest of our commands we make use of overloaded
127+Here and in the rest of our commands we make use of overloaded
121labels to refer to named tables and columns in our schema.
128labels to refer to named tables and columns in our schema.
122
129
123−```haskell
130+```Haskell
124>>> :{
131>>> :{
125let
132let
126 setup :: Definition '[] Schema
133 setup :: Definition '[] Schema
127 setup =
134 setup =
128− createTable #users
135+ createTable #users
129− ( serial `As` #id :*
136+ ( serial `As` #id :*
130− (text & notNull) `As` #name :* Nil )
137+ (text & notNullable) `As` #name :* Nil )
131− ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>>
138+ ( primaryKey #id `As` #pk_users :* Nil ) >>>
132− createTable #emails
139+ createTable #emails
133− ( serial `As` #id :*
140+ ( serial `As` #id :*
134− (int & notNull) `As` #user_id :*
141+ (int & notNullable) `As` #user_id :*
135− text `As` #email :* Nil )
142+ (text & nullable) `As` #email :* Nil )
136− ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
143+ ( primaryKey #id `As` #pk_emails :*
137− foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
144+ foreignKey #user_id #users #id
138− OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
145+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
139:}
146:}
140```
147```
141
148
142−We can easily see the generated SQL is unsuprising looking.
149+We can easily see the generated SQL is unsurprising looking.
143
150
144−```haskell
151+```Haskell
145−>>> renderDefinition setup
152+>>> printSQL setup
153+CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
146−"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);"
154+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);
147```
155```
148
156
149Notice that `setup` starts with an empty schema `'[]` and produces `Schema`.
157Notice that `setup` starts with an empty schema `'[]` and produces `Schema`.
150In our `createTable` commands we included `TableConstraint`s to define
158In our `createTable` commands we included `TableConstraint`s to define
151−primary and foreign keys, making them somewhat complex. Our tear down
159+primary and foreign keys, making them somewhat complex. Our `teardown`
152`Definition` is simpler.
160`Definition` is simpler.
153
161
154−```haskell
162+```Haskell
155>>> :{
163>>> :{
156let
164let
157 teardown :: Definition Schema '[]
165 teardown :: Definition Schema '[]
158 teardown = dropTable #emails >>> dropTable #users
166 teardown = dropTable #emails >>> dropTable #users
159:}
167:}
168+
160−>>> renderDefinition teardown
169+>>> printSQL teardown
161−"DROP TABLE emails; DROP TABLE users;"
170+DROP TABLE "emails";
171+DROP TABLE "users";
162```
172```
163
173
164Next, we'll write `Manipulation`s to insert data into our two tables.
174Next, we'll write `Manipulation`s to insert data into our two tables.
165−A `Manipulation` is an `insertRow` (or other inserts), `update`
175+A `Manipulation` like `insertRow`, `update` or `deleteFrom`
166−or `deleteFrom` command and
167has three type parameters, the schema it refers to, a list of parameters
176has three type parameters, the schema it refers to, a list of parameters
168it can take as input, and a list of columns it produces as output. When
177it can take as input, and a list of columns it produces as output. When
169we insert into the users table, we will need a parameter for the `name`
178we insert into the users table, we will need a parameter for the `name`
170−field but not for the `id` field. Since it's optional, we can use a default
179+field but not for the `id` field. Since it's serial, we can use a default
171value. However, since the emails table refers to the users table, we will
180value. However, since the emails table refers to the users table, we will
172need to retrieve the user id that the insert generates and insert it into
181need to retrieve the user id that the insert generates and insert it into
173the emails table. Take a careful look at the type and definition of both
182the emails table. Take a careful look at the type and definition of both
174of our inserts.
183of our inserts.
175
184
176−```haskell
185+```Haskell
177>>> :{
186>>> :{
178let
187let
179 insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ]
188 insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ]
@@ -181,6 +190,7 @@ let
181 (Default `As` #id :* Set (param @1) `As` #name :* Nil)
190 (Default `As` #id :* Set (param @1) `As` #name :* Nil)
182 OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
191 OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
183:}
192:}
193+
184>>> :{
194>>> :{
185let
195let
186 insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
196 insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
@@ -190,10 +200,11 @@ let
190 Set (param @2) `As` #email :* Nil )
200 Set (param @2) `As` #email :* Nil )
191 OnConflictDoNothing (Returning Nil)
201 OnConflictDoNothing (Returning Nil)
192:}
202:}
203+
193−>>> renderManipulation insertUser
204+>>> printSQL insertUser
194−"INSERT INTO users (id, name) VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING id AS fromOnly;"
205+INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING "id" AS "fromOnly"
195−>>> renderManipulation insertEmail
206+>>> printSQL insertEmail
196−"INSERT INTO emails (id, user_id, email) VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING;"
207+INSERT INTO "emails" ("id", "user_id", "email") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING
197```
208```
198
209
199Next we write a `Query` to retrieve users from the database. We're not
210Next we write a `Query` to retrieve users from the database. We're not
@@ -201,7 +212,7 @@ interested in the ids here, just the usernames and email addresses. We
201need to use an inner join to get the right result. A `Query` is like a
212need to use an inner join to get the right result. A `Query` is like a
202`Manipulation` with the same kind of type parameters.
213`Manipulation` with the same kind of type parameters.
203
214
204−```haskell
215+```Haskell
205>>> :{
216>>> :{
206let
217let
207 getUsers :: Query Schema '[]
218 getUsers :: Query Schema '[]
@@ -213,8 +224,9 @@ let
213 & innerJoin (table (#emails `As` #e))
224 & innerJoin (table (#emails `As` #e))
214 (#u ! #id .== #e ! #user_id)) )
225 (#u ! #id .== #e ! #user_id)) )
215:}
226:}
227+
216−>>> renderQuery getUsers
228+>>> printSQL getUsers
217−"SELECT u.name AS userName, e.email AS userEmail FROM users AS u INNER JOIN emails AS e ON (u.id = e.user_id)"
229+SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id")
218```
230```
219
231
220Now that we've defined the SQL side of things, we'll need a Haskell type
232Now that we've defined the SQL side of things, we'll need a Haskell type
@@ -223,7 +235,7 @@ for users. We give the type `Generics.SOP.Generic` and
223we receive when we run `getUsers`. Notice that the record fields of the
235we receive when we run `getUsers`. Notice that the record fields of the
224`User` type match the column names of `getUsers`.
236`User` type match the column names of `getUsers`.
225
237
226−```haskell
238+```Haskell
227>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
239>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
228>>> instance SOP.Generic User
240>>> instance SOP.Generic User
229>>> instance SOP.HasDatatypeInfo User
241>>> instance SOP.HasDatatypeInfo User
@@ -231,7 +243,7 @@ we receive when we run `getUsers`. Notice that the record fields of the
231
243
232Let's also create some users to add to the database.
244Let's also create some users to add to the database.
233
245
234−```haskell
246+```Haskell
235>>> :{
247>>> :{
236let
248let
237 users :: [User]
249 users :: [User]
@@ -251,7 +263,7 @@ the changing schema information through by using the indexed `PQ` monad
251transformer and when the schema doesn't change we can use `Monad` and
263transformer and when the schema doesn't change we can use `Monad` and
252`MonadPQ` functionality.
264`MonadPQ` functionality.
253
265
254−```haskell
266+```Haskell
255>>> :{
267>>> :{
256let
268let
257 session :: PQ Schema Schema IO ()
269 session :: PQ Schema Schema IO ()
@@ -262,12 +274,11 @@ let
262 usersResult <- runQuery getUsers
274 usersResult <- runQuery getUsers
263 usersRows <- getRows usersResult
275 usersRows <- getRows usersResult
264 liftBase $ print (usersRows :: [User])
276 liftBase $ print (usersRows :: [User])
265−:}
277+in
266−>>> :{
267−void . withConnection "host=localhost port=5432 dbname=exampledb" $
278+ void . withConnection "host=localhost port=5432 dbname=exampledb" $
268− define setup
279+ define setup
269− & pqThen session
280+ & pqThen session
270− & pqThen (define teardown)
281+ & pqThen (define teardown)
271:}
282:}
272[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
283[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
273```
284```
RELEASE NOTES.md+240
@@ -1,5 +1,245 @@
1## RELEASE NOTES
1## RELEASE NOTES
2
2
3+### Version 0.3 - June 26, 2018
4+
5+Version 0.3 of Squeal adds views as well as composite and enumerated types to Squeal.
6+To support these features, a new kind `SchemumType` was added.
7+
8+```Haskell
9+data SchemumType
10+ = Table TableType
11+ | View RelationType
12+ | Typedef PGType
13+```
14+
15+As a consequence, you will have to update your schema definitions like so:
16+
17+```Haskell
18+-- Squeal 0.2
19+type Schema =
20+ '[ "users" :::
21+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
22+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
23+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
24+ ]
25+ ]
26+
27+-- Squeal 0.3
28+type Schema =
29+ '[ "users" ::: 'Table (
30+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
31+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
32+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
33+ ])
34+ ]
35+```
36+
37+**Views**
38+
39+You can now create, drop, and query views.
40+
41+```Haskell
42+>>> :{
43+type ABC =
44+ ('[] :: TableConstraints) :=>
45+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4
46+ , "b" ::: 'NoDef :=> 'Null 'PGint4
47+ , "c" ::: 'NoDef :=> 'Null 'PGint4
48+ ]
49+type BC =
50+ '[ "b" ::: 'Null 'PGint4
51+ , "c" ::: 'Null 'PGint4
52+ ]
53+:}
54+
55+>>> :{
56+let
57+ definition :: Definition '["abc" ::: 'Table ABC ] '["abc" ::: 'Table ABC, "bc" ::: 'View BC]
58+ definition = createView #bc (select (#b :* #c :* Nil) (from (table #abc)))
59+in printSQL definition
60+:}
61+CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
62+
63+>>> :{
64+let
65+ definition :: Definition '["abc" ::: 'Table ABC, "bc" ::: 'View BC] '["abc" ::: 'Table ABC]
66+ definition = dropView #bc
67+in printSQL definition
68+:}
69+DROP VIEW "bc";
70+
71+>>> :{
72+let
73+ query :: Query '["abc" ::: 'Table ABC, "bc" ::: 'View BC] '[] BC
74+ query = selectStar (from (view #bc))
75+in printSQL query
76+:}
77+SELECT * FROM "bc" AS "bc"
78+```
79+
80+**Enumerated Types**
81+
82+PostgreSQL has a powerful type system. It even allows for user defined types.
83+For instance, you can define enumerated types which are data types that comprise
84+a static, ordered set of values. They are equivalent to Haskell algebraic data
85+types whose constructors are nullary. An example of an enum type might be the days of the week,
86+or a set of status values for a piece of data.
87+
88+Enumerated types are created using the `createTypeEnum` command, for example:
89+
90+```Haskell
91+>>> :{
92+let
93+ definition :: Definition '[] '["mood" ::: 'Typedef ('PGenum '["sad", "ok", "happy"])]
94+ definition = createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil)
95+:}
96+>>> printSQL definition
97+CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
98+```
99+
100+Enumerated types can also be generated from a Haskell algbraic data type with nullary constructors, for example:
101+
102+```Haskell
103+>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
104+>>> instance SOP.Generic Schwarma
105+>>> instance SOP.HasDatatypeInfo Schwarma
106+
107+>>> :kind! EnumFrom Schwarma
108+EnumFrom Schwarma :: PGType
109+= 'PGenum '["Beef", "Lamb", "Chicken"]
110+
111+>>> :{
112+let
113+ definition :: Definition '[] '["schwarma" ::: 'Typedef (EnumFrom Schwarma)]
114+ definition = createTypeEnumFrom @Schwarma #schwarma
115+:}
116+>>> printSQL definition
117+CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
118+```
119+
120+You can express values of an enum type using `label`, which is an overloaded method
121+of the `IsPGlabel` typeclass.
122+
123+```Haskell
124+>>> :{
125+let
126+ expression :: Expression sch rels grp params ('NotNull (EnumFrom Schwarma))
127+ expression = label @"Chicken"
128+in printSQL expression
129+:}
130+'Chicken'
131+```
132+
133+**Composite Types**
134+
135+In addition to enum types, you can define composite types.
136+A composite type represents the structure of a row or record;
137+it is essentially just a list of field names and their data types.
138+
139+
140+`createTypeComposite` creates a composite type. The composite type is
141+specified by a list of attribute names and data types.
142+
143+```Haskell
144+>>> :{
145+let
146+ definition :: Definition '[] '["complex" ::: 'Typedef ('PGcomposite '["real" ::: 'PGfloat8, "imaginary" ::: 'PGfloat8])]
147+ definition = createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil)
148+:}
149+>>> printSQL definition
150+CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
151+```
152+
153+Composite types are almost equivalent to Haskell record types.
154+However, because of the potential presence of `NULL`
155+all the record fields must be `Maybe`s of basic types.
156+Composite types can be generated from a Haskell record type, for example:
157+
158+```Haskell
159+>>> data Complex = Complex {real :: Maybe Double, imaginary :: Maybe Double} deriving GHC.Generic
160+>>> instance SOP.Generic Complex
161+>>> instance SOP.HasDatatypeInfo Complex
162+
163+>>> :kind! CompositeFrom Complex
164+CompositeFrom Complex :: PGType
165+= 'PGcomposite '['("real", 'PGfloat8), '("imaginary", 'PGfloat8)]
166+
167+>>> :{
168+let
169+ definition :: Definition '[] '["complex" ::: 'Typedef (CompositeFrom Complex)]
170+ definition = createTypeCompositeFrom @Complex #complex
171+in printSQL definition
172+:}
173+CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
174+```
175+
176+A row constructor is an expression that builds a row value
177+(also called a composite value) using values for its member fields.
178+
179+```Haskell
180+>>> :{
181+let
182+ i :: Expression '[] '[] 'Ungrouped '[] ('NotNull (CompositeFrom Complex))
183+ i = row (0 `As` #real :* 1 `As` #imaginary :* Nil)
184+:}
185+>>> printSQL i
186+ROW(0, 1)
187+```
188+
189+You can also use `(&)` to apply a field label to a composite value.
190+
191+```Haskell
192+>>> :{
193+let
194+ expr :: Expression '[] '[] 'Ungrouped '[] ('Null 'PGfloat8)
195+ expr = i & #imaginary
196+in printSQL expr
197+:}
198+(ROW(0, 1)).imaginary
199+```
200+
201+Both composite and enum types can be automatically encoded from and decoded to their equivalent Haskell types.
202+And they can be dropped.
203+
204+```Haskell
205+>>> :{
206+let
207+ definition :: Definition '["mood" ::: 'Typedef ('PGenum '["sad", "ok", "happy"])] '[]
208+ definition = dropType #mood
209+:}
210+>>> printSQL definition
211+DROP TYPE "mood";
212+```
213+
214+**Additional Changes**
215+
216+Squeal 0.3 also introduces a typeclass `HasAll` similar to `Has` but for a list of aliases.
217+This makes it possible to clean up some unfortunately messy Squeal 0.2 definitions.
218+
219+```Haskell
220+-- Squeal 0.2
221+>>> unique (Column #a :* Column #b :* Nil)
222+
223+-- Squeal 0.3
224+>>> unique (#a :* #b :* Nil)
225+```
226+
227+Squeal 0.3 also adds `IsLabel` instances for `Aliased` expressions and tables as well as
228+heterogeneous lists, allowing for some more economy of code.
229+
230+```Haskell
231+-- Squeal 0.2 (or 0.3)
232+>>> select (#a `As` #a :* Nil) (from (table (#t `As` #t)))
233+
234+-- Squeal 0.3
235+>>> select #a (from (table #t))
236+```
237+
238+Squeal 0.3 also fixes a bug that prevented joined queries on self-referencing tables.
239+
240+The above changes required major and minor changes to Squeal DSL functions.
241+Please consult the documentation.
242+
3### Version 0.2.1 - April 7, 2018
243### Version 0.2.1 - April 7, 2018
4
244
5This minor update fixes an issue where alias identifiers could conflict with
245This minor update fixes an issue where alias identifiers could conflict with
squeal-postgresql/exe/Example.hs+11−11
@@ -25,36 +25,36 @@ import qualified Generics.SOP as SOP
25import qualified GHC.Generics as GHC
25import qualified GHC.Generics as GHC
26
26
27type Schema =
27type Schema =
28− '[ "users" :::
28+ '[ "users" ::: 'Table (
29 '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
29 '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
30 '[ "id" ::: 'Def :=> 'NotNull 'PGint4
30 '[ "id" ::: 'Def :=> 'NotNull 'PGint4
31 , "name" ::: 'NoDef :=> 'NotNull 'PGtext
31 , "name" ::: 'NoDef :=> 'NotNull 'PGtext
32 , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2)
32 , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2)
33− ]
33+ ])
34− , "emails" :::
34+ , "emails" ::: 'Table (
35 '[ "pk_emails" ::: 'PrimaryKey '["id"]
35 '[ "pk_emails" ::: 'PrimaryKey '["id"]
36 , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
36 , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
37 ] :=>
37 ] :=>
38 '[ "id" ::: 'Def :=> 'NotNull 'PGint4
38 '[ "id" ::: 'Def :=> 'NotNull 'PGint4
39 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
39 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
40 , "email" ::: 'NoDef :=> 'Null 'PGtext
40 , "email" ::: 'NoDef :=> 'Null 'PGtext
41− ]
41+ ])
42 ]
42 ]
43
43
44setup :: Definition '[] Schema
44setup :: Definition '[] Schema
45setup =
45setup =
46 createTable #users
46 createTable #users
47 ( serial `As` #id :*
47 ( serial `As` #id :*
48− (text & notNull) `As` #name :*
48+ (text & notNullable) `As` #name :*
49− (vararray int2 & notNull) `As` #vec :* Nil )
49+ (vararray int2 & notNullable) `As` #vec :* Nil )
50− ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil )
50+ ( primaryKey #id `As` #pk_users :* Nil )
51 >>>
51 >>>
52 createTable #emails
52 createTable #emails
53 ( serial `As` #id :*
53 ( serial `As` #id :*
54− (int & notNull) `As` #user_id :*
54+ (int & notNullable) `As` #user_id :*
55− text `As` #email :* Nil )
55+ (text & nullable) `As` #email :* Nil )
56− ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
56+ ( primaryKey #id `As` #pk_emails :*
57− foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
57+ foreignKey #user_id #users #id
58 OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
58 OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
59
59
60teardown :: Definition Schema '[]
60teardown :: Definition Schema '[]
squeal-postgresql/squeal-postgresql.cabal+6−4
@@ -1,5 +1,5 @@
1name: squeal-postgresql
1name: squeal-postgresql
2−version: 0.2.1.0
2+version: 0.3.0.0
3synopsis: Squeal PostgreSQL Library
3synopsis: Squeal PostgreSQL Library
4description: Squeal is a type-safe embedding of PostgreSQL in Haskell
4description: Squeal is a type-safe embedding of PostgreSQL in Haskell
5homepage: https://github.com/morphismtech/squeal
5homepage: https://github.com/morphismtech/squeal
@@ -34,11 +34,13 @@ library
34 Squeal.PostgreSQL.Schema
34 Squeal.PostgreSQL.Schema
35 Squeal.PostgreSQL.Transaction
35 Squeal.PostgreSQL.Transaction
36 default-language: Haskell2010
36 default-language: Haskell2010
37− ghc-options: -Wall -fprint-explicit-kinds
37+ ghc-options: -Wall -Werror
38 build-depends:
38 build-depends:
39 aeson >= 1.2.4.0
39 aeson >= 1.2.4.0
40 , base >= 4.10.1.0 && < 5.0
40 , base >= 4.10.1.0 && < 5.0
41+ , binary-parser >= 0.5.5
41 , bytestring >= 0.10.8.2
42 , bytestring >= 0.10.8.2
43+ , bytestring-strict-builder >= 0.4.5
42 , deepseq >= 1.4.3.0
44 , deepseq >= 1.4.3.0
43 , generics-sop >= 0.3.2.0
45 , generics-sop >= 0.3.2.0
44 , lifted-base >= 0.2.3.12
46 , lifted-base >= 0.2.3.12
@@ -61,7 +63,7 @@ test-suite squeal-postgresql-doctest
61 default-language: Haskell2010
63 default-language: Haskell2010
62 type: exitcode-stdio-1.0
64 type: exitcode-stdio-1.0
63 hs-source-dirs: test
65 hs-source-dirs: test
64− ghc-options: -Wall
66+ ghc-options: -Wall -Werror
65 main-is: DocTest.hs
67 main-is: DocTest.hs
66 build-depends:
68 build-depends:
67 base >= 4.10.0.0
69 base >= 4.10.0.0
@@ -70,7 +72,7 @@ test-suite squeal-postgresql-doctest
70executable squeal-postgresql-example
72executable squeal-postgresql-example
71 default-language: Haskell2010
73 default-language: Haskell2010
72 hs-source-dirs: exe
74 hs-source-dirs: exe
73− ghc-options: -Wall
75+ ghc-options: -Wall -Werror
74 main-is: Example.hs
76 main-is: Example.hs
75 build-depends:
77 build-depends:
76 base >= 4.10.0.0 && < 5.0
78 base >= 4.10.0.0 && < 5.0
squeal-postgresql/src/Squeal/PostgreSQL.hs+207−202
@@ -1,206 +1,211 @@
1+{-|
1−-- | Module: Squeal.PostgreSQL
2+Module: Squeal.PostgreSQL
2−-- Description: Squeel export module
3+Description: Squeel export module
3−-- Copyright: (c) Eitan Chatav, 2017
4+Copyright: (c) Eitan Chatav, 2017
4−-- Maintainer: eitan@morphism.tech
5+Maintainer: eitan@morphism.tech
5−-- Stability: experimental
6+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
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
15+>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators
16+
17+We'll need some imports.
18+
19+>>> import Control.Monad (void)
20+>>> import Control.Monad.Base (liftBase)
21+>>> import Data.Int (Int32)
22+>>> import Data.Text (Text)
23+>>> import Squeal.PostgreSQL
24+>>> import Squeal.PostgreSQL.Render
25+
26+We'll use generics to easily convert between Haskell and PostgreSQL values.
27+
28+>>> import qualified Generics.SOP as SOP
29+>>> import qualified GHC.Generics as GHC
30+
31+The first step is to define the schema of our database. This is where
32+we use @DataKinds@ and @TypeOperators@.
33+
34+>>> :{
35+type Schema =
36+ '[ "users" ::: 'Table (
37+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
38+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
39+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
40+ ])
41+ , "emails" ::: 'Table (
42+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
43+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
44+ ] :=>
45+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
46+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
47+ , "email" ::: 'NoDef :=> 'Null 'PGtext
48+ ])
49+ ]
50+:}
51+
52+Notice the use of type operators.
53+
54+`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemumType`,
55+a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's @::@
56+operator.
57+
58+`:=>` is used to pair `TableConstraints` with a `ColumnsType`,
59+yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,
60+yielding a `ColumnType`. It is intended to connote Haskell's @=>@ operator
61+
62+Next, we'll write `Definition`s to set up and tear down the schema. In
63+Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`
64+has two type parameters, corresponding to the schema
65+before being run and the schema after. We can compose definitions using `>>>`.
66+Here and in the rest of our commands we make use of overloaded
67+labels to refer to named tables and columns in our schema.
68+
69+>>> :{
70+let
71+ setup :: Definition '[] Schema
72+ setup =
73+ createTable #users
74+ ( serial `As` #id :*
75+ (text & notNullable) `As` #name :* Nil )
76+ ( primaryKey #id `As` #pk_users :* Nil ) >>>
77+ createTable #emails
78+ ( serial `As` #id :*
79+ (int & notNullable) `As` #user_id :*
80+ (text & nullable) `As` #email :* Nil )
81+ ( primaryKey #id `As` #pk_emails :*
82+ foreignKey #user_id #users #id
83+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
84+:}
85+
86+We can easily see the generated SQL is unsurprising looking.
87+
88+>>> printSQL setup
89+CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
90+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);
91+
92+Notice that @setup@ starts with an empty schema @'[]@ and produces @Schema@.
93+In our `createTable` commands we included `TableConstraint`s to define
94+primary and foreign keys, making them somewhat complex. Our @teardown@
95+`Definition` is simpler.
96+
97+>>> :{
98+let
99+ teardown :: Definition Schema '[]
100+ teardown = dropTable #emails >>> dropTable #users
101+:}
102+
103+>>> printSQL teardown
104+DROP TABLE "emails";
105+DROP TABLE "users";
106+
107+Next, we'll write `Manipulation`s to insert data into our two tables.
108+A `Manipulation` like `insertRow`, `update` or `deleteFrom`
109+has three type parameters, the schema it refers to, a list of parameters
110+it can take as input, and a list of columns it produces as output. When
111+we insert into the users table, we will need a parameter for the @name@
112+field but not for the @id@ field. Since it's serial, we can use a default
113+value. However, since the emails table refers to the users table, we will
114+need to retrieve the user id that the insert generates and insert it into
115+the emails table. Take a careful look at the type and definition of both
116+of our inserts.
117+
118+>>> :{
119+let
120+ insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ]
121+ insertUser = insertRow #users
122+ (Default `As` #id :* Set (param @1) `As` #name :* Nil)
123+ OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
124+:}
125+
126+>>> :{
127+let
128+ insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
129+ insertEmail = insertRow #emails
130+ ( Default `As` #id :*
131+ Set (param @1) `As` #user_id :*
132+ Set (param @2) `As` #email :* Nil )
133+ OnConflictDoNothing (Returning Nil)
134+:}
135+
136+>>> printSQL insertUser
137+INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING "id" AS "fromOnly"
138+>>> printSQL insertEmail
139+INSERT INTO "emails" ("id", "user_id", "email") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING
140+
141+Next we write a `Query` to retrieve users from the database. We're not
142+interested in the ids here, just the usernames and email addresses. We
143+need to use an inner join to get the right result. A `Query` is like a
144+`Manipulation` with the same kind of type parameters.
145+
146+>>> :{
147+let
148+ getUsers :: Query Schema '[]
149+ '[ "userName" ::: 'NotNull 'PGtext
150+ , "userEmail" ::: 'Null 'PGtext ]
151+ getUsers = select
152+ (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)
153+ ( from (table (#users `As` #u)
154+ & innerJoin (table (#emails `As` #e))
155+ (#u ! #id .== #e ! #user_id)) )
156+:}
157+
158+>>> printSQL getUsers
159+SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id")
160+
161+Now that we've defined the SQL side of things, we'll need a Haskell type
162+for users. We give the type `Generics.SOP.Generic` and
163+`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows
164+we receive when we run @getUsers@. Notice that the record fields of the
165+@User@ type match the column names of @getUsers@.
166+
167+>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
168+>>> instance SOP.Generic User
169+>>> instance SOP.HasDatatypeInfo User
170+
171+Let's also create some users to add to the database.
172+
173+>>> :{
174+let
175+ users :: [User]
176+ users =
177+ [ User "Alice" (Just "alice@gmail.com")
178+ , User "Bob" Nothing
179+ , User "Carole" (Just "carole@hotmail.com")
180+ ]
181+:}
182+
183+Now we can put together all the pieces into a program. The program
184+connects to the database, sets up the schema, inserts the user data
185+(using prepared statements as an optimization), queries the user
186+data and prints it out and finally closes the connection. We can thread
187+the changing schema information through by using the indexed `PQ` monad
188+transformer and when the schema doesn't change we can use `Monad` and
189+`MonadPQ` functionality.
190+
191+>>> :{
192+let
193+ session :: PQ Schema Schema IO ()
194+ session = do
195+ idResults <- traversePrepared insertUser (Only . userName <$> users)
196+ ids <- traverse (fmap fromOnly . getRow 0) idResults
197+ traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
198+ usersResult <- runQuery getUsers
199+ usersRows <- getRows usersResult
200+ liftBase $ print (usersRows :: [User])
201+in
202+ void . withConnection "host=localhost port=5432 dbname=exampledb" $
203+ define setup
204+ & pqThen session
205+ & pqThen (define teardown)
206+:}
207+[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
208+-}
204module Squeal.PostgreSQL
209module Squeal.PostgreSQL
205 ( module Squeal.PostgreSQL.Binary
210 ( module Squeal.PostgreSQL.Binary
206 , module Squeal.PostgreSQL.Definition
211 , module Squeal.PostgreSQL.Definition
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+271−13
@@ -5,13 +5,131 @@ Copyright: (c) Eitan Chatav, 2017
5Maintainer: eitan@morphism.tech
5Maintainer: eitan@morphism.tech
6Stability: experimental
6Stability: experimental
7
7
8−Binary encoding and decoding between Haskell and PostgreSQL types.
8+This module provides binary encoding and decoding between Haskell and PostgreSQL types.
9+
10+Instances are governed by the `Generic` and `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+>>> import Data.Int (Int16)
15+>>> import Data.Text (Text)
16+
17+>>> data Row = Row { col1 :: Int16, col2 :: Text } deriving (Eq, GHC.Generic)
18+>>> instance Generic Row
19+>>> instance HasDatatypeInfo Row
20+
21+>>> import Control.Monad (void)
22+>>> import Control.Monad.Base (liftBase)
23+>>> import Squeal.PostgreSQL
24+
25+>>> :{
26+let
27+ query :: Query '[]
28+ '[ 'NotNull 'PGint2, 'NotNull 'PGtext]
29+ '["col1" ::: 'NotNull 'PGint2, "col2" ::: 'NotNull 'PGtext]
30+ query = values_ (param @1 `As` #col1 :* param @2 `As` #col2 :* Nil)
31+:}
32+
33+>>> :{
34+let
35+ roundtrip :: IO ()
36+ roundtrip = void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
37+ result <- runQueryParams query (2 :: Int16, "hi" :: Text)
38+ Just row <- firstRow result
39+ liftBase . print $ row == Row 2 "hi"
40+:}
41+
42+>>> roundtrip
43+True
44+
45+In addition to being able to encode and decode basic Haskell types like `Int16` and `Text`,
46+Squeal permits you to encode and decode Haskell types which are equivalent to
47+Postgres enumerated and composite types.
48+
49+Enumerated (enum) types are data types that comprise a static, ordered set of values.
50+They are equivalent to Haskell algebraic data types whose constructors are nullary.
51+An example of an enum type might be the days of the week,
52+or a set of status values for a piece of data.
53+
54+>>> data Schwarma = Beef | Lamb | Chicken deriving (Show, GHC.Generic)
55+>>> instance Generic Schwarma
56+>>> instance HasDatatypeInfo Schwarma
57+
58+A composite type represents the structure of a row or record;
59+it is essentially just a list of field names and their data types. They are almost
60+equivalent to Haskell record types. However, because of the potential presence of @NULL@
61+all the record fields must be `Maybe`s of basic types.
62+
63+>>> data Person = Person {name :: Maybe Text, age :: Maybe Int32} deriving (Show, GHC.Generic)
64+>>> instance Generic Person
65+>>> instance HasDatatypeInfo Person
66+
67+We can create the equivalent Postgres types directly from their Haskell types.
68+
69+>>> :{
70+type Schema =
71+ '[ "schwarma" ::: 'Typedef (EnumFrom Schwarma)
72+ , "person" ::: 'Typedef (CompositeFrom Person)
73+ ]
74+:}
75+
76+>>> :{
77+let
78+ setup :: Definition '[] Schema
79+ setup =
80+ createTypeEnumFrom @Schwarma #schwarma >>>
81+ createTypeCompositeFrom @Person #person
82+:}
83+
84+Then we can perform roundtrip queries;
85+
86+>>> :{
87+let
88+ querySchwarma :: Query Schema
89+ '[ 'NotNull (EnumFrom Schwarma)]
90+ '["fromOnly" ::: 'NotNull (EnumFrom Schwarma)]
91+ querySchwarma = values_ (parameter @1 #schwarma `As` #fromOnly :* Nil)
92+:}
93+
94+>>> :{
95+let
96+ queryPerson :: Query Schema
97+ '[ 'NotNull (CompositeFrom Person)]
98+ '["fromOnly" ::: 'NotNull (CompositeFrom Person)]
99+ queryPerson = values_ (parameter @1 #person `As` #fromOnly :* Nil)
100+:}
101+
102+And finally drop the types.
103+
104+>>> :{
105+let
106+ teardown :: Definition Schema '[]
107+ teardown = dropType #schwarma >>> dropType #person
108+:}
109+
110+Now let's run it.
111+
112+>>> :{
113+let
114+ session = do
115+ result1 <- runQueryParams querySchwarma (Only Chicken)
116+ Just (Only schwarma) <- firstRow result1
117+ liftBase $ print (schwarma :: Schwarma)
118+ result2 <- runQueryParams queryPerson (Only (Person (Just "Faisal") (Just 24)))
119+ Just (Only person) <- firstRow result2
120+ liftBase $ print (person :: Person)
121+in
122+ void . withConnection "host=localhost port=5432 dbname=exampledb" $
123+ define setup
124+ & pqThen session
125+ & pqThen (define teardown)
126+:}
127+Chicken
128+Person {name = Just "Faisal", age = Just 24}
9-}
129-}
10
130
11{-# LANGUAGE
131{-# LANGUAGE
12− ConstraintKinds
132+ AllowAmbiguousTypes
13− , DataKinds
14− , DefaultSignatures
15 , DeriveFoldable
133 , DeriveFoldable
16 , DeriveFunctor
134 , DeriveFunctor
17 , DeriveGeneric
135 , DeriveGeneric
@@ -20,11 +138,9 @@ Binary encoding and decoding between Haskell and PostgreSQL types.
20 , FlexibleInstances
138 , FlexibleInstances
21 , GADTs
139 , GADTs
22 , LambdaCase
140 , LambdaCase
23− , KindSignatures
24 , MultiParamTypeClasses
141 , MultiParamTypeClasses
25 , ScopedTypeVariables
142 , ScopedTypeVariables
26 , TypeApplications
143 , TypeApplications
27− , TypeFamilies
28 , TypeInType
144 , TypeInType
29 , TypeOperators
145 , TypeOperators
30 , UndecidableInstances
146 , UndecidableInstances
@@ -43,9 +159,12 @@ module Squeal.PostgreSQL.Binary
43 , Only (..)
159 , Only (..)
44 ) where
160 ) where
45
161
162+import BinaryParser
163+import ByteString.StrictBuilder
46import Data.Aeson hiding (Null)
164import Data.Aeson hiding (Null)
47import Data.Int
165import Data.Int
48import Data.Kind
166import Data.Kind
167+import Data.Monoid hiding (All)
49import Data.Scientific
168import Data.Scientific
50import Data.Time
169import Data.Time
51import Data.UUID.Types
170import Data.UUID.Types
@@ -56,7 +175,7 @@ import GHC.TypeLits
56import Network.IP.Addr
175import Network.IP.Addr
57
176
58import qualified Data.ByteString.Lazy as Lazy
177import qualified Data.ByteString.Lazy as Lazy
59−import qualified Data.ByteString as Strict hiding (unpack)
178+import qualified Data.ByteString as Strict hiding (pack, unpack)
60import qualified Data.Text.Lazy as Lazy
179import qualified Data.Text.Lazy as Lazy
61import qualified Data.Text as Strict
180import qualified Data.Text as Strict
62import qualified Data.Vector as Vector
181import qualified Data.Vector as Vector
@@ -119,9 +238,83 @@ instance (HasOid pg, ToParam x pg)
119 => ToParam (Vector (Maybe x)) ('PGvararray pg) where
238 => ToParam (Vector (Maybe x)) ('PGvararray pg) where
120 toParam = K . Encoding.nullableArray_vector
239 toParam = K . Encoding.nullableArray_vector
121 (oid @pg) (unK . toParam @x @pg)
240 (oid @pg) (unK . toParam @x @pg)
241+instance
242+ ( IsEnumType x
243+ , HasDatatypeInfo x
244+ , LabelsFrom x ~ labels
245+ ) => ToParam x ('PGenum labels) where
246+ toParam =
247+ let
248+ gshowConstructor :: NP ConstructorInfo xss -> SOP I xss -> String
249+ gshowConstructor Nil _ = ""
250+ gshowConstructor (constructor :* _) (SOP (Z _)) =
251+ constructorName constructor
252+ gshowConstructor (_ :* constructors) (SOP (S xs)) =
253+ gshowConstructor constructors (SOP xs)
254+ in
255+ K . Encoding.text_strict
256+ . Strict.pack
257+ . gshowConstructor (constructorInfo (datatypeInfo (Proxy @x)))
258+ . from
259+instance
260+ ( SListI fields
261+ , MapMaybes xs
262+ , IsProductType x (Maybes xs)
263+ , AllZip ToAliasedParam xs fields
264+ , FieldNamesFrom x ~ AliasesOf fields
265+ , All HasAliasedOid fields
266+ ) => ToParam x ('PGcomposite fields) where
267+ toParam =
268+ let
269+
270+ encoders = htrans (Proxy @ToAliasedParam) toAliasedParam
271+
272+ composite
273+ :: All HasAliasedOid row
274+ => NP (K (Maybe Encoding.Encoding)) row
275+ -> K Encoding.Encoding ('PGcomposite row)
276+ composite fields = K $
277+ -- <number of fields: 4 bytes>
278+ -- [for each field]
279+ -- <OID of field's type: sizeof(Oid) bytes>
280+ -- [if value is NULL]
281+ -- <-1: 4 bytes>
282+ -- [else]
283+ -- <length of value: 4 bytes>
284+ -- <value: <length> bytes>
285+ -- [end if]
286+ -- [end for]
287+ int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
288+ let
289+ each
290+ :: HasAliasedOid field
291+ => K (Maybe Encoding.Encoding) field
292+ -> Encoding.Encoding
293+ each (K field :: K (Maybe Encoding.Encoding) field) =
294+ word32BE (aliasedOid @field)
295+ <> case field of
296+ Nothing -> int64BE (-1)
297+ Just value ->
298+ int32BE (fromIntegral (builderLength value))
299+ <> value
300+ in
301+ hcfoldMap (Proxy @HasAliasedOid) each fields
302+
303+ in
304+ composite . encoders . unMaybes . unZ . unSOP . from
122
305
306+class HasAliasedOid (field :: (Symbol, PGType)) where aliasedOid :: Word32
307+instance HasOid ty => HasAliasedOid (alias ::: ty) where aliasedOid = oid @ty
308+
309+class ToAliasedParam (x :: Type) (field :: (Symbol, PGType)) where
310+ toAliasedParam :: Maybe x -> K (Maybe Encoding.Encoding) field
311+instance ToParam x ty => ToAliasedParam x (alias ::: ty) where
312+ toAliasedParam = \case
313+ Nothing -> K Nothing
314+ Just x -> K . Just . unK $ toParam @x @ty x
315+
123−-- | A `ToColumnParam` constraint lifts the `ToParam` encoding
316+-- | A `ToColumnParam` constraint lifts the `ToParam` encoding
124−-- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should
317+-- of a `Type` to a `NullityType`, encoding `Maybe`s to `Null`s. You should
125-- not define instances of `ToColumnParam`, just use the provided instances.
318-- not define instances of `ToColumnParam`, just use the provided instances.
126class ToColumnParam (x :: Type) (ty :: NullityType) where
319class ToColumnParam (x :: Type) (ty :: NullityType) where
127 -- | >>> toColumnParam @Int16 @('NotNull 'PGint2) 0
320 -- | >>> toColumnParam @Int16 @('NotNull 'PGint2) 0
@@ -201,9 +394,74 @@ instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where
201 fromValue _ = Decoding.array
394 fromValue _ = Decoding.array
202 (Decoding.dimensionArray Vector.replicateM
395 (Decoding.dimensionArray Vector.replicateM
203 (Decoding.nullableValueArray (fromValue (Proxy @pg))))
396 (Decoding.nullableValueArray (fromValue (Proxy @pg))))
397+instance
398+ ( IsEnumType y
399+ , HasDatatypeInfo y
400+ , LabelsFrom y ~ labels
401+ ) => FromValue ('PGenum labels) y where
402+ fromValue _ =
403+ let
404+ greadConstructor
405+ :: All ((~) '[]) xss
406+ => NP ConstructorInfo xss
407+ -> String
408+ -> Maybe (SOP I xss)
409+ greadConstructor Nil _ = Nothing
410+ greadConstructor (constructor :* constructors) name =
411+ if name == constructorName constructor
412+ then Just (SOP (Z Nil))
413+ else SOP . S . unSOP <$> greadConstructor constructors name
414+ in
415+ Decoding.enum
416+ $ fmap to
417+ . greadConstructor (constructorInfo (datatypeInfo (Proxy @y)))
418+ . Strict.unpack
419+
420+instance
421+ ( SListI fields
422+ , MapMaybes ys
423+ , IsProductType y (Maybes ys)
424+ , AllZip FromAliasedValue fields ys
425+ , FieldNamesFrom y ~ AliasesOf fields
426+ ) => FromValue ('PGcomposite fields) y where
427+ fromValue =
428+ let
429+ decoders
430+ :: forall pgs zs proxy
431+ . AllZip FromAliasedValue pgs zs
432+ => proxy ('PGcomposite pgs)
433+ -> NP Decoding.Value zs
434+ decoders _ = htrans (Proxy @FromAliasedValue) fromAliasedValue
435+ (hpure Proxy :: NP Proxy pgs)
436+
437+ composite fields = do
438+ -- <number of fields: 4 bytes>
439+ -- [for each field]
440+ -- <OID of field's type: sizeof(Oid) bytes>
441+ -- [if value is NULL]
442+ -- <-1: 4 bytes>
443+ -- [else]
444+ -- <length of value: 4 bytes>
445+ -- <value: <length> bytes>
446+ -- [end if]
447+ -- [end for]
448+ unitOfSize 4
449+ let
450+ each field = do
451+ unitOfSize 4
452+ len <- sized 4 Decoding.int
453+ if len == -1 then return Nothing else Just <$> sized len field
454+ htraverse' each fields
455+
456+ in fmap (to . SOP . Z . maybes) . composite . decoders
457+
458+class FromAliasedValue (pg :: (Symbol,PGType)) (y :: Type) where
459+ fromAliasedValue :: proxy pg -> Decoding.Value y
460+instance FromValue pg y => FromAliasedValue (alias ::: pg) y where
461+ fromAliasedValue _ = fromValue (Proxy @pg)
204
462
205-- | A `FromColumnValue` constraint lifts the `FromValue` parser
463-- | A `FromColumnValue` constraint lifts the `FromValue` parser
206−-- to a decoding of a @(Symbol, ColumnType)@ to a `Type`,
464+-- to a decoding of a @(Symbol, NullityType)@ to a `Type`,
207-- decoding `Null`s to `Maybe`s. You should not define instances for
465-- decoding `Null`s to `Maybe`s. You should not define instances for
208-- `FromColumnValue`, just use the provided instances.
466-- `FromColumnValue`, just use the provided instances.
209class FromColumnValue (colty :: (Symbol,NullityType)) (y :: Type) where
467class FromColumnValue (colty :: (Symbol,NullityType)) (y :: Type) where
@@ -220,10 +478,10 @@ instance FromValue pg y
220 => FromColumnValue (column ::: ('NotNull pg)) y where
478 => FromColumnValue (column ::: ('NotNull pg)) y where
221 fromColumnValue = \case
479 fromColumnValue = \case
222 K Nothing -> error "fromColumnValue: saw NULL when expecting NOT NULL"
480 K Nothing -> error "fromColumnValue: saw NULL when expecting NOT NULL"
223− K (Just bytes) ->
481+ K (Just bs) ->
224 let
482 let
225 errOrValue =
483 errOrValue =
226− Decoding.valueParser (fromValue @pg @y Proxy) bytes
484+ Decoding.valueParser (fromValue @pg @y Proxy) bs
227 err str = error $ "fromColumnValue: " ++ Strict.unpack str
485 err str = error $ "fromColumnValue: " ++ Strict.unpack str
228 in
486 in
229 either err id errOrValue
487 either err id errOrValue
@@ -257,7 +515,7 @@ instance
257 ( SListI results
515 ( SListI results
258 , IsProductType y ys
516 , IsProductType y ys
259 , AllZip FromColumnValue results ys
517 , AllZip FromColumnValue results ys
260− , SameFields (DatatypeInfoOf y) results
518+ , FieldNamesFrom y ~ AliasesOf results
261 ) => FromRow results y where
519 ) => FromRow results y where
262 fromRow
520 fromRow
263 = to . SOP . Z . htrans (Proxy @FromColumnValue) (I . fromColumnValue)
521 = to . SOP . Z . htrans (Proxy @FromColumnValue) (I . fromColumnValue)
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+569−277
@@ -9,35 +9,33 @@ Squeal data definition language.
9-}
9-}
10
10
11{-# LANGUAGE
11{-# LANGUAGE
12+ AllowAmbiguousTypes
12− ConstraintKinds
13+ , ConstraintKinds
13− , DataKinds
14− , DeriveDataTypeable
15 , DeriveGeneric
14 , DeriveGeneric
16 , FlexibleContexts
15 , FlexibleContexts
17 , FlexibleInstances
16 , FlexibleInstances
18 , GADTs
17 , GADTs
19 , GeneralizedNewtypeDeriving
18 , GeneralizedNewtypeDeriving
20− , KindSignatures
21 , LambdaCase
19 , LambdaCase
22 , MultiParamTypeClasses
20 , MultiParamTypeClasses
23 , OverloadedStrings
21 , OverloadedStrings
24 , RankNTypes
22 , RankNTypes
25 , ScopedTypeVariables
23 , ScopedTypeVariables
26− , StandaloneDeriving
27 , TypeApplications
24 , TypeApplications
28 , TypeInType
25 , TypeInType
29 , TypeOperators
26 , TypeOperators
27+ , UndecidableSuperClasses
30#-}
28#-}
31
29
32module Squeal.PostgreSQL.Definition
30module Squeal.PostgreSQL.Definition
33− ( -- * Definition
31+ ( -- * Definition
34 Definition (UnsafeDefinition, renderDefinition)
32 Definition (UnsafeDefinition, renderDefinition)
35 , (>>>)
33 , (>>>)
34+ -- * Tables
36− -- * Create
35+ -- ** Create
37 , createTable
36 , createTable
38 , createTableIfNotExists
37 , createTableIfNotExists
39 , TableConstraintExpression (..)
38 , TableConstraintExpression (..)
40− , Column (..)
41 , check
39 , check
42 , unique
40 , unique
43 , primaryKey
41 , primaryKey
@@ -47,9 +45,9 @@ module Squeal.PostgreSQL.Definition
47 , renderOnDeleteClause
45 , renderOnDeleteClause
48 , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)
46 , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)
49 , renderOnUpdateClause
47 , renderOnUpdateClause
50− -- * Drop
48+ -- ** Drop
51 , dropTable
49 , dropTable
52− -- * Alter
50+ -- ** Alter
53 , alterTable
51 , alterTable
54 , alterTableRename
52 , alterTableRename
55 , AlterTable (UnsafeAlterTable, renderAlterTable)
53 , AlterTable (UnsafeAlterTable, renderAlterTable)
@@ -65,6 +63,26 @@ module Squeal.PostgreSQL.Definition
65 , setNotNull
63 , setNotNull
66 , dropNotNull
64 , dropNotNull
67 , alterType
65 , alterType
66+ -- * Views
67+ , createView
68+ , dropView
69+ -- * Types
70+ , createTypeEnum
71+ , createTypeEnumFrom
72+ , createTypeComposite
73+ , createTypeCompositeFrom
74+ , dropType
75+ -- * Columns
76+ , ColumnTypeExpression (..)
77+ , nullable
78+ , notNullable
79+ , default_
80+ , serial2
81+ , smallserial
82+ , serial4
83+ , serial
84+ , serial8
85+ , bigserial
68 ) where
86 ) where
69
87
70import Control.Category
88import Control.Category
@@ -78,6 +96,7 @@ import qualified Generics.SOP as SOP
78import qualified GHC.Generics as GHC
96import qualified GHC.Generics as GHC
79
97
80import Squeal.PostgreSQL.Expression
98import Squeal.PostgreSQL.Expression
99+import Squeal.PostgreSQL.Query
81import Squeal.PostgreSQL.Render
100import Squeal.PostgreSQL.Render
82import Squeal.PostgreSQL.Schema
101import Squeal.PostgreSQL.Schema
83
102
@@ -89,67 +108,76 @@ statements
89-- database, like a `createTable`, `dropTable`, or `alterTable` command.
108-- database, like a `createTable`, `dropTable`, or `alterTable` command.
90-- `Definition`s may be composed using the `>>>` operator.
109-- `Definition`s may be composed using the `>>>` operator.
91newtype Definition
110newtype Definition
92− (schema0 :: TablesType)
111+ (schema0 :: SchemaType)
93− (schema1 :: TablesType)
112+ (schema1 :: SchemaType)
94 = UnsafeDefinition { renderDefinition :: ByteString }
113 = UnsafeDefinition { renderDefinition :: ByteString }
95 deriving (GHC.Generic,Show,Eq,Ord,NFData)
114 deriving (GHC.Generic,Show,Eq,Ord,NFData)
96
115
116+instance RenderSQL (Definition schema0 schema1) where
117+ renderSQL = renderDefinition
118+
97instance Category Definition where
119instance Category Definition where
98 id = UnsafeDefinition ";"
120 id = UnsafeDefinition ";"
99 ddl1 . ddl0 = UnsafeDefinition $
121 ddl1 . ddl0 = UnsafeDefinition $
100− renderDefinition ddl0 <+> renderDefinition ddl1
122+ renderDefinition ddl0 <> "\n" <> renderDefinition ddl1
101
123
102{-----------------------------------------
124{-----------------------------------------
103CREATE statements
125CREATE statements
104-----------------------------------------}
126-----------------------------------------}
105
127
106−-- | `createTable` adds a table to the schema.
128+{- | `createTable` adds a table to the schema.
107−--
129+
108−-- >>> :set -XOverloadedLabels
130+>>> :set -XOverloadedLabels
109−-- >>> :{
131+>>> :{
110−-- renderDefinition $
132+printSQL $
111−-- createTable #tab (int `As` #a :* real `As` #b :* Nil) Nil
133+ createTable #tab ((int & nullable) `As` #a :* (real & nullable) `As` #b :* Nil) Nil
112−-- :}
134+:}
113−-- "CREATE TABLE \"tab\" (\"a\" int, \"b\" real);"
135+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
136+-}
114createTable
137createTable
115 :: ( KnownSymbol table
138 :: ( KnownSymbol table
116 , columns ~ (col ': cols)
139 , columns ~ (col ': cols)
117 , SOP.SListI columns
140 , SOP.SListI columns
118− , SOP.SListI constraints )
141+ , SOP.SListI constraints
142+ , schema1 ~ Create table ('Table (constraints :=> columns)) schema0 )
119 => Alias table -- ^ the name of the table to add
143 => Alias table -- ^ the name of the table to add
120− -> NP (Aliased TypeExpression) columns
144+ -> NP (Aliased (ColumnTypeExpression schema0)) columns
121 -- ^ the names and datatype of each column
145 -- ^ the names and datatype of each column
122− -> NP (Aliased (TableConstraintExpression schema columns)) constraints
146+ -> NP (Aliased (TableConstraintExpression schema1 table)) constraints
123 -- ^ constraints that must hold for the table
147 -- ^ constraints that must hold for the table
124− -> Definition schema (Create table (constraints :=> columns) schema)
148+ -> Definition schema0 schema1
125−createTable table columns constraints = UnsafeDefinition $
149+createTable tab columns constraints = UnsafeDefinition $
126− "CREATE TABLE" <+> renderCreation table columns constraints
150+ "CREATE TABLE" <+> renderCreation tab columns constraints
127−
151+
128−-- | `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
152+{-| `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.
153+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`.
154+`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
131−--
155+the `Category` of `Definition`s.
156+
132−-- >>> :set -XOverloadedLabels -XTypeApplications
157+>>> :set -XOverloadedLabels -XTypeApplications
133−-- >>> type Table = '[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGfloat4]
158+>>> type Table = '[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGfloat4]
134−-- >>> type Schema = '["tab" ::: Table]
159+>>> type Schema = '["tab" ::: 'Table Table]
135−-- >>> :{
160+>>> :{
136−-- renderDefinition
161+let
137−-- (createTableIfNotExists #tab (int `As` #a :* real `As` #b :* Nil) Nil :: Definition Schema Schema)
162+ setup :: Definition Schema Schema
163+ setup = createTableIfNotExists #tab ((int & nullable) `As` #a :* (real & nullable) `As` #b :* Nil) Nil
164+in printSQL setup
138−-- :}
165+:}
139−-- "CREATE TABLE IF NOT EXISTS \"tab\" (\"a\" int, \"b\" real);"
166+CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
167+-}
140createTableIfNotExists
168createTableIfNotExists
141− :: ( Has table schema (constraints :=> columns)
169+ :: ( Has table schema ('Table (constraints :=> columns))
142 , SOP.SListI columns
170 , SOP.SListI columns
143 , SOP.SListI constraints )
171 , SOP.SListI constraints )
144 => Alias table -- ^ the name of the table to add
172 => Alias table -- ^ the name of the table to add
145− -> NP (Aliased TypeExpression) columns
173+ -> NP (Aliased (ColumnTypeExpression schema)) columns
146 -- ^ the names and datatype of each column
174 -- ^ the names and datatype of each column
147− -> NP (Aliased (TableConstraintExpression schema columns)) constraints
175+ -> NP (Aliased (TableConstraintExpression schema table)) constraints
148 -- ^ constraints that must hold for the table
176 -- ^ constraints that must hold for the table
149 -> Definition schema schema
177 -> Definition schema schema
150−createTableIfNotExists table columns constraints = UnsafeDefinition $
178+createTableIfNotExists tab columns constraints = UnsafeDefinition $
151 "CREATE TABLE IF NOT EXISTS"
179 "CREATE TABLE IF NOT EXISTS"
152− <+> renderCreation table columns constraints
180+ <+> renderCreation tab columns constraints
153
181
154-- helper function for `createTable` and `createTableIfNotExists`
182-- helper function for `createTable` and `createTableIfNotExists`
155renderCreation
183renderCreation
@@ -157,12 +185,12 @@ renderCreation
157 , SOP.SListI columns
185 , SOP.SListI columns
158 , SOP.SListI constraints )
186 , SOP.SListI constraints )
159 => Alias table -- ^ the name of the table to add
187 => Alias table -- ^ the name of the table to add
160− -> NP (Aliased TypeExpression) columns
188+ -> NP (Aliased (ColumnTypeExpression schema0)) columns
161 -- ^ the names and datatype of each column
189 -- ^ the names and datatype of each column
162− -> NP (Aliased (TableConstraintExpression schema columns)) constraints
190+ -> NP (Aliased (TableConstraintExpression schema1 table)) constraints
163 -- ^ constraints that must hold for the table
191 -- ^ constraints that must hold for the table
164 -> ByteString
192 -> ByteString
165−renderCreation table columns constraints = renderAlias table
193+renderCreation tab columns constraints = renderAlias tab
166 <+> parenthesized
194 <+> parenthesized
167 ( renderCommaSeparated renderColumnDef columns
195 ( renderCommaSeparated renderColumnDef columns
168 <> ( case constraints of
196 <> ( case constraints of
@@ -171,9 +199,9 @@ renderCreation table columns constraints = renderAlias table
171 renderCommaSeparated renderConstraint constraints ) )
199 renderCommaSeparated renderConstraint constraints ) )
172 <> ";"
200 <> ";"
173 where
201 where
174− renderColumnDef :: Aliased TypeExpression x -> ByteString
202+ renderColumnDef :: Aliased (ColumnTypeExpression schema) x -> ByteString
175 renderColumnDef (ty `As` column) =
203 renderColumnDef (ty `As` column) =
176− renderAlias column <+> renderTypeExpression ty
204+ renderAlias column <+> renderColumnTypeExpression ty
177 renderConstraint
205 renderConstraint
178 :: Aliased (TableConstraintExpression schema columns) constraint
206 :: Aliased (TableConstraintExpression schema columns) constraint
179 -> ByteString
207 -> ByteString
@@ -193,156 +221,226 @@ renderCreation table columns constraints = renderAlias table
193-- violate a constraint, an error is raised. This applies
221-- violate a constraint, an error is raised. This applies
194-- even if the value came from the default value definition.
222-- even if the value came from the default value definition.
195newtype TableConstraintExpression
223newtype TableConstraintExpression
196− (schema :: TablesType)
224+ (schema :: SchemaType)
197− (columns :: ColumnsType)
225+ (table :: Symbol)
198 (tableConstraint :: TableConstraint)
226 (tableConstraint :: TableConstraint)
199 = UnsafeTableConstraintExpression
227 = UnsafeTableConstraintExpression
200 { renderTableConstraintExpression :: ByteString }
228 { renderTableConstraintExpression :: ByteString }
201 deriving (GHC.Generic,Show,Eq,Ord,NFData)
229 deriving (GHC.Generic,Show,Eq,Ord,NFData)
202
230
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.
231+{-| A `check` constraint is the most generic `TableConstraint` type.
218−-- It allows you to specify that the value in a certain column must satisfy
232+It allows you to specify that the value in a certain column must satisfy
219−-- a Boolean (truth-value) expression.
233+a Boolean (truth-value) expression.
220−--
234+
235+>>> :{
236+type Schema = '[
237+ "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
238+ "a" ::: 'NoDef :=> 'NotNull 'PGint4,
239+ "b" ::: 'NoDef :=> 'NotNull 'PGint4
240+ ])]
241+:}
242+
221−-- >>> :{
243+>>> :{
222−-- renderDefinition $
244+let
245+ definition :: Definition '[] Schema
223−-- createTable #tab
246+ definition = createTable #tab
224−-- ( (int & notNull) `As` #a :*
247+ ( (int & notNullable) `As` #a :*
225−-- (int & notNull) `As` #b :* Nil )
248+ (int & notNullable) `As` #b :* Nil )
226−-- ( check (Column #a :* Column #b :* Nil) (#a .> #b) `As` #inequality :* Nil )
249+ ( check (#a :* #b :* Nil) (#a .> #b) `As` #inequality :* Nil )
227−-- :}
250+:}
251+
252+>>> printSQL definition
228−-- "CREATE TABLE \"tab\" (\"a\" int NOT NULL, \"b\" int NOT NULL, CONSTRAINT \"inequality\" CHECK ((\"a\" > \"b\")));"
253+CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
254+-}
229check
255check
230− :: NP (Column columns) subcolumns
256+ :: ( Has alias schema ('Table table)
257+ , HasAll aliases (TableToRelation table) subcolumns )
258+ => NP Alias aliases
259+ -- ^ specify the subcolumns which are getting checked
231− -> Condition '[table ::: ColumnsToRelation subcolumns] 'Ungrouped '[]
260+ -> (forall tab. Condition schema '[tab ::: subcolumns] 'Ungrouped '[])
232− -- ^ condition to check
261+ -- ^ a closed `Condition` on those subcolumns
233− -> TableConstraintExpression schema columns ('Check (AliasesOf subcolumns))
262+ -> TableConstraintExpression schema alias ('Check aliases)
234check _cols condition = UnsafeTableConstraintExpression $
263check _cols condition = UnsafeTableConstraintExpression $
235 "CHECK" <+> parenthesized (renderExpression condition)
264 "CHECK" <+> parenthesized (renderExpression condition)
236
265
237−-- | A `unique` constraint ensure that the data contained in a column,
266+{-| 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.
267+or a group of columns, is unique among all the rows in the table.
239−--
268+
269+>>> :{
270+type Schema = '[
271+ "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
272+ "a" ::: 'NoDef :=> 'Null 'PGint4,
273+ "b" ::: 'NoDef :=> 'Null 'PGint4
274+ ])]
275+:}
276+
240−-- >>> :{
277+>>> :{
241−-- renderDefinition $
278+let
279+ definition :: Definition '[] Schema
242−-- createTable #tab
280+ definition = createTable #tab
243−-- ( int `As` #a :*
281+ ( (int & nullable) `As` #a :*
244−-- int `As` #b :* Nil )
282+ (int & nullable) `As` #b :* Nil )
245−-- ( unique (Column #a :* Column #b :* Nil) `As` #uq_a_b :* Nil )
283+ ( unique (#a :* #b :* Nil) `As` #uq_a_b :* Nil )
246−-- :}
284+:}
285+
286+>>> printSQL definition
247−-- "CREATE TABLE \"tab\" (\"a\" int, \"b\" int, CONSTRAINT \"uq_a_b\" UNIQUE (\"a\", \"b\"));"
287+CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
288+-}
248unique
289unique
249− :: SOP.SListI subcolumns
290+ :: ( Has alias schema ('Table table)
250− => NP (Column columns) subcolumns
291+ , HasAll aliases (TableToRelation table) subcolumns )
251− -- ^ unique column or group of columns
292+ => NP Alias aliases
293+ -- ^ specify subcolumns which together are unique for each row
252− -> TableConstraintExpression schema columns ('Unique (AliasesOf subcolumns))
294+ -> TableConstraintExpression schema alias ('Unique aliases)
253unique columns = UnsafeTableConstraintExpression $
295unique columns = UnsafeTableConstraintExpression $
254− "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)
296+ "UNIQUE" <+> parenthesized (commaSeparated (renderAliases columns))
255−
297+
256−-- | A `primaryKey` constraint indicates that a column, or group of columns,
298+{-| A `primaryKey` constraint indicates that a column, or group of columns,
257−-- can be used as a unique identifier for rows in the table.
299+can be used as a unique identifier for rows in the table.
258−-- This requires that the values be both unique and not null.
300+This requires that the values be both unique and not null.
259−--
301+
302+>>> :{
303+type Schema = '[
304+ "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
305+ "id" ::: 'Def :=> 'NotNull 'PGint4,
306+ "name" ::: 'NoDef :=> 'NotNull 'PGtext
307+ ])]
308+:}
309+
260−-- >>> :{
310+>>> :{
261−-- renderDefinition $
311+let
312+ definition :: Definition '[] Schema
262−-- createTable #tab
313+ definition = createTable #tab
263−-- ( serial `As` #id :*
314+ ( serial `As` #id :*
264−-- (text & notNull) `As` #name :* Nil )
315+ (text & notNullable) `As` #name :* Nil )
265−-- ( primaryKey (Column #id :* Nil) `As` #pk_id :* Nil )
316+ ( primaryKey #id `As` #pk_id :* Nil )
266−-- :}
317+:}
318+
319+>>> printSQL definition
267−-- "CREATE TABLE \"tab\" (\"id\" serial, \"name\" text NOT NULL, CONSTRAINT \"pk_id\" PRIMARY KEY (\"id\"));"
320+CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
321+-}
268primaryKey
322primaryKey
323+ :: ( Has alias schema ('Table table)
324+ , HasAll aliases (TableToColumns table) subcolumns
269− :: (SOP.SListI subcolumns, AllNotNull subcolumns)
325+ , AllNotNull subcolumns )
270− => NP (Column columns) subcolumns
326+ => NP Alias aliases
271− -- ^ identifying column or group of columns
327+ -- ^ specify the subcolumns which together form a primary key.
272− -> TableConstraintExpression schema columns ('PrimaryKey (AliasesOf subcolumns))
328+ -> TableConstraintExpression schema alias ('PrimaryKey aliases)
273primaryKey columns = UnsafeTableConstraintExpression $
329primaryKey columns = UnsafeTableConstraintExpression $
274− "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
330+ "PRIMARY KEY" <+> parenthesized (commaSeparated (renderAliases columns))
275−
331+
276−-- | A `foreignKey` specifies that the values in a column
332+{-| A `foreignKey` specifies that the values in a column
277−-- (or a group of columns) must match the values appearing in some row of
333+(or a group of columns) must match the values appearing in some row of
278−-- another table. We say this maintains the referential integrity
334+another table. We say this maintains the referential integrity
279−-- between two related tables.
335+between two related tables.
280−--
336+
281−-- >>> :{
337+>>> :{
282−-- type Schema =
338+type Schema =
283−-- '[ "users" :::
339+ '[ "users" ::: 'Table (
284−-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
340+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
285−-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
341+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
286−-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext
342+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
287−-- ]
343+ ])
288−-- , "emails" :::
344+ , "emails" ::: 'Table (
289−-- '[ "pk_emails" ::: 'PrimaryKey '["id"]
345+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
290−-- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
346+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
291−-- ] :=>
347+ ] :=>
292−-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
348+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
293−-- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
349+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
294−-- , "email" ::: 'NoDef :=> 'Null 'PGtext
350+ , "email" ::: 'NoDef :=> 'Null 'PGtext
295−-- ]
351+ ])
296−-- ]
352+ ]
297−-- :}
353+:}
298−--
354+
299−-- >>> :{
355+>>> :{
300−-- let
356+let
301−-- setup :: Definition '[] Schema
357+ setup :: Definition '[] Schema
302−-- setup =
358+ setup =
303−-- createTable #users
359+ createTable #users
304−-- ( serial `As` #id :*
360+ ( serial `As` #id :*
305−-- (text & notNull) `As` #name :* Nil )
361+ (text & notNullable) `As` #name :* Nil )
306−-- ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>>
362+ ( primaryKey #id `As` #pk_users :* Nil ) >>>
307−-- createTable #emails
363+ createTable #emails
308−-- ( serial `As` #id :*
364+ ( serial `As` #id :*
309−-- (int & notNull) `As` #user_id :*
365+ (int & notNullable) `As` #user_id :*
310−-- text `As` #email :* Nil )
366+ (text & nullable) `As` #email :* Nil )
311−-- ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
367+ ( primaryKey #id `As` #pk_emails :*
312−-- foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
368+ foreignKey #user_id #users #id
313−-- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
369+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
314−-- in renderDefinition setup
370+in printSQL setup
315−-- :}
371+:}
372+CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
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);"
373+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);
374+
375+A `foreignKey` can even be a table self-reference.
376+
377+>>> :{
378+type Schema =
379+ '[ "employees" ::: 'Table (
380+ '[ "employees_pk" ::: 'PrimaryKey '["id"]
381+ , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
382+ ] :=>
383+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
384+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
385+ , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
386+ ])
387+ ]
388+:}
389+
390+>>> :{
391+let
392+ setup :: Definition '[] Schema
393+ setup =
394+ createTable #employees
395+ ( serial `As` #id :*
396+ (text & notNullable) `As` #name :*
397+ (integer & nullable) `As` #employer_id :* Nil )
398+ ( primaryKey #id `As` #employees_pk :*
399+ foreignKey #employer_id #employees #id
400+ OnDeleteCascade OnUpdateCascade `As` #employees_employer_fk :* Nil )
401+in printSQL setup
402+:}
403+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);
404+-}
317foreignKey
405foreignKey
318− :: ForeignKeyed schema table reftable subcolumns refsubcolumns
406+ :: (ForeignKeyed schema child parent
407+ table reftable
408+ columns refcolumns
409+ constraints cols
410+ reftys tys )
319− => NP (Column columns) subcolumns
411+ => NP Alias columns
320 -- ^ column or columns in the table
412 -- ^ column or columns in the table
321− -> Alias table
413+ -> Alias parent
322 -- ^ reference table
414 -- ^ reference table
323− -> NP (Column (TableToColumns reftable)) refsubcolumns
415+ -> NP Alias refcolumns
324 -- ^ reference column or columns in the reference table
416 -- ^ reference column or columns in the reference table
325 -> OnDeleteClause
417 -> OnDeleteClause
326 -- ^ what to do when reference is deleted
418 -- ^ what to do when reference is deleted
327 -> OnUpdateClause
419 -> OnUpdateClause
328 -- ^ what to do when reference is updated
420 -- ^ what to do when reference is updated
329− -> TableConstraintExpression schema columns
421+ -> TableConstraintExpression schema child
330− ('ForeignKey (AliasesOf subcolumns) table (AliasesOf refsubcolumns))
422+ ('ForeignKey columns parent refcolumns)
331−foreignKey columns reftable refcolumns onDelete onUpdate =
332− UnsafeTableConstraintExpression $
423+foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
333− "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
424+ "FOREIGN KEY" <+> parenthesized (commaSeparated (renderAliases keys))
334− <+> "REFERENCES" <+> renderAlias reftable
425+ <+> "REFERENCES" <+> renderAlias parent
335− <+> parenthesized (renderCommaSeparated renderColumn refcolumns)
426+ <+> parenthesized (commaSeparated (renderAliases refs))
336− <+> renderOnDeleteClause onDelete
427+ <+> renderOnDeleteClause ondel
337− <+> renderOnUpdateClause onUpdate
428+ <+> renderOnUpdateClause onupd
338−
429+
339−-- | A type synonym for constraints on a table with a foreign key.
430+-- | A constraint synonym between types involved in a foreign key constraint.
340−type ForeignKeyed schema table reftable subcolumns refsubcolumns
431+type ForeignKeyed schema
432+ child parent
433+ table reftable
434+ columns refcolumns
435+ constraints cols
436+ reftys tys =
437+ ( Has child schema ('Table table)
341− = ( Has table schema reftable
438+ , Has parent schema ('Table reftable)
342− , SameTypes subcolumns refsubcolumns
439+ , HasAll columns (TableToColumns table) tys
343− , AllNotNull subcolumns
440+ , reftable ~ (constraints :=> cols)
344− , SOP.SListI subcolumns
441+ , HasAll refcolumns cols reftys
345− , SOP.SListI refsubcolumns )
442+ , SOP.AllZip SamePGType tys reftys
443+ , Uniquely refcolumns constraints )
346
444
347-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
445-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
348data OnDeleteClause
446data OnDeleteClause
@@ -389,13 +487,19 @@ DROP statements
389
487
390-- | `dropTable` removes a table from the schema.
488-- | `dropTable` removes a table from the schema.
391--
489--
490+-- >>> :{
491+-- let
492+-- definition :: Definition '["muh_table" ::: 'Table t] '[]
392−-- >>> renderDefinition $ dropTable #muh_table
493+-- definition = dropTable #muh_table
494+-- :}
495+--
496+-- >>> printSQL definition
393−-- "DROP TABLE \"muh_table\";"
497+-- DROP TABLE "muh_table";
394dropTable
498dropTable
395− :: KnownSymbol table
499+ :: Has table schema ('Table t)
396 => Alias table -- ^ table to remove
500 => Alias table -- ^ table to remove
397 -> Definition schema (Drop table schema)
501 -> Definition schema (Drop table schema)
398−dropTable table = UnsafeDefinition $ "DROP TABLE" <+> renderAlias table <> ";"
502+dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderAlias tab <> ";"
399
503
400{-----------------------------------------
504{-----------------------------------------
401ALTER statements
505ALTER statements
@@ -403,20 +507,20 @@ ALTER statements
403
507
404-- | `alterTable` changes the definition of a table from the schema.
508-- | `alterTable` changes the definition of a table from the schema.
405alterTable
509alterTable
406− :: Has tab schema table0
510+ :: KnownSymbol alias
407− => Alias tab -- ^ table to alter
511+ => Alias alias -- ^ table to alter
408− -> AlterTable schema table0 table1 -- ^ alteration to perform
512+ -> AlterTable alias table schema -- ^ alteration to perform
409− -> Definition schema (Alter tab schema table1)
513+ -> Definition schema (Alter alias ('Table table) schema)
410−alterTable table alteration = UnsafeDefinition $
514+alterTable tab alteration = UnsafeDefinition $
411 "ALTER TABLE"
515 "ALTER TABLE"
412− <+> renderAlias table
516+ <+> renderAlias tab
413 <+> renderAlterTable alteration
517 <+> renderAlterTable alteration
414 <> ";"
518 <> ";"
415
519
416-- | `alterTableRename` changes the name of a table from the schema.
520-- | `alterTableRename` changes the name of a table from the schema.
417--
521--
418−-- >>> renderDefinition $ alterTableRename #foo #bar
522+-- >>> printSQL $ alterTableRename #foo #bar
419−-- "ALTER TABLE \"foo\" RENAME TO \"bar\";"
523+-- ALTER TABLE "foo" RENAME TO "bar";
420alterTableRename
524alterTableRename
421 :: (KnownSymbol table0, KnownSymbol table1)
525 :: (KnownSymbol table0, KnownSymbol table1)
422 => Alias table0 -- ^ table to rename
526 => Alias table0 -- ^ table to rename
@@ -429,9 +533,9 @@ alterTableRename table0 table1 = UnsafeDefinition $
429-- | An `AlterTable` describes the alteration to perform on the columns
533-- | An `AlterTable` describes the alteration to perform on the columns
430-- of a table.
534-- of a table.
431newtype AlterTable
535newtype AlterTable
432− (schema :: TablesType)
536+ (alias :: Symbol)
433− (table0 :: TableType)
537+ (table :: TableType)
434− (table1 :: TableType) =
538+ (schema :: SchemaType) =
435 UnsafeAlterTable {renderAlterTable :: ByteString}
539 UnsafeAlterTable {renderAlterTable :: ByteString}
436 deriving (GHC.Generic,Show,Eq,Ord,NFData)
540 deriving (GHC.Generic,Show,Eq,Ord,NFData)
437
541
@@ -440,19 +544,21 @@ newtype AlterTable
440-- >>> :{
544-- >>> :{
441-- let
545-- let
442-- definition :: Definition
546-- definition :: Definition
443−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
547+-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]
444−-- '["tab" ::: '["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
548+-- '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]
445−-- definition = alterTable #tab (addConstraint #positive (check (Column #col :* Nil) (#col .> 0)))
549+-- definition = alterTable #tab (addConstraint #positive (check (#col :* Nil) (#col .> 0)))
446−-- in renderDefinition definition
550+-- in printSQL definition
447-- :}
551-- :}
448−-- "ALTER TABLE \"tab\" ADD CONSTRAINT \"positive\" CHECK ((\"col\" > 0));"
552+-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
449addConstraint
553addConstraint
450− :: KnownSymbol alias
554+ :: ( KnownSymbol alias
555+ , Has tab schema ('Table table0)
556+ , table0 ~ (constraints :=> columns)
557+ , table1 ~ (Create alias constraint constraints :=> columns) )
451 => Alias alias
558 => Alias alias
452− -> TableConstraintExpression schema columns constraint
559+ -> TableConstraintExpression schema tab constraint
453 -- ^ constraint to add
560 -- ^ constraint to add
454− -> AlterTable schema (constraints :=> columns)
561+ -> AlterTable tab table1 schema
455− (Create alias constraint constraints :=> columns)
456addConstraint alias constraint = UnsafeAlterTable $
562addConstraint alias constraint = UnsafeAlterTable $
457 "ADD" <+> "CONSTRAINT" <+> renderAlias alias
563 "ADD" <+> "CONSTRAINT" <+> renderAlias alias
458 <+> renderTableConstraintExpression constraint
564 <+> renderTableConstraintExpression constraint
@@ -462,19 +568,20 @@ addConstraint alias constraint = UnsafeAlterTable $
462-- >>> :{
568-- >>> :{
463-- let
569-- let
464-- definition :: Definition
570-- definition :: Definition
465−-- '["tab" ::: '["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
571+-- '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]
466−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
572+-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]
467-- definition = alterTable #tab (dropConstraint #positive)
573-- definition = alterTable #tab (dropConstraint #positive)
468−-- in renderDefinition definition
574+-- in printSQL definition
469-- :}
575-- :}
470−-- "ALTER TABLE \"tab\" DROP CONSTRAINT \"positive\";"
576+-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
471dropConstraint
577dropConstraint
472− :: KnownSymbol constraint
578+ :: ( KnownSymbol constraint
579+ , Has tab schema ('Table table0)
580+ , table0 ~ (constraints :=> columns)
581+ , table1 ~ (Drop constraint constraints :=> columns) )
473 => Alias constraint
582 => Alias constraint
474 -- ^ constraint to drop
583 -- ^ constraint to drop
475− -> AlterTable schema
584+ -> AlterTable tab table1 schema
476− (constraints :=> columns)
477− (Drop constraint constraints :=> columns)
478dropConstraint constraint = UnsafeAlterTable $
585dropConstraint constraint = UnsafeAlterTable $
479 "DROP" <+> "CONSTRAINT" <+> renderAlias constraint
586 "DROP" <+> "CONSTRAINT" <+> renderAlias constraint
480
587
@@ -486,34 +593,36 @@ class AddColumn ty where
486 -- >>> :{
593 -- >>> :{
487 -- let
594 -- let
488 -- definition :: Definition
595 -- definition :: Definition
489− -- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]]
596+ -- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]
490− -- '["tab" ::: '[] :=>
597+ -- '["tab" ::: 'Table ('[] :=>
491 -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
598 -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
492− -- , "col2" ::: 'Def :=> 'Null 'PGtext ]]
599+ -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]
493− -- definition = alterTable #tab (addColumn #col2 (text & default_ "foo"))
600+ -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
494− -- in renderDefinition definition
601+ -- in printSQL definition
495 -- :}
602 -- :}
496− -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text DEFAULT E'foo';"
603+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
497 --
604 --
498 -- >>> :{
605 -- >>> :{
499 -- let
606 -- let
500 -- definition :: Definition
607 -- definition :: Definition
501− -- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]]
608+ -- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]
502− -- '["tab" ::: '[] :=>
609+ -- '["tab" ::: 'Table ('[] :=>
503 -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
610 -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
504− -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ]]
611+ -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]
505− -- definition = alterTable #tab (addColumn #col2 text)
612+ -- definition = alterTable #tab (addColumn #col2 (text & nullable))
506− -- in renderDefinition definition
613+ -- in printSQL definition
507 -- :}
614 -- :}
508− -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text;"
615+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
509 addColumn
616 addColumn
510− :: KnownSymbol column
617+ :: ( KnownSymbol column
618+ , Has tab schema ('Table table0)
619+ , table0 ~ (constraints :=> columns)
620+ , table1 ~ (constraints :=> Create column ty columns) )
511 => Alias column -- ^ column to add
621 => Alias column -- ^ column to add
512− -> TypeExpression ty -- ^ type of the new column
622+ -> ColumnTypeExpression schema ty -- ^ type of the new column
513− -> AlterTable schema (constraints :=> columns)
623+ -> AlterTable tab table1 schema
514− (constraints :=> Create column ty columns)
515 addColumn column ty = UnsafeAlterTable $
624 addColumn column ty = UnsafeAlterTable $
516− "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
625+ "ADD COLUMN" <+> renderAlias column <+> renderColumnTypeExpression ty
517instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
626instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
518instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
627instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
519
628
@@ -525,20 +634,21 @@ instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
525-- >>> :{
634-- >>> :{
526-- let
635-- let
527-- definition :: Definition
636-- definition :: Definition
528−-- '["tab" ::: '[] :=>
637+-- '["tab" ::: 'Table ('[] :=>
529-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
638-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
530−-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ]]
639+-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]
531−-- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]]
640+-- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]
532-- definition = alterTable #tab (dropColumn #col2)
641-- definition = alterTable #tab (dropColumn #col2)
533−-- in renderDefinition definition
642+-- in printSQL definition
534-- :}
643-- :}
535−-- "ALTER TABLE \"tab\" DROP COLUMN \"col2\";"
644+-- ALTER TABLE "tab" DROP COLUMN "col2";
536dropColumn
645dropColumn
537− :: KnownSymbol column
646+ :: ( KnownSymbol column
647+ , Has tab schema ('Table table0)
648+ , table0 ~ (constraints :=> columns)
649+ , table1 ~ (constraints :=> Drop column columns) )
538 => Alias column -- ^ column to remove
650 => Alias column -- ^ column to remove
539− -> AlterTable schema
651+ -> AlterTable tab table1 schema
540− (constraints :=> columns)
541− (DropIfConstraintsInvolve column constraints :=> Drop column columns)
542dropColumn column = UnsafeAlterTable $
652dropColumn column = UnsafeAlterTable $
543 "DROP COLUMN" <+> renderAlias column
653 "DROP COLUMN" <+> renderAlias column
544
654
@@ -547,33 +657,39 @@ dropColumn column = UnsafeAlterTable $
547-- >>> :{
657-- >>> :{
548-- let
658-- let
549-- definition :: Definition
659-- definition :: Definition
550−-- '["tab" ::: '[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4]]
660+-- '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]
551−-- '["tab" ::: '[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4]]
661+-- '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]
552-- definition = alterTable #tab (renameColumn #foo #bar)
662-- definition = alterTable #tab (renameColumn #foo #bar)
553−-- in renderDefinition definition
663+-- in printSQL definition
554-- :}
664-- :}
555−-- "ALTER TABLE \"tab\" RENAME COLUMN \"foo\" TO \"bar\";"
665+-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
556renameColumn
666renameColumn
557− :: (KnownSymbol column0, KnownSymbol column1)
667+ :: ( KnownSymbol column0
668+ , KnownSymbol column1
669+ , Has tab schema ('Table table0)
670+ , table0 ~ (constraints :=> columns)
671+ , table1 ~ (constraints :=> Rename column0 column1 columns) )
558 => Alias column0 -- ^ column to rename
672 => Alias column0 -- ^ column to rename
559 -> Alias column1 -- ^ what to rename the column
673 -> Alias column1 -- ^ what to rename the column
560− -> AlterTable schema (constraints :=> columns)
674+ -> AlterTable tab table1 schema
561− (constraints :=> Rename column0 column1 columns)
562renameColumn column0 column1 = UnsafeAlterTable $
675renameColumn column0 column1 = UnsafeAlterTable $
563 "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1
676 "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1
564
677
565-- | An `alterColumn` alters a single column.
678-- | An `alterColumn` alters a single column.
566alterColumn
679alterColumn
680+ :: ( KnownSymbol column
681+ , Has tab schema ('Table table0)
682+ , table0 ~ (constraints :=> columns)
567− :: (KnownSymbol column, Has column columns ty0)
683+ , Has column columns ty0
684+ , tables1 ~ (constraints :=> Alter column ty1 columns))
568 => Alias column -- ^ column to alter
685 => Alias column -- ^ column to alter
569− -> AlterColumn ty0 ty1 -- ^ alteration to perform
686+ -> AlterColumn schema ty0 ty1 -- ^ alteration to perform
570− -> AlterTable schema (constraints :=> columns)
687+ -> AlterTable tab table1 schema
571− (constraints :=> Alter column columns ty1)
572alterColumn column alteration = UnsafeAlterTable $
688alterColumn column alteration = UnsafeAlterTable $
573 "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration
689 "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration
574
690
575-- | An `AlterColumn` describes the alteration to perform on a single column.
691-- | An `AlterColumn` describes the alteration to perform on a single column.
576−newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) =
692+newtype AlterColumn (schema :: SchemaType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
577 UnsafeAlterColumn {renderAlterColumn :: ByteString}
693 UnsafeAlterColumn {renderAlterColumn :: ByteString}
578 deriving (GHC.Generic,Show,Eq,Ord,NFData)
694 deriving (GHC.Generic,Show,Eq,Ord,NFData)
579
695
@@ -584,15 +700,15 @@ newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) =
584-- >>> :{
700-- >>> :{
585-- let
701-- let
586-- definition :: Definition
702-- definition :: Definition
587−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
703+-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
588−-- '["tab" ::: '[] :=> '["col" ::: 'Def :=> 'Null 'PGint4]]
704+-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]
589-- definition = alterTable #tab (alterColumn #col (setDefault 5))
705-- definition = alterTable #tab (alterColumn #col (setDefault 5))
590−-- in renderDefinition definition
706+-- in printSQL definition
591-- :}
707-- :}
592−-- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" SET DEFAULT 5;"
708+-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
593setDefault
709setDefault
594− :: Expression '[] 'Ungrouped '[] ty -- ^ default value to set
710+ :: Expression schema '[] 'Ungrouped '[] ty -- ^ default value to set
595− -> AlterColumn (constraint :=> ty) ('Def :=> ty)
711+ -> AlterColumn schema (constraint :=> ty) ('Def :=> ty)
596setDefault expression = UnsafeAlterColumn $
712setDefault expression = UnsafeAlterColumn $
597 "SET DEFAULT" <+> renderExpression expression
713 "SET DEFAULT" <+> renderExpression expression
598
714
@@ -601,13 +717,13 @@ setDefault expression = UnsafeAlterColumn $
601-- >>> :{
717-- >>> :{
602-- let
718-- let
603-- definition :: Definition
719-- definition :: Definition
604−-- '["tab" ::: '[] :=> '["col" ::: 'Def :=> 'Null 'PGint4]]
720+-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]
605−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
721+-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
606-- definition = alterTable #tab (alterColumn #col dropDefault)
722-- definition = alterTable #tab (alterColumn #col dropDefault)
607−-- in renderDefinition definition
723+-- in printSQL definition
608-- :}
724-- :}
609−-- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" DROP DEFAULT;"
725+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
610−dropDefault :: AlterColumn ('Def :=> ty) ('NoDef :=> ty)
726+dropDefault :: AlterColumn schema ('Def :=> ty) ('NoDef :=> ty)
611dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
727dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
612
728
613-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
729-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
@@ -617,14 +733,14 @@ dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
617-- >>> :{
733-- >>> :{
618-- let
734-- let
619-- definition :: Definition
735-- definition :: Definition
620−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
736+-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
621−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
737+-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]
622-- definition = alterTable #tab (alterColumn #col setNotNull)
738-- definition = alterTable #tab (alterColumn #col setNotNull)
623−-- in renderDefinition definition
739+-- in printSQL definition
624-- :}
740-- :}
625−-- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" SET NOT NULL;"
741+-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
626setNotNull
742setNotNull
627− :: AlterColumn (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
743+ :: AlterColumn schema (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
628setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
744setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
629
745
630-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
746-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
@@ -632,14 +748,14 @@ setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
632-- >>> :{
748-- >>> :{
633-- let
749-- let
634-- definition :: Definition
750-- definition :: Definition
635−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
751+-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]
636−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
752+-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
637-- definition = alterTable #tab (alterColumn #col dropNotNull)
753-- definition = alterTable #tab (alterColumn #col dropNotNull)
638−-- in renderDefinition definition
754+-- in printSQL definition
639-- :}
755-- :}
640−-- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" DROP NOT NULL;"
756+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
641dropNotNull
757dropNotNull
642− :: AlterColumn (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
758+ :: AlterColumn schema (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
643dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
759dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
644
760
645-- | An `alterType` converts a column to a different data type.
761-- | An `alterType` converts a column to a different data type.
@@ -649,12 +765,188 @@ dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
649-- >>> :{
765-- >>> :{
650-- let
766-- let
651-- definition :: Definition
767-- definition :: Definition
652−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
768+-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]
653−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric]]
769+-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]
654-- definition =
770-- definition =
655−-- alterTable #tab (alterColumn #col (alterType (numeric & notNull)))
771+-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
656−-- in renderDefinition definition
772+-- in printSQL definition
657-- :}
773-- :}
658−-- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" TYPE numeric NOT NULL;"
774+-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
659−alterType :: TypeExpression ty -> AlterColumn ty0 ty
775+alterType :: ColumnTypeExpression schema ty -> AlterColumn schema ty0 ty
660−alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderTypeExpression ty
776+alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
777+
778+-- | Create a view.
779+--
780+-- >>> :{
781+-- let
782+-- definition :: Definition
783+-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]
784+-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
785+-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]
786+-- definition =
787+-- createView #bc (select (#b :* #c :* Nil) (from (table #abc)))
788+-- in printSQL definition
789+-- :}
790+-- CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
791+createView
792+ :: KnownSymbol view
793+ => Alias view -- ^ the name of the view to add
794+ -> Query schema '[] relation
795+ -- ^ query
796+ -> Definition schema (Create view ('View relation) schema)
797+createView alias query = UnsafeDefinition $
798+ "CREATE" <+> "VIEW" <+> renderAlias alias <+> "AS"
799+ <+> renderQuery query <> ";"
800+
801+-- | Drop a view.
802+--
803+-- >>> :{
804+-- let
805+-- definition :: Definition
806+-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
807+-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]
808+-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]
809+-- definition = dropView #bc
810+-- in printSQL definition
811+-- :}
812+-- DROP VIEW "bc";
813+dropView
814+ :: Has view schema ('View v)
815+ => Alias view -- ^ view to remove
816+ -> Definition schema (Drop view schema)
817+dropView v = UnsafeDefinition $ "DROP VIEW" <+> renderAlias v <> ";"
818+
819+-- | Enumerated types are created using the `createTypeEnum` command, for example
820+--
821+-- >>> printSQL $ createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil)
822+-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
823+createTypeEnum
824+ :: (KnownSymbol enum, SOP.All KnownSymbol labels)
825+ => Alias enum
826+ -- ^ name of the user defined enumerated type
827+ -> NP PGlabel labels
828+ -- ^ labels of the enumerated type
829+ -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema)
830+createTypeEnum enum labels = UnsafeDefinition $
831+ "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+> "ENUM" <+>
832+ parenthesized (commaSeparated (renderLabels labels)) <> ";"
833+
834+-- | Enumerated types can also be generated from a Haskell type, for example
835+--
836+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
837+-- >>> instance SOP.Generic Schwarma
838+-- >>> instance SOP.HasDatatypeInfo Schwarma
839+-- >>> printSQL $ createTypeEnumFrom @Schwarma #schwarma
840+-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
841+createTypeEnumFrom
842+ :: forall hask enum schema.
843+ ( SOP.Generic hask
844+ , SOP.All KnownSymbol (LabelsFrom hask)
845+ , KnownSymbol enum
846+ )
847+ => Alias enum
848+ -- ^ name of the user defined enumerated type
849+ -> Definition schema (Create enum ('Typedef (EnumFrom hask)) schema)
850+createTypeEnumFrom enum = createTypeEnum enum
851+ (SOP.hpure label :: NP PGlabel (LabelsFrom hask))
852+
853+-- | `createTypeComposite` creates a composite type. The composite type is
854+-- specified by a list of attribute names and data types.
855+--
856+-- >>> printSQL $ createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil)
857+-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
858+createTypeComposite
859+ :: (KnownSymbol ty, SOP.SListI fields)
860+ => Alias ty
861+ -- ^ name of the user defined composite type
862+ -> NP (Aliased (TypeExpression schema)) fields
863+ -- ^ list of attribute names and data types
864+ -> Definition schema (Create ty ('Typedef ('PGcomposite fields)) schema)
865+createTypeComposite ty fields = UnsafeDefinition $
866+ "CREATE" <+> "TYPE" <+> renderAlias ty <+> "AS" <+> parenthesized
867+ (renderCommaSeparated renderField fields) <> ";"
868+ where
869+ renderField :: Aliased (TypeExpression schema) x -> ByteString
870+ renderField (typ `As` field) =
871+ renderAlias field <+> renderTypeExpression typ
872+
873+-- | Composite types can also be generated from a Haskell type, for example
874+--
875+-- >>> data Complex = Complex {real :: Maybe Double, imaginary :: Maybe Double} deriving GHC.Generic
876+-- >>> instance SOP.Generic Complex
877+-- >>> instance SOP.HasDatatypeInfo Complex
878+-- >>> printSQL $ createTypeCompositeFrom @Complex #complex
879+-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
880+createTypeCompositeFrom
881+ :: forall hask ty schema.
882+ ( ZipAliased (FieldNamesFrom hask) (FieldTypesFrom hask)
883+ , SOP.All (PGTyped schema) (FieldTypesFrom hask)
884+ , KnownSymbol ty
885+ )
886+ => Alias ty
887+ -- ^ name of the user defined composite type
888+ -> Definition schema (Create ty ( 'Typedef (CompositeFrom hask)) schema)
889+createTypeCompositeFrom ty = createTypeComposite ty $ zipAs
890+ (SOP.hpure Alias :: NP Alias (FieldNamesFrom hask))
891+ (SOP.hcpure (SOP.Proxy :: SOP.Proxy (PGTyped schema)) pgtype
892+ :: NP (TypeExpression schema) (FieldTypesFrom hask))
893+
894+-- | Drop a type.
895+--
896+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
897+-- >>> instance SOP.Generic Schwarma
898+-- >>> instance SOP.HasDatatypeInfo Schwarma
899+-- >>> printSQL (dropType #schwarma :: Definition '["schwarma" ::: 'Typedef (EnumFrom Schwarma)] '[])
900+-- DROP TYPE "schwarma";
901+dropType
902+ :: Has tydef schema ('Typedef ty)
903+ => Alias tydef
904+ -- ^ name of the user defined type
905+ -> Definition schema (Drop tydef schema)
906+dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderAlias tydef <> ";"
907+
908+-- | `ColumnTypeExpression`s are used in `createTable` commands.
909+newtype ColumnTypeExpression (schema :: SchemaType) (ty :: ColumnType)
910+ = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
911+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
912+
913+-- | used in `createTable` commands as a column constraint to note that
914+-- @NULL@ may be present in a column
915+nullable
916+ :: TypeExpression schema ty
917+ -> ColumnTypeExpression schema ('NoDef :=> 'Null ty)
918+nullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL"
919+
920+-- | used in `createTable` commands as a column constraint to ensure
921+-- @NULL@ is not present in a column
922+notNullable
923+ :: TypeExpression schema ty
924+ -> ColumnTypeExpression schema (def :=> 'NotNull ty)
925+notNullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL"
926+
927+-- | used in `createTable` commands as a column constraint to give a default
928+default_
929+ :: Expression schema '[] 'Ungrouped '[] ty
930+ -> ColumnTypeExpression schema ('NoDef :=> ty)
931+ -> ColumnTypeExpression schema ('Def :=> ty)
932+default_ x ty = UnsafeColumnTypeExpression $
933+ renderColumnTypeExpression ty <+> "DEFAULT" <+> renderExpression x
934+
935+-- | not a true type, but merely a notational convenience for creating
936+-- unique identifier columns with type `PGint2`
937+serial2, smallserial
938+ :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint2)
939+serial2 = UnsafeColumnTypeExpression "serial2"
940+smallserial = UnsafeColumnTypeExpression "smallserial"
941+-- | not a true type, but merely a notational convenience for creating
942+-- unique identifier columns with type `PGint4`
943+serial4, serial
944+ :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint4)
945+serial4 = UnsafeColumnTypeExpression "serial4"
946+serial = UnsafeColumnTypeExpression "serial"
947+-- | not a true type, but merely a notational convenience for creating
948+-- unique identifier columns with type `PGint8`
949+serial8, bigserial
950+ :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint8)
951+serial8 = UnsafeColumnTypeExpression "serial8"
952+bigserial = UnsafeColumnTypeExpression "bigserial"
squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+482−436
@@ -11,21 +11,15 @@ Squeal expressions are the atoms used to build statements.
11{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
11{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
12{-# LANGUAGE
12{-# LANGUAGE
13 AllowAmbiguousTypes
13 AllowAmbiguousTypes
14− , DataKinds
15 , DeriveGeneric
14 , DeriveGeneric
16− , DeriveDataTypeable
17 , FlexibleContexts
15 , FlexibleContexts
18 , FlexibleInstances
16 , FlexibleInstances
19 , FunctionalDependencies
17 , FunctionalDependencies
20− , GADTs
21 , GeneralizedNewtypeDeriving
18 , GeneralizedNewtypeDeriving
22 , LambdaCase
19 , LambdaCase
23 , MagicHash
20 , MagicHash
24 , OverloadedStrings
21 , OverloadedStrings
25− , PolyKinds
26− , RankNTypes
27 , ScopedTypeVariables
22 , ScopedTypeVariables
28− , StandaloneDeriving
29 , TypeApplications
23 , TypeApplications
30 , TypeFamilies
24 , TypeFamilies
31 , TypeInType
25 , TypeInType
@@ -33,21 +27,23 @@ Squeal expressions are the atoms used to build statements.
33 , UndecidableInstances
27 , UndecidableInstances
34#-}
28#-}
35
29
36−module Squeal.PostgreSQL.Expression
30+module Squeal.PostgreSQL.Expression
37 ( -- * Expression
31 ( -- * Expression
38 Expression (UnsafeExpression, renderExpression)
32 Expression (UnsafeExpression, renderExpression)
39− , HasParameter (param)
33+ , HasParameter (parameter)
34+ , param
40 -- ** Null
35 -- ** Null
41 , null_
36 , null_
42− , unNull
37+ , notNull
43 , coalesce
38 , coalesce
44 , fromNull
39 , fromNull
45 , isNull
40 , isNull
46− , isn'tNull
41+ , isNotNull
47 , matchNull
42 , matchNull
48 , nullIf
43 , nullIf
49− -- ** Arrays
44+ -- ** Collections
50 , array
45 , array
46+ , row
51 -- ** Functions
47 -- ** Functions
52 , unsafeBinaryOp
48 , unsafeBinaryOp
53 , unsafeUnaryOp
49 , unsafeUnaryOp
@@ -97,8 +93,6 @@ module Squeal.PostgreSQL.Expression
97 , count, countDistinct
93 , count, countDistinct
98 , every, everyDistinct
94 , every, everyDistinct
99 , max_, maxDistinct, min_, minDistinct
95 , max_, maxDistinct, min_, minDistinct
100− -- * Tables
101− , Table (UnsafeTable, renderTable)
102 -- * Types
96 -- * Types
103 , TypeExpression (UnsafeTypeExpression, renderTypeExpression)
97 , TypeExpression (UnsafeTypeExpression, renderTypeExpression)
104 , PGTyped (pgtype)
98 , PGTyped (pgtype)
@@ -115,12 +109,6 @@ module Squeal.PostgreSQL.Expression
115 , real
109 , real
116 , float8
110 , float8
117 , doublePrecision
111 , doublePrecision
118− , serial2
119− , smallserial
120− , serial4
121− , serial
122− , serial8
123− , bigserial
124 , text
112 , text
125 , char
113 , char
126 , character
114 , character
@@ -139,8 +127,6 @@ module Squeal.PostgreSQL.Expression
139 , jsonb
127 , jsonb
140 , vararray
128 , vararray
141 , fixarray
129 , fixarray
142− , notNull
143− , default_
144 -- * Re-export
130 -- * Re-export
145 , (&)
131 , (&)
146 , NP ((:*), Nil)
132 , NP ((:*), Nil)
@@ -150,7 +136,7 @@ import Control.Category
150import Control.DeepSeq
136import Control.DeepSeq
151import Data.ByteString (ByteString)
137import Data.ByteString (ByteString)
152import Data.Function ((&))
138import Data.Function ((&))
153−import Data.Monoid hiding (All)
139+import Data.Semigroup
154import Data.Ratio
140import Data.Ratio
155import Data.String
141import Data.String
156import Generics.SOP hiding (from)
142import Generics.SOP hiding (from)
@@ -178,6 +164,7 @@ values from primitive expression using arithmetic, logical,
178and other operations.
164and other operations.
179-}
165-}
180newtype Expression
166newtype Expression
167+ (schema :: SchemaType)
181 (relations :: RelationsType)
168 (relations :: RelationsType)
182 (grouping :: Grouping)
169 (grouping :: Grouping)
183 (params :: [NullityType])
170 (params :: [NullityType])
@@ -185,6 +172,9 @@ newtype Expression
185 = UnsafeExpression { renderExpression :: ByteString }
172 = UnsafeExpression { renderExpression :: ByteString }
186 deriving (GHC.Generic,Show,Eq,Ord,NFData)
173 deriving (GHC.Generic,Show,Eq,Ord,NFData)
187
174
175+instance RenderSQL (Expression schema relations grouping params ty) where
176+ renderSQL = renderExpression
177+
188{- | A `HasParameter` constraint is used to indicate a value that is
178{- | A `HasParameter` constraint is used to indicate a value that is
189supplied externally to a SQL statement.
179supplied externally to a SQL statement.
190`Squeal.PostgreSQL.PQ.manipulateParams`,
180`Squeal.PostgreSQL.PQ.manipulateParams`,
@@ -193,203 +183,302 @@ supplied externally to a SQL statement.
193separately from the SQL command string, in which case `param`s are used to
183separately from the SQL command string, in which case `param`s are used to
194refer to the out-of-line data values.
184refer to the out-of-line data values.
195-}
185-}
196−class (PGTyped (PGTypeOf ty), KnownNat n) => HasParameter
186+class KnownNat n => HasParameter
197 (n :: Nat)
187 (n :: Nat)
188+ (schema :: SchemaType)
198 (params :: [NullityType])
189 (params :: [NullityType])
199 (ty :: NullityType)
190 (ty :: NullityType)
200 | n params -> ty where
191 | n params -> ty where
192+ -- | `parameter` takes a `Nat` using type application and a `TypeExpression`.
193+ --
194+ -- >>> let expr = parameter @1 int4 :: Expression sch rels grp '[ 'Null 'PGint4] ('Null 'PGint4)
195+ -- >>> printSQL expr
196+ -- ($1 :: int4)
197+ parameter
198+ :: TypeExpression schema (PGTypeOf ty)
201− param :: Expression relations grouping params ty
199+ -> Expression schema relations grouping params ty
202− param = UnsafeExpression $ parenthesized $
200+ parameter ty = UnsafeExpression $ parenthesized $
203 "$" <> renderNat (Proxy @n) <+> "::"
201 "$" <> renderNat (Proxy @n) <+> "::"
204− <+> renderTypeExpression (pgtype @(PGTypeOf ty))
202+ <+> renderTypeExpression ty
205−instance {-# OVERLAPPING #-} PGTyped (PGTypeOf ty1)
206− => HasParameter 1 (ty1:tys) ty1
203+instance {-# OVERLAPPING #-} HasParameter 1 schema (ty1:tys) ty1
207−instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
204+instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) schema params ty)
208− => HasParameter n (ty' : params) ty
205+ => HasParameter n schema (ty' : params) ty
206+
207+-- | `param` takes a `Nat` using type application and for basic types,
208+-- infers a `TypeExpression`.
209+--
210+-- >>> let expr = param @1 :: Expression sch rels grp '[ 'Null 'PGint4] ('Null 'PGint4)
211+-- >>> printSQL expr
212+-- ($1 :: int4)
213+param
214+ :: forall n schema params relations grouping ty
215+ . (PGTyped schema (PGTypeOf ty), HasParameter n schema params ty)
216+ => Expression schema relations grouping params ty -- ^ param
217+param = parameter @n pgtype
209
218
210instance (HasUnique relation relations columns, Has column columns ty)
219instance (HasUnique relation relations columns, Has column columns ty)
211− => IsLabel column (Expression relations 'Ungrouped params ty) where
220+ => IsLabel column (Expression schema relations 'Ungrouped params ty) where
212 fromLabel = UnsafeExpression $ renderAlias (Alias @column)
221 fromLabel = UnsafeExpression $ renderAlias (Alias @column)
222+instance (HasUnique relation relations columns, Has column columns ty)
223+ => IsLabel column
224+ (Aliased (Expression schema relations 'Ungrouped params) (column ::: ty)) where
225+ fromLabel = fromLabel @column `As` Alias @column
226+instance (HasUnique relation relations columns, Has column columns ty)
227+ => IsLabel column
228+ (NP (Aliased (Expression schema relations 'Ungrouped params)) '[column ::: ty]) where
229+ fromLabel = fromLabel @column :* Nil
213
230
214instance (Has relation relations columns, Has column columns ty)
231instance (Has relation relations columns, Has column columns ty)
215− => IsQualified relation column (Expression relations 'Ungrouped params ty) where
232+ => IsQualified relation column (Expression schema relations 'Ungrouped params ty) where
216 relation ! column = UnsafeExpression $
233 relation ! column = UnsafeExpression $
217 renderAlias relation <> "." <> renderAlias column
234 renderAlias relation <> "." <> renderAlias column
218−
235+instance (Has relation relations columns, Has column columns ty)
236+ => IsQualified relation column
237+ (Aliased (Expression schema relations 'Ungrouped params) (column ::: ty)) where
238+ relation ! column = relation ! column `As` column
239+instance (Has relation relations columns, Has column columns ty)
240+ => IsQualified relation column
241+ (NP (Aliased (Expression schema relations 'Ungrouped params)) '[column ::: ty]) where
242+ relation ! column = relation ! column :* Nil
243+
219instance
244instance
220 ( HasUnique relation relations columns
245 ( HasUnique relation relations columns
221 , Has column columns ty
246 , Has column columns ty
222 , GroupedBy relation column bys
247 , GroupedBy relation column bys
223 ) => IsLabel column
248 ) => IsLabel column
224− (Expression relations ('Grouped bys) params ty) where
249+ (Expression schema relations ('Grouped bys) params ty) where
225 fromLabel = UnsafeExpression $ renderAlias (Alias @column)
250 fromLabel = UnsafeExpression $ renderAlias (Alias @column)
226−
251+instance
252+ ( HasUnique relation relations columns
253+ , Has column columns ty
254+ , GroupedBy relation column bys
255+ ) => IsLabel column
256+ ( Aliased (Expression schema relations ('Grouped bys) params)
257+ (column ::: ty) ) where
258+ fromLabel = fromLabel @column `As` Alias @column
259+instance
260+ ( HasUnique relation relations columns
261+ , Has column columns ty
262+ , GroupedBy relation column bys
263+ ) => IsLabel column
264+ ( NP (Aliased (Expression schema relations ('Grouped bys) params))
265+ '[column ::: ty] ) where
266+ fromLabel = fromLabel @column :* Nil
267+
227instance
268instance
228 ( Has relation relations columns
269 ( Has relation relations columns
229 , Has column columns ty
270 , Has column columns ty
230 , GroupedBy relation column bys
271 , GroupedBy relation column bys
231 ) => IsQualified relation column
272 ) => IsQualified relation column
232− (Expression relations ('Grouped bys) params ty) where
273+ (Expression schema relations ('Grouped bys) params ty) where
233 relation ! column = UnsafeExpression $
274 relation ! column = UnsafeExpression $
234 renderAlias relation <> "." <> renderAlias column
275 renderAlias relation <> "." <> renderAlias column
276+instance
277+ ( Has relation relations columns
278+ , Has column columns ty
279+ , GroupedBy relation column bys
280+ ) => IsQualified relation column
281+ (Aliased (Expression schema relations ('Grouped bys) params)
282+ (column ::: ty)) where
283+ relation ! column = relation ! column `As` column
284+instance
285+ ( Has relation relations columns
286+ , Has column columns ty
287+ , GroupedBy relation column bys
288+ ) => IsQualified relation column
289+ ( NP (Aliased (Expression schema relations ('Grouped bys) params))
290+ '[column ::: ty]) where
291+ relation ! column = relation ! column :* Nil
235
292
236-- | analagous to `Nothing`
293-- | analagous to `Nothing`
237--
294--
238−-- >>> renderExpression $ null_
295+-- >>> printSQL null_
239−-- "NULL"
296+-- NULL
240−null_ :: Expression relations grouping params ('Null ty)
297+null_ :: Expression schema rels grouping params ('Null ty)
241null_ = UnsafeExpression "NULL"
298null_ = UnsafeExpression "NULL"
242
299
243-- | analagous to `Just`
300-- | analagous to `Just`
244--
301--
245−-- >>> renderExpression $ unNull true
302+-- >>> printSQL $ notNull true
246−-- "TRUE"
303+-- TRUE
247−unNull
304+notNull
248− :: Expression relations grouping params ('NotNull ty)
305+ :: Expression schema rels grouping params ('NotNull ty)
249− -- ^ not @NULL@
250− -> Expression relations grouping params ('Null ty)
306+ -> Expression schema rels grouping params ('Null ty)
251−unNull = UnsafeExpression . renderExpression
307+notNull = UnsafeExpression . renderExpression
252
308
253-- | return the leftmost value which is not NULL
309-- | return the leftmost value which is not NULL
254--
310--
255−-- >>> renderExpression $ coalesce [null_, unNull true] false
311+-- >>> printSQL $ coalesce [null_, notNull true] false
256−-- "COALESCE(NULL, TRUE, FALSE)"
312+-- COALESCE(NULL, TRUE, FALSE)
257coalesce
313coalesce
258− :: [Expression relations grouping params ('Null ty)]
314+ :: [Expression schema relations grouping params ('Null ty)]
259 -- ^ @NULL@s may be present
315 -- ^ @NULL@s may be present
260− -> Expression relations grouping params ('NotNull ty)
316+ -> Expression schema relations grouping params ('NotNull ty)
261 -- ^ @NULL@ is absent
317 -- ^ @NULL@ is absent
262− -> Expression relations grouping params ('NotNull ty)
318+ -> Expression schema relations grouping params ('NotNull ty)
263coalesce nullxs notNullx = UnsafeExpression $
319coalesce nullxs notNullx = UnsafeExpression $
264 "COALESCE" <> parenthesized (commaSeparated
320 "COALESCE" <> parenthesized (commaSeparated
265 ((renderExpression <$> nullxs) <> [renderExpression notNullx]))
321 ((renderExpression <$> nullxs) <> [renderExpression notNullx]))
266
322
267-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@
323-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@
268--
324--
269−-- >>> renderExpression $ fromNull true null_
325+-- >>> printSQL $ fromNull true null_
270−-- "COALESCE(NULL, TRUE)"
326+-- COALESCE(NULL, TRUE)
271fromNull
327fromNull
272− :: Expression relations grouping params ('NotNull ty)
328+ :: Expression schema relations grouping params ('NotNull ty)
273 -- ^ what to convert @NULL@ to
329 -- ^ what to convert @NULL@ to
274− -> Expression relations grouping params ('Null ty)
330+ -> Expression schema relations grouping params ('Null ty)
275− -> Expression relations grouping params ('NotNull ty)
331+ -> Expression schema relations grouping params ('NotNull ty)
276fromNull notNullx nullx = coalesce [nullx] notNullx
332fromNull notNullx nullx = coalesce [nullx] notNullx
277
333
278−-- | >>> renderExpression $ null_ & isNull
334+-- | >>> printSQL $ null_ & isNull
279−-- "NULL IS NULL"
335+-- NULL IS NULL
280isNull
336isNull
281− :: Expression relations grouping params ('Null ty)
337+ :: Expression schema relations grouping params ('Null ty)
282 -- ^ possibly @NULL@
338 -- ^ possibly @NULL@
283− -> Condition relations grouping params
339+ -> Condition schema relations grouping params
284isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL"
340isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL"
285
341
286−-- | >>> renderExpression $ null_ & isn'tNull
342+-- | >>> printSQL $ null_ & isNotNull
287−-- "NULL IS NOT NULL"
343+-- NULL IS NOT NULL
288−isn'tNull
344+isNotNull
289− :: Expression relations grouping params ('Null ty)
345+ :: Expression schema relations grouping params ('Null ty)
290 -- ^ possibly @NULL@
346 -- ^ possibly @NULL@
291− -> Condition relations grouping params
347+ -> Condition schema relations grouping params
292−isn'tNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL"
348+isNotNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL"
293
349
294-- | analagous to `maybe` using @IS NULL@
350-- | analagous to `maybe` using @IS NULL@
295--
351--
296−-- >>> renderExpression $ matchNull true not_ null_
352+-- >>> printSQL $ matchNull true not_ null_
297−-- "CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END"
353+-- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END
298matchNull
354matchNull
299− :: Expression relations grouping params (nullty)
355+ :: Expression schema relations grouping params (nullty)
300 -- ^ what to convert @NULL@ to
356 -- ^ what to convert @NULL@ to
301− -> ( Expression relations grouping params ('NotNull ty)
357+ -> ( Expression schema relations grouping params ('NotNull ty)
302− -> Expression relations grouping params (nullty) )
358+ -> Expression schema relations grouping params (nullty) )
303 -- ^ function to perform when @NULL@ is absent
359 -- ^ function to perform when @NULL@ is absent
304− -> Expression relations grouping params ('Null ty)
360+ -> Expression schema relations grouping params ('Null ty)
305− -> Expression relations grouping params (nullty)
361+ -> Expression schema relations grouping params (nullty)
306matchNull y f x = ifThenElse (isNull x) y
362matchNull y f x = ifThenElse (isNull x) y
307 (f (UnsafeExpression (renderExpression x)))
363 (f (UnsafeExpression (renderExpression x)))
308
364
309−-- | right inverse to `fromNull`, if its arguments are equal then
365+{-| right inverse to `fromNull`, if its arguments are equal then
310−-- `nullIf` gives @NULL@.
366+`nullIf` gives @NULL@.
311−--
367+
312−-- >>> :set -XTypeApplications -XDataKinds
368+>>> :set -XTypeApplications -XDataKinds
313−-- >>> renderExpression @_ @_ @'[_] $ fromNull false (nullIf false (param @1))
369+>>> let expr = nullIf false (param @1) :: Expression schema rels grp '[ 'NotNull 'PGbool] ('Null 'PGbool)
370+>>> printSQL expr
314−-- "COALESCE(NULL IF (FALSE, ($1 :: bool)), FALSE)"
371+NULL IF (FALSE, ($1 :: bool))
372+-}
315nullIf
373nullIf
316− :: Expression relations grouping params ('NotNull ty)
374+ :: Expression schema relations grouping params ('NotNull ty)
317 -- ^ @NULL@ is absent
375 -- ^ @NULL@ is absent
318− -> Expression relations grouping params ('NotNull ty)
376+ -> Expression schema relations grouping params ('NotNull ty)
319 -- ^ @NULL@ is absent
377 -- ^ @NULL@ is absent
320− -> Expression relations grouping params ('Null ty)
378+ -> Expression schema relations grouping params ('Null ty)
321nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized
379nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized
322 (renderExpression x <> ", " <> renderExpression y)
380 (renderExpression x <> ", " <> renderExpression y)
323
381
324−-- | >>> renderExpression $ array [null_, unNull false, unNull true]
382+-- | >>> printSQL $ array [null_, notNull false, notNull true]
325−-- "ARRAY[NULL, FALSE, TRUE]"
383+-- ARRAY[NULL, FALSE, TRUE]
326array
384array
327− :: [Expression relations grouping params ('Null ty)]
385+ :: [Expression schema relations grouping params ('Null ty)]
328 -- ^ array elements
386 -- ^ array elements
329− -> Expression relations grouping params (nullity ('PGvararray ty))
387+ -> Expression schema relations grouping params (nullity ('PGvararray ty))
330array xs = UnsafeExpression $
388array xs = UnsafeExpression $
331 "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]"
389 "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]"
332
390
391+instance (KnownSymbol label, label `In` labels) => IsPGlabel label
392+ (Expression schema relations grouping params (nullity ('PGenum labels))) where
393+ label = UnsafeExpression $ renderLabel (PGlabel @label)
394+
395+-- | A row constructor is an expression that builds a row value
396+-- (also called a composite value) using values for its member fields.
397+--
398+-- >>> type Complex = PGcomposite '["real" ::: 'PGfloat8, "imaginary" ::: 'PGfloat8]
399+-- >>> let i = row (0 `As` #real :* 1 `As` #imaginary :* Nil) :: Expression '[] '[] 'Ungrouped '[] ('NotNull Complex)
400+-- >>> printSQL i
401+-- ROW(0, 1)
402+row
403+ :: SListI (Nulls fields)
404+ => NP (Aliased (Expression schema relations grouping params)) (Nulls fields)
405+ -- ^ zero or more expressions for the row field values
406+ -> Expression schema relations grouping params (nullity ('PGcomposite fields))
407+row exprs = UnsafeExpression $ "ROW" <> parenthesized
408+ (renderCommaSeparated (\ (expr `As` _) -> renderExpression expr) exprs)
409+
410+instance Has field fields ty => IsLabel field
411+ ( Expression schema relation grouping params (nullity ('PGcomposite fields))
412+ -> Expression schema relation grouping params ('Null ty) ) where
413+ fromLabel expr = UnsafeExpression $
414+ parenthesized (renderExpression expr) <> "." <>
415+ fromString (symbolVal (Proxy @field))
416+
417+instance Semigroup
418+ (Expression schema relations grouping params (nullity ('PGvararray ty))) where
419+ (<>) = unsafeBinaryOp "||"
420+
333instance Monoid
421instance Monoid
334− (Expression relations grouping params (nullity ('PGvararray ty))) where
422+ (Expression schema relations grouping params (nullity ('PGvararray ty))) where
335 mempty = array []
423 mempty = array []
336− mappend = unsafeBinaryOp "||"
424+ mappend = (<>)
337
425
338−-- | >>> renderExpression @_ @_ @'[_] $ greatest currentTimestamp [param @1]
426+-- | >>> let expr = greatest currentTimestamp [param @1] :: Expression sch rels grp '[ 'NotNull 'PGtimestamptz] ('NotNull 'PGtimestamptz)
427+-- >>> printSQL expr
339−-- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))"
428+-- GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))
340greatest
429greatest
341− :: Expression relations grouping params (nullty)
430+ :: Expression schema relations grouping params (nullty)
342 -- ^ needs at least 1 argument
431 -- ^ needs at least 1 argument
343− -> [Expression relations grouping params (nullty)]
432+ -> [Expression schema relations grouping params (nullty)]
344 -- ^ or more
433 -- ^ or more
345− -> Expression relations grouping params (nullty)
434+ -> Expression schema relations grouping params (nullty)
346greatest x xs = UnsafeExpression $ "GREATEST("
435greatest x xs = UnsafeExpression $ "GREATEST("
347 <> commaSeparated (renderExpression <$> (x:xs)) <> ")"
436 <> commaSeparated (renderExpression <$> (x:xs)) <> ")"
348
437
349−-- | >>> renderExpression $ least currentTimestamp [null_]
438+-- | >>> printSQL $ least currentTimestamp [null_]
350−-- "LEAST(CURRENT_TIMESTAMP, NULL)"
439+-- LEAST(CURRENT_TIMESTAMP, NULL)
351least
440least
352− :: Expression relations grouping params (nullty)
441+ :: Expression schema relations grouping params (nullty)
353 -- ^ needs at least 1 argument
442 -- ^ needs at least 1 argument
354− -> [Expression relations grouping params (nullty)]
443+ -> [Expression schema relations grouping params (nullty)]
355 -- ^ or more
444 -- ^ or more
356− -> Expression relations grouping params (nullty)
445+ -> Expression schema relations grouping params (nullty)
357least x xs = UnsafeExpression $ "LEAST("
446least x xs = UnsafeExpression $ "LEAST("
358 <> commaSeparated (renderExpression <$> (x:xs)) <> ")"
447 <> commaSeparated (renderExpression <$> (x:xs)) <> ")"
359
448
360−-- | >>> renderExpression $ unsafeBinaryOp "OR" true false
449+-- | >>> printSQL $ unsafeBinaryOp "OR" true false
361−-- "(TRUE OR FALSE)"
450+-- (TRUE OR FALSE)
362unsafeBinaryOp
451unsafeBinaryOp
363 :: ByteString
452 :: ByteString
364 -- ^ operator
453 -- ^ operator
365− -> Expression relations grouping params (ty0)
454+ -> Expression schema relations grouping params (ty0)
366− -> Expression relations grouping params (ty1)
455+ -> Expression schema relations grouping params (ty1)
367− -> Expression relations grouping params (ty2)
456+ -> Expression schema relations grouping params (ty2)
368unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
457unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
369 renderExpression x <+> op <+> renderExpression y
458 renderExpression x <+> op <+> renderExpression y
370
459
371−-- | >>> renderExpression $ unsafeUnaryOp "NOT" true
460+-- | >>> printSQL $ unsafeUnaryOp "NOT" true
372−-- "(NOT TRUE)"
461+-- (NOT TRUE)
373unsafeUnaryOp
462unsafeUnaryOp
374 :: ByteString
463 :: ByteString
375 -- ^ operator
464 -- ^ operator
376− -> Expression relations grouping params (ty0)
465+ -> Expression schema relations grouping params (ty0)
377− -> Expression relations grouping params (ty1)
466+ -> Expression schema relations grouping params (ty1)
378unsafeUnaryOp op x = UnsafeExpression $ parenthesized $
467unsafeUnaryOp op x = UnsafeExpression $ parenthesized $
379 op <+> renderExpression x
468 op <+> renderExpression x
380
469
381−-- | >>> renderExpression $ unsafeFunction "f" true
470+-- | >>> printSQL $ unsafeFunction "f" true
382−-- "f(TRUE)"
471+-- f(TRUE)
383unsafeFunction
472unsafeFunction
384 :: ByteString
473 :: ByteString
385 -- ^ function
474 -- ^ function
386− -> Expression relations grouping params (xty)
475+ -> Expression schema relations grouping params (xty)
387− -> Expression relations grouping params (yty)
476+ -> Expression schema relations grouping params (yty)
388unsafeFunction fun x = UnsafeExpression $
477unsafeFunction fun x = UnsafeExpression $
389 fun <> parenthesized (renderExpression x)
478 fun <> parenthesized (renderExpression x)
390
479
391instance PGNum ty
480instance PGNum ty
392− => Num (Expression relations grouping params (nullity ty)) where
481+ => Num (Expression schema relations grouping params (nullity ty)) where
393 (+) = unsafeBinaryOp "+"
482 (+) = unsafeBinaryOp "+"
394 (-) = unsafeBinaryOp "-"
483 (-) = unsafeBinaryOp "-"
395 (*) = unsafeBinaryOp "*"
484 (*) = unsafeBinaryOp "*"
@@ -401,12 +490,12 @@ instance PGNum ty
401 . show
490 . show
402
491
403instance (PGNum ty, PGFloating ty) => Fractional
492instance (PGNum ty, PGFloating ty) => Fractional
404− (Expression relations grouping params (nullity ty)) where
493+ (Expression schema relations grouping params (nullity ty)) where
405 (/) = unsafeBinaryOp "/"
494 (/) = unsafeBinaryOp "/"
406 fromRational x = fromInteger (numerator x) / fromInteger (denominator x)
495 fromRational x = fromInteger (numerator x) / fromInteger (denominator x)
407
496
408instance (PGNum ty, PGFloating ty) => Floating
497instance (PGNum ty, PGFloating ty) => Floating
409− (Expression relations grouping params (nullity ty)) where
498+ (Expression schema relations grouping params (nullity ty)) where
410 pi = UnsafeExpression "pi()"
499 pi = UnsafeExpression "pi()"
411 exp = unsafeFunction "exp"
500 exp = unsafeFunction "exp"
412 log = unsafeFunction "ln"
501 log = unsafeFunction "ln"
@@ -429,18 +518,18 @@ instance (PGNum ty, PGFloating ty) => Floating
429
518
430-- | >>> :{
519-- | >>> :{
431-- let
520-- let
432−-- expression :: Expression relations grouping params (nullity 'PGfloat4)
521+-- expression :: Expression schema relations grouping params (nullity 'PGfloat4)
433-- expression = atan2_ pi 2
522-- expression = atan2_ pi 2
434−-- in renderExpression expression
523+-- in printSQL expression
435-- :}
524-- :}
436−-- "atan2(pi(), 2)"
525+-- atan2(pi(), 2)
437atan2_
526atan2_
438 :: PGFloating float
527 :: PGFloating float
439− => Expression relations grouping params (nullity float)
528+ => Expression schema relations grouping params (nullity float)
440 -- ^ numerator
529 -- ^ numerator
441− -> Expression relations grouping params (nullity float)
530+ -> Expression schema relations grouping params (nullity float)
442 -- ^ denominator
531 -- ^ denominator
443− -> Expression relations grouping params (nullity float)
532+ -> Expression schema relations grouping params (nullity float)
444atan2_ y x = UnsafeExpression $
533atan2_ y x = UnsafeExpression $
445 "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"
534 "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"
446
535
@@ -448,14 +537,14 @@ atan2_ y x = UnsafeExpression $
448-- represents a run-time type conversion. The cast will succeed only if a
537-- represents a run-time type conversion. The cast will succeed only if a
449-- suitable type conversion operation has been defined.
538-- suitable type conversion operation has been defined.
450--
539--
451−-- | >>> renderExpression $ true & cast int4
540+-- | >>> printSQL $ true & cast int4
452−-- "(TRUE :: int4)"
541+-- (TRUE :: int4)
453cast
542cast
454− :: TypeExpression ('NoDef :=> 'Null ty1)
543+ :: TypeExpression schema ty1
455 -- ^ type to cast as
544 -- ^ type to cast as
456− -> Expression relations grouping params (nullity ty0)
545+ -> Expression schema relations grouping params (nullity ty0)
457 -- ^ value to convert
546 -- ^ value to convert
458− -> Expression relations grouping params (nullity ty1)
547+ -> Expression schema relations grouping params (nullity ty1)
459cast ty x = UnsafeExpression $ parenthesized $
548cast ty x = UnsafeExpression $ parenthesized $
460 renderExpression x <+> "::" <+> renderTypeExpression ty
549 renderExpression x <+> "::" <+> renderTypeExpression ty
461
550
@@ -463,135 +552,135 @@ cast ty x = UnsafeExpression $ parenthesized $
463--
552--
464-- >>> :{
553-- >>> :{
465-- let
554-- let
466−-- expression :: Expression relations grouping params (nullity 'PGint2)
555+-- expression :: Expression schema relations grouping params (nullity 'PGint2)
467-- expression = 5 `quot_` 2
556-- expression = 5 `quot_` 2
468−-- in renderExpression expression
557+-- in printSQL expression
469-- :}
558-- :}
470−-- "(5 / 2)"
559+-- (5 / 2)
471quot_
560quot_
472 :: PGIntegral int
561 :: PGIntegral int
473− => Expression relations grouping params (nullity int)
562+ => Expression schema relations grouping params (nullity int)
474 -- ^ numerator
563 -- ^ numerator
475− -> Expression relations grouping params (nullity int)
564+ -> Expression schema relations grouping params (nullity int)
476 -- ^ denominator
565 -- ^ denominator
477− -> Expression relations grouping params (nullity int)
566+ -> Expression schema relations grouping params (nullity int)
478quot_ = unsafeBinaryOp "/"
567quot_ = unsafeBinaryOp "/"
479
568
480-- | remainder upon integer division
569-- | remainder upon integer division
481--
570--
482-- >>> :{
571-- >>> :{
483-- let
572-- let
484−-- expression :: Expression relations grouping params (nullity 'PGint2)
573+-- expression :: Expression schema relations grouping params (nullity 'PGint2)
485-- expression = 5 `rem_` 2
574-- expression = 5 `rem_` 2
486−-- in renderExpression expression
575+-- in printSQL expression
487-- :}
576-- :}
488−-- "(5 % 2)"
577+-- (5 % 2)
489rem_
578rem_
490 :: PGIntegral int
579 :: PGIntegral int
491− => Expression relations grouping params (nullity int)
580+ => Expression schema relations grouping params (nullity int)
492 -- ^ numerator
581 -- ^ numerator
493− -> Expression relations grouping params (nullity int)
582+ -> Expression schema relations grouping params (nullity int)
494 -- ^ denominator
583 -- ^ denominator
495− -> Expression relations grouping params (nullity int)
584+ -> Expression schema relations grouping params (nullity int)
496rem_ = unsafeBinaryOp "%"
585rem_ = unsafeBinaryOp "%"
497
586
498-- | >>> :{
587-- | >>> :{
499-- let
588-- let
500−-- expression :: Expression relations grouping params (nullity 'PGfloat4)
589+-- expression :: Expression schema relations grouping params (nullity 'PGfloat4)
501-- expression = trunc pi
590-- expression = trunc pi
502−-- in renderExpression expression
591+-- in printSQL expression
503-- :}
592-- :}
504−-- "trunc(pi())"
593+-- trunc(pi())
505trunc
594trunc
506 :: PGFloating frac
595 :: PGFloating frac
507− => Expression relations grouping params (nullity frac)
596+ => Expression schema relations grouping params (nullity frac)
508 -- ^ fractional number
597 -- ^ fractional number
509− -> Expression relations grouping params (nullity frac)
598+ -> Expression schema relations grouping params (nullity frac)
510trunc = unsafeFunction "trunc"
599trunc = unsafeFunction "trunc"
511
600
512-- | >>> :{
601-- | >>> :{
513-- let
602-- let
514−-- expression :: Expression relations grouping params (nullity 'PGfloat4)
603+-- expression :: Expression schema relations grouping params (nullity 'PGfloat4)
515-- expression = round_ pi
604-- expression = round_ pi
516−-- in renderExpression expression
605+-- in printSQL expression
517-- :}
606-- :}
518−-- "round(pi())"
607+-- round(pi())
519round_
608round_
520 :: PGFloating frac
609 :: PGFloating frac
521− => Expression relations grouping params (nullity frac)
610+ => Expression schema relations grouping params (nullity frac)
522 -- ^ fractional number
611 -- ^ fractional number
523− -> Expression relations grouping params (nullity frac)
612+ -> Expression schema relations grouping params (nullity frac)
524round_ = unsafeFunction "round"
613round_ = unsafeFunction "round"
525
614
526-- | >>> :{
615-- | >>> :{
527-- let
616-- let
528−-- expression :: Expression relations grouping params (nullity 'PGfloat4)
617+-- expression :: Expression schema relations grouping params (nullity 'PGfloat4)
529-- expression = ceiling_ pi
618-- expression = ceiling_ pi
530−-- in renderExpression expression
619+-- in printSQL expression
531-- :}
620-- :}
532−-- "ceiling(pi())"
621+-- ceiling(pi())
533ceiling_
622ceiling_
534 :: PGFloating frac
623 :: PGFloating frac
535− => Expression relations grouping params (nullity frac)
624+ => Expression schema relations grouping params (nullity frac)
536 -- ^ fractional number
625 -- ^ fractional number
537− -> Expression relations grouping params (nullity frac)
626+ -> Expression schema relations grouping params (nullity frac)
538ceiling_ = unsafeFunction "ceiling"
627ceiling_ = unsafeFunction "ceiling"
539
628
540-- | A `Condition` is a boolean valued `Expression`. While SQL allows
629-- | A `Condition` is a boolean valued `Expression`. While SQL allows
541-- conditions to have @NULL@, Squeal instead chooses to disallow @NULL@,
630-- conditions to have @NULL@, Squeal instead chooses to disallow @NULL@,
542-- forcing one to handle the case of @NULL@ explicitly to produce
631-- forcing one to handle the case of @NULL@ explicitly to produce
543-- a `Condition`.
632-- a `Condition`.
544−type Condition relations grouping params =
633+type Condition schema relations grouping params =
545− Expression relations grouping params ('NotNull 'PGbool)
634+ Expression schema relations grouping params ('NotNull 'PGbool)
546
635
547−-- | >>> renderExpression true
636+-- | >>> printSQL true
548−-- "TRUE"
637+-- TRUE
549−true :: Condition relations grouping params
638+true :: Condition schema relations grouping params
550true = UnsafeExpression "TRUE"
639true = UnsafeExpression "TRUE"
551
640
552−-- | >>> renderExpression false
641+-- | >>> printSQL false
553−-- "FALSE"
642+-- FALSE
554−false :: Condition relations grouping params
643+false :: Condition schema relations grouping params
555false = UnsafeExpression "FALSE"
644false = UnsafeExpression "FALSE"
556
645
557−-- | >>> renderExpression $ not_ true
646+-- | >>> printSQL $ not_ true
558−-- "(NOT TRUE)"
647+-- (NOT TRUE)
559not_
648not_
560− :: Condition relations grouping params
649+ :: Condition schema relations grouping params
561− -> Condition relations grouping params
650+ -> Condition schema relations grouping params
562not_ = unsafeUnaryOp "NOT"
651not_ = unsafeUnaryOp "NOT"
563
652
564−-- | >>> renderExpression $ true .&& false
653+-- | >>> printSQL $ true .&& false
565−-- "(TRUE AND FALSE)"
654+-- (TRUE AND FALSE)
566(.&&)
655(.&&)
567− :: Condition relations grouping params
656+ :: Condition schema relations grouping params
568− -> Condition relations grouping params
657+ -> Condition schema relations grouping params
569− -> Condition relations grouping params
658+ -> Condition schema relations grouping params
570(.&&) = unsafeBinaryOp "AND"
659(.&&) = unsafeBinaryOp "AND"
571
660
572−-- | >>> renderExpression $ true .|| false
661+-- | >>> printSQL $ true .|| false
573−-- "(TRUE OR FALSE)"
662+-- (TRUE OR FALSE)
574(.||)
663(.||)
575− :: Condition relations grouping params
664+ :: Condition schema relations grouping params
576− -> Condition relations grouping params
665+ -> Condition schema relations grouping params
577− -> Condition relations grouping params
666+ -> Condition schema relations grouping params
578(.||) = unsafeBinaryOp "OR"
667(.||) = unsafeBinaryOp "OR"
579
668
580-- | >>> :{
669-- | >>> :{
581-- let
670-- let
582−-- expression :: Expression relations grouping params (nullity 'PGint2)
671+-- expression :: Expression schema relations grouping params (nullity 'PGint2)
583-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3
672-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3
584−-- in renderExpression expression
673+-- in printSQL expression
585-- :}
674-- :}
586−-- "CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END"
675+-- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END
587caseWhenThenElse
676caseWhenThenElse
588− :: [ ( Condition relations grouping params
677+ :: [ ( Condition schema relations grouping params
589− , Expression relations grouping params (ty)
678+ , Expression schema relations grouping params (ty)
590 ) ]
679 ) ]
591 -- ^ whens and thens
680 -- ^ whens and thens
592− -> Expression relations grouping params (ty)
681+ -> Expression schema relations grouping params (ty)
593 -- ^ else
682 -- ^ else
594− -> Expression relations grouping params (ty)
683+ -> Expression schema relations grouping params (ty)
595caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
684caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
596 [ "CASE"
685 [ "CASE"
597 , mconcat
686 , mconcat
@@ -607,103 +696,103 @@ caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
607
696
608-- | >>> :{
697-- | >>> :{
609-- let
698-- let
610−-- expression :: Expression relations grouping params (nullity 'PGint2)
699+-- expression :: Expression schema relations grouping params (nullity 'PGint2)
611-- expression = ifThenElse true 1 0
700-- expression = ifThenElse true 1 0
612−-- in renderExpression expression
701+-- in printSQL expression
613-- :}
702-- :}
614−-- "CASE WHEN TRUE THEN 1 ELSE 0 END"
703+-- CASE WHEN TRUE THEN 1 ELSE 0 END
615ifThenElse
704ifThenElse
616− :: Condition relations grouping params
705+ :: Condition schema relations grouping params
617− -> Expression relations grouping params (ty) -- ^ then
706+ -> Expression schema relations grouping params (ty) -- ^ then
618− -> Expression relations grouping params (ty) -- ^ else
707+ -> Expression schema relations grouping params (ty) -- ^ else
619− -> Expression relations grouping params (ty)
708+ -> Expression schema relations grouping params (ty)
620ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
709ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
621
710
622-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`
711-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`
623-- will produce @NULL@s if one of their arguments is @NULL@.
712-- will produce @NULL@s if one of their arguments is @NULL@.
624--
713--
625−-- >>> renderExpression $ unNull true .== null_
714+-- >>> printSQL $ notNull true .== null_
626−-- "(TRUE = NULL)"
715+-- (TRUE = NULL)
627(.==)
716(.==)
628− :: Expression relations grouping params (nullity ty) -- ^ lhs
717+ :: Expression schema relations grouping params (nullity ty) -- ^ lhs
629− -> Expression relations grouping params (nullity ty) -- ^ rhs
718+ -> Expression schema relations grouping params (nullity ty) -- ^ rhs
630− -> Expression relations grouping params (nullity 'PGbool)
719+ -> Expression schema relations grouping params (nullity 'PGbool)
631(.==) = unsafeBinaryOp "="
720(.==) = unsafeBinaryOp "="
632infix 4 .==
721infix 4 .==
633
722
634−-- | >>> renderExpression $ unNull true ./= null_
723+-- | >>> printSQL $ notNull true ./= null_
635−-- "(TRUE <> NULL)"
724+-- (TRUE <> NULL)
636(./=)
725(./=)
637− :: Expression relations grouping params (nullity ty) -- ^ lhs
726+ :: Expression schema relations grouping params (nullity ty) -- ^ lhs
638− -> Expression relations grouping params (nullity ty) -- ^ rhs
727+ -> Expression schema relations grouping params (nullity ty) -- ^ rhs
639− -> Expression relations grouping params (nullity 'PGbool)
728+ -> Expression schema relations grouping params (nullity 'PGbool)
640(./=) = unsafeBinaryOp "<>"
729(./=) = unsafeBinaryOp "<>"
641infix 4 ./=
730infix 4 ./=
642
731
643−-- | >>> renderExpression $ unNull true .>= null_
732+-- | >>> printSQL $ notNull true .>= null_
644−-- "(TRUE >= NULL)"
733+-- (TRUE >= NULL)
645(.>=)
734(.>=)
646− :: Expression relations grouping params (nullity ty) -- ^ lhs
735+ :: Expression schema relations grouping params (nullity ty) -- ^ lhs
647− -> Expression relations grouping params (nullity ty) -- ^ rhs
736+ -> Expression schema relations grouping params (nullity ty) -- ^ rhs
648− -> Expression relations grouping params (nullity 'PGbool)
737+ -> Expression schema relations grouping params (nullity 'PGbool)
649(.>=) = unsafeBinaryOp ">="
738(.>=) = unsafeBinaryOp ">="
650infix 4 .>=
739infix 4 .>=
651
740
652−-- | >>> renderExpression $ unNull true .< null_
741+-- | >>> printSQL $ notNull true .< null_
653−-- "(TRUE < NULL)"
742+-- (TRUE < NULL)
654(.<)
743(.<)
655− :: Expression relations grouping params (nullity ty) -- ^ lhs
744+ :: Expression schema relations grouping params (nullity ty) -- ^ lhs
656− -> Expression relations grouping params (nullity ty) -- ^ rhs
745+ -> Expression schema relations grouping params (nullity ty) -- ^ rhs
657− -> Expression relations grouping params (nullity 'PGbool)
746+ -> Expression schema relations grouping params (nullity 'PGbool)
658(.<) = unsafeBinaryOp "<"
747(.<) = unsafeBinaryOp "<"
659infix 4 .<
748infix 4 .<
660
749
661−-- | >>> renderExpression $ unNull true .<= null_
750+-- | >>> printSQL $ notNull true .<= null_
662−-- "(TRUE <= NULL)"
751+-- (TRUE <= NULL)
663(.<=)
752(.<=)
664− :: Expression relations grouping params (nullity ty) -- ^ lhs
753+ :: Expression schema relations grouping params (nullity ty) -- ^ lhs
665− -> Expression relations grouping params (nullity ty) -- ^ rhs
754+ -> Expression schema relations grouping params (nullity ty) -- ^ rhs
666− -> Expression relations grouping params (nullity 'PGbool)
755+ -> Expression schema relations grouping params (nullity 'PGbool)
667(.<=) = unsafeBinaryOp "<="
756(.<=) = unsafeBinaryOp "<="
668infix 4 .<=
757infix 4 .<=
669
758
670−-- | >>> renderExpression $ unNull true .> null_
759+-- | >>> printSQL $ notNull true .> null_
671−-- "(TRUE > NULL)"
760+-- (TRUE > NULL)
672(.>)
761(.>)
673− :: Expression relations grouping params (nullity ty) -- ^ lhs
762+ :: Expression schema relations grouping params (nullity ty) -- ^ lhs
674− -> Expression relations grouping params (nullity ty) -- ^ rhs
763+ -> Expression schema relations grouping params (nullity ty) -- ^ rhs
675− -> Expression relations grouping params (nullity 'PGbool)
764+ -> Expression schema relations grouping params (nullity 'PGbool)
676(.>) = unsafeBinaryOp ">"
765(.>) = unsafeBinaryOp ">"
677infix 4 .>
766infix 4 .>
678
767
679−-- | >>> renderExpression currentDate
768+-- | >>> printSQL currentDate
680−-- "CURRENT_DATE"
769+-- CURRENT_DATE
681currentDate
770currentDate
682− :: Expression relations grouping params (nullity 'PGdate)
771+ :: Expression schema relations grouping params (nullity 'PGdate)
683currentDate = UnsafeExpression "CURRENT_DATE"
772currentDate = UnsafeExpression "CURRENT_DATE"
684
773
685−-- | >>> renderExpression currentTime
774+-- | >>> printSQL currentTime
686−-- "CURRENT_TIME"
775+-- CURRENT_TIME
687currentTime
776currentTime
688− :: Expression relations grouping params (nullity 'PGtimetz)
777+ :: Expression schema relations grouping params (nullity 'PGtimetz)
689currentTime = UnsafeExpression "CURRENT_TIME"
778currentTime = UnsafeExpression "CURRENT_TIME"
690
779
691−-- | >>> renderExpression currentTimestamp
780+-- | >>> printSQL currentTimestamp
692−-- "CURRENT_TIMESTAMP"
781+-- CURRENT_TIMESTAMP
693currentTimestamp
782currentTimestamp
694− :: Expression relations grouping params (nullity 'PGtimestamptz)
783+ :: Expression schema relations grouping params (nullity 'PGtimestamptz)
695currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"
784currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"
696
785
697−-- | >>> renderExpression localTime
786+-- | >>> printSQL localTime
698−-- "LOCALTIME"
787+-- LOCALTIME
699localTime
788localTime
700− :: Expression relations grouping params (nullity 'PGtime)
789+ :: Expression schema relations grouping params (nullity 'PGtime)
701localTime = UnsafeExpression "LOCALTIME"
790localTime = UnsafeExpression "LOCALTIME"
702
791
703−-- | >>> renderExpression localTimestamp
792+-- | >>> printSQL localTimestamp
704−-- "LOCALTIMESTAMP"
793+-- LOCALTIMESTAMP
705localTimestamp
794localTimestamp
706− :: Expression relations grouping params (nullity 'PGtimestamp)
795+ :: Expression schema relations grouping params (nullity 'PGtimestamp)
707localTimestamp = UnsafeExpression "LOCALTIMESTAMP"
796localTimestamp = UnsafeExpression "LOCALTIMESTAMP"
708
797
709{-----------------------------------------
798{-----------------------------------------
@@ -711,7 +800,7 @@ text
711-----------------------------------------}
800-----------------------------------------}
712
801
713instance IsString
802instance IsString
714− (Expression relations grouping params (nullity 'PGtext)) where
803+ (Expression schema relations grouping params (nullity 'PGtext)) where
715 fromString str = UnsafeExpression $
804 fromString str = UnsafeExpression $
716 "E\'" <> fromString (escape =<< str) <> "\'"
805 "E\'" <> fromString (escape =<< str) <> "\'"
717 where
806 where
@@ -726,33 +815,37 @@ instance IsString
726 '\\' -> "\\\\"
815 '\\' -> "\\\\"
727 c -> [c]
816 c -> [c]
728
817
818+instance Semigroup
819+ (Expression schema relations grouping params (nullity 'PGtext)) where
820+ (<>) = unsafeBinaryOp "||"
821+
729instance Monoid
822instance Monoid
730− (Expression relations grouping params (nullity 'PGtext)) where
823+ (Expression schema relations grouping params (nullity 'PGtext)) where
731 mempty = fromString ""
824 mempty = fromString ""
732− mappend = unsafeBinaryOp "||"
825+ mappend = (<>)
733
826
734−-- | >>> renderExpression $ lower "ARRRGGG"
827+-- | >>> printSQL $ lower "ARRRGGG"
735−-- "lower(E'ARRRGGG')"
828+-- lower(E'ARRRGGG')
736lower
829lower
737− :: Expression relations grouping params (nullity 'PGtext)
830+ :: Expression schema relations grouping params (nullity 'PGtext)
738 -- ^ string to lower case
831 -- ^ string to lower case
739− -> Expression relations grouping params (nullity 'PGtext)
832+ -> Expression schema relations grouping params (nullity 'PGtext)
740lower = unsafeFunction "lower"
833lower = unsafeFunction "lower"
741
834
742−-- | >>> renderExpression $ upper "eeee"
835+-- | >>> printSQL $ upper "eeee"
743−-- "upper(E'eeee')"
836+-- upper(E'eeee')
744upper
837upper
745− :: Expression relations grouping params (nullity 'PGtext)
838+ :: Expression schema relations grouping params (nullity 'PGtext)
746 -- ^ string to upper case
839 -- ^ string to upper case
747− -> Expression relations grouping params (nullity 'PGtext)
840+ -> Expression schema relations grouping params (nullity 'PGtext)
748upper = unsafeFunction "upper"
841upper = unsafeFunction "upper"
749
842
750−-- | >>> renderExpression $ charLength "four"
843+-- | >>> printSQL $ charLength "four"
751−-- "char_length(E'four')"
844+-- char_length(E'four')
752charLength
845charLength
753− :: Expression relations grouping params (nullity 'PGtext)
846+ :: Expression schema relations grouping params (nullity 'PGtext)
754 -- ^ string to measure
847 -- ^ string to measure
755− -> Expression relations grouping params (nullity 'PGint4)
848+ -> Expression schema relations grouping params (nullity 'PGint4)
756charLength = unsafeFunction "char_length"
849charLength = unsafeFunction "char_length"
757
850
758-- | The `like` expression returns true if the @string@ matches
851-- | The `like` expression returns true if the @string@ matches
@@ -762,14 +855,14 @@ charLength = unsafeFunction "char_length"
762-- in pattern stands for (matches) any single character; a percent sign (%)
855-- in pattern stands for (matches) any single character; a percent sign (%)
763-- matches any sequence of zero or more characters.
856-- matches any sequence of zero or more characters.
764--
857--
765−-- >>> renderExpression $ "abc" `like` "a%"
858+-- >>> printSQL $ "abc" `like` "a%"
766−-- "(E'abc' LIKE E'a%')"
859+-- (E'abc' LIKE E'a%')
767like
860like
768− :: Expression relations grouping params (nullity 'PGtext)
861+ :: Expression schema relations grouping params (nullity 'PGtext)
769 -- ^ string
862 -- ^ string
770− -> Expression relations grouping params (nullity 'PGtext)
863+ -> Expression schema relations grouping params (nullity 'PGtext)
771 -- ^ pattern
864 -- ^ pattern
772− -> Expression relations grouping params (nullity 'PGbool)
865+ -> Expression schema relations grouping params (nullity 'PGbool)
773like = unsafeBinaryOp "LIKE"
866like = unsafeBinaryOp "LIKE"
774
867
775{-----------------------------------------
868{-----------------------------------------
@@ -779,54 +872,54 @@ aggregation
779-- | escape hatch to define aggregate functions
872-- | escape hatch to define aggregate functions
780unsafeAggregate
873unsafeAggregate
781 :: ByteString -- ^ aggregate function
874 :: ByteString -- ^ aggregate function
782− -> Expression relations 'Ungrouped params (xty)
875+ -> Expression schema relations 'Ungrouped params (xty)
783− -> Expression relations ('Grouped bys) params (yty)
876+ -> Expression schema relations ('Grouped bys) params (yty)
784unsafeAggregate fun x = UnsafeExpression $ mconcat
877unsafeAggregate fun x = UnsafeExpression $ mconcat
785 [fun, "(", renderExpression x, ")"]
878 [fun, "(", renderExpression x, ")"]
786
879
787-- | escape hatch to define aggregate functions over distinct values
880-- | escape hatch to define aggregate functions over distinct values
788unsafeAggregateDistinct
881unsafeAggregateDistinct
789 :: ByteString -- ^ aggregate function
882 :: ByteString -- ^ aggregate function
790− -> Expression relations 'Ungrouped params (xty)
883+ -> Expression schema relations 'Ungrouped params (xty)
791− -> Expression relations ('Grouped bys) params (yty)
884+ -> Expression schema relations ('Grouped bys) params (yty)
792unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat
885unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat
793 [fun, "(DISTINCT ", renderExpression x, ")"]
886 [fun, "(DISTINCT ", renderExpression x, ")"]
794
887
795-- | >>> :{
888-- | >>> :{
796-- let
889-- let
797−-- expression :: Expression '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric)
890+-- expression :: Expression schema '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric)
798-- expression = sum_ #col
891-- expression = sum_ #col
799−-- in renderExpression expression
892+-- in printSQL expression
800-- :}
893-- :}
801−-- "sum(\"col\")"
894+-- sum("col")
802sum_
895sum_
803 :: PGNum ty
896 :: PGNum ty
804− => Expression relations 'Ungrouped params (nullity ty)
897+ => Expression schema relations 'Ungrouped params (nullity ty)
805 -- ^ what to sum
898 -- ^ what to sum
806− -> Expression relations ('Grouped bys) params (nullity ty)
899+ -> Expression schema relations ('Grouped bys) params (nullity ty)
807sum_ = unsafeAggregate "sum"
900sum_ = unsafeAggregate "sum"
808
901
809-- | >>> :{
902-- | >>> :{
810-- let
903-- let
811−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric)
904+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric)
812-- expression = sumDistinct #col
905-- expression = sumDistinct #col
813−-- in renderExpression expression
906+-- in printSQL expression
814-- :}
907-- :}
815−-- "sum(DISTINCT \"col\")"
908+-- sum(DISTINCT "col")
816sumDistinct
909sumDistinct
817 :: PGNum ty
910 :: PGNum ty
818− => Expression relations 'Ungrouped params (nullity ty)
911+ => Expression schema relations 'Ungrouped params (nullity ty)
819 -- ^ what to sum
912 -- ^ what to sum
820− -> Expression relations ('Grouped bys) params (nullity ty)
913+ -> Expression schema relations ('Grouped bys) params (nullity ty)
821sumDistinct = unsafeAggregateDistinct "sum"
914sumDistinct = unsafeAggregateDistinct "sum"
822
915
823-- | A constraint for `PGType`s that you can take averages of and the resulting
916-- | A constraint for `PGType`s that you can take averages of and the resulting
824-- `PGType`.
917-- `PGType`.
825class PGAvg ty avg | ty -> avg where
918class PGAvg ty avg | ty -> avg where
826 avg, avgDistinct
919 avg, avgDistinct
827− :: Expression relations 'Ungrouped params (nullity ty)
920+ :: Expression schema relations 'Ungrouped params (nullity ty)
828 -- ^ what to average
921 -- ^ what to average
829− -> Expression relations ('Grouped bys) params (nullity avg)
922+ -> Expression schema relations ('Grouped bys) params (nullity avg)
830 avg = unsafeAggregate "avg"
923 avg = unsafeAggregate "avg"
831 avgDistinct = unsafeAggregateDistinct "avg"
924 avgDistinct = unsafeAggregateDistinct "avg"
832instance PGAvg 'PGint2 'PGnumeric
925instance PGAvg 'PGint2 'PGnumeric
@@ -839,312 +932,281 @@ instance PGAvg 'PGinterval 'PGinterval
839
932
840-- | >>> :{
933-- | >>> :{
841-- let
934-- let
842−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
935+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
843-- expression = bitAnd #col
936-- expression = bitAnd #col
844−-- in renderExpression expression
937+-- in printSQL expression
845-- :}
938-- :}
846−-- "bit_and(\"col\")"
939+-- bit_and("col")
847bitAnd
940bitAnd
848 :: PGIntegral int
941 :: PGIntegral int
849− => Expression relations 'Ungrouped params (nullity int)
942+ => Expression schema relations 'Ungrouped params (nullity int)
850 -- ^ what to aggregate
943 -- ^ what to aggregate
851− -> Expression relations ('Grouped bys) params (nullity int)
944+ -> Expression schema relations ('Grouped bys) params (nullity int)
852bitAnd = unsafeAggregate "bit_and"
945bitAnd = unsafeAggregate "bit_and"
853
946
854-- | >>> :{
947-- | >>> :{
855-- let
948-- let
856−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
949+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
857-- expression = bitOr #col
950-- expression = bitOr #col
858−-- in renderExpression expression
951+-- in printSQL expression
859-- :}
952-- :}
860−-- "bit_or(\"col\")"
953+-- bit_or("col")
861bitOr
954bitOr
862 :: PGIntegral int
955 :: PGIntegral int
863− => Expression relations 'Ungrouped params (nullity int)
956+ => Expression schema relations 'Ungrouped params (nullity int)
864 -- ^ what to aggregate
957 -- ^ what to aggregate
865− -> Expression relations ('Grouped bys) params (nullity int)
958+ -> Expression schema relations ('Grouped bys) params (nullity int)
866bitOr = unsafeAggregate "bit_or"
959bitOr = unsafeAggregate "bit_or"
867
960
868-- | >>> :{
961-- | >>> :{
869-- let
962-- let
870−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
963+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
871-- expression = bitAndDistinct #col
964-- expression = bitAndDistinct #col
872−-- in renderExpression expression
965+-- in printSQL expression
873-- :}
966-- :}
874−-- "bit_and(DISTINCT \"col\")"
967+-- bit_and(DISTINCT "col")
875bitAndDistinct
968bitAndDistinct
876 :: PGIntegral int
969 :: PGIntegral int
877− => Expression relations 'Ungrouped params (nullity int)
970+ => Expression schema relations 'Ungrouped params (nullity int)
878 -- ^ what to aggregate
971 -- ^ what to aggregate
879− -> Expression relations ('Grouped bys) params (nullity int)
972+ -> Expression schema relations ('Grouped bys) params (nullity int)
880bitAndDistinct = unsafeAggregateDistinct "bit_and"
973bitAndDistinct = unsafeAggregateDistinct "bit_and"
881
974
882-- | >>> :{
975-- | >>> :{
883-- let
976-- let
884−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
977+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
885-- expression = bitOrDistinct #col
978-- expression = bitOrDistinct #col
886−-- in renderExpression expression
979+-- in printSQL expression
887-- :}
980-- :}
888−-- "bit_or(DISTINCT \"col\")"
981+-- bit_or(DISTINCT "col")
889bitOrDistinct
982bitOrDistinct
890 :: PGIntegral int
983 :: PGIntegral int
891− => Expression relations 'Ungrouped params (nullity int)
984+ => Expression schema relations 'Ungrouped params (nullity int)
892 -- ^ what to aggregate
985 -- ^ what to aggregate
893− -> Expression relations ('Grouped bys) params (nullity int)
986+ -> Expression schema relations ('Grouped bys) params (nullity int)
894bitOrDistinct = unsafeAggregateDistinct "bit_or"
987bitOrDistinct = unsafeAggregateDistinct "bit_or"
895
988
896-- | >>> :{
989-- | >>> :{
897-- let
990-- let
898−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
991+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
899-- expression = boolAnd #col
992-- expression = boolAnd #col
900−-- in renderExpression expression
993+-- in printSQL expression
901-- :}
994-- :}
902−-- "bool_and(\"col\")"
995+-- bool_and("col")
903boolAnd
996boolAnd
904− :: Expression relations 'Ungrouped params (nullity 'PGbool)
997+ :: Expression schema relations 'Ungrouped params (nullity 'PGbool)
905 -- ^ what to aggregate
998 -- ^ what to aggregate
906− -> Expression relations ('Grouped bys) params (nullity 'PGbool)
999+ -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)
907boolAnd = unsafeAggregate "bool_and"
1000boolAnd = unsafeAggregate "bool_and"
908
1001
909-- | >>> :{
1002-- | >>> :{
910-- let
1003-- let
911−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
1004+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
912-- expression = boolOr #col
1005-- expression = boolOr #col
913−-- in renderExpression expression
1006+-- in printSQL expression
914-- :}
1007-- :}
915−-- "bool_or(\"col\")"
1008+-- bool_or("col")
916boolOr
1009boolOr
917− :: Expression relations 'Ungrouped params (nullity 'PGbool)
1010+ :: Expression schema relations 'Ungrouped params (nullity 'PGbool)
918 -- ^ what to aggregate
1011 -- ^ what to aggregate
919− -> Expression relations ('Grouped bys) params (nullity 'PGbool)
1012+ -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)
920boolOr = unsafeAggregate "bool_or"
1013boolOr = unsafeAggregate "bool_or"
921
1014
922-- | >>> :{
1015-- | >>> :{
923-- let
1016-- let
924−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
1017+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
925-- expression = boolAndDistinct #col
1018-- expression = boolAndDistinct #col
926−-- in renderExpression expression
1019+-- in printSQL expression
927-- :}
1020-- :}
928−-- "bool_and(DISTINCT \"col\")"
1021+-- bool_and(DISTINCT "col")
929boolAndDistinct
1022boolAndDistinct
930− :: Expression relations 'Ungrouped params (nullity 'PGbool)
1023+ :: Expression schema relations 'Ungrouped params (nullity 'PGbool)
931 -- ^ what to aggregate
1024 -- ^ what to aggregate
932− -> Expression relations ('Grouped bys) params (nullity 'PGbool)
1025+ -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)
933boolAndDistinct = unsafeAggregateDistinct "bool_and"
1026boolAndDistinct = unsafeAggregateDistinct "bool_and"
934
1027
935-- | >>> :{
1028-- | >>> :{
936-- let
1029-- let
937−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
1030+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
938-- expression = boolOrDistinct #col
1031-- expression = boolOrDistinct #col
939−-- in renderExpression expression
1032+-- in printSQL expression
940-- :}
1033-- :}
941−-- "bool_or(DISTINCT \"col\")"
1034+-- bool_or(DISTINCT "col")
942boolOrDistinct
1035boolOrDistinct
943− :: Expression relations 'Ungrouped params (nullity 'PGbool)
1036+ :: Expression schema relations 'Ungrouped params (nullity 'PGbool)
944 -- ^ what to aggregate
1037 -- ^ what to aggregate
945− -> Expression relations ('Grouped bys) params (nullity 'PGbool)
1038+ -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)
946boolOrDistinct = unsafeAggregateDistinct "bool_or"
1039boolOrDistinct = unsafeAggregateDistinct "bool_or"
947
1040
948-- | A special aggregation that does not require an input
1041-- | A special aggregation that does not require an input
949--
1042--
950−-- >>> renderExpression countStar
1043+-- >>> printSQL countStar
951−-- "count(*)"
1044+-- count(*)
952countStar
1045countStar
953− :: Expression relations ('Grouped bys) params ('NotNull 'PGint8)
1046+ :: Expression schema relations ('Grouped bys) params ('NotNull 'PGint8)
954countStar = UnsafeExpression $ "count(*)"
1047countStar = UnsafeExpression $ "count(*)"
955
1048
956-- | >>> :{
1049-- | >>> :{
957-- let
1050-- let
958−-- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)
1051+-- expression :: Expression schema '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)
959-- expression = count #col
1052-- expression = count #col
960−-- in renderExpression expression
1053+-- in printSQL expression
961-- :}
1054-- :}
962−-- "count(\"col\")"
1055+-- count("col")
963count
1056count
964− :: Expression relations 'Ungrouped params ty
1057+ :: Expression schema relations 'Ungrouped params ty
965 -- ^ what to count
1058 -- ^ what to count
966− -> Expression relations ('Grouped bys) params ('NotNull 'PGint8)
1059+ -> Expression schema relations ('Grouped bys) params ('NotNull 'PGint8)
967count = unsafeAggregate "count"
1060count = unsafeAggregate "count"
968
1061
969-- | >>> :{
1062-- | >>> :{
970-- let
1063-- let
971−-- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)
1064+-- expression :: Expression schema '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)
972-- expression = countDistinct #col
1065-- expression = countDistinct #col
973−-- in renderExpression expression
1066+-- in printSQL expression
974-- :}
1067-- :}
975−-- "count(DISTINCT \"col\")"
1068+-- count(DISTINCT "col")
976countDistinct
1069countDistinct
977− :: Expression relations 'Ungrouped params ty
1070+ :: Expression schema relations 'Ungrouped params ty
978 -- ^ what to count
1071 -- ^ what to count
979− -> Expression relations ('Grouped bys) params ('NotNull 'PGint8)
1072+ -> Expression schema relations ('Grouped bys) params ('NotNull 'PGint8)
980countDistinct = unsafeAggregateDistinct "count"
1073countDistinct = unsafeAggregateDistinct "count"
981
1074
982-- | synonym for `boolAnd`
1075-- | synonym for `boolAnd`
983--
1076--
984-- >>> :{
1077-- >>> :{
985-- let
1078-- let
986−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
1079+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
987-- expression = every #col
1080-- expression = every #col
988−-- in renderExpression expression
1081+-- in printSQL expression
989-- :}
1082-- :}
990−-- "every(\"col\")"
1083+-- every("col")
991every
1084every
992− :: Expression relations 'Ungrouped params (nullity 'PGbool)
1085+ :: Expression schema relations 'Ungrouped params (nullity 'PGbool)
993 -- ^ what to aggregate
1086 -- ^ what to aggregate
994− -> Expression relations ('Grouped bys) params (nullity 'PGbool)
1087+ -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)
995every = unsafeAggregate "every"
1088every = unsafeAggregate "every"
996
1089
997-- | synonym for `boolAndDistinct`
1090-- | synonym for `boolAndDistinct`
998--
1091--
999-- >>> :{
1092-- >>> :{
1000-- let
1093-- let
1001−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
1094+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
1002-- expression = everyDistinct #col
1095-- expression = everyDistinct #col
1003−-- in renderExpression expression
1096+-- in printSQL expression
1004-- :}
1097-- :}
1005−-- "every(DISTINCT \"col\")"
1098+-- every(DISTINCT "col")
1006everyDistinct
1099everyDistinct
1007− :: Expression relations 'Ungrouped params (nullity 'PGbool)
1100+ :: Expression schema relations 'Ungrouped params (nullity 'PGbool)
1008 -- ^ what to aggregate
1101 -- ^ what to aggregate
1009− -> Expression relations ('Grouped bys) params (nullity 'PGbool)
1102+ -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)
1010everyDistinct = unsafeAggregateDistinct "every"
1103everyDistinct = unsafeAggregateDistinct "every"
1011
1104
1012-- | minimum and maximum aggregation
1105-- | minimum and maximum aggregation
1013max_, min_, maxDistinct, minDistinct
1106max_, min_, maxDistinct, minDistinct
1014− :: Expression relations 'Ungrouped params (nullity ty)
1107+ :: Expression schema relations 'Ungrouped params (nullity ty)
1015 -- ^ what to aggregate
1108 -- ^ what to aggregate
1016− -> Expression relations ('Grouped bys) params (nullity ty)
1109+ -> Expression schema relations ('Grouped bys) params (nullity ty)
1017max_ = unsafeAggregate "max"
1110max_ = unsafeAggregate "max"
1018min_ = unsafeAggregate "min"
1111min_ = unsafeAggregate "min"
1019maxDistinct = unsafeAggregateDistinct "max"
1112maxDistinct = unsafeAggregateDistinct "max"
1020minDistinct = unsafeAggregateDistinct "min"
1113minDistinct = unsafeAggregateDistinct "min"
1021
1114
1022−{-----------------------------------------
1023−tables
1024−-----------------------------------------}
1025−
1026−-- | A `Table` from a table expression is a way
1027−-- to call a table reference by its alias.
1028−newtype Table
1029− (schema :: TablesType)
1030− (columns :: RelationType)
1031− = UnsafeTable { renderTable :: ByteString }
1032− deriving (GHC.Generic,Show,Eq,Ord,NFData)
1033−instance
1034− ( Has alias schema table
1035− , relation ~ ColumnsToRelation (TableToColumns table)
1036− ) => IsLabel alias (Table schema relation) where
1037− fromLabel = UnsafeTable $ renderAlias (Alias @alias)
1038−
1039{-----------------------------------------
1115{-----------------------------------------
1040type expressions
1116type expressions
1041-----------------------------------------}
1117-----------------------------------------}
1042
1118
1043-- | `TypeExpression`s are used in `cast`s and `createTable` commands.
1119-- | `TypeExpression`s are used in `cast`s and `createTable` commands.
1044−newtype TypeExpression (ty :: ColumnType)
1120+newtype TypeExpression (schema :: SchemaType) (ty :: PGType)
1045 = UnsafeTypeExpression { renderTypeExpression :: ByteString }
1121 = UnsafeTypeExpression { renderTypeExpression :: ByteString }
1046 deriving (GHC.Generic,Show,Eq,Ord,NFData)
1122 deriving (GHC.Generic,Show,Eq,Ord,NFData)
1047
1123
1124+instance (Has alias schema ('Typedef ty))
1125+ => IsLabel alias (TypeExpression schema ty) where
1126+ fromLabel = UnsafeTypeExpression (renderAlias (fromLabel @alias))
1127+
1048-- | logical Boolean (true/false)
1128-- | logical Boolean (true/false)
1049−bool :: TypeExpression ('NoDef :=> 'Null 'PGbool)
1129+bool :: TypeExpression schema 'PGbool
1050bool = UnsafeTypeExpression "bool"
1130bool = UnsafeTypeExpression "bool"
1051-- | signed two-byte integer
1131-- | signed two-byte integer
1052−int2, smallint :: TypeExpression ('NoDef :=> 'Null 'PGint2)
1132+int2, smallint :: TypeExpression schema 'PGint2
1053int2 = UnsafeTypeExpression "int2"
1133int2 = UnsafeTypeExpression "int2"
1054smallint = UnsafeTypeExpression "smallint"
1134smallint = UnsafeTypeExpression "smallint"
1055-- | signed four-byte integer
1135-- | signed four-byte integer
1056−int4, int, integer :: TypeExpression ('NoDef :=> 'Null 'PGint4)
1136+int4, int, integer :: TypeExpression schema 'PGint4
1057int4 = UnsafeTypeExpression "int4"
1137int4 = UnsafeTypeExpression "int4"
1058int = UnsafeTypeExpression "int"
1138int = UnsafeTypeExpression "int"
1059integer = UnsafeTypeExpression "integer"
1139integer = UnsafeTypeExpression "integer"
1060-- | signed eight-byte integer
1140-- | signed eight-byte integer
1061−int8, bigint :: TypeExpression ('NoDef :=> 'Null 'PGint8)
1141+int8, bigint :: TypeExpression schema 'PGint8
1062int8 = UnsafeTypeExpression "int8"
1142int8 = UnsafeTypeExpression "int8"
1063bigint = UnsafeTypeExpression "bigint"
1143bigint = UnsafeTypeExpression "bigint"
1064-- | arbitrary precision numeric type
1144-- | arbitrary precision numeric type
1065−numeric :: TypeExpression ('NoDef :=> 'Null 'PGnumeric)
1145+numeric :: TypeExpression schema 'PGnumeric
1066numeric = UnsafeTypeExpression "numeric"
1146numeric = UnsafeTypeExpression "numeric"
1067-- | single precision floating-point number (4 bytes)
1147-- | single precision floating-point number (4 bytes)
1068−float4, real :: TypeExpression ('NoDef :=> 'Null 'PGfloat4)
1148+float4, real :: TypeExpression schema 'PGfloat4
1069float4 = UnsafeTypeExpression "float4"
1149float4 = UnsafeTypeExpression "float4"
1070real = UnsafeTypeExpression "real"
1150real = UnsafeTypeExpression "real"
1071-- | double precision floating-point number (8 bytes)
1151-- | double precision floating-point number (8 bytes)
1072−float8, doublePrecision :: TypeExpression ('NoDef :=> 'Null 'PGfloat8)
1152+float8, doublePrecision :: TypeExpression schema 'PGfloat8
1073float8 = UnsafeTypeExpression "float8"
1153float8 = UnsafeTypeExpression "float8"
1074doublePrecision = UnsafeTypeExpression "double precision"
1154doublePrecision = UnsafeTypeExpression "double precision"
1075−-- | not a true type, but merely a notational convenience for creating
1076−-- unique identifier columns with type `'PGint2`
1077−serial2, smallserial
1078− :: TypeExpression ('Def :=> 'NotNull 'PGint2)
1079−serial2 = UnsafeTypeExpression "serial2"
1080−smallserial = UnsafeTypeExpression "smallserial"
1081−-- | not a true type, but merely a notational convenience for creating
1082−-- unique identifier columns with type `'PGint4`
1083−serial4, serial
1084− :: TypeExpression ('Def :=> 'NotNull 'PGint4)
1085−serial4 = UnsafeTypeExpression "serial4"
1086−serial = UnsafeTypeExpression "serial"
1087−-- | not a true type, but merely a notational convenience for creating
1088−-- unique identifier columns with type `'PGint8`
1089−serial8, bigserial
1090− :: TypeExpression ('Def :=> 'NotNull 'PGint8)
1091−serial8 = UnsafeTypeExpression "serial8"
1092−bigserial = UnsafeTypeExpression "bigserial"
1093-- | variable-length character string
1155-- | variable-length character string
1094−text :: TypeExpression ('NoDef :=> 'Null 'PGtext)
1156+text :: TypeExpression schema 'PGtext
1095text = UnsafeTypeExpression "text"
1157text = UnsafeTypeExpression "text"
1096-- | fixed-length character string
1158-- | fixed-length character string
1097char, character
1159char, character
1098 :: (KnownNat n, 1 <= n)
1160 :: (KnownNat n, 1 <= n)
1099 => proxy n
1161 => proxy n
1100− -> TypeExpression ('NoDef :=> 'Null ('PGchar n))
1162+ -> TypeExpression schema ('PGchar n)
1101char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"
1163char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"
1102character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"
1164character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"
1103-- | variable-length character string
1165-- | variable-length character string
1104varchar, characterVarying
1166varchar, characterVarying
1105 :: (KnownNat n, 1 <= n)
1167 :: (KnownNat n, 1 <= n)
1106 => proxy n
1168 => proxy n
1107− -> TypeExpression ('NoDef :=> 'Null ('PGvarchar n))
1169+ -> TypeExpression schema ('PGvarchar n)
1108varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"
1170varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"
1109characterVarying p = UnsafeTypeExpression $
1171characterVarying p = UnsafeTypeExpression $
1110 "character varying(" <> renderNat p <> ")"
1172 "character varying(" <> renderNat p <> ")"
1111-- | binary data ("byte array")
1173-- | binary data ("byte array")
1112−bytea :: TypeExpression ('NoDef :=> 'Null 'PGbytea)
1174+bytea :: TypeExpression schema 'PGbytea
1113bytea = UnsafeTypeExpression "bytea"
1175bytea = UnsafeTypeExpression "bytea"
1114-- | date and time (no time zone)
1176-- | date and time (no time zone)
1115−timestamp :: TypeExpression ('NoDef :=> 'Null 'PGtimestamp)
1177+timestamp :: TypeExpression schema 'PGtimestamp
1116timestamp = UnsafeTypeExpression "timestamp"
1178timestamp = UnsafeTypeExpression "timestamp"
1117-- | date and time, including time zone
1179-- | date and time, including time zone
1118−timestampWithTimeZone :: TypeExpression ('NoDef :=> 'Null 'PGtimestamptz)
1180+timestampWithTimeZone :: TypeExpression schema 'PGtimestamptz
1119timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
1181timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
1120-- | calendar date (year, month, day)
1182-- | calendar date (year, month, day)
1121−date :: TypeExpression ('NoDef :=> 'Null 'PGdate)
1183+date :: TypeExpression schema 'PGdate
1122date = UnsafeTypeExpression "date"
1184date = UnsafeTypeExpression "date"
1123-- | time of day (no time zone)
1185-- | time of day (no time zone)
1124−time :: TypeExpression ('NoDef :=> 'Null 'PGtime)
1186+time :: TypeExpression schema 'PGtime
1125time = UnsafeTypeExpression "time"
1187time = UnsafeTypeExpression "time"
1126-- | time of day, including time zone
1188-- | time of day, including time zone
1127−timeWithTimeZone :: TypeExpression ('NoDef :=> 'Null 'PGtimetz)
1189+timeWithTimeZone :: TypeExpression schema 'PGtimetz
1128timeWithTimeZone = UnsafeTypeExpression "time with time zone"
1190timeWithTimeZone = UnsafeTypeExpression "time with time zone"
1129-- | time span
1191-- | time span
1130−interval :: TypeExpression ('NoDef :=> 'Null 'PGinterval)
1192+interval :: TypeExpression schema 'PGinterval
1131interval = UnsafeTypeExpression "interval"
1193interval = UnsafeTypeExpression "interval"
1132-- | universally unique identifier
1194-- | universally unique identifier
1133−uuid :: TypeExpression ('NoDef :=> 'Null 'PGuuid)
1195+uuid :: TypeExpression schema 'PGuuid
1134uuid = UnsafeTypeExpression "uuid"
1196uuid = UnsafeTypeExpression "uuid"
1135-- | IPv4 or IPv6 host address
1197-- | IPv4 or IPv6 host address
1136−inet :: TypeExpression ('NoDef :=> 'Null 'PGinet)
1198+inet :: TypeExpression schema 'PGinet
1137inet = UnsafeTypeExpression "inet"
1199inet = UnsafeTypeExpression "inet"
1138-- | textual JSON data
1200-- | textual JSON data
1139−json :: TypeExpression ('NoDef :=> 'Null 'PGjson)
1201+json :: TypeExpression schema 'PGjson
1140json = UnsafeTypeExpression "json"
1202json = UnsafeTypeExpression "json"
1141-- | binary JSON data, decomposed
1203-- | binary JSON data, decomposed
1142−jsonb :: TypeExpression ('NoDef :=> 'Null 'PGjsonb)
1204+jsonb :: TypeExpression schema 'PGjsonb
1143jsonb = UnsafeTypeExpression "jsonb"
1205jsonb = UnsafeTypeExpression "jsonb"
1144-- | variable length array
1206-- | variable length array
1145vararray
1207vararray
1146− :: TypeExpression ('NoDef :=> 'Null pg)
1208+ :: TypeExpression schema pg
1147− -> TypeExpression ('NoDef :=> 'Null ('PGvararray pg))
1209+ -> TypeExpression schema ('PGvararray pg)
1148vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"
1210vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"
1149-- | fixed length array
1211-- | fixed length array
1150--
1212--
@@ -1153,52 +1215,36 @@ vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"
1153fixarray
1215fixarray
1154 :: KnownNat n
1216 :: KnownNat n
1155 => proxy n
1217 => proxy n
1156− -> TypeExpression ('NoDef :=> 'Null pg)
1218+ -> TypeExpression schema pg
1157− -> TypeExpression ('NoDef :=> 'Null ('PGfixarray n pg))
1219+ -> TypeExpression schema ('PGfixarray n pg)
1158fixarray p ty = UnsafeTypeExpression $
1220fixarray p ty = UnsafeTypeExpression $
1159 renderTypeExpression ty <> "[" <> renderNat p <> "]"
1221 renderTypeExpression ty <> "[" <> renderNat p <> "]"
1160
1222
1161−-- | used in `createTable` commands as a column constraint to ensure
1162−-- @NULL@ is not present
1163−notNull
1164− :: TypeExpression (def :=> 'Null ty)
1165− -> TypeExpression (def :=> 'NotNull ty)
1166−notNull ty = UnsafeTypeExpression $ renderTypeExpression ty <+> "NOT NULL"
1167−
1168−-- | used in `createTable` commands as a column constraint to give a default
1169−default_
1170− :: Expression '[] 'Ungrouped '[] ty
1171− -> TypeExpression ('NoDef :=> ty)
1172− -> TypeExpression ('Def :=> ty)
1173−default_ x ty = UnsafeTypeExpression $
1174− renderTypeExpression ty <+> "DEFAULT" <+> renderExpression x
1175−
1176-- | `pgtype` is a demoted version of a `PGType`
1223-- | `pgtype` is a demoted version of a `PGType`
1177−class PGTyped (ty :: PGType) where
1224+class PGTyped schema (ty :: PGType) where pgtype :: TypeExpression schema ty
1178− pgtype :: TypeExpression ('NoDef :=> 'Null ty)
1179−instance PGTyped 'PGbool where pgtype = bool
1225+instance PGTyped schema 'PGbool where pgtype = bool
1180−instance PGTyped 'PGint2 where pgtype = int2
1226+instance PGTyped schema 'PGint2 where pgtype = int2
1181−instance PGTyped 'PGint4 where pgtype = int4
1227+instance PGTyped schema 'PGint4 where pgtype = int4
1182−instance PGTyped 'PGint8 where pgtype = int8
1228+instance PGTyped schema 'PGint8 where pgtype = int8
1183−instance PGTyped 'PGnumeric where pgtype = numeric
1229+instance PGTyped schema 'PGnumeric where pgtype = numeric
1184−instance PGTyped 'PGfloat4 where pgtype = float4
1230+instance PGTyped schema 'PGfloat4 where pgtype = float4
1185−instance PGTyped 'PGfloat8 where pgtype = float8
1231+instance PGTyped schema 'PGfloat8 where pgtype = float8
1186−instance PGTyped 'PGtext where pgtype = text
1232+instance PGTyped schema 'PGtext where pgtype = text
1187instance (KnownNat n, 1 <= n)
1233instance (KnownNat n, 1 <= n)
1188− => PGTyped ('PGchar n) where pgtype = char (Proxy @n)
1234+ => PGTyped schema ('PGchar n) where pgtype = char (Proxy @n)
1189instance (KnownNat n, 1 <= n)
1235instance (KnownNat n, 1 <= n)
1190− => PGTyped ('PGvarchar n) where pgtype = varchar (Proxy @n)
1236+ => PGTyped schema ('PGvarchar n) where pgtype = varchar (Proxy @n)
1191−instance PGTyped 'PGbytea where pgtype = bytea
1237+instance PGTyped schema 'PGbytea where pgtype = bytea
1192−instance PGTyped 'PGtimestamp where pgtype = timestamp
1238+instance PGTyped schema 'PGtimestamp where pgtype = timestamp
1193−instance PGTyped 'PGtimestamptz where pgtype = timestampWithTimeZone
1239+instance PGTyped schema 'PGtimestamptz where pgtype = timestampWithTimeZone
1194−instance PGTyped 'PGdate where pgtype = date
1240+instance PGTyped schema 'PGdate where pgtype = date
1195−instance PGTyped 'PGtime where pgtype = time
1241+instance PGTyped schema 'PGtime where pgtype = time
1196−instance PGTyped 'PGtimetz where pgtype = timeWithTimeZone
1242+instance PGTyped schema 'PGtimetz where pgtype = timeWithTimeZone
1197−instance PGTyped 'PGinterval where pgtype = interval
1243+instance PGTyped schema 'PGinterval where pgtype = interval
1198−instance PGTyped 'PGuuid where pgtype = uuid
1244+instance PGTyped schema 'PGuuid where pgtype = uuid
1199−instance PGTyped 'PGjson where pgtype = json
1245+instance PGTyped schema 'PGjson where pgtype = json
1200−instance PGTyped 'PGjsonb where pgtype = jsonb
1246+instance PGTyped schema 'PGjsonb where pgtype = jsonb
1201−instance PGTyped ty => PGTyped ('PGvararray ty) where
1247+instance PGTyped schema ty => PGTyped schema ('PGvararray ty) where
1202− pgtype = vararray (pgtype @ty)
1248+ pgtype = vararray (pgtype @schema @ty)
1203−instance (KnownNat n, PGTyped ty) => PGTyped ('PGfixarray n ty) where
1249+instance (KnownNat n, PGTyped schema ty) => PGTyped schema ('PGfixarray n ty) where
1204− pgtype = fixarray (Proxy @n) (pgtype @ty)
1250+ pgtype = fixarray (Proxy @n) (pgtype @schema @ty)
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+107−112
@@ -9,17 +9,13 @@ Squeal data manipulation language.
9-}
9-}
10
10
11{-# LANGUAGE
11{-# LANGUAGE
12− DataKinds
13− , DeriveDataTypeable
14− , DeriveGeneric
12+ DeriveGeneric
15 , FlexibleContexts
13 , FlexibleContexts
16 , GADTs
14 , GADTs
17 , GeneralizedNewtypeDeriving
15 , GeneralizedNewtypeDeriving
18− , KindSignatures
19 , LambdaCase
16 , LambdaCase
20 , OverloadedStrings
17 , OverloadedStrings
21 , RankNTypes
18 , RankNTypes
22− , StandaloneDeriving
23 , TypeInType
19 , TypeInType
24 , TypeOperators
20 , TypeOperators
25#-}
21#-}
@@ -54,7 +50,6 @@ import Control.DeepSeq
54import Data.ByteString hiding (foldr)
50import Data.ByteString hiding (foldr)
55import Data.Monoid
51import Data.Monoid
56
52
57−import qualified Data.ByteString as ByteString
58import qualified Generics.SOP as SOP
53import qualified Generics.SOP as SOP
59import qualified GHC.Generics as GHC
54import qualified GHC.Generics as GHC
60
55
@@ -73,55 +68,55 @@ simple insert:
73>>> :{
68>>> :{
74let
69let
75 manipulation :: Manipulation
70 manipulation :: Manipulation
76− '[ "tab" ::: '[] :=>
71+ '[ "tab" ::: 'Table ('[] :=>
77 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
72 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
78− , "col2" ::: 'Def :=> 'NotNull 'PGint4 ]] '[] '[]
73+ , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[] '[]
79 manipulation =
74 manipulation =
80 insertRow_ #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil)
75 insertRow_ #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil)
81−in renderManipulation manipulation
76+in printSQL manipulation
82:}
77:}
83−"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT);"
78+INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)
84
79
85parameterized insert:
80parameterized insert:
86
81
87>>> :{
82>>> :{
88let
83let
89 manipulation :: Manipulation
84 manipulation :: Manipulation
90− '[ "tab" ::: '[] :=>
85+ '[ "tab" ::: 'Table ('[] :=>
91 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
86 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
92− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]
87+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]
93 '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]
88 '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]
94 manipulation =
89 manipulation =
95 insertRow_ #tab
90 insertRow_ #tab
96 (Set (param @1) `As` #col1 :* Set (param @2) `As` #col2 :* Nil)
91 (Set (param @1) `As` #col1 :* Set (param @2) `As` #col2 :* Nil)
97−in renderManipulation manipulation
92+in printSQL manipulation
98:}
93:}
99−"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (($1 :: int4), ($2 :: int4));"
94+INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))
100
95
101returning insert:
96returning insert:
102
97
103>>> :{
98>>> :{
104let
99let
105 manipulation :: Manipulation
100 manipulation :: Manipulation
106− '[ "tab" ::: '[] :=>
101+ '[ "tab" ::: 'Table ('[] :=>
107 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
102 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
108− , "col2" ::: 'Def :=> 'NotNull 'PGint4 ]] '[]
103+ , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[]
109 '["fromOnly" ::: 'NotNull 'PGint4]
104 '["fromOnly" ::: 'NotNull 'PGint4]
110 manipulation =
105 manipulation =
111 insertRow #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil)
106 insertRow #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil)
112 OnConflictDoRaise (Returning (#col1 `As` #fromOnly :* Nil))
107 OnConflictDoRaise (Returning (#col1 `As` #fromOnly :* Nil))
113−in renderManipulation manipulation
108+in printSQL manipulation
114:}
109:}
115−"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT) RETURNING \"col1\" AS \"fromOnly\";"
110+INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT) RETURNING "col1" AS "fromOnly"
116
111
117upsert:
112upsert:
118
113
119>>> :{
114>>> :{
120let
115let
121 manipulation :: Manipulation
116 manipulation :: Manipulation
122− '[ "tab" ::: '[] :=>
117+ '[ "tab" ::: 'Table ('[] :=>
123 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
118 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
124− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]
119+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]
125 '[] '[ "sum" ::: 'NotNull 'PGint4]
120 '[] '[ "sum" ::: 'NotNull 'PGint4]
126 manipulation =
121 manipulation =
127 insertRows #tab
122 insertRows #tab
@@ -131,73 +126,76 @@ let
131 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
126 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
132 [#col1 .== #col2])
127 [#col1 .== #col2])
133 (Returning $ (#col1 + #col2) `As` #sum :* Nil)
128 (Returning $ (#col1 + #col2) `As` #sum :* Nil)
134−in renderManipulation manipulation
129+in printSQL manipulation
135:}
130:}
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\";"
131+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"
137
132
138query insert:
133query insert:
139
134
140>>> :{
135>>> :{
141let
136let
142 manipulation :: Manipulation
137 manipulation :: Manipulation
143− '[ "tab" ::: '[] :=>
138+ '[ "tab" ::: 'Table ('[] :=>
144 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
139 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
145 , "col2" ::: 'NoDef :=> 'NotNull 'PGint4
140 , "col2" ::: 'NoDef :=> 'NotNull 'PGint4
146− ]
141+ ])
147− , "other_tab" ::: '[] :=>
142+ , "other_tab" ::: 'Table ('[] :=>
148 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
143 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
149 , "col2" ::: 'NoDef :=> 'NotNull 'PGint4
144 , "col2" ::: 'NoDef :=> 'NotNull 'PGint4
150− ]
145+ ])
151 ] '[] '[]
146 ] '[] '[]
152− manipulation =
147+ manipulation =
153 insertQuery_ #tab
148 insertQuery_ #tab
154 (selectStar (from (table (#other_tab `As` #t))))
149 (selectStar (from (table (#other_tab `As` #t))))
155−in renderManipulation manipulation
150+in printSQL manipulation
156:}
151:}
157−"INSERT INTO \"tab\" SELECT * FROM \"other_tab\" AS \"t\";"
152+INSERT INTO "tab" SELECT * FROM "other_tab" AS "t"
158
153
159update:
154update:
160
155
161>>> :{
156>>> :{
162let
157let
163 manipulation :: Manipulation
158 manipulation :: Manipulation
164− '[ "tab" ::: '[] :=>
159+ '[ "tab" ::: 'Table ('[] :=>
165 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
160 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
166− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[] '[]
161+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[]
167 manipulation =
162 manipulation =
168 update_ #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
163 update_ #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
169 (#col1 ./= #col2)
164 (#col1 ./= #col2)
170−in renderManipulation manipulation
165+in printSQL manipulation
171:}
166:}
172−"UPDATE \"tab\" SET \"col1\" = 2 WHERE (\"col1\" <> \"col2\");"
167+UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")
173
168
174delete:
169delete:
175
170
176>>> :{
171>>> :{
177let
172let
178 manipulation :: Manipulation
173 manipulation :: Manipulation
179− '[ "tab" ::: '[] :=>
174+ '[ "tab" ::: 'Table ('[] :=>
180 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
175 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
181− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[]
176+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[]
182 '[ "col1" ::: 'NotNull 'PGint4
177 '[ "col1" ::: 'NotNull 'PGint4
183 , "col2" ::: 'NotNull 'PGint4 ]
178 , "col2" ::: 'NotNull 'PGint4 ]
184 manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar
179 manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar
185−in renderManipulation manipulation
180+in printSQL manipulation
186:}
181:}
187−"DELETE FROM \"tab\" WHERE (\"col1\" = \"col2\") RETURNING *;"
182+DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING *
188-}
183-}
189newtype Manipulation
184newtype Manipulation
190− (schema :: TablesType)
185+ (schema :: SchemaType)
191 (params :: [NullityType])
186 (params :: [NullityType])
192 (columns :: RelationType)
187 (columns :: RelationType)
193 = UnsafeManipulation { renderManipulation :: ByteString }
188 = UnsafeManipulation { renderManipulation :: ByteString }
194 deriving (GHC.Generic,Show,Eq,Ord,NFData)
189 deriving (GHC.Generic,Show,Eq,Ord,NFData)
195
190
191+instance RenderSQL (Manipulation schema params columns) where
192+ renderSQL = renderManipulation
193+
196-- | Convert a `Query` into a `Manipulation`.
194-- | Convert a `Query` into a `Manipulation`.
197queryStatement
195queryStatement
198 :: Query schema params columns
196 :: Query schema params columns
199 -> Manipulation schema params columns
197 -> Manipulation schema params columns
200−queryStatement q = UnsafeManipulation $ renderQuery q <> ";"
198+queryStatement q = UnsafeManipulation $ renderQuery q
201
199
202{-----------------------------------------
200{-----------------------------------------
203INSERT statements
201INSERT statements
@@ -213,27 +211,27 @@ INSERT statements
213insertRows
211insertRows
214 :: ( SOP.SListI columns
212 :: ( SOP.SListI columns
215 , SOP.SListI results
213 , SOP.SListI results
216− , Has tab schema table
214+ , Has tab schema ('Table table)
217 , columns ~ TableToColumns table )
215 , columns ~ TableToColumns table )
218 => Alias tab -- ^ table to insert into
216 => Alias tab -- ^ table to insert into
219− -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert
217+ -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert
220− -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert
218+ -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert
221− -> ConflictClause columns params
219+ -> ConflictClause schema columns params
222 -- ^ what to do in case of constraint conflict
220 -- ^ what to do in case of constraint conflict
223− -> ReturningClause columns params results -- ^ results to return
221+ -> ReturningClause schema columns params results -- ^ results to return
224 -> Manipulation schema params results
222 -> Manipulation schema params results
225−insertRows tab row rows conflict returning = UnsafeManipulation $
223+insertRows tab rw rws conflict returning = UnsafeManipulation $
226 "INSERT" <+> "INTO" <+> renderAlias tab
224 "INSERT" <+> "INTO" <+> renderAlias tab
227− <+> parenthesized (renderCommaSeparated renderAliasPart row)
225+ <+> parenthesized (renderCommaSeparated renderAliasPart rw)
228 <+> "VALUES"
226 <+> "VALUES"
229 <+> commaSeparated
227 <+> commaSeparated
230 ( parenthesized
228 ( parenthesized
231− . renderCommaSeparated renderColumnValuePart <$> row:rows )
229+ . renderCommaSeparated renderColumnValuePart <$> rw:rws )
232 <> renderConflictClause conflict
230 <> renderConflictClause conflict
233 <> renderReturningClause returning
231 <> renderReturningClause returning
234 where
232 where
235 renderAliasPart, renderColumnValuePart
233 renderAliasPart, renderColumnValuePart
236− :: Aliased (ColumnValue '[] params) ty -> ByteString
234+ :: Aliased (ColumnValue schema '[] params) ty -> ByteString
237 renderAliasPart (_ `As` name) = renderAlias name
235 renderAliasPart (_ `As` name) = renderAlias name
238 renderColumnValuePart (value `As` _) = case value of
236 renderColumnValuePart (value `As` _) = case value of
239 Default -> "DEFAULT"
237 Default -> "DEFAULT"
@@ -243,49 +241,49 @@ insertRows tab row rows conflict returning = UnsafeManipulation $
243insertRow
241insertRow
244 :: ( SOP.SListI columns
242 :: ( SOP.SListI columns
245 , SOP.SListI results
243 , SOP.SListI results
246− , Has tab schema table
244+ , Has tab schema ('Table table)
247 , columns ~ TableToColumns table )
245 , columns ~ TableToColumns table )
248 => Alias tab -- ^ table to insert into
246 => Alias tab -- ^ table to insert into
249− -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert
247+ -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert
250− -> ConflictClause columns params
248+ -> ConflictClause schema columns params
251 -- ^ what to do in case of constraint conflict
249 -- ^ what to do in case of constraint conflict
252− -> ReturningClause columns params results -- ^ results to return
250+ -> ReturningClause schema columns params results -- ^ results to return
253 -> Manipulation schema params results
251 -> Manipulation schema params results
254−insertRow tab row = insertRows tab row []
252+insertRow tab rw = insertRows tab rw []
255
253
256-- | Insert multiple rows returning `Nil` and raising an error on conflicts.
254-- | Insert multiple rows returning `Nil` and raising an error on conflicts.
257insertRows_
255insertRows_
258 :: ( SOP.SListI columns
256 :: ( SOP.SListI columns
259− , Has tab schema table
257+ , Has tab schema ('Table table)
260 , columns ~ TableToColumns table )
258 , columns ~ TableToColumns table )
261 => Alias tab -- ^ table to insert into
259 => Alias tab -- ^ table to insert into
262− -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert
260+ -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert
263− -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert
261+ -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert
264 -> Manipulation schema params '[]
262 -> Manipulation schema params '[]
265−insertRows_ tab row rows =
263+insertRows_ tab rw rws =
266− insertRows tab row rows OnConflictDoRaise (Returning Nil)
264+ insertRows tab rw rws OnConflictDoRaise (Returning Nil)
267
265
268-- | Insert a single row returning `Nil` and raising an error on conflicts.
266-- | Insert a single row returning `Nil` and raising an error on conflicts.
269insertRow_
267insertRow_
270 :: ( SOP.SListI columns
268 :: ( SOP.SListI columns
271− , Has tab schema table
269+ , Has tab schema ('Table table)
272 , columns ~ TableToColumns table )
270 , columns ~ TableToColumns table )
273 => Alias tab -- ^ table to insert into
271 => Alias tab -- ^ table to insert into
274− -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert
272+ -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert
275 -> Manipulation schema params '[]
273 -> Manipulation schema params '[]
276−insertRow_ tab row = insertRow tab row OnConflictDoRaise (Returning Nil)
274+insertRow_ tab rw = insertRow tab rw OnConflictDoRaise (Returning Nil)
277
275
278-- | Insert a `Query`.
276-- | Insert a `Query`.
279insertQuery
277insertQuery
280 :: ( SOP.SListI columns
278 :: ( SOP.SListI columns
281 , SOP.SListI results
279 , SOP.SListI results
282− , Has tab schema table
280+ , Has tab schema ('Table table)
283 , columns ~ TableToColumns table )
281 , columns ~ TableToColumns table )
284 => Alias tab -- ^ table to insert into
282 => Alias tab -- ^ table to insert into
285 -> Query schema params (ColumnsToRelation columns)
283 -> Query schema params (ColumnsToRelation columns)
286− -> ConflictClause columns params
284+ -> ConflictClause schema columns params
287 -- ^ what to do in case of constraint conflict
285 -- ^ what to do in case of constraint conflict
288− -> ReturningClause columns params results -- ^ results to return
286+ -> ReturningClause schema columns params results -- ^ results to return
289 -> Manipulation schema params results
287 -> Manipulation schema params results
290insertQuery tab query conflict returning = UnsafeManipulation $
288insertQuery tab query conflict returning = UnsafeManipulation $
291 "INSERT" <+> "INTO" <+> renderAlias tab
289 "INSERT" <+> "INTO" <+> renderAlias tab
@@ -296,7 +294,7 @@ insertQuery tab query conflict returning = UnsafeManipulation $
296-- | Insert a `Query` returning `Nil` and raising an error on conflicts.
294-- | Insert a `Query` returning `Nil` and raising an error on conflicts.
297insertQuery_
295insertQuery_
298 :: ( SOP.SListI columns
296 :: ( SOP.SListI columns
299− , Has tab schema table
297+ , Has tab schema ('Table table)
300 , columns ~ TableToColumns table )
298 , columns ~ TableToColumns table )
301 => Alias tab -- ^ table to insert into
299 => Alias tab -- ^ table to insert into
302 -> Query schema params (ColumnsToRelation columns)
300 -> Query schema params (ColumnsToRelation columns)
@@ -304,21 +302,22 @@ insertQuery_
304insertQuery_ tab query =
302insertQuery_ tab query =
305 insertQuery tab query OnConflictDoRaise (Returning Nil)
303 insertQuery tab query OnConflictDoRaise (Returning Nil)
306
304
307−-- | `ColumnValue`s are values to insert or update in a row
305+-- | `ColumnValue`s are values to insert or update in a row.
308-- `Same` updates with the same value.
306-- `Same` updates with the same value.
309−-- `Default` inserts or updates with the @DEFAULT@ value
307+-- `Default` inserts or updates with the @DEFAULT@ value.
310−-- `Set` a value to be an `Expression`, relative to the given
308+-- `Set` sets a value to be an `Expression`, which can refer to
311−-- row for an update, and closed for an insert.
309+-- existing value in the row for an update.
312data ColumnValue
310data ColumnValue
311+ (schema :: SchemaType)
313 (columns :: RelationType)
312 (columns :: RelationType)
314 (params :: [NullityType])
313 (params :: [NullityType])
315 (ty :: ColumnType)
314 (ty :: ColumnType)
316 where
315 where
317− Same :: ColumnValue (column ': columns) params ty
316+ Same :: ColumnValue schema (column ': columns) params ty
318− Default :: ColumnValue columns params ('Def :=> ty)
317+ Default :: ColumnValue schema columns params ('Def :=> ty)
319 Set
318 Set
320− :: (forall table. Expression '[table ::: columns] 'Ungrouped params ty)
319+ :: (forall table. Expression schema '[table ::: columns] 'Ungrouped params ty)
321− -> ColumnValue columns params (constraint :=> ty)
320+ -> ColumnValue schema columns params (constraint :=> ty)
322
321
323-- | A `ReturningClause` computes and return value(s) based
322-- | A `ReturningClause` computes and return value(s) based
324-- on each row actually inserted, updated or deleted. This is primarily
323-- on each row actually inserted, updated or deleted. This is primarily
@@ -331,46 +330,47 @@ data ColumnValue
331-- in the row. Use @Returning Nil@ in the common case where no return
330-- in the row. Use @Returning Nil@ in the common case where no return
332-- values are desired.
331-- values are desired.
333data ReturningClause
332data ReturningClause
333+ (schema :: SchemaType)
334 (columns :: ColumnsType)
334 (columns :: ColumnsType)
335 (params :: [NullityType])
335 (params :: [NullityType])
336 (results :: RelationType)
336 (results :: RelationType)
337 where
337 where
338 ReturningStar
338 ReturningStar
339 :: results ~ ColumnsToRelation columns
339 :: results ~ ColumnsToRelation columns
340− => ReturningClause columns params results
340+ => ReturningClause schema columns params results
341 Returning
341 Returning
342 :: rel ~ ColumnsToRelation columns
342 :: rel ~ ColumnsToRelation columns
343− => NP (Aliased (Expression '[table ::: rel] 'Ungrouped params)) results
343+ => NP (Aliased (Expression schema '[table ::: rel] 'Ungrouped params)) results
344− -> ReturningClause columns params results
344+ -> ReturningClause schema columns params results
345
345
346-- | Render a `ReturningClause`.
346-- | Render a `ReturningClause`.
347renderReturningClause
347renderReturningClause
348 :: SOP.SListI results
348 :: SOP.SListI results
349− => ReturningClause params columns results
349+ => ReturningClause schema params columns results
350 -> ByteString
350 -> ByteString
351renderReturningClause = \case
351renderReturningClause = \case
352− ReturningStar -> " RETURNING *;"
352+ ReturningStar -> " RETURNING *"
353− Returning Nil -> ";"
353+ Returning Nil -> ""
354 Returning results -> " RETURNING"
354 Returning results -> " RETURNING"
355− <+> renderCommaSeparated (renderAliasedAs renderExpression) results <> ";"
355+ <+> renderCommaSeparated (renderAliasedAs renderExpression) results
356
356
357-- | A `ConflictClause` specifies an action to perform upon a constraint
357-- | A `ConflictClause` specifies an action to perform upon a constraint
358-- violation. `OnConflictDoRaise` will raise an error.
358-- violation. `OnConflictDoRaise` will raise an error.
359-- `OnConflictDoNothing` simply avoids inserting a row.
359-- `OnConflictDoNothing` simply avoids inserting a row.
360-- `OnConflictDoUpdate` updates the existing row that conflicts with the row
360-- `OnConflictDoUpdate` updates the existing row that conflicts with the row
361-- proposed for insertion.
361-- proposed for insertion.
362−data ConflictClause (columns :: ColumnsType) params where
362+data ConflictClause (schema :: SchemaType) (columns :: ColumnsType) params where
363− OnConflictDoRaise :: ConflictClause columns params
363+ OnConflictDoRaise :: ConflictClause schema columns params
364− OnConflictDoNothing :: ConflictClause columns params
364+ OnConflictDoNothing :: ConflictClause schema columns params
365 OnConflictDoUpdate
365 OnConflictDoUpdate
366− :: NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns
366+ :: NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns
367− -> [Condition '[table ::: ColumnsToRelation columns] 'Ungrouped params]
367+ -> [Condition schema '[table ::: ColumnsToRelation columns] 'Ungrouped params]
368− -> ConflictClause columns params
368+ -> ConflictClause schema columns params
369
369
370-- | Render a `ConflictClause`.
370-- | Render a `ConflictClause`.
371renderConflictClause
371renderConflictClause
372 :: SOP.SListI columns
372 :: SOP.SListI columns
373− => ConflictClause columns params
373+ => ConflictClause schema columns params
374 -> ByteString
374 -> ByteString
375renderConflictClause = \case
375renderConflictClause = \case
376 OnConflictDoRaise -> ""
376 OnConflictDoRaise -> ""
@@ -383,7 +383,7 @@ renderConflictClause = \case
383 wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)
383 wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)
384 where
384 where
385 renderUpdate
385 renderUpdate
386− :: Aliased (ColumnValue columns params) column
386+ :: Aliased (ColumnValue schema columns params) column
387 -> Maybe ByteString
387 -> Maybe ByteString
388 renderUpdate = \case
388 renderUpdate = \case
389 Same `As` _ -> Nothing
389 Same `As` _ -> Nothing
@@ -401,14 +401,14 @@ UPDATE statements
401update
401update
402 :: ( SOP.SListI columns
402 :: ( SOP.SListI columns
403 , SOP.SListI results
403 , SOP.SListI results
404− , Has tab schema table
404+ , Has tab schema ('Table table)
405 , columns ~ TableToColumns table )
405 , columns ~ TableToColumns table )
406 => Alias tab -- ^ table to update
406 => Alias tab -- ^ table to update
407− -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns
407+ -> NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns
408 -- ^ modified values to replace old values
408 -- ^ modified values to replace old values
409− -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params
409+ -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params
410 -- ^ condition under which to perform update on a row
410 -- ^ condition under which to perform update on a row
411− -> ReturningClause columns params results -- ^ results to return
411+ -> ReturningClause schema columns params results -- ^ results to return
412 -> Manipulation schema params results
412 -> Manipulation schema params results
413update tab columns wh returning = UnsafeManipulation $
413update tab columns wh returning = UnsafeManipulation $
414 "UPDATE"
414 "UPDATE"
@@ -419,7 +419,7 @@ update tab columns wh returning = UnsafeManipulation $
419 <> renderReturningClause returning
419 <> renderReturningClause returning
420 where
420 where
421 renderUpdate
421 renderUpdate
422− :: Aliased (ColumnValue columns params) column
422+ :: Aliased (ColumnValue schema columns params) column
423 -> Maybe ByteString
423 -> Maybe ByteString
424 renderUpdate = \case
424 renderUpdate = \case
425 Same `As` _ -> Nothing
425 Same `As` _ -> Nothing
@@ -431,12 +431,12 @@ update tab columns wh returning = UnsafeManipulation $
431-- | Update a row returning `Nil`.
431-- | Update a row returning `Nil`.
432update_
432update_
433 :: ( SOP.SListI columns
433 :: ( SOP.SListI columns
434− , Has tab schema table
434+ , Has tab schema ('Table table)
435 , columns ~ TableToColumns table )
435 , columns ~ TableToColumns table )
436 => Alias tab -- ^ table to update
436 => Alias tab -- ^ table to update
437− -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns
437+ -> NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns
438 -- ^ modified values to replace old values
438 -- ^ modified values to replace old values
439− -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params
439+ -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params
440 -- ^ condition under which to perform update on a row
440 -- ^ condition under which to perform update on a row
441 -> Manipulation schema params '[]
441 -> Manipulation schema params '[]
442update_ tab columns wh = update tab columns wh (Returning Nil)
442update_ tab columns wh = update tab columns wh (Returning Nil)
@@ -448,12 +448,12 @@ DELETE statements
448-- | Delete rows of a table.
448-- | Delete rows of a table.
449deleteFrom
449deleteFrom
450 :: ( SOP.SListI results
450 :: ( SOP.SListI results
451− , Has tab schema table
451+ , Has tab schema ('Table table)
452 , columns ~ TableToColumns table )
452 , columns ~ TableToColumns table )
453 => Alias tab -- ^ table to delete from
453 => Alias tab -- ^ table to delete from
454− -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params
454+ -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params
455 -- ^ condition under which to delete a row
455 -- ^ condition under which to delete a row
456− -> ReturningClause columns params results -- ^ results to return
456+ -> ReturningClause schema columns params results -- ^ results to return
457 -> Manipulation schema params results
457 -> Manipulation schema params results
458deleteFrom tab wh returning = UnsafeManipulation $
458deleteFrom tab wh returning = UnsafeManipulation $
459 "DELETE FROM" <+> renderAlias tab
459 "DELETE FROM" <+> renderAlias tab
@@ -462,10 +462,10 @@ deleteFrom tab wh returning = UnsafeManipulation $
462
462
463-- | Delete rows returning `Nil`.
463-- | Delete rows returning `Nil`.
464deleteFrom_
464deleteFrom_
465− :: ( Has tab schema table
465+ :: ( Has tab schema ('Table table)
466 , columns ~ TableToColumns table )
466 , columns ~ TableToColumns table )
467 => Alias tab -- ^ table to delete from
467 => Alias tab -- ^ table to delete from
468− -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params
468+ -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params
469 -- ^ condition under which to delete a row
469 -- ^ condition under which to delete a row
470 -> Manipulation schema params '[]
470 -> Manipulation schema params '[]
471deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil)
471deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil)
@@ -482,18 +482,18 @@ WITH statements
482--
482--
483-- >>> :{
483-- >>> :{
484-- let
484-- let
485−-- manipulation :: Manipulation '["products" ::: ProductsTable, "products_deleted" ::: ProductsTable] '[ 'NotNull 'PGdate] '[]
485+-- manipulation :: Manipulation '["products" ::: 'Table ProductsTable, "products_deleted" ::: 'Table ProductsTable] '[ 'NotNull 'PGdate] '[]
486-- manipulation = with
486-- manipulation = with
487-- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rows :* Nil)
487-- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rows :* Nil)
488−-- (insertQuery_ #products_deleted (selectStar (from (table (#deleted_rows `As` #t)))))
488+-- (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rows `As` #t)))))
489−-- in renderManipulation manipulation
489+-- in printSQL manipulation
490-- :}
490-- :}
491−-- "WITH \"deleted_rows\" AS (DELETE FROM \"products\" WHERE (\"date\" < ($1 :: date)) RETURNING *) INSERT INTO \"products_deleted\" SELECT * FROM \"deleted_rows\" AS \"t\";"
491+-- WITH "deleted_rows" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "deleted_rows" AS "t"
492with
492with
493 :: SOP.SListI commons
493 :: SOP.SListI commons
494 => NP (Aliased (Manipulation schema params)) commons
494 => NP (Aliased (Manipulation schema params)) commons
495 -- ^ common table expressions
495 -- ^ common table expressions
496− -> Manipulation (Join (RelationsToTables commons) schema) params results
496+ -> Manipulation (With commons schema) params results
497 -> Manipulation schema params results
497 -> Manipulation schema params results
498with commons manipulation = UnsafeManipulation $
498with commons manipulation = UnsafeManipulation $
499 "WITH" <+> renderCommaSeparated renderCommon commons
499 "WITH" <+> renderCommaSeparated renderCommon commons
@@ -504,9 +504,4 @@ with commons manipulation = UnsafeManipulation $
504 -> ByteString
504 -> ByteString
505 renderCommon (common `As` alias) =
505 renderCommon (common `As` alias) =
506 renderAlias alias <+> "AS" <+>
506 renderAlias alias <+> "AS" <+>
507− let
508− str = renderManipulation common
507+ parenthesized (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+34−36
@@ -31,31 +31,31 @@ type EmailsTable =
31
31
32>>> :{
32>>> :{
33let
33let
34− makeUsers :: Migration IO '[] '["users" ::: UsersTable]
34+ makeUsers :: Migration IO '[] '["users" ::: 'Table UsersTable]
35 makeUsers = Migration
35 makeUsers = Migration
36 { name = "make users table"
36 { name = "make users table"
37 , up = void . define $
37 , up = void . define $
38 createTable #users
38 createTable #users
39 ( serial `As` #id :*
39 ( serial `As` #id :*
40− (text & notNull) `As` #name :* Nil )
40+ (text & notNullable) `As` #name :* Nil )
41− ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil )
41+ ( primaryKey #id `As` #pk_users :* Nil )
42 , down = void . define $ dropTable #users
42 , down = void . define $ dropTable #users
43 }
43 }
44:}
44:}
45
45
46>>> :{
46>>> :{
47let
47let
48− makeEmails :: Migration IO '["users" ::: UsersTable]
48+ makeEmails :: Migration IO '["users" ::: 'Table UsersTable]
49− '["users" ::: UsersTable, "emails" ::: EmailsTable]
49+ '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]
50 makeEmails = Migration
50 makeEmails = Migration
51 { name = "make emails table"
51 { name = "make emails table"
52 , up = void . define $
52 , up = void . define $
53 createTable #emails
53 createTable #emails
54 ( serial `As` #id :*
54 ( serial `As` #id :*
55− (int & notNull) `As` #user_id :*
55+ (int & notNullable) `As` #user_id :*
56− text `As` #email :* Nil )
56+ (text & nullable) `As` #email :* Nil )
57− ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
57+ ( primaryKey #id `As` #pk_emails :*
58− foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
58+ foreignKey #user_id #users #id
59 OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
59 OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
60 , down = void . define $ dropTable #emails
60 , down = void . define $ dropTable #emails
61 }
61 }
@@ -68,7 +68,7 @@ Now that we have a couple migrations we can chain them together.
68>>> :{
68>>> :{
69let
69let
70 numMigrations
70 numMigrations
71− :: Has "schema_migrations" schema MigrationsTable
71+ :: Has "schema_migrations" schema ('Table MigrationsTable)
72 => PQ schema schema IO ()
72 => PQ schema schema IO ()
73 numMigrations = do
73 numMigrations = do
74 result <- runQuery (selectStar (from (table (#schema_migrations `As` #m))))
74 result <- runQuery (selectStar (from (table (#schema_migrations `As` #m))))
@@ -90,9 +90,7 @@ Row 0
90-}
90-}
91
91
92{-# LANGUAGE
92{-# LANGUAGE
93− ScopedTypeVariables
94− , OverloadedStrings
95− , DataKinds
93+ DataKinds
96 , GADTs
94 , GADTs
97 , LambdaCase
95 , LambdaCase
98 , PolyKinds
96 , PolyKinds
@@ -162,8 +160,8 @@ migrateUp
162 :: MonadBaseControl IO io
160 :: MonadBaseControl IO io
163 => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run
161 => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run
164 -> PQ
162 -> PQ
165− ("schema_migrations" ::: MigrationsTable ': schema0)
163+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)
166− ("schema_migrations" ::: MigrationsTable ': schema1)
164+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)
167 io ()
165 io ()
168migrateUp migration =
166migrateUp migration =
169 define createMigrations
167 define createMigrations
@@ -175,8 +173,8 @@ migrateUp migration =
175 :: MonadBaseControl IO io
173 :: MonadBaseControl IO io
176 => AlignedList (Migration io) schema0 schema1
174 => AlignedList (Migration io) schema0 schema1
177 -> PQ
175 -> PQ
178− ("schema_migrations" ::: MigrationsTable ': schema0)
176+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)
179− ("schema_migrations" ::: MigrationsTable ': schema1)
177+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)
180 io ()
178 io ()
181 upMigrations = \case
179 upMigrations = \case
182 Done -> return ()
180 Done -> return ()
@@ -185,8 +183,8 @@ migrateUp migration =
185 upMigration
183 upMigration
186 :: MonadBase IO io
184 :: MonadBase IO io
187 => Migration io schema0 schema1 -> PQ
185 => Migration io schema0 schema1 -> PQ
188− ("schema_migrations" ::: MigrationsTable ': schema0)
186+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)
189− ("schema_migrations" ::: MigrationsTable ': schema1)
187+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)
190 io ()
188 io ()
191 upMigration step =
189 upMigration step =
192 queryExecuted step
190 queryExecuted step
@@ -202,8 +200,8 @@ migrateUp migration =
202 queryExecuted
200 queryExecuted
203 :: MonadBase IO io
201 :: MonadBase IO io
204 => Migration io schema0 schema1 -> PQ
202 => Migration io schema0 schema1 -> PQ
205− ("schema_migrations" ::: MigrationsTable ': schema0)
203+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)
206− ("schema_migrations" ::: MigrationsTable ': schema0)
204+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)
207 io Row
205 io Row
208 queryExecuted step = do
206 queryExecuted step = do
209 result <- runQueryParams selectMigration (Only (name step))
207 result <- runQueryParams selectMigration (Only (name step))
@@ -218,8 +216,8 @@ migrateDown
218 :: MonadBaseControl IO io
216 :: MonadBaseControl IO io
219 => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind
217 => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind
220 -> PQ
218 -> PQ
221− ("schema_migrations" ::: MigrationsTable ': schema1)
219+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)
222− ("schema_migrations" ::: MigrationsTable ': schema0)
220+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)
223 io ()
221 io ()
224migrateDown migrations =
222migrateDown migrations =
225 define createMigrations
223 define createMigrations
@@ -230,8 +228,8 @@ migrateDown migrations =
230 downMigrations
228 downMigrations
231 :: MonadBaseControl IO io
229 :: MonadBaseControl IO io
232 => AlignedList (Migration io) schema0 schema1 -> PQ
230 => AlignedList (Migration io) schema0 schema1 -> PQ
233− ("schema_migrations" ::: MigrationsTable ': schema1)
231+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)
234− ("schema_migrations" ::: MigrationsTable ': schema0)
232+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)
235 io ()
233 io ()
236 downMigrations = \case
234 downMigrations = \case
237 Done -> return ()
235 Done -> return ()
@@ -240,8 +238,8 @@ migrateDown migrations =
240 downMigration
238 downMigration
241 :: MonadBase IO io
239 :: MonadBase IO io
242 => Migration io schema0 schema1 -> PQ
240 => Migration io schema0 schema1 -> PQ
243− ("schema_migrations" ::: MigrationsTable ': schema1)
241+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)
244− ("schema_migrations" ::: MigrationsTable ': schema0)
242+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)
245 io ()
243 io ()
246 downMigration step =
244 downMigration step =
247 queryExecuted step
245 queryExecuted step
@@ -257,8 +255,8 @@ migrateDown migrations =
257 queryExecuted
255 queryExecuted
258 :: MonadBase IO io
256 :: MonadBase IO io
259 => Migration io schema0 schema1 -> PQ
257 => Migration io schema0 schema1 -> PQ
260− ("schema_migrations" ::: MigrationsTable ': schema1)
258+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)
261− ("schema_migrations" ::: MigrationsTable ': schema1)
259+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)
262 io Row
260 io Row
263 queryExecuted step = do
261 queryExecuted step = do
264 result <- runQueryParams selectMigration (Only (name step))
262 result <- runQueryParams selectMigration (Only (name step))
@@ -283,18 +281,18 @@ type MigrationsTable =
283
281
284-- | Creates a `MigrationsTable` if it does not already exist.
282-- | Creates a `MigrationsTable` if it does not already exist.
285createMigrations
283createMigrations
286− :: Has "schema_migrations" schema MigrationsTable
284+ :: Has "schema_migrations" schema ('Table MigrationsTable)
287 => Definition schema schema
285 => Definition schema schema
288createMigrations =
286createMigrations =
289 createTableIfNotExists #schema_migrations
287 createTableIfNotExists #schema_migrations
290− ( (text & notNull) `As` #name :*
288+ ( (text & notNullable) `As` #name :*
291− (timestampWithTimeZone & notNull & default_ currentTimestamp)
289+ (timestampWithTimeZone & notNullable & default_ currentTimestamp)
292 `As` #executed_at :* Nil )
290 `As` #executed_at :* Nil )
293− ( unique (Column #name :* Nil) `As` #migrations_unique_name :* Nil )
291+ ( unique (#name :* Nil) `As` #migrations_unique_name :* Nil )
294
292
295-- | Inserts a `Migration` into the `MigrationsTable`
293-- | Inserts a `Migration` into the `MigrationsTable`
296insertMigration
294insertMigration
297− :: Has "schema_migrations" schema MigrationsTable
295+ :: Has "schema_migrations" schema ('Table MigrationsTable)
298 => Manipulation schema '[ 'NotNull 'PGtext] '[]
296 => Manipulation schema '[ 'NotNull 'PGtext] '[]
299insertMigration = insertRow_ #schema_migrations
297insertMigration = insertRow_ #schema_migrations
300 ( Set (param @1) `As` #name :*
298 ( Set (param @1) `As` #name :*
@@ -302,14 +300,14 @@ insertMigration = insertRow_ #schema_migrations
302
300
303-- | Deletes a `Migration` from the `MigrationsTable`
301-- | Deletes a `Migration` from the `MigrationsTable`
304deleteMigration
302deleteMigration
305− :: Has "schema_migrations" schema MigrationsTable
303+ :: Has "schema_migrations" schema ('Table MigrationsTable)
306 => Manipulation schema '[ 'NotNull 'PGtext ] '[]
304 => Manipulation schema '[ 'NotNull 'PGtext ] '[]
307deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)
305deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)
308
306
309-- | Selects a `Migration` from the `MigrationsTable`, returning
307-- | Selects a `Migration` from the `MigrationsTable`, returning
310-- the time at which it was executed.
308-- the time at which it was executed.
311selectMigration
309selectMigration
312− :: Has "schema_migrations" schema MigrationsTable
310+ :: Has "schema_migrations" schema ('Table MigrationsTable)
313 => Query schema '[ 'NotNull 'PGtext ]
311 => Query schema '[ 'NotNull 'PGtext ]
314 '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]
312 '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]
315selectMigration = select
313selectMigration = select
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+17−15
@@ -20,15 +20,10 @@ of executing Squeal commands.
20
20
21{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
21{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
22{-# LANGUAGE
22{-# LANGUAGE
23− DataKinds
24− , DefaultSignatures
23+ DefaultSignatures
25 , FunctionalDependencies
24 , FunctionalDependencies
26− , PolyKinds
27− , DeriveFunctor
28 , FlexibleContexts
25 , FlexibleContexts
29 , FlexibleInstances
26 , FlexibleInstances
30− , MagicHash
31− , MultiParamTypeClasses
32 , OverloadedStrings
27 , OverloadedStrings
33 , RankNTypes
28 , RankNTypes
34 , ScopedTypeVariables
29 , ScopedTypeVariables
@@ -160,8 +155,8 @@ lowerConnection (K conn) = K conn
160-- | We keep track of the schema via an Atkey indexed state monad transformer,
155-- | We keep track of the schema via an Atkey indexed state monad transformer,
161-- `PQ`.
156-- `PQ`.
162newtype PQ
157newtype PQ
163− (schema0 :: TablesType)
158+ (schema0 :: SchemaType)
164− (schema1 :: TablesType)
159+ (schema1 :: SchemaType)
165 (m :: Type -> Type)
160 (m :: Type -> Type)
166 (x :: Type) =
161 (x :: Type) =
167 PQ { unPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }
162 PQ { unPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }
@@ -171,7 +166,7 @@ instance Monad m => Functor (PQ schema0 schema1 m) where
171 K x <- pq conn
166 K x <- pq conn
172 return $ K (f x)
167 return $ K (f x)
173
168
174−-- | Run a `PQ` and keep the result and the `Connection`.
169+-- | Run a `PQ` and keep the result and the `Connection`.
175runPQ
170runPQ
176 :: Functor m
171 :: Functor m
177 => PQ schema0 schema1 m x
172 => PQ schema0 schema1 m x
@@ -181,7 +176,7 @@ runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn
181 -- K x <- pq conn
176 -- K x <- pq conn
182 -- return (x, K (unK conn))
177 -- return (x, K (unK conn))
183
178
184−-- | Execute a `PQ` and discard the result but keep the `Connection`.
179+-- | Execute a `PQ` and discard the result but keep the `Connection`.
185execPQ
180execPQ
186 :: Functor m
181 :: Functor m
187 => PQ schema0 schema1 m x
182 => PQ schema0 schema1 m x
@@ -217,6 +212,7 @@ class IndexedMonadTransPQ pq where
217 :: Monad m
212 :: Monad m
218 => pq schema0 schema1 m (pq schema1 schema2 m y)
213 => pq schema0 schema1 m (pq schema1 schema2 m y)
219 -> pq schema0 schema2 m y
214 -> pq schema0 schema2 m y
215+ pqJoin pq = pq & pqBind id
220
216
221 -- | indexed analog of `=<<`
217 -- | indexed analog of `=<<`
222 pqBind
218 pqBind
@@ -231,6 +227,15 @@ class IndexedMonadTransPQ pq where
231 => pq schema1 schema2 m y
227 => pq schema1 schema2 m y
232 -> pq schema0 schema1 m x
228 -> pq schema0 schema1 m x
233 -> pq schema0 schema2 m y
229 -> pq schema0 schema2 m y
230+ pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
231+
232+ -- | indexed analog of `<=<`
233+ pqAndThen
234+ :: Monad m
235+ => (y -> pq schema1 schema2 m z)
236+ -> (x -> pq schema0 schema1 m y)
237+ -> x -> pq schema0 schema2 m z
238+ pqAndThen g f x = pqBind g (f x)
234
239
235 -- | Safely embed a computation in a larger schema.
240 -- | Safely embed a computation in a larger schema.
236 pqEmbed
241 pqEmbed
@@ -253,14 +258,10 @@ instance IndexedMonadTransPQ PQ where
253 K x' <- x (K (unK conn))
258 K x' <- x (K (unK conn))
254 return $ K (f' x')
259 return $ K (f' x')
255
260
256− pqJoin pq = pq & pqBind id
257−
258 pqBind f (PQ x) = PQ $ \ conn -> do
261 pqBind f (PQ x) = PQ $ \ conn -> do
259 K x' <- x conn
262 K x' <- x conn
260 unPQ (f x') (K (unK conn))
263 unPQ (f x') (K (unK conn))
261
264
262− pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
263−
264 pqEmbed (PQ pq) = PQ $ \ (K conn) -> do
265 pqEmbed (PQ pq) = PQ $ \ (K conn) -> do
265 K x <- pq (K conn)
266 K x <- pq (K conn)
266 return $ K x
267 return $ K x
@@ -394,7 +395,8 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)
394 let
395 let
395 toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)
396 toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)
396 params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
397 params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
398+ q' = q <> ";"
397− resultMaybe <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary
399+ resultMaybe <- liftBase $ LibPQ.execParams conn q' params' LibPQ.Binary
398 case resultMaybe of
400 case resultMaybe of
399 Nothing -> error
401 Nothing -> error
400 "manipulateParams: LibPQ.execParams returned no results"
402 "manipulateParams: LibPQ.execParams returned no results"
squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+3−4
@@ -9,8 +9,7 @@ A `MonadPQ` for pooled connections.
9-}
9-}
10
10
11{-# LANGUAGE
11{-# LANGUAGE
12− DataKinds
13− , DeriveFunctor
12+ DeriveFunctor
14 , FlexibleContexts
13 , FlexibleContexts
15 , FlexibleInstances
14 , FlexibleInstances
16 , MultiParamTypeClasses
15 , MultiParamTypeClasses
@@ -43,7 +42,7 @@ import Squeal.PostgreSQL.PQ
43import Squeal.PostgreSQL.Schema
42import Squeal.PostgreSQL.Schema
44
43
45-- | `PoolPQ` @schema@ should be a drop-in replacement for `PQ` @schema schema@.
44-- | `PoolPQ` @schema@ should be a drop-in replacement for `PQ` @schema schema@.
46−newtype PoolPQ (schema :: TablesType) m x =
45+newtype PoolPQ (schema :: SchemaType) m x =
47 PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x }
46 PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x }
48 deriving Functor
47 deriving Functor
49
48
@@ -110,7 +109,7 @@ instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where
110 (_ :: K () schema) <- flip unPQ conn $
109 (_ :: K () schema) <- flip unPQ conn $
111 traversePrepared_ manipulation params
110 traversePrepared_ manipulation params
112 return ()
111 return ()
113− liftPQ m = PoolPQ $ \ pool ->
112+ liftPQ m = PoolPQ $ \ pool ->
114 withResource pool $ \ conn -> do
113 withResource pool $ \ conn -> do
115 (K result :: K result schema) <- flip unPQ conn $
114 (K result :: K result schema) <- flip unPQ conn $
116 liftPQ m
115 liftPQ m
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+148−103
@@ -9,23 +9,15 @@ Squeal queries.
9-}
9-}
10
10
11{-# LANGUAGE
11{-# LANGUAGE
12− DataKinds
13− , DeriveDataTypeable
14− , DeriveGeneric
12+ DeriveGeneric
15 , FlexibleContexts
13 , FlexibleContexts
16− , FlexibleInstances
17 , GADTs
14 , GADTs
18 , GeneralizedNewtypeDeriving
15 , GeneralizedNewtypeDeriving
19− , KindSignatures
20 , LambdaCase
16 , LambdaCase
21− , MultiParamTypeClasses
22 , OverloadedStrings
17 , OverloadedStrings
23− , ScopedTypeVariables
24 , StandaloneDeriving
18 , StandaloneDeriving
25− , TypeApplications
26 , TypeInType
19 , TypeInType
27 , TypeOperators
20 , TypeOperators
28− , UndecidableInstances
29#-}
21#-}
30
22
31module Squeal.PostgreSQL.Query
23module Squeal.PostgreSQL.Query
@@ -44,6 +36,8 @@ module Squeal.PostgreSQL.Query
44 , selectDistinctStar
36 , selectDistinctStar
45 , selectDotStar
37 , selectDotStar
46 , selectDistinctDotStar
38 , selectDistinctDotStar
39+ , values
40+ , values_
47 -- * Table Expressions
41 -- * Table Expressions
48 , TableExpression (..)
42 , TableExpression (..)
49 , renderTableExpression
43 , renderTableExpression
@@ -58,6 +52,7 @@ module Squeal.PostgreSQL.Query
58 , FromClause (..)
52 , FromClause (..)
59 , table
53 , table
60 , subquery
54 , subquery
55+ , view
61 , crossJoin
56 , crossJoin
62 , innerJoin
57 , innerJoin
63 , leftOuterJoin
58 , leftOuterJoin
@@ -100,111 +95,111 @@ simple query:
100>>> :{
95>>> :{
101let
96let
102 query :: Query
97 query :: Query
103− '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
98+ '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
104 '[]
99 '[]
105 '["col" ::: 'Null 'PGint4]
100 '["col" ::: 'Null 'PGint4]
106− query = selectStar (from (table (#tab `As` #t)))
101+ query = selectStar (from (table #tab))
107−in renderQuery query
102+in printSQL query
108:}
103:}
109−"SELECT * FROM \"tab\" AS \"t\""
104+SELECT * FROM "tab" AS "tab"
110
105
111restricted query:
106restricted query:
112
107
113>>> :{
108>>> :{
114let
109let
115 query :: Query
110 query :: Query
116− '[ "tab" ::: '[] :=>
111+ '[ "tab" ::: 'Table ('[] :=>
117 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
112 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
118− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]
113+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]
119 '[]
114 '[]
120 '[ "sum" ::: 'NotNull 'PGint4
115 '[ "sum" ::: 'NotNull 'PGint4
121 , "col1" ::: 'NotNull 'PGint4 ]
116 , "col1" ::: 'NotNull 'PGint4 ]
122− query =
117+ query =
123 select
118 select
124− ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
119+ ((#col1 + #col2) `As` #sum :* #col1 :* Nil)
125− ( from (table (#tab `As` #t))
120+ ( from (table #tab)
126 & where_ (#col1 .> #col2)
121 & where_ (#col1 .> #col2)
127 & where_ (#col2 .> 0) )
122 & where_ (#col2 .> 0) )
128−in renderQuery query
123+in printSQL query
129:}
124:}
130−"SELECT (\"col1\" + \"col2\") AS \"sum\", \"col1\" AS \"col1\" FROM \"tab\" AS \"t\" WHERE ((\"col1\" > \"col2\") AND (\"col2\" > 0))"
125+SELECT ("col1" + "col2") AS "sum", "col1" AS "col1" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))
131
126
132subquery:
127subquery:
133
128
134>>> :{
129>>> :{
135let
130let
136 query :: Query
131 query :: Query
137− '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
132+ '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
138 '[]
133 '[]
139 '["col" ::: 'Null 'PGint4]
134 '["col" ::: 'Null 'PGint4]
140 query =
135 query =
141 selectStar
136 selectStar
142− (from (subquery (selectStar (from (table (#tab `As` #t))) `As` #sub)))
137+ (from (subquery (selectStar (from (table #tab)) `As` #sub)))
143−in renderQuery query
138+in printSQL query
144:}
139:}
145−"SELECT * FROM (SELECT * FROM \"tab\" AS \"t\") AS \"sub\""
140+SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub"
146
141
147limits and offsets:
142limits and offsets:
148
143
149>>> :{
144>>> :{
150let
145let
151 query :: Query
146 query :: Query
152− '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
147+ '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
153 '[]
148 '[]
154 '["col" ::: 'Null 'PGint4]
149 '["col" ::: 'Null 'PGint4]
155 query = selectStar
150 query = selectStar
156− (from (table (#tab `As` #t)) & limit 100 & offset 2 & limit 50 & offset 2)
151+ (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)
157−in renderQuery query
152+in printSQL query
158:}
153:}
159−"SELECT * FROM \"tab\" AS \"t\" LIMIT 50 OFFSET 4"
154+SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4
160
155
161parameterized query:
156parameterized query:
162
157
163>>> :{
158>>> :{
164let
159let
165 query :: Query
160 query :: Query
166− '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8]]
161+ '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8])]
167 '[ 'NotNull 'PGfloat8]
162 '[ 'NotNull 'PGfloat8]
168 '["col" ::: 'NotNull 'PGfloat8]
163 '["col" ::: 'NotNull 'PGfloat8]
169 query = selectStar
164 query = selectStar
170− (from (table (#tab `As` #t)) & where_ (#col .> param @1))
165+ (from (table #tab) & where_ (#col .> param @1))
171−in renderQuery query
166+in printSQL query
172:}
167:}
173−"SELECT * FROM \"tab\" AS \"t\" WHERE (\"col\" > ($1 :: float8))"
168+SELECT * FROM "tab" AS "tab" WHERE ("col" > ($1 :: float8))
174
169
175aggregation query:
170aggregation query:
176
171
177>>> :{
172>>> :{
178let
173let
179 query :: Query
174 query :: Query
180− '[ "tab" ::: '[] :=>
175+ '[ "tab" ::: 'Table ('[] :=>
181 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
176 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
182− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]
177+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]
183 '[]
178 '[]
184 '[ "sum" ::: 'NotNull 'PGint4
179 '[ "sum" ::: 'NotNull 'PGint4
185 , "col1" ::: 'NotNull 'PGint4 ]
180 , "col1" ::: 'NotNull 'PGint4 ]
186 query =
181 query =
187− select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil)
182+ select (sum_ #col2 `As` #sum :* #col1 :* Nil)
188 ( from (table (#tab `As` #table1))
183 ( from (table (#tab `As` #table1))
189− & group (By #col1 :* Nil)
184+ & group (By #col1 :* Nil)
190 & having (#col1 + sum_ #col2 .> 1) )
185 & having (#col1 + sum_ #col2 .> 1) )
191−in renderQuery query
186+in printSQL query
192:}
187:}
193−"SELECT sum(\"col2\") AS \"sum\", \"col1\" AS \"col1\" FROM \"tab\" AS \"table1\" GROUP BY \"col1\" HAVING ((\"col1\" + sum(\"col2\")) > 1)"
188+SELECT sum("col2") AS "sum", "col1" AS "col1" FROM "tab" AS "table1" GROUP BY "col1" HAVING (("col1" + sum("col2")) > 1)
194
189
195sorted query:
190sorted query:
196
191
197>>> :{
192>>> :{
198let
193let
199 query :: Query
194 query :: Query
200− '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
195+ '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
201 '[]
196 '[]
202 '["col" ::: 'Null 'PGint4]
197 '["col" ::: 'Null 'PGint4]
203 query = selectStar
198 query = selectStar
204− (from (table (#tab `As` #t)) & orderBy [#col & AscNullsFirst])
199+ (from (table #tab) & orderBy [#col & AscNullsFirst])
205−in renderQuery query
200+in printSQL query
206:}
201:}
207−"SELECT * FROM \"tab\" AS \"t\" ORDER BY \"col\" ASC NULLS FIRST"
202+SELECT * FROM "tab" AS "tab" ORDER BY "col" ASC NULLS FIRST
208
203
209joins:
204joins:
210
205
@@ -212,7 +207,7 @@ joins:
212>>> :{
207>>> :{
213let
208let
214 query :: Query
209 query :: Query
215− '[ "orders" :::
210+ '[ "orders" ::: 'Table (
216 '["pk_orders" ::: PrimaryKey '["id"]
211 '["pk_orders" ::: PrimaryKey '["id"]
217 ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]
212 ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]
218 ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"]] :=>
213 ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"]] :=>
@@ -220,17 +215,17 @@ let
220 , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
215 , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
221 , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
216 , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
222 , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4
217 , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4
223− ]
218+ ])
224− , "customers" :::
219+ , "customers" ::: 'Table (
225 '["pk_customers" ::: PrimaryKey '["id"]] :=>
220 '["pk_customers" ::: PrimaryKey '["id"]] :=>
226 '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
221 '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
227 , "name" ::: 'NoDef :=> 'NotNull 'PGtext
222 , "name" ::: 'NoDef :=> 'NotNull 'PGtext
228− ]
223+ ])
229− , "shippers" :::
224+ , "shippers" ::: 'Table (
230 '["pk_shippers" ::: PrimaryKey '["id"]] :=>
225 '["pk_shippers" ::: PrimaryKey '["id"]] :=>
231 '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
226 '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
232 , "name" ::: 'NoDef :=> 'NotNull 'PGtext
227 , "name" ::: 'NoDef :=> 'NotNull 'PGtext
233− ]
228+ ])
234 ]
229 ]
235 '[]
230 '[]
236 '[ "order_price" ::: 'NotNull 'PGfloat4
231 '[ "order_price" ::: 'NotNull 'PGfloat4
@@ -246,49 +241,50 @@ let
246 (#o ! #customer_id .== #c ! #id)
241 (#o ! #customer_id .== #c ! #id)
247 & innerJoin (table (#shippers `As` #s))
242 & innerJoin (table (#shippers `As` #s))
248 (#o ! #shipper_id .== #s ! #id)) )
243 (#o ! #shipper_id .== #s ! #id)) )
249−in renderQuery query
244+in printSQL query
250:}
245:}
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\")"
246+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")
252
247
253self-join:
248self-join:
254
249
255>>> :{
250>>> :{
256let
251let
257 query :: Query
252 query :: Query
258− '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
253+ '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
259 '[]
254 '[]
260 '["col" ::: 'Null 'PGint4]
255 '["col" ::: 'Null 'PGint4]
261 query = selectDotStar #t1
256 query = selectDotStar #t1
262 (from (table (#tab `As` #t1) & crossJoin (table (#tab `As` #t2))))
257 (from (table (#tab `As` #t1) & crossJoin (table (#tab `As` #t2))))
263−in renderQuery query
258+in printSQL query
264:}
259:}
265−"SELECT \"t1\".* FROM \"tab\" AS \"t1\" CROSS JOIN \"tab\" AS \"t2\""
260+SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2"
266
261
267set operations:
262set operations:
268
263
269>>> :{
264>>> :{
270let
265let
271 query :: Query
266 query :: Query
272− '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
267+ '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]
273 '[]
268 '[]
274 '["col" ::: 'Null 'PGint4]
269 '["col" ::: 'Null 'PGint4]
275 query =
270 query =
276− selectStar (from (table (#tab `As` #t)))
271+ selectStar (from (table #tab))
277 `unionAll`
272 `unionAll`
278− selectStar (from (table (#tab `As` #t)))
273+ selectStar (from (table #tab))
279−in renderQuery query
274+in printSQL query
280:}
275:}
281−"(SELECT * FROM \"tab\" AS \"t\") UNION ALL (SELECT * FROM \"tab\" AS \"t\")"
276+(SELECT * FROM "tab" AS "tab") UNION ALL (SELECT * FROM "tab" AS "tab")
282-}
277-}
283newtype Query
278newtype Query
284− (schema :: TablesType)
279+ (schema :: SchemaType)
285 (params :: [NullityType])
280 (params :: [NullityType])
286 (columns :: RelationType)
281 (columns :: RelationType)
287 = UnsafeQuery { renderQuery :: ByteString }
282 = UnsafeQuery { renderQuery :: ByteString }
288 deriving (GHC.Generic,Show,Eq,Ord,NFData)
283 deriving (GHC.Generic,Show,Eq,Ord,NFData)
284+instance RenderSQL (Query schema params columns) where renderSQL = renderQuery
289
285
290-- | The results of two queries can be combined using the set operation
286-- | The results of two queries can be combined using the set operation
291−-- `union`. Duplicate rows are eliminated.
287+-- `union`. Duplicate rows are eliminated.
292union
288union
293 :: Query schema params columns
289 :: Query schema params columns
294 -> Query schema params columns
290 -> Query schema params columns
@@ -364,7 +360,7 @@ SELECT queries
364-- the intermediate table are actually output.
360-- the intermediate table are actually output.
365select
361select
366 :: SListI columns
362 :: SListI columns
367− => NP (Aliased (Expression relations grouping params)) (column ': columns)
363+ => NP (Aliased (Expression schema relations grouping params)) (column ': columns)
368 -- ^ select list
364 -- ^ select list
369 -> TableExpression schema params relations grouping
365 -> TableExpression schema params relations grouping
370 -- ^ intermediate virtual table
366 -- ^ intermediate virtual table
@@ -378,7 +374,7 @@ select list rels = UnsafeQuery $
378-- be subject to the elimination of duplicate rows using `selectDistinct`.
374-- be subject to the elimination of duplicate rows using `selectDistinct`.
379selectDistinct
375selectDistinct
380 :: SListI columns
376 :: SListI columns
381− => NP (Aliased (Expression relations 'Ungrouped params)) (column ': columns)
377+ => NP (Aliased (Expression schema relations 'Ungrouped params)) (column ': columns)
382 -- ^ select list
378 -- ^ select list
383 -> TableExpression schema params relations 'Ungrouped
379 -> TableExpression schema params relations 'Ungrouped
384 -- ^ intermediate virtual table
380 -- ^ intermediate virtual table
@@ -419,7 +415,7 @@ selectDotStar
419selectDotStar rel relations = UnsafeQuery $
415selectDotStar rel relations = UnsafeQuery $
420 "SELECT" <+> renderAlias rel <> ".*" <+> renderTableExpression relations
416 "SELECT" <+> renderAlias rel <> ".*" <+> renderTableExpression relations
421
417
422−-- | A `selectDistinctDotStar` asks for all the columns of a particular table,
418+-- | A `selectDistinctDotStar` asks for all the columns of a particular table,
423-- and eliminates duplicate rows.
419-- and eliminates duplicate rows.
424selectDistinctDotStar
420selectDistinctDotStar
425 :: Has relation relations columns
421 :: Has relation relations columns
@@ -432,6 +428,45 @@ selectDistinctDotStar rel relations = UnsafeQuery $
432 "SELECT DISTINCT" <+> renderAlias rel <> ".*"
428 "SELECT DISTINCT" <+> renderAlias rel <> ".*"
433 <+> renderTableExpression relations
429 <+> renderTableExpression relations
434
430
431+-- | `values` computes a row value or set of row values
432+-- specified by value expressions. It is most commonly used
433+-- to generate a “constant table” within a larger command,
434+-- but it can be used on its own.
435+--
436+-- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]
437+-- >>> let query = values (1 `As` #a :* "one" `As` #b :* Nil) [] :: Query '[] '[] Row
438+-- >>> printSQL query
439+-- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b")
440+values
441+ :: SListI cols
442+ => NP (Aliased (Expression schema '[] 'Ungrouped params)) cols
443+ -> [NP (Aliased (Expression schema '[] 'Ungrouped params)) cols]
444+ -- ^ When more than one row is specified, all the rows must
445+ -- must have the same number of elements
446+ -> Query schema params cols
447+values rw rws = UnsafeQuery $ "SELECT * FROM"
448+ <+> parenthesized (
449+ "VALUES"
450+ <+> commaSeparated
451+ ( parenthesized
452+ . renderCommaSeparated renderValuePart <$> rw:rws )
453+ ) <+> "AS t"
454+ <+> parenthesized (renderCommaSeparated renderAliasPart rw)
455+ where
456+ renderAliasPart, renderValuePart
457+ :: Aliased (Expression schema '[] 'Ungrouped params) ty -> ByteString
458+ renderAliasPart (_ `As` name) = renderAlias name
459+ renderValuePart (value `As` _) = renderExpression value
460+
461+-- | `values_` computes a row value or set of row values
462+-- specified by value expressions.
463+values_
464+ :: SListI cols
465+ => NP (Aliased (Expression schema '[] 'Ungrouped params)) cols
466+ -- ^ one row of values
467+ -> Query schema params cols
468+values_ rw = values rw []
469+
435{-----------------------------------------
470{-----------------------------------------
436Table Expressions
471Table Expressions
437-----------------------------------------}
472-----------------------------------------}
@@ -443,7 +478,7 @@ Table Expressions
443-- to a table on disk, a so-called base table, but more complex expressions
478-- to a table on disk, a so-called base table, but more complex expressions
444-- can be used to modify or combine base tables in various ways.
479-- can be used to modify or combine base tables in various ways.
445data TableExpression
480data TableExpression
446− (schema :: TablesType)
481+ (schema :: SchemaType)
447 (params :: [NullityType])
482 (params :: [NullityType])
448 (relations :: RelationsType)
483 (relations :: RelationsType)
449 (grouping :: Grouping)
484 (grouping :: Grouping)
@@ -451,7 +486,7 @@ data TableExpression
451 { fromClause :: FromClause schema params relations
486 { fromClause :: FromClause schema params relations
452 -- ^ A table reference that can be a table name, or a derived table such
487 -- ^ A table reference that can be a table name, or a derived table such
453 -- as a subquery, a @JOIN@ construct, or complex combinations of these.
488 -- as a subquery, a @JOIN@ construct, or complex combinations of these.
454− , whereClause :: [Condition relations 'Ungrouped params]
489+ , whereClause :: [Condition schema relations 'Ungrouped params]
455 -- ^ optional search coditions, combined with `.&&`. After the processing
490 -- ^ optional search coditions, combined with `.&&`. After the processing
456 -- of the `fromClause` is done, each row of the derived virtual table
491 -- of the `fromClause` is done, each row of the derived virtual table
457 -- is checked against the search condition. If the result of the
492 -- is checked against the search condition. If the result of the
@@ -467,13 +502,13 @@ data TableExpression
467 -- set of rows having common values into one group row that represents all
502 -- set of rows having common values into one group row that represents all
468 -- rows in the group. This is done to eliminate redundancy in the output
503 -- rows in the group. This is done to eliminate redundancy in the output
469 -- and/or compute aggregates that apply to these groups.
504 -- and/or compute aggregates that apply to these groups.
470− , havingClause :: HavingClause relations grouping params
505+ , havingClause :: HavingClause schema relations grouping params
471 -- ^ If a table has been grouped using `groupBy`, but only certain groups
506 -- ^ If a table has been grouped using `groupBy`, but only certain groups
472 -- are of interest, the `havingClause` can be used, much like a
507 -- are of interest, the `havingClause` can be used, much like a
473 -- `whereClause`, to eliminate groups from the result. Expressions in the
508 -- `whereClause`, to eliminate groups from the result. Expressions in the
474 -- `havingClause` can refer both to grouped expressions and to ungrouped
509 -- `havingClause` can refer both to grouped expressions and to ungrouped
475 -- expressions (which necessarily involve an aggregate function).
510 -- expressions (which necessarily involve an aggregate function).
476− , orderByClause :: [SortExpression relations grouping params]
511+ , orderByClause :: [SortExpression schema relations grouping params]
477 -- ^ The `orderByClause` is for optional sorting. When more than one
512 -- ^ The `orderByClause` is for optional sorting. When more than one
478 -- `SortExpression` is specified, the later (right) values are used to sort
513 -- `SortExpression` is specified, the later (right) values are used to sort
479 -- rows that are equal according to the earlier (left) values.
514 -- rows that are equal according to the earlier (left) values.
@@ -532,7 +567,7 @@ from rels = TableExpression rels [] NoGroups NoHaving [] [] []
532-- | A `where_` is an endomorphism of `TableExpression`s which adds a
567-- | A `where_` is an endomorphism of `TableExpression`s which adds a
533-- search condition to the `whereClause`.
568-- search condition to the `whereClause`.
534where_
569where_
535− :: Condition relations 'Ungrouped params -- ^ filtering condition
570+ :: Condition schema relations 'Ungrouped params -- ^ filtering condition
536 -> TableExpression schema params relations grouping
571 -> TableExpression schema params relations grouping
537 -> TableExpression schema params relations grouping
572 -> TableExpression schema params relations grouping
538where_ wh rels = rels {whereClause = wh : whereClause rels}
573where_ wh rels = rels {whereClause = wh : whereClause rels}
@@ -543,7 +578,7 @@ where_ wh rels = rels {whereClause = wh : whereClause rels}
543group
578group
544 :: SListI bys
579 :: SListI bys
545 => NP (By relations) bys -- ^ grouped columns
580 => NP (By relations) bys -- ^ grouped columns
546− -> TableExpression schema params relations 'Ungrouped
581+ -> TableExpression schema params relations 'Ungrouped
547 -> TableExpression schema params relations ('Grouped bys)
582 -> TableExpression schema params relations ('Grouped bys)
548group bys rels = TableExpression
583group bys rels = TableExpression
549 { fromClause = fromClause rels
584 { fromClause = fromClause rels
@@ -558,7 +593,7 @@ group bys rels = TableExpression
558-- | A `having` is an endomorphism of `TableExpression`s which adds a
593-- | A `having` is an endomorphism of `TableExpression`s which adds a
559-- search condition to the `havingClause`.
594-- search condition to the `havingClause`.
560having
595having
561− :: Condition relations ('Grouped bys) params -- ^ having condition
596+ :: Condition schema relations ('Grouped bys) params -- ^ having condition
562 -> TableExpression schema params relations ('Grouped bys)
597 -> TableExpression schema params relations ('Grouped bys)
563 -> TableExpression schema params relations ('Grouped bys)
598 -> TableExpression schema params relations ('Grouped bys)
564having hv rels = rels
599having hv rels = rels
@@ -567,7 +602,7 @@ having hv rels = rels
567-- | An `orderBy` is an endomorphism of `TableExpression`s which appends an
602-- | An `orderBy` is an endomorphism of `TableExpression`s which appends an
568-- ordering to the right of the `orderByClause`.
603-- ordering to the right of the `orderByClause`.
569orderBy
604orderBy
570− :: [SortExpression relations grouping params] -- ^ sort expressions
605+ :: [SortExpression schema relations grouping params] -- ^ sort expressions
571 -> TableExpression schema params relations grouping
606 -> TableExpression schema params relations grouping
572 -> TableExpression schema params relations grouping
607 -> TableExpression schema params relations grouping
573orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}
608orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}
@@ -602,16 +637,26 @@ newtype FromClause schema params relations
602
637
603-- | A real `table` is a table from the schema.
638-- | A real `table` is a table from the schema.
604table
639table
605− :: Aliased (Table schema) table
640+ :: Has tab schema ('Table table)
641+ => Aliased Alias (alias ::: tab)
606− -> FromClause schema params '[table]
642+ -> FromClause schema params '[alias ::: TableToRelation table]
607−table = UnsafeFromClause . renderAliasedAs renderTable
643+table (tab `As` alias) = UnsafeFromClause $
644+ renderAlias tab <+> "AS" <+> renderAlias alias
608
645
609-- | `subquery` derives a table from a `Query`.
646-- | `subquery` derives a table from a `Query`.
610subquery
647subquery
611− :: Aliased (Query schema params) table
648+ :: Aliased (Query schema params) rel
612− -> FromClause schema params '[table]
649+ -> FromClause schema params '[rel]
613subquery = UnsafeFromClause . renderAliasedAs (parenthesized . renderQuery)
650subquery = UnsafeFromClause . renderAliasedAs (parenthesized . renderQuery)
614
651
652+-- | `view` derives a table from a `View`.
653+view
654+ :: Has view schema ('View rel)
655+ => Aliased Alias (alias ::: view)
656+ -> FromClause schema params '[alias ::: rel]
657+view (vw `As` alias) = UnsafeFromClause $
658+ renderAlias vw <+> "AS" <+> renderAlias alias
659+
615{- | @left & crossJoin right@. For every possible combination of rows from
660{- | @left & crossJoin right@. For every possible combination of rows from
616 @left@ and @right@ (i.e., a Cartesian product), the joined table will contain
661 @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@.
662 a row consisting of all columns in @left@ followed by all columns in @right@.
@@ -633,7 +678,7 @@ the @on@ condition.
633innerJoin
678innerJoin
634 :: FromClause schema params right
679 :: FromClause schema params right
635 -- ^ right
680 -- ^ right
636− -> Condition (Join left right) 'Ungrouped params
681+ -> Condition schema (Join left right) 'Ungrouped params
637 -- ^ @on@ condition
682 -- ^ @on@ condition
638 -> FromClause schema params left
683 -> FromClause schema params left
639 -- ^ left
684 -- ^ left
@@ -650,7 +695,7 @@ innerJoin right on left = UnsafeFromClause $
650leftOuterJoin
695leftOuterJoin
651 :: FromClause schema params right
696 :: FromClause schema params right
652 -- ^ right
697 -- ^ right
653− -> Condition (Join left right) 'Ungrouped params
698+ -> Condition schema (Join left right) 'Ungrouped params
654 -- ^ @on@ condition
699 -- ^ @on@ condition
655 -> FromClause schema params left
700 -> FromClause schema params left
656 -- ^ left
701 -- ^ left
@@ -668,7 +713,7 @@ leftOuterJoin right on left = UnsafeFromClause $
668rightOuterJoin
713rightOuterJoin
669 :: FromClause schema params right
714 :: FromClause schema params right
670 -- ^ right
715 -- ^ right
671− -> Condition (Join left right) 'Ungrouped params
716+ -> Condition schema (Join left right) 'Ungrouped params
672 -- ^ @on@ condition
717 -- ^ @on@ condition
673 -> FromClause schema params left
718 -> FromClause schema params left
674 -- ^ left
719 -- ^ left
@@ -687,7 +732,7 @@ rightOuterJoin right on left = UnsafeFromClause $
687fullOuterJoin
732fullOuterJoin
688 :: FromClause schema params right
733 :: FromClause schema params right
689 -- ^ right
734 -- ^ right
690− -> Condition (Join left right) 'Ungrouped params
735+ -> Condition schema (Join left right) 'Ungrouped params
691 -- ^ @on@ condition
736 -- ^ @on@ condition
692 -> FromClause schema params left
737 -> FromClause schema params left
693 -- ^ left
738 -- ^ left
@@ -751,17 +796,17 @@ renderGroupByClause = \case
751-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
796-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
752-- `TableExpression` must use `Having` whose conditions are combined with
797-- `TableExpression` must use `Having` whose conditions are combined with
753-- `.&&`.
798-- `.&&`.
754−data HavingClause relations grouping params where
799+data HavingClause schema relations grouping params where
755− NoHaving :: HavingClause relations 'Ungrouped params
800+ NoHaving :: HavingClause schema relations 'Ungrouped params
756 Having
801 Having
757− :: [Condition relations ('Grouped bys) params]
802+ :: [Condition schema relations ('Grouped bys) params]
758− -> HavingClause relations ('Grouped bys) params
803+ -> HavingClause schema relations ('Grouped bys) params
759−deriving instance Show (HavingClause relations grouping params)
804+deriving instance Show (HavingClause schema relations grouping params)
760−deriving instance Eq (HavingClause relations grouping params)
805+deriving instance Eq (HavingClause schema relations grouping params)
761−deriving instance Ord (HavingClause relations grouping params)
806+deriving instance Ord (HavingClause schema relations grouping params)
762
807
763-- | Render a `HavingClause`.
808-- | Render a `HavingClause`.
764−renderHavingClause :: HavingClause relations grouping params -> ByteString
809+renderHavingClause :: HavingClause schema relations grouping params -> ByteString
765renderHavingClause = \case
810renderHavingClause = \case
766 NoHaving -> ""
811 NoHaving -> ""
767 Having [] -> ""
812 Having [] -> ""
@@ -780,29 +825,29 @@ Sorting
780-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to
825-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to
781-- determine whether nulls appear before or after non-null values in the sort
826-- determine whether nulls appear before or after non-null values in the sort
782-- ordering of a `Null` result column.
827-- ordering of a `Null` result column.
783−data SortExpression relations grouping params where
828+data SortExpression schema relations grouping params where
784 Asc
829 Asc
785− :: Expression relations grouping params ('NotNull ty)
830+ :: Expression schema relations grouping params ('NotNull ty)
786− -> SortExpression relations grouping params
831+ -> SortExpression schema relations grouping params
787 Desc
832 Desc
788− :: Expression relations grouping params ('NotNull ty)
833+ :: Expression schema relations grouping params ('NotNull ty)
789− -> SortExpression relations grouping params
834+ -> SortExpression schema relations grouping params
790 AscNullsFirst
835 AscNullsFirst
791− :: Expression relations grouping params ('Null ty)
836+ :: Expression schema relations grouping params ('Null ty)
792− -> SortExpression relations grouping params
837+ -> SortExpression schema relations grouping params
793 AscNullsLast
838 AscNullsLast
794− :: Expression relations grouping params ('Null ty)
839+ :: Expression schema relations grouping params ('Null ty)
795− -> SortExpression relations grouping params
840+ -> SortExpression schema relations grouping params
796 DescNullsFirst
841 DescNullsFirst
797− :: Expression relations grouping params ('Null ty)
842+ :: Expression schema relations grouping params ('Null ty)
798− -> SortExpression relations grouping params
843+ -> SortExpression schema relations grouping params
799 DescNullsLast
844 DescNullsLast
800− :: Expression relations grouping params ('Null ty)
845+ :: Expression schema relations grouping params ('Null ty)
801− -> SortExpression relations grouping params
846+ -> SortExpression schema relations grouping params
802−deriving instance Show (SortExpression relations grouping params)
847+deriving instance Show (SortExpression schema relations grouping params)
803
848
804-- | Render a `SortExpression`.
849-- | Render a `SortExpression`.
805−renderSortExpression :: SortExpression relations grouping params -> ByteString
850+renderSortExpression :: SortExpression schema relations grouping params -> ByteString
806renderSortExpression = \case
851renderSortExpression = \case
807 Asc expression -> renderExpression expression <+> "ASC"
852 Asc expression -> renderExpression expression <+> "ASC"
808 Desc expression -> renderExpression expression <+> "DESC"
853 Desc expression -> renderExpression expression <+> "DESC"
squeal-postgresql/src/Squeal/PostgreSQL/Render.hs+14−2
@@ -9,12 +9,12 @@ Rendering helper functions.
9-}
9-}
10
10
11{-# LANGUAGE
11{-# LANGUAGE
12+ FlexibleContexts
12− MagicHash
13+ , MagicHash
13 , OverloadedStrings
14 , OverloadedStrings
14 , PolyKinds
15 , PolyKinds
15 , RankNTypes
16 , RankNTypes
16 , ScopedTypeVariables
17 , ScopedTypeVariables
17− , TypeApplications
18#-}
18#-}
19
19
20module Squeal.PostgreSQL.Render
20module Squeal.PostgreSQL.Render
@@ -26,8 +26,11 @@ module Squeal.PostgreSQL.Render
26 , renderCommaSeparated
26 , renderCommaSeparated
27 , renderCommaSeparatedMaybe
27 , renderCommaSeparatedMaybe
28 , renderNat
28 , renderNat
29+ , RenderSQL (..)
30+ , printSQL
29 ) where
31 ) where
30
32
33+import Control.Monad.Base
31import Data.ByteString (ByteString)
34import Data.ByteString (ByteString)
32import Data.Maybe
35import Data.Maybe
33import Data.Monoid ((<>))
36import Data.Monoid ((<>))
@@ -36,6 +39,7 @@ import GHC.Exts
36import GHC.TypeLits
39import GHC.TypeLits
37
40
38import qualified Data.ByteString as ByteString
41import qualified Data.ByteString as ByteString
42+import qualified Data.ByteString.Char8 as Char8
39
43
40-- | Parenthesize a `ByteString`.
44-- | Parenthesize a `ByteString`.
41parenthesized :: ByteString -> ByteString
45parenthesized :: ByteString -> ByteString
@@ -78,3 +82,11 @@ renderCommaSeparatedMaybe render
78-- | Render a promoted `Nat`.
82-- | Render a promoted `Nat`.
79renderNat :: KnownNat n => proxy n -> ByteString
83renderNat :: KnownNat n => proxy n -> ByteString
80renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))
84renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))
85+
86+-- | A class for rendering SQL
87+class RenderSQL sql where
88+ renderSQL :: sql -> ByteString
89+
90+-- | Print SQL.
91+printSQL :: (RenderSQL sql, MonadBase IO io) => sql -> io ()
92+printSQL = liftBase . Char8.putStrLn . renderSQL
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+364−96
@@ -5,32 +5,31 @@ Copyright: (c) Eitan Chatav, 2017
5Maintainer: eitan@morphism.tech
5Maintainer: eitan@morphism.tech
6Stability: experimental
6Stability: experimental
7
7
8−A type-level DSL for kinds of PostgreSQL types, constraints, and aliases.
8+This module 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.
9-}
12-}
10
13
11{-# LANGUAGE
14{-# LANGUAGE
12 AllowAmbiguousTypes
15 AllowAmbiguousTypes
13 , ConstraintKinds
16 , ConstraintKinds
14− , DataKinds
15 , DeriveAnyClass
17 , DeriveAnyClass
16− , DeriveDataTypeable
17 , DeriveGeneric
18 , DeriveGeneric
18 , FlexibleContexts
19 , FlexibleContexts
19 , FlexibleInstances
20 , FlexibleInstances
20 , FunctionalDependencies
21 , FunctionalDependencies
21 , GADTs
22 , GADTs
22− , MagicHash
23− , MultiParamTypeClasses
24 , OverloadedStrings
23 , OverloadedStrings
25− , PolyKinds
26 , RankNTypes
24 , RankNTypes
27 , ScopedTypeVariables
25 , ScopedTypeVariables
28 , StandaloneDeriving
26 , StandaloneDeriving
29 , TypeApplications
27 , TypeApplications
30− , TypeFamilies
28+ , TypeFamilyDependencies
31 , TypeInType
29 , TypeInType
32 , TypeOperators
30 , TypeOperators
33 , UndecidableInstances
31 , UndecidableInstances
32+ , UndecidableSuperClasses
34#-}
33#-}
35
34
36module Squeal.PostgreSQL.Schema
35module Squeal.PostgreSQL.Schema
@@ -39,35 +38,47 @@ module Squeal.PostgreSQL.Schema
39 , HasOid (..)
38 , HasOid (..)
40 , NullityType (..)
39 , NullityType (..)
41 , ColumnType
40 , ColumnType
41+ -- * Tables
42 , ColumnsType
42 , ColumnsType
43 , RelationType
43 , RelationType
44 , NilRelation
44 , NilRelation
45 , RelationsType
45 , RelationsType
46 , TableType
46 , TableType
47− , TablesType
47+ -- * Schema
48− , NilTables
48+ , SchemumType (..)
49− -- * Grouping
49+ , SchemaType
50− , Grouping (..)
51− , GroupedBy
52 -- * Constraints
50 -- * Constraints
53 , (:=>)
51 , (:=>)
54 , ColumnConstraint (..)
52 , ColumnConstraint (..)
55 , TableConstraint (..)
53 , TableConstraint (..)
56 , TableConstraints
54 , TableConstraints
57 , NilTableConstraints
55 , NilTableConstraints
56+ , Uniquely
58 -- * Aliases
57 -- * Aliases
59 , (:::)
58 , (:::)
60 , Alias (Alias)
59 , Alias (Alias)
61 , renderAlias
60 , renderAlias
61+ , renderAliases
62 , Aliased (As)
62 , Aliased (As)
63 , renderAliasedAs
63 , renderAliasedAs
64 , AliasesOf
64 , AliasesOf
65+ , ZipAliased (..)
65 , Has
66 , Has
66 , HasUnique
67 , HasUnique
68+ , HasAll
67 , IsLabel (..)
69 , IsLabel (..)
68 , IsQualified (..)
70 , IsQualified (..)
71+ -- * Enumerated Labels
72+ , IsPGlabel (..)
73+ , PGlabel (..)
74+ , renderLabel
75+ , renderLabels
76+ -- * Grouping
77+ , Grouping (..)
78+ , GroupedBy
69 -- * Type Families
79 -- * Type Families
70 , Join
80 , Join
81+ , With
71 , Create
82 , Create
72 , Drop
83 , Drop
73 , Alter
84 , Alter
@@ -79,35 +90,58 @@ module Squeal.PostgreSQL.Schema
79 , PGFloating
90 , PGFloating
80 , PGTypeOf
91 , PGTypeOf
81 , SameTypes
92 , SameTypes
93+ , SamePGType
82 , AllNotNull
94 , AllNotNull
83 , NotAllNull
95 , NotAllNull
84 , NullifyType
96 , NullifyType
85 , NullifyRelation
97 , NullifyRelation
86 , NullifyRelations
98 , NullifyRelations
87 , ColumnsToRelation
99 , ColumnsToRelation
88− , RelationToColumns
89 , TableToColumns
100 , TableToColumns
90− , TablesToRelations
101+ , TableToRelation
91− , RelationsToTables
92 , ConstraintInvolves
102 , ConstraintInvolves
93 , DropIfConstraintsInvolve
103 , DropIfConstraintsInvolve
94− -- * Generics
104+ -- * Embedding
95− , SameField
105+ , PG
96− , SameFields
106+ , EnumFrom
107+ , LabelsFrom
108+ , CompositeFrom
109+ , FieldNamesFrom
110+ , FieldTypesFrom
111+ , ConstructorsOf
112+ , ConstructorNameOf
113+ , ConstructorNamesOf
114+ , FieldsOf
115+ , FieldNameOf
116+ , FieldNamesOf
117+ , FieldTypeOf
118+ , FieldTypesOf
119+ , RecordCodeOf
120+ , MapMaybes (..)
121+ , Nulls
97 ) where
122 ) where
98
123
99import Control.DeepSeq
124import Control.DeepSeq
100−import Data.ByteString
125+import Data.Aeson (Value)
126+import Data.ByteString (ByteString)
127+import Data.Int (Int16, Int32, Int64)
128+import Data.Kind
101−import Data.Monoid
129+import Data.Monoid hiding (All)
130+import Data.Scientific (Scientific)
102import Data.String
131import Data.String
103−import Data.Word
132+import Data.Text (Text)
133+import Data.Time
134+import Data.Word (Word16, Word32, Word64)
104import Data.Type.Bool
135import Data.Type.Bool
136+import Data.UUID.Types (UUID)
105−import Generics.SOP (AllZip)
137+import Generics.SOP
106−import GHC.Generics (Generic)
107−import GHC.Exts
108import GHC.OverloadedLabels
138import GHC.OverloadedLabels
109import GHC.TypeLits
139import GHC.TypeLits
140+import Network.IP.Addr
110
141
142+import qualified Data.ByteString.Lazy as Lazy
143+import qualified Data.Text.Lazy as Lazy
144+import qualified GHC.Generics as GHC
111import qualified Generics.SOP.Type.Metadata as Type
145import qualified Generics.SOP.Type.Metadata as Type
112
146
113import Squeal.PostgreSQL.Render
147import Squeal.PostgreSQL.Render
@@ -141,6 +175,8 @@ data PGType
141 | PGjsonb -- ^ binary JSON data, decomposed
175 | PGjsonb -- ^ binary JSON data, decomposed
142 | PGvararray PGType -- ^ variable length array
176 | PGvararray PGType -- ^ variable length array
143 | PGfixarray Nat PGType -- ^ fixed length array
177 | PGfixarray Nat PGType -- ^ fixed length array
178+ | PGenum [Symbol]
179+ | PGcomposite [(Symbol, PGType)]
144 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
180 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
145
181
146-- | The object identifier of a `PGType`.
182-- | The object identifier of a `PGType`.
@@ -190,10 +226,7 @@ type (:=>) constraint ty = '(constraint,ty)
190infixr 7 :=>
226infixr 7 :=>
191
227
192-- | The alias operator `:::` is like a promoted version of `As`,
228-- | The alias operator `:::` is like a promoted version of `As`,
193−-- a type level pair between
229+-- a type level pair between an alias and some type.
194−-- an alias and some type, like a column alias and either a `ColumnType` or
195−-- `NullityType` or a table alias and either a `TableType` or a `RelationType`
196−-- or a constraint alias and a `TableConstraint`.
197type (:::) (alias :: Symbol) ty = '(alias,ty)
230type (:::) (alias :: Symbol) ty = '(alias,ty)
198infixr 6 :::
231infixr 6 :::
199
232
@@ -244,6 +277,15 @@ type TableConstraints = [(Symbol,TableConstraint)]
244type family NilTableConstraints :: TableConstraints where
277type family NilTableConstraints :: TableConstraints where
245 NilTableConstraints = '[]
278 NilTableConstraints = '[]
246
279
280+-- | A `ForeignKey` must reference columns that either are
281+-- a `PrimaryKey` or form a `Unique` constraint.
282+type family Uniquely
283+ (key :: [Symbol])
284+ (constraints :: TableConstraints) :: Constraint where
285+ Uniquely key (uq ::: 'Unique key ': constraints) = ()
286+ Uniquely key (pk ::: 'PrimaryKey key ': constraints) = ()
287+ Uniquely key (_ ': constraints) = Uniquely key constraints
288+
247-- | `TableType` encodes a row of constraints on a table as well as the types
289-- | `TableType` encodes a row of constraints on a table as well as the types
248-- of its columns.
290-- of its columns.
249--
291--
@@ -257,31 +299,6 @@ type family NilTableConstraints :: TableConstraints where
257-- :}
299-- :}
258type TableType = (TableConstraints,ColumnsType)
300type TableType = (TableConstraints,ColumnsType)
259
301
260−-- | `TablesType` is a row of `TableType`s, thought of as a union.
261−--
262−-- >>> :{
263−-- type family Schema :: TablesType where
264−-- Schema =
265−-- '[ "users" :::
266−-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
267−-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
268−-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext
269−-- , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2)
270−-- ]
271−-- , "emails" :::
272−-- '[ "pk_emails" ::: 'PrimaryKey '["id"]
273−-- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
274−-- ] :=>
275−-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
276−-- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
277−-- , "email" ::: 'NoDef :=> 'Null 'PGtext
278−-- ]
279−-- ]
280−-- :}
281−type TablesType = [(Symbol,TableType)]
282−-- | A monokinded empty `TablesType`.
283−type family NilTables :: TablesType where NilTables = '[]
284−
285-- | `RelationType` is a row of `NullityType`
302-- | `RelationType` is a row of `NullityType`
286--
303--
287-- >>> :{
304-- >>> :{
@@ -305,27 +322,13 @@ type family ColumnsToRelation (columns :: ColumnsType) :: RelationType where
305 ColumnsToRelation (column ::: constraint :=> ty ': columns) =
322 ColumnsToRelation (column ::: constraint :=> ty ': columns) =
306 column ::: ty ': ColumnsToRelation columns
323 column ::: ty ': ColumnsToRelation columns
307
324
308−-- | `RelationToColumns` adds `'NoDef` column constraints.
309−type family RelationToColumns (relation :: RelationType) :: ColumnsType where
310− RelationToColumns '[] = '[]
311− RelationToColumns (column ::: ty ': columns) =
312− column ::: 'NoDef :=> ty ': RelationToColumns columns
313−
314-- | `TableToColumns` removes table constraints.
325-- | `TableToColumns` removes table constraints.
315type family TableToColumns (table :: TableType) :: ColumnsType where
326type family TableToColumns (table :: TableType) :: ColumnsType where
316 TableToColumns (constraints :=> columns) = columns
327 TableToColumns (constraints :=> columns) = columns
317
328
318−-- | `TablesToRelations` removes both table and column constraints.
329+-- | Convert a table to a relation.
319−type family TablesToRelations (tables :: TablesType) :: RelationsType where
330+type family TableToRelation (table :: TableType) :: RelationType where
320− TablesToRelations '[] = '[]
331+ TableToRelation tab = ColumnsToRelation (TableToColumns tab)
321− TablesToRelations (alias ::: constraint :=> columns ': tables) =
322− alias ::: ColumnsToRelation columns ': TablesToRelations tables
323−
324−-- | `RelationsToTables` adds both trivial table and column constraints.
325−type family RelationsToTables (tables :: RelationsType) :: TablesType where
326− RelationsToTables '[] = '[]
327− RelationsToTables (alias ::: columns ': relations) =
328− alias ::: '[] :=> RelationToColumns columns ': RelationsToTables relations
329
332
330-- | `Grouping` is an auxiliary namespace, created by
333-- | `Grouping` is an auxiliary namespace, created by
331-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
334-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
@@ -355,15 +358,26 @@ instance {-# OVERLAPPABLE #-}
355-- >>> #foobar :: Alias "foobar"
358-- >>> #foobar :: Alias "foobar"
356-- Alias
359-- Alias
357data Alias (alias :: Symbol) = Alias
360data Alias (alias :: Symbol) = Alias
358− deriving (Eq,Generic,Ord,Show,NFData)
361+ deriving (Eq,GHC.Generic,Ord,Show,NFData)
359instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
362instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
360 fromLabel = Alias
363 fromLabel = Alias
364+instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where
365+ fromLabel = fromLabel :* Nil
366+instance KnownSymbol alias => RenderSQL (Alias alias) where renderSQL = renderAlias
361
367
362-- | >>> renderAlias #jimbob
368-- | >>> renderAlias #jimbob
363-- "\"jimbob\""
369-- "\"jimbob\""
364renderAlias :: KnownSymbol alias => Alias alias -> ByteString
370renderAlias :: KnownSymbol alias => Alias alias -> ByteString
365renderAlias = doubleQuoted . fromString . symbolVal
371renderAlias = doubleQuoted . fromString . symbolVal
366
372
373+-- | >>> import Generics.SOP (NP(..))
374+-- >>> renderAliases (#jimbob :* #kandi :* Nil)
375+-- ["\"jimbob\"","\"kandi\""]
376+renderAliases
377+ :: All KnownSymbol aliases => NP Alias aliases -> [ByteString]
378+renderAliases = hcollapse
379+ . hcmap (Proxy @KnownSymbol) (K . renderAlias)
380+
367-- | The `As` operator is used to name an expression. `As` is like a demoted
381-- | The `As` operator is used to name an expression. `As` is like a demoted
368-- version of `:::`.
382-- version of `:::`.
369--
383--
@@ -381,6 +395,9 @@ deriving instance Eq (expression ty)
381 => Eq (Aliased expression (alias ::: ty))
395 => Eq (Aliased expression (alias ::: ty))
382deriving instance Ord (expression ty)
396deriving instance Ord (expression ty)
383 => Ord (Aliased expression (alias ::: ty))
397 => Ord (Aliased expression (alias ::: ty))
398+instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)
399+ => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where
400+ fromLabel = fromLabel @alias2 `As` fromLabel @alias1
384
401
385-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")
402-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")
386-- >>> renderAliasedAs renderMaybe (Just (3::Int) `As` #an_int)
403-- >>> renderAliasedAs renderMaybe (Just (3::Int) `As` #an_int)
@@ -397,12 +414,43 @@ type family AliasesOf aliaseds where
397 AliasesOf '[] = '[]
414 AliasesOf '[] = '[]
398 AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys
415 AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys
399
416
417+-- | The `ZipAliased` class provides a type family for zipping
418+-- `Symbol` lists together with arbitrary lists of the same size,
419+-- with an associated type family `ZipAs`, together with
420+-- a method `zipAs` for zipping heterogeneous lists of `Alias`es
421+-- together with a heterogeneous list of expressions into
422+-- a heterogeneous list of `Aliased` expressions.
423+class
424+ ( SListI (ZipAs ns xs)
425+ , All KnownSymbol ns
426+ ) => ZipAliased ns xs where
427+
428+ type family ZipAs
429+ (ns :: [Symbol]) (xs :: [k]) = (zs :: [(Symbol,k)]) | zs -> ns xs
430+
431+ zipAs
432+ :: NP Alias ns
433+ -> NP expr xs
434+ -> NP (Aliased expr) (ZipAs ns xs)
435+
436+instance ZipAliased '[] '[] where
437+ type ZipAs '[] '[] = '[]
438+ zipAs Nil Nil = Nil
439+
440+instance
441+ ( KnownSymbol n
442+ , ZipAliased ns xs
443+ ) => ZipAliased (n ': ns) (x ': xs) where
444+ type ZipAs (n ': ns) (x ': xs) = '(n,x) ': ZipAs ns xs
445+ zipAs (n :* ns) (x :* xs) = x `As` n :* zipAs ns xs
446+
400-- | @HasUnique alias fields field@ is a constraint that proves that
447-- | @HasUnique alias fields field@ is a constraint that proves that
401-- @fields@ is a singleton of @alias ::: field@.
448-- @fields@ is a singleton of @alias ::: field@.
402type HasUnique alias fields field = fields ~ '[alias ::: field]
449type HasUnique alias fields field = fields ~ '[alias ::: field]
403
450
404-- | @Has alias fields field@ is a constraint that proves that
451-- | @Has alias fields field@ is a constraint that proves that
405−-- @fields@ has a field of @alias ::: field@.
452+-- @fields@ has a field of @alias ::: field@, inferring @field@
453+-- from @alias@ and @fields@.
406class KnownSymbol alias =>
454class KnownSymbol alias =>
407 Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
455 Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
408 | alias fields -> field where
456 | alias fields -> field where
@@ -411,6 +459,20 @@ instance {-# OVERLAPPING #-} KnownSymbol alias
411instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)
459instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)
412 => Has alias (field' ': fields) field
460 => Has alias (field' ': fields) field
413
461
462+-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer
463+-- a list of @subfields@.
464+class
465+ ( All KnownSymbol aliases
466+ ) => HasAll
467+ (aliases :: [Symbol])
468+ (fields :: [(Symbol,kind)])
469+ (subfields :: [(Symbol,kind)])
470+ | aliases fields -> subfields where
471+instance {-# OVERLAPPING #-} HasAll '[] fields '[]
472+instance {-# OVERLAPPABLE #-}
473+ (Has alias fields field, HasAll aliases fields subfields)
474+ => HasAll (alias ': aliases) fields (alias ::: field ': subfields)
475+
414-- | Analagous to `IsLabel`, the constraint
476-- | Analagous to `IsLabel`, the constraint
415-- `IsQualified` defines `!` for a column alias qualified
477-- `IsQualified` defines `!` for a column alias qualified
416-- by a table alias.
478-- by a table alias.
@@ -456,6 +518,13 @@ type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType)
456 SameTypes (column0 ::: def0 :=> ty0 ': columns0) (column1 ::: def1 :=> ty1 ': columns1)
518 SameTypes (column0 ::: def0 :=> ty0 ': columns0) (column1 ::: def1 :=> ty1 ': columns1)
457 = (ty0 ~ ty1, SameTypes columns0 columns1)
519 = (ty0 ~ ty1, SameTypes columns0 columns1)
458
520
521+-- | Equality constraint on the underlying `PGType` of two columns.
522+class SamePGType
523+ (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where
524+instance ty0 ~ ty1 => SamePGType
525+ (alias0 ::: def0 :=> nullity0 ty0)
526+ (alias1 ::: def1 :=> nullity1 ty1)
527+
459-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
528-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
460type family AllNotNull (columns :: ColumnsType) :: Constraint where
529type family AllNotNull (columns :: ColumnsType) :: Constraint where
461 AllNotNull '[] = ()
530 AllNotNull '[] = ()
@@ -497,6 +566,10 @@ type family Join xs ys where
497-- `Squeal.PostgreSQL.Definition.addColumn`.
566-- `Squeal.PostgreSQL.Definition.addColumn`.
498type family Create alias x xs where
567type family Create alias x xs where
499 Create alias x '[] = '[alias ::: x]
568 Create alias x '[] = '[alias ::: x]
569+ Create alias x (alias ::: y ': xs) = TypeError
570+ ('Text "Create: alias "
571+ ':<>: 'ShowType alias
572+ ':<>: 'Text "already in use")
500 Create alias y (x ': xs) = x ': Create alias y xs
573 Create alias y (x ': xs) = x ': Create alias y xs
501
574
502-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
575-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
@@ -506,12 +579,12 @@ type family Drop alias xs where
506 Drop alias ((alias ::: x) ': xs) = xs
579 Drop alias ((alias ::: x) ': xs) = xs
507 Drop alias (x ': xs) = x ': Drop alias xs
580 Drop alias (x ': xs) = x ': Drop alias xs
508
581
509−-- | @Alter alias xs x@ replaces the type associated with an @alias@ in @xs@
582+-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@
510-- with the type `x` and is used in `Squeal.PostgreSQL.Definition.alterTable`
583-- with the type `x` and is used in `Squeal.PostgreSQL.Definition.alterTable`
511-- and `Squeal.PostgreSQL.Definition.alterColumn`.
584-- and `Squeal.PostgreSQL.Definition.alterColumn`.
512−type family Alter alias xs x where
585+type family Alter alias x xs where
513− Alter alias ((alias ::: x0) ': xs) x1 = (alias ::: x1) ': xs
586+ Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
514− Alter alias (x0 ': xs) x1 = x0 ': Alter alias xs x1
587+ Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
515
588
516-- type family AddConstraint constraint ty where
589-- type family AddConstraint constraint ty where
517-- AddConstraint constraint (constraints :=> ty)
590-- AddConstraint constraint (constraints :=> ty)
@@ -533,26 +606,25 @@ type family Rename alias0 alias1 xs where
533 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
606 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
534 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
607 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
535
608
536−-- | A `SameField` constraint is an equality constraint on a
609+-- | `MapMaybes` is used in the binary instances of composite types.
537−-- `Generics.SOP.Type.Metadata.FieldInfo` and the column alias in a `:::` pair.
610+class MapMaybes xs where
538−class SameField
611+ type family Maybes (xs :: [Type]) = (mxs :: [Type]) | mxs -> xs
539− (fieldInfo :: Type.FieldInfo) (fieldty :: (Symbol,NullityType)) where
612+ maybes :: NP Maybe xs -> NP I (Maybes xs)
540−instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty)
613+ unMaybes :: NP I (Maybes xs) -> NP Maybe xs
541−
614+instance MapMaybes '[] where
542−-- | A `SameFields` constraint proves that a
615+ type Maybes '[] = '[]
543−-- `Generics.SOP.Type.Metadata.DatatypeInfo` of a record type has the same
616+ maybes Nil = Nil
544−-- field names as the column AliasesOf of a `ColumnsType`.
617+ unMaybes Nil = Nil
545−type family SameFields
618+instance MapMaybes xs => MapMaybes (x ': xs) where
546− (datatypeInfo :: Type.DatatypeInfo) (columns :: RelationType)
619+ type Maybes (x ': xs) = Maybe x ': Maybes xs
547− :: Constraint where
620+ maybes (x :* xs) = I x :* maybes xs
548− SameFields
621+ unMaybes (I mx :* xs) = mx :* unMaybes xs
549− ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields])
622+
550− columns
623+-- | `Nulls` is used to construct a `Squeal.Postgresql.Expression.row`
551− = AllZip SameField fields columns
624+-- of a composite type.
552− SameFields
625+type family Nulls tys where
553− ('Type.Newtype _module _datatype ('Type.Record _constructor fields))
626+ Nulls '[] = '[]
554− columns
627+ Nulls (field ::: ty ': tys) = field ::: 'Null ty ': Nulls tys
555− = AllZip SameField fields columns
556
628
557-- | Check if a `TableConstraint` involves a column
629-- | Check if a `TableConstraint` involves a column
558type family ConstraintInvolves column constraint where
630type family ConstraintInvolves column constraint where
@@ -569,3 +641,199 @@ type family DropIfConstraintsInvolve column constraints where
569 = If (ConstraintInvolves column constraint)
641 = If (ConstraintInvolves column constraint)
570 (DropIfConstraintsInvolve column constraints)
642 (DropIfConstraintsInvolve column constraints)
571 (alias ::: constraint ': DropIfConstraintsInvolve column constraints)
643 (alias ::: constraint ': DropIfConstraintsInvolve column constraints)
644+
645+-- | A `SchemumType` is a user-defined type, either a `Table`,
646+-- `View` or `Typedef`.
647+data SchemumType
648+ = Table TableType
649+ | View RelationType
650+ | Typedef PGType
651+
652+-- | The schema of a database consists of a list of aliased,
653+-- user-defined `SchemumType`s.
654+type SchemaType = [(Symbol,SchemumType)]
655+
656+-- | Used in `Squeal.Postgresql.Manipulation.with`.
657+type family With
658+ (relations :: RelationsType)
659+ (schema :: SchemaType)
660+ :: SchemaType where
661+ With '[] schema = schema
662+ With (alias ::: rel ': rels) schema =
663+ alias ::: 'View rel ': With rels schema
664+
665+-- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas
666+-- the overloaded label, `fromLabel` is used for column references,
667+-- `label`s are used for enum terms. A `label` is called with
668+-- type application like `label @"beef"`.
669+class IsPGlabel (label :: Symbol) expr where label :: expr
670+instance label ~ label'
671+ => IsPGlabel label (PGlabel label') where label = PGlabel
672+-- | A `PGlabel` unit type with an `IsPGlabel` instance
673+data PGlabel (label :: Symbol) = PGlabel
674+-- | Renders a label
675+renderLabel :: KnownSymbol label => proxy label -> ByteString
676+renderLabel (_ :: proxy label) =
677+ "\'" <> fromString (symbolVal (Proxy @label)) <> "\'"
678+-- | Renders a list of labels
679+renderLabels
680+ :: All KnownSymbol labels => NP PGlabel labels -> [ByteString]
681+renderLabels = hcollapse
682+ . hcmap (Proxy @KnownSymbol) (K . renderLabel)
683+
684+-- | The `PG` type family embeds a subset of Haskell types
685+-- as Postgres basic types.
686+--
687+-- >>> :kind! PG LocalTime
688+-- PG LocalTime :: PGType
689+-- = 'PGtimestamp
690+type family PG (hask :: Type) :: PGType where
691+ PG Bool = 'PGbool
692+ PG Int16 = 'PGint2
693+ PG Int32 = 'PGint4
694+ PG Int64 = 'PGint8
695+ PG Word16 = 'PGint2
696+ PG Word32 = 'PGint4
697+ PG Word64 = 'PGint8
698+ PG Scientific = 'PGnumeric
699+ PG Float = 'PGfloat4
700+ PG Double = 'PGfloat8
701+ PG Char = 'PGchar 1
702+ PG Text = 'PGtext
703+ PG Lazy.Text = 'PGtext
704+ PG ByteString = 'PGbytea
705+ PG Lazy.ByteString = 'PGbytea
706+ PG LocalTime = 'PGtimestamp
707+ PG UTCTime = 'PGtimestamptz
708+ PG Day = 'PGdate
709+ PG TimeOfDay = 'PGtime
710+ PG (TimeOfDay, TimeZone) = 'PGtimetz
711+ PG DiffTime = 'PGinterval
712+ PG UUID = 'PGuuid
713+ PG (NetAddr IP) = 'PGinet
714+ PG Value = 'PGjson
715+ PG ty = TypeError
716+ ('Text "There is no Postgres basic type for " ':<>: 'ShowType ty)
717+
718+-- | The `EnumFrom` type family embeds Haskell enum types, ADTs with
719+-- nullary constructors, as Postgres enum types
720+--
721+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
722+-- >>> instance Generic Schwarma
723+-- >>> instance HasDatatypeInfo Schwarma
724+-- >>> :kind! EnumFrom Schwarma
725+-- EnumFrom Schwarma :: PGType
726+-- = 'PGenum '["Beef", "Lamb", "Chicken"]
727+type family EnumFrom (hask :: Type) :: PGType where
728+ EnumFrom hask = 'PGenum (LabelsFrom hask)
729+
730+-- | The `LabelsFrom` type family calculates the constructors of a
731+-- Haskell enum type.
732+--
733+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
734+-- >>> instance Generic Schwarma
735+-- >>> instance HasDatatypeInfo Schwarma
736+-- >>> :kind! LabelsFrom Schwarma
737+-- LabelsFrom Schwarma :: [Type.ConstructorName]
738+-- = '["Beef", "Lamb", "Chicken"]
739+type family LabelsFrom (hask :: Type) :: [Type.ConstructorName] where
740+ LabelsFrom hask =
741+ ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask))
742+
743+-- | The `CompositeFrom` type family embeds Haskell record types as
744+-- Postgres composite types, as long as the record fields
745+-- are `Maybe`s of Haskell types that can be embedded as basic types
746+-- with the `PG` type family.
747+--
748+-- >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic
749+-- >>> instance Generic Row
750+-- >>> instance HasDatatypeInfo Row
751+-- >>> :kind! CompositeFrom Row
752+-- CompositeFrom Row :: PGType
753+-- = 'PGcomposite '['("a", 'PGint2), '("b", 'PGtimestamp)]
754+type family CompositeFrom (hask :: Type) :: PGType where
755+ CompositeFrom hask =
756+ 'PGcomposite (ZipAs (FieldNamesFrom hask) (FieldTypesFrom hask))
757+
758+-- | >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic
759+-- >>> instance Generic Row
760+-- >>> instance HasDatatypeInfo Row
761+-- >>> :kind! FieldNamesFrom Row
762+-- FieldNamesFrom Row :: [Type.FieldName]
763+-- = '["a", "b"]
764+type family FieldNamesFrom (hask :: Type) :: [Type.FieldName] where
765+ FieldNamesFrom hask = FieldNamesOf (FieldsOf (DatatypeInfoOf hask))
766+
767+-- | >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic
768+-- >>> instance Generic Row
769+-- >>> instance HasDatatypeInfo Row
770+-- >>> :kind! FieldTypesFrom Row
771+-- FieldTypesFrom Row :: [PGType]
772+-- = '['PGint2, 'PGtimestamp]
773+type family FieldTypesFrom (hask :: Type) :: [PGType] where
774+ FieldTypesFrom hask = FieldTypesOf (RecordCodeOf hask (Code hask))
775+
776+-- | Calculates constructors of a datatype.
777+type family ConstructorsOf (datatype :: Type.DatatypeInfo)
778+ :: [Type.ConstructorInfo] where
779+ ConstructorsOf ('Type.ADT _module _datatype constructors) =
780+ constructors
781+ ConstructorsOf ('Type.Newtype _module _datatype constructor) =
782+ '[constructor]
783+
784+-- | Calculates the name of a nullary constructor, otherwise
785+-- generates a type error.
786+type family ConstructorNameOf (constructors :: Type.ConstructorInfo)
787+ :: Type.ConstructorName where
788+ ConstructorNameOf ('Type.Constructor name) = name
789+ ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError
790+ ('Text "ConstructorNameOf error: non-nullary constructor "
791+ ':<>: 'Text name)
792+ ConstructorNameOf ('Type.Record name _fields) = TypeError
793+ ('Text "ConstructorNameOf error: non-nullary constructor "
794+ ':<>: 'Text name)
795+
796+-- | Calculate the names of nullary constructors.
797+type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])
798+ :: [Type.ConstructorName] where
799+ ConstructorNamesOf '[] = '[]
800+ ConstructorNamesOf (constructor ': constructors) =
801+ ConstructorNameOf constructor ': ConstructorNamesOf constructors
802+
803+-- | Calculate the fields of a datatype.
804+type family FieldsOf (datatype :: Type.DatatypeInfo)
805+ :: [Type.FieldInfo] where
806+ FieldsOf ('Type.ADT _module _datatype '[ 'Type.Record _name fields]) =
807+ fields
808+ FieldsOf ('Type.Newtype _module _datatype ('Type.Record _name fields)) =
809+ fields
810+
811+-- | Calculate the name of a field.
812+type family FieldNameOf (field :: Type.FieldInfo) :: Type.FieldName where
813+ FieldNameOf ('Type.FieldInfo name) = name
814+
815+-- | Calculate the names of fields.
816+type family FieldNamesOf (fields :: [Type.FieldInfo])
817+ :: [Type.FieldName] where
818+ FieldNamesOf '[] = '[]
819+ FieldNamesOf (field ': fields) = FieldNameOf field ': FieldNamesOf fields
820+
821+-- | >>> :kind! FieldTypeOf (Maybe Int16)
822+-- FieldTypeOf (Maybe Int16) :: PGType
823+-- = 'PGint2
824+type family FieldTypeOf (maybe :: Type) where
825+ FieldTypeOf (Maybe hask) = PG hask
826+ FieldTypeOf ty = TypeError
827+ ('Text "FieldTypeOf error: non-Maybe type " ':<>: 'ShowType ty)
828+
829+-- | Calculate the types of fields.
830+type family FieldTypesOf (fields :: [Type]) where
831+ FieldTypesOf '[] = '[]
832+ FieldTypesOf (field ': fields) = FieldTypeOf field ': FieldTypesOf fields
833+
834+-- | Inspect the code of an algebraic datatype and ensure it's a product,
835+-- otherwise generate a type error
836+type family RecordCodeOf (hask :: Type) (code ::[[Type]]) :: [Type] where
837+ RecordCodeOf _hask '[tys] = tys
838+ RecordCodeOf hask _tys = TypeError
839+ ('Text "RecordCodeOf error: non-Record type " ':<>: 'ShowType hask)
squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+5−12
@@ -9,16 +9,9 @@ Squeal transaction control language.
9-}
9-}
10
10
11{-# LANGUAGE
11{-# LANGUAGE
12− DataKinds
13− , EmptyCase
14− , FlexibleContexts
12+ FlexibleContexts
15− , FlexibleInstances
16 , LambdaCase
13 , LambdaCase
17 , OverloadedStrings
14 , OverloadedStrings
18− , MultiParamTypeClasses
19− , ScopedTypeVariables
20− , TypeFamilies
21− , TypeInType
22#-}
15#-}
23
16
24module Squeal.PostgreSQL.Transaction
17module Squeal.PostgreSQL.Transaction
@@ -165,22 +158,22 @@ data IsolationLevel
165 = Serializable
158 = Serializable
166 -- ^ Dirty read is not possible.
159 -- ^ Dirty read is not possible.
167 -- Nonrepeatable read is not possible.
160 -- Nonrepeatable read is not possible.
168− -- Phantom read is not possible.
161+ -- Phantom read is not possible.
169 -- Serialization anomaly is not possible.
162 -- Serialization anomaly is not possible.
170 | RepeatableRead
163 | RepeatableRead
171 -- ^ Dirty read is not possible.
164 -- ^ Dirty read is not possible.
172 -- Nonrepeatable read is not possible.
165 -- Nonrepeatable read is not possible.
173− -- Phantom read is not possible.
166+ -- Phantom read is not possible.
174 -- Serialization anomaly is possible.
167 -- Serialization anomaly is possible.
175 | ReadCommitted
168 | ReadCommitted
176 -- ^ Dirty read is not possible.
169 -- ^ Dirty read is not possible.
177 -- Nonrepeatable read is possible.
170 -- Nonrepeatable read is possible.
178− -- Phantom read is possible.
171+ -- Phantom read is possible.
179 -- Serialization anomaly is possible.
172 -- Serialization anomaly is possible.
180 | ReadUncommitted
173 | ReadUncommitted
181 -- ^ Dirty read is not possible.
174 -- ^ Dirty read is not possible.
182 -- Nonrepeatable read is possible.
175 -- Nonrepeatable read is possible.
183− -- Phantom read is possible.
176+ -- Phantom read is possible.
184 -- Serialization anomaly is possible.
177 -- Serialization anomaly is possible.
185 deriving (Show, Eq)
178 deriving (Show, Eq)
186
179
stack.yaml+1−1
@@ -1,3 +1,3 @@
1−resolver: lts-11.1
1+resolver: lts-11.15
2packages:
2packages:
3- squeal-postgresql
3- squeal-postgresql