git.iko.soy/squeal
on dev help sign in
Merge pull request #23 from morphismtech/0.2

0.2

commit1ac00ca33f35af72a66d14f99445a6f79611a8c0 authorEitan Chatav <eitan.chatav@gmail.com> dateMon 26 Mar 2018, 17:39 (9 years ago) parentd94f9e09920eb0
26 files changed+3306−2111
compare with dev
unifiedsplit
.circleci/config.yml+23 .gitignore+1 README.md+162−97 RELEASE NOTES.md+134 circle.yml−12 squeal-postgresql/README.md+162−97 squeal-postgresql/exe/Example.hs+43−36 squeal-postgresql/squeal-postgresql.cabal+35−44 squeal-postgresql/src/Squeal/PostgreSQL.hs+138−102 squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+46−33 squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+270−183 squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+399−336 squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+332−188 squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+318 squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+227−194 squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+133 squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+287−248 squeal-postgresql/src/Squeal/PostgreSQL/Prettyprint.hs → squeal-postgresql/src/Squeal/PostgreSQL/Render.hs+12−4 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+347−102 squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+232 squeal-postgresql/test/DocTest.hs+4 squeal-postgresql/test/Spec.hs−1 squeal-postgresql/test/Squeal/PostgreSQL/DefinitionSpec.hs−124 squeal-postgresql/test/Squeal/PostgreSQL/ManipulationSpec.hs−128 squeal-postgresql/test/Squeal/PostgreSQL/QuerySpec.hs−181 stack.yaml+1−1
.circleci/config.ymlnew file+23
@@ -0,0 +1,23 @@
1+version: 2
2+jobs:
3+ build:
4+ docker:
5+ - image: haskell:latest
6+ - image: circleci/postgres:latest
7+ environment:
8+ POSTGRES_DB: exampledb
9+ steps:
10+ - checkout
11+ - restore_cache:
12+ keys:
13+ - dependency-cache
14+ - run: apt-get update && apt-get install -y libpq-dev xz-utils make
15+ - run: stack upgrade && stack update
16+ - run: stack build
17+ - run: stack test
18+ - run: stack haddock
19+ - save_cache:
20+ key: dependency-cache
21+ paths:
22+ - ".stack-work"
23+ - "/root/.stack/"
.gitignore+1
@@ -17,3 +17,4 @@ cabal.sandbox.config
1717*.eventlog
1818.stack-work/
1919cabal.project.local
20+.DS_Store
README.md+162−97
@@ -2,7 +2,7 @@
22
33![squeal-icon](http://www.emoticonswallpapers.com/emotion/cute-big-pig/cute-pig-smiley-046.gif)
44
5−[![CircleCI](https://circleci.com/gh/echatav/squeal.svg?style=svg&circle-token=a699a654ef50db2c3744fb039cf2087c484d1226)](https://circleci.com/gh/echatav/squeal)
5+[![CircleCI](https://circleci.com/gh/echatav/squeal.svg?style=svg&circle-token=a699a654ef50db2c3744fb039cf2087c484d1226)](https://circleci.com/gh/morphismtech/squeal)
66
77[Github](https://github.com/morphismtech/squeal)
88
@@ -17,148 +17,213 @@
1717## usage
1818
1919Squeal is a deep embedding of PostgreSQL in Haskell. Let's see an example!
20−
21−First, we need some language extensions because Squeal uses modern GHC features.
22−
20+First, we need some language extensions because Squeal uses modern GHC
21+features.
2322```haskell
24−{-# LANGUAGE
25− DataKinds
26− , DeriveGeneric
27− , OverloadedLabels
28− , OverloadedStrings
29− , TypeApplications
30− , TypeOperators
31−#-}
23+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
24+>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators
3225```
3326
34−Here comes the Main module and imports.
27+We'll need some imports.
3528
3629```haskell
37−module Main (main) where
38−
39−import Control.Monad.Base (liftBase)
40−import Data.Int (Int32)
41−import Data.Text (Text)
42−
43−import Squeal.PostgreSQL
30+>>> import Control.Monad (void)
31+>>> import Control.Monad.Base (liftBase)
32+>>> import Data.Int (Int32)
33+>>> import Data.Text (Text)
34+>>> import Squeal.PostgreSQL
4435```
4536
4637We'll use generics to easily convert between Haskell and PostgreSQL values.
4738
4839```haskell
49−import qualified Generics.SOP as SOP
50−import qualified GHC.Generics as GHC
40+>>> import qualified Generics.SOP as SOP
41+>>> import qualified GHC.Generics as GHC
5142```
5243
53−The first step is to define the schema of our database. This is where we use DataKinds and TypeOperators. The schema consists of a type-level list of tables, a `:::` pairing of a type level string or `Symbol` and a list a columns, itself a `:::` pairing of a `Symbol` and a `ColumnType`. The `ColumnType` describes the PostgreSQL type of the column as well as whether or not it may contain `NULL` and whether or not inserts and updates can use a `DEFAULT`. For our schema, we'll define two tables, a users table and an emails table.
44+The first step is to define the schema of our database. This is where
45+we use `DataKinds` and `TypeOperators`. The schema consists of a type-level
46+list of tables, a `:::` pairing of a type level string or
47+`Symbol` and a list a columns, itself a `:::` pairing of a
48+`Symbol` and a `ColumnType`. The `ColumnType` describes the
49+PostgreSQL type of the column as well as whether or not it may contain
50+`NULL` and whether or not inserts and updates can use a `DEFAULT`. For our
51+schema, we'll define two tables, a users table and an emails table.
5452
5553```haskell
54+>>> :{
5655type Schema =
57− '[ "users" :::
58− '[ "id" ::: 'Optional ('NotNull 'PGint4)
59− , "name" ::: 'Required ('NotNull 'PGtext)
56+ '[ "users" :::
57+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
58+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
59+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
6060 ]
6161 , "emails" :::
62− '[ "id" ::: 'Optional ('NotNull 'PGint4)
63− , "user_id" ::: 'Required ('NotNull 'PGint4)
64− , "email" ::: 'Required ('Null 'PGtext)
62+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
63+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
64+ ] :=>
65+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
66+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
67+ , "email" ::: 'NoDef :=> 'Null 'PGtext
6568 ]
6669 ]
70+:}
6771```
6872
69−Next, we'll write Definitions to set up and tear down the schema. In Squeal, a Definition is a `createTable`, `alterTable` or `dropTable` command and has two type parameters, corresponding to the schema before being run and the schema after. We can compose definitions using `>>>`. Here and in the rest of our commands we make use of overloaded labels to refer to named tables and columns in our schema.
73+Next, we'll write `Definition`s to set up and tear down the schema. In
74+Squeal, a `Definition` is a `createTable`, `alterTable` or `dropTable`
75+command and has two type parameters, corresponding to the schema
76+before being run and the schema after. We can compose definitions using
77+`>>>`. Here and in the rest of our commands we make use of overloaded
78+labels to refer to named tables and columns in our schema.
7079
7180```haskell
72−setup :: Definition '[] Schema
73−setup =
74− createTable #users
75− ( serial `As` #id :*
76− (text & notNull) `As` #name :* Nil )
77− [ primaryKey (Column #id :* Nil) ]
78− >>>
79− createTable #emails
80− ( serial `As` #id :*
81− (int & notNull) `As` #user_id :*
82− text `As` #email :* Nil )
83− [ primaryKey (Column #id :* Nil)
84− , foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
85− OnDeleteCascade OnUpdateCascade ]
81+>>> :{
82+let
83+ setup :: Definition '[] Schema
84+ setup =
85+ createTable #users
86+ ( serial `As` #id :*
87+ (text & notNull) `As` #name :* Nil )
88+ ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>>
89+ createTable #emails
90+ ( serial `As` #id :*
91+ (int & notNull) `As` #user_id :*
92+ text `As` #email :* Nil )
93+ ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
94+ foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
95+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
96+:}
8697```
8798
88−Notice that setup starts with an empty schema `'[]` and produces `Schema`. In our `createTable` commands we included `TableConstraint`s to define primary and foreign keys, making them somewhat complex. Our tear down `Definition` is simpler.
99+We can easily see the generated SQL is unsuprising looking.
89100
90101```haskell
91−teardown :: Definition Schema '[]
92−teardown = dropTable #emails >>> dropTable #users
102+>>> renderDefinition setup
103+"CREATE TABLE users (id serial, name text NOT NULL, CONSTRAINT pk_users PRIMARY KEY (id)); CREATE TABLE emails (id serial, user_id int NOT NULL, email text, CONSTRAINT pk_emails PRIMARY KEY (id), CONSTRAINT fk_user_id FOREIGN KEY (user_id) REFERENCES rs (id) ON DELETE CASCADE ON UPDATE CASCADE);"
93104```
94105
95−Next, we'll write `Manipulation`s to insert data into our two tables. A `Manipulation` is an `insertInto`, `update` or `deleteFrom` command and has three type parameters, the schema it refers to, a list of parameters it can take as input, and a list of columns it produces as output. When we insert into the users table, we will need a parameter for the name field but not for the id field. Since it's optional, we can use a default value. However, since the emails table refers to the users table, we will need to retrieve the user id that the insert generates and insert it into the emails table. Take a careful look at the type and definition of both of our inserts.
106+Notice that `setup` starts with an empty schema `'[]` and produces `Schema`.
107+In our `createTable` commands we included `TableConstraint`s to define
108+primary and foreign keys, making them somewhat complex. Our tear down
109+`Definition` is simpler.
96110
97111```haskell
98−insertUser :: Manipulation Schema
99− '[ 'Required ('NotNull 'PGtext)]
100− '[ "fromOnly" ::: 'Required ('NotNull 'PGint4) ]
101−insertUser = insertInto #users
102− ( Values (def `As` #id :* param @1 `As` #name :* Nil) [] )
103− OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
104−
105−insertEmail :: Manipulation Schema
106− '[ 'Required ('NotNull 'PGint4), 'Required ('Null 'PGtext)] '[]
107−insertEmail = insertInto #emails ( Values
108− ( def `As` #id :*
109− param @1 `As` #user_id :*
110− param @2 `As` #email :* Nil) [] )
111− OnConflictDoNothing (Returning Nil)
112+>>> :{
113+let
114+ teardown :: Definition Schema '[]
115+ teardown = dropTable #emails >>> dropTable #users
116+:}
117+>>> renderDefinition teardown
118+"DROP TABLE emails; DROP TABLE users;"
112119```
113120
114−Next we write a `Query` to retrieve users from the database. We're not interested in the ids here, just the usernames and email addresses. We need to use an inner join to get the right result. A `Query` is like a `Manipulation` with the same kind of type parameters.
121+Next, we'll write `Manipulation`s to insert data into our two tables.
122+A `Manipulation` is a `insertInto`, `update` or `deleteFrom` command and
123+has three type parameters, the schema it refers to, a list of parameters
124+it can take as input, and a list of columns it produces as output. When
125+we insert into the users table, we will need a parameter for the `name`
126+field but not for the `id` field. Since it's optional, we can use a default
127+value. However, since the emails table refers to the users table, we will
128+need to retrieve the user id that the insert generates and insert it into
129+the emails table. Take a careful look at the type and definition of both
130+of our inserts.
115131
116132```haskell
117−getUsers :: Query Schema '[]
118− '[ "userName" ::: 'Required ('NotNull 'PGtext)
119− , "userEmail" ::: 'Required ('Null 'PGtext) ]
120−getUsers = select
121− (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)
122− ( from (Table (#users `As` #u)
123− & InnerJoin (Table (#emails `As` #e))
124− (#u ! #id .== #e ! #user_id)) )
133+>>> :{
134+let
135+ insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ]
136+ '[ "fromOnly" ::: 'NotNull 'PGint4 ]
137+ insertUser = insertRow #users
138+ (Default `As` #id :* Set (param `1) `As` #name :* Nil)
139+ OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
140+:}
141+>>> :{
142+let
143+ insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
144+ insertEmail = insertRow #emails
145+ ( Default `As` #id :*
146+ Set (param `1) `As` #user_id :*
147+ Set (param `2) `As` #email :* Nil )
148+ OnConflictDoNothing (Returning Nil)
149+:}
150+>>> renderManipulation insertUser
151+"INSERT INTO users (id, name) VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING URNING id AS fromOnly;"
152+>>> renderManipulation insertEmail
153+"INSERT INTO emails (id, user_id, email) VALUES (DEFAULT, ($1 :: int4), ($2 :: text)N CONFLICT DO NOTHING;"
125154```
126155
127−Now that we've defined the SQL side of things, we'll need a Haskell type for users. We give the type `Generic` and `HasDatatypeInfo` instances so that we can decode the rows we receive when we run getUsers. Notice that the record fields of the `User` type match the column names of `getUsers`.
156+Next we write a `Query` to retrieve users from the database. We're not
157+interested in the ids here, just the usernames and email addresses. We
158+need to use an inner join to get the right result. A `Query` is like a
159+`Manipulation` with the same kind of type parameters.
160+
161+```haskell
162+>>> :{
163+let
164+ getUsers :: Query Schema '[]
165+ '[ "userName" ::: 'NotNull 'PGtext
166+ , "userEmail" ::: 'Null 'PGtext ]
167+ getUsers = select
168+ (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)
169+ ( from (table (#users `As` #u)
170+ & innerJoin (table (#emails `As` #e))
171+ (#u ! #id .== #e ! #user_id)) )
172+:}
173+>>> renderQuery getUsers
174+"SELECT u.name AS userName, e.email AS userEmail FROM users AS u INNER JOIN emails e ON (u.id = e.user_id)"
175+```
176+Now that we've defined the SQL side of things, we'll need a Haskell type
177+for users. We give the type `Generics.SOP.Generic` and
178+`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows
179+we receive when we run `getUsers`. Notice that the record fields of the
180+`User` type match the column names of `getUsers`.
128181
129182```haskell
130−data User = User { userName :: Text, userEmail :: Maybe Text }
131− deriving (Show, GHC.Generic)
132−instance SOP.Generic User
133−instance SOP.HasDatatypeInfo User
183+>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, .Generic)
184+>>> instance SOP.Generic User
185+>>> instance SOP.HasDatatypeInfo User
134186```
135187
136188Let's also create some users to add to the database.
137189
138190```haskell
139−users :: [User]
140−users =
141− [ User "Alice" (Just "alice@gmail.com")
142− , User "Bob" Nothing
143− , User "Carole" (Just "carole@hotmail.com")
144− ]
191+>>> :{
192+let
193+ users :: [User]
194+ users =
195+ [ User "Alice" (Just "alice`gmail.com")
196+ , User "Bob" Nothing
197+ , User "Carole" (Just "carole`hotmail.com")
198+ ]
199+:}
145200```
146201
147−Now we can put together all the pieces into a program. The program connects to the database, sets up the schema, inserts the user data (using prepared statements as an optimization), queries the user data and prints it out and finally closes the connection. We can thread the changing schema information through by using the indexed `PQ` monad transformer and when the schema doesn't change we can use `Monad` and `MonadPQ` functionality.
202+Now we can put together all the pieces into a program. The program
203+connects to the database, sets up the schema, inserts the user data
204+(using prepared statements as an optimization), queries the user
205+data and prints it out and finally closes the connection. We can thread
206+the changing schema information through by using the indexed `PQ` monad
207+transformer and when the schema doesn't change we can use `Monad` and
208+`MonadPQ` functionality.
148209
149210```haskell
150−main :: IO ()
151−main = void $
152− withConnection "host=localhost port=5432 dbname=exampledb" . runPQ $
153− define setup
154− & pqThen session
155− & thenDefine teardown
156− where
157− session = do
158− idResults <- traversePrepared insertUser (Only . userName <$> users)
159− ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults
160− traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
161− usersResult <- runQuery getUsers
162− usersRows <- getRows usersResult
163− liftBase $ print (usersRows :: [User])
211+>>> :{
212+let
213+ session :: PQ Schema Schema IO ()
214+ session = do
215+ idResults <- traversePrepared insertUser (Only . userName <$> users)
216+ ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults
217+ traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
218+ usersResult <- runQuery getUsers
219+ usersRows <- getRows usersResult
220+ liftBase $ print (usersRows :: [User])
221+:}
222+>>> :{
223+void . withConnection "host=localhost port=5432 dbname=exampledb" $
224+ define setup
225+ & pqThen session
226+ & thenDefine teardown
227+:}
228+[User {userName = "Alice", userEmail = Just "alice`gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just role`hotmail.com"}]
164229```
RELEASE NOTES.mdnew file+134
@@ -0,0 +1,134 @@
1+## RELEASE NOTES
2+
3+### Version 0.2 - March 24, 2018
4+
5+**Changes**
6+- **Constraints** - Type level table constraints like primary and foreign keys and column constraints like having `DEFAULT`.
7+- **Migrations** - Support for linear, invertible migrations tracked in an auxiliary table
8+- **Arrays** - Support for fixed- and variable-length arrays
9+- **Aliases** - Generalized `Has` constraint
10+- **Pools** - Support for pooled connections
11+- **Transactions** - Support for transaction control language
12+- **Queries, Manipulations, Definitions** - Small and large changes to Squeal's DSL
13+
14+Well, a lot of things changed!
15+
16+**Constraints**
17+
18+An important request was to bring constraints to the type level.
19+This means that more of the schema is statically known. In `0.1` column constraints - which boil down
20+to having `DEFAULT` or not - were at the type level, but they were confusingly named.
21+
22+```haskell
23+0.1: 'Optional ('NotNull 'PGInt4)
24+0.2: 'Def :=> 'NotNull 'PGInt4
25+0.1: 'Required ('NotNull 'PGInt4)
26+0.2: 'NoDef :=> 'NotNull 'PGInt4
27+```
28+
29+The `:=>` type operator is intended to helpfully connote a constraint relation.
30+It's also used for table constraints which are new in `0.2`.
31+
32+```haskell
33+"emails" :::
34+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
35+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
36+ ] :=>
37+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
38+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
39+ , "email" ::: 'NoDef :=> 'Null 'PGtext
40+ ]
41+```
42+
43+Another change in the constraint system was the removal of column constraints from
44+query and manipulation results, as result columns don't support a notion of `DEFAULT`.
45+This necessitates a distinction between `TableType`s which have both column and table
46+constraints and `RelationType`s which have neither.
47+
48+**Migrations**
49+
50+Migrations are a hot topic and many people have requested this feature. Squeal `0.2`
51+adds support for linear, invertible migrations. That is, a migration is a named,
52+invertible, schema-tracking computation:
53+
54+```haskell
55+data Migration io schema0 schema1 = Migration
56+ { name :: Text -- ^ The `name` of a `Migration`.
57+ -- Each `name` in a `Migration` should be unique.
58+ , up :: PQ schema0 schema1 io () -- ^ The `up` instruction of a `Migration`.
59+ , down :: PQ schema1 schema0 io () -- ^ The `down` instruction of a `Migration`.
60+ }
61+```
62+
63+And, `Migration`s can be put together in an "aligned" list:
64+
65+```haskell
66+data AlignedList p x0 x1 where
67+ Done :: AlignedList p x x
68+ (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
69+```
70+
71+These aligned lists are free categories and might look familiar from
72+the [reflections without remorse](http://okmij.org/ftp/Haskell/zseq.pdf) technique,
73+which uses their cousins, aligned sequences.
74+
75+In the context of migration, they allow one to chain new migrations as a
76+schema evolves over time. `Migration`s' execution is tracked in an auxiliary
77+migrations table. Migration lists can then be run or rewinded.
78+
79+```haskell
80+migrateUp
81+ :: MonadBaseControl IO io
82+ => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run
83+ -> PQ
84+ ("schema_migrations" ::: MigrationsTable ': schema0)
85+ ("schema_migrations" ::: MigrationsTable ': schema1)
86+ io ()
87+
88+migrateDown
89+ :: MonadBaseControl IO io
90+ => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind
91+ -> PQ
92+ ("schema_migrations" ::: MigrationsTable ': schema1)
93+ ("schema_migrations" ::: MigrationsTable ': schema0)
94+ io ()
95+```
96+
97+**Aliases**
98+
99+In Squeal `0.1`, we had different typeclasses `HasColumn` and `HasTable` to indicate
100+that a table has a column or that a schema has a table. In Squeal `0.2` this has been
101+unified to a single typeclass,
102+
103+```haskell
104+class KnownSymbol alias =>
105+ Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
106+ | alias fields -> field where
107+```
108+
109+**Arrays**
110+
111+Support for array types has been added to Squeal `0.2` through
112+the `'PGfixarray` and `'PGvararray` `PGType`s. Array values can be
113+constructed using the `array` function and can be encoded from and decoded to
114+Haskell `Vector`s.
115+
116+**Pools**
117+
118+Squeal `0.2` provides a monad transformer `PoolPQ` that's an instance of `MonadPQ`.
119+The `resource-pool` library is leveraged to provide striped pools of `Connection`s.
120+`PoolPQ` should be a drop in replacement for running `Manipulation`s and `Query`s with
121+`PQ`.
122+
123+**Transactions**
124+
125+Squeal `0.2` supports a simple transaction control language. A computation in
126+`MonadPQ` can be called `transactionally` with different levels of isolation.
127+Additionally, a schema changing computation, a data definition, can be run in a
128+transaction. Running a computation in a transaction means that all SQL statements
129+will be rolled back if an exception is encountered.
130+
131+**Queries, Manipulations and Definitions**
132+
133+The above changes required major and minor changes to Squeal DSL functions.
134+Please consult the documentation.
circle.ymldeleted−12
@@ -1,12 +0,0 @@
1−dependencies:
2− cache_directories:
3− - "~/.stack"
4− - ".stack-work"
5− override:
6− - stack upgrade
7− - stack update
8− - stack setup
9− - stack test --no-run-tests
10−test:
11− override:
12− - stack test
squeal-postgresql/README.md+162−97
@@ -2,7 +2,7 @@
22
33![squeal-icon](http://www.emoticonswallpapers.com/emotion/cute-big-pig/cute-pig-smiley-046.gif)
44
5−[![CircleCI](https://circleci.com/gh/echatav/squeal.svg?style=svg&circle-token=a699a654ef50db2c3744fb039cf2087c484d1226)](https://circleci.com/gh/echatav/squeal)
5+[![CircleCI](https://circleci.com/gh/echatav/squeal.svg?style=svg&circle-token=a699a654ef50db2c3744fb039cf2087c484d1226)](https://circleci.com/gh/morphismtech/squeal)
66
77[Github](https://github.com/morphismtech/squeal)
88
@@ -17,148 +17,213 @@
1717## usage
1818
1919Squeal is a deep embedding of PostgreSQL in Haskell. Let's see an example!
20−
21−First, we need some language extensions because Squeal uses modern GHC features.
22−
20+First, we need some language extensions because Squeal uses modern GHC
21+features.
2322```haskell
24−{-# LANGUAGE
25− DataKinds
26− , DeriveGeneric
27− , OverloadedLabels
28− , OverloadedStrings
29− , TypeApplications
30− , TypeOperators
31−#-}
23+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
24+>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators
3225```
3326
34−Here comes the Main module and imports.
27+We'll need some imports.
3528
3629```haskell
37−module Main (main) where
38−
39−import Control.Monad.Base (liftBase)
40−import Data.Int (Int32)
41−import Data.Text (Text)
42−
43−import Squeal.PostgreSQL
30+>>> import Control.Monad (void)
31+>>> import Control.Monad.Base (liftBase)
32+>>> import Data.Int (Int32)
33+>>> import Data.Text (Text)
34+>>> import Squeal.PostgreSQL
4435```
4536
4637We'll use generics to easily convert between Haskell and PostgreSQL values.
4738
4839```haskell
49−import qualified Generics.SOP as SOP
50−import qualified GHC.Generics as GHC
40+>>> import qualified Generics.SOP as SOP
41+>>> import qualified GHC.Generics as GHC
5142```
5243
53−The first step is to define the schema of our database. This is where we use DataKinds and TypeOperators. The schema consists of a type-level list of tables, a `:::` pairing of a type level string or `Symbol` and a list a columns, itself a `:::` pairing of a `Symbol` and a `ColumnType`. The `ColumnType` describes the PostgreSQL type of the column as well as whether or not it may contain `NULL` and whether or not inserts and updates can use a `DEFAULT`. For our schema, we'll define two tables, a users table and an emails table.
44+The first step is to define the schema of our database. This is where
45+we use `DataKinds` and `TypeOperators`. The schema consists of a type-level
46+list of tables, a `:::` pairing of a type level string or
47+`Symbol` and a list a columns, itself a `:::` pairing of a
48+`Symbol` and a `ColumnType`. The `ColumnType` describes the
49+PostgreSQL type of the column as well as whether or not it may contain
50+`NULL` and whether or not inserts and updates can use a `DEFAULT`. For our
51+schema, we'll define two tables, a users table and an emails table.
5452
5553```haskell
54+>>> :{
5655type Schema =
57− '[ "users" :::
58− '[ "id" ::: 'Optional ('NotNull 'PGint4)
59− , "name" ::: 'Required ('NotNull 'PGtext)
56+ '[ "users" :::
57+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
58+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
59+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
6060 ]
6161 , "emails" :::
62− '[ "id" ::: 'Optional ('NotNull 'PGint4)
63− , "user_id" ::: 'Required ('NotNull 'PGint4)
64− , "email" ::: 'Required ('Null 'PGtext)
62+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
63+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
64+ ] :=>
65+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
66+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
67+ , "email" ::: 'NoDef :=> 'Null 'PGtext
6568 ]
6669 ]
70+:}
6771```
6872
69−Next, we'll write Definitions to set up and tear down the schema. In Squeal, a Definition is a `createTable`, `alterTable` or `dropTable` command and has two type parameters, corresponding to the schema before being run and the schema after. We can compose definitions using `>>>`. Here and in the rest of our commands we make use of overloaded labels to refer to named tables and columns in our schema.
73+Next, we'll write `Definition`s to set up and tear down the schema. In
74+Squeal, a `Definition` is a `createTable`, `alterTable` or `dropTable`
75+command and has two type parameters, corresponding to the schema
76+before being run and the schema after. We can compose definitions using
77+`>>>`. Here and in the rest of our commands we make use of overloaded
78+labels to refer to named tables and columns in our schema.
7079
7180```haskell
72−setup :: Definition '[] Schema
73−setup =
74− createTable #users
75− ( serial `As` #id :*
76− (text & notNull) `As` #name :* Nil )
77− [ primaryKey (Column #id :* Nil) ]
78− >>>
79− createTable #emails
80− ( serial `As` #id :*
81− (int & notNull) `As` #user_id :*
82− text `As` #email :* Nil )
83− [ primaryKey (Column #id :* Nil)
84− , foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
85− OnDeleteCascade OnUpdateCascade ]
81+>>> :{
82+let
83+ setup :: Definition '[] Schema
84+ setup =
85+ createTable #users
86+ ( serial `As` #id :*
87+ (text & notNull) `As` #name :* Nil )
88+ ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>>
89+ createTable #emails
90+ ( serial `As` #id :*
91+ (int & notNull) `As` #user_id :*
92+ text `As` #email :* Nil )
93+ ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
94+ foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
95+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
96+:}
8697```
8798
88−Notice that setup starts with an empty schema `'[]` and produces `Schema`. In our `createTable` commands we included `TableConstraint`s to define primary and foreign keys, making them somewhat complex. Our tear down `Definition` is simpler.
99+We can easily see the generated SQL is unsuprising looking.
89100
90101```haskell
91−teardown :: Definition Schema '[]
92−teardown = dropTable #emails >>> dropTable #users
102+>>> renderDefinition setup
103+"CREATE TABLE users (id serial, name text NOT NULL, CONSTRAINT pk_users PRIMARY KEY (id)); CREATE TABLE emails (id serial, user_id int NOT NULL, email text, CONSTRAINT pk_emails PRIMARY KEY (id), CONSTRAINT fk_user_id FOREIGN KEY (user_id) REFERENCES rs (id) ON DELETE CASCADE ON UPDATE CASCADE);"
93104```
94105
95−Next, we'll write `Manipulation`s to insert data into our two tables. A `Manipulation` is an `insertInto`, `update` or `deleteFrom` command and has three type parameters, the schema it refers to, a list of parameters it can take as input, and a list of columns it produces as output. When we insert into the users table, we will need a parameter for the name field but not for the id field. Since it's optional, we can use a default value. However, since the emails table refers to the users table, we will need to retrieve the user id that the insert generates and insert it into the emails table. Take a careful look at the type and definition of both of our inserts.
106+Notice that `setup` starts with an empty schema `'[]` and produces `Schema`.
107+In our `createTable` commands we included `TableConstraint`s to define
108+primary and foreign keys, making them somewhat complex. Our tear down
109+`Definition` is simpler.
96110
97111```haskell
98−insertUser :: Manipulation Schema
99− '[ 'Required ('NotNull 'PGtext)]
100− '[ "fromOnly" ::: 'Required ('NotNull 'PGint4) ]
101−insertUser = insertInto #users
102− ( Values (def `As` #id :* param @1 `As` #name :* Nil) [] )
103− OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
104−
105−insertEmail :: Manipulation Schema
106− '[ 'Required ('NotNull 'PGint4), 'Required ('Null 'PGtext)] '[]
107−insertEmail = insertInto #emails ( Values
108− ( def `As` #id :*
109− param @1 `As` #user_id :*
110− param @2 `As` #email :* Nil) [] )
111− OnConflictDoNothing (Returning Nil)
112+>>> :{
113+let
114+ teardown :: Definition Schema '[]
115+ teardown = dropTable #emails >>> dropTable #users
116+:}
117+>>> renderDefinition teardown
118+"DROP TABLE emails; DROP TABLE users;"
112119```
113120
114−Next we write a `Query` to retrieve users from the database. We're not interested in the ids here, just the usernames and email addresses. We need to use an inner join to get the right result. A `Query` is like a `Manipulation` with the same kind of type parameters.
121+Next, we'll write `Manipulation`s to insert data into our two tables.
122+A `Manipulation` is a `insertInto`, `update` or `deleteFrom` command and
123+has three type parameters, the schema it refers to, a list of parameters
124+it can take as input, and a list of columns it produces as output. When
125+we insert into the users table, we will need a parameter for the `name`
126+field but not for the `id` field. Since it's optional, we can use a default
127+value. However, since the emails table refers to the users table, we will
128+need to retrieve the user id that the insert generates and insert it into
129+the emails table. Take a careful look at the type and definition of both
130+of our inserts.
115131
116132```haskell
117−getUsers :: Query Schema '[]
118− '[ "userName" ::: 'Required ('NotNull 'PGtext)
119− , "userEmail" ::: 'Required ('Null 'PGtext) ]
120−getUsers = select
121− (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)
122− ( from (Table (#users `As` #u)
123− & InnerJoin (Table (#emails `As` #e))
124− (#u ! #id .== #e ! #user_id)) )
133+>>> :{
134+let
135+ insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ]
136+ '[ "fromOnly" ::: 'NotNull 'PGint4 ]
137+ insertUser = insertRow #users
138+ (Default `As` #id :* Set (param `1) `As` #name :* Nil)
139+ OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
140+:}
141+>>> :{
142+let
143+ insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
144+ insertEmail = insertRow #emails
145+ ( Default `As` #id :*
146+ Set (param `1) `As` #user_id :*
147+ Set (param `2) `As` #email :* Nil )
148+ OnConflictDoNothing (Returning Nil)
149+:}
150+>>> renderManipulation insertUser
151+"INSERT INTO users (id, name) VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING URNING id AS fromOnly;"
152+>>> renderManipulation insertEmail
153+"INSERT INTO emails (id, user_id, email) VALUES (DEFAULT, ($1 :: int4), ($2 :: text)N CONFLICT DO NOTHING;"
125154```
126155
127−Now that we've defined the SQL side of things, we'll need a Haskell type for users. We give the type `Generic` and `HasDatatypeInfo` instances so that we can decode the rows we receive when we run getUsers. Notice that the record fields of the `User` type match the column names of `getUsers`.
156+Next we write a `Query` to retrieve users from the database. We're not
157+interested in the ids here, just the usernames and email addresses. We
158+need to use an inner join to get the right result. A `Query` is like a
159+`Manipulation` with the same kind of type parameters.
160+
161+```haskell
162+>>> :{
163+let
164+ getUsers :: Query Schema '[]
165+ '[ "userName" ::: 'NotNull 'PGtext
166+ , "userEmail" ::: 'Null 'PGtext ]
167+ getUsers = select
168+ (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)
169+ ( from (table (#users `As` #u)
170+ & innerJoin (table (#emails `As` #e))
171+ (#u ! #id .== #e ! #user_id)) )
172+:}
173+>>> renderQuery getUsers
174+"SELECT u.name AS userName, e.email AS userEmail FROM users AS u INNER JOIN emails e ON (u.id = e.user_id)"
175+```
176+Now that we've defined the SQL side of things, we'll need a Haskell type
177+for users. We give the type `Generics.SOP.Generic` and
178+`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows
179+we receive when we run `getUsers`. Notice that the record fields of the
180+`User` type match the column names of `getUsers`.
128181
129182```haskell
130−data User = User { userName :: Text, userEmail :: Maybe Text }
131− deriving (Show, GHC.Generic)
132−instance SOP.Generic User
133−instance SOP.HasDatatypeInfo User
183+>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, .Generic)
184+>>> instance SOP.Generic User
185+>>> instance SOP.HasDatatypeInfo User
134186```
135187
136188Let's also create some users to add to the database.
137189
138190```haskell
139−users :: [User]
140−users =
141− [ User "Alice" (Just "alice@gmail.com")
142− , User "Bob" Nothing
143− , User "Carole" (Just "carole@hotmail.com")
144− ]
191+>>> :{
192+let
193+ users :: [User]
194+ users =
195+ [ User "Alice" (Just "alice`gmail.com")
196+ , User "Bob" Nothing
197+ , User "Carole" (Just "carole`hotmail.com")
198+ ]
199+:}
145200```
146201
147−Now we can put together all the pieces into a program. The program connects to the database, sets up the schema, inserts the user data (using prepared statements as an optimization), queries the user data and prints it out and finally closes the connection. We can thread the changing schema information through by using the indexed `PQ` monad transformer and when the schema doesn't change we can use `Monad` and `MonadPQ` functionality.
202+Now we can put together all the pieces into a program. The program
203+connects to the database, sets up the schema, inserts the user data
204+(using prepared statements as an optimization), queries the user
205+data and prints it out and finally closes the connection. We can thread
206+the changing schema information through by using the indexed `PQ` monad
207+transformer and when the schema doesn't change we can use `Monad` and
208+`MonadPQ` functionality.
148209
149210```haskell
150−main :: IO ()
151−main = void $
152− withConnection "host=localhost port=5432 dbname=exampledb" . runPQ $
153− define setup
154− & pqThen session
155− & thenDefine teardown
156− where
157− session = do
158− idResults <- traversePrepared insertUser (Only . userName <$> users)
159− ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults
160− traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
161− usersResult <- runQuery getUsers
162− usersRows <- getRows usersResult
163− liftBase $ print (usersRows :: [User])
211+>>> :{
212+let
213+ session :: PQ Schema Schema IO ()
214+ session = do
215+ idResults <- traversePrepared insertUser (Only . userName <$> users)
216+ ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults
217+ traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
218+ usersResult <- runQuery getUsers
219+ usersRows <- getRows usersResult
220+ liftBase $ print (usersRows :: [User])
221+:}
222+>>> :{
223+void . withConnection "host=localhost port=5432 dbname=exampledb" $
224+ define setup
225+ & pqThen session
226+ & thenDefine teardown
227+:}
228+[User {userName = "Alice", userEmail = Just "alice`gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just role`hotmail.com"}]
164229```
squeal-postgresql/exe/Example.hs+43−36
@@ -4,6 +4,7 @@
44 , FlexibleContexts
55 , OverloadedLabels
66 , OverloadedStrings
7+ , OverloadedLists
78 , TypeApplications
89 , TypeOperators
910#-}
@@ -12,9 +13,10 @@ module Main (main, main2) where
1213
1314import Control.Monad (void)
1415import Control.Monad.Base (liftBase, MonadBase)
15−import Data.Int (Int32)
16+import Data.Int (Int16, Int32)
1617import Data.Monoid ((<>))
1718import Data.Text (Text)
19+import Data.Vector (Vector)
1820
1921import Squeal.PostgreSQL
2022
@@ -24,13 +26,18 @@ import qualified GHC.Generics as GHC
2426
2527type Schema =
2628 '[ "users" :::
27− '[ "id" ::: 'Optional ('NotNull 'PGint4)
28− , "name" ::: 'Required ('NotNull 'PGtext)
29+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
30+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
31+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
32+ , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2)
2933 ]
3034 , "emails" :::
31− '[ "id" ::: 'Optional ('NotNull 'PGint4)
32− , "user_id" ::: 'Required ('NotNull 'PGint4)
33− , "email" ::: 'Required ('Null 'PGtext)
35+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
36+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
37+ ] :=>
38+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
39+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
40+ , "email" ::: 'NoDef :=> 'Null 'PGtext
3441 ]
3542 ]
3643
@@ -38,61 +45,61 @@ setup :: Definition '[] Schema
3845setup =
3946 createTable #users
4047 ( serial `As` #id :*
41− (text & notNull) `As` #name :* Nil )
42− [ primaryKey (Column #id :* Nil) ]
48+ (text & notNull) `As` #name :*
49+ (vararray int2 & notNull) `As` #vec :* Nil )
50+ ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil )
4351 >>>
4452 createTable #emails
4553 ( serial `As` #id :*
4654 (int & notNull) `As` #user_id :*
4755 text `As` #email :* Nil )
48− [ primaryKey (Column #id :* Nil)
49− , foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
50− OnDeleteCascade OnUpdateCascade ]
56+ ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
57+ foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
58+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
5159
5260teardown :: Definition Schema '[]
5361teardown = dropTable #emails >>> dropTable #users
5462
55−insertUser :: Manipulation Schema
56− '[ 'Required ('NotNull 'PGtext)]
57− '[ "fromOnly" ::: 'Required ('NotNull 'PGint4) ]
58−insertUser = insertInto #users
59− ( Values (def `As` #id :* param @1 `As` #name :* Nil) [] )
63+insertUser :: Manipulation Schema '[ 'NotNull 'PGtext, 'NotNull ('PGvararray 'PGint2)]
64+ '[ "fromOnly" ::: 'NotNull 'PGint4 ]
65+insertUser = insertRows #users
66+ (Default `As` #id :* Set (param @1) `As` #name :* Set (param @2) `As` #vec :* Nil) []
6067 OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
6168
62−insertEmail :: Manipulation Schema
63− '[ 'Required ('NotNull 'PGint4), 'Required ('Null 'PGtext)] '[]
64−insertEmail = insertInto #emails ( Values
65− ( def `As` #id :*
66− param @1 `As` #user_id :*
67− param @2 `As` #email :* Nil) [] )
69+insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]
70+insertEmail = insertRows #emails
71+ ( Default `As` #id :*
72+ Set (param @1) `As` #user_id :*
73+ Set (param @2) `As` #email :* Nil ) []
6874 OnConflictDoNothing (Returning Nil)
6975
7076getUsers :: Query Schema '[]
71− '[ "userName" ::: 'Required ('NotNull 'PGtext)
72− , "userEmail" ::: 'Required ('Null 'PGtext) ]
77+ '[ "userName" ::: 'NotNull 'PGtext
78+ , "userEmail" ::: 'Null 'PGtext
79+ , "userVec" ::: 'NotNull ('PGvararray 'PGint2)]
7380getUsers = select
74− (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)
75− ( from (Table (#users `As` #u)
76− & InnerJoin (Table (#emails `As` #e))
81+ (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* #u ! #vec `As` #userVec :* Nil)
82+ ( from (table (#users `As` #u)
83+ & innerJoin (table (#emails `As` #e))
7784 (#u ! #id .== #e ! #user_id)) )
7885
79−data User = User { userName :: Text, userEmail :: Maybe Text }
86+data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: Vector (Maybe Int16) }
8087 deriving (Show, GHC.Generic)
8188instance SOP.Generic User
8289instance SOP.HasDatatypeInfo User
8390
8491users :: [User]
8592users =
86− [ User "Alice" (Just "alice@gmail.com")
87− , User "Bob" Nothing
88− , User "Carole" (Just "carole@hotmail.com")
93+ [ User "Alice" (Just "alice@gmail.com") [Nothing, Just 1]
94+ , User "Bob" Nothing [Just 2, Nothing]
95+ , User "Carole" (Just "carole@hotmail.com") [Just 3]
8996 ]
9097
9198session :: (MonadBase IO pq, MonadPQ Schema pq) => pq ()
9299session = do
93100 liftBase $ Char8.putStrLn "manipulating"
94− idResults <- traversePrepared insertUser (Only . userName <$> users)
95− ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults
101+ idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])
102+ ids <- traverse (fmap fromOnly . getRow 0) idResults
96103 traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
97104 liftBase $ Char8.putStrLn "querying"
98105 usersResult <- runQuery getUsers
@@ -114,8 +121,8 @@ main = do
114121 finish connection3
115122
116123main2 :: IO ()
117−main2 = void $
118− withConnection "host=localhost port=5432 dbname=exampledb" . runPQ $
124+main2 =
125+ void . withConnection "host=localhost port=5432 dbname=exampledb" $
119126 define setup
120127 & pqThen session
121− & thenDefine teardown
128+ & pqThen (define teardown)
squeal-postgresql/squeal-postgresql.cabal+35−44
@@ -1,5 +1,5 @@
11name: squeal-postgresql
2−version: 0.1.1.4
2+version: 0.2
33synopsis: Squeal PostgreSQL Library
44description: Squeal is a type-safe embedding of PostgreSQL in Haskell
55homepage: https://github.com/morphismtech/squeal
@@ -26,46 +26,36 @@ library
2626 Squeal.PostgreSQL.Definition
2727 Squeal.PostgreSQL.Expression
2828 Squeal.PostgreSQL.Manipulation
29+ Squeal.PostgreSQL.Migration
30+ Squeal.PostgreSQL.Pool
2931 Squeal.PostgreSQL.PQ
30− Squeal.PostgreSQL.Prettyprint
32+ Squeal.PostgreSQL.Render
3133 Squeal.PostgreSQL.Query
3234 Squeal.PostgreSQL.Schema
35+ Squeal.PostgreSQL.Transaction
3336 default-language: Haskell2010
3437 ghc-options: -Wall -fprint-explicit-kinds
3538 build-depends:
36− aeson >= 1.2.1.0 && < 2
37− , base >= 4.10.0.0 && < 5
38− , bytestring >= 0.10.8.2 && < 1
39− , deepseq >= 1.4.3.0 && < 2
40− , generics-sop >= 0.3.1.0 && < 1
41− , lifted-base >= 0.2.3.11 && < 1
42− , monad-control >= 1.0.2.2 && < 2
43− , mtl >= 2.2.1 && < 3
44− , network-ip >= 0.3.0.2 && < 1
45− , postgresql-binary >= 0.12.1 && < 1
46− , postgresql-libpq >= 0.9.3.1 && < 1
47− , scientific >= 0.3.5.1 && < 1
48− , text >= 1.2.2.2 && < 2
49− , time >= 1.8.0.2 && < 2
50− , transformers >= 0.5.2.0 && < 1
51− , transformers-base >= 0.4.4 && < 1
52− , uuid >= 1.3.13 && < 2
53−
54−test-suite squeal-postgresql-spec
55− default-language: Haskell2010
56− type: exitcode-stdio-1.0
57− hs-source-dirs: test
58− ghc-options: -Wall
59− main-is: Spec.hs
60− other-modules:
61− Squeal.PostgreSQL.DefinitionSpec
62− Squeal.PostgreSQL.ManipulationSpec
63− Squeal.PostgreSQL.QuerySpec
64− build-depends:
65− base >= 4.10.0.0 && < 5
66− , generics-sop >= 0.3.1.0 && < 1
67− , hspec >= 2.4.4 && < 3
68− , squeal-postgresql
39+ aeson >= 1.2.4.0
40+ , base >= 4.10.1.0
41+ , bytestring >= 0.10.8.2
42+ , deepseq >= 1.4.3.0
43+ , generics-sop >= 0.3.2.0
44+ , lifted-base >= 0.2.3.12
45+ , mmorph >= 1.1.1
46+ , monad-control >= 1.0.2.3
47+ , mtl >= 2.2.2
48+ , network-ip >= 0.3.0.2
49+ , postgresql-binary >= 0.12.1
50+ , postgresql-libpq >= 0.9.4.1
51+ , resource-pool >= 0.2.3.2
52+ , scientific >= 0.3.5.3
53+ , text >= 1.2.3.0
54+ , time >= 1.8.0.2
55+ , transformers >= 0.5.2.0
56+ , transformers-base >= 0.4.4
57+ , uuid-types >= 1.0.3
58+ , vector >= 0.12.0.1
6959
7060test-suite squeal-postgresql-doctest
7161 default-language: Haskell2010
@@ -74,8 +64,8 @@ test-suite squeal-postgresql-doctest
7464 ghc-options: -Wall
7565 main-is: DocTest.hs
7666 build-depends:
77− base >= 4.10.0.0 && < 5
78− , doctest >= 0.11.4 && < 1
67+ base >= 4.10.0.0
68+ , doctest >= 0.11.4
7969
8070executable squeal-postgresql-example
8171 default-language: Haskell2010
@@ -83,11 +73,12 @@ executable squeal-postgresql-example
8373 ghc-options: -Wall
8474 main-is: Example.hs
8575 build-depends:
86− base >= 4.10.0.0 && < 5
87− , bytestring >= 0.10.8.2 && < 1
88− , generics-sop >= 0.3.1.0 && < 1
89− , mtl >= 2.2.1 && < 3
76+ base >= 4.10.0.0
77+ , bytestring >= 0.10.8.2
78+ , generics-sop >= 0.3.1.0
79+ , mtl >= 2.2.1
9080 , squeal-postgresql
91− , text >= 1.2.2.2 && < 2
92− , transformers >= 0.5.2.0 && < 1
93− , transformers-base >= 0.4.4 && < 1
81+ , text >= 1.2.2.2
82+ , transformers >= 0.5.2.0
83+ , transformers-base >= 0.4.4
84+ , vector >= 0.12.0.1
squeal-postgresql/src/Squeal/PostgreSQL.hs+138−102
@@ -4,55 +4,54 @@
44-- Maintainer: eitan@morphism.tech
55-- Stability: experimental
66--
7−-- Squeal is a deep embedding of PostgreSQL in Haskell. Let's see an example!
7+-- Squeal is a deep embedding of [PostgreSQL](https://www.postgresql.org) in Haskell.
8+-- Let's see an example!
89--
910-- First, we need some language extensions because Squeal uses modern GHC
1011-- features.
1112--
12−-- > {-# LANGUAGE
13−-- > DataKinds
14−-- > , DeriveGeneric
15−-- > , OverloadedLabels
16−-- > , OverloadedStrings
17−-- > , TypeApplications
18−-- > , TypeOperators
19−-- > #-}
13+-- >>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels
14+-- >>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators
2015--
21−-- Here comes the @Main@ module and imports.
16+-- We'll need some imports.
2217--
23−-- > module Main (main) where
24−-- >
25−-- > import Control.Monad.Base (liftBase)
26−-- > import Data.Int (Int32)
27−-- > import Data.Text (Text)
28−-- >
29−-- > import Squeal.PostgreSQL
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
3023--
3124-- We'll use generics to easily convert between Haskell and PostgreSQL values.
3225--
33−-- > import qualified Generics.SOP as SOP
34−-- > import qualified GHC.Generics as GHC
26+-- >>> import qualified Generics.SOP as SOP
27+-- >>> import qualified GHC.Generics as GHC
3528--
3629-- The first step is to define the schema of our database. This is where
37−-- we use @DataKinds@ and @TypeOperators@. The schema consists of a type-level
38−-- list of tables, a `:::` pairing of a type level string or
39−-- @Symbol@ and a list a columns, itself a `:::` pairing of a
40−-- @Symbol@ and a `ColumnType`. The `ColumnType` describes the
41−-- PostgreSQL type of the column as well as whether or not it may contain
42−-- @NULL@ and whether or not inserts and updates can use a @DEFAULT@. For our
43−-- schema, we'll define two tables, a users table and an emails table.
44−--
45−-- > type Schema =
46−-- > '[ "users" :::
47−-- > '[ "id" ::: 'Optional ('NotNull 'PGint4)
48−-- > , "name" ::: 'Required ('NotNull 'PGtext)
49−-- > ]
50−-- > , "emails" :::
51−-- > '[ "id" ::: 'Optional ('NotNull 'PGint4)
52−-- > , "user_id" ::: 'Required ('NotNull 'PGint4)
53−-- > , "email" ::: 'Required ('Null 'PGtext)
54−-- > ]
55−-- > ]
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`.
5655--
5756-- Next, we'll write `Definition`s to set up and tear down the schema. In
5857-- Squeal, a `Definition` is a `createTable`, `alterTable` or `dropTable`
@@ -61,31 +60,45 @@
6160-- `>>>`. Here and in the rest of our commands we make use of overloaded
6261-- labels to refer to named tables and columns in our schema.
6362--
64−-- > setup :: Definition '[] Schema
65−-- > setup =
66−-- > createTable #users
67−-- > ( serial `As` #id :*
68−-- > (text & notNull) `As` #name :* Nil )
69−-- > [ primaryKey (Column #id :* Nil) ]
70−-- > >>>
71−-- > createTable #emails
72−-- > ( serial `As` #id :*
73−-- > (int & notNull) `As` #user_id :*
74−-- > text `As` #email :* Nil )
75−-- > [ primaryKey (Column #id :* Nil)
76−-- > , foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
77−-- > OnDeleteCascade OnUpdateCascade ]
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);"
7884--
7985-- Notice that @setup@ starts with an empty schema @'[]@ and produces @Schema@.
8086-- In our `createTable` commands we included `TableConstraint`s to define
8187-- primary and foreign keys, making them somewhat complex. Our tear down
8288-- `Definition` is simpler.
8389--
84−-- > teardown :: Definition Schema '[]
85−-- > teardown = dropTable #emails >>> dropTable #users
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;"
8698--
8799-- Next, we'll write `Manipulation`s to insert data into our two tables.
88−-- A `Manipulation` is a `insertInto`, `update` or `deleteFrom` command and
100+-- A `Manipulation` is an `insertRow` (or other inserts), `update`
101+-- or `deleteFrom` command and
89102-- has three type parameters, the schema it refers to, a list of parameters
90103-- it can take as input, and a list of columns it produces as output. When
91104-- we insert into the users table, we will need a parameter for the @name@
@@ -95,34 +108,48 @@
95108-- the emails table. Take a careful look at the type and definition of both
96109-- of our inserts.
97110--
98−-- > insertUser :: Manipulation Schema
99−-- > '[ 'Required ('NotNull 'PGtext)]
100−-- > '[ "fromOnly" ::: 'Required ('NotNull 'PGint4) ]
101−-- > insertUser = insertInto #users
102−-- > ( Values (def `As` #id :* param @1 `As` #name :* Nil) [] )
103−-- > OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))
104−-- >
105−-- > insertEmail :: Manipulation Schema
106−-- > '[ 'Required ('NotNull 'PGint4), 'Required ('Null 'PGtext)] '[]
107−-- > insertEmail = insertInto #emails ( Values
108−-- > ( def `As` #id :*
109−-- > param @1 `As` #user_id :*
110−-- > param @2 `As` #email :* Nil) [] )
111−-- > OnConflictDoNothing (Returning Nil)
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;"
112133--
113134-- Next we write a `Query` to retrieve users from the database. We're not
114135-- interested in the ids here, just the usernames and email addresses. We
115136-- need to use an inner join to get the right result. A `Query` is like a
116137-- `Manipulation` with the same kind of type parameters.
117138--
118−-- > getUsers :: Query Schema '[]
119−-- > '[ "userName" ::: 'Required ('NotNull 'PGtext)
120−-- > , "userEmail" ::: 'Required ('Null 'PGtext) ]
121−-- > getUsers = select
122−-- > (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)
123−-- > ( from (Table (#users `As` #u)
124−-- > & InnerJoin (Table (#emails `As` #e))
125−-- > (#u ! #id .== #e ! #user_id)) )
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)"
126153--
127154-- Now that we've defined the SQL side of things, we'll need a Haskell type
128155-- for users. We give the type `Generics.SOP.Generic` and
@@ -130,19 +157,21 @@
130157-- we receive when we run @getUsers@. Notice that the record fields of the
131158-- @User@ type match the column names of @getUsers@.
132159--
133−-- > data User = User { userName :: Text, userEmail :: Maybe Text }
134−-- > deriving (Show, GHC.Generic)
135−-- > instance SOP.Generic User
136−-- > instance SOP.HasDatatypeInfo User
160+-- >>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
161+-- >>> instance SOP.Generic User
162+-- >>> instance SOP.HasDatatypeInfo User
137163--
138164-- Let's also create some users to add to the database.
139165--
140−-- > users :: [User]
141−-- > users =
142−-- > [ User "Alice" (Just "alice@gmail.com")
143−-- > , User "Bob" Nothing
144−-- > , User "Carole" (Just "carole@hotmail.com")
145−-- > ]
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+-- :}
146175--
147176-- Now we can put together all the pieces into a program. The program
148177-- connects to the database, sets up the schema, inserts the user data
@@ -151,21 +180,26 @@
151180-- the changing schema information through by using the indexed `PQ` monad
152181-- transformer and when the schema doesn't change we can use `Monad` and
153182-- `MonadPQ` functionality.
154−--
155−-- > main :: IO ()
156−-- > main = void $
157−-- > withConnection "host=localhost port=5432 dbname=exampledb" . runPQ $
158−-- > define setup
159−-- > & pqThen session
160−-- > & thenDefine teardown
161−-- > where
162−-- > session = do
163−-- > idResults <- traversePrepared insertUser (Only . userName <$> users)
164−-- > ids <- traverse (fmap fromOnly . getRow (RowNumber 0)) idResults
165−-- > traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
166−-- > usersResult <- runQuery getUsers
167−-- > usersRows <- getRows usersResult
168−-- > liftBase $ print (usersRows :: [User])
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"}]
169203
170204module Squeal.PostgreSQL
171205 ( module Squeal.PostgreSQL.Binary
@@ -175,6 +209,7 @@ module Squeal.PostgreSQL
175209 , module Squeal.PostgreSQL.PQ
176210 , module Squeal.PostgreSQL.Query
177211 , module Squeal.PostgreSQL.Schema
212+ , module Squeal.PostgreSQL.Transaction
178213 ) where
179214
180215import Squeal.PostgreSQL.Binary
@@ -184,3 +219,4 @@ import Squeal.PostgreSQL.Manipulation
184219import Squeal.PostgreSQL.PQ
185220import Squeal.PostgreSQL.Query
186221import Squeal.PostgreSQL.Schema
222+import Squeal.PostgreSQL.Transaction
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+46−33
@@ -48,7 +48,8 @@ import Data.Int
4848import Data.Kind
4949import Data.Scientific
5050import Data.Time
51−import Data.UUID
51+import Data.UUID.Types
52+import Data.Vector (Vector)
5253import Data.Word
5354import Generics.SOP
5455import GHC.TypeLits
@@ -58,6 +59,7 @@ import qualified Data.ByteString.Lazy as Lazy
5859import qualified Data.ByteString as Strict hiding (unpack)
5960import qualified Data.Text.Lazy as Lazy
6061import qualified Data.Text as Strict
62+import qualified Data.Vector as Vector
6163import qualified GHC.Generics as GHC
6264import qualified PostgreSQL.Binary.Decoding as Decoding
6365import qualified PostgreSQL.Binary.Encoding as Encoding
@@ -113,39 +115,43 @@ instance ToParam UTCTime 'PGtimestamptz where
113115instance ToParam DiffTime 'PGinterval where toParam = K . Encoding.interval_int
114116instance ToParam Value 'PGjson where toParam = K . Encoding.json_ast
115117instance ToParam Value 'PGjsonb where toParam = K . Encoding.jsonb_ast
118+instance (HasOid pg, ToParam x pg)
119+ => ToParam (Vector (Maybe x)) ('PGvararray pg) where
120+ toParam = K . Encoding.nullableArray_vector
121+ (oid @pg) (unK . toParam @x @pg)
116122
117123-- | A `ToColumnParam` constraint lifts the `ToParam` encoding
118124-- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should
119125-- not define instances of `ToColumnParam`, just use the provided instances.
120−class ToColumnParam (x :: Type) (ty :: ColumnType) where
121− -- | >>> toColumnParam @Int16 @('Required ('NotNull 'PGint2)) 0
126+class ToColumnParam (x :: Type) (ty :: NullityType) where
127+ -- | >>> toColumnParam @Int16 @('NotNull 'PGint2) 0
122128 -- K (Just "\NUL\NUL")
123129 --
124− -- >>> toColumnParam @(Maybe Int16) @('Required ('Null 'PGint2)) (Just 0)
130+ -- >>> toColumnParam @(Maybe Int16) @('Null 'PGint2) (Just 0)
125131 -- K (Just "\NUL\NUL")
126132 --
127− -- >>> toColumnParam @(Maybe Int16) @('Required ('Null 'PGint2)) Nothing
133+ -- >>> toColumnParam @(Maybe Int16) @('Null 'PGint2) Nothing
128134 -- K Nothing
129135 toColumnParam :: x -> K (Maybe Strict.ByteString) ty
130−instance ToParam x pg => ToColumnParam x (optionality ('NotNull pg)) where
136+instance ToParam x pg => ToColumnParam x ('NotNull pg) where
131137 toColumnParam = K . Just . Encoding.encodingBytes . unK . toParam @x @pg
132−instance ToParam x pg => ToColumnParam (Maybe x) (optionality ('Null pg)) where
138+instance ToParam x pg => ToColumnParam (Maybe x) ('Null pg) where
133139 toColumnParam = K . fmap (Encoding.encodingBytes . unK . toParam @x @pg)
134140
135141-- | A `ToParams` constraint generically sequences the encodings of `Type`s
136142-- of the fields of a tuple or record to a row of `ColumnType`s. You should
137143-- not define instances of `ToParams`. Instead define `Generic` instances
138144-- which in turn provide `ToParams` instances.
139−class SListI tys => ToParams (x :: Type) (tys :: [ColumnType]) where
140− -- | >>> type PGparams = '[ 'Required ('NotNull 'PGbool), 'Required ('Null 'PGint2)]
141− -- >>> toParams @(Bool, Maybe Int16) @PGparams (False, Just 0)
142− -- K (Just "\NUL") :* (K (Just "\NUL\NUL") :* Nil)
145+class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where
146+ -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2]
147+ -- >>> toParams @(Bool, Maybe Int16) @'[ 'NotNull 'PGbool, 'Null 'PGint2] (False, Just 0)
148+ -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil
143149 --
144150 -- >>> :set -XDeriveGeneric
145− -- >>> data Hparams = Hparams { col1 :: Bool, col2 :: Maybe Int16} deriving GHC.Generic
146− -- >>> instance Generic Hparams
147− -- >>> toParams @Hparams @PGparams (Hparams False (Just 0))
148− -- K (Just "\NUL") :* (K (Just "\NUL\NUL") :* Nil)
151+ -- >>> data Tuple = Tuple { p1 :: Bool, p2 :: Maybe Int16} deriving GHC.Generic
152+ -- >>> instance Generic Tuple
153+ -- >>> toParams @Tuple @Params (Tuple False (Just 0))
154+ -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil
149155 toParams :: x -> NP (K (Maybe Strict.ByteString)) tys
150156instance (SListI tys, IsProductType x xs, AllZip ToColumnParam xs tys)
151157 => ToParams x tys where
@@ -187,23 +193,31 @@ instance FromValue 'PGinterval DiffTime where
187193 fromValue _ = Decoding.interval_int
188194instance FromValue 'PGjson Value where fromValue _ = Decoding.json_ast
189195instance FromValue 'PGjsonb Value where fromValue _ = Decoding.jsonb_ast
196+instance FromValue pg y => FromValue ('PGvararray pg) (Vector (Maybe y)) where
197+ fromValue _ = Decoding.array
198+ (Decoding.dimensionArray Vector.replicateM
199+ (Decoding.nullableValueArray (fromValue (Proxy @pg))))
200+instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where
201+ fromValue _ = Decoding.array
202+ (Decoding.dimensionArray Vector.replicateM
203+ (Decoding.nullableValueArray (fromValue (Proxy @pg))))
190204
191205-- | A `FromColumnValue` constraint lifts the `FromValue` parser
192206-- to a decoding of a @(Symbol, ColumnType)@ to a `Type`,
193207-- decoding `Null`s to `Maybe`s. You should not define instances for
194208-- `FromColumnValue`, just use the provided instances.
195−class FromColumnValue (colty :: (Symbol,ColumnType)) (y :: Type) where
209+class FromColumnValue (colty :: (Symbol,NullityType)) (y :: Type) where
196210 -- | >>> :set -XTypeOperators -XOverloadedStrings
197211 -- >>> newtype Id = Id { getId :: Int16 } deriving Show
198212 -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue
199− -- >>> fromColumnValue @("col" ::: 'Required ('NotNull 'PGint2)) @Id (K (Just "\NUL\SOH"))
213+ -- >>> fromColumnValue @("col" ::: 'NotNull 'PGint2) @Id (K (Just "\NUL\SOH"))
200214 -- Id {getId = 1}
201215 --
202− -- >>> fromColumnValue @("col" ::: 'Required ('Null 'PGint2)) @(Maybe Id) (K (Just "\NUL\SOH"))
216+ -- >>> fromColumnValue @("col" ::: 'Null 'PGint2) @(Maybe Id) (K (Just "\NUL\SOH"))
203217 -- Just (Id {getId = 1})
204218 fromColumnValue :: K (Maybe Strict.ByteString) colty -> y
205219instance FromValue pg y
206− => FromColumnValue (column ::: ('Required ('NotNull pg))) y where
220+ => FromColumnValue (column ::: ('NotNull pg)) y where
207221 fromColumnValue = \case
208222 K Nothing -> error "fromColumnValue: saw NULL when expecting NOT NULL"
209223 K (Just bytes) ->
@@ -214,7 +228,7 @@ instance FromValue pg y
214228 in
215229 either err id errOrValue
216230instance FromValue pg y
217− => FromColumnValue (column ::: ('Required ('Null pg))) (Maybe y) where
231+ => FromColumnValue (column ::: ('Null pg)) (Maybe y) where
218232 fromColumnValue (K nullOrBytes)
219233 = either err id
220234 . Decoding.valueParser (fromValue @pg @y Proxy)
@@ -223,21 +237,21 @@ instance FromValue pg y
223237 err str = error $ "fromColumnValue: " ++ Strict.unpack str
224238
225239-- | A `FromRow` constraint generically sequences the parsings of the columns
226−-- of a `ColumnsType` into the fields of a record `Type` provided they have
240+-- of a `RelationType` into the fields of a record `Type` provided they have
227241-- the same field names. You should not define instances of `FromRow`.
228242-- Instead define `Generic` and `HasDatatypeInfo` instances which in turn
229243-- provide `FromRow` instances.
230−class SListI results => FromRow (results :: ColumnsType) y where
244+class SListI results => FromRow (results :: RelationType) y where
231245 -- | >>> :set -XOverloadedStrings
232246 -- >>> import Data.Text
233− -- >>> newtype Id = Id { getId :: Int16 } deriving Show
234− -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue
235− -- >>> data Hrow = Hrow { userId :: Id, userName :: Maybe Text } deriving (Show, GHC.Generic)
236− -- >>> instance Generic Hrow
237− -- >>> instance HasDatatypeInfo Hrow
238− -- >>> type PGrow = '["userId" ::: 'Required ('NotNull 'PGint2), "userName" ::: 'Required ('Null 'PGtext)]
239− -- >>> fromRow @PGrow @Hrow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)
240− -- Hrow {userId = Id {getId = 1}, userName = Just "bloodninja"}
247+ -- >>> newtype UserId = UserId { getUserId :: Int16 } deriving Show
248+ -- >>> instance FromValue 'PGint2 UserId where fromValue = fmap UserId . fromValue
249+ -- >>> data UserRow = UserRow { userId :: UserId, userName :: Maybe Text } deriving (Show, GHC.Generic)
250+ -- >>> instance Generic UserRow
251+ -- >>> instance HasDatatypeInfo UserRow
252+ -- >>> type User = '["userId" ::: 'NotNull 'PGint2, "userName" ::: 'Null 'PGtext]
253+ -- >>> fromRow @User @UserRow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)
254+ -- UserRow {userId = UserId {getUserId = 1}, userName = Just "bloodninja"}
241255 fromRow :: NP (K (Maybe Strict.ByteString)) results -> y
242256instance
243257 ( SListI results
@@ -252,11 +266,10 @@ instance
252266-- `toParams` or decoding a single value with `fromRow`.
253267--
254268-- >>> import Data.Text
255−-- >>> toParams @(Only (Maybe Text)) @'[ 'Required ('Null 'PGtext)] (Only (Just "foo"))
269+-- >>> toParams @(Only (Maybe Text)) @'[ 'Null 'PGtext] (Only (Just "foo"))
256270-- K (Just "foo") :* Nil
257271--
258−-- >>> type PGShortRow = '["fromOnly" ::: 'Required ('Null 'PGtext)]
259−-- >>> fromRow @PGShortRow @(Only (Maybe Text)) (K (Just "bar") :* Nil)
272+-- >>> fromRow @'["fromOnly" ::: 'Null 'PGtext] @(Only (Maybe Text)) (K (Just "bar") :* Nil)
260273-- Only {fromOnly = Just "bar"}
261274newtype Only x = Only { fromOnly :: x }
262275 deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+270−183
@@ -9,16 +9,22 @@ Squeal data definition language.
99-}
1010
1111{-# LANGUAGE
12− DataKinds
12+ ConstraintKinds
13+ , DataKinds
1314 , DeriveDataTypeable
1415 , DeriveGeneric
16+ , FlexibleContexts
17+ , FlexibleInstances
1518 , GADTs
1619 , GeneralizedNewtypeDeriving
1720 , KindSignatures
1821 , LambdaCase
22+ , MultiParamTypeClasses
1923 , OverloadedStrings
2024 , RankNTypes
25+ , ScopedTypeVariables
2126 , StandaloneDeriving
27+ , TypeApplications
2228 , TypeInType
2329 , TypeOperators
2430#-}
@@ -29,11 +35,14 @@ module Squeal.PostgreSQL.Definition
2935 , (>>>)
3036 -- * Create
3137 , createTable
32− , TableConstraint (UnsafeTableConstraint, renderTableConstraint)
38+ , createTableIfNotExists
39+ , TableConstraintExpression (..)
40+ , Column (..)
3341 , check
3442 , unique
3543 , primaryKey
3644 , foreignKey
45+ , ForeignKeyed
3746 , OnDeleteClause (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade)
3847 , renderOnDeleteClause
3948 , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)
@@ -43,12 +52,11 @@ module Squeal.PostgreSQL.Definition
4352 -- * Alter
4453 , alterTable
4554 , alterTableRename
46− , alterTableAddConstraint
47− , AlterColumns (UnsafeAlterColumns, renderAlterColumns)
48− , addColumnDefault
49− , addColumnNull
55+ , AlterTable (UnsafeAlterTable, renderAlterTable)
56+ , addConstraint
57+ , dropConstraint
58+ , AddColumn (addColumn)
5059 , dropColumn
51− , dropColumnCascade
5260 , renameColumn
5361 , alterColumn
5462 , AlterColumn (UnsafeAlterColumn, renderAlterColumn)
@@ -70,7 +78,7 @@ import qualified Generics.SOP as SOP
7078import qualified GHC.Generics as GHC
7179
7280import Squeal.PostgreSQL.Expression
73−import Squeal.PostgreSQL.Prettyprint
81+import Squeal.PostgreSQL.Render
7482import Squeal.PostgreSQL.Schema
7583
7684{-----------------------------------------
@@ -100,31 +108,77 @@ CREATE statements
100108-- >>> :set -XOverloadedLabels
101109-- >>> :{
102110-- renderDefinition $
103−-- createTable #tab (int `As` #a :* real `As` #b :* Nil) []
111+-- createTable #tab (int `As` #a :* real `As` #b :* Nil) Nil
104112-- :}
105113-- "CREATE TABLE tab (a int, b real);"
106114createTable
107− :: (KnownSymbol table, SOP.SListI columns)
115+ :: ( KnownSymbol table
116+ , columns ~ (col ': cols)
117+ , SOP.SListI columns
118+ , SOP.SListI constraints )
108119 => Alias table -- ^ the name of the table to add
109− -> NP (Aliased TypeExpression) (column ': columns)
120+ -> NP (Aliased TypeExpression) columns
110121 -- ^ the names and datatype of each column
111− -> [TableConstraint schema (column ': columns)]
122+ -> NP (Aliased (TableConstraintExpression schema columns)) constraints
112123 -- ^ constraints that must hold for the table
113− -> Definition schema (Create table (column ': columns) schema)
124+ -> Definition schema (Create table (constraints :=> columns) schema)
114125createTable table columns constraints = UnsafeDefinition $
115− "CREATE TABLE" <+> renderAlias table
126+ "CREATE TABLE" <+> renderCreation table columns constraints
127+
128+-- | `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
129+-- Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
130+-- `createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in the `Category` `Definition`.
131+--
132+-- >>> :set -XOverloadedLabels -XTypeApplications
133+-- >>> type Table = '[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGfloat4]
134+-- >>> type Schema = '["tab" ::: Table]
135+-- >>> :{
136+-- renderDefinition
137+-- (createTableIfNotExists #tab (int `As` #a :* real `As` #b :* Nil) Nil :: Definition Schema Schema)
138+-- :}
139+-- "CREATE TABLE IF NOT EXISTS tab (a int, b real);"
140+createTableIfNotExists
141+ :: ( Has table schema (constraints :=> columns)
142+ , SOP.SListI columns
143+ , SOP.SListI constraints )
144+ => Alias table -- ^ the name of the table to add
145+ -> NP (Aliased TypeExpression) columns
146+ -- ^ the names and datatype of each column
147+ -> NP (Aliased (TableConstraintExpression schema columns)) constraints
148+ -- ^ constraints that must hold for the table
149+ -> Definition schema schema
150+createTableIfNotExists table columns constraints = UnsafeDefinition $
151+ "CREATE TABLE IF NOT EXISTS"
152+ <+> renderCreation table columns constraints
153+
154+-- helper function for `createTable` and `createTableIfNotExists`
155+renderCreation
156+ :: ( KnownSymbol table
157+ , SOP.SListI columns
158+ , SOP.SListI constraints )
159+ => Alias table -- ^ the name of the table to add
160+ -> NP (Aliased TypeExpression) columns
161+ -- ^ the names and datatype of each column
162+ -> NP (Aliased (TableConstraintExpression schema columns)) constraints
163+ -- ^ constraints that must hold for the table
164+ -> ByteString
165+renderCreation table columns constraints = renderAlias table
116166 <+> parenthesized
117167 ( renderCommaSeparated renderColumnDef columns
118− <> renderConstraints constraints )
168+ <> ( case constraints of
169+ Nil -> ""
170+ _ -> ", " <>
171+ renderCommaSeparated renderConstraint constraints ) )
119172 <> ";"
120173 where
121174 renderColumnDef :: Aliased TypeExpression x -> ByteString
122175 renderColumnDef (ty `As` column) =
123176 renderAlias column <+> renderTypeExpression ty
124− renderConstraints :: [TableConstraint schema columns] -> ByteString
125− renderConstraints = \case
126− [] -> ""
127− _ -> ", " <> commaSeparated (renderTableConstraint <$> constraints)
177+ renderConstraint
178+ :: Aliased (TableConstraintExpression schema columns) constraint
179+ -> ByteString
180+ renderConstraint (constraint `As` alias) =
181+ "CONSTRAINT" <+> renderAlias alias <+> renderTableConstraintExpression constraint
128182
129183-- | Data types are a way to limit the kind of data that can be stored in a
130184-- table. For many applications, however, the constraint they provide is
@@ -138,12 +192,28 @@ createTable table columns constraints = UnsafeDefinition $
138192-- as you wish. If a user attempts to store data in a column that would
139193-- violate a constraint, an error is raised. This applies
140194-- even if the value came from the default value definition.
141−newtype TableConstraint
195+newtype TableConstraintExpression
142196 (schema :: TablesType)
143197 (columns :: ColumnsType)
144− = UnsafeTableConstraint { renderTableConstraint :: ByteString }
198+ (tableConstraint :: TableConstraint)
199+ = UnsafeTableConstraintExpression
200+ { renderTableConstraintExpression :: ByteString }
145201 deriving (GHC.Generic,Show,Eq,Ord,NFData)
146202
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+
147217-- | A `check` constraint is the most generic `TableConstraint` type.
148218-- It allows you to specify that the value in a certain column must satisfy
149219-- a Boolean (truth-value) expression.
@@ -153,14 +223,15 @@ newtype TableConstraint
153223-- createTable #tab
154224-- ( (int & notNull) `As` #a :*
155225-- (int & notNull) `As` #b :* Nil )
156−-- [ check (#a .> #b) ]
226+-- ( check (Column #a :* Column #b :* Nil) (#a .> #b) `As` #inequality :* Nil )
157227-- :}
158−-- "CREATE TABLE tab (a int NOT NULL, b int NOT NULL, CHECK ((a > b)));"
228+-- "CREATE TABLE tab (a int NOT NULL, b int NOT NULL, CONSTRAINT inequality CHECK ((a > b)));"
159229check
160− :: Condition '[table ::: columns] 'Ungrouped '[]
230+ :: NP (Column columns) subcolumns
231+ -> Condition '[table ::: ColumnsToRelation subcolumns] 'Ungrouped '[]
161232 -- ^ condition to check
162− -> TableConstraint schema columns
163−check condition = UnsafeTableConstraint $
233+ -> TableConstraintExpression schema columns ('Check (AliasesOf subcolumns))
234+check _cols condition = UnsafeTableConstraintExpression $
164235 "CHECK" <+> parenthesized (renderExpression condition)
165236
166237-- | A `unique` constraint ensure that the data contained in a column,
@@ -171,15 +242,15 @@ check condition = UnsafeTableConstraint $
171242-- createTable #tab
172243-- ( int `As` #a :*
173244-- int `As` #b :* Nil )
174−-- [ unique (Column #a :* Column #b :* Nil) ]
245+-- ( unique (Column #a :* Column #b :* Nil) `As` #uq_a_b :* Nil )
175246-- :}
176−-- "CREATE TABLE tab (a int, b int, UNIQUE (a, b));"
247+-- "CREATE TABLE tab (a int, b int, CONSTRAINT uq_a_b UNIQUE (a, b));"
177248unique
178249 :: SOP.SListI subcolumns
179250 => NP (Column columns) subcolumns
180251 -- ^ unique column or group of columns
181− -> TableConstraint schema columns
182−unique columns = UnsafeTableConstraint $
252+ -> TableConstraintExpression schema columns ('Unique (AliasesOf subcolumns))
253+unique columns = UnsafeTableConstraintExpression $
183254 "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)
184255
185256-- | A `primaryKey` constraint indicates that a column, or group of columns,
@@ -191,15 +262,15 @@ unique columns = UnsafeTableConstraint $
191262-- createTable #tab
192263-- ( serial `As` #id :*
193264-- (text & notNull) `As` #name :* Nil )
194−-- [ primaryKey (Column #id :* Nil) ]
265+-- ( primaryKey (Column #id :* Nil) `As` #pk_id :* Nil )
195266-- :}
196−-- "CREATE TABLE tab (id serial, name text NOT NULL, PRIMARY KEY (id));"
267+-- "CREATE TABLE tab (id serial, name text NOT NULL, CONSTRAINT pk_id PRIMARY KEY (id));"
197268primaryKey
198269 :: (SOP.SListI subcolumns, AllNotNull subcolumns)
199270 => NP (Column columns) subcolumns
200271 -- ^ identifying column or group of columns
201− -> TableConstraint schema columns
202−primaryKey columns = UnsafeTableConstraint $
272+ -> TableConstraintExpression schema columns ('PrimaryKey (AliasesOf subcolumns))
273+primaryKey columns = UnsafeTableConstraintExpression $
203274 "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
204275
205276-- | A `foreignKey` specifies that the values in a column
@@ -208,59 +279,72 @@ primaryKey columns = UnsafeTableConstraint $
208279-- between two related tables.
209280--
210281-- >>> :{
211−-- let
212−-- definition :: Definition '[]
213−-- '[ "users" :::
214−-- '[ "id" ::: 'Optional ('NotNull 'PGint4)
215−-- , "username" ::: 'Required ('NotNull 'PGtext)
282+-- type Schema =
283+-- '[ "users" :::
284+-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
285+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
286+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext
216287-- ]
217−-- , "emails" :::
218−-- '[ "id" ::: 'Optional ('NotNull 'PGint4)
219−-- , "userid" ::: 'Required ('NotNull 'PGint4)
220−-- , "email" ::: 'Required ('NotNull 'PGtext)
288+-- , "emails" :::
289+-- '[ "pk_emails" ::: 'PrimaryKey '["id"]
290+-- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
291+-- ] :=>
292+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
293+-- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
294+-- , "email" ::: 'NoDef :=> 'Null 'PGtext
221295-- ]
222−-- ]
223−-- definition =
224−-- createTable #users
225−-- (serial `As` #id :* (text & notNull) `As` #username :* Nil)
226−-- [primaryKey (Column #id :* Nil)] >>>
227−-- createTable #emails
228−-- ( serial `As` #id :*
229−-- (integer & notNull) `As` #userid :*
230−-- (text & notNull) `As` #email :* Nil )
231−-- [ primaryKey (Column #id :* Nil)
232−-- , foreignKey (Column #userid :* Nil) #users (Column #id :* Nil)
233−-- OnDeleteCascade OnUpdateRestrict
234−-- ]
235−-- in renderDefinition definition
296+-- ]
297+-- :}
298+--
299+-- >>> :{
300+-- let
301+-- setup :: Definition '[] Schema
302+-- setup =
303+-- createTable #users
304+-- ( serial `As` #id :*
305+-- (text & notNull) `As` #name :* Nil )
306+-- ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>>
307+-- createTable #emails
308+-- ( serial `As` #id :*
309+-- (int & notNull) `As` #user_id :*
310+-- text `As` #email :* Nil )
311+-- ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
312+-- foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
313+-- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
314+-- in renderDefinition setup
236315-- :}
237−-- "CREATE TABLE users (id serial, username text NOT NULL, PRIMARY KEY (id)); CREATE TABLE emails (id serial, userid integer NOT NULL, email text NOT NULL, PRIMARY KEY (id), FOREIGN KEY (userid) REFERENCES users (id) ON DELETE CASCADE ON UPDATE RESTRICT);"
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);"
238317foreignKey
239− :: ( HasTable reftable schema refcolumns
240− , SameTypes subcolumns refsubcolumns
241− , AllNotNull subcolumns
242− , SOP.SListI subcolumns
243− , SOP.SListI refsubcolumns)
318+ :: ForeignKeyed schema table reftable subcolumns refsubcolumns
244319 => NP (Column columns) subcolumns
245320 -- ^ column or columns in the table
246− -> Alias reftable
321+ -> Alias table
247322 -- ^ reference table
248− -> NP (Column refcolumns) refsubcolumns
323+ -> NP (Column (TableToColumns reftable)) refsubcolumns
249324 -- ^ reference column or columns in the reference table
250325 -> OnDeleteClause
251326 -- ^ what to do when reference is deleted
252327 -> OnUpdateClause
253328 -- ^ what to do when reference is updated
254− -> TableConstraint schema columns
329+ -> TableConstraintExpression schema columns
330+ ('ForeignKey (AliasesOf subcolumns) table (AliasesOf refsubcolumns))
255331foreignKey columns reftable refcolumns onDelete onUpdate =
256− UnsafeTableConstraint $
332+ UnsafeTableConstraintExpression $
257333 "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)
258334 <+> "REFERENCES" <+> renderAlias reftable
259335 <+> parenthesized (renderCommaSeparated renderColumn refcolumns)
260336 <+> renderOnDeleteClause onDelete
261337 <+> renderOnUpdateClause onUpdate
262338
263−-- | `OnDelete` indicates what to do with rows that reference a deleted row.
339+-- | A type synonym for constraints on a table with a foreign key.
340+type ForeignKeyed schema table reftable subcolumns refsubcolumns
341+ = ( Has table schema reftable
342+ , SameTypes subcolumns refsubcolumns
343+ , AllNotNull subcolumns
344+ , SOP.SListI subcolumns
345+ , SOP.SListI refsubcolumns )
346+
347+-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
264348data OnDeleteClause
265349 = OnDeleteNoAction
266350 -- ^ if any referencing rows still exist when the constraint is checked,
@@ -279,7 +363,7 @@ renderOnDeleteClause = \case
279363 OnDeleteRestrict -> "ON DELETE RESTRICT"
280364 OnDeleteCascade -> "ON DELETE CASCADE"
281365
282−-- | Analagous to `OnDelete` there is also `OnUpdate` which is invoked
366+-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
283367-- when a referenced column is changed (updated).
284368data OnUpdateClause
285369 = OnUpdateNoAction
@@ -319,14 +403,14 @@ ALTER statements
319403
320404-- | `alterTable` changes the definition of a table from the schema.
321405alterTable
322− :: HasTable table schema columns0
323− => Alias table -- ^ table to alter
324− -> AlterColumns columns0 columns1 -- ^ alteration to perform
325− -> Definition schema (Alter table schema columns1)
406+ :: Has tab schema table0
407+ => Alias tab -- ^ table to alter
408+ -> AlterTable schema table0 table1 -- ^ alteration to perform
409+ -> Definition schema (Alter tab schema table1)
326410alterTable table alteration = UnsafeDefinition $
327411 "ALTER TABLE"
328412 <+> renderAlias table
329− <+> renderAlterColumns alteration
413+ <+> renderAlterTable alteration
330414 <> ";"
331415
332416-- | `alterTableRename` changes the name of a table from the schema.
@@ -342,78 +426,96 @@ alterTableRename table0 table1 = UnsafeDefinition $
342426 "ALTER TABLE" <+> renderAlias table0
343427 <+> "RENAME TO" <+> renderAlias table1 <> ";"
344428
345−-- | An `alterTableAddConstraint` adds a table constraint.
346−--
347−-- >>> :{
348−-- let
349−-- definition :: Definition
350−-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]
351−-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]
352−-- definition = alterTableAddConstraint #tab (check (#col .> 0))
353−-- in renderDefinition definition
354−-- :}
355−-- "ALTER TABLE tab ADD CHECK ((col > 0));"
356−alterTableAddConstraint
357− :: HasTable table schema columns
358− => Alias table -- ^ table to constrain
359− -> TableConstraint schema columns -- ^ what constraint to add
360− -> Definition schema schema
361−alterTableAddConstraint table constraint = UnsafeDefinition $
362− "ALTER TABLE" <+> renderAlias table
363− <+> "ADD" <+> renderTableConstraint constraint <> ";"
364−
365−-- | An `AlterColumns` describes the alteration to perform on the columns
429+-- | An `AlterTable` describes the alteration to perform on the columns
366430-- of a table.
367−newtype AlterColumns
368− (columns0 :: ColumnsType)
369− (columns1 :: ColumnsType) =
370− UnsafeAlterColumns {renderAlterColumns :: ByteString}
431+newtype AlterTable
432+ (schema :: TablesType)
433+ (table0 :: TableType)
434+ (table1 :: TableType) =
435+ UnsafeAlterTable {renderAlterTable :: ByteString}
371436 deriving (GHC.Generic,Show,Eq,Ord,NFData)
372437
373−-- | An `addColumnDefault` adds a new `Optional` column. The new column is
374−-- initially filled with whatever default value is given.
438+-- | An `addConstraint` adds a table constraint.
375439--
376440-- >>> :{
377441-- let
378442-- definition :: Definition
379−-- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]
380−-- '["tab" :::
381−-- '[ "col1" ::: 'Required ('Null 'PGint4)
382−-- , "col2" ::: 'Optional ('Null 'PGtext) ]]
383−-- definition = alterTable #tab
384−-- (addColumnDefault #col2 (text & default_ "foo"))
443+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
444+-- '["tab" ::: '["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
445+-- definition = alterTable #tab (addConstraint #positive (check (Column #col :* Nil) (#col .> 0)))
385446-- in renderDefinition definition
386447-- :}
387−-- "ALTER TABLE tab ADD COLUMN col2 text DEFAULT E'foo';"
388−addColumnDefault
389− :: KnownSymbol column
390− => Alias column -- ^ column to add
391− -> TypeExpression ('Optional ty) -- ^ type of the new column
392− -> AlterColumns columns (Create column ('Optional ty) columns)
393−addColumnDefault column ty = UnsafeAlterColumns $
394− "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
395−
396−-- | An `addColumnNull` adds a new `Null` column. The new column is initially
397−-- filled with @NULL@s.
448+-- "ALTER TABLE tab ADD CONSTRAINT positive CHECK ((col > 0));"
449+addConstraint
450+ :: KnownSymbol alias
451+ => Alias alias
452+ -> TableConstraintExpression schema columns constraint
453+ -- ^ constraint to add
454+ -> AlterTable schema (constraints :=> columns)
455+ (Create alias constraint constraints :=> columns)
456+addConstraint alias constraint = UnsafeAlterTable $
457+ "ADD" <+> "CONSTRAINT" <+> renderAlias alias
458+ <+> renderTableConstraintExpression constraint
459+
460+-- | A `dropConstraint` drops a table constraint.
398461--
399462-- >>> :{
400463-- let
401464-- definition :: Definition
402−-- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]
403−-- '["tab" :::
404−-- '[ "col1" ::: 'Required ('Null 'PGint4)
405−-- , "col2" ::: 'Required ('Null 'PGtext) ]]
406−-- definition = alterTable #tab (addColumnNull #col2 text)
465+-- '["tab" ::: '["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
466+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
467+-- definition = alterTable #tab (dropConstraint #positive)
407468-- in renderDefinition definition
408469-- :}
409−-- "ALTER TABLE tab ADD COLUMN col2 text;"
410−addColumnNull
411− :: KnownSymbol column
412− => Alias column -- ^ column to add
413− -> TypeExpression ('Required ('Null ty)) -- ^ type of the new column
414− -> AlterColumns columns (Create column ('Required ('Null ty)) columns)
415−addColumnNull column ty = UnsafeAlterColumns $
416− "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
470+-- "ALTER TABLE tab DROP CONSTRAINT positive;"
471+dropConstraint
472+ :: KnownSymbol constraint
473+ => Alias constraint
474+ -- ^ constraint to drop
475+ -> AlterTable schema
476+ (constraints :=> columns)
477+ (Drop constraint constraints :=> columns)
478+dropConstraint constraint = UnsafeAlterTable $
479+ "DROP" <+> "CONSTRAINT" <+> renderAlias constraint
480+
481+-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
482+class AddColumn ty where
483+ -- | `addColumn` adds a new column, initially filled with whatever
484+ -- default value is given or with @NULL@.
485+ --
486+ -- >>> :{
487+ -- let
488+ -- definition :: Definition
489+ -- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]]
490+ -- '["tab" ::: '[] :=>
491+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
492+ -- , "col2" ::: 'Def :=> 'Null 'PGtext ]]
493+ -- definition = alterTable #tab (addColumn #col2 (text & default_ "foo"))
494+ -- in renderDefinition definition
495+ -- :}
496+ -- "ALTER TABLE tab ADD COLUMN col2 text DEFAULT E'foo';"
497+ --
498+ -- >>> :{
499+ -- let
500+ -- definition :: Definition
501+ -- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]]
502+ -- '["tab" ::: '[] :=>
503+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
504+ -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ]]
505+ -- definition = alterTable #tab (addColumn #col2 text)
506+ -- in renderDefinition definition
507+ -- :}
508+ -- "ALTER TABLE tab ADD COLUMN col2 text;"
509+ addColumn
510+ :: KnownSymbol column
511+ => Alias column -- ^ column to add
512+ -> TypeExpression ty -- ^ type of the new column
513+ -> AlterTable schema (constraints :=> columns)
514+ (constraints :=> Create column ty columns)
515+ addColumn column ty = UnsafeAlterTable $
516+ "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty
517+instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
518+instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
417519
418520-- | A `dropColumn` removes a column. Whatever data was in the column
419521-- disappears. Table constraints involving the column are dropped, too.
@@ -423,10 +525,10 @@ addColumnNull column ty = UnsafeAlterColumns $
423525-- >>> :{
424526-- let
425527-- definition :: Definition
426−-- '["tab" :::
427−-- '[ "col1" ::: 'Required ('Null 'PGint4)
428−-- , "col2" ::: 'Required ('Null 'PGtext) ]]
429−-- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]
528+-- '["tab" ::: '[] :=>
529+-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
530+-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ]]
531+-- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]]
430532-- definition = alterTable #tab (dropColumn #col2)
431533-- in renderDefinition definition
432534-- :}
@@ -434,57 +536,40 @@ addColumnNull column ty = UnsafeAlterColumns $
434536dropColumn
435537 :: KnownSymbol column
436538 => Alias column -- ^ column to remove
437− -> AlterColumns columns (Drop column columns)
438−dropColumn column = UnsafeAlterColumns $
539+ -> AlterTable schema
540+ (constraints :=> columns)
541+ (DropIfConstraintsInvolve column constraints :=> Drop column columns)
542+dropColumn column = UnsafeAlterTable $
439543 "DROP COLUMN" <+> renderAlias column
440544
441−-- | Like `dropColumn` but authorizes dropping everything that depends
442−-- on the column.
443−--
444−-- >>> :{
445−-- let
446−-- definition :: Definition
447−-- '["tab" :::
448−-- '[ "col1" ::: 'Required ('Null 'PGint4)
449−-- , "col2" ::: 'Required ('Null 'PGtext) ]]
450−-- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]
451−-- definition = alterTable #tab (dropColumnCascade #col2)
452−-- in renderDefinition definition
453−-- :}
454−-- "ALTER TABLE tab DROP COLUMN col2 CASCADE;"
455−dropColumnCascade
456− :: KnownSymbol column
457− => Alias column -- ^ column to remove
458− -> AlterColumns columns (Drop column columns)
459−dropColumnCascade column = UnsafeAlterColumns $
460− "DROP COLUMN" <+> renderAlias column <+> "CASCADE"
461−
462545-- | A `renameColumn` renames a column.
463546--
464547-- >>> :{
465548-- let
466549-- definition :: Definition
467−-- '["tab" ::: '["foo" ::: 'Required ('Null 'PGint4)]]
468−-- '["tab" ::: '["bar" ::: 'Required ('Null 'PGint4)]]
550+-- '["tab" ::: '[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4]]
551+-- '["tab" ::: '[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4]]
469552-- definition = alterTable #tab (renameColumn #foo #bar)
470553-- in renderDefinition definition
471554-- :}
472555-- "ALTER TABLE tab RENAME COLUMN foo TO bar;"
473556renameColumn
474557 :: (KnownSymbol column0, KnownSymbol column1)
475− => Alias column0
476− -> Alias column1
477− -> AlterColumns columns (Rename column0 column1 columns)
478−renameColumn column0 column1 = UnsafeAlterColumns $
558+ => Alias column0 -- ^ column to rename
559+ -> Alias column1 -- ^ what to rename the column
560+ -> AlterTable schema (constraints :=> columns)
561+ (constraints :=> Rename column0 column1 columns)
562+renameColumn column0 column1 = UnsafeAlterTable $
479563 "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1
480564
481565-- | An `alterColumn` alters a single column.
482566alterColumn
483− :: (KnownSymbol column, HasColumn column columns ty0)
567+ :: (KnownSymbol column, Has column columns ty0)
484568 => Alias column -- ^ column to alter
485569 -> AlterColumn ty0 ty1 -- ^ alteration to perform
486− -> AlterColumns columns (Alter column columns ty1)
487−alterColumn column alteration = UnsafeAlterColumns $
570+ -> AlterTable schema (constraints :=> columns)
571+ (constraints :=> Alter column columns ty1)
572+alterColumn column alteration = UnsafeAlterTable $
488573 "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration
489574
490575-- | An `AlterColumn` describes the alteration to perform on a single column.
@@ -494,20 +579,20 @@ newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) =
494579
495580-- | A `setDefault` sets a new default for a column. Note that this doesn't
496581-- affect any existing rows in the table, it just changes the default for
497−-- future `insertTable` and `updateTable` commands.
582+-- future insert and update commands.
498583--
499584-- >>> :{
500585-- let
501586-- definition :: Definition
502−-- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]
503−-- '["tab" ::: '["col" ::: 'Optional ('Null 'PGint4)]]
587+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
588+-- '["tab" ::: '[] :=> '["col" ::: 'Def :=> 'Null 'PGint4]]
504589-- definition = alterTable #tab (alterColumn #col (setDefault 5))
505590-- in renderDefinition definition
506591-- :}
507592-- "ALTER TABLE tab ALTER COLUMN col SET DEFAULT 5;"
508593setDefault
509− :: Expression '[] 'Ungrouped '[] ('Required ty) -- ^ default value to set
510− -> AlterColumn (optionality ty) ('Optional ty)
594+ :: Expression '[] 'Ungrouped '[] ty -- ^ default value to set
595+ -> AlterColumn (constraint :=> ty) ('Def :=> ty)
511596setDefault expression = UnsafeAlterColumn $
512597 "SET DEFAULT" <+> renderExpression expression
513598
@@ -516,13 +601,13 @@ setDefault expression = UnsafeAlterColumn $
516601-- >>> :{
517602-- let
518603-- definition :: Definition
519−-- '["tab" ::: '["col" ::: 'Optional ('Null 'PGint4)]]
520−-- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]
604+-- '["tab" ::: '[] :=> '["col" ::: 'Def :=> 'Null 'PGint4]]
605+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
521606-- definition = alterTable #tab (alterColumn #col dropDefault)
522607-- in renderDefinition definition
523608-- :}
524609-- "ALTER TABLE tab ALTER COLUMN col DROP DEFAULT;"
525−dropDefault :: AlterColumn (optionality ty) ('Required ty)
610+dropDefault :: AlterColumn ('Def :=> ty) ('NoDef :=> ty)
526611dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
527612
528613-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
@@ -532,13 +617,14 @@ dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
532617-- >>> :{
533618-- let
534619-- definition :: Definition
535−-- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]
536−-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]
620+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
621+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
537622-- definition = alterTable #tab (alterColumn #col setNotNull)
538623-- in renderDefinition definition
539624-- :}
540625-- "ALTER TABLE tab ALTER COLUMN col SET NOT NULL;"
541−setNotNull :: AlterColumn (optionality ('Null ty)) (optionality ('NotNull ty))
626+setNotNull
627+ :: AlterColumn (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
542628setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
543629
544630-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
@@ -546,13 +632,14 @@ setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
546632-- >>> :{
547633-- let
548634-- definition :: Definition
549−-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]
550−-- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]
635+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
636+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
551637-- definition = alterTable #tab (alterColumn #col dropNotNull)
552638-- in renderDefinition definition
553639-- :}
554640-- "ALTER TABLE tab ALTER COLUMN col DROP NOT NULL;"
555−dropNotNull :: AlterColumn (optionality ('NotNull ty)) (optionality ('Null ty))
641+dropNotNull
642+ :: AlterColumn (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
556643dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
557644
558645-- | An `alterType` converts a column to a different data type.
@@ -562,8 +649,8 @@ dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
562649-- >>> :{
563650-- let
564651-- definition :: Definition
565−-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]
566−-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGnumeric)]]
652+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]
653+-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric]]
567654-- definition =
568655-- alterTable #tab (alterColumn #col (alterType (numeric & notNull)))
569656-- in renderDefinition definition
squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+399−336
@@ -37,13 +37,6 @@ module Squeal.PostgreSQL.Expression
3737 ( -- * Expression
3838 Expression (UnsafeExpression, renderExpression)
3939 , HasParameter (param)
40− , HasColumn (getColumn)
41− , Column (Column)
42− , renderColumn
43− , GroupedBy (getGroup1, getGroup2)
44− -- ** Default
45− , def
46− , unDef
4740 -- ** Null
4841 , null_
4942 , unNull
@@ -53,7 +46,9 @@ module Squeal.PostgreSQL.Expression
5346 , isn'tNull
5447 , matchNull
5548 , nullIf
56− -- ** Functions
49+ -- ** Arrays
50+ , array
51+ -- ** Functions
5752 , unsafeBinaryOp
5853 , unsafeUnaryOp
5954 , unsafeFunction
@@ -104,8 +99,7 @@ module Squeal.PostgreSQL.Expression
10499 , max_, maxDistinct, min_, minDistinct
105100 -- * Tables
106101 , Table (UnsafeTable, renderTable)
107− , HasTable (getTable)
108− -- * TypeExpression
102+ -- * Types
109103 , TypeExpression (UnsafeTypeExpression, renderTypeExpression)
110104 , PGTyped (pgtype)
111105 , bool
@@ -143,6 +137,8 @@ module Squeal.PostgreSQL.Expression
143137 , inet
144138 , json
145139 , jsonb
140+ , vararray
141+ , fixarray
146142 , notNull
147143 , default_
148144 -- * Re-export
@@ -164,7 +160,7 @@ import Prelude hiding (id, (.))
164160
165161import qualified GHC.Generics as GHC
166162
167−import Squeal.PostgreSQL.Prettyprint
163+import Squeal.PostgreSQL.Render
168164import Squeal.PostgreSQL.Schema
169165
170166{-----------------------------------------
@@ -181,10 +177,10 @@ values from primitive expression using arithmetic, logical,
181177and other operations.
182178-}
183179newtype Expression
184− (tables :: TablesType)
180+ (relations :: RelationsType)
185181 (grouping :: Grouping)
186− (params :: [ColumnType])
187− (ty :: ColumnType)
182+ (params :: [NullityType])
183+ (ty :: NullityType)
188184 = UnsafeExpression { renderExpression :: ByteString }
189185 deriving (GHC.Generic,Show,Eq,Ord,NFData)
190186
@@ -196,123 +192,51 @@ supplied externally to a SQL statement.
196192separately from the SQL command string, in which case `param`s are used to
197193refer to the out-of-line data values.
198194-}
199−class (PGTyped (BaseType ty), KnownNat n)
200− => HasParameter (n :: Nat) params ty | n params -> ty where
201− param :: Expression tables grouping params ty
195+class (PGTyped (PGTypeOf ty), KnownNat n) => HasParameter
196+ (n :: Nat)
197+ (params :: [NullityType])
198+ (ty :: NullityType)
199+ | n params -> ty where
200+ param :: Expression relations grouping params ty
202201 param = UnsafeExpression $ parenthesized $
203202 "$" <> renderNat (Proxy @n) <+> "::"
204− <+> renderTypeExpression (pgtype @(BaseType ty))
205−instance {-# OVERLAPPING #-} PGTyped (BaseType ty1)
203+ <+> renderTypeExpression (pgtype @(PGTypeOf ty))
204+instance {-# OVERLAPPING #-} PGTyped (PGTypeOf ty1)
206205 => HasParameter 1 (ty1:tys) ty1
207206instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
208207 => HasParameter n (ty' : params) ty
209208
210−{- | A `HasColumn` constraint indicates an unqualified column reference.
211−`getColumn` can only be unambiguous when the `TableExpression` the column
212−references is unique, in which case the column may be referenced using
213−@-XOverloadedLabels@. Otherwise, combined with a `HasTable` constraint, the
214−qualified column reference operator `!` may be used.
215−-}
216−class KnownSymbol column => HasColumn column columns ty
217− | column columns -> ty where
218− getColumn
219− :: HasUnique table tables columns
220− => Alias column
221− -> Expression tables 'Ungrouped params ty
222− getColumn column = UnsafeExpression $ renderAlias column
223−instance {-# OVERLAPPING #-} KnownSymbol column
224− => HasColumn column ((column ::: optionality ty) ': tys) ('Required ty)
225−instance {-# OVERLAPPABLE #-} (KnownSymbol column, HasColumn column table ty)
226− => HasColumn column (ty' ': table) ty
227−
228−instance (HasColumn column columns ty, HasUnique table tables columns)
229− => IsLabel column (Expression tables 'Ungrouped params ty) where
230− fromLabel = getColumn (Alias @column)
231−
232−instance (HasTable table tables columns, HasColumn column columns ty)
233− => IsTableColumn table column (Expression tables 'Ungrouped params ty) where
234− table ! column = UnsafeExpression $
235− renderAlias table <> "." <> renderAlias column
236−
237−-- | A `Column` is a witness to a `HasColumn` constraint. It's used
238−-- in `Squeel.PostgreSQL.Definition.unique` and other
239−-- `Squeel.PostgreSQL.Definition.TableConstraint`s to witness a
240−-- subcolumns relationship.
241−data Column
242− (columns :: ColumnsType)
243− (columnty :: (Symbol,ColumnType))
244− where
245− Column
246− :: HasColumn column columns ty
247− => Alias column
248− -> Column columns (column ::: ty)
249−deriving instance Show (Column columns columnty)
250−deriving instance Eq (Column columns columnty)
251−deriving instance Ord (Column columns columnty)
252−
253−-- | Render a `Column`.
254−renderColumn :: Column columns columnty -> ByteString
255−renderColumn (Column column) = renderAlias column
256−
257−{- | A `GroupedBy` constraint indicates that a table qualified column is
258−a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,
259−may be called in an output `Expression` without aggregating.
260−-}
261−class (KnownSymbol table, KnownSymbol column)
262− => GroupedBy table column bys where
263− getGroup1
264− :: (HasUnique table tables columns, HasColumn column columns ty)
265− => Alias column
266− -> Expression tables ('Grouped bys) params ty
267− getGroup1 column = UnsafeExpression $ renderAlias column
268− getGroup2
269− :: (HasTable table tables columns, HasColumn column columns ty)
270− => Alias table
271− -> Alias column
272− -> Expression tables ('Grouped bys) params ty
273− getGroup2 table column = UnsafeExpression $
274− renderAlias table <> "." <> renderAlias column
275−instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
276− => GroupedBy table column ('(table,column) ': bys)
277−instance {-# OVERLAPPABLE #-}
278− ( KnownSymbol table
279− , KnownSymbol column
280− , GroupedBy table column bys
281− ) => GroupedBy table column (tabcol ': bys)
209+instance (HasUnique relation relations columns, Has column columns ty)
210+ => IsLabel column (Expression relations 'Ungrouped params ty) where
211+ fromLabel = UnsafeExpression $ renderAlias (Alias @column)
212+
213+instance (Has relation relations columns, Has column columns ty)
214+ => IsQualified relation column (Expression relations 'Ungrouped params ty) where
215+ relation ! column = UnsafeExpression $
216+ renderAlias relation <> "." <> renderAlias column
282217
283218instance
284− ( HasUnique table tables columns
285− , HasColumn column columns ty
286− , GroupedBy table column bys
219+ ( HasUnique relation relations columns
220+ , Has column columns ty
221+ , GroupedBy relation column bys
287222 ) => IsLabel column
288− (Expression tables ('Grouped bys) params ty) where
289− fromLabel = getGroup1 (Alias @column)
223+ (Expression relations ('Grouped bys) params ty) where
224+ fromLabel = UnsafeExpression $ renderAlias (Alias @column)
290225
291226instance
292− ( HasTable table tables columns
293− , HasColumn column columns ty
294− , GroupedBy table column bys
295− ) => IsTableColumn table column
296− (Expression tables ('Grouped bys) params ty) where (!) = getGroup2
297−
298−-- | >>> renderExpression def
299−-- "DEFAULT"
300−def :: Expression '[] 'Ungrouped params ('Optional (nullity ty))
301−def = UnsafeExpression "DEFAULT"
302−
303−-- | >>> renderExpression $ unDef false
304−-- "FALSE"
305−unDef
306− :: Expression '[] 'Ungrouped params ('Required (nullity ty))
307− -- ^ not @DEFAULT@
308− -> Expression '[] 'Ungrouped params ('Optional (nullity ty))
309−unDef = UnsafeExpression . renderExpression
227+ ( Has relation relations columns
228+ , Has column columns ty
229+ , GroupedBy relation column bys
230+ ) => IsQualified relation column
231+ (Expression relations ('Grouped bys) params ty) where
232+ relation ! column = UnsafeExpression $
233+ renderAlias relation <> "." <> renderAlias column
310234
311235-- | analagous to `Nothing`
312236--
313237-- >>> renderExpression $ null_
314238-- "NULL"
315−null_ :: Expression tables grouping params (optionality ('Null ty))
239+null_ :: Expression relations grouping params ('Null ty)
316240null_ = UnsafeExpression "NULL"
317241
318242-- | analagous to `Just`
@@ -320,9 +244,9 @@ null_ = UnsafeExpression "NULL"
320244-- >>> renderExpression $ unNull true
321245-- "TRUE"
322246unNull
323− :: Expression tables grouping params (optionality ('NotNull ty))
247+ :: Expression relations grouping params ('NotNull ty)
324248 -- ^ not @NULL@
325− -> Expression tables grouping params (optionality ('Null ty))
249+ -> Expression relations grouping params ('Null ty)
326250unNull = UnsafeExpression . renderExpression
327251
328252-- | return the leftmost value which is not NULL
@@ -330,40 +254,40 @@ unNull = UnsafeExpression . renderExpression
330254-- >>> renderExpression $ coalesce [null_, unNull true] false
331255-- "COALESCE(NULL, TRUE, FALSE)"
332256coalesce
333− :: [Expression tables grouping params ('Required ('Null ty))]
257+ :: [Expression relations grouping params ('Null ty)]
334258 -- ^ @NULL@s may be present
335− -> Expression tables grouping params ('Required ('NotNull ty))
259+ -> Expression relations grouping params ('NotNull ty)
336260 -- ^ @NULL@ is absent
337− -> Expression tables grouping params ('Required ('NotNull ty))
261+ -> Expression relations grouping params ('NotNull ty)
338262coalesce nullxs notNullx = UnsafeExpression $
339263 "COALESCE" <> parenthesized (commaSeparated
340264 ((renderExpression <$> nullxs) <> [renderExpression notNullx]))
341265
342−-- | analagous to `fromMaybe` using @COALESCE@
266+-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@
343267--
344268-- >>> renderExpression $ fromNull true null_
345269-- "COALESCE(NULL, TRUE)"
346270fromNull
347− :: Expression tables grouping params ('Required ('NotNull ty))
271+ :: Expression relations grouping params ('NotNull ty)
348272 -- ^ what to convert @NULL@ to
349− -> Expression tables grouping params ('Required ('Null ty))
350− -> Expression tables grouping params ('Required ('NotNull ty))
273+ -> Expression relations grouping params ('Null ty)
274+ -> Expression relations grouping params ('NotNull ty)
351275fromNull notNullx nullx = coalesce [nullx] notNullx
352276
353277-- | >>> renderExpression $ null_ & isNull
354278-- "NULL IS NULL"
355279isNull
356− :: Expression tables grouping params ('Required ('Null ty))
280+ :: Expression relations grouping params ('Null ty)
357281 -- ^ possibly @NULL@
358− -> Condition tables grouping params
282+ -> Condition relations grouping params
359283isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL"
360284
361285-- | >>> renderExpression $ null_ & isn'tNull
362286-- "NULL IS NOT NULL"
363287isn'tNull
364− :: Expression tables grouping params ('Required ('Null ty))
288+ :: Expression relations grouping params ('Null ty)
365289 -- ^ possibly @NULL@
366− -> Condition tables grouping params
290+ -> Condition relations grouping params
367291isn'tNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL"
368292
369293-- | analagous to `maybe` using @IS NULL@
@@ -371,13 +295,13 @@ isn'tNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL"
371295-- >>> renderExpression $ matchNull true not_ null_
372296-- "CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END"
373297matchNull
374− :: Expression tables grouping params ('Required nullty)
298+ :: Expression relations grouping params (nullty)
375299 -- ^ what to convert @NULL@ to
376− -> ( Expression tables grouping params ('Required ('NotNull ty))
377− -> Expression tables grouping params ('Required nullty) )
300+ -> ( Expression relations grouping params ('NotNull ty)
301+ -> Expression relations grouping params (nullty) )
378302 -- ^ function to perform when @NULL@ is absent
379− -> Expression tables grouping params ('Required ('Null ty))
380− -> Expression tables grouping params ('Required nullty)
303+ -> Expression relations grouping params ('Null ty)
304+ -> Expression relations grouping params (nullty)
381305matchNull y f x = ifThenElse (isNull x) y
382306 (f (UnsafeExpression (renderExpression x)))
383307
@@ -388,33 +312,47 @@ matchNull y f x = ifThenElse (isNull x) y
388312-- >>> renderExpression @_ @_ @'[_] $ fromNull false (nullIf false (param @1))
389313-- "COALESCE(NULL IF (FALSE, ($1 :: bool)), FALSE)"
390314nullIf
391− :: Expression tables grouping params ('Required ('NotNull ty))
315+ :: Expression relations grouping params ('NotNull ty)
392316 -- ^ @NULL@ is absent
393− -> Expression tables grouping params ('Required ('NotNull ty))
317+ -> Expression relations grouping params ('NotNull ty)
394318 -- ^ @NULL@ is absent
395− -> Expression tables grouping params ('Required ('Null ty))
319+ -> Expression relations grouping params ('Null ty)
396320nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized
397321 (renderExpression x <> ", " <> renderExpression y)
398322
323+-- | >>> renderExpression $ array [null_, unNull false, unNull true]
324+-- "ARRAY[NULL, FALSE, TRUE]"
325+array
326+ :: [Expression relations grouping params ('Null ty)]
327+ -- ^ array elements
328+ -> Expression relations grouping params (nullity ('PGvararray ty))
329+array xs = UnsafeExpression $
330+ "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]"
331+
332+instance Monoid
333+ (Expression relations grouping params (nullity ('PGvararray ty))) where
334+ mempty = array []
335+ mappend = unsafeBinaryOp "||"
336+
399337-- | >>> renderExpression @_ @_ @'[_] $ greatest currentTimestamp [param @1]
400338-- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))"
401339greatest
402− :: Expression tables grouping params ('Required nullty)
340+ :: Expression relations grouping params (nullty)
403341 -- ^ needs at least 1 argument
404− -> [Expression tables grouping params ('Required nullty)]
342+ -> [Expression relations grouping params (nullty)]
405343 -- ^ or more
406− -> Expression tables grouping params ('Required nullty)
344+ -> Expression relations grouping params (nullty)
407345greatest x xs = UnsafeExpression $ "GREATEST("
408346 <> commaSeparated (renderExpression <$> (x:xs)) <> ")"
409347
410348-- | >>> renderExpression $ least currentTimestamp [null_]
411349-- "LEAST(CURRENT_TIMESTAMP, NULL)"
412350least
413− :: Expression tables grouping params ('Required nullty)
351+ :: Expression relations grouping params (nullty)
414352 -- ^ needs at least 1 argument
415− -> [Expression tables grouping params ('Required nullty)]
353+ -> [Expression relations grouping params (nullty)]
416354 -- ^ or more
417− -> Expression tables grouping params ('Required nullty)
355+ -> Expression relations grouping params (nullty)
418356least x xs = UnsafeExpression $ "LEAST("
419357 <> commaSeparated (renderExpression <$> (x:xs)) <> ")"
420358
@@ -423,9 +361,9 @@ least x xs = UnsafeExpression $ "LEAST("
423361unsafeBinaryOp
424362 :: ByteString
425363 -- ^ operator
426− -> Expression tables grouping params ('Required ty0)
427− -> Expression tables grouping params ('Required ty1)
428− -> Expression tables grouping params ('Required ty2)
364+ -> Expression relations grouping params (ty0)
365+ -> Expression relations grouping params (ty1)
366+ -> Expression relations grouping params (ty2)
429367unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
430368 renderExpression x <+> op <+> renderExpression y
431369
@@ -434,8 +372,8 @@ unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
434372unsafeUnaryOp
435373 :: ByteString
436374 -- ^ operator
437− -> Expression tables grouping params ('Required ty0)
438− -> Expression tables grouping params ('Required ty1)
375+ -> Expression relations grouping params (ty0)
376+ -> Expression relations grouping params (ty1)
439377unsafeUnaryOp op x = UnsafeExpression $ parenthesized $
440378 op <+> renderExpression x
441379
@@ -444,13 +382,13 @@ unsafeUnaryOp op x = UnsafeExpression $ parenthesized $
444382unsafeFunction
445383 :: ByteString
446384 -- ^ function
447− -> Expression tables grouping params ('Required xty)
448− -> Expression tables grouping params ('Required yty)
385+ -> Expression relations grouping params (xty)
386+ -> Expression relations grouping params (yty)
449387unsafeFunction fun x = UnsafeExpression $
450388 fun <> parenthesized (renderExpression x)
451389
452390instance PGNum ty
453− => Num (Expression tables grouping params ('Required (nullity ty))) where
391+ => Num (Expression relations grouping params (nullity ty)) where
454392 (+) = unsafeBinaryOp "+"
455393 (-) = unsafeBinaryOp "-"
456394 (*) = unsafeBinaryOp "*"
@@ -462,12 +400,12 @@ instance PGNum ty
462400 . show
463401
464402instance (PGNum ty, PGFloating ty) => Fractional
465− (Expression tables grouping params ('Required (nullity ty))) where
403+ (Expression relations grouping params (nullity ty)) where
466404 (/) = unsafeBinaryOp "/"
467405 fromRational x = fromInteger (numerator x) / fromInteger (denominator x)
468406
469407instance (PGNum ty, PGFloating ty) => Floating
470− (Expression tables grouping params ('Required (nullity ty))) where
408+ (Expression relations grouping params (nullity ty)) where
471409 pi = UnsafeExpression "pi()"
472410 exp = unsafeFunction "exp"
473411 log = unsafeFunction "ln"
@@ -488,15 +426,20 @@ instance (PGNum ty, PGFloating ty) => Floating
488426 acosh x = log (x + sqrt (x*x - 1))
489427 atanh x = log ((1 + x) / (1 - x)) / 2
490428
491−-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ atan2_ pi 2
429+-- | >>> :{
430+-- let
431+-- expression :: Expression relations grouping params (nullity 'PGfloat4)
432+-- expression = atan2_ pi 2
433+-- in renderExpression expression
434+-- :}
492435-- "atan2(pi(), 2)"
493436atan2_
494437 :: PGFloating float
495− => Expression tables grouping params ('Required (nullity float))
438+ => Expression relations grouping params (nullity float)
496439 -- ^ numerator
497− -> Expression tables grouping params ('Required (nullity float))
440+ -> Expression relations grouping params (nullity float)
498441 -- ^ denominator
499− -> Expression tables grouping params ('Required (nullity float))
442+ -> Expression relations grouping params (nullity float)
500443atan2_ y x = UnsafeExpression $
501444 "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"
502445
@@ -507,115 +450,147 @@ atan2_ y x = UnsafeExpression $
507450-- | >>> renderExpression $ true & cast int4
508451-- "(TRUE :: int4)"
509452cast
510− :: TypeExpression ('Required ('Null ty1))
453+ :: TypeExpression ('NoDef :=> 'Null ty1)
511454 -- ^ type to cast as
512− -> Expression tables grouping params ('Required (nullity ty0))
455+ -> Expression relations grouping params (nullity ty0)
513456 -- ^ value to convert
514− -> Expression tables grouping params ('Required (nullity ty1))
457+ -> Expression relations grouping params (nullity ty1)
515458cast ty x = UnsafeExpression $ parenthesized $
516459 renderExpression x <+> "::" <+> renderTypeExpression ty
517460
518461-- | integer division, truncates the result
519462--
520−-- >>> renderExpression @_ @_ @_ @(_(_ 'PGint2)) $ 5 `quot_` 2
463+-- >>> :{
464+-- let
465+-- expression :: Expression relations grouping params (nullity 'PGint2)
466+-- expression = 5 `quot_` 2
467+-- in renderExpression expression
468+-- :}
521469-- "(5 / 2)"
522470quot_
523471 :: PGIntegral int
524− => Expression tables grouping params ('Required (nullity int))
472+ => Expression relations grouping params (nullity int)
525473 -- ^ numerator
526− -> Expression tables grouping params ('Required (nullity int))
474+ -> Expression relations grouping params (nullity int)
527475 -- ^ denominator
528− -> Expression tables grouping params ('Required (nullity int))
476+ -> Expression relations grouping params (nullity int)
529477quot_ = unsafeBinaryOp "/"
530478
531479-- | remainder upon integer division
532480--
533−-- >>> renderExpression @_ @_ @_ @(_ (_ 'PGint2)) $ 5 `rem_` 2
481+-- >>> :{
482+-- let
483+-- expression :: Expression relations grouping params (nullity 'PGint2)
484+-- expression = 5 `rem_` 2
485+-- in renderExpression expression
486+-- :}
534487-- "(5 % 2)"
535488rem_
536489 :: PGIntegral int
537− => Expression tables grouping params ('Required (nullity int))
490+ => Expression relations grouping params (nullity int)
538491 -- ^ numerator
539− -> Expression tables grouping params ('Required (nullity int))
492+ -> Expression relations grouping params (nullity int)
540493 -- ^ denominator
541− -> Expression tables grouping params ('Required (nullity int))
494+ -> Expression relations grouping params (nullity int)
542495rem_ = unsafeBinaryOp "%"
543496
544−-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ trunc pi
497+-- | >>> :{
498+-- let
499+-- expression :: Expression relations grouping params (nullity 'PGfloat4)
500+-- expression = trunc pi
501+-- in renderExpression expression
502+-- :}
545503-- "trunc(pi())"
546504trunc
547505 :: PGFloating frac
548− => Expression tables grouping params ('Required (nullity frac))
506+ => Expression relations grouping params (nullity frac)
549507 -- ^ fractional number
550− -> Expression tables grouping params ('Required (nullity frac))
508+ -> Expression relations grouping params (nullity frac)
551509trunc = unsafeFunction "trunc"
552510
553−-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ round_ pi
511+-- | >>> :{
512+-- let
513+-- expression :: Expression relations grouping params (nullity 'PGfloat4)
514+-- expression = round_ pi
515+-- in renderExpression expression
516+-- :}
554517-- "round(pi())"
555518round_
556519 :: PGFloating frac
557− => Expression tables grouping params ('Required (nullity frac))
520+ => Expression relations grouping params (nullity frac)
558521 -- ^ fractional number
559− -> Expression tables grouping params ('Required (nullity frac))
522+ -> Expression relations grouping params (nullity frac)
560523round_ = unsafeFunction "round"
561524
562−-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ ceiling_ pi
525+-- | >>> :{
526+-- let
527+-- expression :: Expression relations grouping params (nullity 'PGfloat4)
528+-- expression = ceiling_ pi
529+-- in renderExpression expression
530+-- :}
563531-- "ceiling(pi())"
564532ceiling_
565533 :: PGFloating frac
566− => Expression tables grouping params ('Required (nullity frac))
534+ => Expression relations grouping params (nullity frac)
567535 -- ^ fractional number
568− -> Expression tables grouping params ('Required (nullity frac))
536+ -> Expression relations grouping params (nullity frac)
569537ceiling_ = unsafeFunction "ceiling"
570538
571539-- | A `Condition` is a boolean valued `Expression`. While SQL allows
572−-- conditions to have @NULL@, squeal instead chooses to disallow @NULL@,
540+-- conditions to have @NULL@, Squeal instead chooses to disallow @NULL@,
573541-- forcing one to handle the case of @NULL@ explicitly to produce
574542-- a `Condition`.
575−type Condition tables grouping params =
576− Expression tables grouping params ('Required ('NotNull 'PGbool))
543+type Condition relations grouping params =
544+ Expression relations grouping params ('NotNull 'PGbool)
577545
578546-- | >>> renderExpression true
579547-- "TRUE"
580−true :: Condition tables grouping params
548+true :: Condition relations grouping params
581549true = UnsafeExpression "TRUE"
582550
583551-- | >>> renderExpression false
584552-- "FALSE"
585−false :: Condition tables grouping params
553+false :: Condition relations grouping params
586554false = UnsafeExpression "FALSE"
587555
588556-- | >>> renderExpression $ not_ true
589557-- "(NOT TRUE)"
590558not_
591− :: Condition tables grouping params
592− -> Condition tables grouping params
559+ :: Condition relations grouping params
560+ -> Condition relations grouping params
593561not_ = unsafeUnaryOp "NOT"
594562
595563-- | >>> renderExpression $ true .&& false
596564-- "(TRUE AND FALSE)"
597565(.&&)
598− :: Condition tables grouping params
599− -> Condition tables grouping params
600− -> Condition tables grouping params
566+ :: Condition relations grouping params
567+ -> Condition relations grouping params
568+ -> Condition relations grouping params
601569(.&&) = unsafeBinaryOp "AND"
602570
603571-- | >>> renderExpression $ true .|| false
604572-- "(TRUE OR FALSE)"
605573(.||)
606− :: Condition tables grouping params
607− -> Condition tables grouping params
608− -> Condition tables grouping params
574+ :: Condition relations grouping params
575+ -> Condition relations grouping params
576+ -> Condition relations grouping params
609577(.||) = unsafeBinaryOp "OR"
610578
611−-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGint2)) $ caseWhenThenElse [(true, 1), (false, 2)] 3
579+-- | >>> :{
580+-- let
581+-- expression :: Expression relations grouping params (nullity 'PGint2)
582+-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3
583+-- in renderExpression expression
584+-- :}
612585-- "CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END"
613586caseWhenThenElse
614− :: [ ( Condition tables grouping params
615− , Expression tables grouping params ('Required ty)
587+ :: [ ( Condition relations grouping params
588+ , Expression relations grouping params (ty)
616589 ) ]
617− -> Expression tables grouping params ('Required ty)
618− -> Expression tables grouping params ('Required ty)
590+ -- ^ whens and thens
591+ -> Expression relations grouping params (ty)
592+ -- ^ else
593+ -> Expression relations grouping params (ty)
619594caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
620595 [ "CASE"
621596 , mconcat
@@ -629,13 +604,18 @@ caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
629604 , " END"
630605 ]
631606
632−-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGint2)) $ ifThenElse true 1 0
607+-- | >>> :{
608+-- let
609+-- expression :: Expression relations grouping params (nullity 'PGint2)
610+-- expression = ifThenElse true 1 0
611+-- in renderExpression expression
612+-- :}
633613-- "CASE WHEN TRUE THEN 1 ELSE 0 END"
634614ifThenElse
635− :: Condition tables grouping params
636− -> Expression tables grouping params ('Required ty)
637− -> Expression tables grouping params ('Required ty)
638− -> Expression tables grouping params ('Required ty)
615+ :: Condition relations grouping params
616+ -> Expression relations grouping params (ty) -- ^ then
617+ -> Expression relations grouping params (ty) -- ^ else
618+ -> Expression relations grouping params (ty)
639619ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
640620
641621-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`
@@ -644,85 +624,85 @@ ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
644624-- >>> renderExpression $ unNull true .== null_
645625-- "(TRUE = NULL)"
646626(.==)
647− :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs
648− -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs
649− -> Expression tables grouping params ('Required (nullity 'PGbool))
627+ :: Expression relations grouping params (nullity ty) -- ^ lhs
628+ -> Expression relations grouping params (nullity ty) -- ^ rhs
629+ -> Expression relations grouping params (nullity 'PGbool)
650630(.==) = unsafeBinaryOp "="
651631infix 4 .==
652632
653633-- | >>> renderExpression $ unNull true ./= null_
654634-- "(TRUE <> NULL)"
655635(./=)
656− :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs
657− -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs
658− -> Expression tables grouping params ('Required (nullity 'PGbool))
636+ :: Expression relations grouping params (nullity ty) -- ^ lhs
637+ -> Expression relations grouping params (nullity ty) -- ^ rhs
638+ -> Expression relations grouping params (nullity 'PGbool)
659639(./=) = unsafeBinaryOp "<>"
660640infix 4 ./=
661641
662642-- | >>> renderExpression $ unNull true .>= null_
663643-- "(TRUE >= NULL)"
664644(.>=)
665− :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs
666− -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs
667− -> Expression tables grouping params ('Required (nullity 'PGbool))
645+ :: Expression relations grouping params (nullity ty) -- ^ lhs
646+ -> Expression relations grouping params (nullity ty) -- ^ rhs
647+ -> Expression relations grouping params (nullity 'PGbool)
668648(.>=) = unsafeBinaryOp ">="
669649infix 4 .>=
670650
671651-- | >>> renderExpression $ unNull true .< null_
672652-- "(TRUE < NULL)"
673653(.<)
674− :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs
675− -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs
676− -> Expression tables grouping params ('Required (nullity 'PGbool))
654+ :: Expression relations grouping params (nullity ty) -- ^ lhs
655+ -> Expression relations grouping params (nullity ty) -- ^ rhs
656+ -> Expression relations grouping params (nullity 'PGbool)
677657(.<) = unsafeBinaryOp "<"
678658infix 4 .<
679659
680660-- | >>> renderExpression $ unNull true .<= null_
681661-- "(TRUE <= NULL)"
682662(.<=)
683− :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs
684− -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs
685− -> Expression tables grouping params ('Required (nullity 'PGbool))
663+ :: Expression relations grouping params (nullity ty) -- ^ lhs
664+ -> Expression relations grouping params (nullity ty) -- ^ rhs
665+ -> Expression relations grouping params (nullity 'PGbool)
686666(.<=) = unsafeBinaryOp "<="
687667infix 4 .<=
688668
689669-- | >>> renderExpression $ unNull true .> null_
690670-- "(TRUE > NULL)"
691671(.>)
692− :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs
693− -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs
694− -> Expression tables grouping params ('Required (nullity 'PGbool))
672+ :: Expression relations grouping params (nullity ty) -- ^ lhs
673+ -> Expression relations grouping params (nullity ty) -- ^ rhs
674+ -> Expression relations grouping params (nullity 'PGbool)
695675(.>) = unsafeBinaryOp ">"
696676infix 4 .>
697677
698−-- | >>> renderExpression $ currentDate
678+-- | >>> renderExpression currentDate
699679-- "CURRENT_DATE"
700680currentDate
701− :: Expression tables grouping params ('Required (nullity 'PGdate))
681+ :: Expression relations grouping params (nullity 'PGdate)
702682currentDate = UnsafeExpression "CURRENT_DATE"
703683
704−-- | >>> renderExpression $ currentTime
684+-- | >>> renderExpression currentTime
705685-- "CURRENT_TIME"
706686currentTime
707− :: Expression tables grouping params ('Required (nullity 'PGtimetz))
687+ :: Expression relations grouping params (nullity 'PGtimetz)
708688currentTime = UnsafeExpression "CURRENT_TIME"
709689
710−-- | >>> renderExpression $ currentTimestamp
690+-- | >>> renderExpression currentTimestamp
711691-- "CURRENT_TIMESTAMP"
712692currentTimestamp
713− :: Expression tables grouping params ('Required (nullity 'PGtimestamptz))
693+ :: Expression relations grouping params (nullity 'PGtimestamptz)
714694currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"
715695
716−-- | >>> renderExpression $ localTime
696+-- | >>> renderExpression localTime
717697-- "LOCALTIME"
718698localTime
719− :: Expression tables grouping params ('Required (nullity 'PGtime))
699+ :: Expression relations grouping params (nullity 'PGtime)
720700localTime = UnsafeExpression "LOCALTIME"
721701
722−-- | >>> renderExpression $ localTimestamp
702+-- | >>> renderExpression localTimestamp
723703-- "LOCALTIMESTAMP"
724704localTimestamp
725− :: Expression tables grouping params ('Required (nullity 'PGtimestamp))
705+ :: Expression relations grouping params (nullity 'PGtimestamp)
726706localTimestamp = UnsafeExpression "LOCALTIMESTAMP"
727707
728708{-----------------------------------------
@@ -730,7 +710,7 @@ text
730710-----------------------------------------}
731711
732712instance IsString
733− (Expression tables grouping params ('Required (nullity 'PGtext))) where
713+ (Expression relations grouping params (nullity 'PGtext)) where
734714 fromString str = UnsafeExpression $
735715 "E\'" <> fromString (escape =<< str) <> "\'"
736716 where
@@ -746,32 +726,32 @@ instance IsString
746726 c -> [c]
747727
748728instance Monoid
749− (Expression tables grouping params ('Required (nullity 'PGtext))) where
729+ (Expression relations grouping params (nullity 'PGtext)) where
750730 mempty = fromString ""
751731 mappend = unsafeBinaryOp "||"
752732
753733-- | >>> renderExpression $ lower "ARRRGGG"
754734-- "lower(E'ARRRGGG')"
755735lower
756− :: Expression tables grouping params ('Required (nullity 'PGtext))
736+ :: Expression relations grouping params (nullity 'PGtext)
757737 -- ^ string to lower case
758− -> Expression tables grouping params ('Required (nullity 'PGtext))
738+ -> Expression relations grouping params (nullity 'PGtext)
759739lower = unsafeFunction "lower"
760740
761741-- | >>> renderExpression $ upper "eeee"
762742-- "upper(E'eeee')"
763743upper
764− :: Expression tables grouping params ('Required (nullity 'PGtext))
744+ :: Expression relations grouping params (nullity 'PGtext)
765745 -- ^ string to upper case
766− -> Expression tables grouping params ('Required (nullity 'PGtext))
746+ -> Expression relations grouping params (nullity 'PGtext)
767747upper = unsafeFunction "upper"
768748
769749-- | >>> renderExpression $ charLength "four"
770750-- "char_length(E'four')"
771751charLength
772− :: Expression tables grouping params ('Required (nullity 'PGtext))
752+ :: Expression relations grouping params (nullity 'PGtext)
773753 -- ^ string to measure
774− -> Expression tables grouping params ('Required (nullity 'PGint4))
754+ -> Expression relations grouping params (nullity 'PGint4)
775755charLength = unsafeFunction "char_length"
776756
777757-- | The `like` expression returns true if the @string@ matches
@@ -784,11 +764,11 @@ charLength = unsafeFunction "char_length"
784764-- >>> renderExpression $ "abc" `like` "a%"
785765-- "(E'abc' LIKE E'a%')"
786766like
787− :: Expression tables grouping params ('Required (nullity 'PGtext))
767+ :: Expression relations grouping params (nullity 'PGtext)
788768 -- ^ string
789− -> Expression tables grouping params ('Required (nullity 'PGtext))
769+ -> Expression relations grouping params (nullity 'PGtext)
790770 -- ^ pattern
791− -> Expression tables grouping params ('Required (nullity 'PGbool))
771+ -> Expression relations grouping params (nullity 'PGbool)
792772like = unsafeBinaryOp "LIKE"
793773
794774{-----------------------------------------
@@ -798,44 +778,54 @@ aggregation
798778-- | escape hatch to define aggregate functions
799779unsafeAggregate
800780 :: ByteString -- ^ aggregate function
801− -> Expression tables 'Ungrouped params ('Required xty)
802− -> Expression tables ('Grouped bys) params ('Required yty)
781+ -> Expression relations 'Ungrouped params (xty)
782+ -> Expression relations ('Grouped bys) params (yty)
803783unsafeAggregate fun x = UnsafeExpression $ mconcat
804784 [fun, "(", renderExpression x, ")"]
805785
806786-- | escape hatch to define aggregate functions over distinct values
807787unsafeAggregateDistinct
808788 :: ByteString -- ^ aggregate function
809− -> Expression tables 'Ungrouped params ('Required xty)
810− -> Expression tables ('Grouped bys) params ('Required yty)
789+ -> Expression relations 'Ungrouped params (xty)
790+ -> Expression relations ('Grouped bys) params (yty)
811791unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat
812792 [fun, "(DISTINCT ", renderExpression x, ")"]
813793
814−-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGnumeric)]] $ sum_ #col
794+-- | >>> :{
795+-- let
796+-- expression :: Expression '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric)
797+-- expression = sum_ #col
798+-- in renderExpression expression
799+-- :}
815800-- "sum(col)"
816801sum_
817802 :: PGNum ty
818− => Expression tables 'Ungrouped params ('Required (nullity ty))
803+ => Expression relations 'Ungrouped params (nullity ty)
819804 -- ^ what to sum
820− -> Expression tables ('Grouped bys) params ('Required (nullity ty))
805+ -> Expression relations ('Grouped bys) params (nullity ty)
821806sum_ = unsafeAggregate "sum"
822807
823−-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGnumeric)]] $ sumDistinct #col
808+-- | >>> :{
809+-- let
810+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric)
811+-- expression = sumDistinct #col
812+-- in renderExpression expression
813+-- :}
824814-- "sum(DISTINCT col)"
825815sumDistinct
826816 :: PGNum ty
827− => Expression tables 'Ungrouped params ('Required (nullity ty))
817+ => Expression relations 'Ungrouped params (nullity ty)
828818 -- ^ what to sum
829− -> Expression tables ('Grouped bys) params ('Required (nullity ty))
819+ -> Expression relations ('Grouped bys) params (nullity ty)
830820sumDistinct = unsafeAggregateDistinct "sum"
831821
832822-- | A constraint for `PGType`s that you can take averages of and the resulting
833823-- `PGType`.
834824class PGAvg ty avg | ty -> avg where
835825 avg, avgDistinct
836− :: Expression tables 'Ungrouped params ('Required (nullity ty))
826+ :: Expression relations 'Ungrouped params (nullity ty)
837827 -- ^ what to average
838− -> Expression tables ('Grouped bys) params ('Required (nullity avg))
828+ -> Expression relations ('Grouped bys) params (nullity avg)
839829 avg = unsafeAggregate "avg"
840830 avgDistinct = unsafeAggregateDistinct "avg"
841831instance PGAvg 'PGint2 'PGnumeric
@@ -846,72 +836,112 @@ instance PGAvg 'PGfloat4 'PGfloat8
846836instance PGAvg 'PGfloat8 'PGfloat8
847837instance PGAvg 'PGinterval 'PGinterval
848838
849−-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitAnd #col
839+-- | >>> :{
840+-- let
841+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
842+-- expression = bitAnd #col
843+-- in renderExpression expression
844+-- :}
850845-- "bit_and(col)"
851846bitAnd
852847 :: PGIntegral int
853− => Expression tables 'Ungrouped params ('Required (nullity int))
848+ => Expression relations 'Ungrouped params (nullity int)
854849 -- ^ what to aggregate
855− -> Expression tables ('Grouped bys) params ('Required (nullity int))
850+ -> Expression relations ('Grouped bys) params (nullity int)
856851bitAnd = unsafeAggregate "bit_and"
857852
858−-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitOr #col
853+-- | >>> :{
854+-- let
855+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
856+-- expression = bitOr #col
857+-- in renderExpression expression
858+-- :}
859859-- "bit_or(col)"
860860bitOr
861861 :: PGIntegral int
862− => Expression tables 'Ungrouped params ('Required (nullity int))
862+ => Expression relations 'Ungrouped params (nullity int)
863863 -- ^ what to aggregate
864− -> Expression tables ('Grouped bys) params ('Required (nullity int))
864+ -> Expression relations ('Grouped bys) params (nullity int)
865865bitOr = unsafeAggregate "bit_or"
866866
867−-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitAndDistinct #col
867+-- | >>> :{
868+-- let
869+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
870+-- expression = bitAndDistinct #col
871+-- in renderExpression expression
872+-- :}
868873-- "bit_and(DISTINCT col)"
869874bitAndDistinct
870875 :: PGIntegral int
871− => Expression tables 'Ungrouped params ('Required (nullity int))
876+ => Expression relations 'Ungrouped params (nullity int)
872877 -- ^ what to aggregate
873− -> Expression tables ('Grouped bys) params ('Required (nullity int))
878+ -> Expression relations ('Grouped bys) params (nullity int)
874879bitAndDistinct = unsafeAggregateDistinct "bit_and"
875880
876−-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitOrDistinct #col
881+-- | >>> :{
882+-- let
883+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)
884+-- expression = bitOrDistinct #col
885+-- in renderExpression expression
886+-- :}
877887-- "bit_or(DISTINCT col)"
878888bitOrDistinct
879889 :: PGIntegral int
880− => Expression tables 'Ungrouped params ('Required (nullity int))
890+ => Expression relations 'Ungrouped params (nullity int)
881891 -- ^ what to aggregate
882− -> Expression tables ('Grouped bys) params ('Required (nullity int))
892+ -> Expression relations ('Grouped bys) params (nullity int)
883893bitOrDistinct = unsafeAggregateDistinct "bit_or"
884894
885−-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolAnd #col
895+-- | >>> :{
896+-- let
897+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
898+-- expression = boolAnd #col
899+-- in renderExpression expression
900+-- :}
886901-- "bool_and(col)"
887902boolAnd
888− :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))
903+ :: Expression relations 'Ungrouped params (nullity 'PGbool)
889904 -- ^ what to aggregate
890− -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))
905+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)
891906boolAnd = unsafeAggregate "bool_and"
892907
893−-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolOr #col
908+-- | >>> :{
909+-- let
910+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
911+-- expression = boolOr #col
912+-- in renderExpression expression
913+-- :}
894914-- "bool_or(col)"
895915boolOr
896− :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))
916+ :: Expression relations 'Ungrouped params (nullity 'PGbool)
897917 -- ^ what to aggregate
898− -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))
918+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)
899919boolOr = unsafeAggregate "bool_or"
900920
901−-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolAndDistinct #col
921+-- | >>> :{
922+-- let
923+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
924+-- expression = boolAndDistinct #col
925+-- in renderExpression expression
926+-- :}
902927-- "bool_and(DISTINCT col)"
903928boolAndDistinct
904− :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))
929+ :: Expression relations 'Ungrouped params (nullity 'PGbool)
905930 -- ^ what to aggregate
906− -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))
931+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)
907932boolAndDistinct = unsafeAggregateDistinct "bool_and"
908933
909−-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolOrDistinct #col
934+-- | >>> :{
935+-- let
936+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
937+-- expression = boolOrDistinct #col
938+-- in renderExpression expression
939+-- :}
910940-- "bool_or(DISTINCT col)"
911941boolOrDistinct
912− :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))
942+ :: Expression relations 'Ungrouped params (nullity 'PGbool)
913943 -- ^ what to aggregate
914− -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))
944+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)
915945boolOrDistinct = unsafeAggregateDistinct "bool_or"
916946
917947-- | A special aggregation that does not require an input
@@ -919,50 +949,70 @@ boolOrDistinct = unsafeAggregateDistinct "bool_or"
919949-- >>> renderExpression countStar
920950-- "count(*)"
921951countStar
922− :: Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))
952+ :: Expression relations ('Grouped bys) params ('NotNull 'PGint8)
923953countStar = UnsafeExpression $ "count(*)"
924954
925−-- | >>> renderExpression @'[_ ::: '["col" ::: 'Optional _]] $ count #col
955+-- | >>> :{
956+-- let
957+-- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)
958+-- expression = count #col
959+-- in renderExpression expression
960+-- :}
926961-- "count(col)"
927962count
928− :: Expression tables 'Ungrouped params ('Required ty)
963+ :: Expression relations 'Ungrouped params ty
929964 -- ^ what to count
930− -> Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))
965+ -> Expression relations ('Grouped bys) params ('NotNull 'PGint8)
931966count = unsafeAggregate "count"
932967
933−-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required _]] $ countDistinct #col
968+-- | >>> :{
969+-- let
970+-- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)
971+-- expression = countDistinct #col
972+-- in renderExpression expression
973+-- :}
934974-- "count(DISTINCT col)"
935975countDistinct
936− :: Expression tables 'Ungrouped params ('Required ty)
976+ :: Expression relations 'Ungrouped params ty
937977 -- ^ what to count
938− -> Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))
978+ -> Expression relations ('Grouped bys) params ('NotNull 'PGint8)
939979countDistinct = unsafeAggregateDistinct "count"
940980
941981-- | synonym for `boolAnd`
942982--
943−-- >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ every #col
983+-- >>> :{
984+-- let
985+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
986+-- expression = every #col
987+-- in renderExpression expression
988+-- :}
944989-- "every(col)"
945990every
946− :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))
991+ :: Expression relations 'Ungrouped params (nullity 'PGbool)
947992 -- ^ what to aggregate
948− -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))
993+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)
949994every = unsafeAggregate "every"
950995
951996-- | synonym for `boolAndDistinct`
952997--
953−-- >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ everyDistinct #col
998+-- >>> :{
999+-- let
1000+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)
1001+-- expression = everyDistinct #col
1002+-- in renderExpression expression
1003+-- :}
9541004-- "every(DISTINCT col)"
9551005everyDistinct
956− :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))
1006+ :: Expression relations 'Ungrouped params (nullity 'PGbool)
9571007 -- ^ what to aggregate
958− -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))
1008+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)
9591009everyDistinct = unsafeAggregateDistinct "every"
9601010
9611011-- | minimum and maximum aggregation
9621012max_, min_, maxDistinct, minDistinct
963− :: Expression tables 'Ungrouped params ('Required (nullity ty))
1013+ :: Expression relations 'Ungrouped params (nullity ty)
9641014 -- ^ what to aggregate
965− -> Expression tables ('Grouped bys) params ('Required (nullity ty))
1015+ -> Expression relations ('Grouped bys) params (nullity ty)
9661016max_ = unsafeAggregate "max"
9671017min_ = unsafeAggregate "min"
9681018maxDistinct = unsafeAggregateDistinct "max"
@@ -972,28 +1022,18 @@ minDistinct = unsafeAggregateDistinct "min"
9721022tables
9731023-----------------------------------------}
9741024
975−-- | A `Table` from a schema without its alias with an `IsLabel` instance
1025+-- | A `Table` from a table expression is a way
9761026-- to call a table reference by its alias.
9771027newtype Table
9781028 (schema :: TablesType)
979− (columns :: ColumnsType)
1029+ (columns :: RelationType)
9801030 = UnsafeTable { renderTable :: ByteString }
9811031 deriving (GHC.Generic,Show,Eq,Ord,NFData)
982−
983−-- | A `HasTable` constraint indicates a table reference.
984−class KnownSymbol table => HasTable table tables columns
985− | table tables -> columns where
986− getTable :: Alias table -> Table tables columns
987− getTable table = UnsafeTable $ renderAlias table
988−instance {-# OVERLAPPING #-} KnownSymbol table
989− => HasTable table ((table ::: columns) ': tables) columns
990−instance {-# OVERLAPPABLE #-}
991− (KnownSymbol table, HasTable table schema columns)
992− => HasTable table (table' ': schema) columns
993−
994−instance HasTable table schema columns
995− => IsLabel table (Table schema columns) where
996− fromLabel = getTable (Alias @table)
1032+instance
1033+ ( Has alias schema table
1034+ , relation ~ ColumnsToRelation (TableToColumns table)
1035+ ) => IsLabel alias (Table schema relation) where
1036+ fromLabel = UnsafeTable $ renderAlias (Alias @alias)
9971037
9981038{-----------------------------------------
9991039type expressions
@@ -1005,117 +1045,136 @@ newtype TypeExpression (ty :: ColumnType)
10051045 deriving (GHC.Generic,Show,Eq,Ord,NFData)
10061046
10071047-- | logical Boolean (true/false)
1008−bool :: TypeExpression ('Required ('Null 'PGbool))
1048+bool :: TypeExpression ('NoDef :=> 'Null 'PGbool)
10091049bool = UnsafeTypeExpression "bool"
10101050-- | signed two-byte integer
1011−int2, smallint :: TypeExpression ('Required ('Null 'PGint2))
1051+int2, smallint :: TypeExpression ('NoDef :=> 'Null 'PGint2)
10121052int2 = UnsafeTypeExpression "int2"
10131053smallint = UnsafeTypeExpression "smallint"
10141054-- | signed four-byte integer
1015−int4, int, integer :: TypeExpression ('Required ('Null 'PGint4))
1055+int4, int, integer :: TypeExpression ('NoDef :=> 'Null 'PGint4)
10161056int4 = UnsafeTypeExpression "int4"
10171057int = UnsafeTypeExpression "int"
10181058integer = UnsafeTypeExpression "integer"
10191059-- | signed eight-byte integer
1020−int8, bigint :: TypeExpression ('Required ('Null 'PGint8))
1060+int8, bigint :: TypeExpression ('NoDef :=> 'Null 'PGint8)
10211061int8 = UnsafeTypeExpression "int8"
10221062bigint = UnsafeTypeExpression "bigint"
10231063-- | arbitrary precision numeric type
1024−numeric :: TypeExpression ('Required ('Null 'PGnumeric))
1064+numeric :: TypeExpression ('NoDef :=> 'Null 'PGnumeric)
10251065numeric = UnsafeTypeExpression "numeric"
10261066-- | single precision floating-point number (4 bytes)
1027−float4, real :: TypeExpression ('Required ('Null 'PGfloat4))
1067+float4, real :: TypeExpression ('NoDef :=> 'Null 'PGfloat4)
10281068float4 = UnsafeTypeExpression "float4"
10291069real = UnsafeTypeExpression "real"
10301070-- | double precision floating-point number (8 bytes)
1031−float8, doublePrecision :: TypeExpression ('Required ('Null 'PGfloat8))
1071+float8, doublePrecision :: TypeExpression ('NoDef :=> 'Null 'PGfloat8)
10321072float8 = UnsafeTypeExpression "float8"
10331073doublePrecision = UnsafeTypeExpression "double precision"
10341074-- | not a true type, but merely a notational convenience for creating
10351075-- unique identifier columns with type `'PGint2`
1036−serial2, smallserial :: TypeExpression ('Optional ('NotNull 'PGint2))
1076+serial2, smallserial
1077+ :: TypeExpression ('Def :=> 'NotNull 'PGint2)
10371078serial2 = UnsafeTypeExpression "serial2"
10381079smallserial = UnsafeTypeExpression "smallserial"
10391080-- | not a true type, but merely a notational convenience for creating
10401081-- unique identifier columns with type `'PGint4`
1041−serial4, serial :: TypeExpression ('Optional ('NotNull 'PGint4))
1082+serial4, serial
1083+ :: TypeExpression ('Def :=> 'NotNull 'PGint4)
10421084serial4 = UnsafeTypeExpression "serial4"
10431085serial = UnsafeTypeExpression "serial"
10441086-- | not a true type, but merely a notational convenience for creating
10451087-- unique identifier columns with type `'PGint8`
1046−serial8, bigserial :: TypeExpression ('Optional ('NotNull 'PGint8))
1088+serial8, bigserial
1089+ :: TypeExpression ('Def :=> 'NotNull 'PGint8)
10471090serial8 = UnsafeTypeExpression "serial8"
10481091bigserial = UnsafeTypeExpression "bigserial"
10491092-- | variable-length character string
1050−text :: TypeExpression ('Required ('Null 'PGtext))
1093+text :: TypeExpression ('NoDef :=> 'Null 'PGtext)
10511094text = UnsafeTypeExpression "text"
10521095-- | fixed-length character string
10531096char, character
10541097 :: (KnownNat n, 1 <= n)
10551098 => proxy n
1056− -> TypeExpression ('Required ('Null ('PGchar n)))
1099+ -> TypeExpression ('NoDef :=> 'Null ('PGchar n))
10571100char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"
10581101character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"
10591102-- | variable-length character string
10601103varchar, characterVarying
10611104 :: (KnownNat n, 1 <= n)
10621105 => proxy n
1063− -> TypeExpression ('Required ('Null ('PGvarchar n)))
1106+ -> TypeExpression ('NoDef :=> 'Null ('PGvarchar n))
10641107varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"
10651108characterVarying p = UnsafeTypeExpression $
10661109 "character varying(" <> renderNat p <> ")"
10671110-- | binary data ("byte array")
1068−bytea :: TypeExpression ('Required ('Null 'PGbytea))
1111+bytea :: TypeExpression ('NoDef :=> 'Null 'PGbytea)
10691112bytea = UnsafeTypeExpression "bytea"
10701113-- | date and time (no time zone)
1071−timestamp :: TypeExpression ('Required ('Null 'PGtimestamp))
1114+timestamp :: TypeExpression ('NoDef :=> 'Null 'PGtimestamp)
10721115timestamp = UnsafeTypeExpression "timestamp"
10731116-- | date and time, including time zone
1074−timestampWithTimeZone :: TypeExpression ('Required ('Null 'PGtimestamptz))
1117+timestampWithTimeZone :: TypeExpression ('NoDef :=> 'Null 'PGtimestamptz)
10751118timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
10761119-- | calendar date (year, month, day)
1077−date :: TypeExpression ('Required ('Null 'PGdate))
1120+date :: TypeExpression ('NoDef :=> 'Null 'PGdate)
10781121date = UnsafeTypeExpression "date"
10791122-- | time of day (no time zone)
1080−time :: TypeExpression ('Required ('Null 'PGtime))
1123+time :: TypeExpression ('NoDef :=> 'Null 'PGtime)
10811124time = UnsafeTypeExpression "time"
10821125-- | time of day, including time zone
1083−timeWithTimeZone :: TypeExpression ('Required ('Null 'PGtimetz))
1126+timeWithTimeZone :: TypeExpression ('NoDef :=> 'Null 'PGtimetz)
10841127timeWithTimeZone = UnsafeTypeExpression "time with time zone"
10851128-- | time span
1086−interval :: TypeExpression ('Required ('Null 'PGinterval))
1129+interval :: TypeExpression ('NoDef :=> 'Null 'PGinterval)
10871130interval = UnsafeTypeExpression "interval"
10881131-- | universally unique identifier
1089−uuid :: TypeExpression ('Required ('Null 'PGuuid))
1132+uuid :: TypeExpression ('NoDef :=> 'Null 'PGuuid)
10901133uuid = UnsafeTypeExpression "uuid"
10911134-- | IPv4 or IPv6 host address
1092−inet :: TypeExpression ('Required ('Null 'PGinet))
1135+inet :: TypeExpression ('NoDef :=> 'Null 'PGinet)
10931136inet = UnsafeTypeExpression "inet"
10941137-- | textual JSON data
1095−json :: TypeExpression ('Required ('Null 'PGjson))
1138+json :: TypeExpression ('NoDef :=> 'Null 'PGjson)
10961139json = UnsafeTypeExpression "json"
10971140-- | binary JSON data, decomposed
1098−jsonb :: TypeExpression ('Required ('Null 'PGjsonb))
1141+jsonb :: TypeExpression ('NoDef :=> 'Null 'PGjsonb)
10991142jsonb = UnsafeTypeExpression "jsonb"
1143+-- | variable length array
1144+vararray
1145+ :: TypeExpression ('NoDef :=> 'Null pg)
1146+ -> TypeExpression ('NoDef :=> 'Null ('PGvararray pg))
1147+vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"
1148+-- | fixed length array
1149+--
1150+-- >>> renderTypeExpression (fixarray (Proxy @2) json)
1151+-- "json[2]"
1152+fixarray
1153+ :: KnownNat n
1154+ => proxy n
1155+ -> TypeExpression ('NoDef :=> 'Null pg)
1156+ -> TypeExpression ('NoDef :=> 'Null ('PGfixarray n pg))
1157+fixarray p ty = UnsafeTypeExpression $
1158+ renderTypeExpression ty <> "[" <> renderNat p <> "]"
11001159
11011160-- | used in `createTable` commands as a column constraint to ensure
11021161-- @NULL@ is not present
11031162notNull
1104− :: TypeExpression (optionality ('Null ty))
1105− -> TypeExpression (optionality ('NotNull ty))
1163+ :: TypeExpression (def :=> 'Null ty)
1164+ -> TypeExpression (def :=> 'NotNull ty)
11061165notNull ty = UnsafeTypeExpression $ renderTypeExpression ty <+> "NOT NULL"
11071166
11081167-- | used in `createTable` commands as a column constraint to give a default
11091168default_
1110− :: Expression '[] 'Ungrouped '[] ('Required ty)
1111− -> TypeExpression ('Required ty)
1112− -> TypeExpression ('Optional ty)
1169+ :: Expression '[] 'Ungrouped '[] ty
1170+ -> TypeExpression ('NoDef :=> ty)
1171+ -> TypeExpression ('Def :=> ty)
11131172default_ x ty = UnsafeTypeExpression $
11141173 renderTypeExpression ty <+> "DEFAULT" <+> renderExpression x
11151174
11161175-- | `pgtype` is a demoted version of a `PGType`
11171176class PGTyped (ty :: PGType) where
1118− pgtype :: TypeExpression ('Required ('Null ty))
1177+ pgtype :: TypeExpression ('NoDef :=> 'Null ty)
11191178instance PGTyped 'PGbool where pgtype = bool
11201179instance PGTyped 'PGint2 where pgtype = int2
11211180instance PGTyped 'PGint4 where pgtype = int4
@@ -1138,3 +1197,7 @@ instance PGTyped 'PGinterval where pgtype = interval
11381197instance PGTyped 'PGuuid where pgtype = uuid
11391198instance PGTyped 'PGjson where pgtype = json
11401199instance PGTyped 'PGjsonb where pgtype = jsonb
1200+instance PGTyped ty => PGTyped ('PGvararray ty) where
1201+ pgtype = vararray (pgtype @ty)
1202+instance (KnownNat n, PGTyped ty) => PGTyped ('PGfixarray n ty) where
1203+ pgtype = fixarray (Proxy @n) (pgtype @ty)
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+332−188
@@ -12,6 +12,7 @@ Squeal data manipulation language.
1212 DataKinds
1313 , DeriveDataTypeable
1414 , DeriveGeneric
15+ , FlexibleContexts
1516 , GADTs
1617 , GeneralizedNewtypeDeriving
1718 , KindSignatures
@@ -27,90 +28,72 @@ module Squeal.PostgreSQL.Manipulation
2728 ( -- * Manipulation
2829 Manipulation (UnsafeManipulation, renderManipulation)
2930 , queryStatement
30− -- * Insert
31− , insertInto
32− , ValuesClause (Values, ValuesQuery)
33− , renderValuesClause
31+ , ColumnValue (..)
3432 , ReturningClause (ReturningStar, Returning)
35− , renderReturningClause
3633 , ConflictClause (OnConflictDoRaise, OnConflictDoNothing, OnConflictDoUpdate)
34+ -- * Insert
35+ , insertRows
36+ , insertRow
37+ , insertRows_
38+ , insertRow_
39+ , insertQuery
40+ , insertQuery_
41+ , renderReturningClause
3742 , renderConflictClause
3843 -- * Update
3944 , update
40− , UpdateExpression (Same, Set)
41− , renderUpdateExpression
45+ , update_
46+ -- * Delete
4247 , deleteFrom
48+ , deleteFrom_
49+ -- * With
50+ , with
4351 ) where
4452
4553import Control.DeepSeq
46−import Data.ByteString
54+import Data.ByteString hiding (foldr)
4755import Data.Monoid
4856
57+import qualified Data.ByteString as ByteString
4958import qualified Generics.SOP as SOP
5059import qualified GHC.Generics as GHC
5160
5261import Squeal.PostgreSQL.Expression
53−import Squeal.PostgreSQL.Prettyprint
62+import Squeal.PostgreSQL.Render
5463import Squeal.PostgreSQL.Query
5564import Squeal.PostgreSQL.Schema
5665
57−-- | A `Manipulation` is a statement which may modify data in the database,
58−-- but does not alter the schema. Examples are `insertInto`, `update` and
59−-- `deleteFrom`. A `Query` is also considered a `Manipulation` even though
60−-- it does not modify data.
61−newtype Manipulation
62− (schema :: TablesType)
63− (params :: [ColumnType])
64− (columns :: ColumnsType)
65− = UnsafeManipulation { renderManipulation :: ByteString }
66− deriving (GHC.Generic,Show,Eq,Ord,NFData)
67−
68−-- | Convert a `Query` into a `Manipulation`.
69−queryStatement
70− :: Query schema params columns
71− -> Manipulation schema params columns
72−queryStatement q = UnsafeManipulation $ renderQuery q <> ";"
73−
74−{-----------------------------------------
75−INSERT statements
76−-----------------------------------------}
77−
7866{- |
79−When a table is created, it contains no data. The first thing to do
80−before a database can be of much use is to insert data. Data is
81−conceptually inserted one row at a time. Of course you can also insert
82−more than one row, but there is no way to insert less than one row.
83−Even if you know only some column values, a complete row must be created.
67+A `Manipulation` is a statement which may modify data in the database,
68+but does not alter the schema. Examples are inserts, updates and deletes.
69+A `Query` is also considered a `Manipulation` even though it does not modify data.
8470
8571simple insert:
8672
8773>>> :{
8874let
8975 manipulation :: Manipulation
90− '[ "tab" :::
91− '[ "col1" ::: 'Required ('NotNull 'PGint4)
92− , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[] '[]
76+ '[ "tab" ::: '[] :=>
77+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
78+ , "col2" ::: 'Def :=> 'NotNull 'PGint4 ]] '[] '[]
9379 manipulation =
94− insertInto #tab (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
95− OnConflictDoRaise (Returning Nil)
80+ insertRow_ #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil)
9681in renderManipulation manipulation
9782:}
98−"INSERT INTO tab (col1, col2) VALUES (2, 4);"
83+"INSERT INTO tab (col1, col2) VALUES (2, DEFAULT);"
9984
10085parameterized insert:
10186
10287>>> :{
10388let
10489 manipulation :: Manipulation
105− '[ "tab" :::
106− '[ "col1" ::: 'Required ('NotNull 'PGint4)
107− , "col2" ::: 'Required ('NotNull 'PGint4) ]]
108− '[ 'Required ('NotNull 'PGint4)
109− , 'Required ('NotNull 'PGint4) ] '[]
90+ '[ "tab" ::: '[] :=>
91+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
92+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]
93+ '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]
11094 manipulation =
111− insertInto #tab
112− (Values (param @1 `As` #col1 :* param @2 `As` #col2 :* Nil) [])
113− OnConflictDoRaise (Returning Nil)
95+ insertRow_ #tab
96+ (Set (param @1) `As` #col1 :* Set (param @2) `As` #col2 :* Nil)
11497in renderManipulation manipulation
11598:}
11699"INSERT INTO tab (col1, col2) VALUES (($1 :: int4), ($2 :: int4));"
@@ -120,105 +103,222 @@ returning insert:
120103>>> :{
121104let
122105 manipulation :: Manipulation
123− '[ "tab" :::
124− '[ "col1" ::: 'Required ('NotNull 'PGint4)
125− , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[]
126− '["fromOnly" ::: 'Required ('NotNull 'PGint4)]
106+ '[ "tab" ::: '[] :=>
107+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
108+ , "col2" ::: 'Def :=> 'NotNull 'PGint4 ]] '[]
109+ '["fromOnly" ::: 'NotNull 'PGint4]
127110 manipulation =
128− insertInto #tab (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
111+ insertRow #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil)
129112 OnConflictDoRaise (Returning (#col1 `As` #fromOnly :* Nil))
130113in renderManipulation manipulation
131114:}
132−"INSERT INTO tab (col1, col2) VALUES (2, 4) RETURNING col1 AS fromOnly;"
115+"INSERT INTO tab (col1, col2) VALUES (2, DEFAULT) RETURNING col1 AS fromOnly;"
116+
117+upsert:
118+
119+>>> :{
120+let
121+ manipulation :: Manipulation
122+ '[ "tab" ::: '[] :=>
123+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
124+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]
125+ '[] '[ "sum" ::: 'NotNull 'PGint4]
126+ manipulation =
127+ insertRows #tab
128+ (Set 2 `As` #col1 :* Set 4 `As` #col2 :* Nil)
129+ [Set 6 `As` #col1 :* Set 8 `As` #col2 :* Nil]
130+ (OnConflictDoUpdate
131+ (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
132+ [#col1 .== #col2])
133+ (Returning $ (#col1 + #col2) `As` #sum :* Nil)
134+in renderManipulation manipulation
135+:}
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;"
133137
134138query insert:
135139
136140>>> :{
137141let
138142 manipulation :: Manipulation
139− '[ "tab" :::
140− '[ "col1" ::: 'Required ('NotNull 'PGint4)
141− , "col2" ::: 'Required ('NotNull 'PGint4)
143+ '[ "tab" ::: '[] :=>
144+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
145+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4
142146 ]
143− , "other_tab" :::
144− '[ "col1" ::: 'Required ('NotNull 'PGint4)
145− , "col2" ::: 'Required ('NotNull 'PGint4)
147+ , "other_tab" ::: '[] :=>
148+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
149+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4
146150 ]
147151 ] '[] '[]
148152 manipulation =
149− insertInto #tab
150− ( ValuesQuery $
151− selectStar (from (Table (#other_tab `As` #t))) )
152− OnConflictDoRaise (Returning Nil)
153+ insertQuery_ #tab
154+ (selectStar (from (table (#other_tab `As` #t))))
153155in renderManipulation manipulation
154156:}
155157"INSERT INTO tab SELECT * FROM other_tab AS t;"
156158
157−upsert:
159+update:
158160
159161>>> :{
160162let
161163 manipulation :: Manipulation
162− '[ "tab" :::
163− '[ "col1" ::: 'Required ('NotNull 'PGint4)
164− , "col2" ::: 'Required ('NotNull 'PGint4) ]]
165− '[] '[ "sum" ::: 'Required ('NotNull 'PGint4)]
164+ '[ "tab" ::: '[] :=>
165+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
166+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[] '[]
166167 manipulation =
167− insertInto #tab
168− (Values
169− (2 `As` #col1 :* 4 `As` #col2 :* Nil)
170− [6 `As` #col1 :* 8 `As` #col2 :* Nil])
171− (OnConflictDoUpdate
172− (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
173− (Just (#col1 .== #col2)))
174− (Returning $ (#col1 + #col2) `As` #sum :* Nil)
168+ update_ #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
169+ (#col1 ./= #col2)
175170in renderManipulation manipulation
176171:}
177−"INSERT INTO tab (col1, col2) VALUES (2, 4), (6, 8) ON CONFLICT DO UPDATE SET col1 = 2 WHERE (col1 = col2) RETURNING (col1 + col2) AS sum;"
172+"UPDATE tab SET col1 = 2 WHERE (col1 <> col2);"
173+
174+delete:
175+
176+>>> :{
177+let
178+ manipulation :: Manipulation
179+ '[ "tab" ::: '[] :=>
180+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
181+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[]
182+ '[ "col1" ::: 'NotNull 'PGint4
183+ , "col2" ::: 'NotNull 'PGint4 ]
184+ manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar
185+in renderManipulation manipulation
186+:}
187+"DELETE FROM tab WHERE (col1 = col2) RETURNING *;"
178188-}
179−insertInto
180− :: (SOP.SListI columns, SOP.SListI results, HasTable table schema columns)
181− => Alias table -- ^ table to insert into
182− -> ValuesClause schema params columns -- ^ values to insert
189+newtype Manipulation
190+ (schema :: TablesType)
191+ (params :: [NullityType])
192+ (columns :: RelationType)
193+ = UnsafeManipulation { renderManipulation :: ByteString }
194+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
195+
196+-- | Convert a `Query` into a `Manipulation`.
197+queryStatement
198+ :: Query schema params columns
199+ -> Manipulation schema params columns
200+queryStatement q = UnsafeManipulation $ renderQuery q <> ";"
201+
202+{-----------------------------------------
203+INSERT statements
204+-----------------------------------------}
205+
206+-- | Insert multiple rows.
207+--
208+-- When a table is created, it contains no data. The first thing to do
209+-- before a database can be of much use is to insert data. Data is
210+-- conceptually inserted one row at a time. Of course you can also insert
211+-- more than one row, but there is no way to insert less than one row.
212+-- Even if you know only some column values, a complete row must be created.
213+insertRows
214+ :: ( SOP.SListI columns
215+ , SOP.SListI results
216+ , Has tab schema table
217+ , columns ~ TableToColumns table )
218+ => Alias tab -- ^ table to insert into
219+ -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert
220+ -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert
183221 -> ConflictClause columns params
184222 -- ^ what to do in case of constraint conflict
185223 -> ReturningClause columns params results -- ^ results to return
186224 -> Manipulation schema params results
187−insertInto table insert conflict returning = UnsafeManipulation $
188− "INSERT" <+> "INTO" <+> renderAlias table
189− <+> renderValuesClause insert
190− <> renderConflictClause conflict
191− <> renderReturningClause returning
192−
193−-- | A `ValuesClause` lets you insert either values, free `Expression`s,
194−-- or the result of a `Query`.
195−data ValuesClause
196− (schema :: TablesType)
197− (params :: [ColumnType])
198− (columns :: ColumnsType)
199− = Values
200− (NP (Aliased (Expression '[] 'Ungrouped params)) columns)
201− [NP (Aliased (Expression '[] 'Ungrouped params)) columns]
202− -- ^ at least one row of values
203− | ValuesQuery (Query schema params columns)
204−
205−-- | Render a `ValuesClause`.
206−renderValuesClause
207− :: SOP.SListI columns
208− => ValuesClause schema params columns
209− -> ByteString
210−renderValuesClause = \case
211− Values row rows ->
212− parenthesized (renderCommaSeparated renderAliasPart row)
225+insertRows tab row rows conflict returning = UnsafeManipulation $
226+ "INSERT" <+> "INTO" <+> renderAlias tab
227+ <+> parenthesized (renderCommaSeparated renderAliasPart row)
213228 <+> "VALUES"
214229 <+> commaSeparated
215− (parenthesized . renderCommaSeparated renderValuePart <$> row:rows)
230+ ( parenthesized
231+ . renderCommaSeparated renderColumnValuePart <$> row:rows )
232+ <> renderConflictClause conflict
233+ <> renderReturningClause returning
216234 where
217− renderAliasPart, renderValuePart
218− :: Aliased (Expression '[] 'Ungrouped params) ty -> ByteString
235+ renderAliasPart, renderColumnValuePart
236+ :: Aliased (ColumnValue '[] params) ty -> ByteString
219237 renderAliasPart (_ `As` name) = renderAlias name
220− renderValuePart (value `As` _) = renderExpression value
221− ValuesQuery q -> renderQuery q
238+ renderColumnValuePart (value `As` _) = case value of
239+ Default -> "DEFAULT"
240+ Set expression -> renderExpression expression
241+
242+-- | Insert a single row.
243+insertRow
244+ :: ( SOP.SListI columns
245+ , SOP.SListI results
246+ , Has tab schema table
247+ , columns ~ TableToColumns table )
248+ => Alias tab -- ^ table to insert into
249+ -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert
250+ -> ConflictClause columns params
251+ -- ^ what to do in case of constraint conflict
252+ -> ReturningClause columns params results -- ^ results to return
253+ -> Manipulation schema params results
254+insertRow tab row = insertRows tab row []
255+
256+-- | Insert multiple rows returning `Nil` and raising an error on conflicts.
257+insertRows_
258+ :: ( SOP.SListI columns
259+ , Has tab schema table
260+ , columns ~ TableToColumns table )
261+ => Alias tab -- ^ table to insert into
262+ -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert
263+ -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert
264+ -> Manipulation schema params '[]
265+insertRows_ tab row rows =
266+ insertRows tab row rows OnConflictDoRaise (Returning Nil)
267+
268+-- | Insert a single row returning `Nil` and raising an error on conflicts.
269+insertRow_
270+ :: ( SOP.SListI columns
271+ , Has tab schema table
272+ , columns ~ TableToColumns table )
273+ => Alias tab -- ^ table to insert into
274+ -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert
275+ -> Manipulation schema params '[]
276+insertRow_ tab row = insertRow tab row OnConflictDoRaise (Returning Nil)
277+
278+-- | Insert a `Query`.
279+insertQuery
280+ :: ( SOP.SListI columns
281+ , SOP.SListI results
282+ , Has tab schema table
283+ , columns ~ TableToColumns table )
284+ => Alias tab -- ^ table to insert into
285+ -> Query schema params (ColumnsToRelation columns)
286+ -> ConflictClause columns params
287+ -- ^ what to do in case of constraint conflict
288+ -> ReturningClause columns params results -- ^ results to return
289+ -> Manipulation schema params results
290+insertQuery tab query conflict returning = UnsafeManipulation $
291+ "INSERT" <+> "INTO" <+> renderAlias tab
292+ <+> renderQuery query
293+ <> renderConflictClause conflict
294+ <> renderReturningClause returning
295+
296+-- | Insert a `Query` returning `Nil` and raising an error on conflicts.
297+insertQuery_
298+ :: ( SOP.SListI columns
299+ , Has tab schema table
300+ , columns ~ TableToColumns table )
301+ => Alias tab -- ^ table to insert into
302+ -> Query schema params (ColumnsToRelation columns)
303+ -> Manipulation schema params '[]
304+insertQuery_ tab query =
305+ insertQuery tab query OnConflictDoRaise (Returning Nil)
306+
307+-- | `ColumnValue`s are values to insert or update in a row
308+-- `Same` updates with the same value.
309+-- `Default` inserts or updates with the @DEFAULT@ value
310+-- `Set` a value to be an `Expression`, relative to the given
311+-- row for an update, and closed for an insert.
312+data ColumnValue
313+ (columns :: RelationType)
314+ (params :: [NullityType])
315+ (ty :: ColumnType)
316+ where
317+ Same :: ColumnValue (column ': columns) params ty
318+ Default :: ColumnValue columns params ('Def :=> ty)
319+ Set
320+ :: (forall table. Expression '[table ::: columns] 'Ungrouped params ty)
321+ -> ColumnValue columns params (constraint :=> ty)
222322
223323-- | A `ReturningClause` computes and return value(s) based
224324-- on each row actually inserted, updated or deleted. This is primarily
@@ -228,18 +328,19 @@ renderValuesClause = \case
228328-- deleted will be returned. For example, if a row was locked
229329-- but not updated because an `OnConflictDoUpdate` condition was not satisfied,
230330-- the row will not be returned. `ReturningStar` will return all columns
231−-- in the row. Use `Returning Nil` in the common case where no return
331+-- in the row. Use @Returning Nil@ in the common case where no return
232332-- values are desired.
233333data ReturningClause
234334 (columns :: ColumnsType)
235− (params :: [ColumnType])
236− (results :: ColumnsType)
335+ (params :: [NullityType])
336+ (results :: RelationType)
237337 where
238− ReturningStar :: ReturningClause columns params columns
338+ ReturningStar
339+ :: results ~ ColumnsToRelation columns
340+ => ReturningClause columns params results
239341 Returning
240− :: NP
241− (Aliased (Expression '[table ::: columns] 'Ungrouped params))
242− results
342+ :: rel ~ ColumnsToRelation columns
343+ => NP (Aliased (Expression '[table ::: rel] 'Ungrouped params)) results
243344 -> ReturningClause columns params results
244345
245346-- | Render a `ReturningClause`.
@@ -251,19 +352,19 @@ renderReturningClause = \case
251352 ReturningStar -> " RETURNING *;"
252353 Returning Nil -> ";"
253354 Returning results -> " RETURNING"
254− <+> renderCommaSeparated (renderAliased renderExpression) results <> ";"
355+ <+> renderCommaSeparated (renderAliasedAs renderExpression) results <> ";"
255356
256357-- | A `ConflictClause` specifies an action to perform upon a constraint
257358-- violation. `OnConflictDoRaise` will raise an error.
258359-- `OnConflictDoNothing` simply avoids inserting a row.
259360-- `OnConflictDoUpdate` updates the existing row that conflicts with the row
260361-- proposed for insertion.
261−data ConflictClause columns params where
362+data ConflictClause (columns :: ColumnsType) params where
262363 OnConflictDoRaise :: ConflictClause columns params
263364 OnConflictDoNothing :: ConflictClause columns params
264365 OnConflictDoUpdate
265− :: NP (Aliased (UpdateExpression columns params)) columns
266− -> Maybe (Condition '[table ::: columns] 'Ungrouped params)
366+ :: NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns
367+ -> [Condition '[table ::: ColumnsToRelation columns] 'Ungrouped params]
267368 -> ConflictClause columns params
268369
269370-- | Render a `ConflictClause`.
@@ -274,12 +375,22 @@ renderConflictClause
274375renderConflictClause = \case
275376 OnConflictDoRaise -> ""
276377 OnConflictDoNothing -> " ON CONFLICT DO NOTHING"
277− OnConflictDoUpdate updates whMaybe
378+ OnConflictDoUpdate updates whs'
278379 -> " ON CONFLICT DO UPDATE SET"
279− <+> renderCommaSeparatedMaybe renderUpdateExpression updates
280− <> case whMaybe of
281− Nothing -> ""
282− Just wh -> " WHERE" <+> renderExpression wh
380+ <+> renderCommaSeparatedMaybe renderUpdate updates
381+ <> case whs' of
382+ [] -> ""
383+ wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)
384+ where
385+ renderUpdate
386+ :: Aliased (ColumnValue columns params) column
387+ -> Maybe ByteString
388+ renderUpdate = \case
389+ Same `As` _ -> Nothing
390+ Default `As` column -> Just $
391+ renderAlias column <+> "=" <+> "DEFAULT"
392+ Set expression `As` column -> Just $
393+ renderAlias column <+> "=" <+> renderExpression expression
283394
284395{-----------------------------------------
285396UPDATE statements
@@ -287,82 +398,115 @@ UPDATE statements
287398
288399-- | An `update` command changes the values of the specified columns
289400-- in all rows that satisfy the condition.
290−--
291−-- >>> :{
292−-- let
293−-- manipulation :: Manipulation
294−-- '[ "tab" :::
295−-- '[ "col1" ::: 'Required ('NotNull 'PGint4)
296−-- , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[] '[]
297−-- manipulation =
298−-- update #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
299−-- (#col1 ./= #col2) (Returning Nil)
300−-- in renderManipulation manipulation
301−-- :}
302−-- "UPDATE tab SET col1 = 2 WHERE (col1 <> col2);"
303401update
304− :: (HasTable table schema columns, SOP.SListI columns, SOP.SListI results)
305− => Alias table -- ^ table to update
306− -> NP (Aliased (UpdateExpression columns params)) columns
402+ :: ( SOP.SListI columns
403+ , SOP.SListI results
404+ , Has tab schema table
405+ , columns ~ TableToColumns table )
406+ => Alias tab -- ^ table to update
407+ -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns
307408 -- ^ modified values to replace old values
308− -> Condition '[tab ::: columns] 'Ungrouped params
409+ -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params
309410 -- ^ condition under which to perform update on a row
310411 -> ReturningClause columns params results -- ^ results to return
311412 -> Manipulation schema params results
312−update table columns wh returning = UnsafeManipulation $
413+update tab columns wh returning = UnsafeManipulation $
313414 "UPDATE"
314− <+> renderAlias table
415+ <+> renderAlias tab
315416 <+> "SET"
316− <+> renderCommaSeparatedMaybe renderUpdateExpression columns
417+ <+> renderCommaSeparatedMaybe renderUpdate columns
317418 <+> "WHERE" <+> renderExpression wh
318419 <> renderReturningClause returning
319−
320−-- | Columns to be updated are mentioned with `Set`; columns which are to
321−-- remain the same are mentioned with `Same`.
322−data UpdateExpression columns params ty
323− = Same
324− -- ^ column to remain the same upon update
325− | Set (forall table. Expression '[table ::: columns] 'Ungrouped params ty)
326− -- ^ column to be updated
327−deriving instance Show (UpdateExpression columns params ty)
328−deriving instance Eq (UpdateExpression columns params ty)
329−deriving instance Ord (UpdateExpression columns params ty)
330−
331−-- | Render an `UpdateExpression`.
332−renderUpdateExpression
333− :: Aliased (UpdateExpression params columns) column
334− -> Maybe ByteString
335−renderUpdateExpression = \case
336− Same `As` _ -> Nothing
337− Set expression `As` column -> Just $
338− renderAlias column <+> "=" <+> renderExpression expression
420+ where
421+ renderUpdate
422+ :: Aliased (ColumnValue columns params) column
423+ -> Maybe ByteString
424+ renderUpdate = \case
425+ Same `As` _ -> Nothing
426+ Default `As` column -> Just $
427+ renderAlias column <+> "=" <+> "DEFAULT"
428+ Set expression `As` column -> Just $
429+ renderAlias column <+> "=" <+> renderExpression expression
430+
431+-- | Update a row returning `Nil`.
432+update_
433+ :: ( SOP.SListI columns
434+ , Has tab schema table
435+ , columns ~ TableToColumns table )
436+ => Alias tab -- ^ table to update
437+ -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns
438+ -- ^ modified values to replace old values
439+ -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params
440+ -- ^ condition under which to perform update on a row
441+ -> Manipulation schema params '[]
442+update_ tab columns wh = update tab columns wh (Returning Nil)
339443
340444{-----------------------------------------
341445DELETE statements
342446-----------------------------------------}
343447
344448-- | Delete rows of a table.
345−--
346−-- >>> :{
347−-- let
348−-- manipulation :: Manipulation
349−-- '[ "tab" :::
350−-- '[ "col1" ::: 'Required ('NotNull 'PGint4)
351−-- , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[]
352−-- '[ "col1" ::: 'Required ('NotNull 'PGint4)
353−-- , "col2" ::: 'Required ('NotNull 'PGint4) ]
354−-- manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar
355−-- in renderManipulation manipulation
356−-- :}
357−-- "DELETE FROM tab WHERE (col1 = col2) RETURNING *;"
358449deleteFrom
359− :: (SOP.SListI results, HasTable table schema columns)
360− => Alias table -- ^ table to delete from
361− -> Condition '[table ::: columns] 'Ungrouped params
450+ :: ( SOP.SListI results
451+ , Has tab schema table
452+ , columns ~ TableToColumns table )
453+ => Alias tab -- ^ table to delete from
454+ -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params
362455 -- ^ condition under which to delete a row
363456 -> ReturningClause columns params results -- ^ results to return
364457 -> Manipulation schema params results
365−deleteFrom table wh returning = UnsafeManipulation $
366− "DELETE FROM" <+> renderAlias table
458+deleteFrom tab wh returning = UnsafeManipulation $
459+ "DELETE FROM" <+> renderAlias tab
367460 <+> "WHERE" <+> renderExpression wh
368461 <> renderReturningClause returning
462+
463+-- | Delete rows returning `Nil`.
464+deleteFrom_
465+ :: ( Has tab schema table
466+ , columns ~ TableToColumns table )
467+ => Alias tab -- ^ table to delete from
468+ -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params
469+ -- ^ condition under which to delete a row
470+ -> Manipulation schema params '[]
471+deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil)
472+
473+{-----------------------------------------
474+WITH statements
475+-----------------------------------------}
476+
477+-- | `with` provides a way to write auxiliary statements for use in a larger statement.
478+-- These statements, which are often referred to as Common Table Expressions or CTEs,
479+-- can be thought of as defining temporary tables that exist just for one statement.
480+--
481+-- >>> type ProductsTable = '[] :=> '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]
482+--
483+-- >>> :{
484+-- let
485+-- manipulation :: Manipulation '["products" ::: ProductsTable, "products_deleted" ::: ProductsTable] '[ 'NotNull 'PGdate] '[]
486+-- manipulation = with
487+-- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rows :* Nil)
488+-- (insertQuery_ #products_deleted (selectStar (from (table (#deleted_rows `As` #t)))))
489+-- in renderManipulation manipulation
490+-- :}
491+-- "WITH deleted_rows AS (DELETE FROM products WHERE (date < ($1 :: date)) RETURNING *) INSERT INTO products_deleted SELECT * FROM deleted_rows AS t;"
492+with
493+ :: SOP.SListI commons
494+ => NP (Aliased (Manipulation schema params)) commons
495+ -- ^ common table expressions
496+ -> Manipulation (Join (RelationsToTables commons) schema) params results
497+ -> Manipulation schema params results
498+with commons manipulation = UnsafeManipulation $
499+ "WITH" <+> renderCommaSeparated renderCommon commons
500+ <+> renderManipulation manipulation
501+ where
502+ renderCommon
503+ :: Aliased (Manipulation schema params) common
504+ -> ByteString
505+ renderCommon (common `As` alias) =
506+ renderAlias alias <+> "AS" <+>
507+ let
508+ str = renderManipulation common
509+ len = ByteString.length str
510+ str' = ByteString.take (len - 1) str -- remove ';'
511+ in
512+ parenthesized str'
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hsnew file+318
@@ -0,0 +1,318 @@
1+{-|
2+Module: Squeal.PostgreSQL.Migration
3+Description: Squeal migrations
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+This module defines a `Migration` type to safely
9+change the schema of your database over time. Let's see an example!
10+
11+>>> :set -XDataKinds -XOverloadedLabels
12+>>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators
13+>>> :{
14+type UsersTable =
15+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
16+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
17+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
18+ ]
19+:}
20+
21+>>> :{
22+type EmailsTable =
23+ '[ "pk_emails" ::: 'PrimaryKey '["id"]
24+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
25+ ] :=>
26+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4
27+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
28+ , "email" ::: 'NoDef :=> 'Null 'PGtext
29+ ]
30+:}
31+
32+>>> :{
33+let
34+ makeUsers :: Migration IO '[] '["users" ::: UsersTable]
35+ makeUsers = Migration
36+ { name = "make users table"
37+ , up = void . define $
38+ createTable #users
39+ ( serial `As` #id :*
40+ (text & notNull) `As` #name :* Nil )
41+ ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil )
42+ , down = void . define $ dropTable #users
43+ }
44+:}
45+
46+>>> :{
47+let
48+ makeEmails :: Migration IO '["users" ::: UsersTable]
49+ '["users" ::: UsersTable, "emails" ::: EmailsTable]
50+ makeEmails = Migration
51+ { name = "make emails table"
52+ , up = void . define $
53+ createTable #emails
54+ ( serial `As` #id :*
55+ (int & notNull) `As` #user_id :*
56+ text `As` #email :* Nil )
57+ ( primaryKey (Column #id :* Nil) `As` #pk_emails :*
58+ foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)
59+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )
60+ , down = void . define $ dropTable #emails
61+ }
62+:}
63+
64+Now that we have a couple migrations we can chain them together.
65+
66+>>> let migrations = makeUsers :>> makeEmails :>> Done
67+
68+>>> :{
69+let
70+ numMigrations
71+ :: Has "schema_migrations" schema MigrationsTable
72+ => PQ schema schema IO ()
73+ numMigrations = do
74+ result <- runQuery (selectStar (from (table (#schema_migrations `As` #m))))
75+ num <- ntuples result
76+ liftBase $ print num
77+:}
78+
79+>>> :{
80+withConnection "host=localhost port=5432 dbname=exampledb" $
81+ manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
82+ -- suppress notices
83+ & pqThen (migrateUp migrations)
84+ & pqThen numMigrations
85+ & pqThen (migrateDown migrations)
86+ & pqThen numMigrations
87+:}
88+Row 2
89+Row 0
90+-}
91+
92+{-# LANGUAGE
93+ ScopedTypeVariables
94+ , OverloadedStrings
95+ , DataKinds
96+ , GADTs
97+ , LambdaCase
98+ , PolyKinds
99+ , OverloadedLabels
100+ , TypeApplications
101+ , FlexibleContexts
102+ , TypeOperators
103+#-}
104+
105+module Squeal.PostgreSQL.Migration
106+ ( -- * Migration
107+ Migration (..)
108+ , migrateUp
109+ , migrateDown
110+ -- * Aligned lists
111+ , AlignedList (..)
112+ , single
113+ -- * Migration table
114+ , MigrationsTable
115+ , createMigrations
116+ , insertMigration
117+ , deleteMigration
118+ , selectMigration
119+ ) where
120+
121+import Control.Category
122+import Control.Monad
123+import Control.Monad.Base
124+import Control.Monad.Trans.Control
125+import Data.Monoid
126+import Generics.SOP (K(..))
127+import Data.Function ((&))
128+import Data.Text (Text)
129+import Prelude hiding (id, (.))
130+
131+import Squeal.PostgreSQL
132+
133+-- | A `Migration` should contain an inverse pair of
134+-- `up` and `down` instructions and a unique `name`.
135+data Migration io schema0 schema1 = Migration
136+ { name :: Text -- ^ The `name` of a `Migration`.
137+ -- Each `name` in a `Migration` should be unique.
138+ , up :: PQ schema0 schema1 io () -- ^ The `up` instruction of a `Migration`.
139+ , down :: PQ schema1 schema0 io () -- ^ The `down` instruction of a `Migration`.
140+ }
141+
142+-- | An `AlignedList` is a type-aligned list or free category.
143+data AlignedList p x0 x1 where
144+ Done :: AlignedList p x x
145+ (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
146+infixr 7 :>>
147+instance Category (AlignedList p) where
148+ id = Done
149+ (.) list = \case
150+ Done -> list
151+ step :>> steps -> step :>> (steps >>> list)
152+
153+-- | A `single` step.
154+single :: p x0 x1 -> AlignedList p x0 x1
155+single step = step :>> Done
156+
157+-- | Run `Migration`s by creating the `MigrationsTable`
158+-- if it does not exist and then in a transaction, for each each `Migration`
159+-- query to see if the `Migration` is executed. If not, then
160+-- execute the `Migration` and insert its row in the `MigrationsTable`.
161+migrateUp
162+ :: MonadBaseControl IO io
163+ => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run
164+ -> PQ
165+ ("schema_migrations" ::: MigrationsTable ': schema0)
166+ ("schema_migrations" ::: MigrationsTable ': schema1)
167+ io ()
168+migrateUp migration =
169+ define createMigrations
170+ & pqBind okResult
171+ & pqThen (transactionallySchema_ (upMigrations migration))
172+ where
173+
174+ upMigrations
175+ :: MonadBaseControl IO io
176+ => AlignedList (Migration io) schema0 schema1
177+ -> PQ
178+ ("schema_migrations" ::: MigrationsTable ': schema0)
179+ ("schema_migrations" ::: MigrationsTable ': schema1)
180+ io ()
181+ upMigrations = \case
182+ Done -> return ()
183+ step :>> steps -> upMigration step & pqThen (upMigrations steps)
184+
185+ upMigration
186+ :: MonadBase IO io
187+ => Migration io schema0 schema1 -> PQ
188+ ("schema_migrations" ::: MigrationsTable ': schema0)
189+ ("schema_migrations" ::: MigrationsTable ': schema1)
190+ io ()
191+ upMigration step =
192+ queryExecuted step
193+ & pqBind (\ executed ->
194+ if executed == 1 -- up step has already been executed
195+ then PQ (\ _ -> return (K ())) -- unsafely switch schemas
196+ else
197+ pqEmbed (up step) -- safely switch schemas
198+ & pqThen (manipulateParams insertMigration (Only (name step)))
199+ -- insert execution record
200+ & pqBind okResult)
201+
202+ queryExecuted
203+ :: MonadBase IO io
204+ => Migration io schema0 schema1 -> PQ
205+ ("schema_migrations" ::: MigrationsTable ': schema0)
206+ ("schema_migrations" ::: MigrationsTable ': schema0)
207+ io Row
208+ queryExecuted step = do
209+ result <- runQueryParams selectMigration (Only (name step))
210+ okResult result
211+ ntuples result
212+
213+-- | Rewind `Migration`s by creating the `MigrationsTable`
214+-- if it does not exist and then in a transaction, for each each `Migration`
215+-- query to see if the `Migration` is executed. If it is, then
216+-- rewind the `Migration` and delete its row in the `MigrationsTable`.
217+migrateDown
218+ :: MonadBaseControl IO io
219+ => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind
220+ -> PQ
221+ ("schema_migrations" ::: MigrationsTable ': schema1)
222+ ("schema_migrations" ::: MigrationsTable ': schema0)
223+ io ()
224+migrateDown migrations =
225+ define createMigrations
226+ & pqBind okResult
227+ & pqThen (transactionallySchema_ (downMigrations migrations))
228+ where
229+
230+ downMigrations
231+ :: MonadBaseControl IO io
232+ => AlignedList (Migration io) schema0 schema1 -> PQ
233+ ("schema_migrations" ::: MigrationsTable ': schema1)
234+ ("schema_migrations" ::: MigrationsTable ': schema0)
235+ io ()
236+ downMigrations = \case
237+ Done -> return ()
238+ step :>> steps -> downMigrations steps & pqThen (downMigration step)
239+
240+ downMigration
241+ :: MonadBase IO io
242+ => Migration io schema0 schema1 -> PQ
243+ ("schema_migrations" ::: MigrationsTable ': schema1)
244+ ("schema_migrations" ::: MigrationsTable ': schema0)
245+ io ()
246+ downMigration step =
247+ queryExecuted step
248+ & pqBind (\ executed ->
249+ if executed == 0 -- up step has not been executed
250+ then PQ (\ _ -> return (K ())) -- unsafely switch schemas
251+ else
252+ pqEmbed (down step) -- safely switch schemas
253+ & pqThen (manipulateParams deleteMigration (Only (name step)))
254+ -- delete execution record
255+ & pqBind okResult)
256+
257+ queryExecuted
258+ :: MonadBase IO io
259+ => Migration io schema0 schema1 -> PQ
260+ ("schema_migrations" ::: MigrationsTable ': schema1)
261+ ("schema_migrations" ::: MigrationsTable ': schema1)
262+ io Row
263+ queryExecuted step = do
264+ result <- runQueryParams selectMigration (Only (name step))
265+ okResult result
266+ ntuples result
267+
268+okResult :: MonadBase IO io => K Result results -> PQ schema schema io ()
269+okResult result = do
270+ status <- resultStatus result
271+ when (not (status `elem` [CommandOk, TuplesOk])) $ do
272+ errorMessageMaybe <- resultErrorMessage result
273+ case errorMessageMaybe of
274+ Nothing -> error "migrateDown: unknown error"
275+ Just msg -> error ("migrationDown: " <> show msg)
276+
277+-- | The `TableType` for a Squeal migration.
278+type MigrationsTable =
279+ '[ "migrations_unique_name" ::: 'Unique '["name"]] :=>
280+ '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext
281+ , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz
282+ ]
283+
284+-- | Creates a `MigrationsTable` if it does not already exist.
285+createMigrations
286+ :: Has "schema_migrations" schema MigrationsTable
287+ => Definition schema schema
288+createMigrations =
289+ createTableIfNotExists #schema_migrations
290+ ( (text & notNull) `As` #name :*
291+ (timestampWithTimeZone & notNull & default_ currentTimestamp)
292+ `As` #executed_at :* Nil )
293+ ( unique (Column #name :* Nil) `As` #migrations_unique_name :* Nil )
294+
295+-- | Inserts a `Migration` into the `MigrationsTable`
296+insertMigration
297+ :: Has "schema_migrations" schema MigrationsTable
298+ => Manipulation schema '[ 'NotNull 'PGtext] '[]
299+insertMigration = insertRow_ #schema_migrations
300+ ( Set (param @1) `As` #name :*
301+ Default `As` #executed_at :* Nil )
302+
303+-- | Deletes a `Migration` from the `MigrationsTable`
304+deleteMigration
305+ :: Has "schema_migrations" schema MigrationsTable
306+ => Manipulation schema '[ 'NotNull 'PGtext ] '[]
307+deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)
308+
309+-- | Selects a `Migration` from the `MigrationsTable`, returning
310+-- the time at which it was executed.
311+selectMigration
312+ :: Has "schema_migrations" schema MigrationsTable
313+ => Query schema '[ 'NotNull 'PGtext ]
314+ '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]
315+selectMigration = select
316+ (#executed_at `As` #executed_at :* Nil)
317+ ( from (table (#schema_migrations `As` #m))
318+ & where_ (#name .== param @1))
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+227−194
@@ -5,9 +5,17 @@ Copyright: (c) Eitan Chatav, 2017
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
8−`Squeal.PostgreSQL.PQ` is where Squeal statements come to actually get run by
9−`LibPQ`. It contains a `PQ` indexed monad transformer to run `Definition`s and
10−a `MonadPQ` constraint for running a `Manipulation` or `Query`.
8+This module is where Squeal commands actually get executed by
9+`LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing
10+a `Definition` and `MonadPQ` for executing a `Manipulation` or `Query`,
11+and a `PQ` type with instances for them.
12+
13+Using Squeal in your application will come down to defining
14+the @schema@ of your database and including @PQ schema schema@ in your
15+application's monad transformer stack, giving it an instance of `MonadPQ`.
16+
17+This module also provides functions for retrieving rows from the `LibPQ.Result`
18+of executing Squeal commands.
1119-}
1220
1321{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
@@ -33,39 +41,38 @@ a `MonadPQ` constraint for running a `Manipulation` or `Query`.
3341
3442module Squeal.PostgreSQL.PQ
3543 ( -- * Connection
36− Connection (Connection, unConnection)
44+ LibPQ.Connection
3745 , connectdb
3846 , finish
3947 , withConnection
48+ , lowerConnection
4049 -- * PQ
41− , PQ (PQ, runPQ)
50+ , PQ (PQ, unPQ)
51+ , runPQ
4252 , execPQ
43− , pqAp
44− , pqBind
45− , pqThen
46− , define
47− , thenDefine
48− -- * MonadPQ
53+ , evalPQ
54+ , IndexedMonadTransPQ (..)
4955 , MonadPQ (..)
5056 , PQRun
5157 , pqliftWith
5258 -- * Result
53− , Result (Result, unResult)
54− , RowNumber (RowNumber, unRowNumber)
55− , ColumnNumber (UnsafeColumnNumber, getColumnNumber)
56− , HasColumnNumber (columnNumber)
57− , getValue
59+ , LibPQ.Result
60+ , LibPQ.Row
61+ , ntuples
5862 , getRow
5963 , getRows
60− , ntuples
6164 , nextRow
6265 , firstRow
6366 , liftResult
67+ , LibPQ.ExecStatus (..)
68+ , resultStatus
69+ , resultErrorMessage
6470 ) where
6571
6672import Control.Exception.Lifted
6773import Control.Monad.Base
6874import Control.Monad.Except
75+import Control.Monad.Morph
6976import Control.Monad.Trans.Control
7077import Data.ByteString (ByteString)
7178import Data.Foldable
@@ -74,8 +81,6 @@ import Data.Kind
7481import Data.Monoid
7582import Data.Traversable
7683import Generics.SOP
77−import GHC.Exts hiding (fromList)
78−import GHC.TypeLits
7984
8085import qualified Database.PostgreSQL.LibPQ as LibPQ
8186
@@ -99,11 +104,6 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict
99104import qualified Control.Monad.Trans.RWS.Lazy as Lazy
100105import qualified Control.Monad.Trans.RWS.Strict as Strict
101106
102−-- | A `Connection` consists of a `Database.PostgreSQL.LibPQ`
103−-- `Database.PastgreSQL.LibPQ.Connection` and a phantom `TablesType`
104−newtype Connection (schema :: TablesType) =
105− Connection { unConnection :: LibPQ.Connection }
106−
107107{- | Makes a new connection to the database server.
108108
109109This function opens a new database connection using the parameters taken
@@ -119,8 +119,9 @@ backslashes within the value must be escaped with a backslash, i.e., ' and \.
119119To specify the schema you wish to connect with, use type application.
120120
121121>>> :set -XDataKinds
122+>>> :set -XPolyKinds
122123>>> :set -XTypeOperators
123−>>> type Schema = '["tab" ::: '["col" ::: 'Required ('Null 'PGint2)]]
124+>>> type Schema = '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint2]]
124125>>> :set -XTypeApplications
125126>>> :set -XOverloadedStrings
126127>>> conn <- connectdb @Schema "host=localhost port=5432 dbname=exampledb"
@@ -132,24 +133,30 @@ connectdb
132133 :: forall schema io
133134 . MonadBase IO io
134135 => ByteString -- ^ conninfo
135− -> io (Connection schema)
136−connectdb = fmap Connection . liftBase . LibPQ.connectdb
136+ -> io (K LibPQ.Connection schema)
137+connectdb = fmap K . liftBase . LibPQ.connectdb
137138
138139-- | Closes the connection to the server.
139−finish :: MonadBase IO io => Connection schema -> io ()
140−finish = liftBase . LibPQ.finish . unConnection
140+finish :: MonadBase IO io => K LibPQ.Connection schema -> io ()
141+finish = liftBase . LibPQ.finish . unK
141142
142143-- | Do `connectdb` and `finish` before and after a computation.
143144withConnection
144145 :: forall schema0 schema1 io x
145146 . MonadBaseControl IO io
146147 => ByteString
147− -> (Connection schema0 -> io (x, Connection schema1))
148+ -> PQ schema0 schema1 io x
148149 -> io x
149150withConnection connString action = do
150− (x, _conn) <- bracket (connectdb connString) finish action
151+ K x <- bracket (connectdb connString) finish (unPQ action)
151152 return x
152153
154+-- | Safely `lowerConnection` to a smaller schema.
155+lowerConnection
156+ :: K LibPQ.Connection (table ': schema)
157+ -> K LibPQ.Connection schema
158+lowerConnection (K conn) = K conn
159+
153160-- | We keep track of the schema via an Atkey indexed state monad transformer,
154161-- `PQ`.
155162newtype PQ
@@ -157,67 +164,113 @@ newtype PQ
157164 (schema1 :: TablesType)
158165 (m :: Type -> Type)
159166 (x :: Type) =
160− PQ { runPQ :: Connection schema0 -> m (x, Connection schema1) }
161− deriving Functor
167+ PQ { unPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }
162168
163−-- | Run a `PQ` and discard the result but keep the `Connection`.
169+instance Monad m => Functor (PQ schema0 schema1 m) where
170+ fmap f (PQ pq) = PQ $ \ conn -> do
171+ K x <- pq conn
172+ return $ K (f x)
173+
174+-- | Run a `PQ` and keep the result and the `Connection`.
175+runPQ
176+ :: Functor m
177+ => PQ schema0 schema1 m x
178+ -> K LibPQ.Connection schema0
179+ -> m (x, K LibPQ.Connection schema1)
180+runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn
181+ -- K x <- pq conn
182+ -- return (x, K (unK conn))
183+
184+-- | Execute a `PQ` and discard the result but keep the `Connection`.
164185execPQ
165186 :: Functor m
166187 => PQ schema0 schema1 m x
167− -> Connection schema0
168− -> m (Connection schema1)
169−execPQ (PQ pq) = fmap snd . pq
170−
171−-- | indexed analog of `<*>`
172−pqAp
173− :: Monad m
174− => PQ schema0 schema1 m (x -> y)
175− -> PQ schema1 schema2 m x
176− -> PQ schema0 schema2 m y
177−pqAp (PQ f) (PQ x) = PQ $ \ conn -> do
178− (f', conn') <- f conn
179− (x', conn'') <- x conn'
180− return (f' x', conn'')
181−
182−-- | indexed analog of `=<<`
183−pqBind
184− :: Monad m
185− => (x -> PQ schema1 schema2 m y)
186− -> PQ schema0 schema1 m x
187− -> PQ schema0 schema2 m y
188−pqBind f (PQ x) = PQ $ \ conn -> do
189− (x', conn') <- x conn
190− runPQ (f x') conn'
191−
192−-- | indexed analog of flipped `>>`
193−pqThen
194− :: Monad m
195− => PQ schema1 schema2 m y
196− -> PQ schema0 schema1 m x
197− -> PQ schema0 schema2 m y
198−pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
199−
200−-- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law
201−--
202−-- @define statement1 & thenDefine statement2 = define (statement1 >>> statement2)@
203−define
204− :: MonadBase IO io
205− => Definition schema0 schema1
206− -> PQ schema0 schema1 io (Result '[])
207−define (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do
208− resultMaybe <- liftBase $ LibPQ.exec conn q
209− case resultMaybe of
210− Nothing -> error
211− "define: LibPQ.exec returned no results"
212− Just result -> return (Result result, Connection conn)
213−
214−-- | Chain together `define` actions.
215−thenDefine
216− :: MonadBase IO io
217− => Definition schema1 schema2
218− -> PQ schema0 schema1 io x
219− -> PQ schema0 schema2 io (Result '[])
220−thenDefine = pqThen . define
188+ -> K LibPQ.Connection schema0
189+ -> m (K LibPQ.Connection schema1)
190+execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn
191+
192+-- | Evaluate a `PQ` and discard the `Connection` but keep the result.
193+evalPQ
194+ :: Functor m
195+ => PQ schema0 schema1 m x
196+ -> K LibPQ.Connection schema0
197+ -> m x
198+evalPQ (PQ pq) conn = unK <$> pq conn
199+
200+-- | An [Atkey indexed monad](https://bentnib.org/paramnotions-jfp.pdf) is a `Functor`
201+-- [enriched category](https://ncatlab.org/nlab/show/enriched+category).
202+-- An indexed monad transformer transforms a `Monad` into an indexed monad.
203+-- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that
204+-- support running `Definition`s using `define` and embedding a computation
205+-- in a larger schema using `pqEmbed`.
206+class IndexedMonadTransPQ pq where
207+
208+ -- | indexed analog of `<*>`
209+ pqAp
210+ :: Monad m
211+ => pq schema0 schema1 m (x -> y)
212+ -> pq schema1 schema2 m x
213+ -> pq schema0 schema2 m y
214+
215+ -- | indexed analog of `join`
216+ pqJoin
217+ :: Monad m
218+ => pq schema0 schema1 m (pq schema1 schema2 m y)
219+ -> pq schema0 schema2 m y
220+
221+ -- | indexed analog of `=<<`
222+ pqBind
223+ :: Monad m
224+ => (x -> pq schema1 schema2 m y)
225+ -> pq schema0 schema1 m x
226+ -> pq schema0 schema2 m y
227+
228+ -- | indexed analog of flipped `>>`
229+ pqThen
230+ :: Monad m
231+ => pq schema1 schema2 m y
232+ -> pq schema0 schema1 m x
233+ -> pq schema0 schema2 m y
234+
235+ -- | Safely embed a computation in a larger schema.
236+ pqEmbed
237+ :: Monad m
238+ => pq schema0 schema1 m x
239+ -> pq (table ': schema0) (table : schema1) m x
240+
241+ -- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law
242+ --
243+ -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@
244+ define
245+ :: MonadBase IO io
246+ => Definition schema0 schema1
247+ -> pq schema0 schema1 io (K LibPQ.Result '[])
248+
249+instance IndexedMonadTransPQ PQ where
250+
251+ pqAp (PQ f) (PQ x) = PQ $ \ conn -> do
252+ K f' <- f conn
253+ K x' <- x (K (unK conn))
254+ return $ K (f' x')
255+
256+ pqJoin pq = pq & pqBind id
257+
258+ pqBind f (PQ x) = PQ $ \ conn -> do
259+ K x' <- x conn
260+ unPQ (f x') (K (unK conn))
261+
262+ pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
263+
264+ pqEmbed (PQ pq) = PQ $ \ (K conn) -> do
265+ K x <- pq (K conn)
266+ return $ K x
267+
268+ define (UnsafeDefinition q) = PQ $ \ (K conn) -> do
269+ resultMaybe <- liftBase $ LibPQ.exec conn q
270+ case resultMaybe of
271+ Nothing -> error
272+ "define: LibPQ.exec returned no results"
273+ Just result -> return $ K (K result)
221274
222275{- | `MonadPQ` is an `mtl` style constraint, similar to
223276`Control.Monad.State.Class.MonadState`, for using `LibPQ` to
@@ -230,6 +283,8 @@ thenDefine = pqThen . define
230283
231284* `runQueryParams` is like `manipulateParams` for query statements.
232285
286+* `runQuery` is like `runQueryParams` for a parameter-free statement.
287+
233288* `traversePrepared` has the same type signature as a composition of
234289 `traverse` and `manipulateParams` but provides an optimization by
235290 preparing the statement with `LibPQ.prepare` and then traversing a
@@ -255,42 +310,42 @@ class Monad pq => MonadPQ schema pq | pq -> schema where
255310 manipulateParams
256311 :: ToParams x params
257312 => Manipulation schema params ys
258− -- ^ `insertInto`, `update` or `deleteFrom`
259− -> x -> pq (Result ys)
313+ -- ^ `insertRows`, `update` or `deleteFrom`
314+ -> x -> pq (K LibPQ.Result ys)
260315 default manipulateParams
261316 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
262317 => ToParams x params
263318 => Manipulation schema params ys
264− -- ^ `insertInto`, `update` or `deleteFrom`
265− -> x -> pq (Result ys)
319+ -- ^ `insertRows`, `update` or `deleteFrom`
320+ -> x -> pq (K LibPQ.Result ys)
266321 manipulateParams manipulation params = lift $
267322 manipulateParams manipulation params
268323
269− manipulate :: Manipulation schema '[] ys -> pq (Result ys)
324+ manipulate :: Manipulation schema '[] ys -> pq (K LibPQ.Result ys)
270325 manipulate statement = manipulateParams statement ()
271326
272327 runQueryParams
273328 :: ToParams x params
274329 => Query schema params ys
275330 -- ^ `select` and friends
276− -> x -> pq (Result ys)
331+ -> x -> pq (K LibPQ.Result ys)
277332 runQueryParams = manipulateParams . queryStatement
278333
279334 runQuery
280335 :: Query schema '[] ys
281336 -- ^ `select` and friends
282− -> pq (Result ys)
337+ -> pq (K LibPQ.Result ys)
283338 runQuery q = runQueryParams q ()
284339
285340 traversePrepared
286341 :: (ToParams x params, Traversable list)
287342 => Manipulation schema params ys
288− -- ^ `insertInto`, `update` or `deleteFrom`
289− -> list x -> pq (list (Result ys))
343+ -- ^ `insertRows`, `update`, or `deleteFrom`, and friends
344+ -> list x -> pq (list (K LibPQ.Result ys))
290345 default traversePrepared
291346 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
292347 => (ToParams x params, Traversable list)
293− => Manipulation schema params ys -> list x -> pq (list (Result ys))
348+ => Manipulation schema params ys -> list x -> pq (list (K LibPQ.Result ys))
294349 traversePrepared manipulation params = lift $
295350 traversePrepared manipulation params
296351
@@ -298,20 +353,20 @@ class Monad pq => MonadPQ schema pq | pq -> schema where
298353 :: (ToParams x params, Traversable list)
299354 => list x
300355 -> Manipulation schema params ys
301− -- ^ `insertInto`, `update` or `deleteFrom`
302− -> pq (list (Result ys))
356+ -- ^ `insertRows`, `update` or `deleteFrom`
357+ -> pq (list (K LibPQ.Result ys))
303358 forPrepared = flip traversePrepared
304359
305360 traversePrepared_
306361 :: (ToParams x params, Foldable list)
307362 => Manipulation schema params '[]
308− -- ^ `insertInto`, `update` or `deleteFrom`
363+ -- ^ `insertRows`, `update` or `deleteFrom`
309364 -> list x -> pq ()
310365 default traversePrepared_
311366 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)
312367 => (ToParams x params, Foldable list)
313368 => Manipulation schema params '[]
314− -- ^ `insertInto`, `update` or `deleteFrom`
369+ -- ^ `insertRows`, `update` or `deleteFrom`
315370 -> list x -> pq ()
316371 traversePrepared_ manipulation params = lift $
317372 traversePrepared_ manipulation params
@@ -320,7 +375,7 @@ class Monad pq => MonadPQ schema pq | pq -> schema where
320375 :: (ToParams x params, Foldable list)
321376 => list x
322377 -> Manipulation schema params '[]
323− -- ^ `insertInto`, `update` or `deleteFrom`
378+ -- ^ `insertRows`, `update` or `deleteFrom`
324379 -> pq ()
325380 forPrepared_ = flip traversePrepared_
326381
@@ -330,11 +385,12 @@ class Monad pq => MonadPQ schema pq | pq -> schema where
330385 => (LibPQ.Connection -> IO a) -> pq a
331386 liftPQ = lift . liftPQ
332387
333−instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
388+instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)
389+ => MonadPQ schema (PQ schema0 schema1 io) where
334390
335391 manipulateParams
336392 (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =
337− PQ $ \ (Connection conn) -> do
393+ PQ $ \ (K conn) -> do
338394 let
339395 toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)
340396 params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))
@@ -342,11 +398,11 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
342398 case resultMaybe of
343399 Nothing -> error
344400 "manipulateParams: LibPQ.execParams returned no results"
345− Just result -> return (Result result, Connection conn)
401+ Just result -> return $ K (K result)
346402
347403 traversePrepared
348404 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =
349− PQ $ \ (Connection conn) -> liftBase $ do
405+ PQ $ \ (K conn) -> liftBase $ do
350406 let temp = "temporary_statement"
351407 prepResultMaybe <- LibPQ.prepare conn temp q Nothing
352408 case prepResultMaybe of
@@ -364,7 +420,7 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
364420 case resultMaybe of
365421 Nothing -> error
366422 "traversePrepared: LibPQ.execParams returned no results"
367− Just result -> return $ Result result
423+ Just result -> return $ K result
368424 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
369425 case deallocResultMaybe of
370426 Nothing -> error
@@ -373,11 +429,11 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
373429 status <- LibPQ.resultStatus deallocResult
374430 unless (status == LibPQ.CommandOk) . error $
375431 "traversePrepared: DEALLOCATE status " <> show status
376− return (results, Connection conn)
432+ return (K results)
377433
378434 traversePrepared_
379435 (UnsafeManipulation q :: Manipulation schema xs '[]) (list :: list x) =
380− PQ $ \ (Connection conn) -> liftBase $ do
436+ PQ $ \ (K conn) -> liftBase $ do
381437 let temp = "temporary_statement"
382438 prepResultMaybe <- LibPQ.prepare conn temp q Nothing
383439 case prepResultMaybe of
@@ -404,11 +460,11 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where
404460 status <- LibPQ.resultStatus deallocResult
405461 unless (status == LibPQ.CommandOk) . error $
406462 "traversePrepared: DEALLOCATE status " <> show status
407− return ((), Connection conn)
463+ return (K ())
408464
409− liftPQ pq = PQ $ \ (Connection conn) -> do
465+ liftPQ pq = PQ $ \ (K conn) -> do
410466 y <- liftBase $ pq conn
411− return (y, Connection conn)
467+ return (K y)
412468
413469instance MonadPQ schema m => MonadPQ schema (IdentityT m)
414470instance MonadPQ schema m => MonadPQ schema (ReaderT r m)
@@ -423,91 +479,58 @@ instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Lazy.RWST r w s m)
423479instance MonadPQ schema m => MonadPQ schema (ContT r m)
424480instance MonadPQ schema m => MonadPQ schema (ListT m)
425481
426−instance Monad m => Applicative (PQ schema schema m) where
427− pure x = PQ $ \ conn -> pure (x, conn)
482+instance (Monad m, schema0 ~ schema1)
483+ => Applicative (PQ schema0 schema1 m) where
484+ pure x = PQ $ \ _conn -> pure (K x)
428485 (<*>) = pqAp
429486
430−instance Monad m => Monad (PQ schema schema m) where
487+instance (Monad m, schema0 ~ schema1)
488+ => Monad (PQ schema0 schema1 m) where
431489 return = pure
432490 (>>=) = flip pqBind
433491
434−instance MonadTrans (PQ schema schema) where
435− lift m = PQ $ \ conn -> do
492+instance schema0 ~ schema1 => MFunctor (PQ schema0 schema1) where
493+ hoist f (PQ pq) = PQ (f . pq)
494+
495+instance schema0 ~ schema1 => MonadTrans (PQ schema0 schema1) where
496+ lift m = PQ $ \ _conn -> do
436497 x <- m
437− return (x, conn)
498+ return (K x)
438499
439−instance MonadBase b m => MonadBase b (PQ schema schema m) where
500+instance schema0 ~ schema1 => MMonad (PQ schema0 schema1) where
501+ embed f (PQ pq) = PQ $ \ conn -> do
502+ evalPQ (f (pq conn)) conn
503+
504+instance (MonadBase b m, schema0 ~ schema1)
505+ => MonadBase b (PQ schema0 schema1 m) where
440506 liftBase = lift . liftBase
441507
442508-- | A snapshot of the state of a `PQ` computation.
443509type PQRun schema =
444− forall m x. Monad m => PQ schema schema m x -> m (x, Connection schema)
510+ forall m x. Monad m => PQ schema schema m x -> m (K x schema)
445511
446512-- | Helper function in defining `MonadBaseControl` instance for `PQ`.
447513pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a
448514pqliftWith f = PQ $ \ conn ->
449− fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)
515+ fmap K (f $ \ pq -> unPQ pq conn)
450516
451−instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where
452− type StM (PQ schema schema m) x = StM m (x, Connection schema)
517+instance (MonadBaseControl b m, schema0 ~ schema1)
518+ => MonadBaseControl b (PQ schema0 schema1 m) where
519+ type StM (PQ schema0 schema1 m) x = StM m (K x schema0)
453520 liftBaseWith f =
454521 pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
455522 restoreM = PQ . const . restoreM
456523
457−-- | Encapsulates the result of a squeal command run by @LibPQ@.
458−-- `Result`s are parameterized by a `ColumnsType` describing the column names
459−-- and their types.
460−newtype Result (columns :: ColumnsType)
461− = Result { unResult :: LibPQ.Result }
462−
463−-- | Just newtypes around a `CInt`
464−newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }
465−
466−-- | In addition to being newtypes around a `CInt`, a `ColumnNumber` is
467−-- parameterized by a `Nat`ural number and acts as an index into a row.
468−newtype ColumnNumber (n :: Nat) (cs :: [k]) (c :: k) =
469− UnsafeColumnNumber { getColumnNumber :: LibPQ.Column }
470−
471−-- | >>> getColumnNumber (columnNumber @5 @'[_,_,_,_,_,_])
472−-- Col 5
473−class KnownNat n => HasColumnNumber n columns column
474− | n columns -> column where
475− columnNumber :: ColumnNumber n columns column
476− columnNumber =
477− UnsafeColumnNumber . fromIntegral $ natVal' (proxy# :: Proxy# n)
478−instance {-# OVERLAPPING #-} HasColumnNumber 0 (column1:columns) column1
479−instance {-# OVERLAPPABLE #-}
480− (KnownNat n, HasColumnNumber (n-1) columns column)
481− => HasColumnNumber n (column' : columns) column
482−
483−-- | Get a single value corresponding to a given row and column number
484−-- from a `Result`.
485−getValue
486− :: (FromColumnValue colty y, MonadBase IO io)
487− => RowNumber -- ^ row
488− -> ColumnNumber n columns colty -- ^ col
489− -> Result columns -- ^ result
490− -> io y
491−getValue
492− (RowNumber r)
493− (UnsafeColumnNumber c :: ColumnNumber n columns colty)
494− (Result result)
495− = fmap (fromColumnValue @colty . K) $ liftBase $ do
496− numRows <- LibPQ.ntuples result
497− when (numRows < r) $ error $
498− "getValue: expected at least " <> show r <> "rows but only saw "
499− <> show numRows
500− LibPQ.getvalue result r c
501−
502−-- | Get a row corresponding to a given row number from a `Result`.
524+-- | Get a row corresponding to a given row number from a `LibPQ.Result`,
525+-- throwing an exception if the row number is out of bounds.
503526getRow
504527 :: (FromRow columns y, MonadBase IO io)
505− => RowNumber
506− -- ^ row
507− -> Result columns
528+ => LibPQ.Row
529+ -- ^ row number
530+ -> K LibPQ.Result columns
508531 -- ^ result
509532 -> io y
510−getRow (RowNumber r) (Result result :: Result columns) = liftBase $ do
533+getRow r (K result :: K LibPQ.Result columns) = liftBase $ do
511534 numRows <- LibPQ.ntuples result
512535 when (numRows < r) $ error $
513536 "getRow: expected at least " <> show r <> "rows but only saw "
@@ -518,34 +541,30 @@ getRow (RowNumber r) (Result result :: Result columns) = liftBase $ do
518541 Nothing -> error "getRow: found unexpected length"
519542 Just row -> return $ fromRow @columns row
520543
521−-- | Returns the number of rows (tuples) in the query result.
522−ntuples :: MonadBase IO io => Result columns -> io RowNumber
523−ntuples (Result result) = liftBase $ RowNumber <$> LibPQ.ntuples result
524−
525544-- | Intended to be used for unfolding in streaming libraries, `nextRow`
526545-- takes a total number of rows (which can be found with `ntuples`)
527−-- and a `Result` and given a row number if it's too large returns `Nothing`,
546+-- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`,
528547-- otherwise returning the row along with the next row number.
529548nextRow
530549 :: (FromRow columns y, MonadBase IO io)
531− => RowNumber -- ^ total number of rows
532− -> Result columns -- ^ result
533− -> RowNumber -- ^ row number
534− -> io (Maybe (RowNumber,y))
535−nextRow (RowNumber total) (Result result :: Result columns) (RowNumber r)
550+ => LibPQ.Row -- ^ total number of rows
551+ -> K LibPQ.Result columns -- ^ result
552+ -> LibPQ.Row -- ^ row number
553+ -> io (Maybe (LibPQ.Row,y))
554+nextRow total (K result :: K LibPQ.Result columns) r
536555 = liftBase $ if r >= total then return Nothing else do
537556 let len = fromIntegral (lengthSList (Proxy @columns))
538557 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
539558 case fromList row' of
540559 Nothing -> error "nextRow: found unexpected length"
541− Just row -> return $ Just (RowNumber (r+1), fromRow @columns row)
560+ Just row -> return $ Just (r+1, fromRow @columns row)
542561
543−-- | Get all rows from a `Result`.
562+-- | Get all rows from a `LibPQ.Result`.
544563getRows
545564 :: (FromRow columns y, MonadBase IO io)
546− => Result columns -- ^ result
565+ => K LibPQ.Result columns -- ^ result
547566 -> io [y]
548−getRows (Result result :: Result columns) = liftBase $ do
567+getRows (K result :: K LibPQ.Result columns) = liftBase $ do
549568 let len = fromIntegral (lengthSList (Proxy @columns))
550569 numRows <- LibPQ.ntuples result
551570 for [0 .. numRows - 1] $ \ r -> do
@@ -554,12 +573,12 @@ getRows (Result result :: Result columns) = liftBase $ do
554573 Nothing -> error "getRows: found unexpected length"
555574 Just row -> return $ fromRow @columns row
556575
557−-- | Get the first row if possible from a `Result`.
576+-- | Get the first row if possible from a `LibPQ.Result`.
558577firstRow
559578 :: (FromRow columns y, MonadBase IO io)
560− => Result columns -- ^ result
579+ => K LibPQ.Result columns -- ^ result
561580 -> io (Maybe y)
562−firstRow (Result result :: Result columns) = liftBase $ do
581+firstRow (K result :: K LibPQ.Result columns) = liftBase $ do
563582 numRows <- LibPQ.ntuples result
564583 if numRows <= 0 then return Nothing else do
565584 let len = fromIntegral (lengthSList (Proxy @columns))
@@ -568,9 +587,23 @@ firstRow (Result result :: Result columns) = liftBase $ do
568587 Nothing -> error "firstRow: found unexpected length"
569588 Just row -> return . Just $ fromRow @columns row
570589
571−-- | Lifts actions on results from `LibPQ`.
590+-- | Lifts actions on results from @LibPQ@.
572591liftResult
573592 :: MonadBase IO io
574593 => (LibPQ.Result -> IO x)
575− -> Result results -> io x
576−liftResult f (Result result) = liftBase $ f result
594+ -> K LibPQ.Result results -> io x
595+liftResult f (K result) = liftBase $ f result
596+
597+-- | Returns the number of rows (tuples) in the query result.
598+ntuples :: MonadBase IO io => K LibPQ.Result columns -> io LibPQ.Row
599+ntuples = liftResult LibPQ.ntuples
600+
601+-- | Returns the result status of the command.
602+resultStatus :: MonadBase IO io => K LibPQ.Result results -> io LibPQ.ExecStatus
603+resultStatus = liftResult LibPQ.resultStatus
604+
605+-- | Returns the error message most recently generated by an operation
606+-- on the connection.
607+resultErrorMessage
608+ :: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)
609+resultErrorMessage = liftResult LibPQ.resultErrorMessage
squeal-postgresql/src/Squeal/PostgreSQL/Pool.hsnew file+133
@@ -0,0 +1,133 @@
1+{-|
2+Module: Squeal.PostgreSQL.Definition
3+Description: Pooled connections
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+A `MonadPQ` for pooled connections.
9+-}
10+
11+{-# LANGUAGE
12+ DataKinds
13+ , DeriveFunctor
14+ , FlexibleContexts
15+ , FlexibleInstances
16+ , MultiParamTypeClasses
17+ , RankNTypes
18+ , ScopedTypeVariables
19+ , TypeFamilies
20+ , TypeInType
21+ , UndecidableInstances
22+#-}
23+
24+module Squeal.PostgreSQL.Pool
25+ ( -- * Pools
26+ PoolPQ (..)
27+ , createConnectionPool
28+ , Pool
29+ , destroyAllResources
30+ , PoolPQRun
31+ , poolpqliftWith
32+ ) where
33+
34+import Control.Monad.Base
35+import Control.Monad.Trans
36+import Control.Monad.Trans.Control
37+import Data.ByteString
38+import Data.Pool
39+import Data.Time
40+import Generics.SOP (K(..))
41+
42+import Squeal.PostgreSQL.PQ
43+import Squeal.PostgreSQL.Schema
44+
45+-- | `PoolPQ` @schema@ should be a drop-in replacement for `PQ` @schema schema@.
46+newtype PoolPQ (schema :: TablesType) m x =
47+ PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x }
48+ deriving Functor
49+
50+-- | Create a striped pool of connections.
51+-- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyAllResources` when you're done with the pool so that the connections are freed up as soon as possible.
52+createConnectionPool
53+ :: MonadBase IO io
54+ => ByteString
55+ -- ^ The passed string can be empty to use all default parameters, or it can
56+ -- contain one or more parameter settings separated by whitespace.
57+ -- Each parameter setting is in the form keyword = value. Spaces around the equal
58+ -- sign are optional. To write an empty value or a value containing spaces,
59+ -- surround it with single quotes, e.g., keyword = 'a value'. Single quotes and
60+ -- backslashes within the value must be escaped with a backslash, i.e., ' and \.
61+ -> Int
62+ -- ^ The number of stripes (distinct sub-pools) to maintain. The smallest acceptable value is 1.
63+ -> NominalDiffTime
64+ -- ^ Amount of time for which an unused connection is kept open. The smallest acceptable value is 0.5 seconds.
65+ -- The elapsed time before destroying a connection may be a little longer than requested, as the reaper thread wakes at 1-second intervals.
66+ -> Int
67+ -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1.
68+ -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.
69+ -> io (Pool (K Connection schema))
70+createConnectionPool conninfo stripes idle maxResrc = liftBase $
71+ createPool (connectdb conninfo) finish stripes idle maxResrc
72+
73+-- | `Applicative` instance for `PoolPQ`.
74+instance Monad m => Applicative (PoolPQ schema m) where
75+ pure x = PoolPQ $ \ _ -> pure x
76+ PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do
77+ f' <- f pool
78+ x' <- x pool
79+ return $ f' x'
80+
81+-- | `Monad` instance for `PoolPQ`.
82+instance Monad m => Monad (PoolPQ schema m) where
83+ return = pure
84+ PoolPQ x >>= f = PoolPQ $ \ pool -> do
85+ x' <- x pool
86+ runPoolPQ (f x') pool
87+
88+-- | `MonadTrans` instance for `PoolPQ`.
89+instance MonadTrans (PoolPQ schema) where
90+ lift m = PoolPQ $ \ _pool -> m
91+
92+-- | `MonadBase` instance for `PoolPQ`.
93+instance MonadBase b m => MonadBase b (PoolPQ schema m) where
94+ liftBase = lift . liftBase
95+
96+-- | `MonadPQ` instance for `PoolPQ`.
97+instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where
98+ manipulateParams manipulation params = PoolPQ $ \ pool -> do
99+ withResource pool $ \ conn -> do
100+ (K result :: K (K Result ys) schema) <- flip unPQ conn $
101+ manipulateParams manipulation params
102+ return result
103+ traversePrepared manipulation params = PoolPQ $ \ pool ->
104+ withResource pool $ \ conn -> do
105+ (K result :: K (list (K Result ys)) schema) <- flip unPQ conn $
106+ traversePrepared manipulation params
107+ return result
108+ traversePrepared_ manipulation params = PoolPQ $ \ pool -> do
109+ withResource pool $ \ conn -> do
110+ (_ :: K () schema) <- flip unPQ conn $
111+ traversePrepared_ manipulation params
112+ return ()
113+ liftPQ m = PoolPQ $ \ pool ->
114+ withResource pool $ \ conn -> do
115+ (K result :: K result schema) <- flip unPQ conn $
116+ liftPQ m
117+ return result
118+
119+-- | A snapshot of the state of a `PoolPQ` computation.
120+type PoolPQRun schema =
121+ forall m x. Monad m => PoolPQ schema m x -> m x
122+
123+-- | Helper function in defining `MonadBaseControl` instance for `PoolPQ`.
124+poolpqliftWith :: Functor m => (PoolPQRun schema -> m a) -> PoolPQ schema m a
125+poolpqliftWith f = PoolPQ $ \ pool ->
126+ (f $ \ pq -> runPoolPQ pq pool)
127+
128+-- | `MonadBaseControl` instance for `PoolPQ`.
129+instance MonadBaseControl b m => MonadBaseControl b (PoolPQ schema m) where
130+ type StM (PoolPQ schema m) x = StM m x
131+ liftBaseWith f =
132+ poolpqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run
133+ restoreM = PoolPQ . const . restoreM
squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+287−248
@@ -12,6 +12,7 @@ Squeal queries.
1212 DataKinds
1313 , DeriveDataTypeable
1414 , DeriveGeneric
15+ , FlexibleContexts
1516 , FlexibleInstances
1617 , GADTs
1718 , GeneralizedNewtypeDeriving
@@ -55,7 +56,13 @@ module Squeal.PostgreSQL.Query
5556 , offset
5657 -- * From
5758 , FromClause (..)
58− , renderFromClause
59+ , table
60+ , subquery
61+ , crossJoin
62+ , innerJoin
63+ , leftOuterJoin
64+ , rightOuterJoin
65+ , fullOuterJoin
5966 -- * Grouping
6067 , By (By, By2)
6168 , renderBy
@@ -70,7 +77,7 @@ module Squeal.PostgreSQL.Query
7077
7178import Control.DeepSeq
7279import Data.ByteString (ByteString)
73−import Data.Monoid
80+import Data.Monoid hiding (All)
7481import Data.String
7582import Data.Word
7683import Generics.SOP hiding (from)
@@ -79,7 +86,7 @@ import GHC.TypeLits
7986import qualified GHC.Generics as GHC
8087
8188import Squeal.PostgreSQL.Expression
82−import Squeal.PostgreSQL.Prettyprint
89+import Squeal.PostgreSQL.Render
8390import Squeal.PostgreSQL.Schema
8491
8592{- |
@@ -92,9 +99,11 @@ simple query:
9299
93100>>> :{
94101let
95− query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]
96− '["col" ::: 'Required ('Null 'PGint4)]
97− query = selectStar (from (Table (#tab `As` #t)))
102+ query :: Query
103+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
104+ '[]
105+ '["col" ::: 'Null 'PGint4]
106+ query = selectStar (from (table (#tab `As` #t)))
98107in renderQuery query
99108:}
100109"SELECT * FROM tab AS t"
@@ -104,16 +113,16 @@ restricted query:
104113>>> :{
105114let
106115 query :: Query
107− '[ "tab" :::
108− '[ "col1" ::: 'Required ('NotNull 'PGint4)
109− , "col2" ::: 'Required ('NotNull 'PGint4) ]]
116+ '[ "tab" ::: '[] :=>
117+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
118+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]
110119 '[]
111− '[ "sum" ::: 'Required ('NotNull 'PGint4)
112− , "col1" ::: 'Required ('NotNull 'PGint4) ]
120+ '[ "sum" ::: 'NotNull 'PGint4
121+ , "col1" ::: 'NotNull 'PGint4 ]
113122 query =
114123 select
115124 ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
116− ( from (Table (#tab `As` #t))
125+ ( from (table (#tab `As` #t))
117126 & where_ (#col1 .> #col2)
118127 & where_ (#col2 .> 0) )
119128in renderQuery query
@@ -124,11 +133,13 @@ subquery:
124133
125134>>> :{
126135let
127− query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]
128− '["col" ::: 'Required ('Null 'PGint4)]
136+ query :: Query
137+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
138+ '[]
139+ '["col" ::: 'Null 'PGint4]
129140 query =
130141 selectStar
131− (from (Subquery (selectStar (from (Table (#tab `As` #t))) `As` #sub)))
142+ (from (subquery (selectStar (from (table (#tab `As` #t))) `As` #sub)))
132143in renderQuery query
133144:}
134145"SELECT * FROM (SELECT * FROM tab AS t) AS sub"
@@ -137,10 +148,12 @@ limits and offsets:
137148
138149>>> :{
139150let
140− query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]
141− '["col" ::: 'Required ('Null 'PGint4)]
151+ query :: Query
152+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
153+ '[]
154+ '["col" ::: 'Null 'PGint4]
142155 query = selectStar
143− (from (Table (#tab `As` #t)) & limit 100 & offset 2 & limit 50 & offset 2)
156+ (from (table (#tab `As` #t)) & limit 100 & offset 2 & limit 50 & offset 2)
144157in renderQuery query
145158:}
146159"SELECT * FROM tab AS t LIMIT 50 OFFSET 4"
@@ -149,11 +162,12 @@ parameterized query:
149162
150163>>> :{
151164let
152− query :: Query '["tab" ::: '["col" ::: 'Required ('NotNull 'PGfloat8)]]
153− '[ 'Required ('NotNull 'PGfloat8)]
154− '["col" ::: 'Required ('NotNull 'PGfloat8)]
165+ query :: Query
166+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8]]
167+ '[ 'NotNull 'PGfloat8]
168+ '["col" ::: 'NotNull 'PGfloat8]
155169 query = selectStar
156− (from (Table (#tab `As` #t)) & where_ (#col .> param @1))
170+ (from (table (#tab `As` #t)) & where_ (#col .> param @1))
157171in renderQuery query
158172:}
159173"SELECT * FROM tab AS t WHERE (col > ($1 :: float8))"
@@ -163,15 +177,15 @@ aggregation query:
163177>>> :{
164178let
165179 query :: Query
166− '[ "tab" :::
167− '[ "col1" ::: 'Required ('NotNull 'PGint4)
168− , "col2" ::: 'Required ('NotNull 'PGint4) ]]
180+ '[ "tab" ::: '[] :=>
181+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
182+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]
169183 '[]
170− '[ "sum" ::: 'Required ('NotNull 'PGint4)
171− , "col1" ::: 'Required ('NotNull 'PGint4) ]
184+ '[ "sum" ::: 'NotNull 'PGint4
185+ , "col1" ::: 'NotNull 'PGint4 ]
172186 query =
173187 select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil)
174− ( from (Table (#tab `As` #table1))
188+ ( from (table (#tab `As` #table1))
175189 & group (By #col1 :* Nil)
176190 & having (#col1 + sum_ #col2 .> 1) )
177191in renderQuery query
@@ -182,10 +196,12 @@ sorted query:
182196
183197>>> :{
184198let
185− query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]
186− '["col" ::: 'Required ('Null 'PGint4)]
199+ query :: Query
200+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
201+ '[]
202+ '["col" ::: 'Null 'PGint4]
187203 query = selectStar
188− (from (Table (#tab `As` #t)) & orderBy [#col & AscNullsFirst])
204+ (from (table (#tab `As` #t)) & orderBy [#col & AscNullsFirst])
189205in renderQuery query
190206:}
191207"SELECT * FROM tab AS t ORDER BY col ASC NULLS FIRST"
@@ -197,33 +213,38 @@ joins:
197213let
198214 query :: Query
199215 '[ "orders" :::
200− '[ "id" ::: 'Required ('NotNull 'PGint4)
201− , "price" ::: 'Required ('NotNull 'PGfloat4)
202− , "customer_id" ::: 'Required ('NotNull 'PGint4)
203− , "shipper_id" ::: 'Required ('NotNull 'PGint4)
216+ '["pk_orders" ::: PrimaryKey '["id"]
217+ ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]
218+ ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"]] :=>
219+ '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
220+ , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
221+ , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
222+ , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4
204223 ]
205224 , "customers" :::
206− '[ "id" ::: 'Required ('NotNull 'PGint4)
207− , "name" ::: 'Required ('NotNull 'PGtext)
225+ '["pk_customers" ::: PrimaryKey '["id"]] :=>
226+ '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
227+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
208228 ]
209229 , "shippers" :::
210− '[ "id" ::: 'Required ('NotNull 'PGint4)
211− , "name" ::: 'Required ('NotNull 'PGtext)
230+ '["pk_shippers" ::: PrimaryKey '["id"]] :=>
231+ '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
232+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext
212233 ]
213234 ]
214235 '[]
215− '[ "order_price" ::: 'Required ('NotNull 'PGfloat4)
216− , "customer_name" ::: 'Required ('NotNull 'PGtext)
217− , "shipper_name" ::: 'Required ('NotNull 'PGtext)
236+ '[ "order_price" ::: 'NotNull 'PGfloat4
237+ , "customer_name" ::: 'NotNull 'PGtext
238+ , "shipper_name" ::: 'NotNull 'PGtext
218239 ]
219240 query = select
220241 ( #o ! #price `As` #order_price :*
221242 #c ! #name `As` #customer_name :*
222243 #s ! #name `As` #shipper_name :* Nil )
223− ( from (Table (#orders `As` #o)
224− & InnerJoin (Table (#customers `As` #c))
244+ ( from (table (#orders `As` #o)
245+ & innerJoin (table (#customers `As` #c))
225246 (#o ! #customer_id .== #c ! #id)
226− & InnerJoin (Table (#shippers `As` #s))
247+ & innerJoin (table (#shippers `As` #s))
227248 (#o ! #shipper_id .== #s ! #id)) )
228249in renderQuery query
229250:}
@@ -233,10 +254,12 @@ self-join:
233254
234255>>> :{
235256let
236− query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]
237− '["col" ::: 'Required ('Null 'PGint4)]
257+ query :: Query
258+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
259+ '[]
260+ '["col" ::: 'Null 'PGint4]
238261 query = selectDotStar #t1
239− (from (Table (#tab `As` #t1) & CrossJoin (Table (#tab `As` #t2))))
262+ (from (table (#tab `As` #t1) & crossJoin (table (#tab `As` #t2))))
240263in renderQuery query
241264:}
242265"SELECT t1.* FROM tab AS t1 CROSS JOIN tab AS t2"
@@ -245,21 +268,22 @@ set operations:
245268
246269>>> :{
247270let
248− query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]
249− '["col" ::: 'Required ('Null 'PGint4)]
271+ query :: Query
272+ '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]
273+ '[]
274+ '["col" ::: 'Null 'PGint4]
250275 query =
251− selectStar (from (Table (#tab `As` #t)))
276+ selectStar (from (table (#tab `As` #t)))
252277 `unionAll`
253− selectStar (from (Table (#tab `As` #t)))
278+ selectStar (from (table (#tab `As` #t)))
254279in renderQuery query
255280:}
256281"(SELECT * FROM tab AS t) UNION ALL (SELECT * FROM tab AS t)"
257282-}
258−
259283newtype Query
260284 (schema :: TablesType)
261− (params :: [ColumnType])
262− (columns :: ColumnsType)
285+ (params :: [NullityType])
286+ (columns :: RelationType)
263287 = UnsafeQuery { renderQuery :: ByteString }
264288 deriving (GHC.Generic,Show,Eq,Ord,NFData)
265289
@@ -340,73 +364,73 @@ SELECT queries
340364-- the intermediate table are actually output.
341365select
342366 :: SListI columns
343− => NP (Aliased (Expression tables grouping params)) (column ': columns)
367+ => NP (Aliased (Expression relations grouping params)) (column ': columns)
344368 -- ^ select list
345− -> TableExpression schema params tables grouping
369+ -> TableExpression schema params relations grouping
346370 -- ^ intermediate virtual table
347371 -> Query schema params (column ': columns)
348−select list tabs = UnsafeQuery $
372+select list rels = UnsafeQuery $
349373 "SELECT"
350− <+> renderCommaSeparated (renderAliased renderExpression) list
351− <+> renderTableExpression tabs
374+ <+> renderCommaSeparated (renderAliasedAs renderExpression) list
375+ <+> renderTableExpression rels
352376
353377-- | After the select list has been processed, the result table can
354378-- be subject to the elimination of duplicate rows using `selectDistinct`.
355379selectDistinct
356380 :: SListI columns
357− => NP (Aliased (Expression tables 'Ungrouped params)) (column ': columns)
381+ => NP (Aliased (Expression relations 'Ungrouped params)) (column ': columns)
358382 -- ^ select list
359− -> TableExpression schema params tables 'Ungrouped
383+ -> TableExpression schema params relations 'Ungrouped
360384 -- ^ intermediate virtual table
361385 -> Query schema params (column ': columns)
362−selectDistinct list tabs = UnsafeQuery $
386+selectDistinct list rels = UnsafeQuery $
363387 "SELECT DISTINCT"
364− <+> renderCommaSeparated (renderAliased renderExpression) list
365− <+> renderTableExpression tabs
388+ <+> renderCommaSeparated (renderAliasedAs renderExpression) list
389+ <+> renderTableExpression rels
366390
367391-- | The simplest kind of query is `selectStar` which emits all columns
368392-- that the table expression produces.
369393selectStar
370− :: HasUnique table tables columns
371− => TableExpression schema params tables 'Ungrouped
394+ :: HasUnique relation relations columns
395+ => TableExpression schema params relations 'Ungrouped
372396 -- ^ intermediate virtual table
373397 -> Query schema params columns
374−selectStar tabs = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression tabs
398+selectStar rels = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression rels
375399
376400-- | A `selectDistinctStar` emits all columns that the table expression
377401-- produces and eliminates duplicate rows.
378402selectDistinctStar
379− :: HasUnique table tables columns
380− => TableExpression schema params tables 'Ungrouped
403+ :: HasUnique relation relations columns
404+ => TableExpression schema params relations 'Ungrouped
381405 -- ^ intermediate virtual table
382406 -> Query schema params columns
383−selectDistinctStar tabs = UnsafeQuery $
384− "SELECT DISTINCT" <+> "*" <+> renderTableExpression tabs
407+selectDistinctStar rels = UnsafeQuery $
408+ "SELECT DISTINCT" <+> "*" <+> renderTableExpression rels
385409
386410-- | When working with multiple tables, it can also be useful to ask
387411-- for all the columns of a particular table, using `selectDotStar`.
388412selectDotStar
389− :: HasTable table tables columns
390− => Alias table
413+ :: Has relation relations columns
414+ => Alias relation
391415 -- ^ particular virtual subtable
392− -> TableExpression schema params tables 'Ungrouped
416+ -> TableExpression schema params relations 'Ungrouped
393417 -- ^ intermediate virtual table
394418 -> Query schema params columns
395−selectDotStar table tables = UnsafeQuery $
396− "SELECT" <+> renderAlias table <> ".*" <+> renderTableExpression tables
419+selectDotStar rel relations = UnsafeQuery $
420+ "SELECT" <+> renderAlias rel <> ".*" <+> renderTableExpression relations
397421
398422-- | A `selectDistinctDotStar` asks for all the columns of a particular table,
399423-- and eliminates duplicate rows.
400424selectDistinctDotStar
401− :: HasTable table tables columns
402− => Alias table
403− -- ^ particular virtual subtable
404− -> TableExpression schema params tables 'Ungrouped
425+ :: Has relation relations columns
426+ => Alias relation
427+ -- ^ particular virtual table
428+ -> TableExpression schema params relations 'Ungrouped
405429 -- ^ intermediate virtual table
406430 -> Query schema params columns
407−selectDistinctDotStar table tables = UnsafeQuery $
408− "SELECT DISTINCT" <+> renderAlias table <> ".*"
409− <+> renderTableExpression tables
431+selectDistinctDotStar rel relations = UnsafeQuery $
432+ "SELECT DISTINCT" <+> renderAlias rel <> ".*"
433+ <+> renderTableExpression relations
410434
411435{-----------------------------------------
412436Table Expressions
@@ -420,14 +444,14 @@ Table Expressions
420444-- can be used to modify or combine base tables in various ways.
421445data TableExpression
422446 (schema :: TablesType)
423− (params :: [ColumnType])
424− (tables :: TablesType)
447+ (params :: [NullityType])
448+ (relations :: RelationsType)
425449 (grouping :: Grouping)
426450 = TableExpression
427− { fromClause :: FromClause schema params tables
451+ { fromClause :: FromClause schema params relations
428452 -- ^ A table reference that can be a table name, or a derived table such
429453 -- as a subquery, a @JOIN@ construct, or complex combinations of these.
430− , whereClause :: [Condition tables 'Ungrouped params]
454+ , whereClause :: [Condition relations 'Ungrouped params]
431455 -- ^ optional search coditions, combined with `.&&`. After the processing
432456 -- of the `fromClause` is done, each row of the derived virtual table
433457 -- is checked against the search condition. If the result of the
@@ -436,20 +460,20 @@ data TableExpression
436460 -- at least one column of the table generated in the `fromClause`;
437461 -- this is not required, but otherwise the WHERE clause will
438462 -- be fairly useless.
439− , groupByClause :: GroupByClause tables grouping
463+ , groupByClause :: GroupByClause relations grouping
440464 -- ^ The `groupByClause` is used to group together those rows in a table
441465 -- that have the same values in all the columns listed. The order in which
442466 -- the columns are listed does not matter. The effect is to combine each
443467 -- set of rows having common values into one group row that represents all
444468 -- rows in the group. This is done to eliminate redundancy in the output
445469 -- and/or compute aggregates that apply to these groups.
446− , havingClause :: HavingClause tables grouping params
470+ , havingClause :: HavingClause relations grouping params
447471 -- ^ If a table has been grouped using `groupBy`, but only certain groups
448472 -- are of interest, the `havingClause` can be used, much like a
449473 -- `whereClause`, to eliminate groups from the result. Expressions in the
450474 -- `havingClause` can refer both to grouped expressions and to ungrouped
451475 -- expressions (which necessarily involve an aggregate function).
452− , orderByClause :: [SortExpression tables grouping params]
476+ , orderByClause :: [SortExpression relations grouping params]
453477 -- ^ The `orderByClause` is for optional sorting. When more than one
454478 -- `SortExpression` is specified, the later (right) values are used to sort
455479 -- rows that are equal according to the earlier (left) values.
@@ -467,11 +491,11 @@ data TableExpression
467491
468492-- | Render a `TableExpression`
469493renderTableExpression
470− :: TableExpression schema params tables grouping
494+ :: TableExpression schema params relations grouping
471495 -> ByteString
472496renderTableExpression
473− (TableExpression tables whs' grps' hvs' srts' lims' offs') = mconcat
474− [ "FROM ", renderFromClause tables
497+ (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat
498+ [ "FROM ", renderFromClause frm'
475499 , renderWheres whs'
476500 , renderGroupByClause grps'
477501 , renderHavingClause hvs'
@@ -501,68 +525,68 @@ renderTableExpression
501525-- `group`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator
502526-- to match the left-to-right sequencing of their placement in SQL.
503527from
504− :: FromClause schema params tables -- ^ table reference
505− -> TableExpression schema params tables 'Ungrouped
506−from tables = TableExpression tables [] NoGroups NoHaving [] [] []
528+ :: FromClause schema params relations -- ^ table reference
529+ -> TableExpression schema params relations 'Ungrouped
530+from rels = TableExpression rels [] NoGroups NoHaving [] [] []
507531
508532-- | A `where_` is an endomorphism of `TableExpression`s which adds a
509533-- search condition to the `whereClause`.
510534where_
511− :: Condition tables 'Ungrouped params
512− -> TableExpression schema params tables grouping
513− -> TableExpression schema params tables grouping
514−where_ wh tables = tables {whereClause = wh : whereClause tables}
535+ :: Condition relations 'Ungrouped params -- ^ filtering condition
536+ -> TableExpression schema params relations grouping
537+ -> TableExpression schema params relations grouping
538+where_ wh rels = rels {whereClause = wh : whereClause rels}
515539
516540-- | A `group` is a transformation of `TableExpression`s which switches
517541-- its `Grouping` from `Ungrouped` to `Grouped`. Use @group Nil@ to perform
518542-- a "grand total" aggregation query.
519543group
520544 :: SListI bys
521− => NP (By tables) bys
522− -> TableExpression schema params tables 'Ungrouped
523− -> TableExpression schema params tables ('Grouped bys)
524−group bys tables = TableExpression
525− { fromClause = fromClause tables
526− , whereClause = whereClause tables
545+ => NP (By relations) bys -- ^ grouped columns
546+ -> TableExpression schema params relations 'Ungrouped
547+ -> TableExpression schema params relations ('Grouped bys)
548+group bys rels = TableExpression
549+ { fromClause = fromClause rels
550+ , whereClause = whereClause rels
527551 , groupByClause = Group bys
528552 , havingClause = Having []
529553 , orderByClause = []
530− , limitClause = limitClause tables
531− , offsetClause = offsetClause tables
554+ , limitClause = limitClause rels
555+ , offsetClause = offsetClause rels
532556 }
533557
534558-- | A `having` is an endomorphism of `TableExpression`s which adds a
535559-- search condition to the `havingClause`.
536560having
537− :: Condition tables ('Grouped bys) params
538− -> TableExpression schema params tables ('Grouped bys)
539− -> TableExpression schema params tables ('Grouped bys)
540−having hv tables = tables
541− { havingClause = case havingClause tables of Having hvs -> Having (hv:hvs) }
561+ :: Condition relations ('Grouped bys) params -- ^ having condition
562+ -> TableExpression schema params relations ('Grouped bys)
563+ -> TableExpression schema params relations ('Grouped bys)
564+having hv rels = rels
565+ { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) }
542566
543567-- | An `orderBy` is an endomorphism of `TableExpression`s which appends an
544568-- ordering to the right of the `orderByClause`.
545569orderBy
546− :: [SortExpression tables grouping params]
547− -> TableExpression schema params tables grouping
548− -> TableExpression schema params tables grouping
549−orderBy srts tables = tables {orderByClause = orderByClause tables ++ srts}
570+ :: [SortExpression relations grouping params] -- ^ sort expressions
571+ -> TableExpression schema params relations grouping
572+ -> TableExpression schema params relations grouping
573+orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}
550574
551575-- | A `limit` is an endomorphism of `TableExpression`s which adds to the
552576-- `limitClause`.
553577limit
554− :: Word64
555− -> TableExpression schema params tables grouping
556− -> TableExpression schema params tables grouping
557−limit lim tables = tables {limitClause = lim : limitClause tables}
578+ :: Word64 -- ^ limit parameter
579+ -> TableExpression schema params relations grouping
580+ -> TableExpression schema params relations grouping
581+limit lim rels = rels {limitClause = lim : limitClause rels}
558582
559583-- | An `offset` is an endomorphism of `TableExpression`s which adds to the
560584-- `offsetClause`.
561585offset
562− :: Word64
563− -> TableExpression schema params tables grouping
564− -> TableExpression schema params tables grouping
565−offset off tables = tables {offsetClause = off : offsetClause tables}
586+ :: Word64 -- ^ offset parameter
587+ -> TableExpression schema params relations grouping
588+ -> TableExpression schema params relations grouping
589+offset off rels = rels {offsetClause = off : offsetClause rels}
566590
567591{-----------------------------------------
568592FROM clauses
@@ -571,93 +595,107 @@ FROM clauses
571595{- |
572596A `FromClause` can be a table name, or a derived table such
573597as a subquery, a @JOIN@ construct, or complex combinations of these.
574−
575−* A real `Table` is a table from the schema.
576−
577−* `Subquery` derives a table from a `Query`.
578−
579−* A joined table is a table derived from two other (real or derived) tables
580−according to the rules of the particular join type. `CrossJoin`, `InnerJoin`,
581−`LeftOuterJoin`, `RightOuterJoin` and `FullOuterJoin` are available and can
582−be nested using the `&` operator to match the left-to-right sequencing of
583−their placement in SQL.
584−
585− * @t1 & CrossJoin t2@. For every possible combination of rows from
586− @t1@ and @t2@ (i.e., a Cartesian product), the joined table will contain
587− a row consisting of all columns in @t1@ followed by all columns in @t2@.
598+-}
599+newtype FromClause schema params relations
600+ = UnsafeFromClause { renderFromClause :: ByteString }
601+ deriving (GHC.Generic,Show,Eq,Ord,NFData)
602+
603+-- | A real `table` is a table from the schema.
604+table
605+ :: Aliased (Table schema) table
606+ -> FromClause schema params '[table]
607+table = UnsafeFromClause . renderAliasedAs renderTable
608+
609+-- | `subquery` derives a table from a `Query`.
610+subquery
611+ :: Aliased (Query schema params) table
612+ -> FromClause schema params '[table]
613+subquery = UnsafeFromClause . renderAliasedAs (parenthesized . renderQuery)
614+
615+{- | @left & crossJoin right@. For every possible combination of rows from
616+ @left@ and @right@ (i.e., a Cartesian product), the joined table will contain
617+ a row consisting of all columns in @left@ followed by all columns in @right@.
588618 If the tables have @n@ and @m@ rows respectively, the joined table will
589619 have @n * m@ rows.
590−
591− * @t1 & InnerJoin t2 on@. For each row @r1@ of @t1@, the joined
592− table has a row for each row in @t2@ that satisfies the @on@ condition
593− with @r1@
594−
595− * @t1 & LeftOuterJoin t2 on@. First, an inner join is performed.
596− Then, for each row in @t1@ that does not satisfy the @on@ condition with
597− any row in @t2@, a joined row is added with null values in columns of @t2@.
598− Thus, the joined table always has at least one row for each row in @t1@.
599−
600− * @t1 & RightOuterJoin t2 on@. First, an inner join is performed.
601− Then, for each row in @t2@ that does not satisfy the @on@ condition with
602− any row in @t1@, a joined row is added with null values in columns of @t1@.
620+-}
621+crossJoin
622+ :: FromClause schema params right
623+ -- ^ right
624+ -> FromClause schema params left
625+ -- ^ left
626+ -> FromClause schema params (Join left right)
627+crossJoin right left = UnsafeFromClause $
628+ renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right
629+
630+{- | @left & innerJoin right on@. The joined table is filtered by
631+the @on@ condition.
632+-}
633+innerJoin
634+ :: FromClause schema params right
635+ -- ^ right
636+ -> Condition (Join left right) 'Ungrouped params
637+ -- ^ @on@ condition
638+ -> FromClause schema params left
639+ -- ^ left
640+ -> FromClause schema params (Join left right)
641+innerJoin right on left = UnsafeFromClause $
642+ renderFromClause left <+> "INNER JOIN" <+> renderFromClause right
643+ <+> "ON" <+> renderExpression on
644+
645+{- | @left & leftOuterJoin right on@. First, an inner join is performed.
646+ Then, for each row in @left@ that does not satisfy the @on@ condition with
647+ any row in @right@, a joined row is added with null values in columns of @right@.
648+ Thus, the joined table always has at least one row for each row in @left@.
649+-}
650+leftOuterJoin
651+ :: FromClause schema params right
652+ -- ^ right
653+ -> Condition (Join left right) 'Ungrouped params
654+ -- ^ @on@ condition
655+ -> FromClause schema params left
656+ -- ^ left
657+ -> FromClause schema params (Join left (NullifyRelations right))
658+leftOuterJoin right on left = UnsafeFromClause $
659+ renderFromClause left <+> "LEFT OUTER JOIN" <+> renderFromClause right
660+ <+> "ON" <+> renderExpression on
661+
662+{- | @left & rightOuterJoin right on@. First, an inner join is performed.
663+ Then, for each row in @right@ that does not satisfy the @on@ condition with
664+ any row in @left@, a joined row is added with null values in columns of @left@.
603665 This is the converse of a left join: the result table will always
604− have a row for each row in @t2@.
605−
606− * @t1 & FullOuterJoin t2 on@. First, an inner join is performed.
607− Then, for each row in @t1@ that does not satisfy the @on@ condition with
608− any row in @t2@, a joined row is added with null values in columns of @t2@.
609− Also, for each row of @t2@ that does not satisfy the join condition
610− with any row in @t1@, a joined row with null values in the columns of @t1@
666+ have a row for each row in @right@.
667+-}
668+rightOuterJoin
669+ :: FromClause schema params right
670+ -- ^ right
671+ -> Condition (Join left right) 'Ungrouped params
672+ -- ^ @on@ condition
673+ -> FromClause schema params left
674+ -- ^ left
675+ -> FromClause schema params (Join (NullifyRelations left) right)
676+rightOuterJoin right on left = UnsafeFromClause $
677+ renderFromClause left <+> "RIGHT OUTER JOIN" <+> renderFromClause right
678+ <+> "ON" <+> renderExpression on
679+
680+{- | @left & fullOuterJoin right on@. First, an inner join is performed.
681+ Then, for each row in @left@ that does not satisfy the @on@ condition with
682+ any row in @right@, a joined row is added with null values in columns of @right@.
683+ Also, for each row of @right@ that does not satisfy the join condition
684+ with any row in @left@, a joined row with null values in the columns of @left@
611685 is added.
612686-}
613−data FromClause schema params tables where
614− Table
615− :: Aliased (Table schema) table
616− -> FromClause schema params '[table]
617− Subquery
618− :: Aliased (Query schema params) table
619− -> FromClause schema params '[table]
620− CrossJoin
621− :: FromClause schema params right
622− -> FromClause schema params left
623− -> FromClause schema params (Join left right)
624− InnerJoin
625− :: FromClause schema params right
626− -> Condition (Join left right) 'Ungrouped params
627− -> FromClause schema params left
628− -> FromClause schema params (Join left right)
629− LeftOuterJoin
630− :: FromClause schema params right
631− -> Condition (Join left right) 'Ungrouped params
632− -> FromClause schema params left
633− -> FromClause schema params (Join left (NullifyTables right))
634− RightOuterJoin
635− :: FromClause schema params right
636− -> Condition (Join left right) 'Ungrouped params
637− -> FromClause schema params left
638− -> FromClause schema params (Join (NullifyTables left) right)
639− FullOuterJoin
640− :: FromClause schema params right
641− -> Condition (Join left right) 'Ungrouped params
642− -> FromClause schema params left
643− -> FromClause schema params
644− (Join (NullifyTables left) (NullifyTables right))
645−
646−-- | Renders a `FromClause`.
647−renderFromClause :: FromClause schema params tables -> ByteString
648−renderFromClause = \case
649− Table table -> renderAliased renderTable table
650− Subquery selection -> renderAliased (parenthesized . renderQuery) selection
651− CrossJoin right left ->
652− renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right
653− InnerJoin right on left -> renderJoin "INNER JOIN" right on left
654− LeftOuterJoin right on left -> renderJoin "LEFT OUTER JOIN" right on left
655− RightOuterJoin right on left -> renderJoin "RIGHT OUTER JOIN" right on left
656− FullOuterJoin right on left -> renderJoin "FULL OUTER JOIN" right on left
657− where
658− renderJoin op right on left =
659− renderFromClause left <+> op <+> renderFromClause right
660− <+> "ON" <+> renderExpression on
687+fullOuterJoin
688+ :: FromClause schema params right
689+ -- ^ right
690+ -> Condition (Join left right) 'Ungrouped params
691+ -- ^ @on@ condition
692+ -> FromClause schema params left
693+ -- ^ left
694+ -> FromClause schema params
695+ (Join (NullifyRelations left) (NullifyRelations right))
696+fullOuterJoin right on left = UnsafeFromClause $
697+ renderFromClause left <+> "FULL OUTER JOIN" <+> renderFromClause right
698+ <+> "ON" <+> renderExpression on
661699
662700{-----------------------------------------
663701Grouping
@@ -669,40 +707,41 @@ Grouping
669707-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table
670708-- qualified column @tab.col@.
671709data By
672− (tables :: TablesType)
710+ (relations :: RelationsType)
673711 (by :: (Symbol,Symbol)) where
674712 By
675− :: (HasUnique table tables columns, HasColumn column columns ty)
713+ :: (HasUnique relation relations columns, Has column columns ty)
676714 => Alias column
677− -> By tables '(table, column)
715+ -> By relations '(relation, column)
678716 By2
679− :: (HasTable table tables columns, HasColumn column columns ty)
680− => (Alias table, Alias column)
681− -> By tables '(table, column)
682−deriving instance Show (By tables by)
683−deriving instance Eq (By tables by)
684−deriving instance Ord (By tables by)
717+ :: (Has relation relations columns, Has column columns ty)
718+ => (Alias relation, Alias column)
719+ -> By relations '(relation, column)
720+deriving instance Show (By relations by)
721+deriving instance Eq (By relations by)
722+deriving instance Ord (By relations by)
685723
686724-- | Renders a `By`.
687−renderBy :: By tables tabcolty -> ByteString
725+renderBy :: By relations by -> ByteString
688726renderBy = \case
689727 By column -> renderAlias column
690− By2 (table, column) -> renderAlias table <> "." <> renderAlias column
728+ By2 (rel, column) -> renderAlias rel <> "." <> renderAlias column
691729
692730-- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.
693731-- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`.
694732-- @NoGroups@ is distinguised from @Group Nil@ since no aggregation can be
695733-- done on @NoGroups@ while all output `Expression`s must be aggregated
696−-- in @Group Nil@.
697−data GroupByClause tables grouping where
698− NoGroups :: GroupByClause tables 'Ungrouped
734+-- in @Group Nil@. In general, all output `Expression`s in the
735+-- complement of @bys@ must be aggregated in @Group bys@.
736+data GroupByClause relations grouping where
737+ NoGroups :: GroupByClause relations 'Ungrouped
699738 Group
700739 :: SListI bys
701− => NP (By tables) bys
702− -> GroupByClause tables ('Grouped bys)
740+ => NP (By relations) bys
741+ -> GroupByClause relations ('Grouped bys)
703742
704743-- | Renders a `GroupByClause`.
705−renderGroupByClause :: GroupByClause tables grouping -> ByteString
744+renderGroupByClause :: GroupByClause relations grouping -> ByteString
706745renderGroupByClause = \case
707746 NoGroups -> ""
708747 Group Nil -> ""
@@ -712,17 +751,17 @@ renderGroupByClause = \case
712751-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
713752-- `TableExpression` must use `Having` whose conditions are combined with
714753-- `.&&`.
715−data HavingClause tables grouping params where
716− NoHaving :: HavingClause tables 'Ungrouped params
754+data HavingClause relations grouping params where
755+ NoHaving :: HavingClause relations 'Ungrouped params
717756 Having
718− :: [Condition tables ('Grouped bys) params]
719− -> HavingClause tables ('Grouped bys) params
720−deriving instance Show (HavingClause tables grouping params)
721−deriving instance Eq (HavingClause tables grouping params)
722−deriving instance Ord (HavingClause tables grouping params)
757+ :: [Condition relations ('Grouped bys) params]
758+ -> HavingClause relations ('Grouped bys) params
759+deriving instance Show (HavingClause relations grouping params)
760+deriving instance Eq (HavingClause relations grouping params)
761+deriving instance Ord (HavingClause relations grouping params)
723762
724763-- | Render a `HavingClause`.
725−renderHavingClause :: HavingClause tables grouping params -> ByteString
764+renderHavingClause :: HavingClause relations grouping params -> ByteString
726765renderHavingClause = \case
727766 NoHaving -> ""
728767 Having [] -> ""
@@ -741,29 +780,29 @@ Sorting
741780-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to
742781-- determine whether nulls appear before or after non-null values in the sort
743782-- ordering of a `Null` result column.
744−data SortExpression tables grouping params where
783+data SortExpression relations grouping params where
745784 Asc
746− :: Expression tables grouping params ('Required ('NotNull ty))
747− -> SortExpression tables grouping params
785+ :: Expression relations grouping params ('NotNull ty)
786+ -> SortExpression relations grouping params
748787 Desc
749− :: Expression tables grouping params ('Required ('NotNull ty))
750− -> SortExpression tables grouping params
788+ :: Expression relations grouping params ('NotNull ty)
789+ -> SortExpression relations grouping params
751790 AscNullsFirst
752− :: Expression tables grouping params ('Required ('Null ty))
753− -> SortExpression tables grouping params
791+ :: Expression relations grouping params ('Null ty)
792+ -> SortExpression relations grouping params
754793 AscNullsLast
755− :: Expression tables grouping params ('Required ('Null ty))
756− -> SortExpression tables grouping params
794+ :: Expression relations grouping params ('Null ty)
795+ -> SortExpression relations grouping params
757796 DescNullsFirst
758− :: Expression tables grouping params ('Required ('Null ty))
759− -> SortExpression tables grouping params
797+ :: Expression relations grouping params ('Null ty)
798+ -> SortExpression relations grouping params
760799 DescNullsLast
761− :: Expression tables grouping params ('Required ('Null ty))
762− -> SortExpression tables grouping params
763−deriving instance Show (SortExpression tables grouping params)
800+ :: Expression relations grouping params ('Null ty)
801+ -> SortExpression relations grouping params
802+deriving instance Show (SortExpression relations grouping params)
764803
765804-- | Render a `SortExpression`.
766−renderSortExpression :: SortExpression tables grouping params -> ByteString
805+renderSortExpression :: SortExpression relations grouping params -> ByteString
767806renderSortExpression = \case
768807 Asc expression -> renderExpression expression <+> "ASC"
769808 Desc expression -> renderExpression expression <+> "DESC"
squeal-postgresql/src/Squeal/PostgreSQL/Prettyprint.hs → squeal-postgresql/src/Squeal/PostgreSQL/Render.hsrenamed+12−4
@@ -1,11 +1,11 @@
11{-|
2−Module: Squeal.PostgreSQL.PrettyPrint
3−Description: Pretty print helper functions
2+Module: Squeal.PostgreSQL.Render
3+Description: Rendering helper functions
44Copyright: (c) Eitan Chatav, 2017
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
8−Pretty print helper functions.
8+Rendering helper functions.
99-}
1010
1111{-# LANGUAGE
@@ -17,7 +17,15 @@ Pretty print helper functions.
1717 , TypeApplications
1818#-}
1919
20−module Squeal.PostgreSQL.Prettyprint where
20+module Squeal.PostgreSQL.Render
21+ ( -- * Render
22+ parenthesized
23+ , (<+>)
24+ , commaSeparated
25+ , renderCommaSeparated
26+ , renderCommaSeparatedMaybe
27+ , renderNat
28+ ) where
2129
2230import Data.ByteString (ByteString)
2331import Data.Maybe
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+347−102
@@ -5,17 +5,19 @@ Copyright: (c) Eitan Chatav, 2017
55Maintainer: eitan@morphism.tech
66Stability: experimental
77
8−Embedding of PostgreSQL type and alias system
8+A type-level DSL for kinds of PostgreSQL types, constraints, and aliases.
99-}
1010
1111{-# LANGUAGE
12− ConstraintKinds
12+ AllowAmbiguousTypes
13+ , ConstraintKinds
1314 , DataKinds
1415 , DeriveAnyClass
1516 , DeriveDataTypeable
1617 , DeriveGeneric
1718 , FlexibleContexts
1819 , FlexibleInstances
20+ , FunctionalDependencies
1921 , GADTs
2022 , MagicHash
2123 , MultiParamTypeClasses
@@ -28,43 +30,67 @@ Embedding of PostgreSQL type and alias system
2830 , TypeFamilies
2931 , TypeInType
3032 , TypeOperators
33+ , UndecidableInstances
3134#-}
3235
3336module Squeal.PostgreSQL.Schema
34− ( -- * Kinds
37+ ( -- * Types
3538 PGType (..)
39+ , HasOid (..)
3640 , NullityType (..)
37− , ColumnType (..)
41+ , ColumnType
3842 , ColumnsType
43+ , RelationType
44+ , NilRelation
45+ , RelationsType
46+ , TableType
3947 , TablesType
48+ , NilTables
49+ -- * Grouping
4050 , Grouping (..)
51+ , GroupedBy
4152 -- * Constraints
42− , PGNum
43− , PGIntegral
44− , PGFloating
53+ , (:=>)
54+ , ColumnConstraint (..)
55+ , TableConstraint (..)
56+ , TableConstraints
57+ , NilTableConstraints
4558 -- * Aliases
4659 , (:::)
4760 , Alias (Alias)
4861 , renderAlias
4962 , Aliased (As)
50− , renderAliased
63+ , renderAliasedAs
64+ , AliasesOf
65+ , Has
66+ , HasUnique
5167 , IsLabel (..)
52− , IsTableColumn (..)
68+ , IsQualified (..)
5369 -- * Type Families
54− , In
55− , HasUnique
56− , BaseType
57− , SameTypes
58− , AllNotNull
59− , NotAllNull
60− , NullifyType
61− , NullifyColumns
62− , NullifyTables
6370 , Join
6471 , Create
6572 , Drop
6673 , Alter
6774 , Rename
75+ , Elem
76+ , In
77+ , PGNum
78+ , PGIntegral
79+ , PGFloating
80+ , PGTypeOf
81+ , SameTypes
82+ , AllNotNull
83+ , NotAllNull
84+ , NullifyType
85+ , NullifyRelation
86+ , NullifyRelations
87+ , ColumnsToRelation
88+ , RelationToColumns
89+ , TableToColumns
90+ , TablesToRelations
91+ , RelationsToTables
92+ , ConstraintInvolves
93+ , DropIfConstraintsInvolve
6894 -- * Generics
6995 , SameField
7096 , SameFields
@@ -74,6 +100,8 @@ import Control.DeepSeq
74100import Data.ByteString
75101import Data.Monoid
76102import Data.String
103+import Data.Word
104+import Data.Type.Bool
77105import Generics.SOP (AllZip)
78106import GHC.Generics (Generic)
79107import GHC.Exts
@@ -83,6 +111,10 @@ import GHC.TypeLits
83111import qualified Generics.SOP.Type.Metadata as Type
84112
85113-- | `PGType` is the promoted datakind of PostgreSQL types.
114+--
115+-- >>> import Squeal.PostgreSQL.Schema
116+-- >>> :kind 'PGbool
117+-- 'PGbool :: PGType
86118data PGType
87119 = PGbool -- ^ logical Boolean (true/false)
88120 | PGint2 -- ^ signed two-byte integer
@@ -105,61 +137,214 @@ data PGType
105137 | PGinet -- ^ IPv4 or IPv6 host address
106138 | PGjson -- ^ textual JSON data
107139 | PGjsonb -- ^ binary JSON data, decomposed
140+ | PGvararray PGType -- ^ variable length array
141+ | PGfixarray Nat PGType -- ^ fixed length array
108142 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
109143
144+-- | The object identifier of a `PGType`.
145+--
146+-- >>> :set -XTypeApplications
147+-- >>> oid @'PGbool
148+-- 16
149+class HasOid (ty :: PGType) where oid :: Word32
150+instance HasOid 'PGbool where oid = 16
151+instance HasOid 'PGint2 where oid = 21
152+instance HasOid 'PGint4 where oid = 23
153+instance HasOid 'PGint8 where oid = 20
154+instance HasOid 'PGnumeric where oid = 1700
155+instance HasOid 'PGfloat4 where oid = 700
156+instance HasOid 'PGfloat8 where oid = 701
157+instance HasOid ('PGchar n) where oid = 18
158+instance HasOid ('PGvarchar n) where oid = 1043
159+instance HasOid 'PGtext where oid = 25
160+instance HasOid 'PGbytea where oid = 17
161+instance HasOid 'PGtimestamp where oid = 1114
162+instance HasOid 'PGtimestamptz where oid = 1184
163+instance HasOid 'PGdate where oid = 1082
164+instance HasOid 'PGtime where oid = 1083
165+instance HasOid 'PGtimetz where oid = 1266
166+instance HasOid 'PGinterval where oid = 1186
167+instance HasOid 'PGuuid where oid = 2950
168+instance HasOid 'PGinet where oid = 869
169+instance HasOid 'PGjson where oid = 114
170+instance HasOid 'PGjsonb where oid = 3802
171+
110172-- | `NullityType` encodes the potential presence or definite absence of a
111173-- @NULL@ allowing operations which are sensitive to such to be well typed.
174+--
175+-- >>> :kind 'Null 'PGint4
176+-- 'Null 'PGint4 :: NullityType
177+-- >>> :kind 'NotNull ('PGvarchar 50)
178+-- 'NotNull ('PGvarchar 50) :: NullityType
112179data NullityType
113180 = Null PGType -- ^ @NULL@ may be present
114181 | NotNull PGType -- ^ @NULL@ is absent
115182
116−-- | `ColumnType` encodes the allowance of @DEFAULT@ and the only way
117−-- to generate an `Optional` `Squeal.PostgreSQL.Expression.Expression`
118−-- is to use `Squeal.PostgreSQL.Expression.def`,
119−-- `Squeal.PostgreSQL.Expression.unDef` or
120−-- `Squeal.PostgreSQL.Expression.param`.
121−data ColumnType
122− = Optional NullityType
123− -- ^ @DEFAULT@ is allowed
124− | Required NullityType
125− -- ^ @DEFAULT@ is not allowed
126−
127−-- | `ColumnsType` is a kind synonym for a row of `ColumnType`s.
183+-- | The constraint operator, `:=>` is a type level pair
184+-- between a "constraint" and some type, for use in pairing
185+-- a `ColumnConstraint` with a `NullityType` to produce a `ColumnType`
186+-- or a `TableConstraints` and a `ColumnsType` to produce a `TableType`.
187+type (:=>) constraint ty = '(constraint,ty)
188+infixr 7 :=>
189+
190+-- | The alias operator `:::` is like a promoted version of `As`,
191+-- a type level pair between
192+-- an alias and some type, like a column alias and either a `ColumnType` or
193+-- `NullityType` or a table alias and either a `TableType` or a `RelationType`
194+-- or a constraint alias and a `TableConstraint`.
195+type (:::) (alias :: Symbol) ty = '(alias,ty)
196+infixr 6 :::
197+
198+-- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates.
199+-- A column can be assigned a default value.
200+-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also
201+-- request explicitly that a column be set to its default value,
202+-- without having to know what that value is.
203+data ColumnConstraint
204+ = Def -- ^ @DEFAULT@ is available for inserts and updates
205+ | NoDef -- ^ @DEFAULT@ is unavailable for inserts and updates
206+
207+-- | `ColumnType` encodes the allowance of @DEFAULT@ and @NULL@ and the
208+-- base `PGType` for a column.
209+--
210+-- >>> :set -XTypeFamilies -XTypeInType
211+-- >>> import GHC.TypeLits
212+-- >>> type family IdColumn :: ColumnType where IdColumn = 'Def :=> 'NotNull 'PGint4
213+-- >>> type family EmailColumn :: ColumnType where EmailColumn = 'NoDef :=> 'Null 'PGtext
214+type ColumnType = (ColumnConstraint,NullityType)
215+
216+-- | `ColumnsType` is a row of `ColumnType`s.
217+--
218+-- >>> :{
219+-- type family UsersColumns :: ColumnsType where
220+-- UsersColumns =
221+-- '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext
222+-- , "id" ::: 'Def :=> 'NotNull 'PGint4
223+-- ]
224+-- :}
128225type ColumnsType = [(Symbol,ColumnType)]
129226
130−-- | `TablesType` is a kind synonym for a row of `ColumnsType`s.
131−-- It is used as a kind for both a schema, a disjoint union of tables,
132−-- and a joined table `Squeal.PostgreSQL.Query.FromClause`,
133−-- a product of tables.
134−type TablesType = [(Symbol,ColumnsType)]
227+-- | `TableConstraint` encodes various forms of data constraints
228+-- of columns in a table.
229+-- `TableConstraint`s give you as much control over the data in your tables
230+-- as you wish. If a user attempts to store data in a column that would
231+-- violate a constraint, an error is raised. This applies
232+-- even if the value came from the default value definition.
233+data TableConstraint
234+ = Check [Symbol]
235+ | Unique [Symbol]
236+ | PrimaryKey [Symbol]
237+ | ForeignKey [Symbol] Symbol [Symbol]
238+
239+-- | A `TableConstraints` is a row of `TableConstraint`s.
240+type TableConstraints = [(Symbol,TableConstraint)]
241+-- | A monokinded empty `TableConstraints`.
242+type family NilTableConstraints :: TableConstraints where
243+ NilTableConstraints = '[]
244+
245+-- | `TableType` encodes a row of constraints on a table as well as the types
246+-- of its columns.
247+--
248+-- >>> :{
249+-- type family UsersTable :: TableType where
250+-- UsersTable =
251+-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
252+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
253+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext
254+-- ]
255+-- :}
256+type TableType = (TableConstraints,ColumnsType)
257+
258+-- | `TablesType` is a row of `TableType`s, thought of as a union.
259+--
260+-- >>> :{
261+-- type family Schema :: TablesType where
262+-- Schema =
263+-- '[ "users" :::
264+-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
265+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
266+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext
267+-- , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2)
268+-- ]
269+-- , "emails" :::
270+-- '[ "pk_emails" ::: 'PrimaryKey '["id"]
271+-- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
272+-- ] :=>
273+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
274+-- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
275+-- , "email" ::: 'NoDef :=> 'Null 'PGtext
276+-- ]
277+-- ]
278+-- :}
279+type TablesType = [(Symbol,TableType)]
280+-- | A monokinded empty `TablesType`.
281+type family NilTables :: TablesType where NilTables = '[]
282+
283+-- | `RelationType` is a row of `NullityType`
284+--
285+-- >>> :{
286+-- type family PersonRelation :: RelationType where
287+-- PersonRelation =
288+-- '[ "name" ::: 'NotNull 'PGtext
289+-- , "age" ::: 'NotNull 'PGint4
290+-- , "dateOfBirth" ::: 'Null 'PGdate
291+-- ]
292+-- :}
293+type RelationType = [(Symbol,NullityType)]
294+-- | A monokinded empty `RelationType`.
295+type family NilRelation :: RelationType where NilRelation = '[]
296+
297+-- | `RelationsType` is a row of `RelationType`s, thought of as a product.
298+type RelationsType = [(Symbol,RelationType)]
299+
300+-- | `ColumnsToRelation` removes column constraints.
301+type family ColumnsToRelation (columns :: ColumnsType) :: RelationType where
302+ ColumnsToRelation '[] = '[]
303+ ColumnsToRelation (column ::: constraint :=> ty ': columns) =
304+ column ::: ty ': ColumnsToRelation columns
305+
306+-- | `RelationToColumns` adds `'NoDef` column constraints.
307+type family RelationToColumns (relation :: RelationType) :: ColumnsType where
308+ RelationToColumns '[] = '[]
309+ RelationToColumns (column ::: ty ': columns) =
310+ column ::: 'NoDef :=> ty ': RelationToColumns columns
311+
312+-- | `TableToColumns` removes table constraints.
313+type family TableToColumns (table :: TableType) :: ColumnsType where
314+ TableToColumns (constraints :=> columns) = columns
315+
316+-- | `TablesToRelations` removes both table and column constraints.
317+type family TablesToRelations (tables :: TablesType) :: RelationsType where
318+ TablesToRelations '[] = '[]
319+ TablesToRelations (alias ::: constraint :=> columns ': tables) =
320+ alias ::: ColumnsToRelation columns ': TablesToRelations tables
321+
322+-- | `RelationsToTables` adds both trivial table and column constraints.
323+type family RelationsToTables (tables :: RelationsType) :: TablesType where
324+ RelationsToTables '[] = '[]
325+ RelationsToTables (alias ::: columns ': relations) =
326+ alias ::: '[] :=> RelationToColumns columns ': RelationsToTables relations
135327
136328-- | `Grouping` is an auxiliary namespace, created by
137329-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
138330-- for typesafe aggregation
139331data Grouping
140− = Ungrouped
141− | Grouped [(Symbol,Symbol)]
142−
143−-- | `PGNum` is a constraint on `PGType` whose
144−-- `Squeal.PostgreSQL.Expression.Expression`s have a `Num` constraint.
145−type PGNum ty =
146− In ty '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
332+ = Ungrouped -- ^ no aggregation permitted
333+ | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped
147334
148−-- | `PGFloating` is a constraint on `PGType` whose
149−-- `Squeal.PostgreSQL.Expression.Expression`s
150−-- have `Fractional` and `Floating` constraints.
151−type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]
152−
153−-- | `PGIntegral` is a constraint on `PGType` whose
154−-- `Squeal.PostgreSQL.Expression.Expression`s
155−-- have `Squeal.PostgreSQL.Expression.div_` and
156−-- `Squeal.PostgreSQL.Expression.mod_` functions.
157−type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]
158−
159−-- | `:::` is like a promoted version of `As`, a type level pair between
160−-- an alias and some type, usually a column alias and a `ColumnType` or
161−-- a table alias and a `ColumnsType`.
162−type (:::) (alias :: Symbol) (ty :: polykind) = '(alias,ty)
335+{- | A `GroupedBy` constraint indicates that a table qualified column is
336+a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,
337+may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.
338+-}
339+class (KnownSymbol relation, KnownSymbol column)
340+ => GroupedBy relation column bys where
341+instance {-# OVERLAPPING #-} (KnownSymbol relation, KnownSymbol column)
342+ => GroupedBy relation column ('(table,column) ': bys)
343+instance {-# OVERLAPPABLE #-}
344+ ( KnownSymbol relation
345+ , KnownSymbol column
346+ , GroupedBy relation column bys
347+ ) => GroupedBy relation column (tabcol ': bys)
163348
164349-- | `Alias`es are proxies for a type level string or `Symbol`
165350-- and have an `IsLabel` instance so that with @-XOverloadedLabels@
@@ -172,8 +357,8 @@ data Alias (alias :: Symbol) = Alias
172357instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
173358 fromLabel = Alias
174359
175−-- | >>> renderAlias #alias
176−-- "alias"
360+-- | >>> renderAlias #jimbob
361+-- "jimbob"
177362renderAlias :: KnownSymbol alias => Alias alias -> ByteString
178363renderAlias = fromString . symbolVal
179364
@@ -196,76 +381,108 @@ deriving instance Ord (expression ty)
196381 => Ord (Aliased expression (alias ::: ty))
197382
198383-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")
199−-- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)
384+-- >>> renderAliasedAs renderMaybe (Just (3::Int) `As` #an_int)
200385-- "Just AS an_int"
201−renderAliased
386+renderAliasedAs
202387 :: (forall ty. expression ty -> ByteString)
203388 -> Aliased expression aliased
204389 -> ByteString
205−renderAliased render (expression `As` alias) =
390+renderAliasedAs render (expression `As` alias) =
206391 render expression <> " AS " <> renderAlias alias
207392
393+-- | `AliasesOf` retains the AliasesOf in a row.
394+type family AliasesOf aliaseds where
395+ AliasesOf '[] = '[]
396+ AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys
397+
398+-- | @HasUnique alias fields field@ is a constraint that proves that
399+-- @fields@ is a singleton of @alias ::: field@.
400+type HasUnique alias fields field = fields ~ '[alias ::: field]
401+
402+-- | @Has alias fields field@ is a constraint that proves that
403+-- @fields@ has a field of @alias ::: field@.
404+class KnownSymbol alias =>
405+ Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
406+ | alias fields -> field where
407+instance {-# OVERLAPPING #-} KnownSymbol alias
408+ => Has alias (alias ::: field ': fields) field
409+instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)
410+ => Has alias (field' ': fields) field
411+
208412-- | Analagous to `IsLabel`, the constraint
209−-- `IsTableColumn` defines `!` for a column alias qualified
413+-- `IsQualified` defines `!` for a column alias qualified
210414-- by a table alias.
211−class IsTableColumn table column expression where
415+class IsQualified table column expression where
212416 (!) :: Alias table -> Alias column -> expression
213417 infixl 9 !
214−instance IsTableColumn table column (Alias table, Alias column) where (!) = (,)
418+instance IsQualified table column (Alias table, Alias column) where (!) = (,)
419+
420+-- | @Elem@ is a promoted `Data.List.elem`.
421+type family Elem x xs where
422+ Elem x '[] = 'False
423+ Elem x (x ': xs) = 'True
424+ Elem x (_ ': xs) = Elem x xs
215425
216426-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
217−type family In x xs :: Constraint where
218− In x (x ': xs) = ()
219− In x (y ': xs) = In x xs
427+type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True
220428
221−-- | @HasUnique alias xs x@ is a constraint that proves that @xs@ is a singleton
222−-- of @alias ::: x@.
223−type HasUnique alias xs x = xs ~ '[alias ::: x]
429+-- | `PGNum` is a constraint on `PGType` whose
430+-- `Squeal.PostgreSQL.Expression.Expression`s have a `Num` constraint.
431+type PGNum ty =
432+ In ty '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
224433
225−-- | `BaseType` forgets about @NULL@ and @DEFAULT@
226−type family BaseType (ty :: ColumnType) :: PGType where
227− BaseType (optionality (nullity pg)) = pg
434+-- | `PGFloating` is a constraint on `PGType` whose
435+-- `Squeal.PostgreSQL.Expression.Expression`s
436+-- have `Fractional` and `Floating` constraints.
437+type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]
438+
439+-- | `PGIntegral` is a constraint on `PGType` whose
440+-- `Squeal.PostgreSQL.Expression.Expression`s
441+-- have `Squeal.PostgreSQL.Expression.div_` and
442+-- `Squeal.PostgreSQL.Expression.mod_` functions.
443+type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]
444+
445+-- | `PGTypeOf` forgets about @NULL@ and any column constraints.
446+type family PGTypeOf (ty :: NullityType) :: PGType where
447+ PGTypeOf (nullity pg) = pg
228448
229449-- | `SameTypes` is a constraint that proves two `ColumnsType`s have the same
230450-- length and the same `ColumnType`s.
231−type family SameTypes
232− (columns0 :: ColumnsType) (columns1 :: ColumnsType)
233− :: Constraint where
451+type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType)
452+ :: Constraint where
234453 SameTypes '[] '[] = ()
235− SameTypes ((column0 ::: ty0) ': columns0) ((column1 ::: ty1) ': columns1)
454+ SameTypes (column0 ::: def0 :=> ty0 ': columns0) (column1 ::: def1 :=> ty1 ': columns1)
236455 = (ty0 ~ ty1, SameTypes columns0 columns1)
237456
238457-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
239458type family AllNotNull (columns :: ColumnsType) :: Constraint where
240459 AllNotNull '[] = ()
241− AllNotNull ((column ::: (optionality ('NotNull ty))) ': columns)
242− = AllNotNull columns
460+ AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns
243461
244462-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
245463-- @NOT NULL@.
246−type family NotAllNull columns :: Constraint where
247− NotAllNull ((column ::: (optionality ('NotNull ty))) ': columns) = ()
248− NotAllNull ((column ::: (optionality ('Null ty))) ': columns)
249− = NotAllNull columns
464+type family NotAllNull (columns :: ColumnsType) :: Constraint where
465+ NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()
466+ NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns
250467
251468-- | `NullifyType` is an idempotent that nullifies a `ColumnType`.
252−type family NullifyType (ty :: ColumnType) :: ColumnType where
253− NullifyType (optionality ('Null ty)) = optionality ('Null ty)
254− NullifyType (optionality ('NotNull ty)) = optionality ('Null ty)
469+type family NullifyType (ty :: NullityType) :: NullityType where
470+ NullifyType ('Null ty) = 'Null ty
471+ NullifyType ('NotNull ty) = 'Null ty
255472
256−-- | `NullifyColumns` is an idempotent that nullifies a `ColumnsType`.
257−type family NullifyColumns (columns :: ColumnsType) :: ColumnsType where
258− NullifyColumns '[] = '[]
259− NullifyColumns ((column ::: ty) ': columns) =
260− (column ::: NullifyType ty) ': NullifyColumns columns
473+-- | `NullifyRelation` is an idempotent that nullifies a `ColumnsType`.
474+type family NullifyRelation (columns :: RelationType) :: RelationType where
475+ NullifyRelation '[] = '[]
476+ NullifyRelation (column ::: ty ': columns) =
477+ column ::: NullifyType ty ': NullifyRelation columns
261478
262−-- | `NullifyTables` is an idempotent that nullifies a `TablesType`
479+-- | `NullifyRelations` is an idempotent that nullifies a `RelationsType`
263480-- used to nullify the left or right hand side of an outer join
264481-- in a `Squeal.PostgreSQL.Query.FromClause`.
265−type family NullifyTables (tables :: TablesType) :: TablesType where
266− NullifyTables '[] = '[]
267− NullifyTables ((table ::: columns) ': tables) =
268− (table ::: NullifyColumns columns) ': NullifyTables tables
482+type family NullifyRelations (tables :: RelationsType) :: RelationsType where
483+ NullifyRelations '[] = '[]
484+ NullifyRelations (table ::: columns ': tables) =
485+ table ::: NullifyRelation columns ': NullifyRelations tables
269486
270487-- | `Join` is simply promoted `++` and is used in @JOIN@s in
271488-- `Squeal.PostgreSQL.Query.FromClause`s.
@@ -275,8 +492,7 @@ type family Join xs ys where
275492
276493-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
277494-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
278−-- `Squeal.PostgreSQL.Definition.addColumnDefault` and
279−-- `Squeal.PostgreSQL.Definition.addColumnNull` statements.
495+-- `Squeal.PostgreSQL.Definition.addColumn`.
280496type family Create alias x xs where
281497 Create alias x '[] = '[alias ::: x]
282498 Create alias y (x ': xs) = x ': Create alias y xs
@@ -295,6 +511,19 @@ type family Alter alias xs x where
295511 Alter alias ((alias ::: x0) ': xs) x1 = (alias ::: x1) ': xs
296512 Alter alias (x0 ': xs) x1 = x0 ': Alter alias xs x1
297513
514+-- type family AddConstraint constraint ty where
515+-- AddConstraint constraint (constraints :=> ty)
516+-- = AsSet (constraint ': constraints) :=> ty
517+
518+-- type family DeleteFromList (e :: elem) (list :: [elem]) where
519+-- DeleteFromList elem '[] = '[]
520+-- DeleteFromList elem (x ': xs) =
521+-- If (Cmp elem x == 'EQ) xs (x ': DeleteFromList elem xs)
522+
523+-- type family DropConstraint constraint ty where
524+-- DropConstraint constraint (constraints :=> ty)
525+-- = (AsSet (DeleteFromList constraint constraints)) :=> ty
526+
298527-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
299528-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
300529-- `Squeal.PostgreSQL.Definition.renameColumn`.
@@ -305,14 +534,14 @@ type family Rename alias0 alias1 xs where
305534-- | A `SameField` constraint is an equality constraint on a
306535-- `Generics.SOP.Type.Metadata.FieldInfo` and the column alias in a `:::` pair.
307536class SameField
308− (fieldInfo :: Type.FieldInfo) (fieldty :: (Symbol,ColumnType)) where
537+ (fieldInfo :: Type.FieldInfo) (fieldty :: (Symbol,NullityType)) where
309538instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty)
310539
311540-- | A `SameFields` constraint proves that a
312541-- `Generics.SOP.Type.Metadata.DatatypeInfo` of a record type has the same
313−-- field names as the column aliases of a `ColumnsType`.
542+-- field names as the column AliasesOf of a `ColumnsType`.
314543type family SameFields
315− (datatypeInfo :: Type.DatatypeInfo) (columns :: ColumnsType)
544+ (datatypeInfo :: Type.DatatypeInfo) (columns :: RelationType)
316545 :: Constraint where
317546 SameFields
318547 ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields])
@@ -322,3 +551,19 @@ type family SameFields
322551 ('Type.Newtype _module _datatype ('Type.Record _constructor fields))
323552 columns
324553 = AllZip SameField fields columns
554+
555+-- | Check if a `TableConstraint` involves a column
556+type family ConstraintInvolves column constraint where
557+ ConstraintInvolves column ('Check columns) = column `Elem` columns
558+ ConstraintInvolves column ('Unique columns) = column `Elem` columns
559+ ConstraintInvolves column ('PrimaryKey columns) = column `Elem` columns
560+ ConstraintInvolves column ('ForeignKey columns tab refcolumns)
561+ = column `Elem` columns
562+
563+-- | Drop all `TableConstraint`s that involve a column
564+type family DropIfConstraintsInvolve column constraints where
565+ DropIfConstraintsInvolve column '[] = '[]
566+ DropIfConstraintsInvolve column (alias ::: constraint ': constraints)
567+ = If (ConstraintInvolves column constraint)
568+ (DropIfConstraintsInvolve column constraints)
569+ (alias ::: constraint ': DropIfConstraintsInvolve column constraints)
squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hsnew file+232
@@ -0,0 +1,232 @@
1+{-|
2+Module: Squeal.PostgreSQL.Transaction
3+Description: Squeal transaction control language
4+Copyright: (c) Eitan Chatav, 2017
5+Maintainer: eitan@morphism.tech
6+Stability: experimental
7+
8+Squeal transaction control language.
9+-}
10+
11+{-# LANGUAGE
12+ DataKinds
13+ , EmptyCase
14+ , FlexibleContexts
15+ , FlexibleInstances
16+ , LambdaCase
17+ , OverloadedStrings
18+ , MultiParamTypeClasses
19+ , ScopedTypeVariables
20+ , TypeFamilies
21+ , TypeInType
22+#-}
23+
24+module Squeal.PostgreSQL.Transaction
25+ ( -- * Transaction
26+ transactionally
27+ , transactionally_
28+ , begin
29+ , commit
30+ , rollback
31+ , transactionallySchema
32+ , transactionallySchema_
33+ -- * Transaction Mode
34+ , TransactionMode (..)
35+ , defaultMode
36+ , longRunningMode
37+ , IsolationLevel (..)
38+ , renderIsolationLevel
39+ , AccessMode (..)
40+ , renderAccessMode
41+ , DeferrableMode (..)
42+ , renderDeferrableMode
43+ ) where
44+
45+import Control.Exception.Lifted
46+import Control.Monad.Base
47+import Control.Monad.Trans.Control
48+import Data.ByteString
49+import Data.Monoid
50+import Generics.SOP
51+
52+import qualified Database.PostgreSQL.LibPQ as LibPQ
53+
54+import Squeal.PostgreSQL.Manipulation
55+import Squeal.PostgreSQL.Render
56+import Squeal.PostgreSQL.PQ
57+import Squeal.PostgreSQL.Schema
58+
59+-- | Run a schema invariant computation `transactionally`.
60+transactionally
61+ :: (MonadBaseControl IO tx, MonadPQ schema tx)
62+ => TransactionMode
63+ -> tx x -- ^ run inside a transaction
64+ -> tx x
65+transactionally mode tx = mask $ \restore -> do
66+ _ <- begin mode
67+ result <- restore tx `onException` rollback
68+ _ <- commit
69+ return result
70+
71+-- | Run a schema invariant computation `transactionally_` in `defaultMode`.
72+transactionally_
73+ :: (MonadBaseControl IO tx, MonadPQ schema tx)
74+ => tx x -- ^ run inside a transaction
75+ -> tx x
76+transactionally_ = transactionally defaultMode
77+
78+-- | @BEGIN@ a transaction.
79+begin :: MonadPQ schema tx => TransactionMode -> tx (K Result NilRelation)
80+begin mode = manipulate . UnsafeManipulation $
81+ "BEGIN" <+> renderTransactionMode mode <> ";"
82+
83+-- | @COMMIT@ a schema invariant transaction.
84+commit :: MonadPQ schema tx => tx (K Result NilRelation)
85+commit = manipulate $ UnsafeManipulation "COMMIT;"
86+
87+-- | @ROLLBACK@ a schema invariant transaction.
88+rollback :: MonadPQ schema tx => tx (K Result NilRelation)
89+rollback = manipulate $ UnsafeManipulation "ROLLBACK;"
90+
91+-- | Run a schema changing computation `transactionallySchema`.
92+transactionallySchema
93+ :: MonadBaseControl IO io
94+ => TransactionMode
95+ -> PQ schema0 schema1 io x
96+ -> PQ schema0 schema1 io x
97+transactionallySchema mode u = PQ $ \ conn -> mask $ \ restore -> do
98+ _ <- liftBase . LibPQ.exec (unK conn) $
99+ "BEGIN" <+> renderTransactionMode mode <> ";"
100+ x <- restore (unPQ u conn)
101+ `onException` (liftBase (LibPQ.exec (unK conn) "ROLLBACK"))
102+ _ <- liftBase $ LibPQ.exec (unK conn) "COMMIT"
103+ return x
104+
105+-- | Run a schema changing computation `transactionallySchema_` in `DefaultMode`.
106+transactionallySchema_
107+ :: MonadBaseControl IO io
108+ => PQ schema0 schema1 io x
109+ -> PQ schema0 schema1 io x
110+transactionallySchema_ = transactionallySchema defaultMode
111+
112+-- | The available transaction characteristics are the transaction `IsolationLevel`,
113+-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.
114+data TransactionMode = TransactionMode
115+ { isolationLevel :: IsolationLevel
116+ , accessMode :: AccessMode
117+ , deferrableMode :: DeferrableMode
118+ } deriving (Show, Eq)
119+
120+-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
121+-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.
122+defaultMode :: TransactionMode
123+defaultMode = TransactionMode Serializable ReadWrite NotDeferrable
124+
125+-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
126+-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.
127+-- This mode is well suited for long-running reports or backups.
128+longRunningMode :: TransactionMode
129+longRunningMode = TransactionMode Serializable ReadOnly Deferrable
130+
131+-- | Render a `TransactionMode`.
132+renderTransactionMode :: TransactionMode -> ByteString
133+renderTransactionMode mode =
134+ "ISOLATION LEVEL"
135+ <+> renderIsolationLevel (isolationLevel mode)
136+ <+> renderAccessMode (accessMode mode)
137+ <+> renderDeferrableMode (deferrableMode mode)
138+
139+-- | The SQL standard defines four levels of transaction isolation.
140+-- The most strict is `Serializable`, which is defined by the standard in a paragraph
141+-- which says that any concurrent execution of a set of `Serializable` transactions is
142+-- guaranteed to produce the same effect as running them one at a time in some order.
143+-- The other three levels are defined in terms of phenomena, resulting from interaction
144+-- between concurrent transactions, which must not occur at each level.
145+-- The phenomena which are prohibited at various levels are:
146+--
147+-- __Dirty read__: A transaction reads data written by a concurrent uncommitted transaction.
148+--
149+-- __Nonrepeatable read__: A transaction re-reads data it has previously read and finds that data
150+-- has been modified by another transaction (that committed since the initial read).
151+--
152+-- __Phantom read__: A transaction re-executes a query returning a set of rows that satisfy
153+-- a search condition and finds that the set of rows satisfying the condition
154+-- has changed due to another recently-committed transaction.
155+--
156+-- __Serialization anomaly__: The result of successfully committing a group of transactions is inconsistent
157+-- with all possible orderings of running those transactions one at a time.
158+--
159+-- In PostgreSQL, you can request any of the four standard transaction
160+-- isolation levels, but internally only three distinct isolation levels are implemented,
161+-- i.e. PostgreSQL's `ReadUncommitted` mode behaves like `ReadCommitted`.
162+-- This is because it is the only sensible way to map the standard isolation levels to
163+-- PostgreSQL's multiversion concurrency control architecture.
164+data IsolationLevel
165+ = Serializable
166+ -- ^ Dirty read is not possible.
167+ -- Nonrepeatable read is not possible.
168+ -- Phantom read is not possible.
169+ -- Serialization anomaly is not possible.
170+ | RepeatableRead
171+ -- ^ Dirty read is not possible.
172+ -- Nonrepeatable read is not possible.
173+ -- Phantom read is not possible.
174+ -- Serialization anomaly is possible.
175+ | ReadCommitted
176+ -- ^ Dirty read is not possible.
177+ -- Nonrepeatable read is possible.
178+ -- Phantom read is possible.
179+ -- Serialization anomaly is possible.
180+ | ReadUncommitted
181+ -- ^ Dirty read is not possible.
182+ -- Nonrepeatable read is possible.
183+ -- Phantom read is possible.
184+ -- Serialization anomaly is possible.
185+ deriving (Show, Eq)
186+
187+-- | Render an `IsolationLevel`.
188+renderIsolationLevel :: IsolationLevel -> ByteString
189+renderIsolationLevel = \case
190+ Serializable -> "SERIALIZABLE"
191+ ReadCommitted -> "READ COMMITTED"
192+ ReadUncommitted -> "READ UNCOMMITTED"
193+ RepeatableRead -> "REPEATABLE READ"
194+
195+-- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`.
196+-- `ReadWrite` is the default. When a transaction is `ReadOnly`,
197+-- the following SQL commands are disallowed:
198+-- @INSERT@, @UPDATE@, @DELETE@, and @COPY FROM@
199+-- if the table they would write to is not a temporary table;
200+-- all @CREATE@, @ALTER@, and @DROP@ commands;
201+-- @COMMENT@, @GRANT@, @REVOKE@, @TRUNCATE@;
202+-- and @EXPLAIN ANALYZE@ and @EXECUTE@ if the command they would execute is among those listed.
203+-- This is a high-level notion of `ReadOnly` that does not prevent all writes to disk.
204+data AccessMode
205+ = ReadWrite
206+ | ReadOnly
207+ deriving (Show, Eq)
208+
209+-- | Render an `AccessMode`.
210+renderAccessMode :: AccessMode -> ByteString
211+renderAccessMode = \case
212+ ReadWrite -> "READ WRITE"
213+ ReadOnly -> "READ ONLY"
214+
215+-- | The `Deferrable` transaction property has no effect
216+-- unless the transaction is also `Serializable` and `ReadOnly`.
217+-- When all three of these properties are selected for a transaction,
218+-- the transaction may block when first acquiring its snapshot,
219+-- after which it is able to run without the normal overhead of a
220+-- `Serializable` transaction and without any risk of contributing
221+-- to or being canceled by a serialization failure.
222+-- This `longRunningMode` is well suited for long-running reports or backups.
223+data DeferrableMode
224+ = Deferrable
225+ | NotDeferrable
226+ deriving (Show, Eq)
227+
228+-- | Render a `DeferrableMode`.
229+renderDeferrableMode :: DeferrableMode -> ByteString
230+renderDeferrableMode = \case
231+ Deferrable -> "DEFERRABLE"
232+ NotDeferrable -> "NOT DEFERRABLE"
squeal-postgresql/test/DocTest.hs+4
@@ -5,10 +5,14 @@ import Test.DocTest
55main :: IO ()
66main = doctest
77 [ "-isrc"
8+ , "src/Squeal/PostgreSQL.hs"
89 , "src/Squeal/PostgreSQL/Binary.hs"
910 , "src/Squeal/PostgreSQL/Definition.hs"
1011 , "src/Squeal/PostgreSQL/Manipulation.hs"
1112 , "src/Squeal/PostgreSQL/Query.hs"
1213 , "src/Squeal/PostgreSQL/Expression.hs"
1314 , "src/Squeal/PostgreSQL/PQ.hs"
15+ , "src/Squeal/PostgreSQL/Migration.hs"
16+ , "src/Squeal/PostgreSQL/Transaction.hs"
17+ , "src/Squeal/PostgreSQL/Pool.hs"
1418 ]
squeal-postgresql/test/Spec.hsdeleted−1
@@ -1 +0,0 @@
1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
squeal-postgresql/test/Squeal/PostgreSQL/DefinitionSpec.hsdeleted−124
@@ -1,124 +0,0 @@
1−{-# LANGUAGE
2− DataKinds
3− , MagicHash
4− , OverloadedLabels
5− , OverloadedStrings
6− , TypeApplications
7− , TypeOperators
8−#-}
9−
10−module Squeal.PostgreSQL.DefinitionSpec where
11−
12−import Control.Category ((>>>))
13−import Data.Function
14−import Generics.SOP hiding (from)
15−import Test.Hspec
16−
17−import Squeal.PostgreSQL
18−
19−spec :: Spec
20−spec = do
21− let
22− definition `definitionRenders` str =
23− renderDefinition definition `shouldBe` str
24− it "should render CREATE TABLE statements" $ do
25− createTable #table1
26− ((int4 & notNull) `As` #col1 :* (int4 & notNull) `As` #col2 :* Nil)
27− [primaryKey (Column #col1 :* Column #col2 :* Nil)]
28− `definitionRenders`
29− "CREATE TABLE table1\
30− \ (col1 int4 NOT NULL, col2 int4 NOT NULL,\
31− \ PRIMARY KEY (col1, col2));"
32− createTable #table2
33− ( serial `As` #col1 :*
34− text `As` #col2 :*
35− (int8 & notNull & default_ 8) `As` #col3 :* Nil )
36− [check (#col3 .> 0)]
37− `definitionRenders`
38− "CREATE TABLE table2\
39− \ (col1 serial,\
40− \ col2 text,\
41− \ col3 int8 NOT NULL DEFAULT 8,\
42− \ CHECK ((col3 > 0)));"
43− let
44− statement :: Definition '[]
45− '[ "users" :::
46− '[ "id" ::: 'Optional ('NotNull 'PGint4)
47− , "username" ::: 'Required ('NotNull 'PGtext)
48− ]
49− , "emails" :::
50− '[ "id" ::: 'Optional ('NotNull 'PGint4)
51− , "userid" ::: 'Required ('NotNull 'PGint4)
52− , "email" ::: 'Required ('NotNull 'PGtext)
53− ]
54− ]
55− statement =
56− createTable #users
57− (serial `As` #id :* (text & notNull) `As` #username :* Nil)
58− [primaryKey (Column #id :* Nil)]
59− >>>
60− createTable #emails
61− ( serial `As` #id :*
62− (integer & notNull) `As` #userid :*
63− (text & notNull) `As` #email :* Nil )
64− [ primaryKey (Column #id :* Nil)
65− , foreignKey (Column #userid :* Nil) #users (Column #id :* Nil)
66− OnDeleteCascade OnUpdateRestrict
67− , unique (Column #email :* Nil)
68− , check (#email ./= "")
69− ]
70− statement `definitionRenders`
71− "CREATE TABLE users\
72− \ (id serial, username text NOT NULL,\
73− \ PRIMARY KEY (id));\
74− \ \
75− \CREATE TABLE emails\
76− \ (id serial,\
77− \ userid integer NOT NULL,\
78− \ email text NOT NULL,\
79− \ PRIMARY KEY (id),\
80− \ FOREIGN KEY (userid) REFERENCES users (id)\
81− \ ON DELETE CASCADE ON UPDATE RESTRICT,\
82− \ UNIQUE (email),\
83− \ CHECK ((email <> E'')));"
84− it "should render DROP TABLE statements" $ do
85− let
86− statement :: Definition Tables '[]
87− statement = dropTable #table1
88− statement `definitionRenders` "DROP TABLE table1;"
89−
90−type Columns =
91− '[ "col1" ::: 'Required ('NotNull 'PGint4)
92− , "col2" ::: 'Required ('NotNull 'PGint4)
93− ]
94−type Tables = '[ "table1" ::: Columns ]
95−type SumAndCol1 =
96− '[ "sum" ::: 'Required ('NotNull 'PGint4)
97− , "col1" ::: 'Required ('NotNull 'PGint4)
98− ]
99−type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGtext)]
100−type StudentsTable = '["students" ::: StudentsColumns]
101−type OrderColumns =
102− '[ "orderID" ::: 'Required ('NotNull 'PGint4)
103− , "orderVal" ::: 'Required ('NotNull 'PGtext)
104− , "customerID" ::: 'Required ('NotNull 'PGint4)
105− , "shipperID" ::: 'Required ('NotNull 'PGint4)
106− ]
107−type CustomerColumns =
108− '[ "customerID" ::: 'Required ('NotNull 'PGint4)
109− , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
110− ]
111−type ShipperColumns =
112− '[ "shipperID" ::: 'Required ('NotNull 'PGint4)
113− , "shipperVal" ::: 'Required ('NotNull 'PGbool)
114− ]
115−type JoinTables =
116− '[ "orders" ::: OrderColumns
117− , "customers" ::: CustomerColumns
118− , "shippers" ::: ShipperColumns
119− ]
120−type ValueColumns =
121− '[ "orderVal" ::: 'Required ('NotNull 'PGtext)
122− , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
123− , "shipperVal" ::: 'Required ('NotNull 'PGbool)
124− ]
squeal-postgresql/test/Squeal/PostgreSQL/ManipulationSpec.hsdeleted−128
@@ -1,128 +0,0 @@
1−{-# LANGUAGE
2− DataKinds
3− , MagicHash
4− , OverloadedLabels
5− , OverloadedStrings
6− , TypeApplications
7− , TypeOperators
8−#-}
9−
10−module Squeal.PostgreSQL.ManipulationSpec where
11−
12−import Generics.SOP hiding (from)
13−import Test.Hspec
14−
15−import Squeal.PostgreSQL
16−
17−spec :: Spec
18−spec = do
19− let
20− manipulation `manipulationRenders` str =
21− renderManipulation manipulation `shouldBe` str
22− it "correctly renders returning INSERTs" $ do
23− let
24− statement :: Manipulation Tables '[] SumAndCol1
25− statement =
26− insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
27− OnConflictDoRaise
28− (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
29− statement `manipulationRenders`
30− "INSERT INTO table1 (col1, col2) VALUES (2, 4)\
31− \ RETURNING (col1 + col2) AS sum, col1 AS col1;"
32− it "correctly renders simple UPDATEs" $ do
33− let
34− statement :: Manipulation Tables '[] '[]
35− statement =
36− update #table1 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
37− (#col1 ./= #col2) (Returning Nil)
38− statement `manipulationRenders`
39− "UPDATE table1 SET col1 = 2\
40− \ WHERE (col1 <> col2);"
41− it "correctly renders returning UPDATEs" $ do
42− let
43− statement :: Manipulation Tables '[] SumAndCol1
44− statement =
45− update #table1 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
46− (#col1 ./= #col2)
47− (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
48− statement `manipulationRenders`
49− "UPDATE table1 SET col1 = 2\
50− \ WHERE (col1 <> col2)\
51− \ RETURNING (col1 + col2) AS sum, col1 AS col1;"
52− it "correctly renders upsert INSERTs" $ do
53− let
54− statement :: Manipulation Tables '[] '[]
55− statement =
56− insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
57− (OnConflictDoUpdate
58− (Set 2 `As` #col1 :* Same `As` #col2 :* Nil) Nothing)
59− (Returning Nil)
60− statement `manipulationRenders`
61− "INSERT INTO table1 (col1, col2) VALUES (2, 4)\
62− \ ON CONFLICT DO UPDATE\
63− \ SET col1 = 2;"
64− it "correctly renders returning upsert INSERTs" $ do
65− let
66− statement :: Manipulation Tables '[] SumAndCol1
67− statement =
68− insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])
69− (OnConflictDoUpdate
70− (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)
71− (Just (#col1 ./= #col2)))
72− (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
73− statement `manipulationRenders`
74− "INSERT INTO table1 (col1, col2) VALUES (2, 4)\
75− \ ON CONFLICT DO UPDATE\
76− \ SET col1 = 2\
77− \ WHERE (col1 <> col2)\
78− \ RETURNING (col1 + col2) AS sum, col1 AS col1;"
79− it "correctly renders DELETEs" $ do
80− let
81− statement :: Manipulation Tables '[] '[]
82− statement = deleteFrom #table1 (#col1 .== #col2) (Returning Nil)
83− statement `manipulationRenders`
84− "DELETE FROM table1 WHERE (col1 = col2);"
85− it "should be safe against SQL injection in literal text" $ do
86− let
87− statement :: Manipulation StudentsTable '[] '[]
88− statement = insertInto #students
89− (Values ("Robert'); DROP TABLE students;" `As` #name :* Nil) [])
90− OnConflictDoRaise (Returning Nil)
91− statement `manipulationRenders`
92− "INSERT INTO students (name) VALUES (E'Robert''); DROP TABLE students;');"
93−
94−type Columns =
95− '[ "col1" ::: 'Required ('NotNull 'PGint4)
96− , "col2" ::: 'Required ('NotNull 'PGint4)
97− ]
98−type Tables = '[ "table1" ::: Columns ]
99−type SumAndCol1 =
100− '[ "sum" ::: 'Required ('NotNull 'PGint4)
101− , "col1" ::: 'Required ('NotNull 'PGint4)
102− ]
103−type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGtext)]
104−type StudentsTable = '["students" ::: StudentsColumns]
105−type OrderColumns =
106− '[ "orderID" ::: 'Required ('NotNull 'PGint4)
107− , "orderVal" ::: 'Required ('NotNull 'PGtext)
108− , "customerID" ::: 'Required ('NotNull 'PGint4)
109− , "shipperID" ::: 'Required ('NotNull 'PGint4)
110− ]
111−type CustomerColumns =
112− '[ "customerID" ::: 'Required ('NotNull 'PGint4)
113− , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
114− ]
115−type ShipperColumns =
116− '[ "shipperID" ::: 'Required ('NotNull 'PGint4)
117− , "shipperVal" ::: 'Required ('NotNull 'PGbool)
118− ]
119−type JoinTables =
120− '[ "orders" ::: OrderColumns
121− , "customers" ::: CustomerColumns
122− , "shippers" ::: ShipperColumns
123− ]
124−type ValueColumns =
125− '[ "orderVal" ::: 'Required ('NotNull 'PGtext)
126− , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
127− , "shipperVal" ::: 'Required ('NotNull 'PGbool)
128− ]
squeal-postgresql/test/Squeal/PostgreSQL/QuerySpec.hsdeleted−181
@@ -1,181 +0,0 @@
1−{-# LANGUAGE
2− DataKinds
3− , MagicHash
4− , OverloadedLabels
5− , OverloadedStrings
6− , TypeApplications
7− , TypeOperators
8−#-}
9−
10−module Squeal.PostgreSQL.QuerySpec where
11−
12−import Data.Function
13−import Generics.SOP hiding (from)
14−import Test.Hspec
15−
16−import Squeal.PostgreSQL
17−
18−spec :: Spec
19−spec = do
20− let
21− qry `queryRenders` str =
22− renderManipulation (queryStatement qry) `shouldBe` str
23− it "correctly renders a simple SELECT query" $ do
24− let
25− statement :: Query Tables '[] SumAndCol1
26− statement =
27− select ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
28− (from (Table (#table1 `As` #table1)) & where_ (#col1 .> #col2))
29− statement `queryRenders`
30− "SELECT (col1 + col2) AS sum, col1 AS col1\
31− \ FROM table1 AS table1 WHERE (col1 > col2);"
32− it "combines WHEREs using AND" $ do
33− let
34− statement :: Query Tables '[] SumAndCol1
35− statement =
36− select ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
37− (from (Table (#table1 `As` #table1)) & where_ true & where_ false)
38− statement `queryRenders`
39− "SELECT (col1 + col2) AS sum, col1 AS col1\
40− \ FROM table1 AS table1 WHERE (TRUE AND FALSE);"
41− it "performs sub SELECTs" $ do
42− let
43− statement :: Query Tables '[] SumAndCol1
44− statement =
45− selectStar (from (Subquery
46− (select ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)
47− (from (Table (#table1 `As` #table1))) `As` #sub)))
48− statement `queryRenders`
49− "SELECT * FROM\
50− \ (SELECT (col1 + col2) AS sum, col1 AS col1\
51− \ FROM table1 AS table1) AS sub;"
52− it "does LIMIT clauses" $ do
53− let
54− statement :: Query Tables '[] Columns
55− statement = selectStar (from (Table (#table1 `As` #table1)) & limit 1)
56− statement `queryRenders` "SELECT * FROM table1 AS table1 LIMIT 1;"
57− it "should use the minimum of given LIMITs" $ do
58− let
59− statement :: Query Tables '[] Columns
60− statement =
61− selectStar (from (Table (#table1 `As` #table1)) & limit 1 & limit 2)
62− statement `queryRenders` "SELECT * FROM table1 AS table1 LIMIT 1;"
63− it "should render parameters using $ signs" $ do
64− let
65− statement :: Query Tables '[ 'Required ('NotNull 'PGbool)] Columns
66− statement = selectStar
67− (from (Table (#table1 `As` #table1)) & where_ (param @1))
68− statement `queryRenders`
69− "SELECT * FROM table1 AS table1 WHERE ($1 :: bool);"
70− it "does OFFSET clauses" $ do
71− let
72− statement :: Query Tables '[] Columns
73− statement =
74− selectStar (from (Table (#table1 `As` #table1)) & offset 1)
75− statement `queryRenders` "SELECT * FROM table1 AS table1 OFFSET 1;"
76− it "should use the sum of given OFFSETs" $ do
77− let
78− statement :: Query Tables '[] Columns
79− statement = selectStar
80− (from (Table (#table1 `As` #table1)) & offset 1 & offset 2)
81− statement `queryRenders` "SELECT * FROM table1 AS table1 OFFSET 3;"
82− it "should render GROUP BY and HAVING clauses" $ do
83− let
84− statement :: Query Tables '[] SumAndCol1
85− statement =
86− select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil)
87− ( from (Table (#table1 `As` #table1))
88− & group (By #col1 :* Nil)
89− & having (#col1 + sum_ #col2 .> 1) )
90− statement `queryRenders`
91− "SELECT sum(col2) AS sum, col1 AS col1\
92− \ FROM table1 AS table1\
93− \ GROUP BY col1\
94− \ HAVING ((col1 + sum(col2)) > 1);"
95− describe "JOINs" $ do
96− it "should render CROSS JOINs" $ do
97− let
98− statement :: Query JoinTables '[] ValueColumns
99− statement = select
100− ( #orders ! #orderVal `As` #orderVal :*
101− #customers ! #customerVal `As` #customerVal :*
102− #shippers ! #shipperVal `As` #shipperVal :* Nil )
103− ( from (Table (#orders `As` #orders)
104− & CrossJoin (Table (#customers `As` #customers))
105− & CrossJoin (Table (#shippers `As` #shippers))) )
106− statement `queryRenders`
107− "SELECT\
108− \ orders.orderVal AS orderVal,\
109− \ customers.customerVal AS customerVal,\
110− \ shippers.shipperVal AS shipperVal\
111− \ FROM orders AS orders\
112− \ CROSS JOIN customers AS customers\
113− \ CROSS JOIN shippers AS shippers;"
114− it "should render INNER JOINs" $ do
115− let
116− statement :: Query JoinTables '[] ValueColumns
117− statement = select
118− ( (#orders ! #orderVal) `As` #orderVal
119− :* (#customers ! #customerVal) `As` #customerVal
120− :* (#shippers ! #shipperVal) `As` #shipperVal :* Nil)
121− ( from (Table (#orders `As` #orders)
122− & InnerJoin (Table (#customers `As` #customers))
123− ((#orders ! #customerID) .== (#customers ! #customerID))
124− & InnerJoin (Table (#shippers `As` #shippers))
125− ((#orders ! #shipperID) .== (#shippers ! #shipperID))))
126− statement `queryRenders`
127− "SELECT\
128− \ orders.orderVal AS orderVal,\
129− \ customers.customerVal AS customerVal,\
130− \ shippers.shipperVal AS shipperVal\
131− \ FROM orders AS orders\
132− \ INNER JOIN customers AS customers\
133− \ ON (orders.customerID = customers.customerID)\
134− \ INNER JOIN shippers AS shippers\
135− \ ON (orders.shipperID = shippers.shipperID);"
136− it "should render self JOINs" $ do
137− let
138− statement :: Query JoinTables '[] OrderColumns
139− statement = selectDotStar #orders1
140− (from (Table (#orders `As` #orders1)
141− & CrossJoin (Table (#orders `As` #orders2))))
142− statement `queryRenders`
143− "SELECT orders1.*\
144− \ FROM orders AS orders1\
145− \ CROSS JOIN orders AS orders2;"
146−
147−type Columns =
148− '[ "col1" ::: 'Required ('NotNull 'PGint4)
149− , "col2" ::: 'Required ('NotNull 'PGint4)
150− ]
151−type Tables = '[ "table1" ::: Columns ]
152−type SumAndCol1 =
153− '[ "sum" ::: 'Required ('NotNull 'PGint4)
154− , "col1" ::: 'Required ('NotNull 'PGint4)
155− ]
156−type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGtext)]
157−type StudentsTable = '["students" ::: StudentsColumns]
158−type OrderColumns =
159− '[ "orderID" ::: 'Required ('NotNull 'PGint4)
160− , "orderVal" ::: 'Required ('NotNull 'PGtext)
161− , "customerID" ::: 'Required ('NotNull 'PGint4)
162− , "shipperID" ::: 'Required ('NotNull 'PGint4)
163− ]
164−type CustomerColumns =
165− '[ "customerID" ::: 'Required ('NotNull 'PGint4)
166− , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
167− ]
168−type ShipperColumns =
169− '[ "shipperID" ::: 'Required ('NotNull 'PGint4)
170− , "shipperVal" ::: 'Required ('NotNull 'PGbool)
171− ]
172−type JoinTables =
173− '[ "orders" ::: OrderColumns
174− , "customers" ::: CustomerColumns
175− , "shippers" ::: ShipperColumns
176− ]
177−type ValueColumns =
178− '[ "orderVal" ::: 'Required ('NotNull 'PGtext)
179− , "customerVal" ::: 'Required ('NotNull 'PGfloat4)
180− , "shipperVal" ::: 'Required ('NotNull 'PGbool)
181− ]
stack.yaml+1−1
@@ -1,3 +1,3 @@
1−resolver: nightly-2017-08-25
1+resolver: lts-11.1
22packages:
33- squeal-postgresql