git.iko.soy/squeal
on 0cff6db help sign in
ddc9847
swap
0 ahead, 911 behind
67 files changed+2262−14512
since splitsnapshots
unifiedsplit
.circleci/config.yml−24 .gitignore−1 README.md+4−277 RELEASE NOTES.md−1217 circle.yml+10 scrap-your-nils.md−60 squeal-postgresql/LICENSE−31 squeal-postgresql/README.md−11 squeal-postgresql/docs-upload.sh−18 squeal-postgresql/exe/Example.hs−125 squeal-postgresql/squeal-postgresql.cabal−147 squeal-postgresql/src/Squeal/PostgreSQL.hs−233 squeal-postgresql/src/Squeal/PostgreSQL/Alias.hs−249 squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs−848 squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs−82 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hs−238 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hs−159 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hs−96 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hs−500 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table/Constraint.hs−339 squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hs−229 squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hs−104 squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs−472 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hs−462 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hs−169 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs−206 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hs−462 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Literal.hs−87 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs−105 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs−100 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hs−104 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hs−80 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hs−230 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Set.hs−139 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hs−85 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hs−120 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs−64 squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs−157 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs−192 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs−446 squeal-postgresql/src/Squeal/PostgreSQL/Expression/Window.hs−284 squeal-postgresql/src/Squeal/PostgreSQL/List.hs−112 squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs−578 squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs−448 squeal-postgresql/src/Squeal/PostgreSQL/PG.hs−388 squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs−712 squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs−122 squeal-postgresql/src/Squeal/PostgreSQL/Query.hs−1098 squeal-postgresql/src/Squeal/PostgreSQL/Render.hs−145 squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs−596 squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs−252 squeal-postgresql/test/Doc.hs−6 squeal-postgresql/test/Property.hs−166 squeal-postgresql/test/Spec.hs−136 squeal-presentation-raveline.md−794 squeal-presentation.pdf squeal-postgresql/Setup.hs → squeel-postgresql/Setup.hs squeel-postgresql/exe/Example.hs+87 squeel-postgresql/squeel-postgresql.cabal+71 squeel-postgresql/src/Squeel/PostgreSQL.hs+11 squeel-postgresql/src/Squeel/PostgreSQL/Binary.hs+178 squeel-postgresql/src/Squeel/PostgreSQL/PQ.hs+206 squeel-postgresql/src/Squeel/PostgreSQL/Schema.hs+162 squeel-postgresql/src/Squeel/PostgreSQL/Statement.hs+1202 squeel-postgresql/test/Spec.hs+1 squeel-postgresql/test/Squeel/PostgreSQL/StatementSpec.hs+328 stack.yaml+2−7
.circleci/config.ymldeleted−24
@@ -1,24 +0,0 @@
1−version: 2
2−jobs:
3− build:
4− docker:
5− - image: haskell:8.6.5
6− - image: circleci/postgres:latest
7− environment:
8− POSTGRES_USER: root
9− POSTGRES_DB: exampledb
10− steps:
11− - checkout
12− - restore_cache:
13− keys:
14− - dependency-cache
15− - run: apt-get update && apt-get install -y libpq-dev xz-utils make
16− - run: stack upgrade && stack update
17− - run: stack build --fast
18− - run: stack test
19− - run: stack haddock
20− - save_cache:
21− key: dependency-cache
22− paths:
23− - ".stack-work"
24− - "/root/.stack/"
.gitignore−1
@@ -17,4 +17,3 @@ cabal.sandbox.config
1717*.eventlog
1818.stack-work/
1919cabal.project.local
20−.DS_Store
README.md+4−277
@@ -1,280 +1,7 @@
1−# squeal
1+# squeel
22
3−![squeal-icon](http://www.emoticonswallpapers.com/emotion/cute-big-pig/cute-pig-smiley-046.gif)
3+![squeel-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/morphismtech/squeal)
5+[![CircleCI](https://circleci.com/gh/echatav/squeel.svg?style=svg&circle-token=a699a654ef50db2c3744fb039cf2087c484d1226)](https://circleci.com/gh/echatav/squeel)
66
7−[Github](https://github.com/morphismtech/squeal)
8−
9−[Hackage](https://hackage.haskell.org/package/squeal-postgresql)
10−
11−[Stackage](https://www.stackage.org/package/squeal-postgresql)
12−
13−[YouTube](https://www.youtube.com/watch?v=rWfEQfAaNc4)
14−
15−## introduction
16−
17−Squeal is a deep embedding of SQL into Haskell. By "deep embedding", I am abusing the
18−term somewhat. What I mean is that Squeal embeds both SQL terms and SQL types
19−into Haskell at the term and type levels respectively. This leads to a very high level
20−of type-safety in Squeal.
21−
22−Squeal embeds not just the structured query language of SQL but also the
23−data manipulation language and the data definition language; that's `SELECT`,
24−`INSERT`, `UPDATE`, `DELETE`, `WITH`, `CREATE`, `DROP`, and `ALTER` commands.
25−
26−Squeal expressions closely match their corresponding SQL expressions so that
27−the SQL they actually generate is completely predictable. They are also highly
28−composable and cover a large portion of SQL.
29−
30−## features
31−
32−* generic encoding of Haskell tuples and records into query parameters
33− and generic decoding of query results into Haskell records
34− using [`generics-sop`](https://hackage.haskell.org/package/generics-sop)
35−* access to SQL alias system using the `OverloadedLabels` extension
36−* type-safe `NULL` and `DEFAULT`
37−* type-safe SQL constraints `CHECK`, `UNIQUE`, `PRIMARY KEY` and `FOREIGN KEY`
38−* type-safe aggregation
39−* escape hatches for writing raw SQL
40−* [`mtl`](https://hackage.haskell.org/package/mtl) compatible monad transformer
41− for executing as well as preparing queries and manipulations
42− and [Atkey](https://bentnib.org/paramnotions-jfp.pdf) indexed monad transformer
43− for executing definitions.
44−* linear, invertible migrations
45−* connection pools
46−* transactions
47−* views
48−* array, composite and enumerated types
49−* json functions and operations
50−* multischema support
51−* correlated subqueries
52−* window functions
53−* text search
54−
55−## installation
56−
57−`stack install squeal-postgresql`
58−
59−## testing
60−
61−Start postgres on localhost port `5432` and create a database named `exampledb`.
62−
63−`stack test`
64−
65−## contributing
66−
67−We welcome contributors.
68−Please make pull requests on the `dev` branch instead of `master`.
69−The `Issues` page is a good place to communicate.
70−
71−## usage
72−
73−Let's see an example!
74−
75−First, we need some language extensions because Squeal uses modern GHC
76−features.
77−
78−```Haskell
79−>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts
80−>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs
81−```
82−
83−We'll need some imports.
84−
85−```Haskell
86−>>> import Control.Monad.IO.Class (liftIO)
87−>>> import Data.Int (Int32)
88−>>> import Data.Text (Text)
89−>>> import Squeal.PostgreSQL
90−```
91−
92−We'll use generics to easily convert between Haskell and PostgreSQL values.
93−
94−```Haskell
95−>>> import qualified Generics.SOP as SOP
96−>>> import qualified GHC.Generics as GHC
97−```
98−
99−The first step is to define the schema of our database. This is where
100−we use `DataKinds` and `TypeOperators`.
101−
102−```Haskell
103−>>> :{
104−type UsersColumns =
105− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
106− , "name" ::: 'NoDef :=> 'NotNull 'PGtext ]
107−type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]
108−type EmailsColumns =
109− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
110− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
111− , "email" ::: 'NoDef :=> 'Null 'PGtext ]
112−type EmailsConstraints =
113− '[ "pk_emails" ::: 'PrimaryKey '["id"]
114− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] ]
115−type Schema =
116− '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns)
117− , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ]
118−type Schemas = Public Schema
119−:}
120−```
121−
122−Notice the use of type operators.
123−
124−`:::` is used to pair an alias `Symbol` with a `SchemumType`,
125−a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's `::`
126−operator.
127−
128−`:=>` is used to pair `TableConstraints` with a `ColumnsType`,
129−yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,
130−yielding a `ColumnType`. It is intended to connote Haskell's `=>` operator
131−
132−Next, we'll write `Definition`s to set up and tear down the schema. In
133−Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`
134−has two type parameters, corresponding to the schema
135−before being run and the schema after. We can compose definitions using `>>>`.
136−Here and in the rest of our commands we make use of overloaded
137−labels to refer to named tables and columns in our schema.
138−
139−```Haskell
140−>>> :{
141−let
142− setup :: Definition (Public '[]) Schemas
143− setup =
144− createTable #users
145− ( serial `as` #id :*
146− (text & notNullable) `as` #name )
147− ( primaryKey #id `as` #pk_users ) >>>
148− createTable #emails
149− ( serial `as` #id :*
150− (int & notNullable) `as` #user_id :*
151− (text & nullable) `as` #email )
152− ( primaryKey #id `as` #pk_emails :*
153− foreignKey #user_id #users #id
154− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
155−:}
156−```
157−
158−We can easily see the generated SQL is unsurprising looking.
159−
160−```Haskell
161−>>> printSQL setup
162−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
163−CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
164−```
165−
166−Notice that `setup` starts with an empty schema `'[]` and produces `Schema`.
167−In our `createTable` commands we included `TableConstraint`s to define
168−primary and foreign keys, making them somewhat complex. Our `teardown`
169−`Definition` is simpler.
170−
171−```Haskell
172−>>> :{
173−let
174− teardown :: Definition Schemas (Public '[])
175− teardown = dropTable #emails >>> dropTable #users
176−:}
177−
178−>>> printSQL teardown
179−DROP TABLE "emails";
180−DROP TABLE "users";
181−```
182−
183−We'll need a Haskell type for `User`s. We give the type `SOP.Generic` and
184−`SOP.HasDatatypeInfo` instances so that we can encode and decode `User`s.
185−
186−```Haskell
187−>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
188−>>> instance SOP.Generic User
189−>>> instance SOP.HasDatatypeInfo User
190−```
191−
192−Next, we'll write `Manipulation_`s to insert `User`s into our two tables.
193−A `Manipulation_` like `insertInto`, `update` or `deleteFrom`
194−has three type parameters, the schemas it refers to, input parameters
195−and an output row. When
196−we insert into the users table, we will need a parameter for the `name`
197−field but not for the `id` field. Since it's serial, we can use a default
198−value. However, since the emails table refers to the users table, we will
199−need to retrieve the user id that the insert generates and insert it into
200−the emails table. We can do this in a single `Manipulation_` by using a
201−`with` statement.
202−
203−```Haskell
204−>>> :{
205−let
206− insertUser :: Manipulation_ Schemas User ()
207− insertUser = with (u `as` #u) e
208− where
209− u = insertInto #users
210− (Values_ (Default `as` #id :* Set (param @1) `as` #name))
211− OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))
212− e = insertInto_ #emails $ Select
213− (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)
214− (from (common #u))
215−:}
216−
217−>>> printSQL insertUser
218−WITH "u" AS (INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u"
219−```
220−
221−Next we write a `Query_` to retrieve users from the database. We're not
222−interested in the ids here, just the usernames and email addresses. We
223−need to use an `innerJoin` to get the right result. A `Query_` is like a
224−`Manipulation_` with the same kind of type parameters.
225−
226−```Haskell
227−>>> :{
228−let
229− getUsers :: Query_ Schemas () User
230− getUsers = select_
231− (#u ! #name `as` #userName :* #e ! #email `as` #userEmail)
232− ( from (table (#users `as` #u)
233− & innerJoin (table (#emails `as` #e))
234− (#u ! #id .== #e ! #user_id)) )
235−:}
236−
237−>>> printSQL getUsers
238−SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id")
239−```
240−
241−Let's create some users to add to the database.
242−
243−```Haskell
244−>>> :{
245−let
246− users :: [User]
247− users =
248− [ User "Alice" (Just "alice@gmail.com")
249− , User "Bob" Nothing
250− , User "Carole" (Just "carole@hotmail.com")
251− ]
252−:}
253−```
254−
255−Now we can put together all the pieces into a program. The program
256−connects to the database, sets up the schema, inserts the user data
257−(using prepared statements as an optimization), queries the user
258−data and prints it out and finally closes the connection. We can thread
259−the changing schema information through by using the indexed `PQ` monad
260−transformer and when the schema doesn't change we can use `Monad` and
261−`MonadPQ` functionality.
262−
263−```Haskell
264−>>> :{
265−let
266− session :: PQ Schemas Schemas IO ()
267− session = do
268− _ <- traversePrepared_ insertUser users
269− usersResult <- runQuery getUsers
270− usersRows <- getRows usersResult
271− liftIO $ print (usersRows :: [User])
272−in
273− withConnection "host=localhost port=5432 dbname=exampledb" $
274− define setup
275− & pqThen session
276− & pqThen (define teardown)
277−:}
278−[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
279−-}
280−```
7+Main repository for the squeel database library.
RELEASE NOTES.mddeleted−1217
@@ -1,1217 +0,0 @@
1−## RELEASE NOTES
2−
3−### Version 0.5
4−
5−Version 0.5 makes a number of large changes and additions to Squeal.
6−I want to thank folks who contributed issues and pull requests;
7−Raveline, rimmington, ilyakooo0, chshersh, reygoch, and more.
8−
9−**Multi-schema support**
10−
11−Previous versions of Squeal only supported definitions in the "public"
12−schema. Squeal 0.5 adds support for multiple schemas with the new kind
13−
14−```Haskell
15−type SchemasType = [(Symbol,SchemaType)]
16−```
17−
18−In order to upgrade your queries, manipulations and definitions from
19−Squeal 0.4, you will have to apply the `Public` type family, which indicates
20−that your only schema is the "public" schema.
21−
22−```Haskell
23−-- Squeal 0.4
24−setup :: Definition '[] Schema
25−
26−-- Squeal 0.5
27−setup :: Definition (Public '[]) (Public Schema)
28−```
29−
30−You can create non-public schemas using `createSchema` and inversely
31−remove them using `dropSchema`. There is also an idempotent
32−`createSchemaIfNotExists`.
33−
34−In order to handle aliases which may refer to non-public schemas, Squeal 0.5
35−introduces `QualifiedAlias`es. A `QualifiedAlias` can be referred to using
36−the `(!)` operator from the `IsQualified` typeclass; but if you want to refer
37−to an alias from the "public" schema, you can continue to use a single
38−overloaded label, no need to write `#public ! #tab`, just write `#tab`.
39−
40−**Top-level statements**
41−
42−As a consequence of multi-schema support, common table expressions that
43−a `Query` or `Manipulation` may refer to had to be broken into a new parameter.
44−Additionally, `Query` gained another new parameter for its outer scope which
45−will be discussed in the next section.
46−
47−To simplify type signatures that you have to write for top-level queries
48−and manipulations, Squeal 0.5 introduces the `Query_` and `Manipulation_`
49−type families.
50−
51−```
52−type family Query_
53− (schemas :: SchemasType)
54− (parameters :: Type)
55− (row :: Type) where
56− Query_ schemas params row =
57− Query '[] '[] schemas (TuplePG params) (RowPG row)
58−```
59−
60−As you see, a top-level `Query_` has no outer scope and no common
61−table expressions in scope, they are empty `'[]`. Moreover,
62−its parameters and row parameters are now `Type`s, which are
63−converted to corresponding Postgres types using the `TuplePG`
64−and `RowPG` type families. This means you can write the type signatures
65−for your top-level statements using the Haskell types that you
66−intend to input and retrieve when running the statements. Similar
67−to `Query_`, there is a `Manipulation_` type, the only difference
68−being that a general `Manipulation` doesn't have an outer scope,
69−only a scope for common table expressions.
70−
71−**Subquery expressions**
72−
73−Previous versions of Squeal offered subquery expression support
74−but there were issues. The common use case of using the `IN` operator
75−from SQL was overly complex. There was a proliferation of subquery
76−functions to handle different comparison operators, each with two versions
77−for comparing `ALL` or `ANY` of the query rows. And, most confoundedly,
78−there was no way to support the `EXISTS` subquery because the "outer scope"
79−for a query was not available.
80−
81−Squeal adds an outer scope to the `Query` type.
82−
83−```Haskell
84−newtype Query
85− (outer :: FromType)
86− (commons :: FromType)
87− (schemas :: SchemasType)
88− (params :: [NullityType])
89− (row :: RowType)
90− = UnsafeQuery { renderQuery :: ByteString }
91−```
92−
93−This enables a well-typed `exists` function.
94−
95−```Haskell
96−exists
97− :: Query (Join outer from) commons schemas params row
98− -> Condition outer commons grp schemas params from
99−```
100−
101−The `in_` and `notIn` functions were simplified to handle the most
102−common use case of comparing to a list of values.
103−
104−```Haskell
105−in_
106− :: Expression outer commons grp schemas params from ty -- ^ expression
107− -> [Expression outer commons grp schemas params from ty]
108− -> Condition outer commons grp schemas params from
109−```
110−
111−Finally, general subquery comparisons were abstracted to work with
112−any comparison operators, using the `Operator` type which will be discussed in
113−the next section.
114−
115−```Haskell
116−subAll
117− :: Expression outer commons grp schemas params from ty1
118− -> Operator ty1 ty2 ('Null 'PGbool)
119− -> Query (Join outer from) commons schemas params '[col ::: ty2]
120− -> Condition outer commons grp schemas params from
121−
122−subAny
123− :: Expression outer commons grp schemas params from ty1
124− -> Operator ty1 ty2 ('Null 'PGbool)
125− -> Query (Join outer from) commons schemas params '[col ::: ty2]
126− -> Condition outer commons grp schemas params from
127−```
128−
129−**Expression RankNTypes**
130−
131−Squeal 0.5 introduces RankNType type synonyms for common expression patterns.
132−The simplest example is the `Expr` type, a type for "closed" expressions
133−that cannot reference any aliases or parameters.
134−
135−```Haskell
136−type Expr x
137− = forall outer commons grp schemas params from
138− . Expression outer commons grp schemas params from x
139−```
140−
141−There is also a function type `(-->)`, which is a subtype of the usual Haskell function
142−type `(->)`.
143−
144−```Haskell
145−type (-->) x y
146− = forall outer commons grp schemas params from
147− . Expression outer commons grp schemas params from x
148− -> Expression outer commons grp schemas params from y
149−```
150−
151−We saw in the subquery section that there is an `Operator` type.
152−
153−```Haskell
154−type Operator x1 x2 y
155− = forall outer commons grp schemas params from
156− . Expression outer commons grp schemas params from x1
157− -> Expression outer commons grp schemas params from x2
158− -> Expression outer commons grp schemas params from y
159−```
160−
161−There are also types `FunctionN` and `FunctionVar` for n-ary functions
162−and variadic functions.
163−
164−```
165−type FunctionN xs y
166− = forall outer commons grp schemas params from
167− . NP (Expression outer commons grp schemas params from) xs
168− -> Expression outer commons grp schemas params from y
169−```
170−
171−An n-ary function takes an `NP` list of `Expression`s as its argument.
172−Squeal 0.5 adds a helpful operator `(*:)`, to help scrap your `Nil`s.
173−You can construct an `NP` list now by using the operator `(:*)`,
174−until your last element, using `(*:)` there. For instance, the function
175−`atan2_` takes two arguments, `atan2_ (pi *: 2)`.
176−
177−**Selections**
178−
179−Previously, Squeal provided a couple versions of `SELECT` depending
180−on whether you wanted to select all columns of a unique table
181−in the from clause, i.e. `*`, all columns of a particular table
182−in the from clause, i.e. `.*`, or a list of columns from the from clause.
183−
184−Squeal 0.5 refactors this pattern into a `Selection` GADT type, allowing
185−for abstraction and combinations that were not possible before.
186−
187−```Haskell
188−data Selection outer commons grp schemas params from row where
189− Star
190− :: HasUnique tab from row
191− => Selection outer commons 'Ungrouped schemas params from row
192− DotStar
193− :: Has tab from row
194− => Alias tab
195− -> Selection outer commons 'Ungrouped schemas params from row
196− List
197− :: SListI row
198− => NP (Aliased (Expression outer commons grp schemas params from)) row
199− -> Selection outer commons grp schemas params from row
200− Over
201− :: SListI row
202− => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
203− -> WindowDefinition outer commons grp schemas params from
204− -> Selection outer commons grp schemas params from row
205− Also
206− :: Selection outer commons grp schemas params from right
207− -> Selection outer commons grp schemas params from left
208− -> Selection outer commons grp schemas params from (Join left right)
209−```
210−
211−In addition to the `Star`, `DotStar` and `List` constructors, there is an
212−`Also` constructor combinator, which enables users to combine `Selection`s.
213−Additionally, there is an `Over` constructor that is used to enable
214−window functions, described in the next section.
215−
216−To upgrade from Squeal 0.4, you will replace `selectStar` with `select Star`,
217−replace `selectDotStar #tab` with `select (DotStar #tab)`. The `List`
218−selection is such a common use case that there is a function `select_` which
219−automatically applies it, so to upgrade from Squeal 0.4, replace `select`
220−with `select_`. There are also independent `selectDistinct` and `selectDistinct_`
221−functions to filter out duplicate rows.
222−
223−**Query clauses**
224−
225−Previously, Squeal provided a couple versions of `INSERT` depending
226−on whether you wanted to insert `VALUES` or a query.
227−
228−Squeal 0.5 refactors this pattern into a `QueryClause` GADT.
229−
230−```
231−-- Squeal 0.4
232−insertRow_ #tab (Set 2 `as` #col1 :* Default `as` #col2)
233−insertQuery_ #tab (selectStar (from (table #other_tab)))
234−
235−-- Squeal 0.5
236−insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))
237−insertInto_ #tab (Subquery (select Star (from (table #other_tab))))
238−```
239−
240−**Window functions and aggregation**
241−
242−Previous versions of Squeal provided no support for window functions.
243−Squeal 0.5 adds support for window functions. We saw `Over` in the
244−previous section.
245−
246−```Haskell
247−Over
248− :: SListI row
249− => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
250− -> WindowDefinition outer commons grp schemas params from
251− -> Selection outer commons grp schemas params from row
252−```
253−
254−`Over` combines window functions with window definitions. A `WindowDefinition`
255−is constructed using the `partitionBy` function, optionally with an `orderBy`
256−clause. For example,
257−
258−```Haskell
259−query :: Query_ (Public Schema) () (Row Int32 Int32)
260−query = select
261− (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
262− (from (table #tab))
263−```
264−
265−Here the `rank` function is a `WindowFunction`
266−
267−```Haskell
268−rank :: WinFun0 ('NotNull 'PGint8)
269−rank = UnsafeWindowFunction "rank()"
270−```
271−
272−`WinFun0` is a RankNType, like `Expr` was, used for no argument window functions.
273−Similarly, there are also `WinFun1` and `WinFunN` types for
274−window functions and n-ary window functions.
275−
276−In order to use the same syntax for certain window functions and aggregate functions,
277−a new typeclass `Aggregate` was introduced. So for instance, `sum_` can be
278−either a `Distinction` `Expression` or a `WindowFunction`, used either with
279−a `groupBy` or with a `partitionBy` in the appropriate way.
280−
281−```
282−data Distinction (expr :: kind -> Type) (ty :: kind)
283− = All (expr ty)
284− | Distinct (expr ty)
285−```
286−
287−Aggregate functions can be run over all rows or only over distinct rows,
288−while window functions bear no such distinction.
289−
290−**Migrations**
291−
292−Thanks to [https://github.com/Raveline](Raveline) Squeal 0.5 introduces
293−a function `defaultMain` to easily create a command line program to
294−run or rewind your migrations.
295−
296−Previously, Squeal's migrations were impure, allowing in addition to
297−running `Definition`s to run arbitrary `IO` operations, such as inserting
298−data into the database or printing out status messages. In order to
299−provide compatibility with other migration systems, Squeal 0.5 introduces
300−pure migrations, that is migrations that are only `Definition`s.
301−
302−```Haskell
303−data Migration p schemas0 schemas1 = Migration
304− { name :: Text -- ^ The `name` of a `Migration`.
305− -- Each `name` in a `Migration` should be unique.
306− , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.
307− , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.
308− } deriving (GHC.Generic)
309−```
310−
311−A pure migration is a `Migration Definition`, a pair of inverse
312−`Definition`s with a unique name. To recover impure migrations, Squeal 0.5
313−introduces the `Terminally` type.
314−
315−```Haskell
316−newtype Terminally trans monad x0 x1 = Terminally
317− { runTerminally :: trans x0 x1 monad () }
318−```
319−
320−`Terminally` applies the indexed monad transformer and the monad it transforms
321−to the unit type `()`, thereby turning an indexed monad into a `Category`. An
322−impure migration is a `Migration (Terminally PQ IO)`. You can always cast
323−a pure migration into an impure migration with the functor, `pureMigration`.
324−
325−```Haskell
326−pureMigration
327− :: Migration Definition schemas0 schemas1
328− -> Migration (Terminally PQ IO) schemas0 schemas1
329−```
330−
331−To run either pure or impure migrations, Squeal 0.5 introduces
332−a typeclass, `Migratory`.
333−
334−```
335−class Category p => Migratory p where
336−
337− migrateUp
338− :: AlignedList (Migration p) schemas0 schemas1
339− -> PQ schemas0 schemas1 IO ()
340−
341− migrateDown
342− :: AlignedList (Migration p) schemas0 schemas1
343− -> PQ schemas1 schemas0 IO ()
344−```
345−
346−The signatures of `migrateUp` and `migrateDown` have been changed
347−to make them easier to compose with other `PQ` actions.
348−
349−**Transactions**
350−
351−You can now run transactions `ephemerally`, guaranteed to roll back,
352−but return the result or throw the exception that the transaction
353−would have generated. This is useful for testing. You can also
354−`transactionallyRetry` computations, retrying the transaction if
355−a [serialization failure](https://www.postgresql.org/docs/11/transaction-iso.html#XACT-REPEATABLE-READ) occurs.
356−
357−**Types**
358−
359−Squeal now supports money via a `Money` Haskell `Type` and a `'PGmoney`
360−`PGType`. Squeal 0.5 also adds support for creating domain types
361−with `createDomain`.
362−
363−**Time**
364−
365−Squeal 0.5 adds support for new functions; `now`, `makeDate`, `makeTime`,
366−, `makeTimestamp`, and `makeTimestamptz`, a function `interval_` for
367−constructing time intervals out multiples of `TimeUnit`s, and a new
368−`TimeOp` class, defining affine space operators for time types and their
369−differences.
370−
371−**Literals**
372−
373−Squeal allows you to include Haskell values in your statements using
374−out of line `parameter`s, but often you want to include them inline,
375−as a SQL `literal`. Squeal 0.5 enables this using the `Literal` class.
376−
377−**Set returning functions**
378−
379−Squeal 0.5 adds support for set returning functions such as `unnest`,
380−with the `RankNType` `SetOfFunction`, which can be used as as a `FromClause`.
381−
382−**Text search**
383−
384−Squeal 0.5 adds extensive support for text search types, functions and operators.
385−
386−**Much more**
387−
388−Lots more changes went into and under the hood of the new version.
389−The `Expression` module was split into coherent submodules since it
390−had grown to immense proportions. New modules `Alias`, `PG` and `List`
391−were added to relieve some of the burden that the `Schema` module
392−had been carrying. Rendering has been better unified with a new
393−`RenderSQL` typeclass. Type level list concatenation with the `Additional`
394−typeclass has been added. `Manipulation`s `update` and `delete`
395−were upgraded, so you can leave out fields you don't want to update and
396−use `USING` clauses in deletes. Upserts which were previously broken
397−now work. The `IO` typeclass hierarchy was changed from `MonadBase`
398−and `MonadBaseControl` to `MonadIO` and `MonadUnliftIO`. A new
399−`withRecursive` `Manipulation` was added. `SquealException`s were
400−refactored and a `trySqueal` function added. Arrays were refactored.
401−And there was probably more I've forgotten.
402−
403−### Version 0.4
404−
405−Version 0.4 strengthens Squeal's type system, adds
406−support for multidimensional arrays, improves support
407−for container type, improves `with` statements,
408−improves runtime exceptions, accomodates SQL's three-valued logic,
409−adds subquery expressions, and adds table and view type expressions.
410−
411−**Types**
412−
413−Squeal 0.4 renames some kinds to aid intuition:
414−
415−```Haskell
416−type RowType = [(Symbol, NullityType)] -- previously RelationType
417−type FromType = [(Symbol, RowType)] -- previously RelationsType
418−```
419−
420−Null safety for array and composite types is gained by having the base
421−type of an array be a `NullityType` and the base type of a composite
422−a `RowType`.
423−
424−```Haskell
425−data PGType
426− = ..
427− | PGvararray NullityType
428− | PGfixarray Nat NullityType
429− | PGcomposite RowType
430−```
431−
432−Squeal embeds Postgres types into Haskell using data kinds and type-in-type:
433−
434−```Haskell
435−data PGType = PGbool | ..
436−data NullityType = Null PGType | NotNull PGType
437−type RowType = [(Symbol, NullityType)] -- previously RelationType
438−type FromType = [(Symbol, RowType)] -- previously RelationsType
439−```
440−
441−In another sense, we can embed Haskell types
442−into Postgres types by providing type families:
443−
444−```Haskell
445−type family PG (hask :: Type) :: PGType
446−type family NullPG (hask :: Type) :: NullityType
447−type family TuplePG (hask :: Type) :: [NullityType]
448−type family RowPG (hask :: Type) :: RowType
449−```
450−
451−Let's look at these one by one.
452−
453−`PG` was introduced in Squeal 0.3. It was a closed type family that
454−associates some Haskell types to their obvious corresponding Postgres
455−types like `PG Double = 'PGfloat8`. It only worked on base types,
456−no arrays or composites. Squeal 0.4 extends it to
457−such container types and makes it an open type family so that
458−users can make their own type instances.
459−
460−`NullPG` had a different name before but it does the obvious
461−thing for Haskell with `Maybe`s:
462−
463−```Haskell
464−type family NullPG hask where
465− NullPG (Maybe hask) = 'Null (PG hask)
466− NullPG hask = 'NotNull (PG hask)
467−```
468−
469−`TuplePG` uses generics to turn tuple types (including records)
470−into lists of `NullityType`s in the logical way, e.g.
471−`TuplePG (Bool, Day) = '[ 'PGbool, 'PGdate]`.
472−
473−`RowPG` also uses generics to turn record types into a `RowType` in the logical way, e.g.
474−
475−```Haskell
476−>>> data Person = Person { name :: Text, age :: Int32 } deriving GHC.Generic
477−>>> instance SOP.Generic Person
478−>>> instance SOP.HasDatatypeInfo Person
479−>>> :kind! TuplePG Person
480−TuplePG Person :: [NullityType]
481−= '['NotNull 'PGtext, 'NotNull 'PGint4]
482−>>> :kind! RowPG Person
483−RowPG Person :: [(Symbol, NullityType)]
484−= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
485−```
486−
487−We've already seen a hint of why these types are useful in one construction
488−from Squeal 0.3. Creating composite types in Postgres directly from a Haskell
489−record type essentially uses `RowPG`. Another important use is in simplifying
490−the type signatures for a `Query` or `Manipulation`. Very often, you will have
491−a tuple type corresponding to the parameters and a record type corresponding
492−to the returned columns of a `Query` or `Manipulation`. Instead of writing
493−boilerplate signature you can reuse these with the help of `TuplePG` and `RowPG`
494−
495−For instance:
496−
497−```Haskell
498−>>> :{
499−let
500− query :: Query '["user" ::: 'View (RowPG Person)] (TuplePG (Only Int32)) (RowPG Person)
501− query = selectStar (from (view #user) & where_ (#age .> param @1))
502−:}
503−```
504−
505−**Arrays**
506−
507−In addition to being able to encode and decode basic Haskell types
508−like `Int16` and `Text`, Squeal 0.4 permits you to encode and decode Haskell types to
509−Postgres array types. The `Vector` type corresponds to to variable length arrays.
510−And thanks to an idea from [Mike Ledger](https://github.com/mikeplus64),
511−homogeneous tuples correspond to fixed length arrays. We can even
512−create multi-dimensional fixed length arrays. Let's see an example.
513−
514−```Haskell
515−>>> :{
516−data Row = Row
517− { col1 :: Vector Int16
518− , col2 :: (Maybe Int16,Maybe Int16)
519− , col3 :: ((Int16,Int16),(Int16,Int16),(Int16,Int16))
520− } deriving (Eq, GHC.Generic)
521−:}
522−
523−>>> instance Generic Row
524−>>> instance HasDatatypeInfo Row
525−```
526−
527−Define a simple round trip query.
528−
529−```Haskell
530−>>> :{
531−let
532− roundTrip :: Query '[] (TuplePG Row) (RowPG Row)
533− roundTrip = values_ $
534− parameter @1 (int2 & vararray) `as` #col1 :*
535− parameter @2 (int2 & fixarray @2) `as` #col2 :*
536− parameter @3 (int2 & fixarray @2 & fixarray @3) `as` #col3
537−:}
538−
539−>>> :set -XOverloadedLists
540−>>> let input = Row [1,2] (Just 1,Nothing) ((1,2),(3,4),(5,6))
541−>>> :{
542−void . withConnection "host=localhost port=5432 dbname=exampledb" $ do
543− result <- runQueryParams roundTrip input
544− Just output <- firstRow result
545− liftBase . print $ input == output
546−:}
547−True
548−```
549−
550−**Containers**
551−
552−Squeal aims to provide a correspondence between Haskell types and Postgres types.
553−In particular, Haskell ADTs with nullary constructors can correspond to
554−Postgres enum types and Haskell record types can correspond to Postgres
555−composite types. However, it's not always obvious that that's how a user
556−will choose to store values of those types. So Squeal 0.4 introduces newtypes
557−whose purpose is to specify how a user wants to store values of a type.
558−
559−```Haskell
560−newtype Json hask = Json {getJson :: hask}
561−newtype Jsonb hask = Jsonb {getJsonb :: hask}
562−newtype Composite record = Composite {getComposite :: record}
563−newtype Enumerated enum = Enumerated {getEnumerated :: enum}
564−```
565−
566−Let's see an example:
567−
568−```Haskell
569−>>> data Schwarma = Beef | Lamb | Chicken deriving (Eq, Show, GHC.Generic)
570−>>> instance SOP.Generic Schwarma
571−>>> instance SOP.HasDatatypeInfo Schwarma
572−>>>
573−>>> data Person = Person {name :: Text, age :: Int32} deriving (Eq, Show, GHC.Generic)
574−>>> instance SOP.Generic Person
575−>>> instance SOP.HasDatatypeInfo Person
576−>>> instance Aeson.FromJSON Person
577−>>> instance Aeson.ToJSON Person
578−```
579−
580−We can create the equivalent Postgres types directly from their Haskell types.
581−
582−```Haskell
583−>>> :{
584−type Schema =
585− '[ "schwarma" ::: 'Typedef (PG (Enumerated Schwarma))
586− , "person" ::: 'Typedef (PG (Composite Person))
587− ]
588−:}
589−
590−>>> :{
591−let
592− setup :: Definition '[] Schema
593− setup =
594− createTypeEnumFrom @Schwarma #schwarma >>>
595− createTypeCompositeFrom @Person #person
596−:}
597−```
598−
599−Let's demonstrate how to associate our Haskell types `Schwarma` and `Person`
600−with enumerated, composite or json types in Postgres. First create a Haskell
601−`Row` type using the `Enumerated`, `Composite` and `Json` newtypes as fields.
602−
603−```Haskell
604−>>> :{
605−data Row = Row
606− { schwarma :: Enumerated Schwarma
607− , person1 :: Composite Person
608− , person2 :: Json Person
609− } deriving (Eq, GHC.Generic)
610−:}
611−
612−>>> instance Generic Row
613−>>> instance HasDatatypeInfo Row
614−>>> :{
615−let
616− input = Row
617− (Enumerated Chicken)
618− (Composite (Person "Faisal" 24))
619− (Json (Person "Ahmad" 48))
620−:}
621−```
622−
623−Once again, define a round trip query.
624−
625−```Haskell
626−>>> :{
627−let
628− roundTrip :: Query Schema (TuplePG Row) (RowPG Row)
629− roundTrip = values_ $
630− parameter @1 (typedef #schwarma) `as` #schwarma :*
631− parameter @2 (typedef #person) `as` #person1 :*
632− parameter @3 json `as` #person2
633−:}
634−```
635−
636−Finally, we can drop our type definitions.
637−
638−```Haskell
639−>>> :{
640−let
641− teardown :: Definition Schema '[]
642− teardown = dropType #schwarma >>> dropType #person
643−:}
644−```
645−
646−Now let's run it.
647−
648−```Haskell
649−>>> :{
650−let
651− session = do
652− result <- runQueryParams roundTrip input
653− Just output <- firstRow result
654− liftBase . print $ input == output
655−in
656− void . withConnection "host=localhost port=5432 dbname=exampledb" $
657− define setup
658− & pqThen session
659− & pqThen (define teardown)
660−:}
661−True
662−```
663−
664−**With**
665−
666−Squeal 0.3 supported WITH statements but there's a couple problems with them.
667−Here's the type signature for `with` in Squeal 0.3.
668−
669−```Haskell
670−with
671− :: SOP.SListI commons
672− => NP (Aliased (Manipulation schema params)) (common ': commons)
673− -- ^ common table expressions
674− -> Manipulation (With (common ': commons) schema) params results
675− -> Manipulation schema params results
676−```
677−
678−The first problem is that `with` only works with `Manipulations`.
679−It can work on `Query`s by using `queryStatement` but it still will
680−return a `Manipulation`. We can fix this issue by making `with` a
681−method of a type class with instances for both `Query` and `Manipulation`.
682−
683−The second problem is that all the common table expressions
684−refer the base schema, whereas in SQL, each subsequent CTE can
685−refer to previous CTEs as well. But this can be fixed! First define a datatype:
686−
687−```Haskell
688−data CommonTableExpression statement params schema0 schema1 where
689− CommonTableExpression
690− :: Aliased (statement schema params) (alias ::: cte)
691− -> CommonTableExpression statement params schema (alias ::: 'View cte ': schema)
692−```
693−
694−It's just a wrapper around an aliased statement, where the statement
695−could be either a `Query` or `Manipulation`, but it augments the schema
696−by adding a view to it. It almost looks like a morphism between schemas
697−but there is no way yet to compose them. Luckily, Squeal already has
698−a datatype for this, which is used for migrations, the `AlignedList`
699−type which is really the "free category". So we can then define a `With` type class:
700−
701−```Haskell
702−class With statement where
703− with
704− :: AlignedList (CommonTableExpression statement params) schema0 schema1
705− -> statement schema1 params row
706− -> statement schema0 params row
707−```
708−
709−By giving `Aliasable` instances to CTEs and aligned singleton lists of CTEs (i.e. scrap-your-nils), we get a nice syntax for WITH statements in Squeal.
710−
711−Here's an example of using `with` for a `Query` and a `Manipulation`:
712−
713−```Haskell
714−>>> :{
715−let
716− query :: Query
717− '[ "t1" ::: 'View
718− '[ "c1" ::: 'NotNull 'PGtext
719− , "c2" ::: 'NotNull 'PGtext] ]
720− '[]
721− '[ "c1" ::: 'NotNull 'PGtext
722− , "c2" ::: 'NotNull 'PGtext ]
723− query = with (
724− selectStar (from (view #t1)) `as` #t2 :>>
725− selectStar (from (view #t2)) `as` #t3
726− ) (selectStar (from (view #t3)))
727−in printSQL query
728−:}
729−WITH "t2" AS (SELECT * FROM "t1" AS "t1"), "t3" AS (SELECT * FROM "t2" AS "t2") SELECT * FROM "t3" AS "t3"
730−
731−>>> type ProductsTable = '[] :=> '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]
732−
733−>>> :{
734−let
735− manipulation :: Manipulation
736− '[ "products" ::: 'Table ProductsTable
737− , "products_deleted" ::: 'Table ProductsTable
738− ] '[ 'NotNull 'PGdate] '[]
739− manipulation = with
740− (deleteFrom #products (#date .< param @1) ReturningStar `as` #deleted_rows)
741− (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rows `as` #t)))))
742−in printSQL manipulation
743−:}
744−WITH "deleted_rows" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "deleted_rows" AS "t"
745−```
746−
747−**Three Valued Logic**
748−
749−In previous versions of Squeal, conditions followed classical two valued logic
750−of `true` and `false`.
751−
752−```Haskell
753−-- Squeal 0.3
754−type Condition schema from grouping params =
755− Expression schema from grouping params ('NotNull 'PGbool)
756−```
757−
758−I had thought that three valued logic, which is what SQL uses, was confusing.
759−However, multiple users reported being confused at being forced to do `NULL`
760−handling, particularly in their left joins. Since the original motivation
761−of being less confusing evaporated I decided to switch to three valued logic
762−of `true`, `false` and `null_`.
763−
764−```Haskell
765−-- Squeal 0.4
766−type Condition schema from grouping params =
767− Expression schema from grouping params ('Null 'PGbool)
768−```
769−
770−**Subquery Expressions**
771−
772−Squeal 0.4 adds support for subquery expressions such as `IN` and `op ANY/ALL`.
773−
774−**Row Types**
775−
776−Squeal 0.4 adds functions to define type expressions from tables and views
777−and a type expression for user defined types, `typetable`, `typeview` and
778−`typedef`.
779−
780−**Runtime Exceptions**
781−
782−Squeal now has an exception type which gives details on the sort of error
783−encountered and handler functions.
784−
785−```Haskell
786−data SquealException
787− = PQException
788− { sqlExecStatus :: LibPQ.ExecStatus
789− , sqlStateCode :: Maybe ByteString
790− -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html
791− , sqlErrorMessage :: Maybe ByteString
792− }
793− | ResultException Text
794− | ParseException Text
795− deriving (Eq, Show)
796−instance Exception SquealException
797−
798−catchSqueal
799− :: MonadBaseControl IO io
800− => io a
801− -> (SquealException -> io a) -- ^ handler
802− -> io a
803−
804−handleSqueal
805− :: MonadBaseControl IO io
806− => (SquealException -> io a) -- ^ handler
807− -> io a -> io a
808−```
809−
810−**Additional Changes**
811−
812−Squeal 0.4 adds `field` and `index` functions to get components of composite
813−and array expressions.
814−
815−Squeal 0.4 adds a dependency on `records-sop` to offload a lot of boilerplate
816−type family logic that was needed for `RowPG`.
817−
818−The above changes required major and minor changes to Squeal DSL functions.
819−Please consult the documentation.
820−
821−### Version 0.3.2 - August 4, 2018
822−
823−Version 0.3.2 features extensive support for `JSON` functionality with
824−more than 50 new functions.
825−This work is entirely due to [Mike Ledger](https://github.com/mikeplus64)
826−who has been making terrific contributions to Squeal. Thanks!
827−We also got some examples in the documentation for pools submitted by
828−[Raveline](https://github.com/Raveline). I'm so pleased to be
829−getting pull requests and issue submissions from you all!
830−
831−### Version 0.3.1 - July 7, 2018
832−
833−Version 0.3.1 of Squeal enables the "Scrap your Nils" trick for
834−heterogeneous lists of `Alias`es, `Aliased` expressions, `PGlabel`s and `By`s
835−with the typeclasses `IsLabel`, `IsQualified`, `IsPGlabel`,
836−and the new `Aliasable` typeclass, to eliminate all need of using `Nil` in a list.
837−There were a couple minor name changes, i.e. the function `group` was renamed to `groupBy`.
838−Please consult the documentation.
839−
840−### Version 0.3 - June 26, 2018
841−
842−Version 0.3 of Squeal adds views as well as composite and enumerated types to Squeal.
843−To support these features, a new kind `SchemumType` was added.
844−
845−```Haskell
846−data SchemumType
847− = Table TableType
848− | View RelationType
849− | Typedef PGType
850−```
851−
852−As a consequence, you will have to update your schema definitions like so:
853−
854−```Haskell
855−-- Squeal 0.2
856−type Schema =
857− '[ "users" :::
858− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
859− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
860− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
861− ]
862− ]
863−
864−-- Squeal 0.3
865−type Schema =
866− '[ "users" ::: 'Table (
867− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
868− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
869− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
870− ])
871− ]
872−```
873−
874−**Views**
875−
876−You can now create, drop, and query views.
877−
878−```Haskell
879−>>> :{
880−type ABC =
881− ('[] :: TableConstraints) :=>
882− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
883− , "b" ::: 'NoDef :=> 'Null 'PGint4
884− , "c" ::: 'NoDef :=> 'Null 'PGint4
885− ]
886−type BC =
887− '[ "b" ::: 'Null 'PGint4
888− , "c" ::: 'Null 'PGint4
889− ]
890−:}
891−
892−>>> :{
893−let
894− definition :: Definition '["abc" ::: 'Table ABC ] '["abc" ::: 'Table ABC, "bc" ::: 'View BC]
895− definition = createView #bc (select (#b :* #c :* Nil) (from (table #abc)))
896−in printSQL definition
897−:}
898−CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
899−
900−>>> :{
901−let
902− definition :: Definition '["abc" ::: 'Table ABC, "bc" ::: 'View BC] '["abc" ::: 'Table ABC]
903− definition = dropView #bc
904−in printSQL definition
905−:}
906−DROP VIEW "bc";
907−
908−>>> :{
909−let
910− query :: Query '["abc" ::: 'Table ABC, "bc" ::: 'View BC] '[] BC
911− query = selectStar (from (view #bc))
912−in printSQL query
913−:}
914−SELECT * FROM "bc" AS "bc"
915−```
916−
917−**Enumerated Types**
918−
919−PostgreSQL has a powerful type system. It even allows for user defined types.
920−For instance, you can define enumerated types which are data types that comprise
921−a static, ordered set of values. They are equivalent to Haskell algebraic data
922−types whose constructors are nullary. An example of an enum type might be the days of the week,
923−or a set of status values for a piece of data.
924−
925−Enumerated types are created using the `createTypeEnum` command, for example:
926−
927−```Haskell
928−>>> :{
929−let
930− definition :: Definition '[] '["mood" ::: 'Typedef ('PGenum '["sad", "ok", "happy"])]
931− definition = createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil)
932−:}
933−>>> printSQL definition
934−CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
935−```
936−
937−Enumerated types can also be generated from a Haskell algebraic data type with nullary constructors, for example:
938−
939−```Haskell
940−>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
941−>>> instance SOP.Generic Schwarma
942−>>> instance SOP.HasDatatypeInfo Schwarma
943−
944−>>> :kind! EnumFrom Schwarma
945−EnumFrom Schwarma :: PGType
946−= 'PGenum '["Beef", "Lamb", "Chicken"]
947−
948−>>> :{
949−let
950− definition :: Definition '[] '["schwarma" ::: 'Typedef (EnumFrom Schwarma)]
951− definition = createTypeEnumFrom @Schwarma #schwarma
952−:}
953−>>> printSQL definition
954−CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
955−```
956−
957−You can express values of an enum type using `label`, which is an overloaded method
958−of the `IsPGlabel` typeclass.
959−
960−```Haskell
961−>>> :{
962−let
963− expression :: Expression sch rels grp params ('NotNull (EnumFrom Schwarma))
964− expression = label @"Chicken"
965−in printSQL expression
966−:}
967−'Chicken'
968−```
969−
970−**Composite Types**
971−
972−In addition to enum types, you can define composite types.
973−A composite type represents the structure of a row or record;
974−it is essentially just a list of field names and their data types.
975−
976−
977−`createTypeComposite` creates a composite type. The composite type is
978−specified by a list of attribute names and data types.
979−
980−```Haskell
981−>>> :{
982−let
983− definition :: Definition '[] '["complex" ::: 'Typedef ('PGcomposite '["real" ::: 'PGfloat8, "imaginary" ::: 'PGfloat8])]
984− definition = createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil)
985−:}
986−>>> printSQL definition
987−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
988−```
989−
990−Composite types are almost equivalent to Haskell record types.
991−However, because of the potential presence of `NULL`
992−all the record fields must be `Maybe`s of basic types.
993−Composite types can be generated from a Haskell record type, for example:
994−
995−```Haskell
996−>>> data Complex = Complex {real :: Maybe Double, imaginary :: Maybe Double} deriving GHC.Generic
997−>>> instance SOP.Generic Complex
998−>>> instance SOP.HasDatatypeInfo Complex
999−
1000−>>> :kind! CompositeFrom Complex
1001−CompositeFrom Complex :: PGType
1002−= 'PGcomposite '['("real", 'PGfloat8), '("imaginary", 'PGfloat8)]
1003−
1004−>>> :{
1005−let
1006− definition :: Definition '[] '["complex" ::: 'Typedef (CompositeFrom Complex)]
1007− definition = createTypeCompositeFrom @Complex #complex
1008−in printSQL definition
1009−:}
1010−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
1011−```
1012−
1013−A row constructor is an expression that builds a row value
1014−(also called a composite value) using values for its member fields.
1015−
1016−```Haskell
1017−>>> :{
1018−let
1019− i :: Expression '[] '[] 'Ungrouped '[] ('NotNull (CompositeFrom Complex))
1020− i = row (0 `As` #real :* 1 `As` #imaginary :* Nil)
1021−:}
1022−>>> printSQL i
1023−ROW(0, 1)
1024−```
1025−
1026−You can also use `(&)` to apply a field label to a composite value.
1027−
1028−```Haskell
1029−>>> :{
1030−let
1031− expr :: Expression '[] '[] 'Ungrouped '[] ('Null 'PGfloat8)
1032− expr = i & #imaginary
1033−in printSQL expr
1034−:}
1035−(ROW(0, 1)).imaginary
1036−```
1037−
1038−Both composite and enum types can be automatically encoded from and decoded to their equivalent Haskell types.
1039−And they can be dropped.
1040−
1041−```Haskell
1042−>>> :{
1043−let
1044− definition :: Definition '["mood" ::: 'Typedef ('PGenum '["sad", "ok", "happy"])] '[]
1045− definition = dropType #mood
1046−:}
1047−>>> printSQL definition
1048−DROP TYPE "mood";
1049−```
1050−
1051−**Additional Changes**
1052−
1053−Squeal 0.3 also introduces a typeclass `HasAll` similar to `Has` but for a list of aliases.
1054−This makes it possible to clean up some unfortunately messy Squeal 0.2 definitions.
1055−
1056−```Haskell
1057−-- Squeal 0.2
1058−>>> unique (Column #a :* Column #b :* Nil)
1059−
1060−-- Squeal 0.3
1061−>>> unique (#a :* #b :* Nil)
1062−```
1063−
1064−Squeal 0.3 also adds `IsLabel` instances for `Aliased` expressions and tables as well as
1065−heterogeneous lists, allowing for some more economy of code.
1066−
1067−```Haskell
1068−-- Squeal 0.2 (or 0.3)
1069−>>> select (#a `As` #a :* Nil) (from (table (#t `As` #t)))
1070−
1071−-- Squeal 0.3
1072−>>> select #a (from (table #t))
1073−```
1074−
1075−Squeal 0.3 also fixes a bug that prevented joined queries on self-referencing tables.
1076−
1077−The above changes required major and minor changes to Squeal DSL functions.
1078−Please consult the documentation.
1079−
1080−### Version 0.2.1 - April 7, 2018
1081−
1082−This minor update fixes an issue where alias identifiers could conflict with
1083−reserved words in PostgreSQL. To fix the issue, alias identifiers are now
1084−quoted. Thanks to Petter Rasmussen for the fix.
1085−
1086−### Version 0.2 - March 26, 2018
1087−
1088−**Changes**
1089−- **Constraints** - Type level table constraints like primary and foreign keys and column constraints like having `DEFAULT`.
1090−- **Migrations** - Support for linear, invertible migrations tracked in an auxiliary table
1091−- **Arrays** - Support for fixed- and variable-length arrays
1092−- **Aliases** - Generalized `Has` constraint
1093−- **Pools** - Support for pooled connections
1094−- **Transactions** - Support for transaction control language
1095−- **Queries, Manipulations, Definitions** - Small and large changes to Squeal's DSL
1096−
1097−Well, a lot of things changed!
1098−
1099−**Constraints**
1100−
1101−An important request was to bring constraints to the type level.
1102−This means that more of the schema is statically known. In `0.1` column constraints - which boil down
1103−to having `DEFAULT` or not - were at the type level, but they were confusingly named.
1104−
1105−```haskell
1106−0.1: 'Optional ('NotNull 'PGInt4)
1107−0.2: 'Def :=> 'NotNull 'PGInt4
1108−0.1: 'Required ('NotNull 'PGInt4)
1109−0.2: 'NoDef :=> 'NotNull 'PGInt4
1110−```
1111−
1112−The `:=>` type operator is intended to helpfully connote a constraint relation.
1113−It's also used for table constraints which are new in `0.2`.
1114−
1115−```haskell
1116−"emails" :::
1117− '[ "pk_emails" ::: 'PrimaryKey '["id"]
1118− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
1119− ] :=>
1120− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
1121− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
1122− , "email" ::: 'NoDef :=> 'Null 'PGtext
1123− ]
1124−```
1125−
1126−Another change in the constraint system was the removal of column constraints from
1127−query and manipulation results, as result columns don't support a notion of `DEFAULT`.
1128−This necessitates a distinction between `TableType`s which have both column and table
1129−constraints and `RelationType`s which have neither.
1130−
1131−**Migrations**
1132−
1133−Migrations are a hot topic and many people have requested this feature. Squeal `0.2`
1134−adds support for linear, invertible migrations. That is, a migration is a named,
1135−invertible, schema-tracking computation:
1136−
1137−```haskell
1138−data Migration io schema0 schema1 = Migration
1139− { name :: Text -- ^ The `name` of a `Migration`.
1140− -- Each `name` in a `Migration` should be unique.
1141− , up :: PQ schema0 schema1 io () -- ^ The `up` instruction of a `Migration`.
1142− , down :: PQ schema1 schema0 io () -- ^ The `down` instruction of a `Migration`.
1143− }
1144−```
1145−
1146−And, `Migration`s can be put together in an "aligned" list:
1147−
1148−```haskell
1149−data AlignedList p x0 x1 where
1150− Done :: AlignedList p x x
1151− (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2
1152−```
1153−
1154−These aligned lists are free categories and might look familiar from
1155−the [reflections without remorse](http://okmij.org/ftp/Haskell/zseq.pdf) technique,
1156−which uses their cousins, aligned sequences.
1157−
1158−In the context of migration, they allow one to chain new migrations as a
1159−schema evolves over time. `Migration`s' execution is tracked in an auxiliary
1160−migrations table. Migration lists can then be run or rewinded.
1161−
1162−```haskell
1163−migrateUp
1164− :: MonadBaseControl IO io
1165− => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run
1166− -> PQ
1167− ("schema_migrations" ::: MigrationsTable ': schema0)
1168− ("schema_migrations" ::: MigrationsTable ': schema1)
1169− io ()
1170−
1171−migrateDown
1172− :: MonadBaseControl IO io
1173− => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind
1174− -> PQ
1175− ("schema_migrations" ::: MigrationsTable ': schema1)
1176− ("schema_migrations" ::: MigrationsTable ': schema0)
1177− io ()
1178−```
1179−
1180−**Aliases**
1181−
1182−In Squeal `0.1`, we had different typeclasses `HasColumn` and `HasTable` to indicate
1183−that a table has a column or that a schema has a table. In Squeal `0.2` this has been
1184−unified to a single typeclass,
1185−
1186−```haskell
1187−class KnownSymbol alias =>
1188− Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
1189− | alias fields -> field where
1190−```
1191−
1192−**Arrays**
1193−
1194−Support for array types has been added to Squeal `0.2` through
1195−the `'PGfixarray` and `'PGvararray` `PGType`s. Array values can be
1196−constructed using the `array` function and can be encoded from and decoded to
1197−Haskell `Vector`s.
1198−
1199−**Pools**
1200−
1201−Squeal `0.2` provides a monad transformer `PoolPQ` that's an instance of `MonadPQ`.
1202−The `resource-pool` library is leveraged to provide striped pools of `Connection`s.
1203−`PoolPQ` should be a drop in replacement for running `Manipulation`s and `Query`s with
1204−`PQ`.
1205−
1206−**Transactions**
1207−
1208−Squeal `0.2` supports a simple transaction control language. A computation in
1209−`MonadPQ` can be called `transactionally` with different levels of isolation.
1210−Additionally, a schema changing computation, a data definition, can be run in a
1211−transaction. Running a computation in a transaction means that all SQL statements
1212−will be rolled back if an exception is encountered.
1213−
1214−**Queries, Manipulations and Definitions**
1215−
1216−The above changes required major and minor changes to Squeal DSL functions.
1217−Please consult the documentation.
circle.ymlnew file+10
@@ -0,0 +1,10 @@
1+dependencies:
2+ cache_directories:
3+ - "~/.stack"
4+ - ".stack-work"
5+ override:
6+ - stack setup
7+ - stack test --no-run-tests
8+test:
9+ override:
10+ - stack test
scrap-your-nils.mddeleted−60
@@ -1,60 +0,0 @@
1−## Scrap your Nils
2−
3−One of the most useful types I've come across in Haskell is the type of
4−"heterogeneous lists". This is the same as the [Rec](http://hackage.haskell.org/package/vinyl-0.8.1.1/docs/Data-Vinyl-Core.html)
5−datatype from the [vinyl](http://hackage.haskell.org/package/vinyl) library.
6−It's also the same as the [NP](http://hackage.haskell.org/package/generics-sop-0.3.2.0/docs/Generics-SOP-NP.html)
7−datatype from the [generics-sop](http://hackage.haskell.org/package/generics-sop) library.
8−Squeal makes heavy use of this type.
9−
10−```Haskell
11−>>> import Generics.SOP (NP(..))
12−>>> :i NP
13−type role NP representational nominal
14−data NP (a :: k -> *) (b :: [k]) where
15− Nil :: forall k (a :: k -> *). NP a '[]
16− (:*) :: forall k (a :: k -> *) (x :: k) (xs :: [k]).
17− (a x) -> (NP a xs) -> NP a (x : xs)
18− -- Defined in ‘Generics.SOP.NP’
19−```
20−
21−This type allows us to construct "product" types, where the types of the individual
22−"terms" are hosted at the type level.
23−
24−```Haskell
25−>>> :set -XDataKinds
26−>>> import Generics.SOP (I(..))
27−>>> let example = I "foo" :* I pi :* Nil :: NP I '[String, Double]
28−>>> example
29−I "foo" :* I 3.141592653589793 :* Nil
30−```
31−
32−One thing Squeal uses `NP` for is to form lists of aliases,
33−using GHC's `OverloadedLabels` extension, hosting the names
34−of the aliases themselves at the type level.
35−
36−```Haskell
37−>>> :set -XKindSignatures -XOverloadedLabels -XFlexibleInstances -XMultiParamTypeClasses
38−>>> import GHC.TypeLits
39−>>> import GHC.OverloadedLabels
40−>>> data Alias (alias :: Symbol) = Alias deriving (Eq,Ord,Show)
41−>>> instance IsLabel label (Alias label) where fromLabel = Alias
42−>>> let aliases = #foo :* #bar :* Nil :: NP Alias '["foo", "bar"]
43−```
44−
45−However, it's very ugly to have to end every list with `:* Nil`.
46−When I announced the release of Squeal, people rightly [complained](https://www.reddit.com/r/haskell/comments/6yr5v6/announcing_squeal_a_deep_embedding_of_sql_in/dmq8vvn)
47−about the syntactic noise. Luckily, there's a neat trick we can use to get rid of it.
48−Making an `IsLabel` instance not only for elements of our list
49−but also for lists of length 1, we can ask GHC to interpret
50−the last label as a list.
51−
52−```Haskell
53−>>> instance IsLabel label (NP Alias '[label]) where fromLabel = Alias :* Nil
54−>>> let aliases' = #foo :* #bar :: NP Alias '["foo", "bar"]
55−```
56−
57−Version 0.3.1 of Squeal enables the "Scrap your Nils" trick for
58−heterogeneous lists of `Alias`es, `Aliased` expressions, `PGlabel`s and `By`s
59−with the typeclasses `IsLabel`, `IsQualified`, `IsPGlabel`,
60−and the new `Aliasable` typeclass, to eliminate all need of using `Nil` in a list.
squeal-postgresql/LICENSEdeleted−31
@@ -1,31 +0,0 @@
1−Copyright (c) 2017 Morphism, LLC
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are
7−met:
8−
9− * Redistributions of source code must retain the above copyright
10− notice, this list of conditions and the following disclaimer.
11−
12− * Redistributions in binary form must reproduce the above
13− copyright notice, this list of conditions and the following
14− disclaimer in the documentation and/or other materials provided
15− with the distribution.
16−
17− * Neither the names of the copyright holders nor the names of the
18− contributors may be used to endorse or promote products derived
19− from this software without specific prior written permission.
20−
21−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
27−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
28−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
30−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
31−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
squeal-postgresql/README.mddeleted−11
@@ -1,11 +0,0 @@
1−# squeal-postgresql
2−
3−![squeal-icon](http://www.emoticonswallpapers.com/emotion/cute-big-pig/cute-pig-smiley-046.gif)
4−
5−[![CircleCI](https://circleci.com/gh/echatav/squeal.svg?style=svg&circle-token=a699a654ef50db2c3744fb039cf2087c484d1226)](https://circleci.com/gh/morphismtech/squeal)
6−
7−[Github](https://github.com/morphismtech/squeal)
8−
9−[Hackage](https://hackage.haskell.org/package/squeal-postgresql)
10−
11−[Stackage](https://www.stackage.org/package/squeal-postgresql)
squeal-postgresql/docs-upload.shdeleted−18
@@ -1,18 +0,0 @@
1−#!/bin/bash
2−
3−# Run this script in the top-level of your package directory
4−# (where the .cabal file is) to compile documentation and
5−# upload it to hackage.
6−
7−# Requirements:
8−# cabal-install-1.24 (for --for-hackage)
9−# haddock 2.17 (for the hyperlinked source)
10−
11−set -e
12−
13−dir=$(mktemp -d dist-docs.XXXXXX)
14−trap 'rm -r "$dir"' EXIT
15−
16−cabal configure --builddir="$dir"
17−cabal haddock --builddir="$dir" --for-hackage --haddock-option=--hyperlinked-source
18−cabal upload -d $dir/*-docs.tar.gz
squeal-postgresql/exe/Example.hsdeleted−125
@@ -1,125 +0,0 @@
1−{-# LANGUAGE
2− DataKinds
3− , DeriveGeneric
4− , FlexibleContexts
5− , OverloadedLabels
6− , OverloadedStrings
7− , OverloadedLists
8− , TypeApplications
9− , TypeOperators
10−#-}
11−
12−module Main (main, main2) where
13−
14−import Control.Monad.IO.Class (MonadIO (..))
15−import Data.Int (Int16, Int32)
16−import Data.Monoid ((<>))
17−import Data.Text (Text)
18−import Data.Vector (Vector)
19−
20−import Squeal.PostgreSQL
21−
22−import qualified Data.ByteString.Char8 as Char8
23−import qualified Generics.SOP as SOP
24−import qualified GHC.Generics as GHC
25−
26−type Schema =
27− '[ "users" ::: 'Table (
28− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
29− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
30− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
31− , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))
32− ])
33− , "emails" ::: 'Table (
34− '[ "pk_emails" ::: 'PrimaryKey '["id"]
35− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
36− ] :=>
37− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
38− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
39− , "email" ::: 'NoDef :=> 'Null 'PGtext
40− ])
41− , "positive" ::: 'Typedef 'PGfloat4
42− ]
43−
44−type Schemas = Public Schema
45−
46−setup :: Definition (Public '[]) Schemas
47−setup =
48− createTable #users
49− ( serial `as` #id :*
50− (text & notNullable) `as` #name :*
51− (vararray int2 & notNullable) `as` #vec )
52− ( primaryKey #id `as` #pk_users )
53− >>>
54− createTable #emails
55− ( serial `as` #id :*
56− hask @Int32 `as` #user_id :*
57− hask @(Maybe Text) `as` #email )
58− ( primaryKey #id `as` #pk_emails :*
59− foreignKey #user_id #users #id
60− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
61− >>>
62− createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
63−
64−teardown :: Definition Schemas (Public '[])
65−teardown = dropType #positive >>> dropTable #emails >>> dropTable #users
66−
67−insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)
68−insertUser = insertInto #users
69− (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #vec))
70− (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly))
71−
72−insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()
73−insertEmail = insertInto_ #emails
74− (Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email))
75−
76−getUsers :: Query_ Schemas () User
77−getUsers = select_
78− (#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec)
79− ( from (table (#users `as` #u)
80− & innerJoin (table (#emails `as` #e))
81− (#u ! #id .== #e ! #user_id)) )
82−
83−data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: VarArray (Vector (Maybe Int16)) }
84− deriving (Show, GHC.Generic)
85−instance SOP.Generic User
86−instance SOP.HasDatatypeInfo User
87−
88−users :: [User]
89−users =
90− [ User "Alice" (Just "alice@gmail.com") (VarArray [Nothing, Just 1])
91− , User "Bob" Nothing (VarArray [Just 2, Nothing])
92− , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3])
93− ]
94−
95−session :: (MonadIO pq, MonadPQ Schemas pq) => pq ()
96−session = do
97− liftIO $ Char8.putStrLn "manipulating"
98− idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])
99− ids <- traverse (fmap fromOnly . getRow 0) idResults
100− traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))
101− liftIO $ Char8.putStrLn "querying"
102− usersResult <- runQuery getUsers
103− usersRows <- getRows usersResult
104− liftIO $ print (usersRows :: [User])
105−
106−main :: IO ()
107−main = do
108− Char8.putStrLn "squeal"
109− connectionString <- pure
110− "host=localhost port=5432 dbname=exampledb"
111− Char8.putStrLn $ "connecting to " <> connectionString
112− connection0 <- connectdb connectionString
113− Char8.putStrLn "setting up schema"
114− connection1 <- execPQ (define setup) connection0
115− connection2 <- execPQ session connection1
116− Char8.putStrLn "tearing down schema"
117− connection3 <- execPQ (define teardown) connection2
118− finish connection3
119−
120−main2 :: IO ()
121−main2 =
122− withConnection "host=localhost port=5432 dbname=exampledb" $
123− define setup
124− & pqThen session
125− & pqThen (define teardown)
squeal-postgresql/squeal-postgresql.cabaldeleted−147
@@ -1,147 +0,0 @@
1−name: squeal-postgresql
2−version: 0.5.1.0
3−synopsis: Squeal PostgreSQL Library
4−description: Squeal is a type-safe embedding of PostgreSQL in Haskell
5−homepage: https://github.com/morphismtech/squeal
6−bug-reports: https://github.com/morphismtech/squeal/issues
7−license: BSD3
8−license-file: LICENSE
9−author: Eitan Chatav
10−maintainer: eitan.chatav@gmail.com
11−copyright: Copyright (c) 2017 Morphism, LLC
12−category: Database
13−build-type: Simple
14−cabal-version: >=1.18
15−extra-doc-files: README.md
16−
17−source-repository head
18− type: git
19− location: https://github.com/morphismtech/squeal.git
20−
21−library
22− hs-source-dirs: src
23− exposed-modules:
24− Squeal.PostgreSQL
25− Squeal.PostgreSQL.Alias
26− Squeal.PostgreSQL.Binary
27− Squeal.PostgreSQL.Definition
28− Squeal.PostgreSQL.Definition.Function
29− Squeal.PostgreSQL.Definition.Index
30− Squeal.PostgreSQL.Definition.Table
31− Squeal.PostgreSQL.Definition.Table.Constraint
32− Squeal.PostgreSQL.Definition.Type
33− Squeal.PostgreSQL.Definition.Schema
34− Squeal.PostgreSQL.Definition.View
35− Squeal.PostgreSQL.Expression
36− Squeal.PostgreSQL.Expression.Aggregate
37− Squeal.PostgreSQL.Expression.Collection
38− Squeal.PostgreSQL.Expression.Comparison
39− Squeal.PostgreSQL.Expression.Json
40− Squeal.PostgreSQL.Expression.Literal
41− Squeal.PostgreSQL.Expression.Logic
42− Squeal.PostgreSQL.Expression.Math
43− Squeal.PostgreSQL.Expression.Null
44− Squeal.PostgreSQL.Expression.Parameter
45− Squeal.PostgreSQL.Expression.Range
46− Squeal.PostgreSQL.Expression.Set
47− Squeal.PostgreSQL.Expression.Sort
48− Squeal.PostgreSQL.Expression.Subquery
49− Squeal.PostgreSQL.Expression.Text
50− Squeal.PostgreSQL.Expression.TextSearch
51− Squeal.PostgreSQL.Expression.Time
52− Squeal.PostgreSQL.Expression.Type
53− Squeal.PostgreSQL.Expression.Window
54− Squeal.PostgreSQL.List
55− Squeal.PostgreSQL.Manipulation
56− Squeal.PostgreSQL.Migration
57− Squeal.PostgreSQL.Pool
58− Squeal.PostgreSQL.PG
59− Squeal.PostgreSQL.PQ
60− Squeal.PostgreSQL.Render
61− Squeal.PostgreSQL.Query
62− Squeal.PostgreSQL.Schema
63− Squeal.PostgreSQL.Transaction
64− default-language: Haskell2010
65− ghc-options: -Wall
66− build-depends:
67− aeson >= 1.2.4.0
68− , base >= 4.11.1.0 && < 5.0
69− , binary-parser >= 0.5.5
70− , bytestring >= 0.10.8.2
71− , bytestring-strict-builder >= 0.4.5
72− , deepseq >= 1.4.3.0
73− , free-categories >= 0.1.0.0
74− , generics-sop >= 0.3.2.0 && < 0.5.0.0
75− , mmorph >= 1.1.1
76− , mtl >= 2.2.2
77− , network-ip >= 0.3.0.2
78− , postgresql-binary >= 0.12.1
79− , postgresql-libpq >= 0.9.4.1
80− , records-sop >= 0.1.0.0
81− , resource-pool >= 0.2.3.2
82− , scientific >= 0.3.5.3
83− , text >= 1.2.3.0
84− , time >= 1.8.0.2
85− , transformers >= 0.5.2.0
86− , unliftio >= 0.2.10
87− , unliftio-pool >= 0.2.1.0
88− , uuid-types >= 1.0.3
89− , vector >= 0.12.0.1
90−
91−test-suite doctest
92− default-language: Haskell2010
93− type: exitcode-stdio-1.0
94− hs-source-dirs: test
95− ghc-options: -Wall
96− main-is: Doc.hs
97− build-depends:
98− base >= 4.10.0.0
99− , doctest >= 0.11.4
100− , squeal-postgresql
101−
102−test-suite properties
103− default-language: Haskell2010
104− type: exitcode-stdio-1.0
105− hs-source-dirs: test
106− ghc-options: -Wall
107− main-is: Property.hs
108− build-depends:
109− base >= 4.10.0.0
110− , bytestring >= 0.10.8.2
111− , hedgehog >= 1.0
112− , mtl >= 2.2.2
113− , scientific >= 0.3.5.3
114− , squeal-postgresql
115− , time >= 1.8.0.2
116−
117−test-suite spec
118− default-language: Haskell2010
119− type: exitcode-stdio-1.0
120− hs-source-dirs: test
121− ghc-options: -Wall
122− main-is: Spec.hs
123− build-depends:
124− base >= 4.10.0.0
125− , async >= 2.2.2
126− , bytestring >= 0.10.8.2
127− , generics-sop >= 0.3.1.0
128− , hspec >= 2.4.8
129− , mtl >= 2.2.2
130− , squeal-postgresql
131− , text >= 1.2.2.2
132− , vector >= 0.12.0.1
133−
134−executable example
135− default-language: Haskell2010
136− hs-source-dirs: exe
137− ghc-options: -Wall
138− main-is: Example.hs
139− build-depends:
140− base >= 4.10.0.0 && < 5.0
141− , bytestring >= 0.10.8.2
142− , generics-sop >= 0.3.1.0
143− , mtl >= 2.2.1
144− , squeal-postgresql
145− , text >= 1.2.2.2
146− , transformers >= 0.5.2.0
147− , vector >= 0.12.0.1
squeal-postgresql/src/Squeal/PostgreSQL.hsdeleted−233
@@ -1,233 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL
3−Description: Squeal export module
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Squeal is a deep embedding of [PostgreSQL](https://www.postgresql.org) in Haskell.
9−Let's see an example!
10−
11−First, we need some language extensions because Squeal uses modern GHC
12−features.
13−
14−>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts
15−>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs
16−
17−We'll need some imports.
18−
19−>>> import Control.Monad.IO.Class (liftIO)
20−>>> import Data.Int (Int32)
21−>>> import Data.Text (Text)
22−>>> import Squeal.PostgreSQL
23−
24−We'll use generics to easily convert between Haskell and PostgreSQL values.
25−
26−>>> import qualified Generics.SOP as SOP
27−>>> import qualified GHC.Generics as GHC
28−
29−The first step is to define the schema of our database. This is where
30−we use @DataKinds@ and @TypeOperators@.
31−
32−>>> :{
33−type UsersColumns =
34− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
35− , "name" ::: 'NoDef :=> 'NotNull 'PGtext ]
36−type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]
37−type EmailsColumns =
38− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
39− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
40− , "email" ::: 'NoDef :=> 'Null 'PGtext ]
41−type EmailsConstraints =
42− '[ "pk_emails" ::: 'PrimaryKey '["id"]
43− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] ]
44−type Schema =
45− '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns)
46− , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ]
47−type Schemas = Public Schema
48−:}
49−
50−Notice the use of type operators.
51−
52−`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemasType`, a `SchemumType`,
53−a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's @::@
54−operator.
55−
56−`:=>` is used to pair `TableConstraints` with a `ColumnsType`,
57−yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,
58−yielding a `ColumnType`. It is intended to connote Haskell's @=>@ operator
59−
60−Next, we'll write `Definition`s to set up and tear down the schema. In
61−Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`
62−has two type parameters, corresponding to the schema
63−before being run and the schema after. We can compose definitions using `>>>`.
64−Here and in the rest of our commands we make use of overloaded
65−labels to refer to named tables and columns in our schema.
66−
67−>>> :{
68−let
69− setup :: Definition (Public '[]) Schemas
70− setup =
71− createTable #users
72− ( serial `as` #id :*
73− (text & notNullable) `as` #name )
74− ( primaryKey #id `as` #pk_users ) >>>
75− createTable #emails
76− ( serial `as` #id :*
77− (int & notNullable) `as` #user_id :*
78− (text & nullable) `as` #email )
79− ( primaryKey #id `as` #pk_emails :*
80− foreignKey #user_id #users #id
81− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
82−:}
83−
84−We can easily see the generated SQL is unsurprising looking.
85−
86−>>> printSQL setup
87−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
88−CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
89−
90−Notice that @setup@ starts with an empty public schema @(Public '[])@ and produces @Schemas@.
91−In our `createTable` commands we included `TableConstraint`s to define
92−primary and foreign keys, making them somewhat complex. Our @teardown@
93−`Definition` is simpler.
94−
95−>>> :{
96−let
97− teardown :: Definition Schemas (Public '[])
98− teardown = dropTable #emails >>> dropTable #users
99−:}
100−
101−>>> printSQL teardown
102−DROP TABLE "emails";
103−DROP TABLE "users";
104−
105−We'll need a Haskell type for @User@s. We give the type `Generics.SOP.Generic` and
106−`Generics.SOP.HasDatatypeInfo` instances so that we can encode and decode @User@s.
107−
108−>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)
109−>>> instance SOP.Generic User
110−>>> instance SOP.HasDatatypeInfo User
111−
112−Next, we'll write `Manipulation_`s to insert @User@s into our two tables.
113−A `Manipulation_` like `insertInto`, `update` or `deleteFrom`
114−has three type parameters, the schemas it refers to, input parameters
115−and an output row. When
116−we insert into the users table, we will need a parameter for the @name@
117−field but not for the @id@ field. Since it's serial, we can use a default
118−value. However, since the emails table refers to the users table, we will
119−need to retrieve the user id that the insert generates and insert it into
120−the emails table. We can do this in a single `Manipulation_` by using a
121−`with` statement.
122−
123−>>> :{
124−let
125− insertUser :: Manipulation_ Schemas User ()
126− insertUser = with (u `as` #u) e
127− where
128− u = insertInto #users
129− (Values_ (Default `as` #id :* Set (param @1) `as` #name))
130− OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))
131− e = insertInto_ #emails $ Select
132− (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)
133− (from (common #u))
134−:}
135−
136−>>> printSQL insertUser
137−WITH "u" AS (INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u"
138−
139−Next we write a `Query_` to retrieve users from the database. We're not
140−interested in the ids here, just the usernames and email addresses. We
141−need to use an `innerJoin` to get the right result. A `Query_` is like a
142−`Manipulation_` with the same kind of type parameters.
143−
144−>>> :{
145−let
146− getUsers :: Query_ Schemas () User
147− getUsers = select_
148− (#u ! #name `as` #userName :* #e ! #email `as` #userEmail)
149− ( from (table (#users `as` #u)
150− & innerJoin (table (#emails `as` #e))
151− (#u ! #id .== #e ! #user_id)) )
152−:}
153−
154−>>> printSQL getUsers
155−SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id")
156−
157−Let's create some users to add to the database.
158−
159−>>> :{
160−let
161− users :: [User]
162− users =
163− [ User "Alice" (Just "alice@gmail.com")
164− , User "Bob" Nothing
165− , User "Carole" (Just "carole@hotmail.com")
166− ]
167−:}
168−
169−Now we can put together all the pieces into a program. The program
170−connects to the database, sets up the schema, inserts the user data
171−(using prepared statements as an optimization), queries the user
172−data and prints it out and finally closes the connection. We can thread
173−the changing schema information through by using the indexed `PQ` monad
174−transformer and when the schema doesn't change we can use `Monad` and
175−`MonadPQ` functionality.
176−
177−>>> :{
178−let
179− session :: PQ Schemas Schemas IO ()
180− session = do
181− _ <- traversePrepared_ insertUser users
182− usersResult <- runQuery getUsers
183− usersRows <- getRows usersResult
184− liftIO $ print (usersRows :: [User])
185−in
186− withConnection "host=localhost port=5432 dbname=exampledb" $
187− define setup
188− & pqThen session
189− & pqThen (define teardown)
190−:}
191−[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]
192−-}
193−module Squeal.PostgreSQL (module X, RenderSQL(..), printSQL) where
194−
195−import Squeal.PostgreSQL.Alias as X
196−import Squeal.PostgreSQL.Binary as X
197−import Squeal.PostgreSQL.Definition as X
198−import Squeal.PostgreSQL.Definition.Function as X
199−import Squeal.PostgreSQL.Definition.Index as X
200−import Squeal.PostgreSQL.Definition.Schema as X
201−import Squeal.PostgreSQL.Definition.Table as X
202−import Squeal.PostgreSQL.Definition.Table.Constraint as X
203−import Squeal.PostgreSQL.Definition.Type as X
204−import Squeal.PostgreSQL.Definition.View as X
205−import Squeal.PostgreSQL.Expression as X
206−import Squeal.PostgreSQL.Expression.Aggregate as X
207−import Squeal.PostgreSQL.Expression.Collection as X
208−import Squeal.PostgreSQL.Expression.Comparison as X
209−import Squeal.PostgreSQL.Expression.Json as X
210−import Squeal.PostgreSQL.Expression.Literal as X
211−import Squeal.PostgreSQL.Expression.Logic as X
212−import Squeal.PostgreSQL.Expression.Math as X
213−import Squeal.PostgreSQL.Expression.Null as X
214−import Squeal.PostgreSQL.Expression.Parameter as X
215−import Squeal.PostgreSQL.Expression.Range as X
216−import Squeal.PostgreSQL.Expression.Set as X
217−import Squeal.PostgreSQL.Expression.Sort as X
218−import Squeal.PostgreSQL.Expression.Subquery as X
219−import Squeal.PostgreSQL.Expression.Text as X
220−import Squeal.PostgreSQL.Expression.TextSearch as X
221−import Squeal.PostgreSQL.Expression.Time as X
222−import Squeal.PostgreSQL.Expression.Type as X
223−import Squeal.PostgreSQL.Expression.Window as X
224−import Squeal.PostgreSQL.List as X
225−import Squeal.PostgreSQL.Manipulation as X
226−import Squeal.PostgreSQL.Migration as X
227−import Squeal.PostgreSQL.PG as X
228−import Squeal.PostgreSQL.Pool as X
229−import Squeal.PostgreSQL.PQ as X
230−import Squeal.PostgreSQL.Query as X
231−import Squeal.PostgreSQL.Render (RenderSQL(..), printSQL)
232−import Squeal.PostgreSQL.Schema as X
233−import Squeal.PostgreSQL.Transaction as X
squeal-postgresql/src/Squeal/PostgreSQL/Alias.hsdeleted−249
@@ -1,249 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Alias
3−Description: Aliases
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−This module embeds Postgres's alias system in Haskell in
9−a typesafe fashion. Thanks to GHC's @OverloadedLabels@ extension,
10−Squeal can reference aliases by prepending with a @#@.
11−-}
12−
13−{-# LANGUAGE
14− AllowAmbiguousTypes
15− , ConstraintKinds
16− , DeriveAnyClass
17− , DeriveGeneric
18− , FlexibleContexts
19− , FlexibleInstances
20− , FunctionalDependencies
21− , GADTs
22− , LambdaCase
23− , OverloadedStrings
24− , QuantifiedConstraints
25− , RankNTypes
26− , ScopedTypeVariables
27− , StandaloneDeriving
28− , TypeApplications
29− , TypeFamilyDependencies
30− , TypeInType
31− , TypeOperators
32− , UndecidableInstances
33− , UndecidableSuperClasses
34−#-}
35−
36−module Squeal.PostgreSQL.Alias
37− ( (:::)
38− , Alias (..)
39− , IsLabel (..)
40− , Aliased (As)
41− , Aliasable (as)
42− , renderAliased
43− , Has
44− , HasUnique
45− , HasAll
46− , HasIn
47− , QualifiedAlias (..)
48− , IsQualified (..)
49− -- * Grouping
50− , Grouping (..)
51− , GroupedBy
52− ) where
53−
54−import Control.DeepSeq
55−import Data.ByteString (ByteString)
56−import Data.String (fromString)
57−import GHC.OverloadedLabels
58−import GHC.TypeLits
59−
60−import qualified Generics.SOP as SOP
61−import qualified GHC.Generics as GHC
62−
63−import Squeal.PostgreSQL.List
64−import Squeal.PostgreSQL.Render
65−
66−-- $setup
67−-- >>> import Squeal.PostgreSQL
68−
69−-- | The alias operator `:::` is like a promoted version of `As`,
70−-- a type level pair between an alias and some type.
71−type (:::) (alias :: Symbol) ty = '(alias,ty)
72−infixr 6 :::
73−
74−
75−-- | `Grouping` is an auxiliary namespace, created by
76−-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used
77−-- for typesafe aggregation
78−data Grouping
79− = Ungrouped -- ^ no aggregation permitted
80− | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped
81−
82−{- | A `GroupedBy` constraint indicates that a table qualified column is
83−a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,
84−may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.
85−-}
86−class (KnownSymbol table, KnownSymbol column)
87− => GroupedBy table column bys where
88−instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)
89− => GroupedBy table column ('(table,column) ': bys)
90−instance {-# OVERLAPPABLE #-}
91− ( KnownSymbol table
92− , KnownSymbol column
93− , GroupedBy table column bys
94− ) => GroupedBy table column (tabcol ': bys)
95−
96−-- | `Alias`es are proxies for a type level string or `Symbol`
97−-- and have an `IsLabel` instance so that with @-XOverloadedLabels@
98−--
99−-- >>> :set -XOverloadedLabels
100−-- >>> #foobar :: Alias "foobar"
101−-- Alias
102−data Alias (alias :: Symbol) = Alias
103− deriving (Eq,GHC.Generic,Ord,Show,NFData)
104−instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where
105− fromLabel = Alias
106−instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where
107− fromLabel = fromLabel SOP.:* Nil
108−-- | >>> printSQL (#jimbob :: Alias "jimbob")
109−-- "jimbob"
110−instance KnownSymbol alias => RenderSQL (Alias alias) where
111− renderSQL = doubleQuoted . fromString . symbolVal
112−
113−-- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"])
114−-- "jimbob", "kandi"
115−instance SOP.All KnownSymbol aliases => RenderSQL (NP Alias aliases) where
116− renderSQL
117− = commaSeparated
118− . SOP.hcollapse
119− . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderSQL)
120−
121−-- | The `As` operator is used to name an expression. `As` is like a demoted
122−-- version of `:::`.
123−--
124−-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)
125−-- As (Just "hello") Alias
126−data Aliased expression aliased where
127− As
128− :: KnownSymbol alias
129− => expression ty
130− -> Alias alias
131− -> Aliased expression (alias ::: ty)
132−deriving instance Show (expression ty)
133− => Show (Aliased expression (alias ::: ty))
134−deriving instance Eq (expression ty)
135− => Eq (Aliased expression (alias ::: ty))
136−deriving instance Ord (expression ty)
137− => Ord (Aliased expression (alias ::: ty))
138−instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)
139− => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where
140− fromLabel = fromLabel @alias2 `As` fromLabel @alias1
141−
142−-- | The `Aliasable` class provides a way to scrap your `Nil`s
143−-- in an `NP` list of `Aliased` expressions.
144−class KnownSymbol alias => Aliasable alias expression aliased
145− | aliased -> expression
146− , aliased -> alias
147− where as :: expression -> Alias alias -> aliased
148−instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias
149− (expression ty)
150− (Aliased expression aliased)
151− where
152− as = As
153−instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias
154− (expression ty)
155− (NP (Aliased expression) tys)
156− where
157− expression `as` alias = expression `As` alias SOP.:* Nil
158−
159−-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")
160−-- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)
161−-- "Just AS \"an_int\""
162−renderAliased
163− :: (forall ty. expression ty -> ByteString)
164− -> Aliased expression aliased
165− -> ByteString
166−renderAliased render (expression `As` alias) =
167− render expression <> " AS " <> renderSQL alias
168−
169−-- | @HasUnique alias fields field@ is a constraint that proves that
170−-- @fields@ is a singleton of @alias ::: field@.
171−type HasUnique alias fields field = fields ~ '[alias ::: field]
172−
173−-- | @Has alias fields field@ is a constraint that proves that
174−-- @fields@ has a field of @alias ::: field@, inferring @field@
175−-- from @alias@ and @fields@.
176−class KnownSymbol alias =>
177− Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)
178− | alias fields -> field where
179−instance {-# OVERLAPPING #-} KnownSymbol alias
180− => Has alias (alias ::: field ': fields) field
181−instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)
182− => Has alias (field' ': fields) field
183−
184−{-| @HasIn fields (alias ::: field)@ is a constraint that proves that
185−@fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to
186−choose which subfields to update.
187−-}
188−class HasIn fields field where
189−instance (Has alias fields field) => HasIn fields (alias ::: field) where
190−
191−-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer
192−-- a list of @subfields@.
193−class
194− ( SOP.All KnownSymbol aliases
195− ) => HasAll
196− (aliases :: [Symbol])
197− (fields :: [(Symbol,kind)])
198− (subfields :: [(Symbol,kind)])
199− | aliases fields -> subfields where
200−instance {-# OVERLAPPING #-} HasAll '[] fields '[]
201−instance {-# OVERLAPPABLE #-}
202− (Has alias fields field, HasAll aliases fields subfields)
203− => HasAll (alias ': aliases) fields (alias ::: field ': subfields)
204−
205−-- | Analagous to `IsLabel`, the constraint
206−-- `IsQualified` defines `!` for a column alias qualified
207−-- by a table alias.
208−class IsQualified table column expression where
209− (!) :: Alias table -> Alias column -> expression
210− infixl 9 !
211−instance IsQualified table column (Alias table, Alias column) where (!) = (,)
212−
213−{-| `QualifiedAlias`es enables multi-schema support by allowing a reference
214−to a `Squeal.PostgreSQL.Schema.Table`, `Squeal.PostgreSQL.Schema.Typedef`
215−or `Squeal.PostgreSQL.Schema.View` to be qualified by their schemas. By default,
216−a qualifier of @public@ is provided.
217−
218−>>> :{
219−let
220− alias1 :: QualifiedAlias "sch" "tab"
221− alias1 = #sch ! #tab
222− alias2 :: QualifiedAlias "public" "vw"
223− alias2 = #vw
224−in printSQL alias1 >> printSQL alias2
225−:}
226−"sch"."tab"
227−"vw"
228−-}
229−data QualifiedAlias (qualifier :: Symbol) (alias :: Symbol) = QualifiedAlias
230− deriving (Eq,GHC.Generic,Ord,Show,NFData)
231−instance (q ~ q', a ~ a') => IsQualified q a (QualifiedAlias q' a') where
232− _!_ = QualifiedAlias
233−instance (q' ~ "public", a ~ a') => IsLabel a (QualifiedAlias q' a') where
234− fromLabel = QualifiedAlias
235−instance (q0 ~ q1, a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
236− IsQualified q0 a0 (Aliased (QualifiedAlias q1) (a1 ::: a2)) where
237− _!_ = QualifiedAlias `As` Alias
238−instance (q ~ "public", a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>
239− IsLabel a0 (Aliased (QualifiedAlias q) (a1 ::: a2)) where
240− fromLabel = QualifiedAlias `As` Alias
241−
242−instance (KnownSymbol q, KnownSymbol a)
243− => RenderSQL (QualifiedAlias q a) where
244− renderSQL _ =
245− let
246− qualifier = renderSQL (Alias @q)
247− alias = renderSQL (Alias @a)
248− in
249− if qualifier == "\"public\"" then alias else qualifier <> "." <> alias
squeal-postgresql/src/Squeal/PostgreSQL/Binary.hsdeleted−848
@@ -1,848 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Binary
3−Description: Binary encoding and decoding
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−This module provides binary encoding and decoding between Haskell and PostgreSQL types.
9−
10−Instances are governed by the `SOP.Generic` and `SOP.HasDatatypeInfo` typeclasses, so you absolutely
11−do not need to define your own instances to decode retrieved rows into Haskell values or
12−to encode Haskell values into statement parameters.
13−
14−Let's see some examples. We'll need some imports
15−
16−>>> import Data.Int (Int16)
17−>>> import Data.Text (Text)
18−>>> import Control.Monad (void)
19−>>> import Control.Monad.IO.Class (liftIO)
20−>>> import Squeal.PostgreSQL
21−
22−Define a Haskell datatype @Row@ that will serve as both the input and output of a simple
23−round trip query.
24−
25−>>> data Row = Row { col1 :: Int16, col2 :: Text, col3 :: Maybe Bool } deriving (Eq, GHC.Generic)
26−>>> instance Generic Row
27−>>> instance HasDatatypeInfo Row
28−>>> :{
29−let
30− roundTrip :: Query_ (Public '[]) Row Row
31− roundTrip = values_ $
32− parameter @1 int2 `as` #col1 :*
33− parameter @2 text `as` #col2 :*
34− parameter @3 bool `as` #col3
35−:}
36−
37−So long as we can encode the parameters and then decode the result of the query,
38−the input and output should be equal.
39−
40−>>> let input = Row 2 "hi" (Just True)
41−>>> :{
42−withConnection "host=localhost port=5432 dbname=exampledb" $ do
43− result <- runQueryParams roundTrip input
44− Just output <- firstRow result
45− liftIO . print $ input == output
46−:}
47−True
48−
49−In addition to being able to encode and decode basic Haskell types
50−like `Int16` and `Data.Text.Text`, Squeal permits you to encode and decode Haskell types to
51−Postgres array, enumerated and composite types and json. Let's see another example,
52−this time using the `Vector` type which corresponds to variable length arrays
53−and homogeneous tuples which correspond to fixed length arrays. We can even
54−create multi-dimensional fixed length arrays.
55−
56−>>> :{
57−data Row = Row
58− { col1 :: VarArray (Vector Int16)
59− , col2 :: FixArray (Maybe Int16,Maybe Int16)
60− , col3 :: FixArray ((Int16,Int16),(Int16,Int16),(Int16,Int16))
61− } deriving (Eq, GHC.Generic)
62−:}
63−
64−>>> instance Generic Row
65−>>> instance HasDatatypeInfo Row
66−
67−Once again, we define a simple round trip query.
68−
69−>>> :{
70−let
71− roundTrip :: Query_ (Public '[]) Row Row
72− roundTrip = values_ $
73− parameter @1 (int2 & vararray) `as` #col1 :*
74− parameter @2 (int2 & fixarray @'[2]) `as` #col2 :*
75− parameter @3 (int2 & fixarray @'[3,2]) `as` #col3
76−:}
77−
78−>>> :set -XOverloadedLists
79−>>> let input = Row (VarArray [1,2]) (FixArray (Just 1,Nothing)) (FixArray ((1,2),(3,4),(5,6)))
80−>>> :{
81−withConnection "host=localhost port=5432 dbname=exampledb" $ do
82− result <- runQueryParams roundTrip input
83− Just output <- firstRow result
84− liftIO . print $ input == output
85−:}
86−True
87−
88−Enumerated (enum) types are data types that comprise a static, ordered set of values.
89−They are equivalent to Haskell algebraic data types whose constructors are nullary.
90−An example of an enum type might be the days of the week,
91−or a set of status values for a piece of data.
92−
93−>>> data Schwarma = Beef | Lamb | Chicken deriving (Eq, Show, GHC.Generic)
94−>>> instance Generic Schwarma
95−>>> instance HasDatatypeInfo Schwarma
96−
97−A composite type represents the structure of a row or record;
98−it is essentially just a list of field names and their data types.
99−
100−>>> data Person = Person {name :: Text, age :: Int32} deriving (Eq, Show, GHC.Generic)
101−>>> instance Generic Person
102−>>> instance HasDatatypeInfo Person
103−>>> instance Aeson.FromJSON Person
104−>>> instance Aeson.ToJSON Person
105−
106−We can create the equivalent Postgres types directly from their Haskell types.
107−
108−>>> :{
109−type Schema =
110− '[ "schwarma" ::: 'Typedef (PG (Enumerated Schwarma))
111− , "person" ::: 'Typedef (PG (Composite Person))
112− ]
113−:}
114−
115−>>> :{
116−let
117− setup :: Definition (Public '[]) (Public Schema)
118− setup =
119− createTypeEnumFrom @Schwarma #schwarma >>>
120− createTypeCompositeFrom @Person #person
121−:}
122−
123−Let's demonstrate how to associate our Haskell types @Schwarma@ and @Person@
124−with enumerated, composite or json types in Postgres. First create a Haskell
125−@Row@ type using the `Enumerated`, `Composite` and `Json` newtypes as fields.
126−
127−>>> :{
128−data Row = Row
129− { schwarma :: Enumerated Schwarma
130− , person1 :: Composite Person
131− , person2 :: Json Person
132− } deriving (Eq, GHC.Generic)
133−:}
134−
135−>>> instance Generic Row
136−>>> instance HasDatatypeInfo Row
137−>>> :{
138−let
139− input = Row
140− (Enumerated Chicken)
141− (Composite (Person "Faisal" 24))
142− (Json (Person "Ahmad" 48))
143−:}
144−
145−Once again, define a round trip query.
146−
147−>>> :{
148−let
149− roundTrip :: Query_ (Public Schema) Row Row
150− roundTrip = values_ $
151− parameter @1 (typedef #schwarma) `as` #schwarma :*
152− parameter @2 (typedef #person) `as` #person1 :*
153− parameter @3 json `as` #person2
154−:}
155−
156−Finally, we can drop our type definitions.
157−
158−>>> :{
159−let
160− teardown :: Definition (Public Schema) (Public '[])
161− teardown = dropType #schwarma >>> dropType #person
162−:}
163−
164−Now let's run it.
165−
166−>>> :{
167−let
168− session = do
169− result <- runQueryParams roundTrip input
170− Just output <- firstRow result
171− liftIO . print $ input == output
172−in
173− withConnection "host=localhost port=5432 dbname=exampledb" $
174− define setup
175− & pqThen session
176− & pqThen (define teardown)
177−:}
178−True
179−-}
180−
181−{-# LANGUAGE
182− AllowAmbiguousTypes
183− , DeriveFoldable
184− , DeriveFunctor
185− , DeriveGeneric
186− , DeriveTraversable
187− , DefaultSignatures
188− , FlexibleContexts
189− , FlexibleInstances
190− , FunctionalDependencies
191− , GADTs
192− , LambdaCase
193− , OverloadedStrings
194− , MultiParamTypeClasses
195− , ScopedTypeVariables
196− , TypeApplications
197− , TypeFamilies
198− , TypeInType
199− , TypeOperators
200− , UndecidableInstances
201− , UndecidableSuperClasses
202−#-}
203−
204−module Squeal.PostgreSQL.Binary
205− ( -- * Encoding
206− ToParam (..)
207− , ToParams (..)
208− , ToNullityParam (..)
209− , ToField (..)
210− , ToFixArray (..)
211− -- * Decoding
212− , FromValue (..)
213− , FromRow (..)
214− , FromField (..)
215− , FromFixArray (..)
216− -- * Only
217− , Only (..)
218− -- * Oid
219− , OidOf (..)
220− , OidOfParam (..)
221− , OidOfField (..)
222− ) where
223−
224−import BinaryParser
225−import ByteString.StrictBuilder (builderLength, int32BE, int64BE, word32BE)
226−import Control.Arrow (left)
227−import Control.Monad
228−import Data.Int
229−import Data.Kind
230−import Data.Scientific
231−import Data.Time
232−import Data.UUID.Types
233−import Data.Vector (Vector)
234−import Data.Word
235−import Foreign.C.Types (CUInt(CUInt))
236−import Generics.SOP
237−import Generics.SOP.Record
238−import GHC.TypeLits
239−import Network.IP.Addr
240−
241−import qualified Data.Aeson as Aeson
242−import qualified Data.ByteString.Lazy as Lazy (ByteString)
243−import qualified Data.ByteString.Lazy as Lazy.ByteString
244−import qualified Data.ByteString as Strict (ByteString)
245−import qualified Data.Text.Lazy as Lazy (Text)
246−import qualified Data.Text as Strict (Text)
247−import qualified Data.Text as Strict.Text
248−import qualified Data.Vector as Vector
249−import qualified Database.PostgreSQL.LibPQ as LibPQ
250−import qualified GHC.Generics as GHC
251−import qualified PostgreSQL.Binary.Decoding as Decoding
252−import qualified PostgreSQL.Binary.Encoding as Encoding
253−
254−import Squeal.PostgreSQL.Alias
255−import Squeal.PostgreSQL.List
256−import Squeal.PostgreSQL.PG
257−import Squeal.PostgreSQL.Schema
258−
259−-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into
260−-- into the binary format of a PostgreSQL `PGType`.
261−class ToParam (x :: Type) (pg :: PGType) where
262− -- | >>> :set -XTypeApplications -XDataKinds
263− -- >>> toParam @Bool @'PGbool False
264− -- K "\NUL"
265− --
266− -- >>> toParam @Int16 @'PGint2 0
267− -- K "\NUL\NUL"
268− --
269− -- >>> toParam @Int32 @'PGint4 0
270− -- K "\NUL\NUL\NUL\NUL"
271− --
272− -- >>> :set -XMultiParamTypeClasses
273− -- >>> newtype Id = Id { getId :: Int16 } deriving Show
274− -- >>> instance ToParam Id 'PGint2 where toParam = toParam . getId
275− -- >>> toParam @Id @'PGint2 (Id 1)
276− -- K "\NUL\SOH"
277− toParam :: x -> K Encoding.Encoding pg
278−instance ToParam Bool 'PGbool where toParam = K . Encoding.bool
279−instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16
280−instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32
281−instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64
282−instance ToParam Oid 'PGoid where toParam = K . Encoding.int4_word32 . getOid
283−instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4
284−instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8
285−instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric
286−instance ToParam Money 'PGmoney where toParam = K . Encoding.int8_int64 . cents
287−instance ToParam UUID 'PGuuid where toParam = K . Encoding.uuid
288−instance ToParam (NetAddr IP) 'PGinet where toParam = K . Encoding.inet
289−instance ToParam Char ('PGchar 1) where toParam = K . Encoding.char_utf8
290−instance ToParam Strict.Text 'PGtext where toParam = K . Encoding.text_strict
291−instance ToParam Lazy.Text 'PGtext where toParam = K . Encoding.text_lazy
292−instance ToParam String 'PGtext where
293− toParam = K . Encoding.text_strict . Strict.Text.pack
294−instance ToParam Strict.ByteString 'PGbytea where
295− toParam = K . Encoding.bytea_strict
296−instance ToParam Lazy.ByteString 'PGbytea where
297− toParam = K . Encoding.bytea_lazy
298−instance ToParam Day 'PGdate where toParam = K . Encoding.date
299−instance ToParam TimeOfDay 'PGtime where toParam = K . Encoding.time_int
300−instance ToParam (TimeOfDay, TimeZone) 'PGtimetz where
301− toParam = K . Encoding.timetz_int
302−instance ToParam LocalTime 'PGtimestamp where
303− toParam = K . Encoding.timestamp_int
304−instance ToParam UTCTime 'PGtimestamptz where
305− toParam = K . Encoding.timestamptz_int
306−instance ToParam DiffTime 'PGinterval where toParam = K . Encoding.interval_int
307−instance ToParam Aeson.Value 'PGjson where toParam = K . Encoding.json_ast
308−instance ToParam Aeson.Value 'PGjsonb where toParam = K . Encoding.jsonb_ast
309−instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where
310− toParam = K . Encoding.json_bytes
311− . Lazy.ByteString.toStrict . Aeson.encode . getJson
312−instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where
313− toParam = K . Encoding.jsonb_bytes
314− . Lazy.ByteString.toStrict . Aeson.encode . getJsonb
315−instance (ToNullityParam x ty, ty ~ nullity pg, OidOf pg)
316− => ToParam (VarArray [x]) ('PGvararray ty) where
317− toParam = K
318− . Encoding.array_foldable
319− (getOid (oidOf @pg)) (unK . toNullityParam @x @ty)
320− . getVarArray
321−instance (ToParam x pg, OidOf pg)
322− => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where
323− toParam = K
324− . Encoding.array_vector (getOid (oidOf @pg)) (unK . toParam @x @pg)
325− . getVarArray
326−instance (ToParam x pg, OidOf pg)
327− => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where
328− toParam = K
329− . Encoding.nullableArray_vector
330− (getOid (oidOf @pg)) (unK . toParam @x @pg)
331− . getVarArray
332−instance (ToFixArray x dims ty, ty ~ nullity pg, OidOf pg)
333− => ToParam (FixArray x) ('PGfixarray dims ty) where
334− toParam = K . Encoding.array (getOid (oidOf @pg))
335− . unK . unK . toFixArray @x @dims @ty . getFixArray
336−instance
337− ( IsEnumType x
338− , HasDatatypeInfo x
339− , LabelsPG x ~ labels
340− ) => ToParam (Enumerated x) ('PGenum labels) where
341− toParam =
342− let
343− gshowConstructor :: NP ConstructorInfo xss -> SOP I xss -> String
344− gshowConstructor Nil _ = ""
345− gshowConstructor (constructor :* _) (SOP (Z _)) =
346− constructorName constructor
347− gshowConstructor (_ :* constructors) (SOP (S xs)) =
348− gshowConstructor constructors (SOP xs)
349− in
350− K . Encoding.text_strict
351− . Strict.Text.pack
352− . gshowConstructor (constructorInfo (datatypeInfo (Proxy @x)))
353− . from
354− . getEnumerated
355−instance
356− ( SListI fields
357− , IsRecord x xs
358− , AllZip ToField xs fields
359− , All OidOfField fields
360− ) => ToParam (Composite x) ('PGcomposite fields) where
361− toParam =
362− let
363−
364− encoders = htrans (Proxy @ToField) toField
365−
366− composite
367− :: All OidOfField row
368− => NP (K (Maybe Encoding.Encoding)) row
369− -> K Encoding.Encoding ('PGcomposite row)
370− composite fields = K $
371− -- <number of fields: 4 bytes>
372− -- [for each field]
373− -- <OID of field's type: sizeof(Oid) bytes>
374− -- [if value is NULL]
375− -- <-1: 4 bytes>
376− -- [else]
377− -- <length of value: 4 bytes>
378− -- <value: <length> bytes>
379− -- [end if]
380− -- [end for]
381− int32BE (fromIntegral (lengthSList (Proxy @xs))) <>
382− let
383− each
384− :: OidOfField field
385− => K (Maybe Encoding.Encoding) field
386− -> Encoding.Encoding
387− each (K field :: K (Maybe Encoding.Encoding) field) =
388− word32BE (getOid (oidOfField @field))
389− <> case field of
390− Nothing -> int64BE (-1)
391− Just value ->
392− int32BE (fromIntegral (builderLength value))
393− <> value
394− in
395− hcfoldMap (Proxy @OidOfField) each fields
396−
397− in
398− composite . encoders . toRecord . getComposite
399−
400−-- | The object identifier of a `PGType`.
401−--
402−-- >>> :set -XTypeApplications
403−-- >>> oidOf @'PGbool
404−-- Oid 16
405−class OidOf (ty :: PGType) where oidOf :: LibPQ.Oid
406−instance OidOf 'PGbool where oidOf = LibPQ.Oid 16
407−instance OidOf ('PGfixarray ns (null 'PGbool)) where oidOf = LibPQ.Oid 1000
408−instance OidOf ('PGvararray (null 'PGbool)) where oidOf = LibPQ.Oid 1000
409−instance OidOf 'PGint2 where oidOf = LibPQ.Oid 21
410−instance OidOf ('PGfixarray ns (null 'PGint2)) where oidOf = LibPQ.Oid 1005
411−instance OidOf ('PGvararray (null 'PGint2)) where oidOf = LibPQ.Oid 1005
412−instance OidOf 'PGint4 where oidOf = LibPQ.Oid 23
413−instance OidOf ('PGfixarray ns (null 'PGint4)) where oidOf = LibPQ.Oid 1007
414−instance OidOf ('PGvararray (null 'PGint4)) where oidOf = LibPQ.Oid 1007
415−instance OidOf 'PGint8 where oidOf = LibPQ.Oid 20
416−instance OidOf ('PGfixarray ns (null 'PGint8)) where oidOf = LibPQ.Oid 1016
417−instance OidOf ('PGvararray (null 'PGint8)) where oidOf = LibPQ.Oid 1016
418−instance OidOf 'PGnumeric where oidOf = LibPQ.Oid 1700
419−instance OidOf ('PGfixarray ns (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231
420−instance OidOf ('PGvararray (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231
421−instance OidOf 'PGfloat4 where oidOf = LibPQ.Oid 700
422−instance OidOf ('PGfixarray ns (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021
423−instance OidOf ('PGvararray (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021
424−instance OidOf 'PGfloat8 where oidOf = LibPQ.Oid 701
425−instance OidOf ('PGfixarray ns (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022
426−instance OidOf ('PGvararray (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022
427−instance OidOf 'PGmoney where oidOf = LibPQ.Oid 790
428−instance OidOf ('PGfixarray ns (null 'PGmoney)) where oidOf = LibPQ.Oid 791
429−instance OidOf ('PGvararray (null 'PGmoney)) where oidOf = LibPQ.Oid 791
430−instance OidOf ('PGchar n) where oidOf = LibPQ.Oid 18
431−instance OidOf ('PGfixarray ns (null ('PGchar n))) where oidOf = LibPQ.Oid 1002
432−instance OidOf ('PGvararray (null ('PGchar n))) where oidOf = LibPQ.Oid 1002
433−instance OidOf ('PGvarchar n) where oidOf = LibPQ.Oid 1043
434−instance OidOf ('PGfixarray ns (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015
435−instance OidOf ('PGvararray (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015
436−instance OidOf 'PGtext where oidOf = LibPQ.Oid 25
437−instance OidOf ('PGfixarray ns (null 'PGtext)) where oidOf = LibPQ.Oid 1009
438−instance OidOf ('PGvararray (null 'PGtext)) where oidOf = LibPQ.Oid 1009
439−instance OidOf 'PGbytea where oidOf = LibPQ.Oid 17
440−instance OidOf ('PGfixarray ns (null 'PGbytea)) where oidOf = LibPQ.Oid 1001
441−instance OidOf ('PGvararray (null 'PGbytea)) where oidOf = LibPQ.Oid 1001
442−instance OidOf 'PGtimestamp where oidOf = LibPQ.Oid 1114
443−instance OidOf ('PGfixarray ns (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115
444−instance OidOf ('PGvararray (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115
445−instance OidOf 'PGtimestamptz where oidOf = LibPQ.Oid 1184
446−instance OidOf ('PGfixarray ns (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185
447−instance OidOf ('PGvararray (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185
448−instance OidOf 'PGdate where oidOf = LibPQ.Oid 1082
449−instance OidOf ('PGfixarray ns (null 'PGdate)) where oidOf = LibPQ.Oid 1182
450−instance OidOf ('PGvararray (null 'PGdate)) where oidOf = LibPQ.Oid 1182
451−instance OidOf 'PGtime where oidOf = LibPQ.Oid 1083
452−instance OidOf ('PGfixarray ns (null 'PGtime)) where oidOf = LibPQ.Oid 1183
453−instance OidOf ('PGvararray (null 'PGtime)) where oidOf = LibPQ.Oid 1183
454−instance OidOf 'PGtimetz where oidOf = LibPQ.Oid 1266
455−instance OidOf ('PGfixarray ns (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270
456−instance OidOf ('PGvararray (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270
457−instance OidOf 'PGinterval where oidOf = LibPQ.Oid 1186
458−instance OidOf ('PGfixarray ns (null 'PGinterval)) where oidOf = LibPQ.Oid 1187
459−instance OidOf ('PGvararray (null 'PGinterval)) where oidOf = LibPQ.Oid 1187
460−instance OidOf 'PGuuid where oidOf = LibPQ.Oid 2950
461−instance OidOf ('PGfixarray ns (null 'PGuuid)) where oidOf = LibPQ.Oid 2951
462−instance OidOf ('PGvararray (null 'PGuuid)) where oidOf = LibPQ.Oid 2951
463−instance OidOf 'PGinet where oidOf = LibPQ.Oid 869
464−instance OidOf ('PGfixarray ns (null 'PGinet)) where oidOf = LibPQ.Oid 1041
465−instance OidOf ('PGvararray (null 'PGinet)) where oidOf = LibPQ.Oid 1041
466−instance OidOf 'PGjson where oidOf = LibPQ.Oid 114
467−instance OidOf ('PGfixarray ns (null 'PGjson)) where oidOf = LibPQ.Oid 199
468−instance OidOf ('PGvararray (null 'PGjson)) where oidOf = LibPQ.Oid 199
469−instance OidOf 'PGjsonb where oidOf = LibPQ.Oid 3802
470−instance OidOf ('PGfixarray ns (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807
471−instance OidOf ('PGvararray (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807
472−instance OidOf 'PGtsvector where oidOf = LibPQ.Oid 3614
473−instance OidOf ('PGfixarray ns (null 'PGtsvector)) where oidOf = LibPQ.Oid 3643
474−instance OidOf ('PGvararray (null 'PGtsvector)) where oidOf = LibPQ.Oid 3643
475−instance OidOf 'PGtsquery where oidOf = LibPQ.Oid 3615
476−instance OidOf ('PGfixarray ns (null 'PGtsquery)) where oidOf = LibPQ.Oid 3645
477−instance OidOf ('PGvararray (null 'PGtsquery)) where oidOf = LibPQ.Oid 3645
478−instance OidOf 'PGoid where oidOf = LibPQ.Oid 26
479−instance OidOf ('PGfixarray ns (null 'PGoid)) where oidOf = LibPQ.Oid 1028
480−instance OidOf ('PGvararray (null 'PGoid)) where oidOf = LibPQ.Oid 1028
481−instance OidOf ('PGrange 'PGint4) where oidOf = LibPQ.Oid 3904
482−instance OidOf ('PGfixarray ns (null ('PGrange 'PGint4))) where oidOf = LibPQ.Oid 3905
483−instance OidOf ('PGvararray (null ('PGrange 'PGint4))) where oidOf = LibPQ.Oid 3905
484−instance OidOf ('PGrange 'PGint8) where oidOf = LibPQ.Oid 3926
485−instance OidOf ('PGfixarray ns (null ('PGrange 'PGint8))) where oidOf = LibPQ.Oid 3927
486−instance OidOf ('PGvararray (null ('PGrange 'PGint8))) where oidOf = LibPQ.Oid 3927
487−instance OidOf ('PGrange 'PGnumeric) where oidOf = LibPQ.Oid 3906
488−instance OidOf ('PGfixarray ns (null ('PGrange 'PGnumeric))) where oidOf = LibPQ.Oid 3907
489−instance OidOf ('PGvararray (null ('PGrange 'PGnumeric))) where oidOf = LibPQ.Oid 3907
490−instance OidOf ('PGrange 'PGtimestamp) where oidOf = LibPQ.Oid 3908
491−instance OidOf ('PGfixarray ns (null ('PGrange 'PGtimestamp))) where oidOf = LibPQ.Oid 3909
492−instance OidOf ('PGvararray (null ('PGrange 'PGtimestamp))) where oidOf = LibPQ.Oid 3909
493−instance OidOf ('PGrange 'PGtimestamptz) where oidOf = LibPQ.Oid 3910
494−instance OidOf ('PGfixarray ns (null ('PGrange 'PGtimestamptz))) where oidOf = LibPQ.Oid 3911
495−instance OidOf ('PGvararray (null ('PGrange 'PGtimestamptz))) where oidOf = LibPQ.Oid 3911
496−instance OidOf ('PGrange 'PGdate) where oidOf = LibPQ.Oid 3912
497−instance OidOf ('PGfixarray ns (null ('PGrange 'PGdate))) where oidOf = LibPQ.Oid 3913
498−instance OidOf ('PGvararray (null ('PGrange 'PGdate))) where oidOf = LibPQ.Oid 3913
499−instance {-# OVERLAPPABLE #-} OidOf ('PGrange ty) where oidOf = LibPQ.invalidOid
500−instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGrange ty))) where oidOf = LibPQ.invalidOid
501−instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGrange ty))) where oidOf = LibPQ.invalidOid
502−instance {-# OVERLAPPABLE #-} OidOf ('PGcomposite row) where oidOf = LibPQ.invalidOid
503−instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGcomposite row))) where oidOf = LibPQ.invalidOid
504−instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGcomposite row))) where oidOf = LibPQ.invalidOid
505−instance {-# OVERLAPPABLE #-} OidOf ('PGenum labels) where oidOf = LibPQ.invalidOid
506−instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGenum labels))) where oidOf = LibPQ.invalidOid
507−instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGenum labels))) where oidOf = LibPQ.invalidOid
508−
509−class OidOfParam (ty :: NullityType) where oidOfParam :: Oid
510−instance OidOf ty => OidOfParam (null ty) where oidOfParam = oidOf @ty
511−
512−-- | Lifts a `OidOf` constraint to a field.
513−class OidOfField (field :: (Symbol, NullityType)) where
514− oidOfField :: Oid
515−instance OidOf ty => OidOfField (alias ::: nullity ty) where
516− oidOfField = oidOf @ty
517−
518−-- | A `ToNullityParam` constraint gives an encoding of a Haskell `Type` into
519−-- into the binary format of a PostgreSQL `NullityType`.
520−class ToNullityParam (x :: Type) (ty :: NullityType) where
521− toNullityParam :: x -> K (Maybe Encoding.Encoding) ty
522−instance ToParam x pg => ToNullityParam x ('NotNull pg) where
523− toNullityParam = K . Just . unK . toParam @x @pg
524−instance ToParam x pg => ToNullityParam (Maybe x) ('Null pg) where
525− toNullityParam = K . fmap (unK . toParam @x @pg)
526−
527−-- | A `ToField` constraint lifts the `ToParam` parser
528−-- to an encoding of a @(Symbol, Type)@ to a @(Symbol, NullityType)@,
529−-- encoding `Null`s to `Maybe`s. You should not define instances for
530−-- `FromField`, just use the provided instances.
531−class ToField (x :: (Symbol, Type)) (field :: (Symbol, NullityType)) where
532− toField :: P x -> K (Maybe Encoding.Encoding) field
533−instance ToNullityParam x ty => ToField (alias ::: x) (alias ::: ty) where
534− toField (P x) = K . unK $ toNullityParam @x @ty x
535−
536−-- | A `ToFixArray` constraint gives an encoding of a Haskell `Type`
537−-- into the binary format of a PostgreSQL fixed-length array.
538−-- You should not define instances for
539−-- `ToFixArray`, just use the provided instances.
540−class ToFixArray (x :: Type) (dims :: [Nat]) (array :: NullityType) where
541− toFixArray :: x -> K (K Encoding.Array dims) array
542−instance ToNullityParam x ty => ToFixArray x '[] ty where
543− toFixArray = K . K . maybe Encoding.nullArray Encoding.encodingArray . unK
544− . toNullityParam @x @ty
545−instance
546− ( IsProductType product xs
547− , Length xs ~ dim
548− , All ((~) x) xs
549− , ToFixArray x dims ty )
550− => ToFixArray product (dim ': dims) ty where
551− toFixArray = K . K . Encoding.dimensionArray foldlN
552− (unK . unK . toFixArray @x @dims @ty) . unZ . unSOP . from
553−
554−-- | A `ToParams` constraint generically sequences the encodings of `Type`s
555−-- of the fields of a tuple or record to a row of `ColumnType`s. You should
556−-- not define instances of `ToParams`. Instead define `SOP.Generic` instances
557−-- which in turn provide `ToParams` instances.
558−class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where
559− -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2]
560− -- >>> toParams @(Bool, Maybe Int16) @'[ 'NotNull 'PGbool, 'Null 'PGint2] (False, Just 0)
561− -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil
562− --
563− -- >>> :set -XDeriveGeneric
564− -- >>> data Tuple = Tuple { p1 :: Bool, p2 :: Maybe Int16} deriving GHC.Generic
565− -- >>> instance Generic Tuple
566− -- >>> toParams @Tuple @Params (Tuple False (Just 0))
567− -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil
568− toParams :: x -> NP (K (Maybe Encoding.Encoding)) tys
569−instance (SListI tys, IsProductType x xs, AllZip ToNullityParam xs tys)
570− => ToParams x tys where
571− toParams
572− = htrans (Proxy @ToNullityParam) (toNullityParam . unI)
573− . unZ . unSOP . from
574−
575−-- | A `FromValue` constraint gives a parser from the binary format of
576−-- a PostgreSQL `PGType` into a Haskell `Type`.
577−class FromValue (pg :: PGType) (y :: Type) where
578− -- | >>> newtype Id = Id { getId :: Int16 } deriving Show
579− -- >>> instance FromValue 'PGint2 Id where fromValue = Id <$> fromValue @'PGint2
580− fromValue :: Decoding.Value y
581−instance FromValue 'PGbool Bool where fromValue = Decoding.bool
582−instance FromValue 'PGint2 Int16 where fromValue = Decoding.int
583−instance FromValue 'PGint4 Int32 where fromValue = Decoding.int
584−instance FromValue 'PGint8 Int64 where fromValue = Decoding.int
585−instance FromValue 'PGoid Word32 where fromValue = Decoding.int
586−instance FromValue 'PGfloat4 Float where fromValue = Decoding.float4
587−instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8
588−instance FromValue 'PGnumeric Scientific where fromValue = Decoding.numeric
589−instance FromValue 'PGmoney Money where fromValue = Money <$> Decoding.int
590−instance FromValue 'PGuuid UUID where fromValue = Decoding.uuid
591−instance FromValue 'PGinet (NetAddr IP) where fromValue = Decoding.inet
592−instance FromValue ('PGchar 1) Char where fromValue = Decoding.char
593−instance FromValue 'PGtext Strict.Text where fromValue = Decoding.text_strict
594−instance FromValue 'PGtext Lazy.Text where fromValue = Decoding.text_lazy
595−instance FromValue 'PGtext String where
596− fromValue = Strict.Text.unpack <$> Decoding.text_strict
597−instance FromValue 'PGbytea Strict.ByteString where
598− fromValue = Decoding.bytea_strict
599−instance FromValue 'PGbytea Lazy.ByteString where
600− fromValue = Decoding.bytea_lazy
601−instance FromValue 'PGdate Day where fromValue = Decoding.date
602−instance FromValue 'PGtime TimeOfDay where fromValue = Decoding.time_int
603−instance FromValue 'PGtimetz (TimeOfDay, TimeZone) where
604− fromValue = Decoding.timetz_int
605−instance FromValue 'PGtimestamp LocalTime where
606− fromValue = Decoding.timestamp_int
607−instance FromValue 'PGtimestamptz UTCTime where
608− fromValue = Decoding.timestamptz_int
609−instance FromValue 'PGinterval DiffTime where
610− fromValue = Decoding.interval_int
611−instance FromValue 'PGjson Aeson.Value where fromValue = Decoding.json_ast
612−instance FromValue 'PGjsonb Aeson.Value where fromValue = Decoding.jsonb_ast
613−instance Aeson.FromJSON x => FromValue 'PGjson (Json x) where
614− fromValue = Json <$>
615− Decoding.json_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)
616−instance Aeson.FromJSON x => FromValue 'PGjsonb (Jsonb x) where
617− fromValue = Jsonb <$>
618− Decoding.jsonb_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)
619−instance FromValue pg y
620− => FromValue ('PGvararray ('NotNull pg)) (VarArray (Vector y)) where
621− fromValue =
622− let
623− rep n x = VarArray <$> Vector.replicateM n x
624− in
625− Decoding.array $ Decoding.dimensionArray rep
626− (fromFixArray @'[] @('NotNull pg))
627−instance FromValue pg y
628− => FromValue ('PGvararray ('Null pg)) (VarArray (Vector (Maybe y))) where
629− fromValue =
630− let
631− rep n x = VarArray <$> Vector.replicateM n x
632− in
633− Decoding.array $ Decoding.dimensionArray rep
634− (fromFixArray @'[] @('Null pg))
635−instance FromValue pg y
636− => FromValue ('PGvararray ('NotNull pg)) (VarArray [y]) where
637− fromValue =
638− let
639− rep n x = VarArray <$> replicateM n x
640− in
641− Decoding.array $ Decoding.dimensionArray rep
642− (fromFixArray @'[] @('NotNull pg))
643−instance FromValue pg y
644− => FromValue ('PGvararray ('Null pg)) (VarArray [Maybe y]) where
645− fromValue =
646− let
647− rep n x = VarArray <$> replicateM n x
648− in
649− Decoding.array $ Decoding.dimensionArray rep
650− (fromFixArray @'[] @('Null pg))
651−instance FromFixArray dims ty y
652− => FromValue ('PGfixarray dims ty) (FixArray y) where
653− fromValue = FixArray <$> Decoding.array (fromFixArray @dims @ty @y)
654−instance
655− ( IsEnumType y
656− , HasDatatypeInfo y
657− , LabelsPG y ~ labels
658− ) => FromValue ('PGenum labels) (Enumerated y) where
659− fromValue =
660− let
661− greadConstructor
662− :: All ((~) '[]) xss
663− => NP ConstructorInfo xss
664− -> String
665− -> Maybe (SOP I xss)
666− greadConstructor Nil _ = Nothing
667− greadConstructor (constructor :* constructors) name =
668− if name == constructorName constructor
669− then Just (SOP (Z Nil))
670− else SOP . S . unSOP <$> greadConstructor constructors name
671− in
672− fmap Enumerated
673− . Decoding.enum
674− $ fmap to
675− . greadConstructor (constructorInfo (datatypeInfo (Proxy @y)))
676− . Strict.Text.unpack
677−instance
678− ( FromRow fields y
679− ) => FromValue ('PGcomposite fields) (Composite y) where
680− fromValue =
681− let
682− -- <number of fields: 4 bytes>
683− -- [for each field]
684− -- <OID of field's type: sizeof(Oid) bytes>
685− -- [if value is NULL]
686− -- <-1: 4 bytes>
687− -- [else]
688− -- <length of value: 4 bytes>
689− -- <value: <length> bytes>
690− -- [end if]
691− -- [end for]
692− composite = Decoding.valueParser $ do
693− unitOfSize 4
694− hsequence' $ hpure $ Comp $ do
695− unitOfSize 4
696− len <- sized 4 Decoding.int
697− if len == -1
698− then return (K Nothing)
699− else K . Just <$> bytesOfSize len
700− in
701− fmap Composite (Decoding.fn (fromRow @fields <=< composite))
702−
703−-- | A `FromField` constraint lifts the `FromValue` parser
704−-- to a decoding of a @(Symbol, NullityType)@ to a `Type`,
705−-- decoding `Null`s to `Maybe`s. You should not define instances for
706−-- `FromField`, just use the provided instances.
707−class FromField (pg :: (Symbol, NullityType)) (y :: (Symbol, Type)) where
708− fromField
709− :: K (Maybe Strict.ByteString) pg
710− -> (Either Strict.Text :.: P) y
711−instance FromValue pg y
712− => FromField (column ::: ('NotNull pg)) (column ::: y) where
713− fromField = Comp . \case
714− K Nothing -> Left "fromField: saw NULL when expecting NOT NULL"
715− K (Just bytestring) -> P <$>
716− Decoding.valueParser (fromValue @pg) bytestring
717−instance FromValue pg y
718− => FromField (column ::: 'Null pg) (column ::: Maybe y) where
719− fromField = Comp . \case
720− K Nothing -> Right $ P Nothing
721− K (Just bytestring) -> P . Just <$>
722− Decoding.valueParser (fromValue @pg) bytestring
723−
724−-- | A `FromFixArray` constraint gives a decoding to a Haskell `Type`
725−-- from the binary format of a PostgreSQL fixed-length array.
726−-- You should not define instances for
727−-- `FromFixArray`, just use the provided instances.
728−class FromFixArray (dims :: [Nat]) (ty :: NullityType) (y :: Type) where
729− fromFixArray :: Decoding.Array y
730−instance FromValue pg y => FromFixArray '[] ('NotNull pg) y where
731− fromFixArray = Decoding.valueArray (fromValue @pg @y)
732−instance FromValue pg y => FromFixArray '[] ('Null pg) (Maybe y) where
733− fromFixArray = Decoding.nullableValueArray (fromValue @pg @y)
734−instance
735− ( IsProductType product ys
736− , Length ys ~ dim
737− , All ((~) y) ys
738− , FromFixArray dims ty y )
739− => FromFixArray (dim ': dims) ty product where
740− fromFixArray =
741− let
742− rep _ = fmap (to . SOP . Z) . replicateMN
743− in
744− Decoding.dimensionArray rep (fromFixArray @dims @ty @y)
745−
746−-- | A `FromRow` constraint generically sequences the parsings of the columns
747−-- of a `RowType` into the fields of a record `Type` provided they have
748−-- the same field names. You should not define instances of `FromRow`.
749−-- Instead define `SOP.Generic` and `SOP.HasDatatypeInfo` instances which in turn
750−-- provide `FromRow` instances.
751−class SListI result => FromRow (result :: RowType) y where
752− -- | >>> :set -XOverloadedStrings
753− -- >>> import Data.Text
754− -- >>> newtype UserId = UserId { getUserId :: Int16 } deriving Show
755− -- >>> instance FromValue 'PGint2 UserId where fromValue = UserId <$> fromValue @'PGint2
756− -- >>> data UserRow = UserRow { userId :: UserId, userName :: Maybe Text } deriving (Show, GHC.Generic)
757− -- >>> instance Generic UserRow
758− -- >>> instance HasDatatypeInfo UserRow
759− -- >>> type User = '["userId" ::: 'NotNull 'PGint2, "userName" ::: 'Null 'PGtext]
760− -- >>> fromRow @User @UserRow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)
761− -- Right (UserRow {userId = UserId {getUserId = 1}, userName = Just "bloodninja"})
762− fromRow :: NP (K (Maybe Strict.ByteString)) result -> Either Strict.Text y
763−instance
764− ( SListI result
765− , IsRecord y ys
766− , AllZip FromField result ys
767− ) => FromRow result y where
768− fromRow
769− = fmap fromRecord
770− . hsequence'
771− . htrans (Proxy @FromField) fromField
772−------------------------------------------------------
773−-- P records
774−------------------------------------------------------
775−-- instance (FromField (col ::: pg) (col ::: hask))
776−-- => FromRow '[col ::: pg] (P (col ::: hask)) where
777−-- fromRow (pg :* Nil) = (unComp . fromField) pg
778−-- instance
779−-- ( row ~ Join row1 row2
780−-- , FromRow row1 hask1
781−-- , FromRow row2 hask2
782−-- , SListI row
783−-- ) => FromRow row (hask1, hask2) where
784−-- fromRow row = case disjoin @row1 @row2 row of
785−-- (row1, row2) -> (,) <$> fromRow row1 <*> fromRow row2
786−-- instance
787−-- ( row ~ Join row1 row23
788−-- , FromRow row1 hask1
789−-- , FromRow row23 (hask2, hask3)
790−-- , SListI row
791−-- ) => FromRow row (hask1, hask2, hask3) where
792−-- fromRow row = case disjoin @row1 @row23 row of
793−-- (row1, row23) -> do
794−-- hask1 <- fromRow row1
795−-- (hask2, hask3) <- fromRow row23
796−-- return (hask1, hask2, hask3)
797−-- instance
798−-- ( row ~ Join row1 row234
799−-- , FromRow row1 hask1
800−-- , FromRow row234 (hask2, hask3, hask4)
801−-- , SListI row
802−-- ) => FromRow row (hask1, hask2, hask3, hask4) where
803−-- fromRow row = case disjoin @row1 @row234 row of
804−-- (row1, row234) -> do
805−-- hask1 <- fromRow row1
806−-- (hask2, hask3, hask4) <- fromRow row234
807−-- return (hask1, hask2, hask3, hask4)
808−-- instance
809−-- ( row ~ Join row1 row2345
810−-- , FromRow row1 hask1
811−-- , FromRow row2345 (hask2, hask3, hask4, hask5)
812−-- , SListI row
813−-- ) => FromRow row (hask1, hask2, hask3, hask4, hask5) where
814−-- fromRow row = case disjoin @row1 @row2345 row of
815−-- (row1, row2345) -> do
816−-- hask1 <- fromRow row1
817−-- (hask2, hask3, hask4, hask5) <- fromRow row2345
818−-- return (hask1, hask2, hask3, hask4, hask5)
819−
820−-- | `Only` is a 1-tuple type, useful for encoding a single parameter with
821−-- `toParams` or decoding a single value with `fromRow`.
822−--
823−-- >>> import Data.Text
824−-- >>> toParams @(Only (Maybe Text)) @'[ 'Null 'PGtext] (Only (Just "foo"))
825−-- K (Just "foo") :* Nil
826−--
827−-- >>> fromRow @'["fromOnly" ::: 'Null 'PGtext] @(Only (Maybe Text)) (K (Just "bar") :* Nil)
828−-- Right (Only {fromOnly = Just "bar"})
829−newtype Only x = Only { fromOnly :: x }
830− deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)
831−instance Generic (Only x)
832−instance HasDatatypeInfo (Only x)
833−
834−foldlN
835− :: All ((~) x) xs
836− => (z -> x -> z) -> z -> NP I xs -> z
837−foldlN f z = \case
838− Nil -> z
839− I x :* xs -> let z' = f z x in seq z' $ foldlN f z' xs
840−
841−replicateMN
842− :: forall x xs m. (All ((~) x) xs, Monad m, SListI xs)
843− => m x -> m (NP I xs)
844−replicateMN mx = hsequence' $
845− hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx))
846−
847−getOid :: LibPQ.Oid -> Word32
848−getOid (LibPQ.Oid (CUInt oid)) = oid
squeal-postgresql/src/Squeal/PostgreSQL/Definition.hsdeleted−82
@@ -1,82 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition
3−Description: Squeal data definition language
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Squeal data definition language.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30− , UndecidableInstances
31−#-}
32−
33−module Squeal.PostgreSQL.Definition
34− ( -- * Definition
35− Definition (..)
36− , (>>>)
37− , manipDefinition
38− ) where
39−
40−import Control.Category
41−import Control.DeepSeq
42−import Data.ByteString
43−import Data.Monoid
44−import Prelude hiding ((.), id)
45−
46−import qualified GHC.Generics as GHC
47−
48−import Squeal.PostgreSQL.Manipulation
49−import Squeal.PostgreSQL.Render
50−import Squeal.PostgreSQL.Schema
51−
52−-- $setup
53−-- >>> import Squeal.PostgreSQL
54−
55−{-----------------------------------------
56−statements
57−-----------------------------------------}
58−
59−-- | A `Definition` is a statement that changes the schemas of the
60−-- database, like a `createTable`, `dropTable`, or `alterTable` command.
61−-- `Definition`s may be composed using the `>>>` operator.
62−newtype Definition
63− (schemas0 :: SchemasType)
64− (schemas1 :: SchemasType)
65− = UnsafeDefinition { renderDefinition :: ByteString }
66− deriving (GHC.Generic,Show,Eq,Ord,NFData)
67−
68−instance RenderSQL (Definition schemas0 schemas1) where
69− renderSQL = renderDefinition
70−
71−instance Category Definition where
72− id = UnsafeDefinition ";"
73− ddl1 . ddl0 = UnsafeDefinition $
74− renderSQL ddl0 <> "\n" <> renderSQL ddl1
75−
76−-- | A `Manipulation` without input or output can be run as a statement
77−-- along with other `Definition`s, by embedding it using `manipDefinition`.
78−manipDefinition
79− :: Manipulation '[] schemas '[] '[]
80− -- ^ no input or output
81− -> Definition schemas schemas
82−manipDefinition = UnsafeDefinition . (<> ";") . renderSQL
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hsdeleted−238
@@ -1,238 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Function
3−Description: Create and drop function and operator definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop function and operator definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Function
33− ( createFunction
34− , createOrReplaceFunction
35− , createSetFunction
36− , createOrReplaceSetFunction
37− , createBinaryOp
38− , createLeftOp
39− , createRightOp
40− , dropFunction
41− , dropFunctionIfExists
42− , dropOperator
43− , dropOperatorIfExists
44− , FunctionDefinition(..)
45− , languageSqlExpr
46− , languageSqlQuery
47− ) where
48−
49−import Control.DeepSeq
50−import Data.ByteString
51−import GHC.TypeLits
52−
53−import qualified Generics.SOP as SOP
54−import qualified GHC.Generics as GHC
55−
56−import Squeal.PostgreSQL.Alias
57−import Squeal.PostgreSQL.Definition
58−import Squeal.PostgreSQL.Expression
59−import Squeal.PostgreSQL.Expression.Type
60−import Squeal.PostgreSQL.List
61−import Squeal.PostgreSQL.Query
62−import Squeal.PostgreSQL.Render
63−import Squeal.PostgreSQL.Schema
64−
65−-- $setup
66−-- >>> import Squeal.PostgreSQL
67−
68−createFunction
69− :: ( Has sch schemas schema
70− , KnownSymbol fun
71− , SOP.SListI args )
72− => QualifiedAlias sch fun
73− -> NP (TypeExpression schemas) args
74− -> TypeExpression schemas ret
75− -> FunctionDefinition schemas args ('Returns ret)
76− -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'Returns ret)) schema) schemas)
77−createFunction fun args ret fundef = UnsafeDefinition $
78− "CREATE" <+> "FUNCTION" <+> renderSQL fun
79− <+> parenthesized (renderCommaSeparated renderSQL args)
80− <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
81−
82−createOrReplaceFunction
83− :: ( Has sch schemas schema
84− , KnownSymbol fun
85− , SOP.SListI args )
86− => QualifiedAlias sch fun
87− -> NP (TypeExpression schemas) args
88− -> TypeExpression schemas ret
89− -> FunctionDefinition schemas args ('Returns ret)
90− -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'Returns ret)) schema) schemas)
91−createOrReplaceFunction fun args ret fundef = UnsafeDefinition $
92− "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
93− <+> parenthesized (renderCommaSeparated renderSQL args)
94− <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"
95−
96−languageSqlExpr
97− :: Expression '[] '[] 'Ungrouped schemas args '[] ret
98− -> FunctionDefinition schemas args ('Returns ret)
99−languageSqlExpr expr = UnsafeFunctionDefinition $
100− "language sql as"
101− <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$"
102−
103−languageSqlQuery
104− :: Query '[] '[] schemas args rets
105− -> FunctionDefinition schemas args ('ReturnsTable rets)
106−languageSqlQuery qry = UnsafeFunctionDefinition $
107− "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"
108−
109−createSetFunction
110− :: ( Has sch schemas schema
111− , KnownSymbol fun
112− , SOP.SListI args
113− , SOP.SListI rets )
114− => QualifiedAlias sch fun
115− -> NP (TypeExpression schemas) args
116− -> NP (Aliased (TypeExpression schemas)) rets
117− -> FunctionDefinition schemas args ('ReturnsTable rets)
118− -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
119−createSetFunction fun args rets fundef = UnsafeDefinition $
120− "CREATE" <+> "FUNCTION" <+> renderSQL fun
121− <+> parenthesized (renderCommaSeparated renderSQL args)
122− <+> "RETURNS" <+> "TABLE"
123− <+> parenthesized (renderCommaSeparated renderRet rets)
124− <+> renderSQL fundef <> ";"
125− where
126− renderRet :: Aliased (TypeExpression s) r -> ByteString
127− renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
128−
129−createOrReplaceSetFunction
130− :: ( Has sch schemas schema
131− , KnownSymbol fun
132− , SOP.SListI args
133− , SOP.SListI rets )
134− => QualifiedAlias sch fun
135− -> NP (TypeExpression schemas) args
136− -> NP (Aliased (TypeExpression schemas)) rets
137− -> FunctionDefinition schemas args ('ReturnsTable rets)
138− -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)
139−createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $
140− "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun
141− <+> parenthesized (renderCommaSeparated renderSQL args)
142− <+> "RETURNS" <+> "TABLE"
143− <+> parenthesized (renderCommaSeparated renderRet rets)
144− <+> renderSQL fundef <> ";"
145− where
146− renderRet :: Aliased (TypeExpression s) r -> ByteString
147− renderRet (ty `As` col) = renderSQL col <+> renderSQL ty
148−
149−createBinaryOp
150− :: forall op fun sch schemas schema x y z.
151− ( Has sch schemas schema
152− , Has fun schema ('Function ('[x,y] :=> 'Returns z))
153− , KnownSymbol op )
154− => QualifiedAlias sch fun
155− -> TypeExpression schemas x
156− -> TypeExpression schemas y
157− -> Definition schemas
158− (Alter sch (Create op ('Operator ('BinaryOp x y z)) schema) schemas)
159−createBinaryOp fun x y = UnsafeDefinition $
160− "CREATE" <+> "OPERATOR" <+> renderSymbol @op
161− <+> parenthesized (commaSeparated opdef)
162− where
163− opdef =
164− [ "FUNCTION" <+> "=" <+> renderSQL fun
165− , "LEFTARG" <+> "=" <+> renderSQL x
166− , "RIGHTARG" <+> "=" <+> renderSQL y ]
167−
168−createLeftOp
169− :: forall op fun sch schemas schema x y.
170− ( Has sch schemas schema
171− , Has fun schema ('Function ('[x] :=> 'Returns y))
172− , KnownSymbol op )
173− => QualifiedAlias sch fun
174− -> TypeExpression schemas x
175− -> Definition schemas
176− (Alter sch (Create op ('Operator ('LeftOp x y)) schema) schemas)
177−createLeftOp fun x = UnsafeDefinition $
178− "CREATE" <+> "OPERATOR" <+> renderSymbol @op
179− <+> parenthesized (commaSeparated opdef)
180− where
181− opdef =
182− [ "FUNCTION" <+> "=" <+> renderSQL fun
183− , "RIGHTARG" <+> "=" <+> renderSQL x ]
184−
185−createRightOp
186− :: forall op fun sch schemas schema x y.
187− ( Has sch schemas schema
188− , Has fun schema ('Function ('[x] :=> 'Returns y))
189− , KnownSymbol op )
190− => QualifiedAlias sch fun
191− -> TypeExpression schemas x
192− -> Definition schemas
193− (Alter sch (Create op ('Operator ('RightOp x y)) schema) schemas)
194−createRightOp fun x = UnsafeDefinition $
195− "CREATE" <+> "OPERATOR" <+> renderSymbol @op
196− <+> parenthesized (commaSeparated opdef)
197− where
198− opdef =
199− [ "FUNCTION" <+> "=" <+> renderSQL fun
200− , "LEFTARG" <+> "=" <+> renderSQL x ]
201−
202−dropFunction
203− :: (Has sch schemas schema, KnownSymbol fun)
204− => QualifiedAlias sch fun
205− -- ^ name of the user defined function
206− -> Definition schemas (Alter sch (DropSchemum fun 'Function schema) schemas)
207−dropFunction fun = UnsafeDefinition $
208− "DROP" <+> "FUNCTION" <+> renderSQL fun <> ";"
209−
210−dropFunctionIfExists
211− :: (Has sch schemas schema, KnownSymbol fun)
212− => QualifiedAlias sch fun
213− -- ^ name of the user defined function
214− -> Definition schemas (Alter sch (DropSchemumIfExists fun 'Function schema) schemas)
215−dropFunctionIfExists fun = UnsafeDefinition $
216− "DROP FUNCTION IF EXISTS" <+> renderSQL fun <> ";"
217−
218−dropOperator
219− :: (Has sch schemas schema, KnownSymbol op)
220− => QualifiedAlias sch op
221− -- ^ name of the user defined operator
222− -> Definition schemas (Alter sch (DropSchemum op 'Operator schema) schemas)
223−dropOperator op = UnsafeDefinition $
224− "DROP" <+> "OPERATOR" <+> renderSQL op <> ";"
225−
226−dropOperatorIfExists
227− :: (Has sch schemas schema, KnownSymbol op)
228− => QualifiedAlias sch op
229− -- ^ name of the user defined operator
230− -> Definition schemas (Alter sch (DropSchemumIfExists op 'Operator schema) schemas)
231−dropOperatorIfExists op = UnsafeDefinition $
232− "DROP OPERATOR IF EXISTS" <+> renderSQL op <> ";"
233−
234−newtype FunctionDefinition schemas args ret = UnsafeFunctionDefinition
235− { renderFunctionDefinition :: ByteString }
236− deriving (Eq,Show,GHC.Generic,NFData)
237−instance RenderSQL (FunctionDefinition schemas args ret) where
238− renderSQL = renderFunctionDefinition
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hsdeleted−159
@@ -1,159 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Index
3−Description: Create and drop index definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop index definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Index
33− ( createIndex
34− , createIndexIfNotExists
35− , dropIndex
36− , dropIndexIfExists
37− , IndexMethod (..)
38− , btree
39− , hash
40− , gist
41− , spgist
42− , gin
43− , brin
44− ) where
45−
46−import Data.ByteString
47−import GHC.TypeLits
48−
49−import qualified GHC.Generics as GHC
50−
51−import Squeal.PostgreSQL.Alias
52−import Squeal.PostgreSQL.Definition
53−import Squeal.PostgreSQL.Expression.Sort
54−import Squeal.PostgreSQL.Render
55−import Squeal.PostgreSQL.Schema
56−
57−-- $setup
58−-- >>> import Squeal.PostgreSQL
59−
60−{- |
61−>>> :{
62−type Table = '[] :=>
63− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
64− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
65−:}
66−
67−>>> :{
68−let
69− setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree])
70− setup =
71− createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>>
72− createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast]
73−in printSQL setup
74−:}
75−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
76−CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST);
77−-}
78−createIndex
79− :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
80− => Alias ix
81− -> QualifiedAlias sch tab
82− -> IndexMethod method
83− -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
84− -> Definition schemas (Alter sch (Create ix ('Index method) schema) schemas)
85−createIndex ix tab method cols = UnsafeDefinition $
86− "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab
87− <+> "USING" <+> renderSQL method
88− <+> parenthesized (commaSeparated (renderIndex <$> cols))
89− <> ";"
90− where
91− renderIndex = \case
92− Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
93− Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
94− AscNullsFirst expression -> parenthesized (renderSQL expression)
95− <+> "ASC NULLS FIRST"
96− DescNullsFirst expression -> parenthesized (renderSQL expression)
97− <+> "DESC NULLS FIRST"
98− AscNullsLast expression -> parenthesized (renderSQL expression)
99− <+> "ASC NULLS LAST"
100− DescNullsLast expression -> parenthesized (renderSQL expression)
101− <+> "DESC NULLS LAST"
102−
103−createIndexIfNotExists
104− :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)
105− => Alias ix
106− -> QualifiedAlias sch tab
107− -> IndexMethod method
108− -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]
109− -> Definition schemas (Alter sch (CreateIfNotExists ix ('Index method) schema) schemas)
110−createIndexIfNotExists ix tab method cols = UnsafeDefinition $
111− "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab
112− <+> "USING" <+> renderSQL method
113− <+> parenthesized (commaSeparated (renderIndex <$> cols))
114− <> ";"
115− where
116− renderIndex = \case
117− Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
118− Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
119− AscNullsFirst expression -> parenthesized (renderSQL expression)
120− <+> "ASC NULLS FIRST"
121− DescNullsFirst expression -> parenthesized (renderSQL expression)
122− <+> "DESC NULLS FIRST"
123− AscNullsLast expression -> parenthesized (renderSQL expression)
124− <+> "ASC NULLS LAST"
125− DescNullsLast expression -> parenthesized (renderSQL expression)
126− <+> "DESC NULLS LAST"
127−
128−newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString}
129− deriving stock (Eq, Ord, Show, GHC.Generic)
130−instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod
131−btree :: IndexMethod 'Btree
132−btree = UnsafeIndexMethod "btree"
133−hash :: IndexMethod 'Hash
134−hash = UnsafeIndexMethod "hash"
135−gist :: IndexMethod 'Gist
136−gist = UnsafeIndexMethod "gist"
137−spgist :: IndexMethod 'Spgist
138−spgist = UnsafeIndexMethod "spgist"
139−gin :: IndexMethod 'Gin
140−gin = UnsafeIndexMethod "gin"
141−brin :: IndexMethod 'Brin
142−brin = UnsafeIndexMethod "brin"
143−
144−-- |
145−-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[]))
146−-- DROP INDEX "ix";
147−dropIndex
148− :: (Has sch schemas schema, KnownSymbol ix)
149− => QualifiedAlias sch ix
150− -- ^ name of the user defined index
151− -> Definition schemas (Alter sch (DropSchemum ix 'Index schema) schemas)
152−dropIndex ix = UnsafeDefinition $ "DROP" <+> "INDEX" <+> renderSQL ix <> ";"
153−
154−dropIndexIfExists
155− :: (Has sch schemas schema, KnownSymbol ix)
156− => QualifiedAlias sch ix
157− -- ^ name of the user defined index
158− -> Definition schemas (Alter sch (DropSchemumIfExists ix 'Index schema) schemas)
159−dropIndexIfExists ix = UnsafeDefinition $ "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hsdeleted−96
@@ -1,96 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Schema
3−Description: Create and drop schema definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop schema definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Schema
33− ( createSchema
34− , createSchemaIfNotExists
35− , dropSchema
36− , dropSchemaIfExists
37− ) where
38−
39−import GHC.TypeLits
40−
41−import Squeal.PostgreSQL.Alias
42−import Squeal.PostgreSQL.Definition
43−import Squeal.PostgreSQL.Render
44−import Squeal.PostgreSQL.Schema
45−
46−-- $setup
47−-- >>> import Squeal.PostgreSQL
48−
49−{- |
50−`createSchema` enters a new schema into the current database.
51−The schema name must be distinct from the name of any existing schema
52−in the current database.
53−
54−A schema is essentially a namespace: it contains named objects
55−(tables, data types, functions, and operators) whose names
56−can duplicate those of other objects existing in other schemas.
57−Named objects are accessed by `QualifiedAlias`es with the schema
58−name as a prefix.
59−-}
60−createSchema
61− :: KnownSymbol sch
62− => Alias sch
63− -> Definition schemas (Create sch '[] schemas)
64−createSchema sch = UnsafeDefinition $
65− "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
66−
67−{- | Idempotent version of `createSchema`. -}
68−createSchemaIfNotExists
69− :: (KnownSymbol sch, Has sch schemas schema)
70− => Alias sch
71− -> Definition schemas (CreateIfNotExists sch '[] schemas)
72−createSchemaIfNotExists sch = UnsafeDefinition $
73− "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
74− <+> renderSQL sch <> ";"
75−
76−-- | >>> :{
77−-- let
78−-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
79−-- definition = dropSchema #muh_schema
80−-- :}
81−--
82−-- >>> printSQL definition
83−-- DROP SCHEMA "muh_schema";
84−dropSchema
85− :: KnownSymbol sch
86− => Alias sch
87− -- ^ user defined schema
88− -> Definition schemas (Drop sch schemas)
89−dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
90−
91−dropSchemaIfExists
92− :: KnownSymbol sch
93− => Alias sch
94− -- ^ user defined schema
95− -> Definition schemas (DropIfExists sch schemas)
96−dropSchemaIfExists sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hsdeleted−500
@@ -1,500 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Table
3−Description: Create, drop and alter table definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create, drop and alter table definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Table
33− ( createTable
34− , createTableIfNotExists
35− , dropTable
36− , dropTableIfExists
37− , alterTable
38− , alterTableIfExists
39− , alterTableRename
40− , alterTableIfExistsRename
41− , AlterTable (..)
42− , addConstraint
43− , dropConstraint
44− , AddColumn (..)
45− , dropColumn
46− , renameColumn
47− , alterColumn
48− , AlterColumn (..)
49− , setDefault
50− , dropDefault
51− , setNotNull
52− , dropNotNull
53− , alterType
54− ) where
55−
56−import Control.DeepSeq
57−import Data.ByteString
58−import GHC.TypeLits
59−
60−import qualified Generics.SOP as SOP
61−import qualified GHC.Generics as GHC
62−
63−import Squeal.PostgreSQL.Alias
64−import Squeal.PostgreSQL.Definition
65−import Squeal.PostgreSQL.Definition.Table.Constraint
66−import Squeal.PostgreSQL.Expression
67−import Squeal.PostgreSQL.Expression.Type
68−import Squeal.PostgreSQL.List
69−import Squeal.PostgreSQL.Render
70−import Squeal.PostgreSQL.Schema
71−
72−-- $setup
73−-- >>> import Squeal.PostgreSQL
74−
75−{- | `createTable` adds a table to the schema.
76−
77−>>> :set -XOverloadedLabels
78−>>> :{
79−type Table = '[] :=>
80− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
81− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
82−:}
83−
84−>>> :{
85−let
86− setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])
87− setup = createTable #tab
88− (nullable int `as` #a :* nullable real `as` #b) Nil
89−in printSQL setup
90−:}
91−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
92−-}
93−createTable
94− :: ( KnownSymbol sch
95− , KnownSymbol tab
96− , columns ~ (col ': cols)
97− , SOP.SListI columns
98− , SOP.SListI constraints
99− , Has sch schemas0 schema0
100− , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )
101− => QualifiedAlias sch tab -- ^ the name of the table to add
102− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
103− -- ^ the names and datatype of each column
104− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
105− -- ^ constraints that must hold for the table
106− -> Definition schemas0 schemas1
107−createTable tab columns constraints = UnsafeDefinition $
108− "CREATE TABLE" <+> renderCreation tab columns constraints
109−
110−{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.
111−Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.
112−`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in
113−the `Category` of `Definition`s.
114−
115−>>> :set -XOverloadedLabels -XTypeApplications
116−>>> :{
117−type Table = '[] :=>
118− '[ "a" ::: 'NoDef :=> 'Null 'PGint4
119− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
120−:}
121−
122−>>> type Schemas = Public '["tab" ::: 'Table Table]
123−
124−>>> :{
125−let
126− setup :: Definition Schemas Schemas
127− setup = createTableIfNotExists #tab
128− (nullable int `as` #a :* nullable real `as` #b) Nil
129−in printSQL setup
130−:}
131−CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);
132−-}
133−createTableIfNotExists
134− :: ( KnownSymbol sch
135− , KnownSymbol tab
136− , columns ~ (col ': cols)
137− , SOP.SListI columns
138− , SOP.SListI constraints
139− , Has sch schemas0 schema0
140− , schemas1 ~ Alter sch (CreateIfNotExists tab ('Table (constraints :=> columns)) schema0) schemas0 )
141− => QualifiedAlias sch tab -- ^ the name of the table to add
142− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
143− -- ^ the names and datatype of each column
144− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
145− -- ^ constraints that must hold for the table
146− -> Definition schemas0 schemas1
147−createTableIfNotExists tab columns constraints = UnsafeDefinition $
148− "CREATE TABLE IF NOT EXISTS"
149− <+> renderCreation tab columns constraints
150−
151−-- helper function for `createTable` and `createTableIfNotExists`
152−renderCreation
153− :: ( KnownSymbol sch
154− , KnownSymbol tab
155− , SOP.SListI columns
156− , SOP.SListI constraints )
157− => QualifiedAlias sch tab -- ^ the name of the table to add
158− -> NP (Aliased (ColumnTypeExpression schemas0)) columns
159− -- ^ the names and datatype of each column
160− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints
161− -- ^ constraints that must hold for the table
162− -> ByteString
163−renderCreation tab columns constraints = renderSQL tab
164− <+> parenthesized
165− ( renderCommaSeparated renderColumnDef columns
166− <> ( case constraints of
167− Nil -> ""
168− _ -> ", " <>
169− renderCommaSeparated renderConstraint constraints ) )
170− <> ";"
171− where
172− renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString
173− renderColumnDef (ty `As` column) =
174− renderSQL column <+> renderColumnTypeExpression ty
175− renderConstraint
176− :: Aliased (TableConstraintExpression sch tab schemas) constraint
177− -> ByteString
178− renderConstraint (constraint `As` alias) =
179− "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint
180−
181−-- | `dropTable` removes a table from the schema.
182−--
183−-- >>> :{
184−-- let
185−-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])
186−-- definition = dropTable #muh_table
187−-- :}
188−--
189−-- >>> printSQL definition
190−-- DROP TABLE "muh_table";
191−dropTable
192− :: ( Has sch schemas schema
193− , KnownSymbol tab )
194− => QualifiedAlias sch tab -- ^ table to remove
195− -> Definition schemas (Alter sch (DropSchemum tab 'Table schema) schemas)
196−dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"
197−
198−dropTableIfExists
199− :: ( Has sch schemas schema
200− , KnownSymbol tab)
201− => QualifiedAlias sch tab -- ^ table to remove
202− -> Definition schemas (Alter sch (DropSchemumIfExists tab 'Table schema) schemas)
203−dropTableIfExists tab = UnsafeDefinition $ "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";"
204−
205−-- | `alterTable` changes the definition of a table from the schema.
206−alterTable
207− :: (Has sch schemas schema, KnownSymbol tab)
208− => QualifiedAlias sch tab -- ^ table to alter
209− -> AlterTable sch tab schemas table -- ^ alteration to perform
210− -> Definition schemas (Alter sch (Alter tab ('Table table) schema) schemas)
211−alterTable tab alteration = UnsafeDefinition $
212− "ALTER TABLE"
213− <+> renderSQL tab
214− <+> renderAlterTable alteration
215− <> ";"
216−
217−-- | `alterTable` changes the definition of a table from the schema.
218−alterTableIfExists
219− :: (Has sch schemas schema, KnownSymbol tab)
220− => QualifiedAlias sch tab -- ^ table to alter
221− -> AlterTable sch tab schemas table -- ^ alteration to perform
222− -> Definition schemas (Alter sch (AlterIfExists tab ('Table table) schema) schemas)
223−alterTableIfExists tab alteration = UnsafeDefinition $
224− "ALTER TABLE IF EXISTS"
225− <+> renderSQL tab
226− <+> renderAlterTable alteration
227− <> ";"
228−
229−-- | `alterTableRename` changes the name of a table from the schema.
230−--
231−-- >>> printSQL $ alterTableRename #foo #bar
232−-- ALTER TABLE "foo" RENAME TO "bar";
233−alterTableRename
234− :: (KnownSymbol tab0, KnownSymbol tab1)
235− => Alias tab0 -- ^ table to rename
236− -> Alias tab1 -- ^ what to rename it
237− -> Definition schema (Rename tab0 tab1 schema)
238−alterTableRename tab0 tab1 = UnsafeDefinition $
239− "ALTER TABLE" <+> renderSQL tab0
240− <+> "RENAME TO" <+> renderSQL tab1 <> ";"
241−
242−alterTableIfExistsRename
243− :: (KnownSymbol tab0, KnownSymbol tab1)
244− => Alias tab0 -- ^ table to rename
245− -> Alias tab1 -- ^ what to rename it
246− -> Definition schema (RenameIfExists tab0 tab1 schema)
247−alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $
248− "ALTER TABLE IF EXISTS" <+> renderSQL tab0
249− <+> "RENAME TO" <+> renderSQL tab1 <> ";"
250−
251−-- | An `AlterTable` describes the alteration to perform on the columns
252−-- of a table.
253−newtype AlterTable
254− (sch :: Symbol)
255− (tab :: Symbol)
256− (schemas :: SchemasType)
257− (table :: TableType) =
258− UnsafeAlterTable {renderAlterTable :: ByteString}
259− deriving (GHC.Generic,Show,Eq,Ord,NFData)
260−
261−-- | An `addConstraint` adds a table constraint.
262−--
263−-- >>> :{
264−-- let
265−-- definition :: Definition
266−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
267−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
268−-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))
269−-- in printSQL definition
270−-- :}
271−-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));
272−addConstraint
273− :: ( KnownSymbol alias
274− , Has sch schemas schema
275− , Has tab schema ('Table table0)
276− , table0 ~ (constraints :=> columns)
277− , table1 ~ (Create alias constraint constraints :=> columns) )
278− => Alias alias
279− -> TableConstraintExpression sch tab schemas constraint
280− -- ^ constraint to add
281− -> AlterTable sch tab schemas table1
282−addConstraint alias constraint = UnsafeAlterTable $
283− "ADD" <+> "CONSTRAINT" <+> renderSQL alias
284− <+> renderSQL constraint
285−
286−-- | A `dropConstraint` drops a table constraint.
287−--
288−-- >>> :{
289−-- let
290−-- definition :: Definition
291−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
292−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
293−-- definition = alterTable #tab (dropConstraint #positive)
294−-- in printSQL definition
295−-- :}
296−-- ALTER TABLE "tab" DROP CONSTRAINT "positive";
297−dropConstraint
298− :: ( KnownSymbol constraint
299− , Has sch schemas schema
300− , Has tab schema ('Table table0)
301− , table0 ~ (constraints :=> columns)
302− , table1 ~ (Drop constraint constraints :=> columns) )
303− => Alias constraint
304− -- ^ constraint to drop
305− -> AlterTable sch tab schemas table1
306−dropConstraint constraint = UnsafeAlterTable $
307− "DROP" <+> "CONSTRAINT" <+> renderSQL constraint
308−
309−-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.
310−class AddColumn ty where
311− -- | `addColumn` adds a new column, initially filled with whatever
312− -- default value is given or with @NULL@.
313− --
314− -- >>> :{
315− -- let
316− -- definition :: Definition
317− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
318− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
319− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
320− -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]
321− -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))
322− -- in printSQL definition
323− -- :}
324− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';
325− --
326− -- >>> :{
327− -- let
328− -- definition :: Definition
329− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
330− -- '["public" ::: '["tab" ::: 'Table ('[] :=>
331− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
332− -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
333− -- definition = alterTable #tab (addColumn #col2 (text & nullable))
334− -- in printSQL definition
335− -- :}
336− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;
337− addColumn
338− :: ( KnownSymbol column
339− , Has sch schemas schema
340− , Has tab schema ('Table table0)
341− , table0 ~ (constraints :=> columns) )
342− => Alias column -- ^ column to add
343− -> ColumnTypeExpression schemas ty -- ^ type of the new column
344− -> AlterTable sch tab schemas (constraints :=> Create column ty columns)
345− addColumn column ty = UnsafeAlterTable $
346− "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty
347−instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)
348−instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)
349−
350−-- | A `dropColumn` removes a column. Whatever data was in the column
351−-- disappears. Table constraints involving the column are dropped, too.
352−-- However, if the column is referenced by a foreign key constraint of
353−-- another table, PostgreSQL will not silently drop that constraint.
354−--
355−-- >>> :{
356−-- let
357−-- definition :: Definition
358−-- '["public" ::: '["tab" ::: 'Table ('[] :=>
359−-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4
360−-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]
361−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]
362−-- definition = alterTable #tab (dropColumn #col2)
363−-- in printSQL definition
364−-- :}
365−-- ALTER TABLE "tab" DROP COLUMN "col2";
366−dropColumn
367− :: ( KnownSymbol column
368− , Has sch schemas schema
369− , Has tab schema ('Table table0)
370− , table0 ~ (constraints :=> columns)
371− , table1 ~ (constraints :=> Drop column columns) )
372− => Alias column -- ^ column to remove
373− -> AlterTable sch tab schemas table1
374−dropColumn column = UnsafeAlterTable $
375− "DROP COLUMN" <+> renderSQL column
376−
377−-- | A `renameColumn` renames a column.
378−--
379−-- >>> :{
380−-- let
381−-- definition :: Definition
382−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]
383−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]
384−-- definition = alterTable #tab (renameColumn #foo #bar)
385−-- in printSQL definition
386−-- :}
387−-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";
388−renameColumn
389− :: ( KnownSymbol column0
390− , KnownSymbol column1
391− , Has sch schemas schema
392− , Has tab schema ('Table table0)
393− , table0 ~ (constraints :=> columns)
394− , table1 ~ (constraints :=> Rename column0 column1 columns) )
395− => Alias column0 -- ^ column to rename
396− -> Alias column1 -- ^ what to rename the column
397− -> AlterTable sch tab schemas table1
398−renameColumn column0 column1 = UnsafeAlterTable $
399− "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1
400−
401−-- | An `alterColumn` alters a single column.
402−alterColumn
403− :: ( KnownSymbol column
404− , Has sch schemas schema
405− , Has tab schema ('Table table0)
406− , table0 ~ (constraints :=> columns)
407− , Has column columns ty0
408− , table1 ~ (constraints :=> Alter column ty1 columns))
409− => Alias column -- ^ column to alter
410− -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform
411− -> AlterTable sch tab schemas table1
412−alterColumn column alteration = UnsafeAlterTable $
413− "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration
414−
415−-- | An `AlterColumn` describes the alteration to perform on a single column.
416−newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =
417− UnsafeAlterColumn {renderAlterColumn :: ByteString}
418− deriving (GHC.Generic,Show,Eq,Ord,NFData)
419−
420−-- | A `setDefault` sets a new default for a column. Note that this doesn't
421−-- affect any existing rows in the table, it just changes the default for
422−-- future insert and update commands.
423−--
424−-- >>> :{
425−-- let
426−-- definition :: Definition
427−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
428−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
429−-- definition = alterTable #tab (alterColumn #col (setDefault 5))
430−-- in printSQL definition
431−-- :}
432−-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;
433−setDefault
434− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set
435− -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)
436−setDefault expression = UnsafeAlterColumn $
437− "SET DEFAULT" <+> renderExpression expression
438−
439−-- | A `dropDefault` removes any default value for a column.
440−--
441−-- >>> :{
442−-- let
443−-- definition :: Definition
444−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]
445−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
446−-- definition = alterTable #tab (alterColumn #col dropDefault)
447−-- in printSQL definition
448−-- :}
449−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;
450−dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)
451−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"
452−
453−-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.
454−-- The constraint will be checked immediately, so the table data must satisfy
455−-- the constraint before it can be added.
456−--
457−-- >>> :{
458−-- let
459−-- definition :: Definition
460−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
461−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
462−-- definition = alterTable #tab (alterColumn #col setNotNull)
463−-- in printSQL definition
464−-- :}
465−-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;
466−setNotNull
467− :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)
468−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"
469−
470−-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.
471−--
472−-- >>> :{
473−-- let
474−-- definition :: Definition
475−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
476−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]
477−-- definition = alterTable #tab (alterColumn #col dropNotNull)
478−-- in printSQL definition
479−-- :}
480−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;
481−dropNotNull
482− :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)
483−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"
484−
485−-- | An `alterType` converts a column to a different data type.
486−-- This will succeed only if each existing entry in the column can be
487−-- converted to the new type by an implicit cast.
488−--
489−-- >>> :{
490−-- let
491−-- definition :: Definition
492−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]
493−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]
494−-- definition =
495−-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))
496−-- in printSQL definition
497−-- :}
498−-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;
499−alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty
500−alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table/Constraint.hsdeleted−339
@@ -1,339 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Table.Constraint
3−Description: Table constraint expressions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Table constraint expressions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Table.Constraint
33− ( TableConstraintExpression (..)
34− , check
35− , unique
36− , primaryKey
37− , foreignKey
38− , ForeignKeyed
39− , OnDeleteClause (..)
40− , OnUpdateClause (..)
41− ) where
42−
43−import Control.DeepSeq
44−import Data.ByteString
45−import GHC.TypeLits
46−
47−import qualified Generics.SOP as SOP
48−import qualified GHC.Generics as GHC
49−
50−import Squeal.PostgreSQL.Alias
51−import Squeal.PostgreSQL.Expression.Logic
52−import Squeal.PostgreSQL.List
53−import Squeal.PostgreSQL.Render
54−import Squeal.PostgreSQL.Schema
55−
56−-- $setup
57−-- >>> import Squeal.PostgreSQL
58−
59−-- | Data types are a way to limit the kind of data that can be stored in a
60−-- table. For many applications, however, the constraint they provide is
61−-- too coarse. For example, a column containing a product price should
62−-- probably only accept positive values. But there is no standard data type
63−-- that accepts only positive numbers. Another issue is that you might want
64−-- to constrain column data with respect to other columns or rows.
65−-- For example, in a table containing product information,
66−-- there should be only one row for each product number.
67−-- `TableConstraint`s give you as much control over the data in your tables
68−-- as you wish. If a user attempts to store data in a column that would
69−-- violate a constraint, an error is raised. This applies
70−-- even if the value came from the default value definition.
71−newtype TableConstraintExpression
72− (sch :: Symbol)
73− (tab :: Symbol)
74− (schemas :: SchemasType)
75− (constraint :: TableConstraint)
76− = UnsafeTableConstraintExpression
77− { renderTableConstraintExpression :: ByteString }
78− deriving (GHC.Generic,Show,Eq,Ord,NFData)
79−instance RenderSQL
80− (TableConstraintExpression sch tab schemas constraint) where
81− renderSQL = renderTableConstraintExpression
82−
83−{-| A `check` constraint is the most generic `TableConstraint` type.
84−It allows you to specify that the value in a certain column must satisfy
85−a Boolean (truth-value) expression.
86−
87−>>> :{
88−type Schema = '[
89− "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[
90− "a" ::: 'NoDef :=> 'NotNull 'PGint4,
91− "b" ::: 'NoDef :=> 'NotNull 'PGint4
92− ])]
93−:}
94−
95−>>> :{
96−let
97− definition :: Definition (Public '[]) (Public Schema)
98− definition = createTable #tab
99− ( (int & notNullable) `as` #a :*
100− (int & notNullable) `as` #b )
101− ( check (#a :* #b) (#a .> #b) `as` #inequality )
102−:}
103−
104−>>> printSQL definition
105−CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));
106−-}
107−check
108− :: ( Has sch schemas schema
109− , Has tab schema ('Table table)
110− , HasAll aliases (TableToRow table) subcolumns )
111− => NP Alias aliases
112− -- ^ specify the subcolumns which are getting checked
113− -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])
114− -- ^ a closed `Condition` on those subcolumns
115− -> TableConstraintExpression sch tab schemas ('Check aliases)
116−check _cols condition = UnsafeTableConstraintExpression $
117− "CHECK" <+> parenthesized (renderSQL condition)
118−
119−{-| A `unique` constraint ensure that the data contained in a column,
120−or a group of columns, is unique among all the rows in the table.
121−
122−>>> :{
123−type Schema = '[
124− "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[
125− "a" ::: 'NoDef :=> 'Null 'PGint4,
126− "b" ::: 'NoDef :=> 'Null 'PGint4
127− ])]
128−:}
129−
130−>>> :{
131−let
132− definition :: Definition (Public '[]) (Public Schema)
133− definition = createTable #tab
134− ( (int & nullable) `as` #a :*
135− (int & nullable) `as` #b )
136− ( unique (#a :* #b) `as` #uq_a_b )
137−:}
138−
139−>>> printSQL definition
140−CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));
141−-}
142−unique
143− :: ( Has sch schemas schema
144− , Has tab schema('Table table)
145− , HasAll aliases (TableToRow table) subcolumns )
146− => NP Alias aliases
147− -- ^ specify subcolumns which together are unique for each row
148− -> TableConstraintExpression sch tab schemas ('Unique aliases)
149−unique columns = UnsafeTableConstraintExpression $
150− "UNIQUE" <+> parenthesized (renderSQL columns)
151−
152−{-| A `primaryKey` constraint indicates that a column, or group of columns,
153−can be used as a unique identifier for rows in the table.
154−This requires that the values be both unique and not null.
155−
156−>>> :{
157−type Schema = '[
158− "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[
159− "id" ::: 'Def :=> 'NotNull 'PGint4,
160− "name" ::: 'NoDef :=> 'NotNull 'PGtext
161− ])]
162−:}
163−
164−>>> :{
165−let
166− definition :: Definition (Public '[]) (Public Schema)
167− definition = createTable #tab
168− ( serial `as` #id :*
169− (text & notNullable) `as` #name )
170− ( primaryKey #id `as` #pk_id )
171−:}
172−
173−>>> printSQL definition
174−CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));
175−-}
176−primaryKey
177− :: ( Has sch schemas schema
178− , Has tab schema ('Table table)
179− , HasAll aliases (TableToColumns table) subcolumns
180− , AllNotNull subcolumns )
181− => NP Alias aliases
182− -- ^ specify the subcolumns which together form a primary key.
183− -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)
184−primaryKey columns = UnsafeTableConstraintExpression $
185− "PRIMARY KEY" <+> parenthesized (renderSQL columns)
186−
187−{-| A `foreignKey` specifies that the values in a column
188−(or a group of columns) must match the values appearing in some row of
189−another table. We say this maintains the referential integrity
190−between two related tables.
191−
192−>>> :{
193−type Schema =
194− '[ "users" ::: 'Table (
195− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
196− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
197− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
198− ])
199− , "emails" ::: 'Table (
200− '[ "pk_emails" ::: 'PrimaryKey '["id"]
201− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
202− ] :=>
203− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
204− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
205− , "email" ::: 'NoDef :=> 'Null 'PGtext
206− ])
207− ]
208−:}
209−
210−>>> :{
211−let
212− setup :: Definition (Public '[]) (Public Schema)
213− setup =
214− createTable #users
215− ( serial `as` #id :*
216− (text & notNullable) `as` #name )
217− ( primaryKey #id `as` #pk_users ) >>>
218− createTable #emails
219− ( serial `as` #id :*
220− (int & notNullable) `as` #user_id :*
221− (text & nullable) `as` #email )
222− ( primaryKey #id `as` #pk_emails :*
223− foreignKey #user_id #users #id
224− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
225−in printSQL setup
226−:}
227−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));
228−CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
229−
230−A `foreignKey` can even be a table self-reference.
231−
232−>>> :{
233−type Schema =
234− '[ "employees" ::: 'Table (
235− '[ "employees_pk" ::: 'PrimaryKey '["id"]
236− , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]
237− ] :=>
238− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
239− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
240− , "employer_id" ::: 'NoDef :=> 'Null 'PGint4
241− ])
242− ]
243−:}
244−
245−>>> :{
246−let
247− setup :: Definition (Public '[]) (Public Schema)
248− setup =
249− createTable #employees
250− ( serial `as` #id :*
251− (text & notNullable) `as` #name :*
252− (integer & nullable) `as` #employer_id )
253− ( primaryKey #id `as` #employees_pk :*
254− foreignKey #employer_id #employees #id
255− OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )
256−in printSQL setup
257−:}
258−CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE);
259−-}
260−foreignKey
261− :: (ForeignKeyed schemas sch schema child parent
262− table reftable
263− columns refcolumns
264− constraints cols
265− reftys tys )
266− => NP Alias columns
267− -- ^ column or columns in the table
268− -> Alias parent
269− -- ^ reference table
270− -> NP Alias refcolumns
271− -- ^ reference column or columns in the reference table
272− -> OnDeleteClause
273− -- ^ what to do when reference is deleted
274− -> OnUpdateClause
275− -- ^ what to do when reference is updated
276− -> TableConstraintExpression sch child schemas
277− ('ForeignKey columns parent refcolumns)
278−foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $
279− "FOREIGN KEY" <+> parenthesized (renderSQL keys)
280− <+> "REFERENCES" <+> renderSQL parent
281− <+> parenthesized (renderSQL refs)
282− <+> renderSQL ondel
283− <+> renderSQL onupd
284−
285−-- | A constraint synonym between types involved in a foreign key constraint.
286−type ForeignKeyed schemas
287− sch
288− schema
289− child parent
290− table reftable
291− columns refcolumns
292− constraints cols
293− reftys tys =
294− ( Has sch schemas schema
295− , Has child schema ('Table table)
296− , Has parent schema ('Table reftable)
297− , HasAll columns (TableToColumns table) tys
298− , reftable ~ (constraints :=> cols)
299− , HasAll refcolumns cols reftys
300− , SOP.AllZip SamePGType tys reftys
301− , Uniquely refcolumns constraints )
302−
303−-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.
304−data OnDeleteClause
305− = OnDeleteNoAction
306− -- ^ if any referencing rows still exist when the constraint is checked,
307− -- an error is raised
308− | OnDeleteRestrict -- ^ prevents deletion of a referenced row
309− | OnDeleteCascade
310− -- ^ specifies that when a referenced row is deleted,
311− -- row(s) referencing it should be automatically deleted as well
312− deriving (GHC.Generic,Show,Eq,Ord)
313−instance NFData OnDeleteClause
314−-- | Render `OnDeleteClause`.
315−instance RenderSQL OnDeleteClause where
316− renderSQL = \case
317− OnDeleteNoAction -> "ON DELETE NO ACTION"
318− OnDeleteRestrict -> "ON DELETE RESTRICT"
319− OnDeleteCascade -> "ON DELETE CASCADE"
320−
321−-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked
322−-- when a referenced column is changed (updated).
323−data OnUpdateClause
324− = OnUpdateNoAction
325− -- ^ if any referencing rows has not changed when the constraint is checked,
326− -- an error is raised
327− | OnUpdateRestrict -- ^ prevents update of a referenced row
328− | OnUpdateCascade
329− -- ^ the updated values of the referenced column(s) should be copied
330− -- into the referencing row(s)
331− deriving (GHC.Generic,Show,Eq,Ord)
332−instance NFData OnUpdateClause
333−
334−-- | Render `OnUpdateClause`.
335−instance RenderSQL OnUpdateClause where
336− renderSQL = \case
337− OnUpdateNoAction -> "ON UPDATE NO ACTION"
338− OnUpdateRestrict -> "ON UPDATE RESTRICT"
339− OnUpdateCascade -> "ON UPDATE CASCADE"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hsdeleted−229
@@ -1,229 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.Type
3−Description: Create and drop type definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop type definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.Type
33− ( createTypeEnum
34− , createTypeEnumFrom
35− , createTypeComposite
36− , createTypeCompositeFrom
37− , createTypeRange
38− , createDomain
39− , dropType
40− , dropTypeIfExists
41− ) where
42−
43−import Data.ByteString
44−import Data.Monoid
45−import GHC.TypeLits
46−import Prelude hiding ((.), id)
47−
48−import qualified Generics.SOP as SOP
49−
50−import Squeal.PostgreSQL.Alias
51−import Squeal.PostgreSQL.Expression.Logic
52−import Squeal.PostgreSQL.Expression.Type
53−import Squeal.PostgreSQL.Definition
54−import Squeal.PostgreSQL.List
55−import Squeal.PostgreSQL.PG
56−import Squeal.PostgreSQL.Render
57−import Squeal.PostgreSQL.Schema
58−
59−-- $setup
60−-- >>> import Squeal.PostgreSQL
61−-- >>> import qualified GHC.Generics as GHC
62−-- >>> import qualified Generics.SOP as SOP
63−
64−-- | Enumerated types are created using the `createTypeEnum` command, for example
65−--
66−-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])
67−-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');
68−createTypeEnum
69− :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)
70− => QualifiedAlias sch enum
71− -- ^ name of the user defined enumerated type
72− -> NP PGlabel labels
73− -- ^ labels of the enumerated type
74− -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)
75−createTypeEnum enum labels = UnsafeDefinition $
76− "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>
77− parenthesized (renderSQL labels) <> ";"
78−
79−-- | Enumerated types can also be generated from a Haskell type, for example
80−--
81−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
82−-- >>> instance SOP.Generic Schwarma
83−-- >>> instance SOP.HasDatatypeInfo Schwarma
84−-- >>> :{
85−-- let
86−-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]
87−-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma
88−-- in
89−-- printSQL createSchwarma
90−-- :}
91−-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');
92−createTypeEnumFrom
93− :: forall hask sch enum schemas schema.
94− ( SOP.Generic hask
95− , SOP.All KnownSymbol (LabelsPG hask)
96− , KnownSymbol enum
97− , Has sch schemas schema )
98− => QualifiedAlias sch enum
99− -- ^ name of the user defined enumerated type
100− -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)
101−createTypeEnumFrom enum = createTypeEnum enum
102− (SOP.hpure label :: NP PGlabel (LabelsPG hask))
103−
104−{- | `createTypeComposite` creates a composite type. The composite type is
105−specified by a list of attribute names and data types.
106−
107−>>> :{
108−type PGcomplex = 'PGcomposite
109− '[ "real" ::: 'NotNull 'PGfloat8
110− , "imaginary" ::: 'NotNull 'PGfloat8 ]
111−:}
112−
113−>>> :{
114−let
115− setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]
116− setup = createTypeComposite #complex
117− (float8 `as` #real :* float8 `as` #imaginary)
118−in printSQL setup
119−:}
120−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
121−-}
122−createTypeComposite
123− :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)
124− => QualifiedAlias sch ty
125− -- ^ name of the user defined composite type
126− -> NP (Aliased (TypeExpression schemas)) fields
127− -- ^ list of attribute names and data types
128− -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)
129−createTypeComposite ty fields = UnsafeDefinition $
130− "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized
131− (renderCommaSeparated renderField fields) <> ";"
132− where
133− renderField :: Aliased (TypeExpression schemas) x -> ByteString
134− renderField (typ `As` alias) =
135− renderSQL alias <+> renderSQL typ
136−
137−-- | Composite types can also be generated from a Haskell type, for example
138−--
139−-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic
140−-- >>> instance SOP.Generic Complex
141−-- >>> instance SOP.HasDatatypeInfo Complex
142−-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]
143−-- >>> :{
144−-- let
145−-- createComplex :: Definition (Public '[]) (Public Schema)
146−-- createComplex = createTypeCompositeFrom @Complex #complex
147−-- in
148−-- printSQL createComplex
149−-- :}
150−-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);
151−createTypeCompositeFrom
152− :: forall hask sch ty schemas schema.
153− ( SOP.All (FieldTyped schemas) (RowPG hask)
154− , KnownSymbol ty
155− , Has sch schemas schema )
156− => QualifiedAlias sch ty
157− -- ^ name of the user defined composite type
158− -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)
159−createTypeCompositeFrom ty = createTypeComposite ty
160− (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype
161− :: NP (Aliased (TypeExpression schemas)) (RowPG hask))
162−
163−{-|
164−`createDomain` creates a new domain. A domain is essentially a data type
165−with constraints (restrictions on the allowed set of values).
166−
167−Domains are useful for abstracting common constraints on fields
168−into a single location for maintenance. For example, several tables might
169−contain email address columns, all requiring the same `check` constraint
170−to verify the address syntax. Define a domain rather than setting up
171−each table's constraint individually.
172−
173−>>> :{
174−let
175− createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])
176− createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))
177−in printSQL createPositive
178−:}
179−CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));
180−-}
181−createDomain
182− :: (Has sch schemas schema, KnownSymbol dom)
183− => QualifiedAlias sch dom
184− -> (forall null. TypeExpression schemas (null ty))
185− -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])
186− -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)
187−createDomain dom ty condition =
188− UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom
189− <+> "AS" <+> renderTypeExpression ty
190− <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"
191−
192−{- |
193−>>> :{
194−let
195− createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)])
196− createSmallIntRange = createTypeRange #int2range int2
197−in printSQL createSmallIntRange
198−:}
199−CREATE TYPE "int2range" AS RANGE (subtype = int2);
200−-}
201−createTypeRange
202− :: (Has sch schemas schema, KnownSymbol range)
203− => QualifiedAlias sch range
204− -> (forall null. TypeExpression schemas (null ty))
205− -> Definition schemas (Alter sch (Create range ('Typedef ('PGrange ty)) schema) schemas)
206−createTypeRange range ty = UnsafeDefinition $
207− "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>
208− parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";"
209−
210−-- | Drop a type.
211−--
212−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
213−-- >>> instance SOP.Generic Schwarma
214−-- >>> instance SOP.HasDatatypeInfo Schwarma
215−-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))
216−-- DROP TYPE "schwarma";
217−dropType
218− :: (Has sch schemas schema, KnownSymbol td)
219− => QualifiedAlias sch td
220− -- ^ name of the user defined type
221− -> Definition schemas (Alter sch (DropSchemum td 'Typedef schema) schemas)
222−dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
223−
224−dropTypeIfExists
225− :: (Has sch schemas schema, KnownSymbol td)
226− => QualifiedAlias sch td
227− -- ^ name of the user defined type
228− -> Definition schemas (Alter sch (DropSchemumIfExists td 'Typedef schema) schemas)
229−dropTypeIfExists tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Definition.View
3−Description: Create and drop view definitions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Create and drop view definitions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DerivingStrategies
17− , FlexibleContexts
18− , FlexibleInstances
19− , GADTs
20− , LambdaCase
21− , MultiParamTypeClasses
22− , OverloadedLabels
23− , OverloadedStrings
24− , RankNTypes
25− , ScopedTypeVariables
26− , TypeApplications
27− , TypeInType
28− , TypeOperators
29− , UndecidableSuperClasses
30−#-}
31−
32−module Squeal.PostgreSQL.Definition.View
33− ( createView
34− , createOrReplaceView
35− , dropView
36− , dropViewIfExists
37− ) where
38−
39−import GHC.TypeLits
40−
41−import Squeal.PostgreSQL.Alias
42−import Squeal.PostgreSQL.Definition
43−import Squeal.PostgreSQL.Query
44−import Squeal.PostgreSQL.Render
45−import Squeal.PostgreSQL.Schema
46−
47−-- $setup
48−-- >>> import Squeal.PostgreSQL
49−
50−{- | Create a view.
51−>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
52−>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
53−>>> :{
54−let
55− definition :: Definition
56− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
57− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
58− definition =
59− createView #bc (select_ (#b :* #c) (from (table #abc)))
60−in printSQL definition
61−:}
62−CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
63−-}
64−createView
65− :: (Has sch schemas schema, KnownSymbol vw)
66− => QualifiedAlias sch vw -- ^ the name of the view to add
67− -> Query '[] '[] schemas '[] view -- ^ query
68− -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)
69−createView alias query = UnsafeDefinition $
70− "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
71− <+> renderQuery query <> ";"
72−
73−createOrReplaceView
74− :: (Has sch schemas schema, KnownSymbol vw)
75− => QualifiedAlias sch vw -- ^ the name of the view to add
76− -> Query '[] '[] schemas '[] view -- ^ query
77− -> Definition schemas (Alter sch (CreateOrReplace vw ('View view) schema) schemas)
78−createOrReplaceView alias query = UnsafeDefinition $
79− "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS"
80− <+> renderQuery query <> ";"
81−
82−-- | Drop a view.
83−--
84−-- >>> :{
85−-- let
86−-- definition :: Definition
87−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
88−-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
89−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
90−-- definition = dropView #bc
91−-- in printSQL definition
92−-- :}
93−-- DROP VIEW "bc";
94−dropView
95− :: (Has sch schemas schema, KnownSymbol vw)
96− => QualifiedAlias sch vw -- ^ view to remove
97− -> Definition schemas (Alter sch (DropSchemum vw 'View schema) schemas)
98−dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
99−
100−dropViewIfExists
101− :: (Has sch schemas schema, KnownSymbol vw)
102− => QualifiedAlias sch vw -- ^ view to remove
103− -> Definition schemas (Alter sch (DropIfExists vw schema) schemas)
104−dropViewIfExists vw = UnsafeDefinition $ "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";"
squeal-postgresql/src/Squeal/PostgreSQL/Expression.hsdeleted−472
@@ -1,472 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression
3−Description: Squeal expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Squeal expressions are the atoms used to build statements.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , DeriveGeneric
15− , FlexibleContexts
16− , FlexibleInstances
17− , FunctionalDependencies
18− , GADTs
19− , GeneralizedNewtypeDeriving
20− , LambdaCase
21− , MagicHash
22− , OverloadedStrings
23− , ScopedTypeVariables
24− , StandaloneDeriving
25− , TypeApplications
26− , TypeFamilies
27− , TypeInType
28− , TypeOperators
29− , UndecidableInstances
30− , RankNTypes
31−#-}
32−
33−module Squeal.PostgreSQL.Expression
34− ( -- * Expression
35− Expression (..)
36− , Expr
37− , type (-->)
38− , FunctionDB
39− , unsafeFunction
40− , function
41− , unsafeLeftOp
42− , leftOp
43− , unsafeRightOp
44− , rightOp
45− , Operator
46− , OperatorDB
47− , unsafeBinaryOp
48− , binaryOp
49− , FunctionVar
50− , unsafeFunctionVar
51− , type (--->)
52− , FunctionNDB
53− , unsafeFunctionN
54− , functionN
55− , PGSubset (..)
56− , PGIntersect (..)
57− -- * Re-export
58− , (&)
59− , K (..)
60− , unK
61− ) where
62−
63−import Control.Category
64−import Control.DeepSeq
65−import Data.ByteString (ByteString)
66−import Data.Function ((&))
67−import Data.Semigroup hiding (All)
68−import Data.String
69−import Generics.SOP hiding (All, from)
70−import GHC.OverloadedLabels
71−import GHC.TypeLits
72−import Numeric
73−import Prelude hiding (id, (.))
74−
75−import qualified GHC.Generics as GHC
76−
77−import Squeal.PostgreSQL.Alias
78−import Squeal.PostgreSQL.List
79−import Squeal.PostgreSQL.Render
80−import Squeal.PostgreSQL.Schema
81−
82−-- $setup
83−-- >>> import Squeal.PostgreSQL
84−
85−{-----------------------------------------
86−column expressions
87−-----------------------------------------}
88−
89−{- | `Expression`s are used in a variety of contexts,
90−such as in the target `Squeal.PostgreSQL.Query.List` of the
91−`Squeal.PostgreSQL.Query.select` command,
92−as new column values in `Squeal.PostgreSQL.Manipulation.insertRow` or
93−`Squeal.PostgreSQL.Manipulation.update`,
94−or in search `Squeal.PostgreSQL.Logic.Condition`s in a number of commands.
95−
96−The expression syntax allows the calculation of
97−values from primitive expression using arithmetic, logical,
98−and other operations.
99−
100−The type parameters of `Expression` are
101−
102−* @outer :: @ `FromType`, the @from@ clauses of any outer queries in which
103− the `Expression` is a correlated subquery expression;
104−* @commons :: @ `FromType`, the `Squeal.PostgreSQL.Query.CommonTableExpression`s
105− that are in scope for the `Expression`;
106−* @grp :: @ `Grouping`, the `Grouping` of the @from@ clause which may limit
107− which columns may be referenced by alias;
108−* @schemas :: @ `SchemasType`, the schemas of your database that are in
109− scope for the `Expression`;
110−* @from :: @ `FromType`, the @from@ clause which the `Expression` may use
111− to reference columns by alias;
112−* @ty :: @ `NullityType`, the type of the `Expression`.
113−-}
114−newtype Expression
115− (outer :: FromType)
116− (commons :: FromType)
117− (grp :: Grouping)
118− (schemas :: SchemasType)
119− (params :: [NullityType])
120− (from :: FromType)
121− (ty :: NullityType)
122− = UnsafeExpression { renderExpression :: ByteString }
123− deriving (GHC.Generic,Show,Eq,Ord,NFData)
124−instance RenderSQL (Expression outer commons grp schemas params from ty) where
125− renderSQL = renderExpression
126−
127−-- | An `Expr` is a closed `Expression`.
128−-- It is a F@RankNType@ but don't be scared.
129−-- Think of it as an expression which sees no
130−-- namespaces, so you can't use parameters
131−-- or alias references. It can be used as
132−-- a simple piece of more complex `Expression`s.
133−type Expr x
134− = forall outer commons grp schemas params from
135− . Expression outer commons grp schemas params from x
136− -- ^ cannot reference aliases
137−
138−-- | A @RankNType@ for binary operators.
139−type Operator x1 x2 y
140− = forall outer commons grp schemas params from
141− . Expression outer commons grp schemas params from x1
142− -- ^ left input
143− -> Expression outer commons grp schemas params from x2
144− -- ^ right input
145− -> Expression outer commons grp schemas params from y
146− -- ^ output
147−
148−type OperatorDB schemas x1 x2 y
149− = forall outer commons grp params from
150− . Expression outer commons grp schemas params from x1
151− -- ^ left input
152− -> Expression outer commons grp schemas params from x2
153− -- ^ right input
154− -> Expression outer commons grp schemas params from y
155− -- ^ output
156−
157−-- | A @RankNType@ for functions with a single argument.
158−-- These could be either function calls or unary operators.
159−-- This is a subtype of the usual Haskell function type `Prelude.->`,
160−-- indeed a subcategory as it is closed under the usual
161−-- `Prelude..` and `Prelude.id`.
162−type (-->) x y
163− = forall outer commons grp schemas params from
164− . Expression outer commons grp schemas params from x
165− -- ^ input
166− -> Expression outer commons grp schemas params from y
167− -- ^ output
168−
169−type FunctionDB schemas x y
170− = forall outer commons grp params from
171− . Expression outer commons grp schemas params from x
172− -- ^ input
173− -> Expression outer commons grp schemas params from y
174− -- ^ output
175−
176−{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.
177−Use the `*:` operator to end your argument lists, like so.
178−
179−>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))
180−fun(TRUE, FALSE, LOCALTIME, TRUE)
181−-}
182−type (--->) xs y
183− = forall outer commons grp schemas params from
184− . NP (Expression outer commons grp schemas params from) xs
185− -- ^ inputs
186− -> Expression outer commons grp schemas params from y
187− -- ^ output
188−
189−type FunctionNDB schemas xs y
190− = forall outer commons grp params from
191− . NP (Expression outer commons grp schemas params from) xs
192− -- ^ inputs
193− -> Expression outer commons grp schemas params from y
194− -- ^ output
195−
196−{- | A @RankNType@ for functions with a variable-length list of
197−homogeneous arguments and at least 1 more argument.
198−-}
199−type FunctionVar x0 x1 y
200− = forall outer commons grp schemas params from
201− . [Expression outer commons grp schemas params from x0]
202− -- ^ inputs
203− -> Expression outer commons grp schemas params from x1
204− -- ^ must have at least 1 input
205− -> Expression outer commons grp schemas params from y
206− -- ^ output
207−
208−{- | >>> printSQL (unsafeFunctionVar "greatest" [true, null_] false)
209−greatest(TRUE, NULL, FALSE)
210−-}
211−unsafeFunctionVar :: ByteString -> FunctionVar x0 x1 y
212−unsafeFunctionVar fun xs x = UnsafeExpression $ fun <> parenthesized
213− (commaSeparated (renderSQL <$> xs) <> ", " <> renderSQL x)
214−
215−instance (HasUnique tab (Join outer from) row, Has col row ty)
216− => IsLabel col (Expression outer commons 'Ungrouped schemas params from ty) where
217− fromLabel = UnsafeExpression $ renderSQL (Alias @col)
218−instance (HasUnique tab (Join outer from) row, Has col row ty, tys ~ '[ty])
219− => IsLabel col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where
220− fromLabel = fromLabel @col :* Nil
221−instance (HasUnique tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))
222− => IsLabel col
223− (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where
224− fromLabel = fromLabel @col `As` Alias
225−instance (HasUnique tab (Join outer from) row, Has col row ty, columns ~ '[col ::: ty])
226− => IsLabel col
227− (NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns) where
228− fromLabel = fromLabel @col :* Nil
229−
230−instance (Has tab (Join outer from) row, Has col row ty)
231− => IsQualified tab col (Expression outer commons 'Ungrouped schemas params from ty) where
232− tab ! col = UnsafeExpression $
233− renderSQL tab <> "." <> renderSQL col
234−instance (Has tab (Join outer from) row, Has col row ty, tys ~ '[ty])
235− => IsQualified tab col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where
236− tab ! col = tab ! col :* Nil
237−instance (Has tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))
238− => IsQualified tab col
239− (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where
240− tab ! col = tab ! col `As` col
241−instance (Has tab (Join outer from) row, Has col row ty, columns ~ '[col ::: ty])
242− => IsQualified tab col
243− (NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns) where
244− tab ! col = tab ! col :* Nil
245−
246−instance
247− ( HasUnique tab (Join outer from) row
248− , Has col row ty
249− , GroupedBy tab col bys
250− ) => IsLabel col
251− (Expression outer commons ('Grouped bys) schemas params from ty) where
252− fromLabel = UnsafeExpression $ renderSQL (Alias @col)
253−instance
254− ( HasUnique tab (Join outer from) row
255− , Has col row ty
256− , GroupedBy tab col bys
257− , tys ~ '[ty]
258− ) => IsLabel col
259− (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where
260− fromLabel = fromLabel @col :* Nil
261−instance
262− ( HasUnique tab (Join outer from) row
263− , Has col row ty
264− , GroupedBy tab col bys
265− , column ~ (col ::: ty)
266− ) => IsLabel col
267− (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where
268− fromLabel = fromLabel @col `As` Alias
269−instance
270− ( HasUnique tab (Join outer from) row
271− , Has col row ty
272− , GroupedBy tab col bys
273− , columns ~ '[col ::: ty]
274− ) => IsLabel col
275− (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where
276− fromLabel = fromLabel @col :* Nil
277−
278−instance
279− ( Has tab (Join outer from) row
280− , Has col row ty
281− , GroupedBy tab col bys
282− ) => IsQualified tab col
283− (Expression outer commons ('Grouped bys) schemas params from ty) where
284− tab ! col = UnsafeExpression $
285− renderSQL tab <> "." <> renderSQL col
286−instance
287− ( Has tab (Join outer from) row
288− , Has col row ty
289− , GroupedBy tab col bys
290− , tys ~ '[ty]
291− ) => IsQualified tab col
292− (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where
293− tab ! col = tab ! col :* Nil
294−instance
295− ( Has tab (Join outer from) row
296− , Has col row ty
297− , GroupedBy tab col bys
298− , column ~ (col ::: ty)
299− ) => IsQualified tab col
300− (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where
301− tab ! col = tab ! col `As` col
302−instance
303− ( Has tab (Join outer from) row
304− , Has col row ty
305− , GroupedBy tab col bys
306− , columns ~ '[col ::: ty]
307− ) => IsQualified tab col
308− (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where
309− tab ! col = tab ! col :* Nil
310−
311−instance (KnownSymbol label, label `In` labels) => IsPGlabel label
312− (Expression outer commons grp schemas params from (null ('PGenum labels))) where
313− label = UnsafeExpression $ renderSQL (PGlabel @label)
314−
315−-- | >>> printSQL $ unsafeBinaryOp "OR" true false
316−-- (TRUE OR FALSE)
317−unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2
318−unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
319− renderSQL x <+> op <+> renderSQL y
320−
321−binaryOp
322− :: forall op sch schemas schema x y z.
323− ( Has sch schemas schema
324− , Has op schema ('Operator ('BinaryOp x y z)) )
325− => OperatorDB schemas x y z
326−binaryOp = unsafeBinaryOp $ renderSymbol @op
327−
328−-- | >>> printSQL $ unsafeLeftOp "NOT" true
329−-- (NOT TRUE)
330−unsafeLeftOp :: ByteString -> x --> y
331−unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
332−
333−leftOp
334− :: forall op sch schemas schema x y.
335− ( Has sch schemas schema
336− , Has op schema ('Operator ('LeftOp x y)) )
337− => FunctionDB schemas x y
338−leftOp = unsafeLeftOp $ renderSymbol @op
339−
340−-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE"
341−-- (TRUE IS NOT TRUE)
342−unsafeRightOp :: ByteString -> x --> y
343−unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
344−
345−rightOp
346− :: forall op sch schemas schema x y.
347− ( Has sch schemas schema
348− , Has op schema ('Operator ('RightOp x y)) )
349− => FunctionDB schemas x y
350−rightOp = unsafeRightOp $ renderSymbol @op
351−
352−-- | >>> printSQL $ unsafeFunction "f" true
353−-- f(TRUE)
354−unsafeFunction :: ByteString -> x --> y
355−unsafeFunction fun x = UnsafeExpression $
356− fun <> parenthesized (renderSQL x)
357−
358−function
359− :: (Has sch schemas schema, Has fun schema ('Function ('[x] :=> 'Returns y)))
360− => QualifiedAlias sch fun
361− -> FunctionDB schemas x y
362−function = unsafeFunction . renderSQL
363−
364−-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')
365−-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')
366−unsafeFunctionN :: SListI xs => ByteString -> xs ---> y
367−unsafeFunctionN fun xs = UnsafeExpression $
368− fun <> parenthesized (renderCommaSeparated renderSQL xs)
369−
370−functionN
371− :: ( Has sch schemas schema
372− , Has fun schema ('Function (xs :=> 'Returns y))
373− , SListI xs )
374− => QualifiedAlias sch fun
375− -> FunctionNDB schemas xs y
376−functionN = unsafeFunctionN . renderSQL
377−
378−instance ty `In` PGNum
379− => Num (Expression outer commons grp schemas params from (null ty)) where
380− (+) = unsafeBinaryOp "+"
381− (-) = unsafeBinaryOp "-"
382− (*) = unsafeBinaryOp "*"
383− abs = unsafeFunction "abs"
384− signum = unsafeFunction "sign"
385− fromInteger
386− = UnsafeExpression
387− . fromString
388− . show
389−
390−instance (ty `In` PGNum, ty `In` PGFloating) => Fractional
391− (Expression outer commons grp schemas params from (null ty)) where
392− (/) = unsafeBinaryOp "/"
393− fromRational
394− = UnsafeExpression
395− . fromString
396− . ($ "")
397− . showFFloat Nothing
398− . fromRat @Double
399−
400−instance (ty `In` PGNum, ty `In` PGFloating) => Floating
401− (Expression outer commons grp schemas params from (null ty)) where
402− pi = UnsafeExpression "pi()"
403− exp = unsafeFunction "exp"
404− log = unsafeFunction "ln"
405− sqrt = unsafeFunction "sqrt"
406− b ** x = UnsafeExpression $
407− "power(" <> renderSQL b <> ", " <> renderSQL x <> ")"
408− logBase b y = log y / log b
409− sin = unsafeFunction "sin"
410− cos = unsafeFunction "cos"
411− tan = unsafeFunction "tan"
412− asin = unsafeFunction "asin"
413− acos = unsafeFunction "acos"
414− atan = unsafeFunction "atan"
415− sinh x = (exp x - exp (-x)) / 2
416− cosh x = (exp x + exp (-x)) / 2
417− tanh x = sinh x / cosh x
418− asinh x = log (x + sqrt (x*x + 1))
419− acosh x = log (x + sqrt (x*x - 1))
420− atanh x = log ((1 + x) / (1 - x)) / 2
421−
422−-- | Contained by operators
423−class PGSubset ty where
424− (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
425− (@>) = unsafeBinaryOp "@>"
426− (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
427− (<@) = unsafeBinaryOp "<@"
428−instance PGSubset 'PGjsonb
429−instance PGSubset 'PGtsquery
430−instance PGSubset ('PGvararray ty)
431−instance PGSubset ('PGrange ty)
432−
433−class PGIntersect ty where
434− (@&&) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
435− (@&&) = unsafeBinaryOp "&&"
436−instance PGIntersect ('PGvararray ty)
437−instance PGIntersect ('PGrange ty)
438−
439−instance IsString
440− (Expression outer commons grp schemas params from (null 'PGtext)) where
441− fromString str = UnsafeExpression $
442− "E\'" <> fromString (escape =<< str) <> "\'"
443−instance IsString
444− (Expression outer commons grp schemas params from (null 'PGtsvector)) where
445− fromString str = UnsafeExpression . parenthesized . (<> " :: tsvector") $
446− "E\'" <> fromString (escape =<< str) <> "\'"
447−instance IsString
448− (Expression outer commons grp schemas params from (null 'PGtsquery)) where
449− fromString str = UnsafeExpression . parenthesized . (<> " :: tsquery") $
450− "E\'" <> fromString (escape =<< str) <> "\'"
451−
452−instance Semigroup
453− (Expression outer commons grp schemas params from (null ('PGvararray ty))) where
454− (<>) = unsafeBinaryOp "||"
455−instance Semigroup
456− (Expression outer commons grp schemas params from (null 'PGjsonb)) where
457− (<>) = unsafeBinaryOp "||"
458−instance Semigroup
459− (Expression outer commons grp schemas params from (null 'PGtext)) where
460− (<>) = unsafeBinaryOp "||"
461−instance Semigroup
462− (Expression outer commons grp schemas params from (null 'PGtsvector)) where
463− (<>) = unsafeBinaryOp "||"
464−
465−instance Monoid
466− (Expression outer commons grp schemas params from (null 'PGtext)) where
467− mempty = fromString ""
468− mappend = (<>)
469−instance Monoid
470− (Expression outer commons grp schemas params from (null 'PGtsvector)) where
471− mempty = fromString ""
472− mappend = (<>)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hsdeleted−462
@@ -1,462 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Aggregate
3−Description: Aggregate functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Aggregate functions
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , DeriveGeneric
14− , FlexibleContexts
15− , FlexibleInstances
16− , FunctionalDependencies
17− , LambdaCase
18− , MultiParamTypeClasses
19− , OverloadedStrings
20− , PolyKinds
21− , TypeFamilies
22− , TypeOperators
23− , UndecidableInstances
24−#-}
25−
26−module Squeal.PostgreSQL.Expression.Aggregate
27− ( Aggregate (..)
28− , Distinction (..)
29− , PGSum
30− , PGAvg
31− ) where
32−
33−import Control.DeepSeq
34−import Data.ByteString (ByteString)
35−import Data.Kind
36−import GHC.TypeLits
37−
38−import qualified GHC.Generics as GHC
39−import qualified Generics.SOP as SOP
40−
41−import Squeal.PostgreSQL.Alias
42−import Squeal.PostgreSQL.Expression
43−import Squeal.PostgreSQL.List
44−import Squeal.PostgreSQL.Render
45−import Squeal.PostgreSQL.Schema
46−
47−-- $setup
48−-- >>> import Squeal.PostgreSQL
49−
50−{- |
51−`Aggregate` functions compute a single result from a set of input values.
52−`Aggregate` functions can be used as `GroupedBy` `Expression`s as well
53−as `Squeal.PostgreSQL.Expression.Window.WindowFunction`s.
54−-}
55−class Aggregate expr1 exprN aggr
56− | aggr -> expr1, aggr -> exprN where
57−
58− -- | A special aggregation that does not require an input
59− --
60− -- >>> :{
61− -- let
62− -- expression :: Expression '[] commons ('Grouped bys) schemas params from ('NotNull 'PGint8)
63− -- expression = countStar
64− -- in printSQL expression
65− -- :}
66− -- count(*)
67− countStar :: aggr ('NotNull 'PGint8)
68−
69− -- | >>> :{
70− -- let
71− -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null ty]] ('NotNull 'PGint8)
72− -- expression = count (All #col)
73− -- in printSQL expression
74− -- :}
75− -- count(ALL "col")
76− count
77− :: expr1 ty
78− -- ^ what to count
79− -> aggr ('NotNull 'PGint8)
80−
81− -- | >>> :{
82− -- let
83− -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric)
84− -- expression = sum_ (Distinct #col)
85− -- in printSQL expression
86− -- :}
87− -- sum(DISTINCT "col")
88− sum_
89− :: expr1 (null ty)
90− -> aggr ('Null (PGSum ty))
91−
92− -- | input values, including nulls, concatenated into an array
93− arrayAgg
94− :: expr1 ty
95− -> aggr ('Null ('PGvararray ty))
96−
97− -- | aggregates values as a JSON array
98− jsonAgg
99− :: expr1 ty
100− -> aggr ('Null 'PGjson)
101−
102− -- | aggregates values as a JSON array
103− jsonbAgg
104− :: expr1 ty
105− -> aggr ('Null 'PGjsonb)
106−
107− {- |
108− the bitwise AND of all non-null input values, or null if none
109−
110− >>> :{
111− let
112− expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)
113− expression = bitAnd (Distinct #col)
114− in printSQL expression
115− :}
116− bit_and(DISTINCT "col")
117− -}
118− bitAnd
119− :: int `In` PGIntegral
120− => expr1 (null int)
121− -- ^ what to aggregate
122− -> aggr ('Null int)
123−
124− {- |
125− the bitwise OR of all non-null input values, or null if none
126−
127− >>> :{
128− let
129− expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)
130− expression = bitOr (All #col)
131− in printSQL expression
132− :}
133− bit_or(ALL "col")
134− -}
135− bitOr
136− :: int `In` PGIntegral
137− => expr1 (null int)
138− -- ^ what to aggregate
139− -> aggr ('Null int)
140−
141− {- |
142− true if all input values are true, otherwise false
143−
144− >>> :{
145− let
146− winFun :: WindowFunction '[] commons 'Ungrouped schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)
147− winFun = boolAnd #col
148− in printSQL winFun
149− :}
150− bool_and("col")
151− -}
152− boolAnd
153− :: expr1 (null 'PGbool)
154− -- ^ what to aggregate
155− -> aggr ('Null 'PGbool)
156−
157− {- |
158− true if at least one input value is true, otherwise false
159−
160− >>> :{
161− let
162− expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)
163− expression = boolOr (All #col)
164− in printSQL expression
165− :}
166− bool_or(ALL "col")
167− -}
168− boolOr
169− :: expr1 (null 'PGbool)
170− -- ^ what to aggregate
171− -> aggr ('Null 'PGbool)
172−
173− {- |
174− equivalent to `boolAnd`
175−
176− >>> :{
177− let
178− expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)
179− expression = every (Distinct #col)
180− in printSQL expression
181− :}
182− every(DISTINCT "col")
183− -}
184− every
185− :: expr1 (null 'PGbool)
186− -- ^ what to aggregate
187− -> aggr ('Null 'PGbool)
188−
189− {- |maximum value of expression across all input values-}
190− max_
191− :: expr1 (null ty)
192− -- ^ what to maximize
193− -> aggr ('Null ty)
194−
195− -- | minimum value of expression across all input values
196− min_
197− :: expr1 (null ty)
198− -- ^ what to minimize
199− -> aggr ('Null ty)
200−
201− -- | the average (arithmetic mean) of all input values
202− avg
203− :: expr1 (null ty)
204− -- ^ what to average
205− -> aggr ('Null (PGAvg ty))
206−
207− {- | correlation coefficient
208−
209− >>> :{
210− let
211− expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
212− expression = corr (All (#y *: #x))
213− in printSQL expression
214− :}
215− corr(ALL "y", "x")
216− -}
217− corr
218− :: exprN '[null 'PGfloat8, null 'PGfloat8]
219− -> aggr ('Null 'PGfloat8)
220−
221− {- | population covariance
222−
223− >>> :{
224− let
225− expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
226− expression = covarPop (All (#y *: #x))
227− in printSQL expression
228− :}
229− covar_pop(ALL "y", "x")
230− -}
231− covarPop
232− :: exprN '[null 'PGfloat8, null 'PGfloat8]
233− -> aggr ('Null 'PGfloat8)
234−
235− {- | sample covariance
236−
237− >>> :{
238− let
239− winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
240− winFun = covarSamp (#y *: #x)
241− in printSQL winFun
242− :}
243− covar_samp("y", "x")
244− -}
245− covarSamp
246− :: exprN '[null 'PGfloat8, null 'PGfloat8]
247− -> aggr ('Null 'PGfloat8)
248−
249− {- | average of the independent variable (sum(X)/N)
250−
251− >>> :{
252− let
253− expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
254− expression = regrAvgX (All (#y *: #x))
255− in printSQL expression
256− :}
257− regr_avgx(ALL "y", "x")
258− -}
259− regrAvgX
260− :: exprN '[null 'PGfloat8, null 'PGfloat8]
261− -> aggr ('Null 'PGfloat8)
262−
263− {- | average of the dependent variable (sum(Y)/N)
264−
265− >>> :{
266− let
267− winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
268− winFun = regrAvgY (#y *: #x)
269− in printSQL winFun
270− :}
271− regr_avgy("y", "x")
272− -}
273− regrAvgY
274− :: exprN '[null 'PGfloat8, null 'PGfloat8]
275− -> aggr ('Null 'PGfloat8)
276−
277− {- | number of input rows in which both expressions are nonnull
278−
279− >>> :{
280− let
281− winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGint8)
282− winFun = regrCount (#y *: #x)
283− in printSQL winFun
284− :}
285− regr_count("y", "x")
286− -}
287− regrCount
288− :: exprN '[null 'PGfloat8, null 'PGfloat8]
289− -> aggr ('Null 'PGint8)
290−
291− {- | y-intercept of the least-squares-fit linear equation determined by the (X, Y) pairs
292− >>> :{
293− let
294− expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)
295− expression = regrIntercept (All (#y *: #x))
296− in printSQL expression
297− :}
298− regr_intercept(ALL "y", "x")
299− -}
300− regrIntercept
301− :: exprN '[null 'PGfloat8, null 'PGfloat8]
302− -> aggr ('Null 'PGfloat8)
303−
304− -- | @regr_r2(Y, X)@, square of the correlation coefficient
305− regrR2
306− :: exprN '[null 'PGfloat8, null 'PGfloat8]
307− -> aggr ('Null 'PGfloat8)
308−
309− -- | @regr_slope(Y, X)@, slope of the least-squares-fit linear equation
310− -- determined by the (X, Y) pairs
311− regrSlope
312− :: exprN '[null 'PGfloat8, null 'PGfloat8]
313− -> aggr ('Null 'PGfloat8)
314−
315− -- | @regr_sxx(Y, X)@, sum(X^2) - sum(X)^2/N
316− -- (“sum of squares” of the independent variable)
317− regrSxx
318− :: exprN '[null 'PGfloat8, null 'PGfloat8]
319− -> aggr ('Null 'PGfloat8)
320−
321− -- | @regr_sxy(Y, X)@, sum(X*Y) - sum(X) * sum(Y)/N
322− -- (“sum of products” of independent times dependent variable)
323− regrSxy
324− :: exprN '[null 'PGfloat8, null 'PGfloat8]
325− -> aggr ('Null 'PGfloat8)
326−
327− -- | @regr_syy(Y, X)@, sum(Y^2) - sum(Y)^2/N
328− -- (“sum of squares” of the dependent variable)
329− regrSyy
330− :: exprN '[null 'PGfloat8, null 'PGfloat8]
331− -> aggr ('Null 'PGfloat8)
332−
333− -- | historical alias for `stddevSamp`
334− stddev
335− :: expr1 (null ty)
336− -> aggr ('Null (PGAvg ty))
337−
338− -- | population standard deviation of the input values
339− stddevPop
340− :: expr1 (null ty)
341− -> aggr ('Null (PGAvg ty))
342−
343− -- | sample standard deviation of the input values
344− stddevSamp
345− :: expr1 (null ty)
346− -> aggr ('Null (PGAvg ty))
347−
348− -- | historical alias for `varSamp`
349− variance
350− :: expr1 (null ty)
351− -> aggr ('Null (PGAvg ty))
352−
353− -- | population variance of the input values
354− -- (square of the population standard deviation)
355− varPop
356− :: expr1 (null ty)
357− -> aggr ('Null (PGAvg ty))
358−
359− -- | sample variance of the input values
360− -- (square of the sample standard deviation)
361− varSamp
362− :: expr1 (null ty)
363− -> aggr ('Null (PGAvg ty))
364−
365−{- |
366−`Distinction`s are used for the input of `Aggregate` `Expression`s.
367−`All` invokes the aggregate once for each input row.
368−`Distinct` invokes the aggregate once for each distinct value of the expression
369−(or distinct set of values, for multiple expressions) found in the input
370−-}
371−data Distinction (expr :: kind -> Type) (ty :: kind)
372− = All (expr ty)
373− | Distinct (expr ty)
374− deriving (GHC.Generic,Show,Eq,Ord)
375−instance NFData (Distinction (Expression outer commons grp schemas params from) ty)
376−instance RenderSQL (Distinction (Expression outer commons grp schemas params from) ty) where
377− renderSQL = \case
378− All x -> "ALL" <+> renderSQL x
379− Distinct x -> "DISTINCT" <+> renderSQL x
380−instance SOP.SListI tys => RenderSQL
381− (Distinction (NP (Expression outer commons grp schemas params from)) tys) where
382− renderSQL = \case
383− All xs -> "ALL" <+> renderCommaSeparated renderSQL xs
384− Distinct xs -> "DISTINCT" <+> renderCommaSeparated renderSQL xs
385−
386−instance Aggregate
387− (Distinction (Expression outer commons 'Ungrouped schemas params from))
388− (Distinction (NP (Expression outer commons 'Ungrouped schemas params from)))
389− (Expression outer commons ('Grouped bys) schemas params from) where
390− countStar = UnsafeExpression "count(*)"
391− count = unsafeAggregate1 "count"
392− sum_ = unsafeAggregate1 "sum"
393− arrayAgg = unsafeAggregate1 "array_agg"
394− jsonAgg = unsafeAggregate1 "json_agg"
395− jsonbAgg = unsafeAggregate1 "jsonb_agg"
396− bitAnd = unsafeAggregate1 "bit_and"
397− bitOr = unsafeAggregate1 "bit_or"
398− boolAnd = unsafeAggregate1 "bool_and"
399− boolOr = unsafeAggregate1 "bool_or"
400− every = unsafeAggregate1 "every"
401− max_ = unsafeAggregate1 "max"
402− min_ = unsafeAggregate1 "min"
403− avg = unsafeAggregate1 "avg"
404− corr = unsafeAggregateN "corr"
405− covarPop = unsafeAggregateN "covar_pop"
406− covarSamp = unsafeAggregateN "covar_samp"
407− regrAvgX = unsafeAggregateN "regr_avgx"
408− regrAvgY = unsafeAggregateN "regr_avgy"
409− regrCount = unsafeAggregateN "regr_count"
410− regrIntercept = unsafeAggregateN "regr_intercept"
411− regrR2 = unsafeAggregateN "regr_r2"
412− regrSlope = unsafeAggregateN "regr_slope"
413− regrSxx = unsafeAggregateN "regr_sxx"
414− regrSxy = unsafeAggregateN "regr_sxy"
415− regrSyy = unsafeAggregateN "regr_syy"
416− stddev = unsafeAggregate1 "stddev"
417− stddevPop = unsafeAggregate1 "stddev_pop"
418− stddevSamp = unsafeAggregate1 "stddev_samp"
419− variance = unsafeAggregate1 "variance"
420− varPop = unsafeAggregate1 "var_pop"
421− varSamp = unsafeAggregate1 "var_samp"
422−
423−-- | escape hatch to define aggregate functions
424−unsafeAggregate1
425− :: ByteString -- ^ aggregate function
426− -> Distinction (Expression outer commons 'Ungrouped schemas params from) x
427− -> Expression outer commons ('Grouped bys) schemas params from y
428−unsafeAggregate1 fun x = UnsafeExpression $ fun <> parenthesized (renderSQL x)
429−
430−unsafeAggregateN
431− :: SOP.SListI xs
432− => ByteString -- ^ function
433− -> Distinction (NP (Expression outer commons 'Ungrouped schemas params from)) xs
434− -> Expression outer commons ('Grouped bys) schemas params from y
435−unsafeAggregateN fun xs = UnsafeExpression $ fun <> parenthesized (renderSQL xs)
436−
437−-- | A type family that calculates `PGSum``PGType` of
438−-- a given argument `PGType`.
439−type family PGSum ty where
440− PGSum 'PGint2 = 'PGint8
441− PGSum 'PGint4 = 'PGint8
442− PGSum 'PGint8 = 'PGnumeric
443− PGSum 'PGfloat4 = 'PGfloat4
444− PGSum 'PGfloat8 = 'PGfloat8
445− PGSum 'PGnumeric = 'PGnumeric
446− PGSum 'PGinterval = 'PGinterval
447− PGSum 'PGmoney = 'PGmoney
448− PGSum pg = TypeError
449− ( 'Text "Squeal type error: Cannot sum with argument type "
450− ':<>: 'ShowType pg )
451−
452−-- | A type family that calculates `PGAvg` type of a `PGType`.
453−type family PGAvg ty where
454− PGAvg 'PGint2 = 'PGnumeric
455− PGAvg 'PGint4 = 'PGnumeric
456− PGAvg 'PGint8 = 'PGnumeric
457− PGAvg 'PGnumeric = 'PGnumeric
458− PGAvg 'PGfloat4 = 'PGfloat8
459− PGAvg 'PGfloat8 = 'PGfloat8
460− PGAvg 'PGinterval = 'PGinterval
461− PGAvg pg = TypeError
462− ('Text "Squeal type error: No average for " ':<>: 'ShowType pg)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hsdeleted−169
@@ -1,169 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Collection
3−Description: Array and composite functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Array and composite functions
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DataKinds
14− , FlexibleContexts
15− , FlexibleInstances
16− , MultiParamTypeClasses
17− , OverloadedLabels
18− , OverloadedStrings
19− , RankNTypes
20− , ScopedTypeVariables
21− , TypeApplications
22− , TypeFamilies
23− , TypeOperators
24− , UndecidableInstances
25−#-}
26−
27−module Squeal.PostgreSQL.Expression.Collection
28− ( array
29− , array1
30− , array2
31− , cardinality
32− , index
33− , unnest
34− , row
35− , field
36− ) where
37−
38−import Data.String
39−import Data.Word (Word64)
40−
41−import qualified Generics.SOP as SOP
42−
43−import Squeal.PostgreSQL.Alias
44−import Squeal.PostgreSQL.Expression
45−import Squeal.PostgreSQL.Expression.Set
46−import Squeal.PostgreSQL.List
47−import Squeal.PostgreSQL.Render
48−import Squeal.PostgreSQL.Schema
49−
50−-- $setup
51−-- >>> import Squeal.PostgreSQL
52−
53−-- | >>> printSQL $ array [null_, false, true]
54−-- ARRAY[NULL, FALSE, TRUE]
55−array
56− :: [Expression outer commons grp schemas params from ty]
57− -- ^ array elements
58− -> Expression outer commons grp schemas params from (null ('PGvararray ty))
59−array xs = UnsafeExpression $ "ARRAY" <>
60− bracketed (commaSeparated (renderSQL <$> xs))
61−
62−{- | construct a 1-dimensional fixed length array
63−
64−>>> printSQL $ array1 (null_ :* false *: true)
65−ARRAY[NULL, FALSE, TRUE]
66−
67−>>> :type array1 (null_ :* false *: true)
68−array1 (null_ :* false *: true)
69− :: Expression
70− outer
71− commons
72− grp
73− schemas
74− params
75− from
76− (null ('PGfixarray '[3] ('Null 'PGbool)))
77−-}
78−array1
79− :: (n ~ Length tys, SOP.All ((~) ty) tys)
80− => NP (Expression outer commons grp schemas params from) tys
81− -> Expression outer commons grp schemas params from (null ('PGfixarray '[n] ty))
82−array1 xs = UnsafeExpression $ "ARRAY" <>
83− bracketed (renderCommaSeparated renderSQL xs)
84−
85−{- | construct a 2-dimensional fixed length array
86−
87−>>> printSQL $ array2 ((null_ :* false *: true) *: (false :* null_ *: true))
88−ARRAY[[NULL, FALSE, TRUE], [FALSE, NULL, TRUE]]
89−
90−>>> :type array2 ((null_ :* false *: true) *: (false :* null_ *: true))
91−array2 ((null_ :* false *: true) *: (false :* null_ *: true))
92− :: Expression
93− outer
94− commons
95− grp
96− schemas
97− params
98− from
99− (null ('PGfixarray '[2, 3] ('Null 'PGbool)))
100−-}
101−array2
102− :: ( SOP.All ((~) tys) tyss
103− , SOP.All SOP.SListI tyss
104− , Length tyss ~ n1
105− , SOP.All ((~) ty) tys
106− , Length tys ~ n2 )
107− => NP (NP (Expression outer commons grp schemas params from)) tyss
108− -> Expression outer commons grp schemas params from (null ('PGfixarray '[n1,n2] ty))
109−array2 xss = UnsafeExpression $ "ARRAY" <>
110− bracketed (renderCommaSeparatedConstraint @SOP.SListI (bracketed . renderCommaSeparated renderSQL) xss)
111−
112−-- | >>> printSQL $ cardinality (array [null_, false, true])
113−-- cardinality(ARRAY[NULL, FALSE, TRUE])
114−cardinality :: null ('PGvararray ty) --> null 'PGint8
115−cardinality = unsafeFunction "cardinality"
116−
117−-- | >>> printSQL $ array [null_, false, true] & index 2
118−-- (ARRAY[NULL, FALSE, TRUE])[2]
119−index
120− :: Word64 -- ^ index
121− -> null ('PGvararray ty) --> NullifyType ty
122−index n expr = UnsafeExpression $
123− parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"
124−
125−-- | Expand an array to a set of rows
126−unnest :: SetFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]
127−unnest = unsafeSetFunction
128−
129−-- | A row constructor is an expression that builds a row value
130−-- (also called a composite value) using values for its member fields.
131−--
132−-- >>> :{
133−-- type Complex = 'PGcomposite
134−-- '[ "real" ::: 'NotNull 'PGfloat8
135−-- , "imaginary" ::: 'NotNull 'PGfloat8 ]
136−-- :}
137−--
138−-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer commons grp schemas params from ('NotNull Complex)
139−-- >>> printSQL i
140−-- ROW(0, 1)
141−row
142− :: SOP.SListI row
143− => NP (Aliased (Expression outer commons grp schemas params from)) row
144− -- ^ zero or more expressions for the row field values
145− -> Expression outer commons grp schemas params from (null ('PGcomposite row))
146−row exprs = UnsafeExpression $ "ROW" <> parenthesized
147− (renderCommaSeparated (\ (expr `As` _) -> renderSQL expr) exprs)
148−
149−-- | >>> :{
150−-- type Complex = 'PGcomposite
151−-- '[ "real" ::: 'NotNull 'PGfloat8
152−-- , "imaginary" ::: 'NotNull 'PGfloat8 ]
153−-- type Schema = '["complex" ::: 'Typedef Complex]
154−-- :}
155−--
156−-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer '[] grp (Public Schema) from params ('NotNull Complex)
157−-- >>> printSQL $ i & field #complex #imaginary
158−-- (ROW(0, 1)::"complex")."imaginary"
159−field
160− :: ( Has sch schemas schema
161− , Has tydef schema ('Typedef ('PGcomposite row))
162− , Has field row ty)
163− => QualifiedAlias sch tydef -- ^ row type
164− -> Alias field -- ^ field name
165− -> Expression outer commons grp schemas params from ('NotNull ('PGcomposite row))
166− -> Expression outer commons grp schemas params from ty
167−field td fld expr = UnsafeExpression $
168− parenthesized (renderSQL expr <> "::" <> renderSQL td)
169− <> "." <> renderSQL fld
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hsdeleted−206
@@ -1,206 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Comparison
3−Description: Comparison expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Comparison functions and operators
9−-}
10−
11−{-# LANGUAGE
12− OverloadedStrings
13− , RankNTypes
14− , TypeInType
15− , TypeOperators
16−#-}
17−
18−module Squeal.PostgreSQL.Expression.Comparison
19− ( (.==)
20− , (./=)
21− , (.>=)
22− , (.<)
23− , (.<=)
24− , (.>)
25− , greatest
26− , least
27− , BetweenExpr
28− , between
29− , notBetween
30− , betweenSymmetric
31− , notBetweenSymmetric
32− , isDistinctFrom
33− , isNotDistinctFrom
34− , isTrue
35− , isNotTrue
36− , isFalse
37− , isNotFalse
38− , isUnknown
39− , isNotUnknown
40− ) where
41−
42−import Data.ByteString
43−
44−import Squeal.PostgreSQL.Expression
45−import Squeal.PostgreSQL.Expression.Logic
46−import Squeal.PostgreSQL.Render
47−import Squeal.PostgreSQL.Schema
48−
49−-- $setup
50−-- >>> import Squeal.PostgreSQL
51−
52−-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`
53−-- will produce @NULL@s if one of their arguments is @NULL@.
54−--
55−-- >>> printSQL $ true .== null_
56−-- (TRUE = NULL)
57−(.==) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
58−(.==) = unsafeBinaryOp "="
59−infix 4 .==
60−
61−-- | >>> printSQL $ true ./= null_
62−-- (TRUE <> NULL)
63−(./=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
64−(./=) = unsafeBinaryOp "<>"
65−infix 4 ./=
66−
67−-- | >>> printSQL $ true .>= null_
68−-- (TRUE >= NULL)
69−(.>=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
70−(.>=) = unsafeBinaryOp ">="
71−infix 4 .>=
72−
73−-- | >>> printSQL $ true .< null_
74−-- (TRUE < NULL)
75−(.<) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
76−(.<) = unsafeBinaryOp "<"
77−infix 4 .<
78−
79−-- | >>> printSQL $ true .<= null_
80−-- (TRUE <= NULL)
81−(.<=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
82−(.<=) = unsafeBinaryOp "<="
83−infix 4 .<=
84−
85−-- | >>> printSQL $ true .> null_
86−-- (TRUE > NULL)
87−(.>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
88−(.>) = unsafeBinaryOp ">"
89−infix 4 .>
90−
91−-- | >>> let expr = greatest [param @1] currentTimestamp :: Expression outer commons grp schemas '[ 'NotNull 'PGtimestamptz] from ('NotNull 'PGtimestamptz)
92−-- >>> printSQL expr
93−-- GREATEST(($1 :: timestamp with time zone), CURRENT_TIMESTAMP)
94−greatest :: FunctionVar ty ty ty
95−greatest = unsafeFunctionVar "GREATEST"
96−
97−-- | >>> printSQL $ least [null_] currentTimestamp
98−-- LEAST(NULL, CURRENT_TIMESTAMP)
99−least :: FunctionVar ty ty ty
100−least = unsafeFunctionVar "LEAST"
101−
102−{- |
103−A @RankNType@ for comparison expressions like `between`.
104−-}
105−type BetweenExpr
106− = forall outer commons grp schemas params from ty
107− . Expression outer commons grp schemas params from ty
108− -> ( Expression outer commons grp schemas params from ty
109− , Expression outer commons grp schemas params from ty ) -- ^ bounds
110− -> Condition outer commons grp schemas params from
111−
112−unsafeBetweenExpr :: ByteString -> BetweenExpr
113−unsafeBetweenExpr fun a (x,y) = UnsafeExpression $
114− renderSQL a <+> fun <+> renderSQL x <+> "AND" <+> renderSQL y
115−
116−{- | >>> printSQL $ true `between` (null_, false)
117−TRUE BETWEEN NULL AND FALSE
118−-}
119−between :: BetweenExpr
120−between = unsafeBetweenExpr "BETWEEN"
121−
122−{- | >>> printSQL $ true `notBetween` (null_, false)
123−TRUE NOT BETWEEN NULL AND FALSE
124−-}
125−notBetween :: BetweenExpr
126−notBetween = unsafeBetweenExpr "NOT BETWEEN"
127−
128−{- | between, after sorting the comparison values
129−
130−>>> printSQL $ true `betweenSymmetric` (null_, false)
131−TRUE BETWEEN SYMMETRIC NULL AND FALSE
132−-}
133−betweenSymmetric :: BetweenExpr
134−betweenSymmetric = unsafeBetweenExpr "BETWEEN SYMMETRIC"
135−
136−{- | not between, after sorting the comparison values
137−
138−>>> printSQL $ true `notBetweenSymmetric` (null_, false)
139−TRUE NOT BETWEEN SYMMETRIC NULL AND FALSE
140−-}
141−notBetweenSymmetric :: BetweenExpr
142−notBetweenSymmetric = unsafeBetweenExpr "NOT BETWEEN SYMMETRIC"
143−
144−{- | not equal, treating null like an ordinary value
145−
146−>>> printSQL $ true `isDistinctFrom` null_
147−(TRUE IS DISTINCT FROM NULL)
148−-}
149−isDistinctFrom :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
150−isDistinctFrom = unsafeBinaryOp "IS DISTINCT FROM"
151−
152−{- | equal, treating null like an ordinary value
153−
154−>>> printSQL $ true `isNotDistinctFrom` null_
155−(TRUE IS NOT DISTINCT FROM NULL)
156−-}
157−isNotDistinctFrom :: Operator (null0 ty) (null1 ty) ('NotNull 'PGbool)
158−isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"
159−
160−{- | is true
161−
162−>>> printSQL $ true & isTrue
163−(TRUE IS TRUE)
164−-}
165−isTrue :: null0 'PGbool --> null1 'PGbool
166−isTrue = unsafeRightOp "IS TRUE"
167−
168−{- | is false or unknown
169−
170−>>> printSQL $ true & isNotTrue
171−(TRUE IS NOT TRUE)
172−-}
173−isNotTrue :: null0 'PGbool --> null1 'PGbool
174−isNotTrue = unsafeRightOp "IS NOT TRUE"
175−
176−{- | is false
177−
178−>>> printSQL $ true & isFalse
179−(TRUE IS FALSE)
180−-}
181−isFalse :: null0 'PGbool --> null1 'PGbool
182−isFalse = unsafeRightOp "IS FALSE"
183−
184−{- | is true or unknown
185−
186−>>> printSQL $ true & isNotFalse
187−(TRUE IS NOT FALSE)
188−-}
189−isNotFalse :: null0 'PGbool --> null1 'PGbool
190−isNotFalse = unsafeRightOp "IS NOT FALSE"
191−
192−{- | is unknown
193−
194−>>> printSQL $ true & isUnknown
195−(TRUE IS UNKNOWN)
196−-}
197−isUnknown :: null0 'PGbool --> null1 'PGbool
198−isUnknown = unsafeRightOp "IS UNKNOWN"
199−
200−{- | is true or false
201−
202−>>> printSQL $ true & isNotUnknown
203−(TRUE IS NOT UNKNOWN)
204−-}
205−isNotUnknown :: null0 'PGbool --> null1 'PGbool
206−isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hsdeleted−462
@@ -1,462 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Json
3−Description: Json and Jsonb functions and operators
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Json and Jsonb functions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , FlexibleContexts
14− , FlexibleInstances
15− , GADTs
16− , OverloadedLabels
17− , OverloadedStrings
18− , PolyKinds
19− , RankNTypes
20− , ScopedTypeVariables
21− , TypeApplications
22− , TypeOperators
23− , UndecidableInstances
24− , UndecidableSuperClasses
25−#-}
26−
27−module Squeal.PostgreSQL.Expression.Json
28− ( -- * Json and Jsonb operators
29− (.->)
30− , (.->>)
31− , (.#>)
32− , (.#>>)
33− -- * Jsonb operators
34− , (.?)
35− , (.?|)
36− , (.?&)
37− , (.-.)
38− , (#-.)
39− -- * Json and Jsonb functions
40− , toJson
41− , toJsonb
42− , arrayToJson
43− , rowToJson
44− , jsonBuildArray
45− , jsonbBuildArray
46− , JsonBuildObject (..)
47− , jsonObject
48− , jsonbObject
49− , jsonZipObject
50− , jsonbZipObject
51− , jsonArrayLength
52− , jsonbArrayLength
53− , jsonTypeof
54− , jsonbTypeof
55− , jsonStripNulls
56− , jsonbStripNulls
57− , jsonbSet
58− , jsonbInsert
59− , jsonbPretty
60− -- * Json and Jsonb set returning functions
61− , jsonEach
62− , jsonbEach
63− , jsonEachText
64− , jsonbEachText
65− , jsonObjectKeys
66− , jsonbObjectKeys
67− , JsonPopulateFunction
68− , jsonPopulateRecord
69− , jsonbPopulateRecord
70− , jsonPopulateRecordSet
71− , jsonbPopulateRecordSet
72− , JsonToRecordFunction
73− , jsonToRecord
74− , jsonbToRecord
75− , jsonToRecordSet
76− , jsonbToRecordSet
77− ) where
78−
79−import Data.ByteString (ByteString)
80−import GHC.TypeLits
81−
82−import Squeal.PostgreSQL.Alias
83−import Squeal.PostgreSQL.Expression
84−import Squeal.PostgreSQL.Expression.Set
85−import Squeal.PostgreSQL.Expression.Type
86−import Squeal.PostgreSQL.List
87−import Squeal.PostgreSQL.Query
88−import Squeal.PostgreSQL.Render
89−import Squeal.PostgreSQL.Schema
90−
91−import qualified Generics.SOP as SOP
92−
93−-- $setup
94−-- >>> import Squeal.PostgreSQL
95−-- >>> import Data.Aeson
96−
97−{-----------------------------------------
98− -- json and jsonb support
99−
100−See https://www.postgresql.org/docs/10/static/functions-json.html -- most
101−comments lifted directly from this page.
102−
103−Table 9.44: json and jsonb operators
104−-----------------------------------------}
105−
106−-- | Get JSON value (object field or array element) at a key.
107−(.->)
108− :: (json `In` PGJsonType, key `In` PGJsonKey)
109− => Operator (null json) (null key) ('Null json)
110−infixl 8 .->
111−(.->) = unsafeBinaryOp "->"
112−
113−-- | Get JSON value (object field or array element) at a key, as text.
114−(.->>)
115− :: (json `In` PGJsonType, key `In` PGJsonKey)
116− => Operator (null json) (null key) ('Null 'PGtext)
117−infixl 8 .->>
118−(.->>) = unsafeBinaryOp "->>"
119−
120−-- | Get JSON value at a specified path.
121−(.#>)
122− :: json `In` PGJsonType
123− => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null json)
124−infixl 8 .#>
125−(.#>) = unsafeBinaryOp "#>"
126−
127−-- | Get JSON value at a specified path as text.
128−(.#>>)
129− :: json `In` PGJsonType
130− => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null 'PGtext)
131−infixl 8 .#>>
132−(.#>>) = unsafeBinaryOp "#>>"
133−
134−-- Additional jsonb operators
135−
136−-- | Does the string exist as a top-level key within the JSON value?
137−(.?) :: Operator (null 'PGjsonb) (null 'PGtext) ('Null 'PGbool)
138−infixl 9 .?
139−(.?) = unsafeBinaryOp "?"
140−
141−-- | Do any of these array strings exist as top-level keys?
142−(.?|) :: Operator
143− (null 'PGjsonb)
144− (null ('PGvararray ('NotNull 'PGtext)))
145− ('Null 'PGbool)
146−infixl 9 .?|
147−(.?|) = unsafeBinaryOp "?|"
148−
149−-- | Do all of these array strings exist as top-level keys?
150−(.?&) :: Operator
151− (null 'PGjsonb)
152− (null ('PGvararray ('NotNull 'PGtext)))
153− ('Null 'PGbool)
154−infixl 9 .?&
155−(.?&) = unsafeBinaryOp "?&"
156−
157−-- | Delete a key or keys from a JSON object, or remove an array element.
158−--
159−-- If the right operand is
160−--
161−-- @ text @: Delete key / value pair or string element from left operand.
162−-- Key / value pairs are matched based on their key value,
163−--
164−-- @ text[] @: Delete multiple key / value pairs or string elements
165−-- from left operand. Key / value pairs are matched based on their key value,
166−--
167−-- @ integer @: Delete the array element with specified index (Negative integers
168−-- count from the end). Throws an error if top level container is not an array.
169−(.-.)
170− :: key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]
171− => Operator (null 'PGjsonb) (null key) (null 'PGjsonb)
172−infixl 6 .-.
173−(.-.) = unsafeBinaryOp "-"
174−
175−-- | Delete the field or element with specified path (for JSON arrays, negative
176−-- integers count from the end)
177−(#-.) :: Operator (null 'PGjsonb) (null ('PGvararray ('NotNull 'PGtext))) (null 'PGjsonb)
178−infixl 6 #-.
179−(#-.) = unsafeBinaryOp "#-"
180−
181−{-----------------------------------------
182−Table 9.45: JSON creation functions
183−-----------------------------------------}
184−
185−-- | Returns the value as json. Arrays and composites are converted
186−-- (recursively) to arrays and objects; otherwise, if there is a cast from the
187−-- type to json, the cast function will be used to perform the conversion;
188−-- otherwise, a scalar value is produced. For any scalar type other than a
189−-- number, a Boolean, or a null value, the text representation will be used, in
190−-- such a fashion that it is a valid json value.
191−toJson :: null ty --> null 'PGjson
192−toJson = unsafeFunction "to_json"
193−
194−-- | Returns the value as jsonb. Arrays and composites are converted
195−-- (recursively) to arrays and objects; otherwise, if there is a cast from the
196−-- type to json, the cast function will be used to perform the conversion;
197−-- otherwise, a scalar value is produced. For any scalar type other than a
198−-- number, a Boolean, or a null value, the text representation will be used, in
199−-- such a fashion that it is a valid jsonb value.
200−toJsonb :: null ty --> null 'PGjsonb
201−toJsonb = unsafeFunction "to_jsonb"
202−
203−-- | Returns the array as a JSON array. A PostgreSQL multidimensional array
204−-- becomes a JSON array of arrays.
205−arrayToJson :: null ('PGvararray ty) --> null 'PGjson
206−arrayToJson = unsafeFunction "array_to_json"
207−
208−-- | Returns the row as a JSON object.
209−rowToJson :: null ('PGcomposite ty) --> null 'PGjson
210−rowToJson = unsafeFunction "row_to_json"
211−
212−-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic
213−-- argument list.
214−jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson
215−jsonBuildArray = unsafeFunctionN "json_build_array"
216−
217−-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a
218−-- variadic argument list.
219−jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb
220−jsonbBuildArray = unsafeFunctionN "jsonb_build_array"
221−
222−-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic
223−-- argument list. The elements of the argument list must alternate between text
224−-- and values.
225−class SOP.SListI tys => JsonBuildObject tys where
226−
227− jsonBuildObject :: tys ---> null 'PGjson
228− jsonBuildObject = unsafeFunctionN "json_build_object"
229−
230− jsonbBuildObject :: tys ---> null 'PGjsonb
231− jsonbBuildObject = unsafeFunctionN "jsonb_build_object"
232−
233−instance JsonBuildObject '[]
234−instance (JsonBuildObject tys, key `In` PGJsonKey)
235− => JsonBuildObject ('NotNull key ': value ': tys)
236−
237−-- | Builds a JSON object out of a text array.
238−-- The array must have two dimensions
239−-- such that each inner array has exactly two elements,
240−-- which are taken as a key/value pair.
241−jsonObject
242− :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
243− --> null 'PGjson
244−jsonObject = unsafeFunction "json_object"
245−
246−-- | Builds a binary JSON object out of a text array.
247−-- The array must have two dimensions
248−-- such that each inner array has exactly two elements,
249−-- which are taken as a key/value pair.
250−jsonbObject
251− :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))
252− --> null 'PGjsonb
253−jsonbObject = unsafeFunction "jsonb_object"
254−
255−-- | This is an alternate form of 'jsonObject' that takes two arrays; one for
256−-- keys and one for values, that are zipped pairwise to create a JSON object.
257−jsonZipObject ::
258− '[ null ('PGvararray ('NotNull 'PGtext))
259− , null ('PGvararray ('NotNull 'PGtext)) ]
260− ---> null 'PGjson
261−jsonZipObject = unsafeFunctionN "json_object"
262−
263−-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for
264−-- keys and one for values, that are zipped pairwise to create a binary JSON
265−-- object.
266−jsonbZipObject ::
267− '[ null ('PGvararray ('NotNull 'PGtext))
268− , null ('PGvararray ('NotNull 'PGtext)) ]
269− ---> null 'PGjsonb
270−jsonbZipObject = unsafeFunctionN "jsonb_object"
271−
272−{-----------------------------------------
273−Table 9.46: JSON processing functions
274−-----------------------------------------}
275−
276−-- | Returns the number of elements in the outermost JSON array.
277−jsonArrayLength :: null 'PGjson --> null 'PGint4
278−jsonArrayLength = unsafeFunction "json_array_length"
279−
280−-- | Returns the number of elements in the outermost binary JSON array.
281−jsonbArrayLength :: null 'PGjsonb --> null 'PGint4
282−jsonbArrayLength = unsafeFunction "jsonb_array_length"
283−
284−-- | Returns the type of the outermost JSON value as a text string. Possible
285−-- types are object, array, string, number, boolean, and null.
286−jsonTypeof :: null 'PGjson --> null 'PGtext
287−jsonTypeof = unsafeFunction "json_typeof"
288−
289−-- | Returns the type of the outermost binary JSON value as a text string.
290−-- Possible types are object, array, string, number, boolean, and null.
291−jsonbTypeof :: null 'PGjsonb --> null 'PGtext
292−jsonbTypeof = unsafeFunction "jsonb_typeof"
293−
294−-- | Returns its argument with all object fields that have null values omitted.
295−-- Other null values are untouched.
296−jsonStripNulls :: null 'PGjson --> null 'PGjson
297−jsonStripNulls = unsafeFunction "json_strip_nulls"
298−
299−-- | Returns its argument with all object fields that have null values omitted.
300−-- Other null values are untouched.
301−jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb
302−jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"
303−
304−-- | @ jsonbSet target path new_value create_missing @
305−--
306−-- Returns target with the section designated by path replaced by @new_value@,
307−-- or with @new_value@ added if create_missing is
308−-- `Squeal.PostgreSQL.Expression.Logic.true` and the
309−-- item designated by path does not exist. As with the path orientated
310−-- operators, negative integers that appear in path count from the end of JSON
311−-- arrays.
312−jsonbSet ::
313− '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
314− , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
315−jsonbSet = unsafeFunctionN "jsonbSet"
316−
317−-- | @ jsonbInsert target path new_value insert_after @
318−--
319−-- Returns target with @new_value@ inserted. If target section designated by
320−-- path is in a JSONB array, @new_value@ will be inserted before target or after
321−-- if @insert_after@ is `Squeal.PostgreSQL.Expression.Logic.true`.
322−-- If target section designated by
323−-- path is in JSONB object, @new_value@ will be inserted only if target does not
324−-- exist. As with the path orientated operators, negative integers that appear
325−-- in path count from the end of JSON arrays.
326−jsonbInsert ::
327− '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))
328− , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb
329−jsonbInsert = unsafeFunctionN "jsonb_insert"
330−
331−-- | Returns its argument as indented JSON text.
332−jsonbPretty :: null 'PGjsonb --> null 'PGtext
333−jsonbPretty = unsafeFunction "jsonb_pretty"
334−
335−{- | Expands the outermost JSON object into a set of key/value pairs.
336−
337−>>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
338−SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))
339−-}
340−jsonEach :: SetFunction "json_each" (null 'PGjson)
341− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
342−jsonEach = unsafeSetFunction
343−
344−{- | Expands the outermost binary JSON object into a set of key/value pairs.
345−
346−>>> printSQL (select Star (from (jsonbEach (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))
347−SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))
348−-}
349−jsonbEach
350− :: SetFunction "jsonb_each" (nullity 'PGjsonb)
351− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]
352−jsonbEach = unsafeSetFunction
353−
354−{- | Expands the outermost JSON object into a set of key/value pairs.
355−
356−>>> printSQL (select Star (from (jsonEachText (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))
357−SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))
358−-}
359−jsonEachText
360− :: SetFunction "json_each_text" (null 'PGjson)
361− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
362−jsonEachText = unsafeSetFunction
363−
364−{- | Expands the outermost binary JSON object into a set of key/value pairs.
365−
366−>>> printSQL (select Star (from (jsonbEachText (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))
367−SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))
368−-}
369−jsonbEachText
370− :: SetFunction "jsonb_each_text" (null 'PGjsonb)
371− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]
372−jsonbEachText = unsafeSetFunction
373−
374−{- | Returns set of keys in the outermost JSON object.
375−
376−>>> printSQL (jsonObjectKeys (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))
377−json_object_keys(('{"a":"foo","b":"bar"}' :: json))
378−-}
379−jsonObjectKeys
380− :: SetFunction "json_object_keys" (nullity 'PGjson)
381− '["json_object_keys" ::: 'NotNull 'PGtext]
382−jsonObjectKeys = unsafeSetFunction
383−
384−{- | Returns set of keys in the outermost JSON object.
385−
386−>>> printSQL (jsonbObjectKeys (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))
387−jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))
388−-}
389−jsonbObjectKeys
390− :: SetFunction "jsonb_object_keys" (null 'PGjsonb)
391− '["jsonb_object_keys" ::: 'NotNull 'PGtext]
392−jsonbObjectKeys = unsafeSetFunction
393−
394−-- | Build rows from Json types.
395−type JsonPopulateFunction fun json
396− = forall schemas row outer commons params
397− . json `In` PGJsonType
398− => TypeExpression schemas ('NotNull ('PGcomposite row)) -- ^ row type
399− -> Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)
400− -- ^ json type
401− -> FromClause outer commons schemas params '[fun ::: row]
402−
403−unsafePopulateFunction
404− :: forall fun ty
405− . KnownSymbol fun => Alias fun -> JsonPopulateFunction fun ty
406−unsafePopulateFunction _fun ty expr = UnsafeFromClause $ renderSymbol @fun
407− <> parenthesized ("null::" <> renderSQL ty <> ", " <> renderSQL expr)
408−
409−-- | Expands the JSON expression to a row whose columns match the record
410−-- type defined by the given table.
411−jsonPopulateRecord :: JsonPopulateFunction "json_populate_record" 'PGjson
412−jsonPopulateRecord = unsafePopulateFunction #json_populate_record
413−
414−-- | Expands the binary JSON expression to a row whose columns match the record
415−-- type defined by the given table.
416−jsonbPopulateRecord :: JsonPopulateFunction "jsonb_populate_record" 'PGjsonb
417−jsonbPopulateRecord = unsafePopulateFunction #jsonb_populate_record
418−
419−-- | Expands the outermost array of objects in the given JSON expression to a
420−-- set of rows whose columns match the record type defined by the given table.
421−jsonPopulateRecordSet :: JsonPopulateFunction "json_populate_record_set" 'PGjson
422−jsonPopulateRecordSet = unsafePopulateFunction #json_populate_record_set
423−
424−-- | Expands the outermost array of objects in the given binary JSON expression
425−-- to a set of rows whose columns match the record type defined by the given
426−-- table.
427−jsonbPopulateRecordSet :: JsonPopulateFunction "jsonb_populate_record_set" 'PGjsonb
428−jsonbPopulateRecordSet = unsafePopulateFunction #jsonb_populate_record_set
429−
430−-- | Build rows from Json types.
431−type JsonToRecordFunction json
432− = forall outer commons schemas params tab row
433− . (SOP.SListI row, json `In` PGJsonType)
434− => Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)
435− -- ^ json type
436− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: row)
437− -- ^ row type
438− -> FromClause outer commons schemas params '[tab ::: row]
439−
440−unsafeRecordFunction :: ByteString -> JsonToRecordFunction json
441−unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $
442− fun <> parenthesized (renderSQL expr) <+> "AS" <+> renderSQL tab
443− <> parenthesized (renderCommaSeparated renderTy types)
444− where
445− renderTy :: Aliased (TypeExpression schemas) ty -> ByteString
446− renderTy (ty `As` alias) = renderSQL alias <+> renderSQL ty
447−
448−-- | Builds an arbitrary record from a JSON object.
449−jsonToRecord :: JsonToRecordFunction 'PGjson
450−jsonToRecord = unsafeRecordFunction "json_to_record"
451−
452−-- | Builds an arbitrary record from a binary JSON object.
453−jsonbToRecord :: JsonToRecordFunction 'PGjsonb
454−jsonbToRecord = unsafeRecordFunction "jsonb_to_record"
455−
456−-- | Builds an arbitrary set of records from a JSON array of objects.
457−jsonToRecordSet :: JsonToRecordFunction 'PGjson
458−jsonToRecordSet = unsafeRecordFunction "json_to_record_set"
459−
460−-- | Builds an arbitrary set of records from a binary JSON array of objects.
461−jsonbToRecordSet :: JsonToRecordFunction 'PGjsonb
462−jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Literal.hsdeleted−87
@@ -1,87 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Literal
3−Description: Literal expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Literal expressions
9−-}
10−
11−{-# LANGUAGE
12− FlexibleContexts
13− , FlexibleInstances
14− , LambdaCase
15− , OverloadedStrings
16− , RankNTypes
17− , ScopedTypeVariables
18− , TypeApplications
19− , TypeSynonymInstances
20− , UndecidableInstances
21−#-}
22−
23−module Squeal.PostgreSQL.Expression.Literal (Literal (..)) where
24−
25−import ByteString.StrictBuilder (builderBytes)
26−import Data.ByteString.Lazy (toStrict)
27−import Data.Int
28−import Data.String
29−import Data.Text (Text)
30−
31−import qualified Data.Aeson as JSON
32−import qualified Data.Text as Text
33−import qualified Data.Text.Lazy as Lazy (Text)
34−import qualified Data.Text.Lazy as Lazy.Text
35−
36−import Squeal.PostgreSQL.Binary
37−import Squeal.PostgreSQL.Expression
38−import Squeal.PostgreSQL.Expression.Logic
39−import Squeal.PostgreSQL.PG
40−import Squeal.PostgreSQL.Render
41−
42−{- |
43−The `Literal` class allows embedding a Haskell value directly
44−as an `Expression` using `literal`.
45−
46−>>> printSQL (literal 'a')
47−E'a'
48−
49−>>> printSQL (literal (1 :: Double))
50−1.0
51−
52−>>> printSQL (literal (Json [1 :: Double, 2]))
53−('[1.0,2.0]' :: json)
54−
55−>>> printSQL (literal (Enumerated GT))
56−'GT'
57−-}
58−class Literal hask where literal :: hask -> Expr (null (PG hask))
59−instance Literal Bool where
60− literal = \case
61− True -> true
62− False -> false
63−instance JSON.ToJSON hask => Literal (Json hask) where
64− literal = UnsafeExpression . parenthesized . (<> " :: json")
65− . singleQuotedUtf8 . toStrict . JSON.encode . getJson
66−instance JSON.ToJSON hask => Literal (Jsonb hask) where
67− literal = UnsafeExpression . parenthesized . (<> " :: jsonb")
68− . singleQuotedUtf8 . toStrict . JSON.encode . getJsonb
69−instance Literal Char where
70− literal chr = UnsafeExpression $
71− "E\'" <> fromString (escape chr) <> "\'"
72−instance Literal String where literal = fromString
73−instance Literal Int16 where literal = fromIntegral
74−instance Literal Int32 where literal = fromIntegral
75−instance Literal Int64 where literal = fromIntegral
76−instance Literal Float where literal = fromRational . toRational
77−instance Literal Double where literal = fromRational . toRational
78−instance Literal Text where literal = fromString . Text.unpack
79−instance Literal Lazy.Text where literal = fromString . Lazy.Text.unpack
80−instance ToParam (Enumerated enum) (PG (Enumerated enum))
81− => Literal (Enumerated enum) where
82− literal
83− = UnsafeExpression
84− . singleQuotedUtf8
85− . builderBytes
86− . unK
87− . toParam @(Enumerated enum) @(PG (Enumerated enum))
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hsdeleted−105
@@ -1,105 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Logic
3−Description: Logical expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Logical expressions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , TypeOperators
15−#-}
16−
17−module Squeal.PostgreSQL.Expression.Logic
18− ( Condition
19− , true
20− , false
21− , not_
22− , (.&&)
23− , (.||)
24− , caseWhenThenElse
25− , ifThenElse
26− ) where
27−
28−import Squeal.PostgreSQL.Expression
29−import Squeal.PostgreSQL.Render
30−import Squeal.PostgreSQL.Schema
31−
32−-- | A `Condition` is an `Expression`, which can evaluate
33−-- to `true`, `false` or `Squeal.PostgreSQL.Null.null_`. This is because SQL uses
34−-- a three valued logic.
35−type Condition outer commons grp schemas params from =
36− Expression outer commons grp schemas params from ('Null 'PGbool)
37−
38−-- | >>> printSQL true
39−-- TRUE
40−true :: Expr (null 'PGbool)
41−true = UnsafeExpression "TRUE"
42−
43−-- | >>> printSQL false
44−-- FALSE
45−false :: Expr (null 'PGbool)
46−false = UnsafeExpression "FALSE"
47−
48−-- | >>> printSQL $ not_ true
49−-- (NOT TRUE)
50−not_ :: null 'PGbool --> null 'PGbool
51−not_ = unsafeLeftOp "NOT"
52−
53−-- | >>> printSQL $ true .&& false
54−-- (TRUE AND FALSE)
55−(.&&) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)
56−infixr 3 .&&
57−(.&&) = unsafeBinaryOp "AND"
58−
59−-- | >>> printSQL $ true .|| false
60−-- (TRUE OR FALSE)
61−(.||) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)
62−infixr 2 .||
63−(.||) = unsafeBinaryOp "OR"
64−
65−-- | >>> :{
66−-- let
67−-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
68−-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3
69−-- in printSQL expression
70−-- :}
71−-- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END
72−caseWhenThenElse
73− :: [ ( Condition outer commons grp schemas params from
74− , Expression outer commons grp schemas params from ty
75− ) ]
76− -- ^ whens and thens
77− -> Expression outer commons grp schemas params from ty
78− -- ^ else
79− -> Expression outer commons grp schemas params from ty
80−caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
81− [ "CASE"
82− , mconcat
83− [ mconcat
84− [ " WHEN ", renderSQL when_
85− , " THEN ", renderSQL then_
86− ]
87− | (when_,then_) <- whenThens
88− ]
89− , " ELSE ", renderSQL else_
90− , " END"
91− ]
92−
93−-- | >>> :{
94−-- let
95−-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
96−-- expression = ifThenElse true 1 0
97−-- in printSQL expression
98−-- :}
99−-- CASE WHEN TRUE THEN 1 ELSE 0 END
100−ifThenElse
101− :: Condition outer commons grp schemas params from
102− -> Expression outer commons grp schemas params from ty -- ^ then
103− -> Expression outer commons grp schemas params from ty -- ^ else
104− -> Expression outer commons grp schemas params from ty
105−ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hsdeleted−100
@@ -1,100 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Math
3−Description: Math expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Mathematical functions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , TypeOperators
15−#-}
16−
17−module Squeal.PostgreSQL.Expression.Math
18− ( atan2_
19− , quot_
20− , rem_
21− , trunc
22− , round_
23− , ceiling_
24− ) where
25−
26−import Squeal.PostgreSQL.Expression
27−import Squeal.PostgreSQL.List
28−import Squeal.PostgreSQL.Schema
29−
30−-- $setup
31−-- >>> import Squeal.PostgreSQL
32−
33−-- | >>> :{
34−-- let
35−-- expression :: Expr (null 'PGfloat4)
36−-- expression = atan2_ (pi *: 2)
37−-- in printSQL expression
38−-- :}
39−-- atan2(pi(), 2)
40−atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float
41−atan2_ = unsafeFunctionN "atan2"
42−
43−
44−-- | integer division, truncates the result
45−--
46−-- >>> :{
47−-- let
48−-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
49−-- expression = 5 `quot_` 2
50−-- in printSQL expression
51−-- :}
52−-- (5 / 2)
53−quot_
54− :: int `In` PGIntegral
55− => Operator (null int) (null int) (null int)
56−quot_ = unsafeBinaryOp "/"
57−
58−-- | remainder upon integer division
59−--
60−-- >>> :{
61−-- let
62−-- expression :: Expression outer commons grp schemas params from (null 'PGint2)
63−-- expression = 5 `rem_` 2
64−-- in printSQL expression
65−-- :}
66−-- (5 % 2)
67−rem_
68− :: int `In` PGIntegral
69− => Operator (null int) (null int) (null int)
70−rem_ = unsafeBinaryOp "%"
71−
72−-- | >>> :{
73−-- let
74−-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)
75−-- expression = trunc pi
76−-- in printSQL expression
77−-- :}
78−-- trunc(pi())
79−trunc :: frac `In` PGFloating => null frac --> null frac
80−trunc = unsafeFunction "trunc"
81−
82−-- | >>> :{
83−-- let
84−-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)
85−-- expression = round_ pi
86−-- in printSQL expression
87−-- :}
88−-- round(pi())
89−round_ :: frac `In` PGFloating => null frac --> null frac
90−round_ = unsafeFunction "round"
91−
92−-- | >>> :{
93−-- let
94−-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)
95−-- expression = ceiling_ pi
96−-- in printSQL expression
97−-- :}
98−-- ceiling(pi())
99−ceiling_ :: frac `In` PGFloating => null frac --> null frac
100−ceiling_ = unsafeFunction "ceiling"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hsdeleted−104
@@ -1,104 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Null
3−Description: Null
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Null values and null handling functions
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , TypeOperators
15−#-}
16−
17−module Squeal.PostgreSQL.Expression.Null
18− ( null_
19− , notNull
20− , coalesce
21− , fromNull
22− , isNull
23− , isNotNull
24− , matchNull
25− , nullIf
26− ) where
27−
28−import Squeal.PostgreSQL.Expression
29−import Squeal.PostgreSQL.Expression.Logic
30−import Squeal.PostgreSQL.Render
31−import Squeal.PostgreSQL.Schema
32−
33−-- $setup
34−-- >>> import Squeal.PostgreSQL
35−
36−-- | analagous to `Nothing`
37−--
38−-- >>> printSQL null_
39−-- NULL
40−null_ :: Expr ('Null ty)
41−null_ = UnsafeExpression "NULL"
42−
43−-- | analagous to `Just`
44−--
45−-- >>> printSQL $ notNull true
46−-- TRUE
47−notNull :: 'NotNull ty --> 'Null ty
48−notNull = UnsafeExpression . renderSQL
49−
50−-- | return the leftmost value which is not NULL
51−--
52−-- >>> printSQL $ coalesce [null_, true] false
53−-- COALESCE(NULL, TRUE, FALSE)
54−coalesce :: FunctionVar ('Null ty) ('NotNull ty) ('NotNull ty)
55−coalesce nullxs notNullx = UnsafeExpression $
56− "COALESCE" <> parenthesized (commaSeparated
57− ((renderSQL <$> nullxs) <> [renderSQL notNullx]))
58−
59−-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@
60−--
61−-- >>> printSQL $ fromNull true null_
62−-- COALESCE(NULL, TRUE)
63−fromNull
64− :: Expression outer commons grp schemas params from ('NotNull ty)
65− -- ^ what to convert @NULL@ to
66− -> Expression outer commons grp schemas params from ('Null ty)
67− -> Expression outer commons grp schemas params from ('NotNull ty)
68−fromNull notNullx nullx = coalesce [nullx] notNullx
69−
70−-- | >>> printSQL $ null_ & isNull
71−-- NULL IS NULL
72−isNull :: 'Null ty --> null 'PGbool
73−isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"
74−
75−-- | >>> printSQL $ null_ & isNotNull
76−-- NULL IS NOT NULL
77−isNotNull :: 'Null ty --> null 'PGbool
78−isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"
79−
80−-- | analagous to `maybe` using @IS NULL@
81−--
82−-- >>> printSQL $ matchNull true not_ null_
83−-- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END
84−matchNull
85− :: Expression outer commons grp schemas params from (nullty)
86− -- ^ what to convert @NULL@ to
87− -> ( Expression outer commons grp schemas params from ('NotNull ty)
88− -> Expression outer commons grp schemas params from (nullty) )
89− -- ^ function to perform when @NULL@ is absent
90− -> Expression outer commons grp schemas params from ('Null ty)
91− -> Expression outer commons grp schemas params from (nullty)
92−matchNull y f x = ifThenElse (isNull x) y
93− (f (UnsafeExpression (renderSQL x)))
94−
95−{-| right inverse to `fromNull`, if its arguments are equal then
96−`nullIf` gives @NULL@.
97−
98−>>> :set -XTypeApplications -XDataKinds
99−>>> let expr = nullIf (false *: param @1) :: Expression outer commons grp schemas '[ 'NotNull 'PGbool] from ('Null 'PGbool)
100−>>> printSQL expr
101−NULLIF(FALSE, ($1 :: bool))
102−-}
103−nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty
104−nullIf = unsafeFunctionN "NULLIF"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hsdeleted−80
@@ -1,80 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Parameter
3−Description: Parameters
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Parameters, out-of-line data values
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DataKinds
14− , FlexibleContexts
15− , FlexibleInstances
16− , FunctionalDependencies
17− , KindSignatures
18− , MultiParamTypeClasses
19− , OverloadedStrings
20− , RankNTypes
21− , ScopedTypeVariables
22− , TypeApplications
23− , TypeOperators
24− , UndecidableInstances
25−#-}
26−
27−module Squeal.PostgreSQL.Expression.Parameter
28− ( HasParameter (parameter)
29− , param
30− ) where
31−
32−import GHC.TypeLits
33−
34−import Squeal.PostgreSQL.Expression
35−import Squeal.PostgreSQL.Expression.Type
36−import Squeal.PostgreSQL.Render
37−import Squeal.PostgreSQL.Schema
38−
39−-- $setup
40−-- >>> import Squeal.PostgreSQL
41−
42−{- | A `HasParameter` constraint is used to indicate a value that is
43−supplied externally to a SQL statement.
44−`Squeal.PostgreSQL.PQ.manipulateParams`,
45−`Squeal.PostgreSQL.PQ.queryParams` and
46−`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values
47−separately from the SQL command string, in which case `param`s are used to
48−refer to the out-of-line data values.
49−-}
50−class KnownNat n => HasParameter
51− (n :: Nat)
52− (params :: [NullityType])
53− (ty :: NullityType)
54− | n params -> ty where
55− -- | `parameter` takes a `Nat` using type application and a `TypeExpression`.
56− --
57− -- >>> let expr = parameter @1 int4 :: Expression outer '[] grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)
58− -- >>> printSQL expr
59− -- ($1 :: int4)
60− parameter
61− :: TypeExpression schemas ty
62− -> Expression outer commons grp schemas params from ty
63− parameter ty = UnsafeExpression $ parenthesized $
64− "$" <> renderNat @n <+> "::"
65− <+> renderSQL ty
66−instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1
67−instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
68− => HasParameter n (ty' : params) ty
69−
70−-- | `param` takes a `Nat` using type application and for basic types,
71−-- infers a `TypeExpression`.
72−--
73−-- >>> let expr = param @1 :: Expression outer commons grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)
74−-- >>> printSQL expr
75−-- ($1 :: int4)
76−param
77− :: forall n outer commons schemas params from grp ty
78− . (PGTyped schemas ty, HasParameter n params ty)
79− => Expression outer commons grp schemas params from ty -- ^ param
80−param = parameter @n (pgtype @schemas)
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hsdeleted−230
@@ -1,230 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Range
3−Description: range types and functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Range types and functions
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DataKinds
14− , DeriveAnyClass
15− , DeriveGeneric
16− , DeriveFoldable
17− , DerivingStrategies
18− , DeriveTraversable
19− , FlexibleContexts
20− , FlexibleInstances
21− , LambdaCase
22− , MultiParamTypeClasses
23− , OverloadedLabels
24− , OverloadedStrings
25− , PatternSynonyms
26− , RankNTypes
27− , ScopedTypeVariables
28− , TypeApplications
29− , TypeFamilies
30− , TypeOperators
31− , UndecidableInstances
32−#-}
33−
34−module Squeal.PostgreSQL.Expression.Range
35− ( range
36− , Range (..)
37− , (<=..<=), (<..<), (<=..<), (<..<=)
38− , moreThan, atLeast, lessThan, atMost
39− , singleton, whole
40− , Bound (..)
41− , (.<@)
42− , (@>.)
43− , (<<@)
44− , (@>>)
45− , (&<)
46− , (&>)
47− , (-|-)
48− , (@+)
49− , (@*)
50− , (@-)
51− , lowerBound
52− , upperBound
53− , isEmpty
54− , lowerInc
55− , lowerInf
56− , upperInc
57− , upperInf
58− , rangeMerge
59− ) where
60−
61−import BinaryParser
62−import ByteString.StrictBuilder
63−import Data.Bits
64−import qualified GHC.Generics as GHC
65−import qualified Generics.SOP as SOP
66−import qualified PostgreSQL.Binary.Decoding as Decoding
67−
68−import Squeal.PostgreSQL.Binary
69−import Squeal.PostgreSQL.Expression
70−import Squeal.PostgreSQL.Expression.Type hiding (bool)
71−import Squeal.PostgreSQL.PG
72−import Squeal.PostgreSQL.Render
73−import Squeal.PostgreSQL.Schema
74−
75−-- $setup
76−-- >>> import Squeal.PostgreSQL
77−
78−-- | Construct a `range`
79−--
80−-- >>> printSQL $ range tstzrange (atLeast now)
81−-- tstzrange(now(), NULL, '[)')
82−-- >>> printSQL $ range numrange (0 <=..< 2*pi)
83−-- numrange(0, (2 * pi()), '[)')
84−-- >>> printSQL $ range int4range Empty
85−-- ('empty' :: int4range)
86−range
87− :: TypeExpression schemas (null ('PGrange ty))
88− -> Range (Expression outer commons grp schemas params from ('NotNull ty))
89− -> Expression outer commons grp schemas params from (null ('PGrange ty))
90−range ty = \case
91− Empty -> UnsafeExpression $ parenthesized
92− (emp <+> "::" <+> renderSQL ty)
93− NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized
94− (commaSeparated (args l u))
95− where
96− emp = singleQuote <> "empty" <> singleQuote
97− args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote]
98− singleQuote = "\'"
99− arg = \case
100− Infinite -> "NULL"; Closed x -> renderSQL x; Open x -> renderSQL x
101− bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "("
102− ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")"
103−
104−data Bound x = Infinite | Closed x | Open x
105− deriving
106− ( Eq, Ord, Show, Read, GHC.Generic
107− , Functor, Foldable, Traversable )
108−
109−data Range x = Empty | NonEmpty (Bound x) (Bound x)
110− deriving
111− ( Eq, Ord, Show, Read, GHC.Generic
112− , Functor, Foldable, Traversable )
113− deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
114−type instance PG (Range x) = 'PGrange (PG x)
115−instance ToParam x pg => ToParam (Range x) ('PGrange pg) where
116− toParam rng = K $
117− word8 (setFlags rng 0) <>
118− case rng of
119− Empty -> mempty
120− NonEmpty lower upper -> putBound lower <> putBound upper
121− where
122− putBound = \case
123− Infinite -> mempty
124− Closed value -> putValue (unK (toParam @x @pg value))
125− Open value -> putValue (unK (toParam @x @pg value))
126− putValue value = int32BE (fromIntegral (builderLength value)) <> value
127− setFlags = \case
128− Empty -> (`setBit` 0)
129− NonEmpty lower upper ->
130− setLowerFlags lower . setUpperFlags upper
131− setLowerFlags = \case
132− Infinite -> (`setBit` 3)
133− Closed _ -> (`setBit` 1)
134− Open _ -> id
135− setUpperFlags = \case
136− Infinite -> (`setBit` 4)
137− Closed _ -> (`setBit` 2)
138− Open _ -> id
139−instance FromValue pg y => FromValue ('PGrange pg) (Range y) where
140− fromValue = do
141− flag <- byte
142− if testBit flag 0 then return Empty else do
143− lower <-
144− if testBit flag 3
145− then return Infinite
146− else do
147− len <- sized 4 Decoding.int
148− l <- sized len (fromValue @pg)
149− return $ if testBit flag 1 then Closed l else Open l
150− upper <-
151− if testBit flag 4
152− then return Infinite
153− else do
154− len <- sized 4 Decoding.int
155− l <- sized len (fromValue @pg)
156− return $ if testBit flag 2 then Closed l else Open l
157− return $ NonEmpty lower upper
158−
159−(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x
160−infix 4 <=..<=, <..<, <=..<, <..<=
161−x <=..<= y = NonEmpty (Closed x) (Closed y)
162−x <..< y = NonEmpty (Open x) (Open y)
163−x <=..< y = NonEmpty (Closed x) (Open y)
164−x <..<= y = NonEmpty (Open x) (Closed y)
165−
166−moreThan, atLeast, lessThan, atMost :: x -> Range x
167−moreThan x = NonEmpty (Open x) Infinite
168−atLeast x = NonEmpty (Closed x) Infinite
169−lessThan x = NonEmpty Infinite (Open x)
170−atMost x = NonEmpty Infinite (Closed x)
171−
172−singleton :: x -> Range x
173−singleton x = x <=..<= x
174−
175−whole :: Range x
176−whole = NonEmpty Infinite Infinite
177−
178−(.<@) :: Operator ('NotNull ty) (null ('PGrange ty)) ('Null 'PGbool)
179−(.<@) = unsafeBinaryOp "<@"
180−
181−(@>.) :: Operator (null ('PGrange ty)) ('NotNull ty) ('Null 'PGbool)
182−(@>.) = unsafeBinaryOp "<@"
183−
184−(<<@) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
185−(<<@) = unsafeBinaryOp "<<"
186−
187−(@>>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
188−(@>>) = unsafeBinaryOp ">>"
189−
190−(&<) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
191−(&<) = unsafeBinaryOp "&<"
192−
193−(&>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
194−(&>) = unsafeBinaryOp "&>"
195−
196−(-|-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
197−(-|-) = unsafeBinaryOp "-|-"
198−
199−(@+) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
200−(@+) = unsafeBinaryOp "+"
201−
202−(@*) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
203−(@*) = unsafeBinaryOp "*"
204−
205−(@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
206−(@-) = unsafeBinaryOp "-"
207−
208−lowerBound :: null ('PGrange ty) --> 'Null ty
209−lowerBound = unsafeFunction "lower"
210−
211−upperBound :: null ('PGrange ty) --> 'Null ty
212−upperBound = unsafeFunction "upper"
213−
214−isEmpty :: null ('PGrange ty) --> 'Null 'PGbool
215−isEmpty = unsafeFunction "isempty"
216−
217−lowerInc :: null ('PGrange ty) --> 'Null 'PGbool
218−lowerInc = unsafeFunction "lower_inc"
219−
220−lowerInf :: null ('PGrange ty) --> 'Null 'PGbool
221−lowerInf = unsafeFunction "lower_inf"
222−
223−upperInc :: null ('PGrange ty) --> 'Null 'PGbool
224−upperInc = unsafeFunction "upper_inc"
225−
226−upperInf :: null ('PGrange ty) --> 'Null 'PGbool
227−upperInf = unsafeFunction "upper_inf"
228−
229−rangeMerge :: '[null ('PGrange ty), null ('PGrange ty)] ---> null ('PGrange ty)
230−rangeMerge = unsafeFunctionN "range_merge"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Set.hsdeleted−139
@@ -1,139 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Set
3−Description: Set returning functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Set returning functions
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DataKinds
14− , FlexibleContexts
15− , OverloadedStrings
16− , PolyKinds
17− , RankNTypes
18− , ScopedTypeVariables
19− , TypeApplications
20− , TypeOperators
21−#-}
22−
23−module Squeal.PostgreSQL.Expression.Set
24− ( generateSeries
25− , generateSeriesStep
26− , generateSeriesTimestamp
27− , SetFunction
28− , unsafeSetFunction
29− , SetFunctionDB
30− , setFunction
31− , SetFunctionN
32− , unsafeSetFunctionN
33− , SetFunctionNDB
34− , setFunctionN
35− ) where
36−
37−import GHC.TypeLits
38−
39−import qualified Generics.SOP as SOP
40−
41−import Squeal.PostgreSQL.Alias
42−import Squeal.PostgreSQL.Expression
43−import Squeal.PostgreSQL.List
44−import Squeal.PostgreSQL.Render
45−import Squeal.PostgreSQL.Query
46−import Squeal.PostgreSQL.Schema
47−
48−{- |
49−A @RankNType@ for set returning functions with 1 argument.
50−-}
51−type SetFunction fun ty row
52− = forall outer commons schemas params
53− . Expression outer commons 'Ungrouped schemas params '[] ty
54− -- ^ input
55− -> FromClause outer commons schemas params '[fun ::: row]
56− -- ^ output
57−
58−type SetFunctionDB fun schemas ty row
59− = forall outer commons params
60− . Expression outer commons 'Ungrouped schemas params '[] ty
61− -- ^ input
62− -> FromClause outer commons schemas params '[fun ::: row]
63− -- ^ output
64−
65−-- | Escape hatch for a set returning function with 1 argument.
66−unsafeSetFunction
67− :: forall fun ty row. KnownSymbol fun
68− => SetFunction fun ty row -- ^ set returning function
69−unsafeSetFunction x = UnsafeFromClause $
70− renderSymbol @fun <> parenthesized (renderSQL x)
71−
72−setFunction
73− :: ( Has sch schemas schema
74− , Has fun schema ('Function ('[ty] :=> 'ReturnsTable row)) )
75− => QualifiedAlias sch fun
76− -> SetFunctionDB fun schemas ty row
77−setFunction _ = unsafeSetFunction
78−
79−{- |
80−A @RankNType@ for set returning functions with multiple argument.
81−-}
82−type SetFunctionN fun tys row
83− = forall outer commons schemas params
84− . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
85− -- ^ inputs
86− -> FromClause outer commons schemas params '[fun ::: row]
87− -- ^ output
88−
89−-- | Escape hatch for a set returning function with multiple argument.
90−unsafeSetFunctionN
91− :: forall fun tys row. (SOP.SListI tys, KnownSymbol fun)
92− => SetFunctionN fun tys row -- ^ set returning function
93−unsafeSetFunctionN xs = UnsafeFromClause $
94− renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)
95−
96−type SetFunctionNDB fun schemas tys row
97− = forall outer commons params
98− . NP (Expression outer commons 'Ungrouped schemas params '[]) tys
99− -- ^ inputs
100− -> FromClause outer commons schemas params '[fun ::: row]
101− -- ^ output
102−
103−setFunctionN
104− :: ( Has sch schemas schema
105− , Has fun schema ('Function (tys :=> 'ReturnsTable row))
106− , SOP.SListI tys )
107− => QualifiedAlias sch fun
108− -> SetFunctionNDB fun schemas tys row
109−setFunctionN _ = unsafeSetFunctionN
110−
111−{- | @generateSeries (start *: stop)@
112−
113−Generate a series of values, from @start@ to @stop@ with a step size of one
114−-}
115−generateSeries
116− :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
117− => SetFunctionN "generate_series" '[ null ty, null ty]
118− '["generate_series" ::: null ty] -- ^ set returning function
119−generateSeries = unsafeSetFunctionN
120−
121−{- | @generateSeries (start :* stop *: step)@
122−
123−Generate a series of values, from @start@ to @stop@ with a step size of @step@
124−-}
125−generateSeriesStep
126− :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
127− => SetFunctionN "generate_series" '[null ty, null ty, null ty]
128− '["generate_series" ::: null ty] -- ^ set returning function
129−generateSeriesStep = unsafeSetFunctionN
130−
131−{- | @generateSeries (start :* stop *: step)@
132−
133−Generate a series of values, from @start@ to @stop@ with a step size of @step@
134−-}
135−generateSeriesTimestamp
136− :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]
137− => SetFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]
138− '["generate_series" ::: null ty] -- ^ set returning function
139−generateSeriesTimestamp = unsafeSetFunctionN
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hsdeleted−85
@@ -1,85 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Sort
3−Description: Sort expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Sort expressions
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , GADTs
14− , LambdaCase
15− , OverloadedStrings
16− , StandaloneDeriving
17−#-}
18−
19−module Squeal.PostgreSQL.Expression.Sort
20− ( SortExpression (..)
21− , OrderBy (..)
22− ) where
23−
24−import Squeal.PostgreSQL.Expression
25−import Squeal.PostgreSQL.Render
26−import Squeal.PostgreSQL.Schema
27−
28−-- | `SortExpression`s are used by `orderBy` to optionally sort the results
29−-- of a `Squeal.PostgreSQL.Query.Query`. `Asc` or `Desc`
30−-- set the sort direction of a `NotNull` result
31−-- column to ascending or descending. Ascending order puts smaller values
32−-- first, where "smaller" is defined in terms of the
33−-- `Squeal.PostgreSQL.Expression.Comparison..<` operator. Similarly,
34−-- descending order is determined with the
35−-- `Squeal.PostgreSQL.Expression.Comparison..>` operator. `AscNullsFirst`,
36−-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to
37−-- determine whether nulls appear before or after non-null values in the sort
38−-- ordering of a `Null` result column.
39−data SortExpression outer commons grp schemas params from where
40− Asc
41− :: Expression outer commons grp schemas params from ('NotNull ty)
42− -> SortExpression outer commons grp schemas params from
43− Desc
44− :: Expression outer commons grp schemas params from ('NotNull ty)
45− -> SortExpression outer commons grp schemas params from
46− AscNullsFirst
47− :: Expression outer commons grp schemas params from ('Null ty)
48− -> SortExpression outer commons grp schemas params from
49− AscNullsLast
50− :: Expression outer commons grp schemas params from ('Null ty)
51− -> SortExpression outer commons grp schemas params from
52− DescNullsFirst
53− :: Expression outer commons grp schemas params from ('Null ty)
54− -> SortExpression outer commons grp schemas params from
55− DescNullsLast
56− :: Expression outer commons grp schemas params from ('Null ty)
57− -> SortExpression outer commons grp schemas params from
58−deriving instance Show (SortExpression outer commons grp schemas params from)
59−instance RenderSQL (SortExpression outer commons grp schemas params from) where
60− renderSQL = \case
61− Asc expression -> renderSQL expression <+> "ASC"
62− Desc expression -> renderSQL expression <+> "DESC"
63− AscNullsFirst expression -> renderSQL expression
64− <+> "ASC NULLS FIRST"
65− DescNullsFirst expression -> renderSQL expression
66− <+> "DESC NULLS FIRST"
67− AscNullsLast expression -> renderSQL expression <+> "ASC NULLS LAST"
68− DescNullsLast expression -> renderSQL expression <+> "DESC NULLS LAST"
69−
70−{- |
71−The `orderBy` clause causes the result rows of a `Squeal.PostgreSQL.Query.TableExpression`
72−to be sorted according to the specified `SortExpression`(s).
73−If two rows are equal according to the leftmost expression,
74−they are compared according to the next expression and so on.
75−If they are equal according to all specified expressions,
76−they are returned in an implementation-dependent order.
77−
78−You can also control the order in which rows are processed by window functions
79−using `orderBy` within `Squeal.PostgreSQL.Query.Over`.
80−-}
81−class OrderBy expr where
82− orderBy
83− :: [SortExpression outer commons grp schemas params from]
84− -> expr outer commons grp schemas params from
85− -> expr outer commons grp schemas params from
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hsdeleted−120
@@ -1,120 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Subquery
3−Description: Subquery expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Subquery expressions
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , RankNTypes
15− , TypeOperators
16−#-}
17−
18−module Squeal.PostgreSQL.Expression.Subquery
19− ( exists
20− , in_
21− , notIn
22− , subAll
23− , subAny
24− ) where
25−
26−import Squeal.PostgreSQL.Alias
27−import Squeal.PostgreSQL.Expression
28−import Squeal.PostgreSQL.Expression.Logic
29−import Squeal.PostgreSQL.List
30−import Squeal.PostgreSQL.Query
31−import Squeal.PostgreSQL.Render
32−import Squeal.PostgreSQL.Schema
33−
34−-- $setup
35−-- >>> import Squeal.PostgreSQL
36−
37−{- |
38−The argument of `exists` is an arbitrary subquery. The subquery is evaluated
39−to determine whether it returns any rows. If it returns at least one row,
40−the result of `exists` is `true`; if the subquery returns no rows,
41−the result of `exists` is `false`.
42−
43−The subquery can refer to variables from the surrounding query,
44−which will act as constants during any one evaluation of the subquery.
45−
46−The subquery will generally only be executed long enough to determine whether
47−at least one row is returned, not all the way to completion.
48−-}
49−exists
50− :: Query (Join outer from) commons schemas params row
51− -> Condition outer commons grp schemas params from
52−exists query = UnsafeExpression $ "EXISTS" <+> parenthesized (renderSQL query)
53−
54−{- |
55−The right-hand side is a parenthesized subquery, which must return
56−exactly one column. The left-hand expression is evaluated and compared to each
57−row of the subquery result using the given `Operator`,
58−which must yield a Boolean result. The result of `subAll` is `true`
59−if all rows yield true (including the case where the subquery returns no rows).
60−The result is `false` if any `false` result is found.
61−The result is `Squeal.PostgreSQL.Expression.Null.null_` if
62− no comparison with a subquery row returns `false`,
63−and at least one comparison returns `Squeal.PostgreSQL.Expression.Null.null_`.
64−
65−>>> printSQL $ subAll true (.==) (values_ (true `as` #foo))
66−(TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo")))
67−-}
68−subAll
69− :: Expression outer commons grp schemas params from ty1 -- ^ expression
70− -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator
71− -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery
72− -> Condition outer commons grp schemas params from
73−subAll expr (?) qry = expr ?
74− (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL qry))
75−
76−{- |
77−The right-hand side is a parenthesized subquery, which must return exactly one column.
78−The left-hand expression is evaluated and compared to each row of the subquery result
79−using the given `Operator`, which must yield a Boolean result. The result of `subAny` is `true`
80−if any `true` result is obtained. The result is `false` if no true result is found
81−(including the case where the subquery returns no rows).
82−
83−>>> printSQL $ subAny "foo" like (values_ ("foobar" `as` #foo))
84−(E'foo' LIKE ANY (SELECT * FROM (VALUES (E'foobar')) AS t ("foo")))
85−-}
86−subAny
87− :: Expression outer commons grp schemas params from ty1 -- ^ expression
88− -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator
89− -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery
90− -> Condition outer commons grp schemas params from
91−subAny expr (?) qry = expr ?
92− (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL qry))
93−
94−{- |
95−The result is `true` if the left-hand expression's result is equal
96−to any of the right-hand expressions.
97−
98−>>> printSQL $ true `in_` [true, false, null_]
99−TRUE IN (TRUE, FALSE, NULL)
100−-}
101−in_
102− :: Expression outer commons grp schemas params from ty -- ^ expression
103− -> [Expression outer commons grp schemas params from ty]
104− -> Condition outer commons grp schemas params from
105−expr `in_` exprs = UnsafeExpression $ renderSQL expr <+> "IN"
106− <+> parenthesized (commaSeparated (renderSQL <$> exprs))
107−
108−{- |
109−The result is `true` if the left-hand expression's result is not equal
110−to any of the right-hand expressions.
111−
112−>>> printSQL $ true `notIn` [false, null_]
113−TRUE NOT IN (FALSE, NULL)
114−-}
115−notIn
116− :: Expression outer commons grp schemas params from ty -- ^ expression
117− -> [Expression outer commons grp schemas params from ty]
118− -> Condition outer commons grp schemas params from
119−expr `notIn` exprs = UnsafeExpression $ renderSQL expr <+> "NOT IN"
120− <+> parenthesized (commaSeparated (renderSQL <$> exprs))
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hsdeleted−64
@@ -1,64 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Text
3−Description: Text expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−String functions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , TypeOperators
15−#-}
16−
17−module Squeal.PostgreSQL.Expression.Text
18− ( lower
19− , upper
20− , charLength
21− , like
22− , ilike
23− ) where
24−
25−import Squeal.PostgreSQL.Expression
26−import Squeal.PostgreSQL.Schema
27−
28−-- $setup
29−-- >>> import Squeal.PostgreSQL
30−
31−-- | >>> printSQL $ lower "ARRRGGG"
32−-- lower(E'ARRRGGG')
33−lower :: null 'PGtext --> null 'PGtext
34−lower = unsafeFunction "lower"
35−
36−-- | >>> printSQL $ upper "eeee"
37−-- upper(E'eeee')
38−upper :: null 'PGtext --> null 'PGtext
39−upper = unsafeFunction "upper"
40−
41−-- | >>> printSQL $ charLength "four"
42−-- char_length(E'four')
43−charLength :: null 'PGtext --> null 'PGint4
44−charLength = unsafeFunction "char_length"
45−
46−-- | The `like` expression returns true if the @string@ matches
47−-- the supplied @pattern@. If @pattern@ does not contain percent signs
48−-- or underscores, then the pattern only represents the string itself;
49−-- in that case `like` acts like the equals operator. An underscore (_)
50−-- in pattern stands for (matches) any single character; a percent sign (%)
51−-- matches any sequence of zero or more characters.
52−--
53−-- >>> printSQL $ "abc" `like` "a%"
54−-- (E'abc' LIKE E'a%')
55−like :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)
56−like = unsafeBinaryOp "LIKE"
57−
58−-- | The key word ILIKE can be used instead of LIKE to make the
59−-- match case-insensitive according to the active locale.
60−--
61−-- >>> printSQL $ "abc" `ilike` "a%"
62−-- (E'abc' ILIKE E'a%')
63−ilike :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)
64−ilike = unsafeBinaryOp "ILIKE"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hsdeleted−157
@@ -1,157 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.TextSearch
3−Description: Text search expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Text search functions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , OverloadedStrings
14− , TypeOperators
15−#-}
16−
17−module Squeal.PostgreSQL.Expression.TextSearch
18− ( (@@)
19− , (.&)
20− , (.|)
21− , (.!)
22− , (<->)
23− , arrayToTSvector
24− , tsvectorLength
25− , numnode
26− , plainToTSquery
27− , phraseToTSquery
28− , websearchToTSquery
29− , queryTree
30− , toTSquery
31− , toTSvector
32− , setWeight
33− , strip
34− , jsonToTSvector
35− , jsonbToTSvector
36− , tsDelete
37− , tsFilter
38− , tsHeadline
39− ) where
40−
41−import Squeal.PostgreSQL.Expression
42−import Squeal.PostgreSQL.List
43−import Squeal.PostgreSQL.Schema
44−
45−-- | `Squeal.PostgreSQL.Expression.Type.tsvector` matches tsquery ?
46−(@@) :: Operator (null 'PGtsvector) (null 'PGtsquery) ('Null 'PGbool)
47−(@@) = unsafeBinaryOp "@@"
48−
49−-- | AND `Squeal.PostgreSQL.Expression.Type.tsquery`s together
50−(.&) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
51−(.&) = unsafeBinaryOp "&&"
52−
53−-- | OR `Squeal.PostgreSQL.Expression.Type.tsquery`s together
54−(.|) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
55−(.|) = unsafeBinaryOp "||"
56−
57−-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`
58−(.!) :: null 'PGtsquery --> null 'PGtsquery
59−(.!) = unsafeLeftOp "!!"
60−
61−-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by
62−-- `Squeal.PostgreSQL.Expression.Type.tsquery`
63−(<->) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
64−(<->) = unsafeBinaryOp "<->"
65−
66−-- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector`
67−arrayToTSvector
68− :: null ('PGvararray ('NotNull 'PGtext))
69− --> null 'PGtsvector
70−arrayToTSvector = unsafeFunction "array_to_tsvector"
71−
72−-- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`
73−tsvectorLength :: null 'PGtsvector --> null 'PGint4
74−tsvectorLength = unsafeFunction "length"
75−
76−-- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`
77−numnode :: null 'PGtsquery --> null 'PGint4
78−numnode = unsafeFunction "numnode"
79−
80−-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation
81−plainToTSquery :: null 'PGtext --> null 'PGtsquery
82−plainToTSquery = unsafeFunction "plainto_tsquery"
83−
84−-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase,
85−-- ignoring punctuation
86−phraseToTSquery :: null 'PGtext --> null 'PGtsquery
87−phraseToTSquery = unsafeFunction "phraseto_tsquery"
88−
89−-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query
90−websearchToTSquery :: null 'PGtext --> null 'PGtsquery
91−websearchToTSquery = unsafeFunction "websearch_to_tsquery"
92−
93−-- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`
94−queryTree :: null 'PGtsquery --> null 'PGtext
95−queryTree = unsafeFunction "query_tree"
96−
97−-- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`
98−toTSquery :: null 'PGtext --> null 'PGtsquery
99−toTSquery = unsafeFunction "to_tsquery"
100−
101−-- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector`
102−toTSvector
103− :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
104− => null ty --> null 'PGtsvector
105−toTSvector = unsafeFunction "to_tsvector"
106−
107−-- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`
108−setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector
109−setWeight = unsafeFunctionN "set_weight"
110−
111−-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
112−strip :: null 'PGtsvector --> null 'PGtsvector
113−strip = unsafeFunction "strip"
114−
115−-- | @jsonToTSvector (document *: filter)@
116−-- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,
117−-- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.
118−-- filter is a `Squeal.PostgreSQL.Expression.Type.json` array, that enumerates what kind of elements
119−-- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.
120−-- Possible values for filter are "string" (to include all string values),
121−-- "numeric" (to include all numeric values in the string format),
122−-- "boolean" (to include all Boolean values in the string format "true"/"false"),
123−-- "key" (to include all keys) or "all" (to include all above).
124−-- These values can be combined together to include, e.g. all string and numeric values.
125−jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector
126−jsonToTSvector = unsafeFunctionN "json_to_tsvector"
127−
128−-- | @jsonbToTSvector (document *: filter)@
129−-- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,
130−-- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.
131−-- filter is a `Squeal.PostgreSQL.Expression.Type.jsonb` array, that enumerates what kind of elements
132−-- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.
133−-- Possible values for filter are "string" (to include all string values),
134−-- "numeric" (to include all numeric values in the string format),
135−-- "boolean" (to include all Boolean values in the string format "true"/"false"),
136−-- "key" (to include all keys) or "all" (to include all above).
137−-- These values can be combined together to include, e.g. all string and numeric values.
138−jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector
139−jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"
140−
141−-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`
142−tsDelete ::
143− '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]
144− ---> null 'PGtsvector
145−tsDelete = unsafeFunctionN "ts_delete"
146−
147−-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
148−tsFilter ::
149− '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]
150− ---> null 'PGtsvector
151−tsFilter = unsafeFunctionN "ts_filter"
152−
153−-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match
154−tsHeadline
155− :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
156− => '[null document, null 'PGtsquery] ---> null 'PGtext
157−tsHeadline = unsafeFunctionN "ts_headline"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hsdeleted−192
@@ -1,192 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Time
3−Description: Date/Time expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Date/Time functions and operators
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , DeriveGeneric
14− , FunctionalDependencies
15− , LambdaCase
16− , MultiParamTypeClasses
17− , OverloadedStrings
18− , PolyKinds
19− , RankNTypes
20− , TypeOperators
21−#-}
22−
23−module Squeal.PostgreSQL.Expression.Time
24− ( TimeOp (..)
25− , currentDate
26− , currentTime
27− , currentTimestamp
28− , localTime
29− , localTimestamp
30− , now
31− , makeDate
32− , makeTime
33− , makeTimestamp
34− , makeTimestamptz
35− , interval_
36− , TimeUnit (..)
37− ) where
38−
39−import Data.String
40−
41−import qualified GHC.Generics as GHC
42−import qualified Generics.SOP as SOP
43−
44−import Squeal.PostgreSQL.Expression
45−import Squeal.PostgreSQL.Render
46−import Squeal.PostgreSQL.Schema
47−
48−-- $setup
49−-- >>> import Squeal.PostgreSQL
50−
51−-- | >>> printSQL currentDate
52−-- CURRENT_DATE
53−currentDate :: Expr (null 'PGdate)
54−currentDate = UnsafeExpression "CURRENT_DATE"
55−
56−-- | >>> printSQL currentTime
57−-- CURRENT_TIME
58−currentTime :: Expr (null 'PGtimetz)
59−currentTime = UnsafeExpression "CURRENT_TIME"
60−
61−-- | >>> printSQL currentTimestamp
62−-- CURRENT_TIMESTAMP
63−currentTimestamp :: Expr (null 'PGtimestamptz)
64−currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"
65−
66−-- | >>> printSQL localTime
67−-- LOCALTIME
68−localTime :: Expr (null 'PGtime)
69−localTime = UnsafeExpression "LOCALTIME"
70−
71−-- | >>> printSQL localTimestamp
72−-- LOCALTIMESTAMP
73−localTimestamp :: Expr (null 'PGtimestamp)
74−localTimestamp = UnsafeExpression "LOCALTIMESTAMP"
75−
76−-- | Current date and time (equivalent to `currentTimestamp`)
77−--
78−-- >>> printSQL now
79−-- now()
80−now :: Expr (null 'PGtimestamptz)
81−now = UnsafeExpression "now()"
82−
83−{-|
84−Create date from year, month and day fields
85−
86−>>> printSQL (makeDate (1984 :* 7 *: 3))
87−make_date(1984, 7, 3)
88−-}
89−makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate
90−makeDate = unsafeFunctionN "make_date"
91−
92−{-|
93−Create time from hour, minute and seconds fields
94−
95−>>> printSQL (makeTime (8 :* 15 *: 23.5))
96−make_time(8, 15, 23.5)
97−-}
98−makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime
99−makeTime = unsafeFunctionN "make_time"
100−
101−{-|
102−Create timestamp from year, month, day, hour, minute and seconds fields
103−
104−>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
105−make_timestamp(2013, 7, 15, 8, 15, 23.5)
106−-}
107−makeTimestamp ::
108− '[ null 'PGint4, null 'PGint4, null 'PGint4
109− , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp
110−makeTimestamp = unsafeFunctionN "make_timestamp"
111−
112−{-|
113−Create timestamp with time zone from
114−year, month, day, hour, minute and seconds fields;
115−the current time zone is used
116−
117−>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
118−make_timestamptz(2013, 7, 15, 8, 15, 23.5)
119−-}
120−makeTimestamptz ::
121− '[ null 'PGint4, null 'PGint4, null 'PGint4
122− , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz
123−makeTimestamptz = unsafeFunctionN "make_timestamptz"
124−
125−{-|
126−Affine space operations on time types.
127−-}
128−class TimeOp time diff | time -> diff where
129− {-|
130− >>> printSQL (makeDate (1984 :* 7 *: 3) !+ 365)
131− (make_date(1984, 7, 3) + 365)
132− -}
133− (!+) :: Operator (null time) (null diff) (null time)
134− (!+) = unsafeBinaryOp "+"
135− {-|
136− >>> printSQL (365 +! makeDate (1984 :* 7 *: 3))
137− (365 + make_date(1984, 7, 3))
138− -}
139− (+!) :: Operator (null diff) (null time) (null time)
140− (+!) = unsafeBinaryOp "+"
141− {-|
142− >>> printSQL (makeDate (1984 :* 7 *: 3) !- 365)
143− (make_date(1984, 7, 3) - 365)
144− -}
145− (!-) :: Operator (null time) (null diff) (null time)
146− (!-) = unsafeBinaryOp "-"
147− {-|
148− >>> printSQL (makeDate (1984 :* 7 *: 3) !-! currentDate)
149− (make_date(1984, 7, 3) - CURRENT_DATE)
150− -}
151− (!-!) :: Operator (null time) (null time) (null diff)
152− (!-!) = unsafeBinaryOp "-"
153−instance TimeOp 'PGtimestamp 'PGinterval
154−instance TimeOp 'PGtimestamptz 'PGinterval
155−instance TimeOp 'PGtime 'PGinterval
156−instance TimeOp 'PGtimetz 'PGinterval
157−instance TimeOp 'PGinterval 'PGinterval
158−instance TimeOp 'PGdate 'PGint4
159−infixl 6 !+
160−infixl 6 +!
161−infixl 6 !-
162−infixl 6 !-!
163−
164−-- | A `TimeUnit` to use in `interval_` construction.
165−data TimeUnit
166− = Years | Months | Weeks | Days
167− | Hours | Minutes | Seconds
168− | Microseconds | Milliseconds
169− | Decades | Centuries | Millennia
170− deriving (Eq, Ord, Show, Read, Enum, GHC.Generic)
171−instance SOP.Generic TimeUnit
172−instance SOP.HasDatatypeInfo TimeUnit
173−instance RenderSQL TimeUnit where
174− renderSQL = \case
175− Years -> "years"
176− Months -> "months"
177− Weeks -> "weeks"
178− Days -> "days"
179− Hours -> "hours"
180− Minutes -> "minutes"
181− Seconds -> "seconds"
182− Microseconds -> "microseconds"
183− Milliseconds -> "milliseconds"
184− Decades -> "decades"
185− Centuries -> "centuries"
186− Millennia -> "millennia"
187−
188−-- | >>> printSQL $ interval_ 7 Days
189−-- (INTERVAL '7.0 days')
190−interval_ :: Double -> TimeUnit -> Expr (null 'PGinterval)
191−interval_ num unit = UnsafeExpression . parenthesized $ "INTERVAL" <+>
192− "'" <> fromString (show num) <+> renderSQL unit <> "'"
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hsdeleted−446
@@ -1,446 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression
3−Description: Type expressions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Type expressions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DataKinds
14− , DeriveGeneric
15− , FlexibleContexts
16− , FlexibleInstances
17− , GADTs
18− , GeneralizedNewtypeDeriving
19− , KindSignatures
20− , MultiParamTypeClasses
21− , OverloadedStrings
22− , RankNTypes
23− , ScopedTypeVariables
24− , TypeApplications
25− , TypeOperators
26− , UndecidableInstances
27−#-}
28−
29−module Squeal.PostgreSQL.Expression.Type
30− ( -- * type casting
31− cast
32− , astype
33− , inferredtype
34− -- * type expressions
35− , TypeExpression (..)
36− , typedef
37− , typetable
38− , typeview
39− , bool
40− , int2
41− , smallint
42− , int4
43− , int
44− , integer
45− , int8
46− , bigint
47− , numeric
48− , float4
49− , real
50− , float8
51− , doublePrecision
52− , money
53− , text
54− , char
55− , character
56− , varchar
57− , characterVarying
58− , bytea
59− , timestamp
60− , timestampWithTimeZone
61− , timestamptz
62− , date
63− , time
64− , timeWithTimeZone
65− , timetz
66− , interval
67− , uuid
68− , inet
69− , json
70− , jsonb
71− , vararray
72− , fixarray
73− , tsvector
74− , tsquery
75− , oid
76− , int4range
77− , int8range
78− , numrange
79− , tsrange
80− , tstzrange
81− , daterange
82− -- * column type definitions
83− , ColumnTypeExpression (..)
84− , nullable
85− , notNullable
86− , default_
87− , serial2
88− , smallserial
89− , serial4
90− , serial
91− , serial8
92− , bigserial
93− , hask
94− -- * type inference
95− , PGTyped (..)
96− , PGNullityTyped (..)
97− , FieldTyped (..)
98− ) where
99−
100−import Control.DeepSeq
101−import Data.ByteString
102−import Data.String
103−import GHC.TypeLits
104−
105−import qualified Data.ByteString as ByteString
106−import qualified GHC.Generics as GHC
107−import qualified Generics.SOP as SOP
108−
109−import Squeal.PostgreSQL.Alias
110−import Squeal.PostgreSQL.Expression
111−import Squeal.PostgreSQL.PG
112−import Squeal.PostgreSQL.Render
113−import Squeal.PostgreSQL.Schema
114−
115−-- $setup
116−-- >>> import Squeal.PostgreSQL
117−
118−-- When a `cast` is applied to an `Expression` of a known type, it
119−-- represents a run-time type conversion. The cast will succeed only if a
120−-- suitable type conversion operation has been defined.
121−--
122−-- | >>> printSQL $ true & cast int4
123−-- (TRUE :: int4)
124−cast
125− :: TypeExpression schemas ty1
126− -- ^ type to cast as
127− -> Expression outer commons grp schemas params from ty0
128− -- ^ value to convert
129− -> Expression outer commons grp schemas params from ty1
130−cast ty x = UnsafeExpression $ parenthesized $
131− renderSQL x <+> "::" <+> renderSQL ty
132−
133−-- | A safe version of `cast` which just matches a value with its type.
134−--
135−-- >>> printSQL (1 & astype int)
136−-- (1 :: int)
137−astype
138− :: TypeExpression schemas ty
139− -- ^ type to specify as
140− -> Expression outer commons grp schemas params from ty
141− -- ^ value
142− -> Expression outer commons grp schemas params from ty
143−astype = cast
144−
145−-- | `inferredtype` will add a type annotation to an `Expression`
146−-- which can be useful for fixing the storage type of a value.
147−--
148−-- >>> printSQL (inferredtype true)
149−-- (TRUE :: bool)
150−inferredtype
151− :: PGTyped schemas ty
152− => Expression outer common grp schemas params from ty
153− -- ^ value
154− -> Expression outer common grp schemas params from ty
155−inferredtype = astype pgtype
156−
157−{-----------------------------------------
158−type expressions
159−-----------------------------------------}
160−
161−-- | `TypeExpression`s are used in `cast`s and
162−-- `Squeal.PostgreSQL.Definition.createTable` commands.
163−newtype TypeExpression (schemas :: SchemasType) (ty :: NullityType)
164− = UnsafeTypeExpression { renderTypeExpression :: ByteString }
165− deriving (GHC.Generic,Show,Eq,Ord,NFData)
166−instance RenderSQL (TypeExpression schemas ty) where
167− renderSQL = renderTypeExpression
168−
169−-- | The enum or composite type in a `Typedef` can be expressed by its alias.
170−typedef
171− :: (Has sch schemas schema, Has td schema ('Typedef ty))
172− => QualifiedAlias sch td
173− -- ^ type alias
174− -> TypeExpression schemas (null ty)
175−typedef = UnsafeTypeExpression . renderSQL
176−
177−-- | The composite type corresponding to a `Table` definition can be expressed
178−-- by its alias.
179−typetable
180− :: (Has sch schemas schema, Has tab schema ('Table table))
181− => QualifiedAlias sch tab
182− -- ^ table alias
183− -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))
184−typetable = UnsafeTypeExpression . renderSQL
185−
186−-- | The composite type corresponding to a `View` definition can be expressed
187−-- by its alias.
188−typeview
189− :: (Has sch schemas schema, Has vw schema ('View view))
190− => QualifiedAlias sch vw
191− -- ^ view alias
192− -> TypeExpression schemas (null ('PGcomposite view))
193−typeview = UnsafeTypeExpression . renderSQL
194−
195−-- | logical Boolean (true/false)
196−bool :: TypeExpression schemas (null 'PGbool)
197−bool = UnsafeTypeExpression "bool"
198−-- | signed two-byte integer
199−int2, smallint :: TypeExpression schemas (null 'PGint2)
200−int2 = UnsafeTypeExpression "int2"
201−smallint = UnsafeTypeExpression "smallint"
202−-- | signed four-byte integer
203−int4, int, integer :: TypeExpression schemas (null 'PGint4)
204−int4 = UnsafeTypeExpression "int4"
205−int = UnsafeTypeExpression "int"
206−integer = UnsafeTypeExpression "integer"
207−-- | signed eight-byte integer
208−int8, bigint :: TypeExpression schemas (null 'PGint8)
209−int8 = UnsafeTypeExpression "int8"
210−bigint = UnsafeTypeExpression "bigint"
211−-- | arbitrary precision numeric type
212−numeric :: TypeExpression schemas (null 'PGnumeric)
213−numeric = UnsafeTypeExpression "numeric"
214−-- | single precision floating-point number (4 bytes)
215−float4, real :: TypeExpression schemas (null 'PGfloat4)
216−float4 = UnsafeTypeExpression "float4"
217−real = UnsafeTypeExpression "real"
218−-- | double precision floating-point number (8 bytes)
219−float8, doublePrecision :: TypeExpression schemas (null 'PGfloat8)
220−float8 = UnsafeTypeExpression "float8"
221−doublePrecision = UnsafeTypeExpression "double precision"
222−-- | currency amount
223−money :: TypeExpression schema (null 'PGmoney)
224−money = UnsafeTypeExpression "money"
225−-- | variable-length character string
226−text :: TypeExpression schemas (null 'PGtext)
227−text = UnsafeTypeExpression "text"
228−-- | fixed-length character string
229−char, character
230− :: forall n schemas null. (KnownNat n, 1 <= n)
231− => TypeExpression schemas (null ('PGchar n))
232−char = UnsafeTypeExpression $ "char(" <> renderNat @n <> ")"
233−character = UnsafeTypeExpression $ "character(" <> renderNat @n <> ")"
234−-- | variable-length character string
235−varchar, characterVarying
236− :: forall n schemas null. (KnownNat n, 1 <= n)
237− => TypeExpression schemas (null ('PGvarchar n))
238−varchar = UnsafeTypeExpression $ "varchar(" <> renderNat @n <> ")"
239−characterVarying = UnsafeTypeExpression $
240− "character varying(" <> renderNat @n <> ")"
241−-- | binary data ("byte array")
242−bytea :: TypeExpression schemas (null 'PGbytea)
243−bytea = UnsafeTypeExpression "bytea"
244−-- | date and time (no time zone)
245−timestamp :: TypeExpression schemas (null 'PGtimestamp)
246−timestamp = UnsafeTypeExpression "timestamp"
247−-- | date and time, including time zone
248−timestampWithTimeZone, timestamptz :: TypeExpression schemas (null 'PGtimestamptz)
249−timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
250−timestamptz = UnsafeTypeExpression "timestamptz"
251−-- | calendar date (year, month, day)
252−date :: TypeExpression schemas (null 'PGdate)
253−date = UnsafeTypeExpression "date"
254−-- | time of day (no time zone)
255−time :: TypeExpression schemas (null 'PGtime)
256−time = UnsafeTypeExpression "time"
257−-- | time of day, including time zone
258−timeWithTimeZone, timetz :: TypeExpression schemas (null 'PGtimetz)
259−timeWithTimeZone = UnsafeTypeExpression "time with time zone"
260−timetz = UnsafeTypeExpression "timetz"
261−-- | time span
262−interval :: TypeExpression schemas (null 'PGinterval)
263−interval = UnsafeTypeExpression "interval"
264−-- | universally unique identifier
265−uuid :: TypeExpression schemas (null 'PGuuid)
266−uuid = UnsafeTypeExpression "uuid"
267−-- | IPv4 or IPv6 host address
268−inet :: TypeExpression schemas (null 'PGinet)
269−inet = UnsafeTypeExpression "inet"
270−-- | textual JSON data
271−json :: TypeExpression schemas (null 'PGjson)
272−json = UnsafeTypeExpression "json"
273−-- | binary JSON data, decomposed
274−jsonb :: TypeExpression schemas (null 'PGjsonb)
275−jsonb = UnsafeTypeExpression "jsonb"
276−-- | variable length array
277−vararray
278− :: TypeExpression schemas pg
279− -> TypeExpression schemas (null ('PGvararray pg))
280−vararray ty = UnsafeTypeExpression $ renderSQL ty <> "[]"
281−-- | fixed length array
282−--
283−-- >>> renderSQL (fixarray @'[2] json)
284−-- "json[2]"
285−fixarray
286− :: forall dims schemas null pg. SOP.All KnownNat dims
287− => TypeExpression schemas pg
288− -> TypeExpression schemas (null ('PGfixarray dims pg))
289−fixarray ty = UnsafeTypeExpression $
290− renderSQL ty <> renderDims @dims
291− where
292− renderDims :: forall ns. SOP.All KnownNat ns => ByteString
293− renderDims =
294− ("[" <>)
295− . (<> "]")
296− . ByteString.intercalate "]["
297− . SOP.hcollapse
298− $ SOP.hcmap (SOP.Proxy @KnownNat)
299− (K . fromString . show . natVal)
300− (SOP.hpure SOP.Proxy :: SOP.NP SOP.Proxy ns)
301−-- | text search query
302−tsvector :: TypeExpression schemas (null 'PGtsvector)
303−tsvector = UnsafeTypeExpression "tsvector"
304−-- | text search document
305−tsquery :: TypeExpression schemas (null 'PGtsquery)
306−tsquery = UnsafeTypeExpression "tsquery"
307−-- | Object identifiers (OIDs) are used internally by PostgreSQL
308−-- as primary keys for various system tables.
309−oid :: TypeExpression schemas (null 'PGoid)
310−oid = UnsafeTypeExpression "oid"
311−-- | Range of integer
312−int4range :: TypeExpression schemas (null ('PGrange 'PGint4))
313−int4range = UnsafeTypeExpression "int4range"
314−-- | Range of bigint
315−int8range :: TypeExpression schemas (null ('PGrange 'PGint8))
316−int8range = UnsafeTypeExpression "int8range"
317−-- | Range of numeric
318−numrange :: TypeExpression schemas (null ('PGrange 'PGnumeric))
319−numrange = UnsafeTypeExpression "numrange"
320−-- | Range of timestamp without time zone
321−tsrange :: TypeExpression schemas (null ('PGrange 'PGtimestamp))
322−tsrange = UnsafeTypeExpression "tsrange"
323−-- | Range of timestamp with time zone
324−tstzrange :: TypeExpression schemas (null ('PGrange 'PGtimestamptz))
325−tstzrange = UnsafeTypeExpression "tstzrange"
326−-- | Range of date
327−daterange :: TypeExpression schemas (null ('PGrange 'PGdate))
328−daterange = UnsafeTypeExpression "daterange"
329−
330−-- | `pgtype` is a demoted version of a `PGType`
331−class PGTyped schemas (ty :: NullityType) where
332− pgtype :: TypeExpression schemas ty
333−instance PGTyped schemas (null 'PGbool) where pgtype = bool
334−instance PGTyped schemas (null 'PGint2) where pgtype = int2
335−instance PGTyped schemas (null 'PGint4) where pgtype = int4
336−instance PGTyped schemas (null 'PGint8) where pgtype = int8
337−instance PGTyped schemas (null 'PGnumeric) where pgtype = numeric
338−instance PGTyped schemas (null 'PGfloat4) where pgtype = float4
339−instance PGTyped schemas (null 'PGfloat8) where pgtype = float8
340−instance PGTyped schemas (null 'PGmoney) where pgtype = money
341−instance PGTyped schemas (null 'PGtext) where pgtype = text
342−instance (KnownNat n, 1 <= n)
343− => PGTyped schemas (null ('PGchar n)) where pgtype = char @n
344−instance (KnownNat n, 1 <= n)
345− => PGTyped schemas (null ('PGvarchar n)) where pgtype = varchar @n
346−instance PGTyped schemas (null 'PGbytea) where pgtype = bytea
347−instance PGTyped schemas (null 'PGtimestamp) where pgtype = timestamp
348−instance PGTyped schemas (null 'PGtimestamptz) where pgtype = timestampWithTimeZone
349−instance PGTyped schemas (null 'PGdate) where pgtype = date
350−instance PGTyped schemas (null 'PGtime) where pgtype = time
351−instance PGTyped schemas (null 'PGtimetz) where pgtype = timeWithTimeZone
352−instance PGTyped schemas (null 'PGinterval) where pgtype = interval
353−instance PGTyped schemas (null 'PGuuid) where pgtype = uuid
354−instance PGTyped schemas (null 'PGjson) where pgtype = json
355−instance PGTyped schemas (null 'PGjsonb) where pgtype = jsonb
356−instance PGTyped schemas ty
357− => PGTyped schemas (null ('PGvararray ty)) where
358− pgtype = vararray (pgtype @schemas @ty)
359−instance (SOP.All KnownNat dims, PGTyped schemas ty)
360− => PGTyped schemas (null ('PGfixarray dims ty)) where
361− pgtype = fixarray @dims (pgtype @schemas @ty)
362−instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector
363−instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery
364−instance PGTyped schemas (null 'PGoid) where pgtype = oid
365−instance PGTyped schemas (null ('PGrange 'PGint4)) where pgtype = int4range
366−instance PGTyped schemas (null ('PGrange 'PGint8)) where pgtype = int8range
367−instance PGTyped schemas (null ('PGrange 'PGnumeric)) where pgtype = numrange
368−instance PGTyped schemas (null ('PGrange 'PGtimestamp)) where pgtype = tsrange
369−instance PGTyped schemas (null ('PGrange 'PGtimestamptz)) where pgtype = tstzrange
370−instance PGTyped schemas (null ('PGrange 'PGdate)) where pgtype = daterange
371−
372−-- | Lift `PGTyped` to a field
373−class FieldTyped schemas ty where
374− fieldtype :: Aliased (TypeExpression schemas) ty
375−instance (KnownSymbol alias, PGTyped schemas ty)
376− => FieldTyped schemas (alias ::: ty) where
377− fieldtype = pgtype `As` Alias
378−
379−-- | `ColumnTypeExpression`s are used in `createTable` commands.
380−newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)
381− = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }
382− deriving (GHC.Generic,Show,Eq,Ord,NFData)
383−instance RenderSQL (ColumnTypeExpression schemas ty) where
384− renderSQL = renderColumnTypeExpression
385−
386−-- | used in `createTable` commands as a column constraint to note that
387−-- @NULL@ may be present in a column
388−nullable
389− :: TypeExpression schemas (nullity ty)
390− -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)
391−nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"
392−
393−-- | used in `createTable` commands as a column constraint to ensure
394−-- @NULL@ is not present in a column
395−notNullable
396− :: TypeExpression schemas (nullity ty)
397− -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)
398−notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"
399−
400−-- | used in `createTable` commands as a column constraint to give a default
401−default_
402− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty
403− -> ColumnTypeExpression schemas ('NoDef :=> ty)
404− -> ColumnTypeExpression schemas ('Def :=> ty)
405−default_ x ty = UnsafeColumnTypeExpression $
406− renderSQL ty <+> "DEFAULT" <+> renderExpression x
407−
408−-- | not a true type, but merely a notational convenience for creating
409−-- unique identifier columns with type `PGint2`
410−serial2, smallserial
411− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)
412−serial2 = UnsafeColumnTypeExpression "serial2"
413−smallserial = UnsafeColumnTypeExpression "smallserial"
414−-- | not a true type, but merely a notational convenience for creating
415−-- unique identifier columns with type `PGint4`
416−serial4, serial
417− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)
418−serial4 = UnsafeColumnTypeExpression "serial4"
419−serial = UnsafeColumnTypeExpression "serial"
420−-- | not a true type, but merely a notational convenience for creating
421−-- unique identifier columns with type `PGint8`
422−serial8, bigserial
423− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)
424−serial8 = UnsafeColumnTypeExpression "serial8"
425−bigserial = UnsafeColumnTypeExpression "bigserial"
426−
427−-- | Like @PGTyped@ but also accounts for nullity.
428−class PGNullityTyped schemas (nullty :: NullityType) where
429− pgNullityType :: ColumnTypeExpression schemas ('NoDef :=> nullty)
430−
431−instance PGTyped schemas ('Null ty) => PGNullityTyped schemas ('Null ty) where
432− pgNullityType = nullable (pgtype @_ @('Null ty))
433−
434−instance PGTyped schemas ('NotNull ty) => PGNullityTyped schemas ('NotNull ty) where
435− pgNullityType = notNullable (pgtype @_ @('NotNull ty))
436−
437−-- | Allow you to specify pg column types in relation to haskell types.
438−-- >>> printSQL $ hask @(Maybe String)
439−-- text NULL
440−--
441−-- >>> printSQL $ hask @Double
442−-- float8 NOT NULL
443−hask
444− :: forall hask schemas. PGNullityTyped schemas (NullPG hask)
445− => ColumnTypeExpression schemas ('NoDef :=> NullPG hask)
446−hask = pgNullityType
squeal-postgresql/src/Squeal/PostgreSQL/Expression/Window.hsdeleted−284
@@ -1,284 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Expression.Window
3−Description: Window functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Window functions and definitions
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , DeriveGeneric
14− , FlexibleContexts
15− , FlexibleInstances
16− , GADTs
17− , GeneralizedNewtypeDeriving
18− , LambdaCase
19− , MultiParamTypeClasses
20− , OverloadedStrings
21− , RankNTypes
22− , KindSignatures
23−#-}
24−
25−module Squeal.PostgreSQL.Expression.Window
26− ( -- * functions
27− partitionBy
28− , rank
29− , rowNumber
30− , denseRank
31− , percentRank
32− , cumeDist
33− , ntile
34− , lag
35− , lead
36− , firstValue
37− , lastValue
38− , nthValue
39− , unsafeWindowFunction1
40− , unsafeWindowFunctionN
41− -- * types
42− , WindowFunction (..)
43− , WindowDefinition (..)
44− , WinFun0
45− , WinFun1
46− , WinFunN
47− ) where
48−
49−import Control.DeepSeq
50−import Data.ByteString
51−
52−import qualified GHC.Generics as GHC
53−import qualified Generics.SOP as SOP
54−
55−import Squeal.PostgreSQL.Alias
56−import Squeal.PostgreSQL.Expression
57−import Squeal.PostgreSQL.Expression.Aggregate
58−import Squeal.PostgreSQL.Expression.Sort
59−import Squeal.PostgreSQL.List
60−import Squeal.PostgreSQL.Render
61−import Squeal.PostgreSQL.Schema
62−
63−instance Aggregate
64− (Expression outer commons grp schemas params from)
65− (NP (Expression outer commons grp schemas params from))
66− (WindowFunction outer commons grp schemas params from) where
67− countStar = UnsafeWindowFunction "count(*)"
68− count = unsafeWindowFunction1 "count"
69− sum_ = unsafeWindowFunction1 "sum"
70− arrayAgg = unsafeWindowFunction1 "array_agg"
71− jsonAgg = unsafeWindowFunction1 "json_agg"
72− jsonbAgg = unsafeWindowFunction1 "jsonb_agg"
73− bitAnd = unsafeWindowFunction1 "bit_and"
74− bitOr = unsafeWindowFunction1 "bit_or"
75− boolAnd = unsafeWindowFunction1 "bool_and"
76− boolOr = unsafeWindowFunction1 "bool_or"
77− every = unsafeWindowFunction1 "every"
78− max_ = unsafeWindowFunction1 "max"
79− min_ = unsafeWindowFunction1 "min"
80− avg = unsafeWindowFunction1 "avg"
81− corr = unsafeWindowFunctionN "corr"
82− covarPop = unsafeWindowFunctionN "covar_pop"
83− covarSamp = unsafeWindowFunctionN "covar_samp"
84− regrAvgX = unsafeWindowFunctionN "regr_avgx"
85− regrAvgY = unsafeWindowFunctionN "regr_avgy"
86− regrCount = unsafeWindowFunctionN "regr_count"
87− regrIntercept = unsafeWindowFunctionN "regr_intercept"
88− regrR2 = unsafeWindowFunctionN "regr_r2"
89− regrSlope = unsafeWindowFunctionN "regr_slope"
90− regrSxx = unsafeWindowFunctionN "regr_sxx"
91− regrSxy = unsafeWindowFunctionN "regr_sxy"
92− regrSyy = unsafeWindowFunctionN "regr_syy"
93− stddev = unsafeWindowFunction1 "stddev"
94− stddevPop = unsafeWindowFunction1 "stddev_pop"
95− stddevSamp = unsafeWindowFunction1 "stddev_samp"
96− variance = unsafeWindowFunction1 "variance"
97− varPop = unsafeWindowFunction1 "var_pop"
98− varSamp = unsafeWindowFunction1 "var_samp"
99−
100−-- | A `WindowDefinition` is a set of table rows that are somehow related
101−-- to the current row
102−data WindowDefinition outer commons grp schemas params from where
103− WindowDefinition
104− :: SOP.SListI bys
105− => NP (Expression outer commons grp schemas params from) bys
106− -- ^ `partitionBy` clause
107− -> [SortExpression outer commons grp schemas params from]
108− -- ^ `Squeal.PostgreSQL.Expression.Sort.orderBy` clause
109− -> WindowDefinition outer commons grp schemas params from
110−
111−instance OrderBy WindowDefinition where
112− orderBy sortsR (WindowDefinition parts sortsL)
113− = WindowDefinition parts (sortsL ++ sortsR)
114−
115−instance RenderSQL (WindowDefinition outer commons schemas from grp params) where
116− renderSQL (WindowDefinition part ord) =
117− renderPartitionByClause part <> renderOrderByClause ord
118− where
119− renderPartitionByClause = \case
120− Nil -> ""
121− parts -> "PARTITION" <+> "BY" <+> renderCommaSeparated renderExpression parts
122− renderOrderByClause = \case
123− [] -> ""
124− srts -> " ORDER" <+> "BY"
125− <+> commaSeparated (renderSQL <$> srts)
126−
127−{- |
128−The `partitionBy` clause within `Squeal.PostgreSQL.Query.Over` divides the rows into groups,
129−or partitions, that share the same values of the `partitionBy` `Expression`(s).
130−For each row, the window function is computed across the rows that fall into
131−the same partition as the current row.
132−-}
133−partitionBy
134− :: SOP.SListI bys
135− => NP (Expression outer commons grp schemas params from) bys -- ^ partitions
136− -> WindowDefinition outer commons grp schemas params from
137−partitionBy bys = WindowDefinition bys []
138−
139−{- |
140−A window function performs a calculation across a set of table rows
141−that are somehow related to the current row. This is comparable to the type
142−of calculation that can be done with an aggregate function.
143−However, window functions do not cause rows to become grouped into a single
144−output row like non-window aggregate calls would.
145−Instead, the rows retain their separate identities.
146−Behind the scenes, the window function is able to access more than
147−just the current row of the query result.
148−-}
149−newtype WindowFunction
150− (outer :: FromType)
151− (commons :: FromType)
152− (grp :: Grouping)
153− (schemas :: SchemasType)
154− (params :: [NullityType])
155− (from :: FromType)
156− (ty :: NullityType)
157− = UnsafeWindowFunction { renderWindowFunction :: ByteString }
158− deriving (GHC.Generic,Show,Eq,Ord,NFData)
159−
160−instance RenderSQL (WindowFunction outer commons grp schemas params from ty) where
161− renderSQL = renderWindowFunction
162−
163−{- |
164−A @RankNType@ for window functions with no arguments.
165−-}
166−type WinFun0 x
167− = forall outer commons grp schemas params from
168− . WindowFunction outer commons grp schemas params from x
169− -- ^ cannot reference aliases
170−
171−{- |
172−A @RankNType@ for window functions with 1 argument.
173−-}
174−type WinFun1 x y
175− = forall outer commons grp schemas params from
176− . Expression outer commons grp schemas params from x
177− -- ^ input
178− -> WindowFunction outer commons grp schemas params from y
179− -- ^ output
180−
181−{- | A @RankNType@ for window functions with a fixed-length
182−list of heterogeneous arguments.
183−Use the `*:` operator to end your argument lists.
184−-}
185−type WinFunN xs y
186− = forall outer commons grp schemas params from
187− . NP (Expression outer commons grp schemas params from) xs
188− -- ^ inputs
189− -> WindowFunction outer commons grp schemas params from y
190− -- ^ output
191−
192−-- | escape hatch for defining window functions
193−unsafeWindowFunction1 :: ByteString -> WinFun1 x y
194−unsafeWindowFunction1 fun x
195− = UnsafeWindowFunction $ fun <> parenthesized (renderSQL x)
196−
197−-- | escape hatch for defining multi-argument window functions
198−unsafeWindowFunctionN :: SOP.SListI xs => ByteString -> WinFunN xs y
199−unsafeWindowFunctionN fun xs = UnsafeWindowFunction $ fun <>
200− parenthesized (renderCommaSeparated renderSQL xs)
201−
202−{- | rank of the current row with gaps; same as `rowNumber` of its first peer
203−
204−>>> printSQL rank
205−rank()
206−-}
207−rank :: WinFun0 ('NotNull 'PGint8)
208−rank = UnsafeWindowFunction "rank()"
209−
210−{- | number of the current row within its partition, counting from 1
211−
212−>>> printSQL rowNumber
213−row_number()
214−-}
215−rowNumber :: WinFun0 ('NotNull 'PGint8)
216−rowNumber = UnsafeWindowFunction "row_number()"
217−
218−{- | rank of the current row without gaps; this function counts peer groups
219−
220−>>> printSQL denseRank
221−dense_rank()
222−-}
223−denseRank :: WinFun0 ('NotNull 'PGint8)
224−denseRank = UnsafeWindowFunction "dense_rank()"
225−
226−{- | relative rank of the current row: (rank - 1) / (total partition rows - 1)
227−
228−>>> printSQL percentRank
229−percent_rank()
230−-}
231−percentRank :: WinFun0 ('NotNull 'PGfloat8)
232−percentRank = UnsafeWindowFunction "percent_rank()"
233−
234−{- | cumulative distribution: (number of partition rows
235−preceding or peer with current row) / total partition rows
236−
237−>>> printSQL cumeDist
238−cume_dist()
239−-}
240−cumeDist :: WinFun0 ('NotNull 'PGfloat8)
241−cumeDist = UnsafeWindowFunction "cume_dist()"
242−
243−{- | integer ranging from 1 to the argument value,
244−dividing the partition as equally as possible
245−
246−>>> printSQL $ ntile 5
247−ntile(5)
248−-}
249−ntile :: WinFun1 ('NotNull 'PGint4) ('NotNull 'PGint4)
250−ntile = unsafeWindowFunction1 "ntile"
251−
252−{- | returns value evaluated at the row that is offset rows before the current
253−row within the partition; if there is no such row, instead return default
254−(which must be of the same type as value). Both offset and default are
255−evaluated with respect to the current row.
256−-}
257−lag :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty
258−lag = unsafeWindowFunctionN "lag"
259−
260−{- | returns value evaluated at the row that is offset rows after the current
261−row within the partition; if there is no such row, instead return default
262−(which must be of the same type as value). Both offset and default are
263−evaluated with respect to the current row.
264−-}
265−lead :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty
266−lead = unsafeWindowFunctionN "lead"
267−
268−{- | returns value evaluated at the row that is the
269−first row of the window frame
270−-}
271−firstValue :: WinFun1 ty ty
272−firstValue = unsafeWindowFunction1 "first_value"
273−
274−{- | returns value evaluated at the row that is the
275−last row of the window frame
276−-}
277−lastValue :: WinFun1 ty ty
278−lastValue = unsafeWindowFunction1 "last_value"
279−
280−{- | returns value evaluated at the row that is the nth
281−row of the window frame (counting from 1); null if no such row
282−-}
283−nthValue :: WinFunN '[null ty, 'NotNull 'PGint4] ('Null ty)
284−nthValue = unsafeWindowFunctionN "nth_value"
squeal-postgresql/src/Squeal/PostgreSQL/List.hsdeleted−112
@@ -1,112 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.List
3−Description: List related types and functions
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Haskell singly-linked lists are very powerful. This module
9−provides functionality for type-level lists, heterogeneous
10−lists and type aligned lists.
11−-}
12−
13−{-# LANGUAGE
14− DataKinds
15− , FlexibleContexts
16− , GADTs
17− , LambdaCase
18− , MultiParamTypeClasses
19− , OverloadedStrings
20− , PolyKinds
21− , QuantifiedConstraints
22− , RankNTypes
23− , ScopedTypeVariables
24− , TypeApplications
25− , TypeFamilies
26− , TypeOperators
27− , UndecidableInstances
28−#-}
29−
30−module Squeal.PostgreSQL.List
31− ( SOP.NP (..)
32− , (*:)
33− , Join
34− , disjoin
35− , Additional (..)
36− , Path (..)
37− , CFunctor (..)
38− , CFoldable (..)
39− , CFree (..)
40− , Elem
41− , In
42− , Length
43− ) where
44−
45−import Control.Category.Free
46−import Data.Function ((&))
47−import Data.Kind
48−import Data.Type.Bool
49−import GHC.TypeLits
50−
51−import Generics.SOP as SOP
52−
53−-- | `Join` is simply promoted `++` and is used in @JOIN@s in
54−-- `Squeal.PostgreSQL.Query.FromClause`s.
55−type family Join xs ys where
56− Join '[] ys = ys
57− Join (x ': xs) ys = x ': Join xs ys
58−
59−-- | `disjoin` is a utility function for splitting an `NP` list into pieces.
60−disjoin
61− :: forall xs ys expr. SListI xs
62− => NP expr (Join xs ys)
63− -> (NP expr xs, NP expr ys)
64−disjoin = case sList @xs of
65− SNil -> \ys -> (Nil, ys)
66− SCons -> \(x :* xsys) ->
67− case disjoin xsys of (xs,ys) -> (x :* xs, ys)
68−
69−-- | The `Additional` class is for appending
70−-- type-level list parameterized constructors such as `NP`,
71−-- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`.
72−class Additional expr where
73− also :: expr ys -> expr xs -> expr (Join xs ys)
74−instance Additional (NP expr) where
75− also ys = \case
76− Nil -> ys
77− x :* xs -> x :* (xs & also ys)
78−
79−-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.
80−(*:) :: f x -> f y -> NP f '[x,y]
81−x *: y = x :* y :* Nil
82−infixl 9 *:
83−
84−-- | @Elem@ is a promoted `Data.List.elem`.
85−type family Elem x xs where
86− Elem x '[] = 'False
87− Elem x (x ': _) = 'True
88− Elem x (_ ': x ': _) = 'True
89− Elem x (_ ': _ ': x ': _) = 'True
90− Elem x (_ ': _ ': _ ': x ': _) = 'True
91− Elem x (_ ': _ ': _ ': _ ': x ': _) = 'True
92− Elem x (_ ': _ ': _ ': _ ': _ ': x ': _) = 'True
93− Elem x (_ ': xs) = Elem x xs
94−
95−-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
96−type family In x xs :: Constraint where
97− In x xs = If (Elem x xs) (() :: Constraint)
98− (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs))
99−
100−{- | Calculate the `Length` of a type level list
101−
102−>>> :kind! Length '[Char,String,Bool,Double]
103−Length '[Char,String,Bool,Double] :: Nat
104−= 4
105−-}
106−type family Length (xs :: [k]) :: Nat where
107− Length (_ ': _ ': _ ': _ ': _ : xs) = 5 + Length xs
108− Length (_ ': _ ': _ ': _ : xs) = 4 + Length xs
109− Length (_ ': _ ': _ : xs) = 3 + Length xs
110− Length (_ ': _ : xs) = 2 + Length xs
111− Length (_ : xs) = 1 + Length xs
112− Length '[] = 0
squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hsdeleted−578
@@ -1,578 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Manipulation
3−Description: Squeal data manipulation language
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Squeal data manipulation language.
9−-}
10−
11−{-# LANGUAGE
12− DeriveGeneric
13− , FlexibleContexts
14− , FlexibleInstances
15− , GADTs
16− , GeneralizedNewtypeDeriving
17− , LambdaCase
18− , MultiParamTypeClasses
19− , OverloadedStrings
20− , PatternSynonyms
21− , QuantifiedConstraints
22− , RankNTypes
23− , ScopedTypeVariables
24− , TypeApplications
25− , TypeFamilies
26− , TypeInType
27− , TypeOperators
28− , UndecidableInstances
29−#-}
30−
31−module Squeal.PostgreSQL.Manipulation
32− ( -- * Manipulation
33− Manipulation_
34− , Manipulation (..)
35− , queryStatement
36− -- * Insert
37− , insertInto
38− , insertInto_
39− -- * Update
40− , update
41− , update_
42− -- * Delete
43− , deleteFrom
44− , deleteFrom_
45− -- * Clauses
46− , Optional (..)
47− , QueryClause (..)
48− , pattern Values_
49− , ReturningClause (..)
50− , pattern Returning_
51− , ConflictClause (..)
52− , ConflictTarget (..)
53− , ConflictAction (..)
54− , UsingClause (..)
55− ) where
56−
57−import Control.DeepSeq
58−import Data.ByteString hiding (foldr)
59−import Data.Kind (Type)
60−
61−import qualified Generics.SOP as SOP
62−import qualified GHC.Generics as GHC
63−
64−import Squeal.PostgreSQL.Alias
65−import Squeal.PostgreSQL.Expression
66−import Squeal.PostgreSQL.Expression.Logic
67−import Squeal.PostgreSQL.List
68−import Squeal.PostgreSQL.PG
69−import Squeal.PostgreSQL.Render
70−import Squeal.PostgreSQL.Query
71−import Squeal.PostgreSQL.Schema
72−
73−-- $setup
74−-- >>> import Squeal.PostgreSQL
75−-- >>> import Data.Int
76−-- >>> import Data.Time
77−
78−{- |
79−A `Manipulation` is a statement which may modify data in the database,
80−but does not alter its schemas. Examples are inserts, updates and deletes.
81−A `Query` is also considered a `Manipulation` even though it does not modify data.
82−
83−The general `Manipulation` type is parameterized by
84−
85−* @commons :: FromType@ - scope for all `common` table expressions,
86−* @schemas :: SchemasType@ - scope for all `table`s and `view`s,
87−* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,
88−* @row :: RowType@ - return type of the `Query`.
89−-}
90−newtype Manipulation
91− (commons :: FromType)
92− (schemas :: SchemasType)
93− (params :: [NullityType])
94− (columns :: RowType)
95− = UnsafeManipulation { renderManipulation :: ByteString }
96− deriving (GHC.Generic,Show,Eq,Ord,NFData)
97−instance RenderSQL (Manipulation commons schemas params columns) where
98− renderSQL = renderManipulation
99−instance With Manipulation where
100− with Done manip = manip
101− with ctes manip = UnsafeManipulation $
102− "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL manip
103−
104−{- |
105−The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`,
106−against which the query is type-checked, an input @parameters@ Haskell `Type`,
107−and an ouput row Haskell `Type`.
108−
109−A top-level `Manipulation_` can be run
110−using `Squeal.PostgreSQL.PQ.manipulateParams`, or if @parameters = ()@
111−using `Squeal.PostgreSQL.PQ.manipulate`.
112−
113−Generally, @parameters@ will be a Haskell tuple or record whose entries
114−may be referenced using positional
115−`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a
116−Haskell record, whose entries will be targeted using overloaded labels.
117−
118−>>> :set -XDeriveAnyClass -XDerivingStrategies
119−>>> :{
120−data Row a b = Row { col1 :: a, col2 :: b }
121− deriving stock (GHC.Generic)
122− deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
123−:}
124−
125−simple insert:
126−
127−>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]
128−>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
129−>>> :{
130−let
131− manipulation :: Manipulation_ (Public Schema) () ()
132− manipulation =
133− insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))
134−in printSQL manipulation
135−:}
136−INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)
137−
138−parameterized insert:
139−
140−>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]
141−>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
142−>>> :{
143−let
144− manipulation :: Manipulation_ (Public Schema) (Int32, Int32) ()
145− manipulation =
146− insertInto_ #tab (Values_ (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2))
147−in printSQL manipulation
148−:}
149−INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))
150−
151−returning insert:
152−
153−>>> :{
154−let
155− manipulation :: Manipulation_ (Public Schema) () (Only Int32)
156− manipulation =
157− insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2))
158− OnConflictDoRaise (Returning (#col1 `as` #fromOnly))
159−in printSQL manipulation
160−:}
161−INSERT INTO "tab" ("col1", "col2") VALUES (2, 3) RETURNING "col1" AS "fromOnly"
162−
163−upsert:
164−
165−>>> type CustomersColumns = '["name" ::: 'NoDef :=> 'NotNull 'PGtext, "email" ::: 'NoDef :=> 'NotNull 'PGtext]
166−>>> type CustomersConstraints = '["uq" ::: 'Unique '["name"]]
167−>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)]
168−>>> :{
169−let
170− manipulation :: Manipulation_ (Public CustomersSchema) () ()
171− manipulation =
172− insertInto #customers
173− (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email))
174− (OnConflict (OnConstraint #uq)
175− (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) []))
176− (Returning_ Nil)
177−in printSQL manipulation
178−:}
179−INSERT INTO "customers" ("name", "email") VALUES (E'John Smith', E'john@smith.com') ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || (E'; ' || "customers"."email"))
180−
181−query insert:
182−
183−>>> :{
184−let
185− manipulation :: Manipulation_ (Public Schema) () ()
186− manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab))))
187−in printSQL manipulation
188−:}
189−INSERT INTO "tab" SELECT * FROM "tab" AS "tab"
190−
191−update:
192−
193−>>> :{
194−let
195− manipulation :: Manipulation_ (Public Schema) () ()
196− manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)
197−in printSQL manipulation
198−:}
199−UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")
200−
201−delete:
202−
203−>>> :{
204−let
205− manipulation :: Manipulation_ (Public Schema) () (Row Int32 Int32)
206− manipulation = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star)
207−in printSQL manipulation
208−:}
209−DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING *
210−
211−delete and using clause:
212−
213−>>> :{
214−type Schema3 =
215− '[ "tab" ::: 'Table ('[] :=> Columns)
216− , "other_tab" ::: 'Table ('[] :=> Columns)
217− , "third_tab" ::: 'Table ('[] :=> Columns) ]
218−:}
219−
220−>>> :{
221−let
222− manipulation :: Manipulation_ (Public Schema3) () ()
223− manipulation =
224− deleteFrom #tab (Using (table #other_tab & also (table #third_tab)))
225− ( (#tab ! #col2 .== #other_tab ! #col2)
226− .&& (#tab ! #col2 .== #third_tab ! #col2) )
227− (Returning_ Nil)
228−in printSQL manipulation
229−:}
230−DELETE FROM "tab" USING "other_tab" AS "other_tab", "third_tab" AS "third_tab" WHERE (("tab"."col2" = "other_tab"."col2") AND ("tab"."col2" = "third_tab"."col2"))
231−
232−with manipulation:
233−
234−>>> type ProductsColumns = '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]
235−>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]
236−>>> :{
237−let
238− manipulation :: Manipulation_ (Public ProductsSchema) (Only Day) ()
239− manipulation = with
240− (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del)
241− (insertInto_ #products_deleted (Subquery (select Star (from (common #del)))))
242−in printSQL manipulation
243−:}
244−WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del"
245−-}
246−type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type) where
247− Manipulation_ schemas params row = Manipulation '[] schemas (TuplePG params) (RowPG row)
248−
249−-- | Convert a `Query` into a `Manipulation`.
250−queryStatement
251− :: Query '[] commons schemas params columns
252− -- ^ `Query` to embed as a `Manipulation`
253− -> Manipulation commons schemas params columns
254−queryStatement q = UnsafeManipulation $ renderSQL q
255−
256−{-----------------------------------------
257−INSERT statements
258−-----------------------------------------}
259−
260−{- |
261−When a table is created, it contains no data. The first thing to do
262−before a database can be of much use is to insert data. Data is
263−conceptually inserted one row at a time. Of course you can also insert
264−more than one row, but there is no way to insert less than one row.
265−Even if you know only some column values, a complete row must be created.
266−-}
267−insertInto
268− :: ( Has sch schemas schema
269− , Has tab schema ('Table table)
270− , columns ~ TableToColumns table
271− , row0 ~ TableToRow table
272− , SOP.SListI columns
273− , SOP.SListI row1 )
274− => QualifiedAlias sch tab
275− -- ^ table
276− -> QueryClause commons schemas params columns
277− -- ^ what to insert
278− -> ConflictClause tab commons schemas params table
279− -- ^ what to do in case of conflict
280− -> ReturningClause commons schemas params '[tab ::: row0] row1
281− -- ^ what to return
282− -> Manipulation commons schemas params row1
283−insertInto tab qry conflict ret = UnsafeManipulation $
284− "INSERT" <+> "INTO" <+> renderSQL tab
285− <+> renderSQL qry
286− <> renderSQL conflict
287− <> renderSQL ret
288−
289−-- | Like `insertInto` but with `OnConflictDoRaise` and `no` `ReturningClause`.
290−insertInto_
291− :: ( Has sch schemas schema
292− , Has tab schema ('Table table)
293− , columns ~ TableToColumns table
294− , row ~ TableToRow table
295− , SOP.SListI columns )
296− => QualifiedAlias sch tab
297− -- ^ table
298− -> QueryClause commons schemas params columns
299− -- ^ what to insert
300− -> Manipulation commons schemas params '[]
301−insertInto_ tab qry =
302− insertInto tab qry OnConflictDoRaise (Returning_ Nil)
303−
304−-- | A `QueryClause` describes what to `insertInto` a table.
305−data QueryClause commons schemas params columns where
306− Values
307− :: SOP.SListI columns
308− => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
309− -- ^ row of values
310− -> [NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns]
311− -- ^ additional rows of values
312− -> QueryClause commons schemas params columns
313− Select
314− :: SOP.SListI columns
315− => NP (Aliased (Optional (Expression '[] commons grp schemas params from))) columns
316− -- ^ row of values
317− -> TableExpression '[] commons grp schemas params from
318− -- ^ from a table expression
319− -> QueryClause commons schemas params columns
320− Subquery
321− :: ColumnsToRow columns ~ row
322− => Query '[] commons schemas params row
323− -- ^ subquery to insert
324− -> QueryClause commons schemas params columns
325−
326−instance RenderSQL (QueryClause commons schemas params columns) where
327− renderSQL = \case
328− Values row0 rows ->
329− parenthesized (renderCommaSeparated renderSQLPart row0)
330− <+> "VALUES"
331− <+> commaSeparated
332− ( parenthesized
333− . renderCommaSeparated renderValuePart <$> row0 : rows )
334− Select row0 tab ->
335− parenthesized (renderCommaSeparatedMaybe renderSQLPartMaybe row0)
336− <+> "SELECT"
337− <+> renderCommaSeparatedMaybe renderValuePartMaybe row0
338− <+> renderSQL tab
339− Subquery qry -> renderQuery qry
340− where
341− renderSQLPartMaybe, renderValuePartMaybe
342− :: Aliased (Optional (Expression '[] commons grp schemas params from)) column
343− -> Maybe ByteString
344− renderSQLPartMaybe = \case
345− Default `As` _ -> Nothing
346− Set _ `As` name -> Just $ renderSQL name
347− renderValuePartMaybe = \case
348− Default `As` _ -> Nothing
349− Set value `As` _ -> Just $ renderExpression value
350− renderSQLPart, renderValuePart
351− :: Aliased (Optional (Expression '[] commons grp schemas params from)) column
352− -> ByteString
353− renderSQLPart (_ `As` name) = renderSQL name
354− renderValuePart (value `As` _) = renderSQL value
355−
356−-- | `Values_` describes a single `NP` list of `Aliased` `Optional` `Expression`s
357−-- whose `ColumnsType` must match the tables'.
358−pattern Values_
359− :: SOP.SListI columns
360− => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns
361− -- ^ row of values
362− -> QueryClause commons schemas params columns
363−pattern Values_ vals = Values vals []
364−
365−-- | `Optional` is either `Default` or a value, parameterized by an appropriate
366−-- `ColumnConstraint`.
367−data Optional expr ty where
368− -- | Use the `Default` value for a column.
369− Default :: Optional expr ('Def :=> ty)
370− -- | `Set` a value for a column.
371− Set :: expr ty -> Optional expr (def :=> ty)
372−
373−instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where
374− renderSQL = \case
375− Default -> "DEFAULT"
376− Set expr -> renderSQL expr
377−
378−-- | A `ReturningClause` computes and return value(s) based
379−-- on each row actually inserted, updated or deleted. This is primarily
380−-- useful for obtaining values that were supplied by defaults, such as a
381−-- serial sequence number. However, any expression using the table's columns
382−-- is allowed. Only rows that were successfully inserted or updated or
383−-- deleted will be returned. For example, if a row was locked
384−-- but not updated because an `OnConflict` `DoUpdate` condition was not satisfied,
385−-- the row will not be returned. `Returning` `Star` will return all columns
386−-- in the row. Use `Returning` `Nil` in the common case where no return
387−-- values are desired.
388−newtype ReturningClause commons schemas params from row =
389− Returning (Selection '[] commons 'Ungrouped schemas params from row)
390−
391−instance RenderSQL (ReturningClause commons schemas params from row) where
392− renderSQL = \case
393− Returning (List Nil) -> ""
394− Returning selection -> " RETURNING" <+> renderSQL selection
395−
396−-- | `Returning` a `List`
397−pattern Returning_
398− :: SOP.SListI row
399− => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row
400− -- ^ row of values
401− -> ReturningClause commons schemas params from row
402−pattern Returning_ list = Returning (List list)
403−
404−-- | A `ConflictClause` specifies an action to perform upon a constraint
405−-- violation. `OnConflictDoRaise` will raise an error.
406−-- `OnConflict` `DoNothing` simply avoids inserting a row.
407−-- `OnConflict` `DoUpdate` updates the existing row that conflicts with the row
408−-- proposed for insertion.
409−data ConflictClause tab commons schemas params table where
410− OnConflictDoRaise :: ConflictClause tab commons schemas params table
411− OnConflict
412− :: ConflictTarget constraints
413− -- ^ conflict target
414− -> ConflictAction tab commons schemas params columns
415− -- ^ conflict action
416− -> ConflictClause tab commons schemas params (constraints :=> columns)
417−
418−-- | Render a `ConflictClause`.
419−instance SOP.SListI (TableToColumns table)
420− => RenderSQL (ConflictClause tab commons schemas params table) where
421− renderSQL = \case
422− OnConflictDoRaise -> ""
423− OnConflict target action -> " ON CONFLICT"
424− <+> renderSQL target <+> renderSQL action
425−
426−{- |
427−`ConflictAction` specifies an alternative `OnConflict` action.
428−It can be either `DoNothing`, or a `DoUpdate` clause specifying
429−the exact details of the `update` action to be performed in case of a conflict.
430−The `Set` and WHERE `Condition`s in `OnConflict` `DoUpdate` have access to the
431−existing row using the table's name (or an alias), and to rows proposed
432−for insertion using the special @#excluded@ table.
433−`OnConflict` `DoNothing` simply avoids inserting a row as its alternative action.
434−`OnConflict` `DoUpdate` updates the existing row that conflicts
435−with the row proposed for insertion as its alternative action.
436−-}
437−data ConflictAction tab commons schemas params columns where
438− DoNothing :: ConflictAction tab commons schemas params columns
439− DoUpdate
440− :: ( row ~ ColumnsToRow columns
441− , SOP.SListI columns
442− , columns ~ (col0 ': cols)
443− , SOP.All (HasIn columns) subcolumns
444− , AllUnique subcolumns )
445− => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]))) subcolumns
446− -> [Condition '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]]
447− -- ^ WHERE `Condition`s
448− -> ConflictAction tab commons schemas params columns
449−
450−instance RenderSQL (ConflictAction tab commons schemas params columns) where
451− renderSQL = \case
452− DoNothing -> "DO NOTHING"
453− DoUpdate updates whs'
454− -> "DO UPDATE SET"
455− <+> renderCommaSeparated renderUpdate updates
456− <> case whs' of
457− [] -> ""
458− wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)
459−
460−renderUpdate
461− :: (forall x. RenderSQL (expr x))
462− => Aliased (Optional expr) ty
463− -> ByteString
464−renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr
465−
466−-- | A `ConflictTarget` specifies the constraint violation that triggers a
467−-- `ConflictAction`.
468−data ConflictTarget constraints where
469− OnConstraint
470− :: Has con constraints constraint
471− => Alias con
472− -> ConflictTarget constraints
473−
474−-- | Render a `ConflictTarget`
475−instance RenderSQL (ConflictTarget constraints) where
476− renderSQL (OnConstraint con) =
477− "ON" <+> "CONSTRAINT" <+> renderSQL con
478−
479−{-----------------------------------------
480−UPDATE statements
481−-----------------------------------------}
482−
483−-- | An `update` command changes the values of the specified columns
484−-- in all rows that satisfy the condition.
485−update
486− :: ( SOP.SListI columns
487− , SOP.SListI row1
488− , Has sch schemas schema
489− , Has tab schema ('Table table)
490− , row0 ~ TableToRow table
491− , columns ~ TableToColumns table
492− , SOP.All (HasIn columns) subcolumns
493− , AllUnique subcolumns )
494− => QualifiedAlias sch tab -- ^ table to update
495− -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row0]))) subcolumns
496− -- ^ modified values to replace old values
497− -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]
498− -- ^ condition under which to perform update on a row
499− -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return
500− -> Manipulation commons schemas params row1
501−update tab columns wh returning = UnsafeManipulation $
502− "UPDATE"
503− <+> renderSQL tab
504− <+> "SET"
505− <+> renderCommaSeparated renderUpdate columns
506− <+> "WHERE" <+> renderSQL wh
507− <> renderSQL returning
508−
509−-- | Update a row returning `Nil`.
510−update_
511− :: ( SOP.SListI columns
512− , Has sch schemas schema
513− , Has tab schema ('Table table)
514− , row ~ TableToRow table
515− , columns ~ TableToColumns table
516− , SOP.All (HasIn columns) subcolumns
517− , AllUnique subcolumns )
518− => QualifiedAlias sch tab -- ^ table to update
519− -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row]))) subcolumns
520− -- ^ modified values to replace old values
521− -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]
522− -- ^ condition under which to perform update on a row
523− -> Manipulation commons schemas params '[]
524−update_ tab columns wh = update tab columns wh (Returning_ Nil)
525−
526−{-----------------------------------------
527−DELETE statements
528−-----------------------------------------}
529−
530−-- | Specify additional tables with `Using`
531−-- an `also` list of table expressions, allowing columns
532−-- from other tables to appear in the WHERE condition.
533−-- This is similar to the list of tables that can be specified
534−-- in the FROM Clause of a SELECT statement;
535−-- for example, an alias for the table name can be specified.
536−-- Do not repeat the target table in the `Using` list,
537−-- unless you wish to set up a self-join.
538−-- `NoUsing` if no additional tables are to be used.
539−data UsingClause commons schemas params from where
540− NoUsing :: UsingClause commons schemas params '[]
541− Using
542− :: FromClause '[] commons schemas params from
543− -- ^ what to use
544− -> UsingClause commons schemas params from
545−
546−-- | Delete rows from a table.
547−deleteFrom
548− :: ( SOP.SListI row1
549− , Has sch schemas schema
550− , Has tab schema ('Table table)
551− , row0 ~ TableToRow table
552− , columns ~ TableToColumns table )
553− => QualifiedAlias sch tab -- ^ table to delete from
554− -> UsingClause commons schemas params from
555− -> Condition '[] commons 'Ungrouped schemas params (tab ::: row0 ': from)
556− -- ^ condition under which to delete a row
557− -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return
558− -> Manipulation commons schemas params row1
559−deleteFrom tab using wh returning = UnsafeManipulation $
560− "DELETE FROM"
561− <+> renderSQL tab
562− <> case using of
563− NoUsing -> ""
564− Using tables -> " USING" <+> renderSQL tables
565− <+> "WHERE" <+> renderSQL wh
566− <> renderSQL returning
567−
568−-- | Delete rows returning `Nil`.
569−deleteFrom_
570− :: ( Has sch schemas schema
571− , Has tab schema ('Table table)
572− , row ~ TableToRow table
573− , columns ~ TableToColumns table )
574− => QualifiedAlias sch tab -- ^ table to delete from
575− -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]
576− -- ^ condition under which to delete a row
577− -> Manipulation commons schemas params '[]
578−deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil)
squeal-postgresql/src/Squeal/PostgreSQL/Migration.hsdeleted−448
@@ -1,448 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Migration
3−Description: Squeal migrations
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−This module defines a `Migration` type to safely
9−change the schema of your database over time. Let's see an example!
10−
11−First turn on some extensions.
12−
13−>>> :set -XDataKinds -XOverloadedLabels
14−>>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators
15−
16−Next, let's define our `TableType`s.
17−
18−>>> :{
19−type UsersTable =
20− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
21− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
22− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
23− ]
24−:}
25−
26−>>> :{
27−type EmailsTable =
28− '[ "pk_emails" ::: 'PrimaryKey '["id"]
29− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
30− ] :=>
31− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
32− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
33− , "email" ::: 'NoDef :=> 'Null 'PGtext
34− ]
35−:}
36−
37−Now we can define some `Migration`s to make our tables.
38−
39−>>> :{
40−let
41− makeUsers :: Migration Definition (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]]
42− makeUsers = Migration
43− { name = "make users table"
44− , up = createTable #users
45− ( serial `as` #id :*
46− notNullable text `as` #name )
47− ( primaryKey #id `as` #pk_users )
48− , down = dropTable #users
49− }
50−:}
51−
52−>>> :{
53−let
54− makeEmails :: Migration Definition '["public" ::: '["users" ::: 'Table UsersTable]]
55− '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]]
56− makeEmails = Migration
57− { name = "make emails table"
58− , up = createTable #emails
59− ( serial `as` #id :*
60− notNullable int `as` #user_id :*
61− nullable text `as` #email )
62− ( primaryKey #id `as` #pk_emails :*
63− foreignKey #user_id #users #id
64− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )
65− , down = dropTable #emails
66− }
67−:}
68−
69−Now that we have a couple migrations we can chain them together into a `Path`.
70−
71−>>> let migrations = makeUsers :>> makeEmails :>> Done
72−
73−Now run the migrations.
74−
75−>>> import Control.Monad.IO.Class
76−>>> :{
77−withConnection "host=localhost port=5432 dbname=exampledb" $
78− manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")
79− -- suppress notices
80− & pqThen (liftIO (putStrLn "Migrate"))
81− & pqThen (migrateUp migrations)
82− & pqThen (liftIO (putStrLn "Rollback"))
83− & pqThen (migrateDown migrations)
84−:}
85−Migrate
86−Rollback
87−
88−We can also create a simple executable using `defaultMain`.
89−
90−>>> let main = defaultMain "host=localhost port=5432 dbname=exampledb" migrations
91−
92−>>> withArgs [] main
93−Invalid command: "". Use:
94−migrate to run all available migrations
95−rollback to rollback all available migrations
96−status to display migrations run and migrations left to run
97−
98−>>> withArgs ["status"] main
99−Migrations already run:
100− None
101−Migrations left to run:
102− - make users table
103− - make emails table
104−
105−>>> withArgs ["migrate"] main
106−Migrations already run:
107− - make users table
108− - make emails table
109−Migrations left to run:
110− None
111−
112−>>> withArgs ["rollback"] main
113−Migrations already run:
114− None
115−Migrations left to run:
116− - make users table
117− - make emails table
118−
119−In addition to enabling `Migration`s using pure SQL `Definition`s for
120−the `up` and `down` instructions, you can also perform impure `IO` actions
121−by using a `Migration`s over the `Terminally` `PQ` `IO` category.
122−-}
123−
124−{-# LANGUAGE
125− DataKinds
126− , DeriveGeneric
127− , FlexibleContexts
128− , FlexibleInstances
129− , GADTs
130− , LambdaCase
131− , OverloadedLabels
132− , OverloadedStrings
133− , PolyKinds
134− , QuantifiedConstraints
135− , RankNTypes
136− , TypeApplications
137− , TypeOperators
138−#-}
139−
140−module Squeal.PostgreSQL.Migration
141− ( -- * Migration
142− Migration (..)
143− , Migratory (..)
144− , Terminally (..)
145− , terminally
146− , pureMigration
147− , MigrationsTable
148− , defaultMain
149− ) where
150−
151−import Control.Category
152−import Control.Monad
153−import Data.ByteString (ByteString)
154−import Data.Foldable (traverse_)
155−import Data.Function ((&))
156−import Data.List ((\\))
157−import Data.Text (Text)
158−import Data.Time (UTCTime)
159−import Prelude hiding ((.), id)
160−import System.Environment
161−import UnliftIO (MonadIO (..))
162−
163−import qualified Data.Text.IO as Text (putStrLn)
164−import qualified Generics.SOP as SOP
165−import qualified GHC.Generics as GHC
166−
167−import Squeal.PostgreSQL.Alias
168−import Squeal.PostgreSQL.Binary
169−import Squeal.PostgreSQL.Definition
170−import Squeal.PostgreSQL.Definition.Table
171−import Squeal.PostgreSQL.Definition.Table.Constraint
172−import Squeal.PostgreSQL.Expression.Comparison
173−import Squeal.PostgreSQL.Expression.Parameter
174−import Squeal.PostgreSQL.Expression.Time
175−import Squeal.PostgreSQL.Expression.Type
176−import Squeal.PostgreSQL.List
177−import Squeal.PostgreSQL.Manipulation
178−import Squeal.PostgreSQL.PQ
179−import Squeal.PostgreSQL.Query
180−import Squeal.PostgreSQL.Schema
181−import Squeal.PostgreSQL.Transaction
182−
183−-- | A `Migration` is a named "isomorphism" over a given category.
184−-- It should contain an inverse pair of `up` and `down`
185−-- instructions and a unique `name`.
186−data Migration p schemas0 schemas1 = Migration
187− { name :: Text -- ^ The `name` of a `Migration`.
188− -- Each `name` in a `Migration` should be unique.
189− , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.
190− , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.
191− } deriving (GHC.Generic)
192−
193−{- |
194−A `Migratory` @p@ is a `Category` for which one can execute or rewind
195−a `Path` of `Migration`s over @p@. This includes the category of pure
196−SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.
197−-}
198−class Category p => Migratory p where
199−
200− {- |
201− Run a `Path` of `Migration`s.
202− Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
203− In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
204− if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.
205− -}
206− migrateUp
207− :: Path (Migration p) schemas0 schemas1
208− -> PQ schemas0 schemas1 IO ()
209−
210− {- |
211− Rewind a `Path` of `Migration`s.
212− Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.
213− In one transaction, for each each `Migration` query to see if the `Migration` has been executed;
214− if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.
215− -}
216− migrateDown
217− :: Path (Migration p) schemas0 schemas1
218− -> PQ schemas1 schemas0 IO ()
219−
220−instance Migratory Definition where
221− migrateUp = migrateUp . cmap pureMigration
222− migrateDown = migrateDown . cmap pureMigration
223−
224−{- | `Terminally` turns an indexed monad transformer and the monad it transforms
225−into a category by restricting the return type to @()@ and permuting the type variables.
226−This is similar to how applying a monad to @()@ yields a monoid.
227−Since a `Terminally` action has a trivial return value, the only reason
228−to run one is for the side effects, in particular database and other IO effects.
229−-}
230−newtype Terminally trans monad x0 x1 = Terminally
231− { runTerminally :: trans x0 x1 monad () }
232− deriving GHC.Generic
233−
234−instance
235− ( IndexedMonadTransPQ trans
236− , Monad monad
237− , forall x0 x1. x0 ~ x1 => Monad (trans x0 x1 monad) )
238− => Category (Terminally trans monad) where
239− id = Terminally (return ())
240− Terminally g . Terminally f = Terminally $ pqThen g f
241−
242−-- | `terminally` ignores the output of a computation, returning @()@ and
243−-- wrapping it up into a `Terminally`. You can lift an action in the base monad
244−-- by using @terminally . lift@.
245−terminally
246− :: Functor (trans x0 x1 monad)
247− => trans x0 x1 monad ignore
248− -> Terminally trans monad x0 x1
249−terminally = Terminally . void
250−
251−-- | A `pureMigration` turns a `Migration` involving only pure SQL
252−-- `Definition`s into a `Migration` that may be combined with arbitrary `IO`.
253−pureMigration
254− :: Migration Definition schemas0 schemas1
255− -> Migration (Terminally PQ IO) schemas0 schemas1
256−pureMigration migration = Migration
257− { name = name migration
258− , up = terminally . define $ up migration
259− , down = terminally . define $ down migration
260− }
261−
262−instance Migratory (Terminally PQ IO) where
263−
264− migrateUp migration = unsafePQ . transactionally_ $ do
265− define createMigrations
266− upMigrations migration
267−
268− where
269−
270− upMigrations
271− :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
272− -> PQ MigrationsSchemas MigrationsSchemas IO ()
273− upMigrations = \case
274− Done -> return ()
275− step :>> steps -> upMigration step >> upMigrations steps
276−
277− upMigration
278− :: Migration (Terminally PQ IO) schemas0 schemas1
279− -> PQ MigrationsSchemas MigrationsSchemas IO ()
280− upMigration step = do
281− executed <- queryExecuted step
282− unless (executed == 1) $ do
283− unsafePQ . runTerminally $ up step
284− manipulateParams_ insertMigration (Only (name step))
285−
286− queryExecuted
287− :: Migration (Terminally PQ IO) schemas0 schemas1
288− -> PQ MigrationsSchemas MigrationsSchemas IO Row
289− queryExecuted step = do
290− result <- runQueryParams selectMigration (Only (name step))
291− ntuples result
292−
293− migrateDown migrations = unsafePQ . transactionally_ $ do
294− define createMigrations
295− downMigrations migrations
296−
297− where
298−
299− downMigrations
300− :: Path (Migration (Terminally PQ IO)) schemas0 schemas1
301− -> PQ MigrationsSchemas MigrationsSchemas IO ()
302− downMigrations = \case
303− Done -> return ()
304− step :>> steps -> downMigrations steps >> downMigration step
305−
306− downMigration
307− :: Migration (Terminally PQ IO) schemas0 schemas1
308− -> PQ MigrationsSchemas MigrationsSchemas IO ()
309− downMigration step = do
310− executed <- queryExecuted step
311− unless (executed == 0) $ do
312− unsafePQ . runTerminally $ down step
313− manipulateParams_ deleteMigration (Only (name step))
314−
315− queryExecuted
316− :: Migration (Terminally PQ IO) schemas0 schemas1
317− -> PQ MigrationsSchemas MigrationsSchemas IO Row
318− queryExecuted step = do
319− result <- runQueryParams selectMigration (Only (name step))
320− ntuples result
321−
322−unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x
323−unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK
324−
325−-- | The `TableType` for a Squeal migration.
326−type MigrationsTable =
327− '[ "migrations_unique_name" ::: 'Unique '["name"]] :=>
328− '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext
329− , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz
330− ]
331−
332−data MigrationRow =
333− MigrationRow { migrationName :: Text
334− , migrationTime :: UTCTime }
335− deriving (GHC.Generic, Show)
336−
337−instance SOP.Generic MigrationRow
338−instance SOP.HasDatatypeInfo MigrationRow
339−
340−type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable]
341−type MigrationsSchemas = Public MigrationsSchema
342−
343−-- | Creates a `MigrationsTable` if it does not already exist.
344−createMigrations :: Definition MigrationsSchemas MigrationsSchemas
345−createMigrations =
346− createTableIfNotExists #schema_migrations
347− ( (text & notNullable) `as` #name :*
348− (timestampWithTimeZone & notNullable & default_ currentTimestamp)
349− `as` #executed_at )
350− ( unique #name `as` #migrations_unique_name )
351−
352−-- | Inserts a `Migration` into the `MigrationsTable`, returning
353−-- the time at which it was inserted.
354−insertMigration :: Manipulation_ MigrationsSchemas (Only Text) ()
355−insertMigration = insertInto_ #schema_migrations
356− (Values_ (Set (param @1) `as` #name :* Default `as` #executed_at))
357−
358−-- | Deletes a `Migration` from the `MigrationsTable`, returning
359−-- the time at which it was inserted.
360−deleteMigration :: Manipulation_ MigrationsSchemas (Only Text) ()
361−deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)
362−
363−-- | Selects a `Migration` from the `MigrationsTable`, returning
364−-- the time at which it was inserted.
365−selectMigration
366− :: Query_ MigrationsSchemas (Only Text) (Only UTCTime)
367−selectMigration = select_ (#executed_at `as` #fromOnly)
368− $ from (table (#schema_migrations))
369− & where_ (#name .== param @1)
370−
371−selectMigrations :: Query_ MigrationsSchemas () MigrationRow
372−selectMigrations = select_
373− (#name `as` #migrationName :* #executed_at `as` #migrationTime)
374− (from (table #schema_migrations))
375−
376−data MigrateCommand
377− = MigrateStatus
378− | MigrateUp
379− | MigrateDown deriving (GHC.Generic, Show)
380−
381−{- | `defaultMain` creates a simple executable
382−from a connection string and a list of `Migration`s. -}
383−defaultMain
384− :: Migratory p
385− => ByteString
386− -- ^ connection string
387− -> Path (Migration p) db0 db1
388− -- ^ migrations
389− -> IO ()
390−defaultMain connectTo migrations = do
391− command <- readCommandFromArgs
392− maybe (pure ()) performCommand command
393−
394− where
395−
396− performCommand :: MigrateCommand -> IO ()
397− performCommand = \case
398− MigrateStatus -> withConnection connectTo $
399− suppressNotices >> migrateStatus
400− MigrateUp -> withConnection connectTo $
401− suppressNotices & pqThen (migrateUp migrations) & pqThen migrateStatus
402− MigrateDown -> withConnection connectTo $
403− suppressNotices & pqThen (migrateDown migrations) & pqThen migrateStatus
404−
405− migrateStatus :: PQ schema schema IO ()
406− migrateStatus = unsafePQ $ do
407− runNames <- getRunMigrationNames
408− let names = ctoList name migrations
409− unrunNames = names \\ runNames
410− liftIO $ displayRunned runNames >> displayUnrunned unrunNames
411−
412− suppressNotices :: PQ schema schema IO ()
413− suppressNotices = manipulate_ $
414− UnsafeManipulation "SET client_min_messages TO WARNING;"
415−
416− readCommandFromArgs :: IO (Maybe MigrateCommand)
417− readCommandFromArgs = getArgs >>= \case
418− ["migrate"] -> pure . Just $ MigrateUp
419− ["rollback"] -> pure . Just $ MigrateDown
420− ["status"] -> pure . Just $ MigrateStatus
421− args -> displayUsage args >> pure Nothing
422−
423− displayUsage :: [String] -> IO ()
424− displayUsage args = do
425− putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:"
426− putStrLn "migrate to run all available migrations"
427− putStrLn "rollback to rollback all available migrations"
428− putStrLn "status to display migrations run and migrations left to run"
429−
430− getRunMigrationNames :: (MonadIO m) => PQ db0 db0 m [Text]
431− getRunMigrationNames =
432− fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery selectMigrations)) >>= getRows)
433−
434− displayListOfNames :: [Text] -> IO ()
435− displayListOfNames [] = Text.putStrLn " None"
436− displayListOfNames xs =
437− let singleName n = Text.putStrLn $ " - " <> n
438− in traverse_ singleName xs
439−
440− displayUnrunned :: [Text] -> IO ()
441− displayUnrunned unrunned =
442− Text.putStrLn "Migrations left to run:"
443− >> displayListOfNames unrunned
444−
445− displayRunned :: [Text] -> IO ()
446− displayRunned runned =
447− Text.putStrLn "Migrations already run:"
448− >> displayListOfNames runned
squeal-postgresql/src/Squeal/PostgreSQL/PG.hsdeleted−388
@@ -1,388 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.PG
3−Description: Embedding of Haskell types into Postgres's type system
4−Copyright: (c) Eitan Chatav, 2010
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−`Squeal.PostgreSQL.PG` provides type families for turning Haskell
9−`Type`s into corresponding Postgres types.
10−-}
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , DeriveAnyClass
14− , DeriveFoldable
15− , DeriveFunctor
16− , DeriveGeneric
17− , DeriveTraversable
18− , DerivingStrategies
19− , DefaultSignatures
20− , FlexibleContexts
21− , FlexibleInstances
22− , FunctionalDependencies
23− , GADTs
24− , LambdaCase
25− , MultiParamTypeClasses
26− , OverloadedStrings
27− , ScopedTypeVariables
28− , TypeApplications
29− , TypeFamilies
30− , TypeInType
31− , TypeOperators
32− , UndecidableInstances
33− , UndecidableSuperClasses
34−#-}
35−
36−module Squeal.PostgreSQL.PG
37− ( -- * PG embeddings
38− PG
39− , NullPG
40− , TuplePG
41− , RowPG
42− -- * Storage newtypes
43− , Money (..)
44− , Json (..)
45− , Jsonb (..)
46− , Composite (..)
47− , Enumerated (..)
48− , VarArray (..)
49− , FixArray (..)
50− , LibPQ.Oid (..)
51− -- * Type families
52− , LabelsPG
53− , DimPG
54− , FixPG
55− , TupleOf
56− , TupleCodeOf
57− , RowOf
58− , ConstructorsOf
59− , ConstructorNameOf
60− , ConstructorNamesOf
61− ) where
62−
63−import Data.Aeson (Value)
64−import Data.Kind (Type)
65−import Data.Int (Int16, Int32, Int64)
66−import Data.Scientific (Scientific)
67−import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)
68−import Data.Vector (Vector)
69−import Data.UUID.Types (UUID)
70−import GHC.TypeLits
71−import Network.IP.Addr (NetAddr, IP)
72−
73−import qualified Data.ByteString.Lazy as Lazy (ByteString)
74−import qualified Data.ByteString as Strict (ByteString)
75−import qualified Data.Text.Lazy as Lazy (Text)
76−import qualified Data.Text as Strict (Text)
77−import qualified Database.PostgreSQL.LibPQ as LibPQ
78−import qualified GHC.Generics as GHC
79−import qualified Generics.SOP as SOP
80−import qualified Generics.SOP.Record as SOP
81−import qualified Generics.SOP.Type.Metadata as Type
82−
83−import Squeal.PostgreSQL.Alias
84−import Squeal.PostgreSQL.Schema
85−
86−-- $setup
87−-- >>> import Squeal.PostgreSQL
88−-- >>> import Data.Text (Text)
89−
90−{- | The `PG` type family embeds a subset of Haskell types
91−as Postgres types. As an open type family, `PG` is extensible.
92−
93−>>> :kind! PG LocalTime
94−PG LocalTime :: PGType
95−= 'PGtimestamp
96−
97−>>> newtype MyDouble = My Double
98−>>> :set -XTypeFamilies
99−>>> type instance PG MyDouble = 'PGfloat8
100−-}
101−type family PG (hask :: Type) :: PGType
102−-- | `PGbool`
103−type instance PG Bool = 'PGbool
104−-- | `PGint2`
105−type instance PG Int16 = 'PGint2
106−-- | `PGint4`
107−type instance PG Int32 = 'PGint4
108−-- | `PGint8`
109−type instance PG Int64 = 'PGint8
110−-- | `PGint2`
111−type instance PG LibPQ.Oid = 'PGoid
112−-- | `PGnumeric`
113−type instance PG Scientific = 'PGnumeric
114−-- | `PGfloat4`
115−type instance PG Float = 'PGfloat4
116−-- | `PGfloat8`
117−type instance PG Double = 'PGfloat8
118−-- | `PGchar` @1@
119−type instance PG Char = 'PGchar 1
120−-- | `PGtext`
121−type instance PG Strict.Text = 'PGtext
122−-- | `PGtext`
123−type instance PG Lazy.Text = 'PGtext
124−-- | `PGtext`
125−type instance PG String = 'PGtext
126−-- | `PGbytea`
127−type instance PG Strict.ByteString = 'PGbytea
128−-- | `PGbytea`
129−type instance PG Lazy.ByteString = 'PGbytea
130−-- | `PGtimestamp`
131−type instance PG LocalTime = 'PGtimestamp
132−-- | `PGtimestamptz`
133−type instance PG UTCTime = 'PGtimestamptz
134−-- | `PGdate`
135−type instance PG Day = 'PGdate
136−-- | `PGtime`
137−type instance PG TimeOfDay = 'PGtime
138−-- | `PGtimetz`
139−type instance PG (TimeOfDay, TimeZone) = 'PGtimetz
140−-- | `PGinterval`
141−type instance PG DiffTime = 'PGinterval
142−-- | `PGuuid`
143−type instance PG UUID = 'PGuuid
144−-- | `PGinet`
145−type instance PG (NetAddr IP) = 'PGinet
146−-- | `PGjson`
147−type instance PG Value = 'PGjson
148−
149−{-| The `LabelsPG` type family calculates the constructors of a
150−Haskell enum type.
151−
152−>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic
153−>>> instance SOP.Generic Schwarma
154−>>> instance SOP.HasDatatypeInfo Schwarma
155−>>> :kind! LabelsPG Schwarma
156−LabelsPG Schwarma :: [Type.ConstructorName]
157−= '["Beef", "Lamb", "Chicken"]
158−-}
159−type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where
160− LabelsPG hask =
161− ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask))
162−
163−{- |
164−`RowPG` turns a Haskell `Type` into a `RowType`.
165−
166−`RowPG` may be applied to normal Haskell record types provided they
167−have `SOP.Generic` and `SOP.HasDatatypeInfo` instances;
168−
169−>>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic
170−>>> instance SOP.Generic Person
171−>>> instance SOP.HasDatatypeInfo Person
172−>>> :kind! RowPG Person
173−RowPG Person :: [(Symbol, NullityType)]
174−= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]
175−-}
176−type family RowPG (hask :: Type) :: RowType where
177− RowPG hask = RowOf (SOP.RecordCodeOf hask)
178−
179−-- | `RowOf` applies `NullPG` to the fields of a list.
180−type family RowOf (record :: [(Symbol, Type)]) :: RowType where
181− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': col4 ::: ty4 ': record) =
182− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': col4 ::: NullPG ty4 ': RowOf record
183− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': record) =
184− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': RowOf record
185− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': record) =
186− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': RowOf record
187− RowOf (col ::: ty ': col1 ::: ty1 ': record) =
188− col ::: NullPG ty ': col1::: NullPG ty1 ': RowOf record
189− RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record
190− RowOf '[] = '[]
191−
192−{- | `NullPG` turns a Haskell type into a `NullityType`.
193−
194−>>> :kind! NullPG Double
195−NullPG Double :: NullityType
196−= 'NotNull 'PGfloat8
197−>>> :kind! NullPG (Maybe Double)
198−NullPG (Maybe Double) :: NullityType
199−= 'Null 'PGfloat8
200−-}
201−type family NullPG (hask :: Type) :: NullityType where
202− NullPG (Maybe hask) = 'Null (PG hask)
203− NullPG hask = 'NotNull (PG hask)
204−
205−{- | `TuplePG` turns a Haskell tuple type (including record types) into
206−the corresponding list of `NullityType`s.
207−
208−>>> :kind! TuplePG (Double, Maybe Char)
209−TuplePG (Double, Maybe Char) :: [NullityType]
210−= '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)]
211−-}
212−type family TuplePG (hask :: Type) :: [NullityType] where
213− TuplePG hask = TupleOf (TupleCodeOf hask (SOP.Code hask))
214−
215−-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.
216−type family TupleOf (tuple :: [Type]) :: [NullityType] where
217− TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': hask5 ': tuple) =
218− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': NullPG hask5 ': TupleOf tuple
219− TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': tuple) =
220− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': TupleOf tuple
221− TupleOf (hask ': hask1 ': hask2 ': hask3 ': tuple) =
222− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': TupleOf tuple
223− TupleOf (hask ': hask1 ': hask2 ': tuple) =
224− NullPG hask ': NullPG hask1 ': NullPG hask2 ': TupleOf tuple
225− TupleOf (hask ': hask1 ': tuple) = NullPG hask ': NullPG hask1 ': TupleOf tuple
226− TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple
227− TupleOf '[] = '[]
228−
229−-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`
230−-- and if it's a simple product returns it, otherwise giving a `TypeError`.
231−type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where
232− TupleCodeOf hask '[tuple] = tuple
233− TupleCodeOf hask '[] =
234− TypeError
235− ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."
236− ':$$: 'Text "It is a void type with no constructors."
237− )
238− TupleCodeOf hask (_ ': _ ': _) =
239− TypeError
240− ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."
241− ':$$: 'Text "It is a sum type with more than one constructor."
242− )
243−
244−-- | Calculates constructors of a datatype.
245−type family ConstructorsOf (datatype :: Type.DatatypeInfo)
246− :: [Type.ConstructorInfo] where
247− ConstructorsOf ('Type.ADT _module _datatype constructors) =
248− constructors
249− ConstructorsOf ('Type.Newtype _module _datatype constructor) =
250− '[constructor]
251−
252−-- | Calculates the name of a nullary constructor, otherwise
253−-- generates a type error.
254−type family ConstructorNameOf (constructor :: Type.ConstructorInfo)
255− :: Type.ConstructorName where
256− ConstructorNameOf ('Type.Constructor name) = name
257− ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError
258− ('Text "ConstructorNameOf error: non-nullary constructor "
259− ':<>: 'Text name)
260− ConstructorNameOf ('Type.Record name _fields) = TypeError
261− ('Text "ConstructorNameOf error: non-nullary constructor "
262− ':<>: 'Text name)
263−
264−-- | Calculate the names of nullary constructors.
265−type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])
266− :: [Type.ConstructorName] where
267− ConstructorNamesOf '[] = '[]
268− ConstructorNamesOf (constructor ': constructors) =
269− ConstructorNameOf constructor ': ConstructorNamesOf constructors
270−
271−-- | `DimPG` turns Haskell nested homogeneous tuples into a list of lengths.
272−type family DimPG (hask :: Type) :: [Nat] where
273− DimPG (x,x) = 2 ': DimPG x
274− DimPG (x,x,x) = 3 ': DimPG x
275− DimPG (x,x,x,x) = 4 ': DimPG x
276− DimPG (x,x,x,x,x) = 5 ': DimPG x
277− DimPG (x,x,x,x,x,x) = 6 ': DimPG x
278− DimPG (x,x,x,x,x,x,x) = 7 ': DimPG x
279− DimPG (x,x,x,x,x,x,x,x) = 8 ': DimPG x
280− DimPG (x,x,x,x,x,x,x,x,x) = 9 ': DimPG x
281− DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x
282− DimPG x = '[]
283−
284−-- | `FixPG` extracts `NullPG` of the base type of nested homogeneous tuples.
285−type family FixPG (hask :: Type) :: NullityType where
286− FixPG (x,x) = FixPG x
287− FixPG (x,x,x) = FixPG x
288− FixPG (x,x,x,x) = FixPG x
289− FixPG (x,x,x,x,x) = FixPG x
290− FixPG (x,x,x,x,x,x) = FixPG x
291− FixPG (x,x,x,x,x,x,x) = FixPG x
292− FixPG (x,x,x,x,x,x,x,x) = FixPG x
293− FixPG (x,x,x,x,x,x,x,x,x) = FixPG x
294− FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x
295− FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x
296− FixPG x = NullPG x
297−
298−{- | The `Money` newtype stores a monetary value in terms
299−of the number of cents, i.e. @$2,000.20@ would be expressed as
300−@Money { cents = 200020 }@.
301−
302−>>> import Control.Monad (void)
303−>>> import Control.Monad.IO.Class (liftIO)
304−>>> import Squeal.PostgreSQL
305−>>> :{
306−let
307− roundTrip :: Query_ (Public '[]) (Only Money) (Only Money)
308− roundTrip = values_ $ parameter @1 money `as` #fromOnly
309−:}
310−
311−>>> let input = Only (Money 20020)
312−
313−>>> :{
314−withConnection "host=localhost port=5432 dbname=exampledb" $ do
315− result <- runQueryParams roundTrip input
316− Just output <- firstRow result
317− liftIO . print $ input == output
318−:}
319−True
320−-}
321−newtype Money = Money { cents :: Int64 }
322− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
323− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
324−-- | `PGmoney`
325−type instance PG Money = 'PGmoney
326−
327−{- | The `Json` newtype is an indication that the Haskell
328−type it's applied to should be stored as a `PGjson`.
329−-}
330−newtype Json hask = Json {getJson :: hask}
331− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
332− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
333−-- | `PGjson`
334−type instance PG (Json hask) = 'PGjson
335−
336−{- | The `Jsonb` newtype is an indication that the Haskell
337−type it's applied to should be stored as a `PGjsonb`.
338−-}
339−newtype Jsonb hask = Jsonb {getJsonb :: hask}
340− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
341− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
342−-- | `PGjsonb`
343−type instance PG (Jsonb hask) = 'PGjsonb
344−
345−{- | The `Composite` newtype is an indication that the Haskell
346−type it's applied to should be stored as a `PGcomposite`.
347−-}
348−newtype Composite record = Composite {getComposite :: record}
349− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
350− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
351−-- | `PGcomposite` @(@`RowPG` @hask)@
352−type instance PG (Composite hask) = 'PGcomposite (RowPG hask)
353−
354−{- | The `Enumerated` newtype is an indication that the Haskell
355−type it's applied to should be stored as a `PGenum`.
356−-}
357−newtype Enumerated enum = Enumerated {getEnumerated :: enum}
358− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
359− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
360−-- | `PGenum` @(@`LabelsPG` @hask)@
361−type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)
362−
363−{- | The `VarArray` newtype is an indication that the Haskell
364−type it's applied to should be stored as a `PGvararray`.
365−
366−>>> :kind! PG (VarArray (Vector Double))
367−PG (VarArray (Vector Double)) :: PGType
368−= 'PGvararray ('NotNull 'PGfloat8)
369−-}
370−newtype VarArray arr = VarArray {getVarArray :: arr}
371− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
372− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
373−-- | `PGvararray` @(@`NullPG` @hask)@
374−type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)
375−type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask)
376−
377−{- | The `FixArray` newtype is an indication that the Haskell
378−type it's applied to should be stored as a `PGfixarray`.
379−
380−>>> :kind! PG (FixArray ((Double, Double), (Double, Double)))
381−PG (FixArray ((Double, Double), (Double, Double))) :: PGType
382−= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)
383−-}
384−newtype FixArray arr = FixArray {getFixArray :: arr}
385− deriving stock (Eq, Ord, Show, Read, GHC.Generic)
386− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
387−-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@
388−type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)
squeal-postgresql/src/Squeal/PostgreSQL/PQ.hsdeleted−712
@@ -1,712 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.PQ
3−Description: PQ monad
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−This module is where Squeal commands actually get executed by
9−`Database.PostgreSQL.LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing
10−a `Definition` and `MonadPQ` for executing a `Manipulation` or `Query`,
11−and a `PQ` type with instances for them.
12−
13−Using Squeal in your application will come down to defining
14−the @schemas@ of your database and including @PQ schemas schemas@ in your
15−application's monad transformer stack, giving it an instance of `MonadPQ`.
16−
17−This module also provides functions for retrieving rows from the `LibPQ.Result`
18−of executing Squeal commands.
19−-}
20−
21−{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
22−{-# LANGUAGE
23− DefaultSignatures
24− , FunctionalDependencies
25− , FlexibleContexts
26− , FlexibleInstances
27− , InstanceSigs
28− , OverloadedStrings
29− , RankNTypes
30− , ScopedTypeVariables
31− , TypeApplications
32− , TypeFamilies
33− , TypeInType
34− , TypeOperators
35− , UndecidableInstances
36−#-}
37−
38−module Squeal.PostgreSQL.PQ
39− ( -- * Connection
40− LibPQ.Connection
41− , connectdb
42− , finish
43− , withConnection
44− , lowerConnection
45− -- * PQ
46− , PQ (PQ, unPQ)
47− , runPQ
48− , execPQ
49− , evalPQ
50− , IndexedMonadTransPQ (..)
51− , MonadPQ (..)
52− -- * Results
53− , LibPQ.Result
54− , LibPQ.Row
55− , ntuples
56− , getRow
57− , getRows
58− , nextRow
59− , firstRow
60− , liftResult
61− , LibPQ.ExecStatus (..)
62− , resultStatus
63− , resultErrorMessage
64− , resultErrorCode
65− -- * Exceptions
66− , SquealException (..)
67− , PQState (..)
68− , okResult
69− , catchSqueal
70− , handleSqueal
71− , trySqueal
72− ) where
73−
74−import Control.Exception (Exception, throw)
75−import Control.Monad.Except
76−import Control.Monad.Morph
77−import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try)
78−import Data.ByteString (ByteString)
79−import Data.Foldable
80−import Data.Function ((&))
81−import Data.Functor ((<&>))
82−import Data.Kind
83−import Data.Text (pack, Text)
84−import Data.Traversable
85−import Generics.SOP
86−import PostgreSQL.Binary.Encoding (encodingBytes)
87−
88−import qualified Control.Monad.Fail as Fail
89−import qualified Database.PostgreSQL.LibPQ as LibPQ
90−import qualified PostgreSQL.Binary.Encoding as Encoding
91−
92−import Squeal.PostgreSQL.Binary
93−import Squeal.PostgreSQL.Definition
94−import Squeal.PostgreSQL.Manipulation
95−import Squeal.PostgreSQL.Query
96−import Squeal.PostgreSQL.Schema
97−
98−-- For `MonadPQ` transformer instances
99−import Control.Monad.Trans.Identity
100−import Control.Monad.Trans.Reader
101−import Control.Monad.Trans.Maybe
102−import Control.Monad.Trans.Cont
103−
104−import qualified Control.Monad.Trans.State.Lazy as Lazy
105−import qualified Control.Monad.Trans.State.Strict as Strict
106−import qualified Control.Monad.Trans.Writer.Lazy as Lazy
107−import qualified Control.Monad.Trans.Writer.Strict as Strict
108−import qualified Control.Monad.Trans.RWS.Lazy as Lazy
109−import qualified Control.Monad.Trans.RWS.Strict as Strict
110−
111−-- $setup
112−-- >>> import Squeal.PostgreSQL
113−
114−{- | Makes a new connection to the database server.
115−
116−This function opens a new database connection using the parameters taken
117−from the string conninfo.
118−
119−The passed string can be empty to use all default parameters, or it can
120−contain one or more parameter settings separated by whitespace.
121−Each parameter setting is in the form keyword = value. Spaces around the equal
122−sign are optional. To write an empty value or a value containing spaces,
123−surround it with single quotes, e.g., keyword = 'a value'. Single quotes and
124−backslashes within the value must be escaped with a backslash, i.e., ' and \.
125−
126−To specify the schema you wish to connect with, use type application.
127−
128−>>> :set -XDataKinds
129−>>> :set -XPolyKinds
130−>>> :set -XTypeOperators
131−>>> type Schema = '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint2]]
132−>>> :set -XTypeApplications
133−>>> :set -XOverloadedStrings
134−>>> conn <- connectdb @Schema "host=localhost port=5432 dbname=exampledb"
135−
136−Note that, for now, squeal doesn't offer any protection from connecting
137−with the wrong schema!
138−-}
139−connectdb
140− :: forall schemas io
141− . MonadIO io
142− => ByteString -- ^ conninfo
143− -> io (K LibPQ.Connection schemas)
144−connectdb = fmap K . liftIO . LibPQ.connectdb
145−
146−-- | Closes the connection to the server.
147−finish :: MonadIO io => K LibPQ.Connection schemas -> io ()
148−finish = liftIO . LibPQ.finish . unK
149−
150−-- | Do `connectdb` and `finish` before and after a computation.
151−withConnection
152− :: forall schemas0 schemas1 io x
153− . MonadUnliftIO io
154− => ByteString
155− -> PQ schemas0 schemas1 io x
156− -> io x
157−withConnection connString action = do
158− K x <- bracket (connectdb connString) finish (unPQ action)
159− return x
160−
161−-- | Safely `lowerConnection` to a smaller schema.
162−lowerConnection
163− :: K LibPQ.Connection (schema ': schemas)
164− -> K LibPQ.Connection schemas
165−lowerConnection (K conn) = K conn
166−
167−-- | We keep track of the schema via an Atkey indexed state monad transformer,
168−-- `PQ`.
169−newtype PQ
170− (schemas0 :: SchemasType)
171− (schemas1 :: SchemasType)
172− (m :: Type -> Type)
173− (x :: Type) =
174− PQ { unPQ :: K LibPQ.Connection schemas0 -> m (K x schemas1) }
175−
176−instance Monad m => Functor (PQ schemas0 schemas1 m) where
177− fmap f (PQ pq) = PQ $ \ conn -> do
178− K x <- pq conn
179− return $ K (f x)
180−
181−-- | Run a `PQ` and keep the result and the `LibPQ.Connection`.
182−runPQ
183− :: Functor m
184− => PQ schemas0 schemas1 m x
185− -> K LibPQ.Connection schemas0
186− -> m (x, K LibPQ.Connection schemas1)
187−runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn
188− -- K x <- pq conn
189− -- return (x, K (unK conn))
190−
191−-- | Execute a `PQ` and discard the result but keep the `LibPQ.Connection`.
192−execPQ
193− :: Functor m
194− => PQ schemas0 schemas1 m x
195− -> K LibPQ.Connection schemas0
196− -> m (K LibPQ.Connection schemas1)
197−execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn
198−
199−-- | Evaluate a `PQ` and discard the `LibPQ.Connection` but keep the result.
200−evalPQ
201− :: Functor m
202− => PQ schemas0 schemas1 m x
203− -> K LibPQ.Connection schemas0
204− -> m x
205−evalPQ (PQ pq) conn = unK <$> pq conn
206−
207−-- | An [Atkey indexed monad](https://bentnib.org/paramnotions-jfp.pdf) is a `Functor`
208−-- [enriched category](https://ncatlab.org/nlab/show/enriched+category).
209−-- An indexed monad transformer transforms a `Monad` into an indexed monad.
210−-- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that
211−-- support running `Definition`s using `define`.
212−class IndexedMonadTransPQ pq where
213−
214− -- | indexed analog of `<*>`
215− pqAp
216− :: Monad m
217− => pq schemas0 schemas1 m (x -> y)
218− -> pq schemas1 schemas2 m x
219− -> pq schemas0 schemas2 m y
220−
221− -- | indexed analog of `join`
222− pqJoin
223− :: Monad m
224− => pq schemas0 schemas1 m (pq schemas1 schemas2 m y)
225− -> pq schemas0 schemas2 m y
226− pqJoin pq = pq & pqBind id
227−
228− -- | indexed analog of `=<<`
229− pqBind
230− :: Monad m
231− => (x -> pq schemas1 schemas2 m y)
232− -> pq schemas0 schemas1 m x
233− -> pq schemas0 schemas2 m y
234−
235− -- | indexed analog of flipped `>>`
236− pqThen
237− :: Monad m
238− => pq schemas1 schemas2 m y
239− -> pq schemas0 schemas1 m x
240− -> pq schemas0 schemas2 m y
241− pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
242−
243− -- | indexed analog of `<=<`
244− pqAndThen
245− :: Monad m
246− => (y -> pq schemas1 schemas2 m z)
247− -> (x -> pq schemas0 schemas1 m y)
248− -> x -> pq schemas0 schemas2 m z
249− pqAndThen g f x = pqBind g (f x)
250−
251− -- | Run a `Definition` with `LibPQ.exec`.
252− --
253− -- It should be functorial in effect.
254− --
255− -- @define id = return ()@
256− -- @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@
257− define
258− :: MonadIO io
259− => Definition schemas0 schemas1
260− -> pq schemas0 schemas1 io ()
261−
262−instance IndexedMonadTransPQ PQ where
263−
264− pqAp (PQ f) (PQ x) = PQ $ \ conn -> do
265− K f' <- f conn
266− K x' <- x (K (unK conn))
267− return $ K (f' x')
268−
269− pqBind f (PQ x) = PQ $ \ conn -> do
270− K x' <- x conn
271− unPQ (f x') (K (unK conn))
272−
273− define (UnsafeDefinition q) = PQ $ \ (K conn) -> do
274− resultMaybe <- liftIO $ LibPQ.exec conn q
275− case resultMaybe of
276− Nothing -> throw $ ResultException
277− "define: LibPQ.exec returned no results"
278− Just result -> K <$> okResult_ result
279−
280−{- | `MonadPQ` is an @mtl@ style constraint, similar to
281−`Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` to
282−
283−* `manipulateParams` runs a `Manipulation` with params from a type
284− with a `ToParams` constraint. It calls `LibPQ.execParams` and
285− doesn't afraid of anything.
286−
287−* `manipulateParams_` is like `manipulateParams` for a returning-free statement.
288−
289−* `manipulate` is like `manipulateParams` for a parameter-free statement.
290−
291−* `manipulate_` is like `manipulate` for a returning-free statement.
292−
293−* `runQueryParams` is like `manipulateParams` for query statements.
294−
295−* `runQuery` is like `runQueryParams` for a parameter-free statement.
296−
297−* `traversePrepared` has the same type signature as a composition of
298− `traverse` and `manipulateParams` but provides an optimization by
299− preparing the statement with `LibPQ.prepare` and then traversing a
300− `Traversable` container with `LibPQ.execPrepared`. The temporary prepared
301− statement is then deallocated.
302−
303−* `forPrepared` is a flipped `traversePrepared`
304−
305−* `traversePrepared_` is like `traversePrepared` but works on `Foldable`
306− containers for a returning-free statement.
307−
308−* `forPrepared_` is a flipped `traversePrepared_`.
309−
310−* `liftPQ` lets you lift actions from `Database.PostgreSQL.LibPQ` that require a connection
311− into your monad.
312−
313−To define an instance, you can minimally define only `manipulateParams`,
314−`traversePrepared`, `traversePrepared_` and `liftPQ`. Monad transformers get
315−a default instance.
316−
317−-}
318−class Monad pq => MonadPQ schemas pq | pq -> schemas where
319− manipulateParams
320− :: (ToParams x params, All OidOfParam params)
321− => Manipulation '[] schemas params ys
322− -- ^ `insertInto`, `update` or `deleteFrom`
323− -> x -> pq (K LibPQ.Result ys)
324− default manipulateParams
325− :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
326− => (ToParams x params, All OidOfParam params)
327− => Manipulation '[] schemas params ys
328− -- ^ `insertInto`, `update` or `deleteFrom`
329− -> x -> pq (K LibPQ.Result ys)
330− manipulateParams manipulation params = lift $
331− manipulateParams manipulation params
332−
333− manipulateParams_
334− :: (ToParams x params, All OidOfParam params)
335− => Manipulation '[] schemas params '[]
336− -- ^ `insertInto`, `update` or `deleteFrom`
337− -> x -> pq ()
338− manipulateParams_ q x = void $ manipulateParams q x
339−
340− manipulate :: Manipulation '[] schemas '[] ys -> pq (K LibPQ.Result ys)
341− manipulate statement = manipulateParams statement ()
342−
343− manipulate_ :: Manipulation '[] schemas '[] '[] -> pq ()
344− manipulate_ = void . manipulate
345−
346− runQueryParams
347− :: (ToParams x params, All OidOfParam params)
348− => Query '[] '[] schemas params ys
349− -- ^ `select` and friends
350− -> x -> pq (K LibPQ.Result ys)
351− runQueryParams = manipulateParams . queryStatement
352−
353− runQuery
354− :: Query '[] '[] schemas '[] ys
355− -- ^ `select` and friends
356− -> pq (K LibPQ.Result ys)
357− runQuery q = runQueryParams q ()
358−
359− traversePrepared
360− :: (ToParams x params, Traversable list, All OidOfParam params)
361− => Manipulation '[] schemas params ys
362− -- ^ `insertInto`, `update`, or `deleteFrom`, and friends
363− -> list x -> pq (list (K LibPQ.Result ys))
364− default traversePrepared
365− :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
366− => (ToParams x params, Traversable list, All OidOfParam params)
367− => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))
368− traversePrepared manipulation params = lift $
369− traversePrepared manipulation params
370−
371− forPrepared
372− :: (ToParams x params, Traversable list, All OidOfParam params)
373− => list x
374− -> Manipulation '[] schemas params ys
375− -- ^ `insertInto`, `update` or `deleteFrom`
376− -> pq (list (K LibPQ.Result ys))
377− forPrepared = flip traversePrepared
378−
379− traversePrepared_
380− :: (ToParams x params, Foldable list, All OidOfParam params)
381− => Manipulation '[] schemas params '[]
382− -- ^ `insertInto`, `update` or `deleteFrom`
383− -> list x -> pq ()
384− default traversePrepared_
385− :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
386− => (ToParams x params, Foldable list, All OidOfParam params)
387− => Manipulation '[] schemas params '[]
388− -- ^ `insertInto`, `update` or `deleteFrom`
389− -> list x -> pq ()
390− traversePrepared_ manipulation params = lift $
391− traversePrepared_ manipulation params
392−
393− forPrepared_
394− :: (ToParams x params, Foldable list, All OidOfParam params)
395− => list x
396− -> Manipulation '[] schemas params '[]
397− -- ^ `insertInto`, `update` or `deleteFrom`
398− -> pq ()
399− forPrepared_ = flip traversePrepared_
400−
401− liftPQ :: (LibPQ.Connection -> IO a) -> pq a
402− default liftPQ
403− :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)
404− => (LibPQ.Connection -> IO a) -> pq a
405− liftPQ = lift . liftPQ
406−
407−instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)
408− => MonadPQ schemas (PQ schemas0 schemas1 io) where
409−
410− manipulateParams
411− (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =
412− PQ $ \ (K conn) -> do
413− let
414− paramSet
415− :: forall param. OidOfParam param
416− => K (Maybe Encoding.Encoding) param
417− -> K (Maybe (LibPQ.Oid, ByteString, LibPQ.Format)) param
418− paramSet (K maybeEncoding) = K $
419− maybeEncoding <&> \encoding ->
420− (oidOfParam @param, encodingBytes encoding, LibPQ.Binary)
421− params'
422− = hcollapse
423− . hcmap (Proxy @OidOfParam) paramSet
424− $ toParams @x @ps params
425− q' = q <> ";"
426− resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary
427− case resultMaybe of
428− Nothing -> throw $ ResultException
429− "manipulateParams: LibPQ.execParams returned no results"
430− Just result -> do
431− okResult_ result
432− return $ K (K result)
433−
434− traversePrepared
435− (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =
436− PQ $ \ (K conn) -> liftIO $ do
437− let
438− temp = "temporary_statement"
439− paramOid :: forall p. OidOfParam p => K LibPQ.Oid p
440− paramOid = K (oidOfParam @p)
441− paramOids :: NP (K LibPQ.Oid) xs
442− paramOids = hcpure (Proxy @OidOfParam) paramOid
443− paramOids' :: [LibPQ.Oid]
444− paramOids' = hcollapse paramOids
445− prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
446− case prepResultMaybe of
447− Nothing -> throw $ ResultException
448− "traversePrepared: LibPQ.prepare returned no results"
449− Just prepResult -> okResult_ prepResult
450− results <- for list $ \ params -> do
451− let
452− toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
453− params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
454− resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
455− case resultMaybe of
456− Nothing -> throw $ ResultException
457− "traversePrepared: LibPQ.execParams returned no results"
458− Just result -> do
459− okResult_ result
460− return $ K result
461− deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
462− case deallocResultMaybe of
463− Nothing -> throw $ ResultException
464− "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
465− Just deallocResult -> okResult_ deallocResult
466− return (K results)
467−
468− traversePrepared_
469− (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =
470− PQ $ \ (K conn) -> liftIO $ do
471− let
472− temp = "temporary_statement"
473− paramOid :: forall p. OidOfParam p => K LibPQ.Oid p
474− paramOid = K (oidOfParam @p)
475− paramOids :: NP (K LibPQ.Oid) xs
476− paramOids = hcpure (Proxy @OidOfParam) paramOid
477− paramOids' :: [LibPQ.Oid]
478− paramOids' = hcollapse paramOids
479− prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')
480− case prepResultMaybe of
481− Nothing -> throw $ ResultException
482− "traversePrepared_: LibPQ.prepare returned no results"
483− Just prepResult -> okResult_ prepResult
484− for_ list $ \ params -> do
485− let
486− toParam' encoding = (encodingBytes encoding, LibPQ.Binary)
487− params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))
488− resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary
489− case resultMaybe of
490− Nothing -> throw $ ResultException
491− "traversePrepared_: LibPQ.execParams returned no results"
492− Just result -> okResult_ result
493− deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")
494− case deallocResultMaybe of
495− Nothing -> throw $ ResultException
496− "traversePrepared: LibPQ.exec DEALLOCATE returned no results"
497− Just deallocResult -> okResult_ deallocResult
498− return (K ())
499−
500− liftPQ pq = PQ $ \ (K conn) -> do
501− y <- liftIO $ pq conn
502− return (K y)
503−
504−instance MonadPQ schemas m => MonadPQ schemas (IdentityT m)
505−instance MonadPQ schemas m => MonadPQ schemas (ReaderT r m)
506−instance MonadPQ schemas m => MonadPQ schemas (Strict.StateT s m)
507−instance MonadPQ schemas m => MonadPQ schemas (Lazy.StateT s m)
508−instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.WriterT w m)
509−instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.WriterT w m)
510−instance MonadPQ schemas m => MonadPQ schemas (MaybeT m)
511−instance MonadPQ schemas m => MonadPQ schemas (ExceptT e m)
512−instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.RWST r w s m)
513−instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.RWST r w s m)
514−instance MonadPQ schemas m => MonadPQ schemas (ContT r m)
515−
516−instance (Monad m, schemas0 ~ schemas1)
517− => Applicative (PQ schemas0 schemas1 m) where
518− pure x = PQ $ \ _conn -> pure (K x)
519− (<*>) = pqAp
520−
521−instance (Monad m, schemas0 ~ schemas1)
522− => Monad (PQ schemas0 schemas1 m) where
523− return = pure
524− (>>=) = flip pqBind
525−
526−instance (Monad m, schemas0 ~ schemas1)
527− => Fail.MonadFail (PQ schemas0 schemas1 m) where
528− fail = Fail.fail
529−
530−instance schemas0 ~ schemas1 => MFunctor (PQ schemas0 schemas1) where
531− hoist f (PQ pq) = PQ (f . pq)
532−
533−instance schemas0 ~ schemas1 => MonadTrans (PQ schemas0 schemas1) where
534− lift m = PQ $ \ _conn -> do
535− x <- m
536− return (K x)
537−
538−instance schemas0 ~ schemas1 => MMonad (PQ schemas0 schemas1) where
539− embed f (PQ pq) = PQ $ \ conn -> do
540− evalPQ (f (pq conn)) conn
541−
542−instance (MonadIO m, schema0 ~ schema1)
543− => MonadIO (PQ schema0 schema1 m) where
544− liftIO = lift . liftIO
545−
546−instance (MonadUnliftIO m, schemas0 ~ schemas1)
547− => MonadUnliftIO (PQ schemas0 schemas1 m) where
548− withRunInIO
549− :: ((forall a . PQ schemas0 schema1 m a -> IO a) -> IO b)
550− -> PQ schemas0 schema1 m b
551− withRunInIO inner = PQ $ \conn ->
552− withRunInIO $ \(run :: (forall x . m x -> IO x)) ->
553− K <$> inner (\pq -> run $ unK <$> unPQ pq conn)
554−
555−-- | Get a row corresponding to a given row number from a `LibPQ.Result`,
556−-- throwing an exception if the row number is out of bounds.
557−getRow
558− :: (FromRow columns y, MonadIO io)
559− => LibPQ.Row
560− -- ^ row number
561− -> K LibPQ.Result columns
562− -- ^ result
563− -> io y
564−getRow r (K result :: K LibPQ.Result columns) = liftIO $ do
565− numRows <- LibPQ.ntuples result
566− when (numRows < r) $ throw $ ResultException $
567− "getRow: expected at least " <> pack (show r) <> "rows but only saw "
568− <> pack (show numRows)
569− let len = fromIntegral (lengthSList (Proxy @columns))
570− row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
571− case fromList row' of
572− Nothing -> throw $ ResultException "getRow: found unexpected length"
573− Just row -> case fromRow @columns row of
574− Left parseError -> throw $ ParseException $ "getRow: " <> parseError
575− Right y -> return y
576−
577−-- | Intended to be used for unfolding in streaming libraries, `nextRow`
578−-- takes a total number of rows (which can be found with `ntuples`)
579−-- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`,
580−-- otherwise returning the row along with the next row number.
581−nextRow
582− :: (FromRow columns y, MonadIO io)
583− => LibPQ.Row -- ^ total number of rows
584− -> K LibPQ.Result columns -- ^ result
585− -> LibPQ.Row -- ^ row number
586− -> io (Maybe (LibPQ.Row,y))
587−nextRow total (K result :: K LibPQ.Result columns) r
588− = liftIO $ if r >= total then return Nothing else do
589− let len = fromIntegral (lengthSList (Proxy @columns))
590− row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
591− case fromList row' of
592− Nothing -> throw $ ResultException "nextRow: found unexpected length"
593− Just row -> case fromRow @columns row of
594− Left parseError -> throw $ ParseException $ "nextRow: " <> parseError
595− Right y -> return $ Just (r+1, y)
596−
597−-- | Get all rows from a `LibPQ.Result`.
598−getRows
599− :: (FromRow columns y, MonadIO io)
600− => K LibPQ.Result columns -- ^ result
601− -> io [y]
602−getRows (K result :: K LibPQ.Result columns) = liftIO $ do
603− let len = fromIntegral (lengthSList (Proxy @columns))
604− numRows <- LibPQ.ntuples result
605− for [0 .. numRows - 1] $ \ r -> do
606− row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]
607− case fromList row' of
608− Nothing -> throw $ ResultException "getRows: found unexpected length"
609− Just row -> case fromRow @columns row of
610− Left parseError -> throw $ ParseException $ "getRows: " <> parseError
611− Right y -> return y
612−
613−-- | Get the first row if possible from a `LibPQ.Result`.
614−firstRow
615− :: (FromRow columns y, MonadIO io)
616− => K LibPQ.Result columns -- ^ result
617− -> io (Maybe y)
618−firstRow (K result :: K LibPQ.Result columns) = liftIO $ do
619− numRows <- LibPQ.ntuples result
620− if numRows <= 0 then return Nothing else do
621− let len = fromIntegral (lengthSList (Proxy @columns))
622− row' <- traverse (LibPQ.getvalue result 0) [0 .. len - 1]
623− case fromList row' of
624− Nothing -> throw $ ResultException "firstRow: found unexpected length"
625− Just row -> case fromRow @columns row of
626− Left parseError -> throw $ ParseException $ "firstRow: " <> parseError
627− Right y -> return $ Just y
628−
629−-- | Lifts actions on results from @LibPQ@.
630−liftResult
631− :: MonadIO io
632− => (LibPQ.Result -> IO x)
633− -> K LibPQ.Result results -> io x
634−liftResult f (K result) = liftIO $ f result
635−
636−-- | Returns the number of rows (tuples) in the query result.
637−ntuples :: MonadIO io => K LibPQ.Result columns -> io LibPQ.Row
638−ntuples = liftResult LibPQ.ntuples
639−
640−-- | Returns the result status of the command.
641−resultStatus :: MonadIO io => K LibPQ.Result results -> io LibPQ.ExecStatus
642−resultStatus = liftResult LibPQ.resultStatus
643−
644−-- | Returns the error message most recently generated by an operation
645−-- on the connection.
646−resultErrorMessage
647− :: MonadIO io => K LibPQ.Result results -> io (Maybe ByteString)
648−resultErrorMessage = liftResult LibPQ.resultErrorMessage
649−
650−-- | Returns the error code most recently generated by an operation
651−-- on the connection.
652−--
653−-- https://www.postgresql.org/docs/current/static/errcodes-appendix.html
654−resultErrorCode
655− :: MonadIO io
656− => K LibPQ.Result results
657− -> io (Maybe ByteString)
658−resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)
659−
660−-- | the state of LibPQ
661−data PQState = PQState
662− { sqlExecStatus :: LibPQ.ExecStatus
663− , sqlStateCode :: Maybe ByteString
664− -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html
665− , sqlErrorMessage :: Maybe ByteString
666− } deriving (Eq, Show)
667−
668−-- | `Exception`s that can be thrown by Squeal.
669−data SquealException
670− = PQException PQState
671− | ResultException Text
672− | ParseException Text
673− deriving (Eq, Show)
674−instance Exception SquealException
675−
676−okResult_ :: MonadIO io => LibPQ.Result -> io ()
677−okResult_ result = liftIO $ do
678− status <- LibPQ.resultStatus result
679− case status of
680− LibPQ.CommandOk -> return ()
681− LibPQ.TuplesOk -> return ()
682− _ -> do
683− stateCode <- LibPQ.resultErrorField result LibPQ.DiagSqlstate
684− msg <- LibPQ.resultErrorMessage result
685− throw . PQException $ PQState status stateCode msg
686−
687−-- | Check if a `LibPQ.Result`'s status is either `LibPQ.CommandOk`
688−-- or `LibPQ.TuplesOk` otherwise `throw` a `PQException`.
689−okResult :: MonadIO io => K LibPQ.Result row -> io ()
690−okResult = okResult_ . unK
691−
692−-- | Catch `SquealException`s.
693−catchSqueal
694− :: MonadUnliftIO io
695− => io a
696− -> (SquealException -> io a) -- ^ handler
697− -> io a
698−catchSqueal = catch
699−
700−-- | Handle `SquealException`s.
701−handleSqueal
702− :: MonadUnliftIO io
703− => (SquealException -> io a) -- ^ handler
704− -> io a -> io a
705−handleSqueal = handle
706−
707−-- | `Either` return a `SquealException` or a result.
708−trySqueal
709− :: MonadUnliftIO io
710− => io a
711− -> io (Either SquealException a)
712−trySqueal = try
squeal-postgresql/src/Squeal/PostgreSQL/Pool.hsdeleted−122
@@ -1,122 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Pool
3−Description: Connection pools
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Connection pools.
9−
10−Typical use case would be to create your pool using `createConnectionPool`
11−and run anything that requires the pool connection with `usingConnectionPool`.
12−
13−Here's a simplified example:
14−
15−>>> import Squeal.PostgreSQL
16−
17−>>> :{
18−do
19− let
20− query :: Query_ (Public '[]) () (Only Char)
21− query = values_ (literal 'a' `as` #fromOnly)
22− pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb" 1 0.5 10
23− chr <- usingConnectionPool pool $ do
24− result <- runQuery query
25− Just (Only a) <- firstRow result
26− return a
27− destroyConnectionPool pool
28− putChar chr
29−:}
30−a
31−-}
32−
33−{-# LANGUAGE
34− DeriveFunctor
35− , FlexibleContexts
36− , FlexibleInstances
37− , InstanceSigs
38− , MultiParamTypeClasses
39− , RankNTypes
40− , ScopedTypeVariables
41− , TypeFamilies
42− , TypeInType
43− , UndecidableInstances
44−#-}
45−
46−module Squeal.PostgreSQL.Pool
47− ( -- * Pools
48− Pool
49− , createConnectionPool
50− , usingConnectionPool
51− , destroyConnectionPool
52− ) where
53−
54−import Data.ByteString
55−import Data.Time
56−import Generics.SOP (K(..), unK)
57−import UnliftIO (MonadUnliftIO (..))
58−import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)
59−
60−import Squeal.PostgreSQL.PQ
61−
62−-- | Create a striped pool of connections.
63−-- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyAllResources` when you're done with the pool so that the connections are freed up as soon as possible.
64−createConnectionPool
65− :: MonadUnliftIO io
66− => ByteString
67− -- ^ The passed string can be empty to use all default parameters, or it can
68− -- contain one or more parameter settings separated by whitespace.
69− -- Each parameter setting is in the form keyword = value. Spaces around the equal
70− -- sign are optional. To write an empty value or a value containing spaces,
71− -- surround it with single quotes, e.g., keyword = 'a value'. Single quotes and
72− -- backslashes within the value must be escaped with a backslash, i.e., ' and \.
73− -> Int
74− -- ^ The number of stripes (distinct sub-pools) to maintain. The smallest acceptable value is 1.
75− -> NominalDiffTime
76− -- ^ Amount of time for which an unused connection is kept open. The smallest acceptable value is 0.5 seconds.
77− -- The elapsed time before destroying a connection may be a little longer than requested, as the reaper thread wakes at 1-second intervals.
78− -> Int
79− -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1.
80− -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.
81− -> io (Pool (K Connection schemas))
82−createConnectionPool conninfo stripes idle maxResrc =
83− createPool (connectdb conninfo) finish stripes idle maxResrc
84−
85−{-|
86−Temporarily take a connection from a `Pool`, perform an action with it,
87−and return it to the pool afterwards.
88−
89−If the pool has an idle connection available, it is used immediately.
90−Otherwise, if the maximum number of connections has not yet been reached,
91−a new connection is created and used.
92−If the maximum number of connections has been reached, this function blocks
93−until a connection becomes available.
94−-}
95−usingConnectionPool
96− :: MonadUnliftIO io
97− => Pool (K Connection schemas) -- ^ pool
98− -> PQ schemas schemas io x -- ^ session
99− -> io x
100−usingConnectionPool pool (PQ session) = unK <$> withResource pool session
101−
102−{- |
103−Destroy all connections in all stripes in the pool.
104−Note that this will ignore any exceptions in the destroy function.
105−
106−This function is useful when you detect that all connections
107−in the pool are broken. For example after a database has been
108−restarted all connections opened before the restart will be broken.
109−In that case it's better to close those connections so that
110−`usingConnectionPool` won't take a broken connection from the pool
111−but will open a new connection instead.
112−
113−Another use-case for this function is that when you know you are done
114−with the pool you can destroy all idle connections immediately
115−instead of waiting on the garbage collector to destroy them,
116−thus freeing up those connections sooner.
117−-}
118−destroyConnectionPool
119− :: MonadUnliftIO io
120− => Pool (K Connection schemas) -- ^ pool
121− -> io ()
122−destroyConnectionPool = destroyAllResources
squeal-postgresql/src/Squeal/PostgreSQL/Query.hsdeleted−1098
@@ -1,1098 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Query
3−Description: Squeal queries
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Squeal queries.
9−-}
10−
11−{-# LANGUAGE
12− ConstraintKinds
13− , DeriveGeneric
14− , FlexibleContexts
15− , FlexibleInstances
16− , GADTs
17− , GeneralizedNewtypeDeriving
18− , LambdaCase
19− , MultiParamTypeClasses
20− , OverloadedLabels
21− , OverloadedStrings
22− , QuantifiedConstraints
23− , ScopedTypeVariables
24− , StandaloneDeriving
25− , TypeApplications
26− , TypeFamilies
27− , TypeInType
28− , TypeOperators
29− , RankNTypes
30− , UndecidableInstances
31− #-}
32−
33−module Squeal.PostgreSQL.Query
34− ( -- * Queries
35− Query_
36− , Query (..)
37− -- ** Select
38− , select
39− , select_
40− , selectDistinct
41− , selectDistinct_
42− , selectDistinctOn
43− , selectDistinctOn_
44− , Selection (..)
45− -- ** Values
46− , values
47− , values_
48− -- ** Set Operations
49− , union
50− , unionAll
51− , intersect
52− , intersectAll
53− , except
54− , exceptAll
55− -- ** With
56− , With (..)
57− , CommonTableExpression (..)
58− , withRecursive
59− -- * Table Expressions
60− , TableExpression (..)
61− , from
62− , where_
63− , groupBy
64− , having
65− , limit
66− , offset
67− -- * From Clauses
68− , FromClause (..)
69− , table
70− , subquery
71− , view
72− , common
73− , crossJoin
74− , innerJoin
75− , leftOuterJoin
76− , rightOuterJoin
77− , fullOuterJoin
78− -- * Grouping
79− , By (..)
80− , GroupByClause (..)
81− , HavingClause (..)
82− ) where
83−
84−import Control.DeepSeq
85−import Data.ByteString (ByteString)
86−import Data.Kind (Type)
87−import Data.String
88−import Data.Word
89−import Generics.SOP hiding (from)
90−import GHC.TypeLits
91−
92−import qualified GHC.Generics as GHC
93−
94−import Squeal.PostgreSQL.Alias
95−import Squeal.PostgreSQL.Expression
96−import Squeal.PostgreSQL.Expression.Logic
97−import Squeal.PostgreSQL.Expression.Sort
98−import Squeal.PostgreSQL.Expression.Window
99−import Squeal.PostgreSQL.List
100−import Squeal.PostgreSQL.PG
101−import Squeal.PostgreSQL.Render
102−import Squeal.PostgreSQL.Schema
103−
104−-- $setup
105−-- >>> import Squeal.PostgreSQL
106−-- >>> import Data.Int (Int32, Int64)
107−-- >>> import Data.Monoid (Sum (..))
108−-- >>> import Data.Text (Text)
109−-- >>> import qualified Generics.SOP as SOP
110−
111−{- |
112−The process of retrieving or the command to retrieve data from
113−a database is called a `Query`.
114−
115−The general `Query` type is parameterized by
116−
117−* @outer :: FromType@ - outer scope for a correlated subquery,
118−* @commons :: FromType@ - scope for all `common` table expressions,
119−* @schemas :: SchemasType@ - scope for all `table`s and `view`s,
120−* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,
121−* @row :: RowType@ - return type of the `Query`.
122−-}
123−newtype Query
124− (outer :: FromType)
125− (commons :: FromType)
126− (schemas :: SchemasType)
127− (params :: [NullityType])
128− (row :: RowType)
129− = UnsafeQuery { renderQuery :: ByteString }
130− deriving (GHC.Generic,Show,Eq,Ord,NFData)
131−instance RenderSQL (Query outer commons schemas params row) where renderSQL = renderQuery
132−
133−{- |
134−The top level `Query_` type is parameterized by a @schemas@ `SchemasType`,
135−against which the query is type-checked, an input @parameters@ Haskell `Type`,
136−and an ouput row Haskell `Type`.
137−
138−A top-level query can be run
139−using `Squeal.PostgreSQL.PQ.runQueryParams`, or if @parameters = ()@
140−using `Squeal.PostgreSQL.PQ.runQuery`.
141−
142−Generally, @parameters@ will be a Haskell tuple or record whose entries
143−may be referenced using positional
144−`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a
145−Haskell record, whose entries will be targeted using overloaded labels.
146−
147−Let's see some examples of queries.
148−
149−>>> :set -XDeriveAnyClass -XDerivingStrategies
150−>>> :{
151−data Row a b = Row { col1 :: a, col2 :: b }
152− deriving stock (GHC.Generic)
153− deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
154−:}
155−
156−simple query:
157−
158−>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]
159−>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
160−>>> :{
161−let
162− query :: Query_ (Public Schema) () (Row Int32 Int32)
163− query = select Star (from (table #tab))
164−in printSQL query
165−:}
166−SELECT * FROM "tab" AS "tab"
167−
168−restricted query:
169−
170−>>> :{
171−let
172− query :: Query_ (Public Schema) () (Row Int32 Int32)
173− query =
174− select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2)
175− ( from (table #tab)
176− & where_ (#col1 .> #col2)
177− & where_ (#col2 .> 0) )
178−in printSQL query
179−:}
180−SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))
181−
182−subquery:
183−
184−>>> :{
185−let
186− query :: Query_ (Public Schema) () (Row Int32 Int32)
187− query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))
188−in printSQL query
189−:}
190−SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub"
191−
192−limits and offsets:
193−
194−>>> :{
195−let
196− query :: Query_ (Public Schema) () (Row Int32 Int32)
197− query = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)
198−in printSQL query
199−:}
200−SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4
201−
202−parameterized query:
203−
204−>>> :{
205−let
206− query :: Query_ (Public Schema) (Only Int32) (Row Int32 Int32)
207− query = select Star (from (table #tab) & where_ (#col1 .> param @1))
208−in printSQL query
209−:}
210−SELECT * FROM "tab" AS "tab" WHERE ("col1" > ($1 :: int4))
211−
212−aggregation query:
213−
214−>>> :{
215−let
216− query :: Query_ (Public Schema) () (Row Int64 Int32)
217− query =
218− select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2)
219− ( from (table (#tab `as` #table1))
220− & groupBy #col1
221− & having (sum_ (Distinct #col2) .> 1) )
222−in printSQL query
223−:}
224−SELECT COALESCE(sum(ALL "col2"), 0) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > 1)
225−
226−sorted query:
227−
228−>>> :{
229−let
230− query :: Query_ (Public Schema) () (Row Int32 Int32)
231− query = select Star (from (table #tab) & orderBy [#col1 & Asc])
232−in printSQL query
233−:}
234−SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC
235−
236−joins:
237−
238−>>> :{
239−type OrdersColumns =
240− '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4
241− , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4
242− , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4
243− , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4 ]
244−:}
245−
246−>>> :{
247−type OrdersConstraints =
248− '["pk_orders" ::: PrimaryKey '["id"]
249− ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]
250− ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"] ]
251−:}
252−
253−>>> type NamesColumns = '["id" ::: 'NoDef :=> 'NotNull 'PGint4, "name" ::: 'NoDef :=> 'NotNull 'PGtext]
254−>>> type CustomersConstraints = '["pk_customers" ::: PrimaryKey '["id"]]
255−>>> type ShippersConstraints = '["pk_shippers" ::: PrimaryKey '["id"]]
256−>>> :{
257−type OrdersSchema =
258− '[ "orders" ::: 'Table (OrdersConstraints :=> OrdersColumns)
259− , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns)
260− , "shippers" ::: 'Table (ShippersConstraints :=> NamesColumns) ]
261−:}
262−
263−>>> :{
264−data Order = Order
265− { price :: Float
266− , customerName :: Text
267− , shipperName :: Text
268− } deriving GHC.Generic
269−instance SOP.Generic Order
270−instance SOP.HasDatatypeInfo Order
271−:}
272−
273−>>> :{
274−let
275− query :: Query_ (Public OrdersSchema) () Order
276− query = select_
277− ( #o ! #price `as` #price :*
278− #c ! #name `as` #customerName :*
279− #s ! #name `as` #shipperName )
280− ( from (table (#orders `as` #o)
281− & innerJoin (table (#customers `as` #c))
282− (#o ! #customer_id .== #c ! #id)
283− & innerJoin (table (#shippers `as` #s))
284− (#o ! #shipper_id .== #s ! #id)) )
285−in printSQL query
286−:}
287−SELECT "o"."price" AS "price", "c"."name" AS "customerName", "s"."name" AS "shipperName" FROM "orders" AS "o" INNER JOIN "customers" AS "c" ON ("o"."customer_id" = "c"."id") INNER JOIN "shippers" AS "s" ON ("o"."shipper_id" = "s"."id")
288−
289−self-join:
290−
291−>>> :{
292−let
293− query :: Query_ (Public Schema) () (Row Int32 Int32)
294− query = select
295− (#t1 & DotStar)
296− (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))
297−in printSQL query
298−:}
299−SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2"
300−
301−value queries:
302−
303−>>> :{
304−let
305− query :: Query_ schemas () (Row String Bool)
306− query = values
307− ("true" `as` #col1 :* true `as` #col2)
308− ["false" `as` #col1 :* false `as` #col2]
309−in printSQL query
310−:}
311−SELECT * FROM (VALUES (E'true', TRUE), (E'false', FALSE)) AS t ("col1", "col2")
312−
313−set operations:
314−
315−>>> :{
316−let
317− query :: Query_ (Public Schema) () (Row Int32 Int32)
318− query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))
319−in printSQL query
320−:}
321−(SELECT * FROM "tab" AS "tab") UNION ALL (SELECT * FROM "tab" AS "tab")
322−
323−with queries:
324−
325−>>> :{
326−let
327− query :: Query_ (Public Schema) () (Row Int32 Int32)
328− query = with (
329− select Star (from (table #tab)) `as` #cte1 :>>
330− select Star (from (common #cte1)) `as` #cte2
331− ) (select Star (from (common #cte2)))
332−in printSQL query
333−:}
334−WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2"
335−
336−window function queries
337−
338−>>> :{
339−let
340− query :: Query_ (Public Schema) () (Row Int32 Int64)
341− query = select
342− (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))
343− (from (table #tab))
344−in printSQL query
345−:}
346−SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "col2" FROM "tab" AS "tab"
347−
348−correlated subqueries
349−
350−>>> :{
351−let
352− query :: Query_ (Public Schema) () (Only Int32)
353− query =
354− select (#col1 `as` #fromOnly) (from (table (#tab `as` #t1))
355− & where_ (exists (
356− select Star (from (table (#tab `as` #t2))
357− & where_ (#t2 ! #col2 .== #t1 ! #col1)))))
358−in printSQL query
359−:}
360−SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))
361−
362−-}
363−type family Query_
364− (schemas :: SchemasType)
365− (parameters :: Type)
366− (row :: Type) where
367− Query_ schemas params row =
368− Query '[] '[] schemas (TuplePG params) (RowPG row)
369−
370−-- | The results of two queries can be combined using the set operation
371−-- `union`. Duplicate rows are eliminated.
372−union
373− :: Query outer commons schemas params columns
374− -> Query outer commons schemas params columns
375− -> Query outer commons schemas params columns
376−q1 `union` q2 = UnsafeQuery $
377− parenthesized (renderSQL q1)
378− <+> "UNION"
379− <+> parenthesized (renderSQL q2)
380−
381−-- | The results of two queries can be combined using the set operation
382−-- `unionAll`, the disjoint union. Duplicate rows are retained.
383−unionAll
384− :: Query outer commons schemas params columns
385− -> Query outer commons schemas params columns
386− -> Query outer commons schemas params columns
387−q1 `unionAll` q2 = UnsafeQuery $
388− parenthesized (renderSQL q1)
389− <+> "UNION" <+> "ALL"
390− <+> parenthesized (renderSQL q2)
391−
392−-- | The results of two queries can be combined using the set operation
393−-- `intersect`, the intersection. Duplicate rows are eliminated.
394−intersect
395− :: Query outer commons schemas params columns
396− -> Query outer commons schemas params columns
397− -> Query outer commons schemas params columns
398−q1 `intersect` q2 = UnsafeQuery $
399− parenthesized (renderSQL q1)
400− <+> "INTERSECT"
401− <+> parenthesized (renderSQL q2)
402−
403−-- | The results of two queries can be combined using the set operation
404−-- `intersectAll`, the intersection. Duplicate rows are retained.
405−intersectAll
406− :: Query outer commons schemas params columns
407− -> Query outer commons schemas params columns
408− -> Query outer commons schemas params columns
409−q1 `intersectAll` q2 = UnsafeQuery $
410− parenthesized (renderSQL q1)
411− <+> "INTERSECT" <+> "ALL"
412− <+> parenthesized (renderSQL q2)
413−
414−-- | The results of two queries can be combined using the set operation
415−-- `except`, the set difference. Duplicate rows are eliminated.
416−except
417− :: Query outer commons schemas params columns
418− -> Query outer commons schemas params columns
419− -> Query outer commons schemas params columns
420−q1 `except` q2 = UnsafeQuery $
421− parenthesized (renderSQL q1)
422− <+> "EXCEPT"
423− <+> parenthesized (renderSQL q2)
424−
425−-- | The results of two queries can be combined using the set operation
426−-- `exceptAll`, the set difference. Duplicate rows are retained.
427−exceptAll
428− :: Query outer commons schemas params columns
429− -> Query outer commons schemas params columns
430− -> Query outer commons schemas params columns
431−q1 `exceptAll` q2 = UnsafeQuery $
432− parenthesized (renderSQL q1)
433− <+> "EXCEPT" <+> "ALL"
434− <+> parenthesized (renderSQL q2)
435−
436−{-----------------------------------------
437−SELECT queries
438−-----------------------------------------}
439−
440−{- | The simplest kinds of `Selection` are `Star` and `DotStar` which
441−emits all columns that a `TableExpression` produces. A select `List`
442−is a list of `Expression`s. A `Selection` could be a list of
443−`WindowFunction`s `Over` `WindowDefinition`. `Additional` `Selection`s can
444−be selected with `Also`.
445−-}
446−data Selection outer commons grp schemas params from row where
447− Star
448− :: HasUnique tab from row
449− => Selection outer commons 'Ungrouped schemas params from row
450− -- ^ `HasUnique` table in the `FromClause`
451− DotStar
452− :: Has tab from row
453− => Alias tab
454− -- ^ `Has` table with `Alias`
455− -> Selection outer commons 'Ungrouped schemas params from row
456− List
457− :: SListI row
458− => NP (Aliased (Expression outer commons grp schemas params from)) row
459− -- ^ `NP` list of `Aliased` `Expression`s
460− -> Selection outer commons grp schemas params from row
461− Over
462− :: SListI row
463− => NP (Aliased (WindowFunction outer commons grp schemas params from)) row
464− -- ^ `NP` list of `Aliased` `WindowFunction`s
465− -> WindowDefinition outer commons grp schemas params from
466− -> Selection outer commons grp schemas params from row
467− Also
468− :: Selection outer commons grp schemas params from right
469− -- ^ `Additional` `Selection`
470− -> Selection outer commons grp schemas params from left
471− -> Selection outer commons grp schemas params from (Join left right)
472−instance Additional (Selection outer commons grp schemas params from) where
473− also = Also
474−instance (KnownSymbol col, row ~ '[col ::: ty])
475− => Aliasable col
476− (Expression outer commons grp schemas params from ty)
477− (Selection outer commons grp schemas params from row) where
478− expr `as` col = List (expr `as` col)
479−instance (Has tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty])
480− => IsQualified tab col
481− (Selection outer commons 'Ungrouped schemas params from row1) where
482− tab ! col = tab ! col `as` col
483−instance
484− ( Has tab (Join outer from) row0
485− , Has col row0 ty
486− , row1 ~ '[col ::: ty]
487− , GroupedBy tab col bys )
488− => IsQualified tab col
489− (Selection outer commons ('Grouped bys) schemas params from row1) where
490− tab ! col = tab ! col `as` col
491−instance (HasUnique tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty])
492− => IsLabel col
493− (Selection outer commons 'Ungrouped schemas params from row1) where
494− fromLabel = fromLabel @col `as` Alias
495−instance
496− ( HasUnique tab (Join outer from) row0
497− , Has col row0 ty
498− , row1 ~ '[col ::: ty]
499− , GroupedBy tab col bys )
500− => IsLabel col
501− (Selection outer commons ('Grouped bys) schemas params from row1) where
502− fromLabel = fromLabel @col `as` Alias
503−
504−instance RenderSQL (Selection outer commons grp schemas params from row) where
505− renderSQL = \case
506− List list -> renderCommaSeparated (renderAliased renderSQL) list
507− Star -> "*"
508− DotStar tab -> renderSQL tab <> ".*"
509− Also right left -> renderSQL left <> ", " <> renderSQL right
510− Over winFns winDef ->
511− let
512− renderOver
513− :: Aliased (WindowFunction outer commons grp schemas params from) field
514− -> ByteString
515− renderOver (winFn `As` col) = renderSQL winFn
516− <+> "OVER" <+> parenthesized (renderSQL winDef)
517− <+> "AS" <+> renderSQL col
518− in
519− renderCommaSeparated renderOver winFns
520−
521−instance IsString
522− (Selection outer commons grp schemas params from '["fromOnly" ::: 'NotNull 'PGtext]) where
523− fromString str = fromString str `as` Alias
524−
525−-- | the `TableExpression` in the `select` command constructs an intermediate
526−-- virtual table by possibly combining tables, views, eliminating rows,
527−-- grouping, etc. This table is finally passed on to processing by
528−-- the select list. The `Selection` determines which columns of
529−-- the intermediate table are actually output.
530−select
531− :: (SListI row, row ~ (x ': xs))
532− => Selection outer commons grp schemas params from row
533− -- ^ selection
534− -> TableExpression outer commons grp schemas params from
535− -- ^ intermediate virtual table
536− -> Query outer commons schemas params row
537−select selection tabexpr = UnsafeQuery $
538− "SELECT"
539− <+> renderSQL selection
540− <+> renderSQL tabexpr
541−
542−-- | Like `select` but takes an `NP` list of `Expression`s instead
543−-- of a general `Selection`.
544−select_
545− :: (SListI row, row ~ (x ': xs))
546− => NP (Aliased (Expression outer commons grp schemas params from)) row
547− -- ^ select list
548− -> TableExpression outer commons grp schemas params from
549− -- ^ intermediate virtual table
550− -> Query outer commons schemas params row
551−select_ = select . List
552−
553−-- | After the select list has been processed, the result table can
554−-- be subject to the elimination of duplicate rows using `selectDistinct`.
555−selectDistinct
556− :: (SListI columns, columns ~ (col ': cols))
557− => Selection outer commons grp schemas params from columns
558− -- ^ selection
559− -> TableExpression outer commons grp schemas params from
560− -- ^ intermediate virtual table
561− -> Query outer commons schemas params columns
562−selectDistinct selection tabexpr = UnsafeQuery $
563− "SELECT DISTINCT"
564− <+> renderSQL selection
565− <+> renderSQL tabexpr
566−
567−-- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead
568−-- of a general `Selection`.
569−selectDistinct_
570− :: (SListI columns, columns ~ (col ': cols))
571− => NP (Aliased (Expression outer commons grp schemas params from)) columns
572− -- ^ select list
573− -> TableExpression outer commons grp schemas params from
574− -- ^ intermediate virtual table
575− -> Query outer commons schemas params columns
576−selectDistinct_ = selectDistinct . List
577−
578−{-|
579−`selectDistinctOn` keeps only the first row of each set of rows where
580−the given expressions evaluate to equal. The DISTINCT ON expressions are
581−interpreted using the same rules as for ORDER BY. ORDER BY is used to
582−ensure that the desired row appears first.
583−
584−The DISTINCT ON expression(s) must match the leftmost ORDER BY expression(s).
585−The ORDER BY clause will normally contain additional expression(s) that
586−determine the desired precedence of rows within each DISTINCT ON group.
587−
588−In order to guarantee they match and reduce redundancy, this function
589−will prepend the The DISTINCT ON expressions to the ORDER BY clause.
590−-}
591−selectDistinctOn
592− :: (SListI columns, columns ~ (col ': cols))
593− => [SortExpression outer commons grp schemas params from]
594− -- ^ DISTINCT ON expression(s) and prepended to ORDER BY clause
595− -> Selection outer commons grp schemas params from columns
596− -- ^ selection
597− -> TableExpression outer commons grp schemas params from
598− -- ^ intermediate virtual table
599− -> Query outer commons schemas params columns
600−selectDistinctOn distincts selection tab = UnsafeQuery $
601− "SELECT DISTINCT ON"
602− <+> parenthesized (commaSeparated (renderDistinctOn <$> distincts))
603− <+> renderSQL selection
604− <+> renderSQL (tab {orderByClause = distincts <> orderByClause tab})
605− where
606− renderDistinctOn = \case
607− Asc expression -> renderSQL expression
608− Desc expression -> renderSQL expression
609− AscNullsFirst expression -> renderSQL expression
610− DescNullsFirst expression -> renderSQL expression
611− AscNullsLast expression -> renderSQL expression
612− DescNullsLast expression -> renderSQL expression
613−
614−-- | Like `selectDistinctOn` but takes an `NP` list of `Expression`s instead
615−-- of a general `Selection`.
616−selectDistinctOn_
617− :: (SListI columns, columns ~ (col ': cols))
618− => [SortExpression outer commons grp schemas params from]
619− -- ^ distinct on and return the first row in ordering
620− -> NP (Aliased (Expression outer commons grp schemas params from)) columns
621− -- ^ selection
622− -> TableExpression outer commons grp schemas params from
623− -- ^ intermediate virtual table
624− -> Query outer commons schemas params columns
625−selectDistinctOn_ distincts = selectDistinctOn distincts . List
626−
627−-- | `values` computes a row value or set of row values
628−-- specified by value expressions. It is most commonly used
629−-- to generate a “constant table” within a larger command,
630−-- but it can be used on its own.
631−--
632−-- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]
633−-- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query outer commons schemas '[] Row
634−-- >>> printSQL query
635−-- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b")
636−values
637− :: SListI cols
638− => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols
639− -> [NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols]
640− -- ^ When more than one row is specified, all the rows must
641− -- must have the same number of elements
642− -> Query outer commons schemas params cols
643−values rw rws = UnsafeQuery $ "SELECT * FROM"
644− <+> parenthesized (
645− "VALUES"
646− <+> commaSeparated
647− ( parenthesized
648− . renderCommaSeparated renderValuePart <$> rw:rws )
649− ) <+> "AS t"
650− <+> parenthesized (renderCommaSeparated renderAliasPart rw)
651− where
652− renderAliasPart, renderValuePart
653− :: Aliased (Expression outer commons 'Ungrouped schemas params '[] ) ty -> ByteString
654− renderAliasPart (_ `As` name) = renderSQL name
655− renderValuePart (value `As` _) = renderSQL value
656−
657−-- | `values_` computes a row value or set of row values
658−-- specified by value expressions.
659−values_
660− :: SListI cols
661− => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols
662− -- ^ one row of values
663− -> Query outer commons schemas params cols
664−values_ rw = values rw []
665−
666−{-----------------------------------------
667−Table Expressions
668−-----------------------------------------}
669−
670−-- | A `TableExpression` computes a table. The table expression contains
671−-- a `fromClause` that is optionally followed by a `whereClause`,
672−-- `groupByClause`, `havingClause`, `orderByClause`, `limitClause`
673−-- and `offsetClause`s. Trivial table expressions simply refer
674−-- to a table on disk, a so-called base table, but more complex expressions
675−-- can be used to modify or combine base tables in various ways.
676−data TableExpression
677− (outer :: FromType)
678− (commons :: FromType)
679− (grp :: Grouping)
680− (schemas :: SchemasType)
681− (params :: [NullityType])
682− (from :: FromType)
683− = TableExpression
684− { fromClause :: FromClause outer commons schemas params from
685− -- ^ A table reference that can be a table name, or a derived table such
686− -- as a subquery, a @JOIN@ construct, or complex combinations of these.
687− , whereClause :: [Condition outer commons 'Ungrouped schemas params from]
688− -- ^ optional search coditions, combined with `.&&`. After the processing
689− -- of the `fromClause` is done, each row of the derived virtual table
690− -- is checked against the search condition. If the result of the
691− -- condition is true, the row is kept in the output table,
692− -- otherwise it is discarded. The search condition typically references
693− -- at least one column of the table generated in the `fromClause`;
694− -- this is not required, but otherwise the WHERE clause will
695− -- be fairly useless.
696− , groupByClause :: GroupByClause grp from
697− -- ^ The `groupByClause` is used to group together those rows in a table
698− -- that have the same values in all the columns listed. The order in which
699− -- the columns are listed does not matter. The effect is to combine each
700− -- set of rows having common values into one group row that represents all
701− -- rows in the group. This is done to eliminate redundancy in the output
702− -- and/or compute aggregates that apply to these groups.
703− , havingClause :: HavingClause outer commons grp schemas params from
704− -- ^ If a table has been grouped using `groupBy`, but only certain groups
705− -- are of interest, the `havingClause` can be used, much like a
706− -- `whereClause`, to eliminate groups from the result. Expressions in the
707− -- `havingClause` can refer both to grouped expressions and to ungrouped
708− -- expressions (which necessarily involve an aggregate function).
709− , orderByClause :: [SortExpression outer commons grp schemas params from]
710− -- ^ The `orderByClause` is for optional sorting. When more than one
711− -- `SortExpression` is specified, the later (right) values are used to sort
712− -- rows that are equal according to the earlier (left) values.
713− , limitClause :: [Word64]
714− -- ^ The `limitClause` is combined with `min` to give a limit count
715− -- if nonempty. If a limit count is given, no more than that many rows
716− -- will be returned (but possibly fewer, if the query itself yields
717− -- fewer rows).
718− , offsetClause :: [Word64]
719− -- ^ The `offsetClause` is combined with `Prelude.+` to give an offset count
720− -- if nonempty. The offset count says to skip that many rows before
721− -- beginning to return rows. The rows are skipped before the limit count
722− -- is applied.
723− } deriving (GHC.Generic)
724−
725−-- | Render a `TableExpression`
726−instance RenderSQL (TableExpression outer commons grp schemas params from) where
727− renderSQL
728− (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat
729− [ "FROM ", renderSQL frm'
730− , renderWheres whs'
731− , renderSQL grps'
732− , renderSQL hvs'
733− , renderOrderByClause srts'
734− , renderLimits lims'
735− , renderOffsets offs' ]
736− where
737− renderWheres = \case
738− [] -> ""
739− wh:[] -> " WHERE" <+> renderSQL wh
740− wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)
741− renderOrderByClause = \case
742− [] -> ""
743− srts -> " ORDER BY"
744− <+> commaSeparated (renderSQL <$> srts)
745− renderLimits = \case
746− [] -> ""
747− lims -> " LIMIT" <+> fromString (show (minimum lims))
748− renderOffsets = \case
749− [] -> ""
750− offs -> " OFFSET" <+> fromString (show (sum offs))
751−
752−-- | A `from` generates a `TableExpression` from a table reference that can be
753−-- a table name, or a derived table such as a subquery, a JOIN construct,
754−-- or complex combinations of these. A `from` may be transformed by `where_`,
755−-- `groupBy`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator
756−-- to match the left-to-right sequencing of their placement in SQL.
757−from
758− :: FromClause outer commons schemas params from -- ^ table reference
759− -> TableExpression outer commons 'Ungrouped schemas params from
760−from tab = TableExpression tab [] noGroups NoHaving [] [] []
761−
762−-- | A `where_` is an endomorphism of `TableExpression`s which adds a
763−-- search condition to the `whereClause`.
764−where_
765− :: Condition outer commons 'Ungrouped schemas params from -- ^ filtering condition
766− -> TableExpression outer commons grp schemas params from
767− -> TableExpression outer commons grp schemas params from
768−where_ wh rels = rels {whereClause = wh : whereClause rels}
769−
770−-- | A `groupBy` is a transformation of `TableExpression`s which switches
771−-- its `Grouping` from `Ungrouped` to `Grouped`. Use @groupBy Nil@ to perform
772−-- a "grand total" aggregation query.
773−groupBy
774− :: SListI bys
775− => NP (By from) bys -- ^ grouped columns
776− -> TableExpression outer commons 'Ungrouped schemas params from
777− -> TableExpression outer commons ('Grouped bys) schemas params from
778−groupBy bys rels = TableExpression
779− { fromClause = fromClause rels
780− , whereClause = whereClause rels
781− , groupByClause = group bys
782− , havingClause = Having []
783− , orderByClause = []
784− , limitClause = limitClause rels
785− , offsetClause = offsetClause rels
786− }
787−
788−-- | A `having` is an endomorphism of `TableExpression`s which adds a
789−-- search condition to the `havingClause`.
790−having
791− :: Condition outer commons ('Grouped bys) schemas params from -- ^ having condition
792− -> TableExpression outer commons ('Grouped bys) schemas params from
793− -> TableExpression outer commons ('Grouped bys) schemas params from
794−having hv rels = rels
795− { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) }
796−
797−instance OrderBy TableExpression where
798− orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}
799−
800−-- | A `limit` is an endomorphism of `TableExpression`s which adds to the
801−-- `limitClause`.
802−limit
803− :: Word64 -- ^ limit parameter
804− -> TableExpression outer commons grp schemas params from
805− -> TableExpression outer commons grp schemas params from
806−limit lim rels = rels {limitClause = lim : limitClause rels}
807−
808−-- | An `offset` is an endomorphism of `TableExpression`s which adds to the
809−-- `offsetClause`.
810−offset
811− :: Word64 -- ^ offset parameter
812− -> TableExpression outer commons grp schemas params from
813− -> TableExpression outer commons grp schemas params from
814−offset off rels = rels {offsetClause = off : offsetClause rels}
815−
816−{-----------------------------------------
817−FROM clauses
818−-----------------------------------------}
819−
820−{- |
821−A `FromClause` can be a table name, or a derived table such
822−as a subquery, a @JOIN@ construct, or complex combinations of these.
823−-}
824−newtype FromClause outer commons schemas params from
825− = UnsafeFromClause { renderFromClause :: ByteString }
826− deriving (GHC.Generic,Show,Eq,Ord,NFData)
827−instance RenderSQL (FromClause outer commons schemas params from) where
828− renderSQL = renderFromClause
829−
830−-- | A real `table` is a table from the database.
831−table
832− :: (Has sch schemas schema, Has tab schema ('Table table))
833− => Aliased (QualifiedAlias sch) (alias ::: tab)
834− -> FromClause outer commons schemas params '[alias ::: TableToRow table]
835−table (tab `As` alias) = UnsafeFromClause $
836− renderSQL tab <+> "AS" <+> renderSQL alias
837−
838−-- | `subquery` derives a table from a `Query`.
839−subquery
840− :: Aliased (Query outer commons schemas params) query
841− -> FromClause outer commons schemas params '[query]
842−subquery = UnsafeFromClause . renderAliased (parenthesized . renderSQL)
843−
844−-- | `view` derives a table from a `View`.
845−view
846− :: (Has sch schemas schema, Has vw schema ('View view))
847− => Aliased (QualifiedAlias sch) (alias ::: vw)
848− -> FromClause outer commons schemas params '[alias ::: view]
849−view (vw `As` alias) = UnsafeFromClause $
850− renderSQL vw <+> "AS" <+> renderSQL alias
851−
852−-- | `common` derives a table from a common table expression.
853−common
854− :: Has cte commons common
855− => Aliased Alias (alias ::: cte)
856− -> FromClause outer commons schemas params '[alias ::: common]
857−common (cte `As` alias) = UnsafeFromClause $
858− renderSQL cte <+> "AS" <+> renderSQL alias
859−
860−instance Additional (FromClause outer commons schemas params) where
861− also right left = UnsafeFromClause $
862− renderSQL left <> ", " <> renderSQL right
863−
864−{- |
865−@left & crossJoin right@. For every possible combination of rows from
866−@left@ and @right@ (i.e., a Cartesian product), the joined table will contain
867−a row consisting of all columns in @left@ followed by all columns in @right@.
868−If the tables have @n@ and @m@ rows respectively, the joined table will
869−have @n * m@ rows.
870−-}
871−crossJoin
872− :: FromClause outer commons schemas params right
873− -- ^ right
874− -> FromClause outer commons schemas params left
875− -- ^ left
876− -> FromClause outer commons schemas params (Join left right)
877−crossJoin right left = UnsafeFromClause $
878− renderSQL left <+> "CROSS JOIN" <+> renderSQL right
879−
880−{- | @left & innerJoin right on@. The joined table is filtered by
881−the @on@ condition.
882−-}
883−innerJoin
884− :: FromClause outer commons schemas params right
885− -- ^ right
886− -> Condition outer commons 'Ungrouped schemas params (Join left right)
887− -- ^ @on@ condition
888− -> FromClause outer commons schemas params left
889− -- ^ left
890− -> FromClause outer commons schemas params (Join left right)
891−innerJoin right on left = UnsafeFromClause $
892− renderSQL left <+> "INNER JOIN" <+> renderSQL right
893− <+> "ON" <+> renderSQL on
894−
895−{- | @left & leftOuterJoin right on@. First, an inner join is performed.
896− Then, for each row in @left@ that does not satisfy the @on@ condition with
897− any row in @right@, a joined row is added with null values in columns of @right@.
898− Thus, the joined table always has at least one row for each row in @left@.
899−-}
900−leftOuterJoin
901− :: FromClause outer commons schemas params right
902− -- ^ right
903− -> Condition outer commons 'Ungrouped schemas params (Join left right)
904− -- ^ @on@ condition
905− -> FromClause outer commons schemas params left
906− -- ^ left
907− -> FromClause outer commons schemas params (Join left (NullifyFrom right))
908−leftOuterJoin right on left = UnsafeFromClause $
909− renderSQL left <+> "LEFT OUTER JOIN" <+> renderSQL right
910− <+> "ON" <+> renderSQL on
911−
912−{- | @left & rightOuterJoin right on@. First, an inner join is performed.
913− Then, for each row in @right@ that does not satisfy the @on@ condition with
914− any row in @left@, a joined row is added with null values in columns of @left@.
915− This is the converse of a left join: the result table will always
916− have a row for each row in @right@.
917−-}
918−rightOuterJoin
919− :: FromClause outer commons schemas params right
920− -- ^ right
921− -> Condition outer commons 'Ungrouped schemas params (Join left right)
922− -- ^ @on@ condition
923− -> FromClause outer commons schemas params left
924− -- ^ left
925− -> FromClause outer commons schemas params (Join (NullifyFrom left) right)
926−rightOuterJoin right on left = UnsafeFromClause $
927− renderSQL left <+> "RIGHT OUTER JOIN" <+> renderSQL right
928− <+> "ON" <+> renderSQL on
929−
930−{- | @left & fullOuterJoin right on@. First, an inner join is performed.
931− Then, for each row in @left@ that does not satisfy the @on@ condition with
932− any row in @right@, a joined row is added with null values in columns of @right@.
933− Also, for each row of @right@ that does not satisfy the join condition
934− with any row in @left@, a joined row with null values in the columns of @left@
935− is added.
936−-}
937−fullOuterJoin
938− :: FromClause outer commons schemas params right
939− -- ^ right
940− -> Condition outer commons 'Ungrouped schemas params (Join left right)
941− -- ^ @on@ condition
942− -> FromClause outer commons schemas params left
943− -- ^ left
944− -> FromClause outer commons schemas params
945− (Join (NullifyFrom left) (NullifyFrom right))
946−fullOuterJoin right on left = UnsafeFromClause $
947− renderSQL left <+> "FULL OUTER JOIN" <+> renderSQL right
948− <+> "ON" <+> renderSQL on
949−
950−{-----------------------------------------
951−Grouping
952−-----------------------------------------}
953−
954−-- | `By`s are used in `groupBy` to reference a list of columns which are then
955−-- used to group together those rows in a table that have the same values
956−-- in all the columns listed. @By \#col@ will reference an unambiguous
957−-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table
958−-- qualified column @tab.col@.
959−data By
960− (from :: FromType)
961− (by :: (Symbol,Symbol)) where
962− By1
963− :: (HasUnique table from columns, Has column columns ty)
964− => Alias column
965− -> By from '(table, column)
966− By2
967− :: (Has table from columns, Has column columns ty)
968− => Alias table
969− -> Alias column
970− -> By from '(table, column)
971−deriving instance Show (By from by)
972−deriving instance Eq (By from by)
973−deriving instance Ord (By from by)
974−instance RenderSQL (By from by) where
975− renderSQL = \case
976− By1 column -> renderSQL column
977− By2 rel column -> renderSQL rel <> "." <> renderSQL column
978−
979−instance (HasUnique rel rels cols, Has col cols ty, by ~ '(rel, col))
980− => IsLabel col (By rels by) where fromLabel = By1 fromLabel
981−instance (HasUnique rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])
982− => IsLabel col (NP (By rels) bys) where fromLabel = By1 fromLabel :* Nil
983−instance (Has rel rels cols, Has col cols ty, by ~ '(rel, col))
984− => IsQualified rel col (By rels by) where (!) = By2
985−instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])
986− => IsQualified rel col (NP (By rels) bys) where
987− rel ! col = By2 rel col :* Nil
988−
989−-- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.
990−-- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`.
991−-- @NoGroups@ is distinguised from @Group Nil@ since no aggregation can be
992−-- done on @NoGroups@ while all output `Expression`s must be aggregated
993−-- in @Group Nil@. In general, all output `Expression`s in the
994−-- complement of @bys@ must be aggregated in @Group bys@.
995−newtype GroupByClause grp from = UnsafeGroupByClause
996− { renderGroupByClause :: ByteString }
997− deriving (GHC.Generic,Show,Eq,Ord,NFData)
998−instance RenderSQL (GroupByClause grp from) where
999− renderSQL = renderGroupByClause
1000−noGroups :: GroupByClause 'Ungrouped from
1001−noGroups = UnsafeGroupByClause ""
1002−group
1003− :: SListI bys
1004− => NP (By from) bys
1005− -> GroupByClause ('Grouped bys) from
1006−group bys = UnsafeGroupByClause $ case bys of
1007− Nil -> ""
1008− bys' -> " GROUP BY" <+> renderCommaSeparated renderSQL bys'
1009−
1010−-- | A `HavingClause` is used to eliminate groups that are not of interest.
1011−-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`
1012−-- `TableExpression` must use `Having` whose conditions are combined with
1013−-- `.&&`.
1014−data HavingClause outer commons grp schemas params from where
1015− NoHaving :: HavingClause outer commons 'Ungrouped schemas params from
1016− Having
1017− :: [Condition outer commons ('Grouped bys) schemas params from]
1018− -> HavingClause outer commons ('Grouped bys) schemas params from
1019−deriving instance Show (HavingClause outer commons grp schemas params from)
1020−deriving instance Eq (HavingClause outer commons grp schemas params from)
1021−deriving instance Ord (HavingClause outer commons grp schemas params from)
1022−
1023−-- | Render a `HavingClause`.
1024−instance RenderSQL (HavingClause outer commons grp schemas params from) where
1025− renderSQL = \case
1026− NoHaving -> ""
1027− Having [] -> ""
1028− Having conditions ->
1029− " HAVING" <+> commaSeparated (renderSQL <$> conditions)
1030−
1031−-- | A `CommonTableExpression` is an auxiliary statement in a `with` clause.
1032−data CommonTableExpression statement
1033− (schemas :: SchemasType)
1034− (params :: [NullityType])
1035− (commons0 :: FromType)
1036− (commons1 :: FromType) where
1037− CommonTableExpression
1038− :: Aliased (statement commons schemas params) (cte ::: common)
1039− -> CommonTableExpression statement schemas params commons (cte ::: common ': commons)
1040−instance
1041− ( KnownSymbol cte
1042− , commons1 ~ (cte ::: common ': commons)
1043− ) => Aliasable cte
1044− (statement commons schemas params common)
1045− (CommonTableExpression statement schemas params commons commons1) where
1046− statement `as` cte = CommonTableExpression (statement `as` cte)
1047−instance
1048− ( KnownSymbol cte
1049− , commons1 ~ (cte ::: common ': commons)
1050− ) => Aliasable cte
1051− (statement commons schemas params common)
1052− (Path (CommonTableExpression statement schemas params) commons commons1) where
1053− statement `as` cte = csingleton (statement `as` cte)
1054−
1055−instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL
1056− (CommonTableExpression statement schemas params commons0 commons1) where
1057− renderSQL (CommonTableExpression (statement `As` cte)) =
1058− renderSQL cte <+> "AS" <+> parenthesized (renderSQL statement)
1059−
1060−-- | `with` provides a way to write auxiliary statements for use in a larger query.
1061−-- These statements, referred to as `CommonTableExpression`s, can be thought of as
1062−-- defining temporary tables that exist just for one query.
1063−class With statement where
1064− with
1065− :: Path (CommonTableExpression statement schemas params) commons0 commons1
1066− -- ^ common table expressions
1067− -> statement commons1 schemas params row
1068− -- ^ larger query
1069− -> statement commons0 schemas params row
1070−instance With (Query outer) where
1071− with Done query = query
1072− with ctes query = UnsafeQuery $
1073− "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL query
1074−
1075−{- |
1076−>>> import Data.Monoid (Sum (..))
1077−>>> import Data.Int (Int64)
1078−>>> :{
1079− let
1080− query :: Query_ schema () (Sum Int64)
1081− query = withRecursive
1082− ( values_ ((1 & astype int) `as` #n)
1083− `unionAll`
1084− select_ ((#n + 1) `as` #n)
1085− (from (common #t) & where_ (#n .< 100)) `as` #t )
1086− ( select_ (fromNull 0 (sum_ (All #n)) `as` #getSum) (from (common #t) & groupBy Nil))
1087− in printSQL query
1088−:}
1089−WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES ((1 :: int))) AS t ("n")) UNION ALL (SELECT ("n" + 1) AS "n" FROM "t" AS "t" WHERE ("n" < 100))) SELECT COALESCE(sum(ALL "n"), 0) AS "getSum" FROM "t" AS "t"
1090−-}
1091−withRecursive
1092− :: Aliased (Query outer (recursive ': commons) schemas params) recursive
1093− -> Query outer (recursive ': commons) schemas params row
1094− -> Query outer commons schemas params row
1095−withRecursive (recursive `As` cte) query = UnsafeQuery $
1096− "WITH RECURSIVE" <+> renderSQL cte
1097− <+> "AS" <+> parenthesized (renderSQL recursive)
1098− <+> renderSQL query
squeal-postgresql/src/Squeal/PostgreSQL/Render.hsdeleted−145
@@ -1,145 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Render
3−Description: Rendering helper functions
4−Copyright: (c) Eitan Chatav, 2017
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Rendering helper functions.
9−-}
10−
11−{-# LANGUAGE
12− AllowAmbiguousTypes
13− , ConstraintKinds
14− , FlexibleContexts
15− , LambdaCase
16− , MagicHash
17− , OverloadedStrings
18− , PolyKinds
19− , RankNTypes
20− , ScopedTypeVariables
21− , TypeApplications
22−#-}
23−
24−module Squeal.PostgreSQL.Render
25− ( -- * Render
26− RenderSQL (..)
27− , printSQL
28− , escape
29− , parenthesized
30− , bracketed
31− , (<+>)
32− , commaSeparated
33− , doubleQuoted
34− , singleQuotedText
35− , singleQuotedUtf8
36− , renderCommaSeparated
37− , renderCommaSeparatedConstraint
38− , renderCommaSeparatedMaybe
39− , renderNat
40− , renderSymbol
41− ) where
42−
43−import Control.Monad.IO.Class (MonadIO (..))
44−import Data.ByteString (ByteString)
45−import Data.Maybe (catMaybes)
46−import Data.Monoid ((<>))
47−import Data.Text (Text)
48−import Generics.SOP
49−import GHC.Exts
50−import GHC.TypeLits hiding (Text)
51−
52−import qualified Data.Text as Text
53−import qualified Data.Text.Encoding as Text
54−import qualified Data.ByteString as ByteString
55−import qualified Data.ByteString.Char8 as Char8
56−
57−-- | Parenthesize a `ByteString`.
58−parenthesized :: ByteString -> ByteString
59−parenthesized str = "(" <> str <> ")"
60−
61−-- | Square bracket a `ByteString`
62−bracketed :: ByteString -> ByteString
63−bracketed str = "[" <> str <> "]"
64−
65−-- | Concatenate two `ByteString`s with a space between.
66−(<+>) :: ByteString -> ByteString -> ByteString
67−infixr 7 <+>
68−str1 <+> str2 = str1 <> " " <> str2
69−
70−-- | Comma separate a list of `ByteString`s.
71−commaSeparated :: [ByteString] -> ByteString
72−commaSeparated = ByteString.intercalate ", "
73−
74−-- | Add double quotes around a `ByteString`.
75−doubleQuoted :: ByteString -> ByteString
76−doubleQuoted str = "\"" <> str <> "\""
77−
78−-- | Add single quotes around a `Text` and escape single quotes within it.
79−singleQuotedText :: Text -> ByteString
80−singleQuotedText str =
81− "'" <> Text.encodeUtf8 (Text.replace "'" "''" str) <> "'"
82−
83−-- | Add single quotes around a `ByteString` and escape single quotes within it.
84−singleQuotedUtf8 :: ByteString -> ByteString
85−singleQuotedUtf8 = singleQuotedText . Text.decodeUtf8
86−
87−-- | Comma separate the renderings of a heterogeneous list.
88−renderCommaSeparated
89− :: SListI xs
90− => (forall x. expression x -> ByteString)
91− -> NP expression xs -> ByteString
92−renderCommaSeparated render
93− = commaSeparated
94− . hcollapse
95− . hmap (K . render)
96−
97−-- | Comma separate the renderings of a heterogeneous list.
98−renderCommaSeparatedConstraint
99− :: forall c xs expression. (All c xs, SListI xs)
100− => (forall x. c x => expression x -> ByteString)
101− -> NP expression xs -> ByteString
102−renderCommaSeparatedConstraint render
103− = commaSeparated
104− . hcollapse
105− . hcmap (Proxy @c) (K . render)
106−
107−-- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping
108−-- `Nothing`s.
109−renderCommaSeparatedMaybe
110− :: SListI xs
111− => (forall x. expression x -> Maybe ByteString)
112− -> NP expression xs -> ByteString
113−renderCommaSeparatedMaybe render
114− = commaSeparated
115− . catMaybes
116− . hcollapse
117− . hmap (K . render)
118−
119−-- | Render a promoted `Nat`.
120−renderNat :: forall n. KnownNat n => ByteString
121−renderNat = fromString (show (natVal' (proxy# :: Proxy# n)))
122−
123−-- | Render a promoted `Symbol`.
124−renderSymbol :: forall s. KnownSymbol s => ByteString
125−renderSymbol = fromString (symbolVal' (proxy# :: Proxy# s))
126−
127−-- | A class for rendering SQL
128−class RenderSQL sql where renderSQL :: sql -> ByteString
129−
130−-- | Print SQL.
131−printSQL :: (RenderSQL sql, MonadIO io) => sql -> io ()
132−printSQL = liftIO . Char8.putStrLn . renderSQL
133−
134−-- | `escape` a character to prevent injection
135−escape :: Char -> String
136−escape = \case
137− '\NUL' -> "\\0"
138− '\'' -> "''"
139− '"' -> "\\\""
140− '\b' -> "\\b"
141− '\n' -> "\\n"
142− '\r' -> "\\r"
143− '\t' -> "\\t"
144− '\\' -> "\\\\"
145− c -> [c]
squeal-postgresql/src/Squeal/PostgreSQL/Schema.hsdeleted−596
@@ -1,596 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Schema
3−Description: Embedding of PostgreSQL type and alias system
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−`Squeal.PostgreSQL.Schema` provides a type-level DSL for kinds of Postgres types,
9−tables, schema, constraints, aliases, enumerated labels, and groupings.
10−It also defines useful type families to operate on these. Finally,
11−it defines an embedding of Haskell types into Postgres types.
12−-}
13−{-# LANGUAGE
14− AllowAmbiguousTypes
15− , ConstraintKinds
16− , DeriveAnyClass
17− , DeriveGeneric
18− , FlexibleContexts
19− , FlexibleInstances
20− , FunctionalDependencies
21− , GADTs
22− , LambdaCase
23− , OverloadedStrings
24− , QuantifiedConstraints
25− , RankNTypes
26− , ScopedTypeVariables
27− , StandaloneDeriving
28− , TypeApplications
29− , TypeFamilyDependencies
30− , TypeInType
31− , TypeOperators
32− , UndecidableInstances
33− , UndecidableSuperClasses
34−#-}
35−
36−module Squeal.PostgreSQL.Schema
37− ( -- * Postgres Types
38− PGType (..)
39− , NullityType (..)
40− , RowType
41− , FromType
42− -- * Schema Types
43− , ColumnType
44− , ColumnsType
45− , TableType
46− , SchemumType (..)
47− , IndexType (..)
48− , FunctionType
49− , OperatorType (..)
50− , ReturnsType (..)
51− , SchemaType
52− , SchemasType
53− , Public
54− -- * Constraints
55− , (:=>)
56− , ColumnConstraint (..)
57− , TableConstraint (..)
58− , TableConstraints
59− , Uniquely
60− -- * Enumerated Labels
61− , IsPGlabel (..)
62− , PGlabel (..)
63− -- * Data Definitions
64− , Create
65− , CreateIfNotExists
66− , CreateOrReplace
67− , Drop
68− , DropSchemum
69− , DropIfExists
70− , DropSchemumIfExists
71− , Alter
72− , AlterIfExists
73− , Rename
74− , RenameIfExists
75− , ConstraintInvolves
76− , DropIfConstraintsInvolve
77− , IsNotElem
78− , AllUnique
79− -- * Type Classifications
80− , PGNum
81− , PGIntegral
82− , PGFloating
83− , PGTypeOf
84− , PGJsonType
85− , PGJsonKey
86− , SamePGType
87− , AllNotNull
88− , NotAllNull
89− -- * Nullifications
90− , NullifyType
91− , NullifyRow
92− , NullifyFrom
93− -- * Table Conversions
94− , TableToColumns
95− , ColumnsToRow
96− , TableToRow
97− ) where
98−
99−import Control.Category
100−import Data.Kind
101−import Data.Monoid hiding (All)
102−import Data.Type.Bool
103−import Generics.SOP
104−import GHC.TypeLits
105−import Prelude hiding (id, (.))
106−
107−import Squeal.PostgreSQL.Alias
108−import Squeal.PostgreSQL.List
109−import Squeal.PostgreSQL.Render
110−
111−-- $setup
112−-- >>> import Squeal.PostgreSQL
113−
114−-- | `PGType` is the promoted datakind of PostgreSQL types.
115−--
116−-- >>> :kind 'PGbool
117−-- 'PGbool :: PGType
118−data PGType
119− = PGbool -- ^ logical Boolean (true/false)
120− | PGint2 -- ^ signed two-byte integer
121− | PGint4 -- ^ signed four-byte integer
122− | PGint8 -- ^ signed eight-byte integer
123− | PGnumeric -- ^ arbitrary precision numeric type
124− | PGfloat4 -- ^ single precision floating-point number (4 bytes)
125− | PGfloat8 -- ^ double precision floating-point number (8 bytes)
126− | PGmoney -- ^ currency amount
127− | PGchar Nat -- ^ fixed-length character string
128− | PGvarchar Nat -- ^ variable-length character string
129− | PGtext -- ^ variable-length character string
130− | PGbytea -- ^ binary data ("byte array")
131− | PGtimestamp -- ^ date and time (no time zone)
132− | PGtimestamptz -- ^ date and time, including time zone
133− | PGdate -- ^ calendar date (year, month, day)
134− | PGtime -- ^ time of day (no time zone)
135− | PGtimetz -- ^ time of day, including time zone
136− | PGinterval -- ^ time span
137− | PGuuid -- ^ universally unique identifier
138− | PGinet -- ^ IPv4 or IPv6 host address
139− | PGjson -- ^ textual JSON data
140− | PGjsonb -- ^ binary JSON data, decomposed
141− | PGvararray NullityType -- ^ variable length array
142− | PGfixarray [Nat] NullityType -- ^ fixed length array
143− | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.
144− | PGcomposite RowType -- ^ a composite type represents the structure of a row or record; it is essentially just a list of field names and their data types.
145− | PGtsvector -- ^ A tsvector value is a sorted list of distinct lexemes, which are words that have been normalized to merge different variants of the same word.
146− | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for.
147− | PGoid -- Object identifiers (OIDs) are used internally by PostgreSQL as primary keys for various system tables.
148− | PGrange PGType -- ^ Range types are data types representing a range of values of some element type (called the range's subtype).
149− | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types
150−
151−-- | `NullityType` encodes the potential presence or definite absence of a
152−-- @NULL@ allowing operations which are sensitive to such to be well typed.
153−--
154−-- >>> :kind 'Null 'PGint4
155−-- 'Null 'PGint4 :: NullityType
156−-- >>> :kind 'NotNull ('PGvarchar 50)
157−-- 'NotNull ('PGvarchar 50) :: NullityType
158−data NullityType
159− = Null PGType -- ^ @NULL@ may be present
160− | NotNull PGType -- ^ @NULL@ is absent
161−
162−-- | The constraint operator, `:=>` is a type level pair
163−-- between a "constraint" and some type, for use in pairing
164−-- a `ColumnConstraint` with a `NullityType` to produce a `ColumnType`
165−-- or a `TableConstraints` and a `ColumnsType` to produce a `TableType`.
166−type (:=>) constraint ty = '(constraint,ty)
167−infixr 7 :=>
168−
169−-- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates.
170−-- A column can be assigned a default value.
171−-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also
172−-- request explicitly that a column be set to its default value,
173−-- without having to know what that value is.
174−data ColumnConstraint
175− = Def -- ^ @DEFAULT@ is available for inserts and updates
176− | NoDef -- ^ @DEFAULT@ is unavailable for inserts and updates
177−
178−-- | `ColumnType` encodes the allowance of @DEFAULT@ and @NULL@ and the
179−-- base `PGType` for a column.
180−--
181−-- >>> :set -XTypeFamilies -XTypeInType
182−-- >>> import GHC.TypeLits
183−-- >>> type family IdColumn :: ColumnType where IdColumn = 'Def :=> 'NotNull 'PGint4
184−-- >>> type family EmailColumn :: ColumnType where EmailColumn = 'NoDef :=> 'Null 'PGtext
185−type ColumnType = (ColumnConstraint,NullityType)
186−
187−-- | `ColumnsType` is a row of `ColumnType`s.
188−--
189−-- >>> :{
190−-- type family UsersColumns :: ColumnsType where
191−-- UsersColumns =
192−-- '[ "name" ::: 'NoDef :=> 'NotNull 'PGtext
193−-- , "id" ::: 'Def :=> 'NotNull 'PGint4
194−-- ]
195−-- :}
196−type ColumnsType = [(Symbol,ColumnType)]
197−
198−-- | `TableConstraint` encodes various forms of data constraints
199−-- of columns in a table.
200−-- `TableConstraint`s give you as much control over the data in your tables
201−-- as you wish. If a user attempts to store data in a column that would
202−-- violate a constraint, an error is raised. This applies
203−-- even if the value came from the default value definition.
204−data TableConstraint
205− = Check [Symbol]
206− | Unique [Symbol]
207− | PrimaryKey [Symbol]
208− | ForeignKey [Symbol] Symbol [Symbol]
209−
210−{- | A `TableConstraints` is a row of `TableConstraint`s.
211−
212−>>> :{
213−type family UsersConstraints :: TableConstraints where
214− UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]
215−:}
216−-}
217−type TableConstraints = [(Symbol,TableConstraint)]
218−
219−-- | A `ForeignKey` must reference columns that either are
220−-- a `PrimaryKey` or form a `Unique` constraint.
221−type family Uniquely
222− (key :: [Symbol])
223− (constraints :: TableConstraints) :: Constraint where
224− Uniquely key (uq ::: 'Unique key ': constraints) = ()
225− Uniquely key (pk ::: 'PrimaryKey key ': constraints) = ()
226− Uniquely key (_ ': constraints) = Uniquely key constraints
227−
228−-- | `TableType` encodes a row of constraints on a table as well as the types
229−-- of its columns.
230−--
231−-- >>> :{
232−-- type family UsersTable :: TableType where
233−-- UsersTable =
234−-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
235−-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4
236−-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext
237−-- ]
238−-- :}
239−type TableType = (TableConstraints,ColumnsType)
240−
241−{- | A `RowType` is a row of `NullityType`. They correspond to Haskell
242−record types by means of `Squeal.PostgreSQL.Binary.RowPG` and are used in many places.
243−
244−>>> :{
245−type family PersonRow :: RowType where
246− PersonRow =
247− '[ "name" ::: 'NotNull 'PGtext
248− , "age" ::: 'NotNull 'PGint4
249− , "dateOfBirth" ::: 'Null 'PGdate
250− ]
251−:}
252−-}
253−type RowType = [(Symbol,NullityType)]
254−
255−{- | `FromType` is a row of `RowType`s. It can be thought of as
256−a product, or horizontal gluing and is used in `Squeal.PostgreSQL.Query.FromClause`s
257−and `Squeal.PostgreSQL.Query.TableExpression`s.
258−-}
259−type FromType = [(Symbol,RowType)]
260−
261−-- | `ColumnsToRow` removes column constraints.
262−type family ColumnsToRow (columns :: ColumnsType) :: RowType where
263− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': column5 ::: _ :=> ty5 ': columns) =
264− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': ColumnsToRow columns
265− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': columns) =
266− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': ColumnsToRow columns
267− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': columns) =
268− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': ColumnsToRow columns
269− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': columns) =
270− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': ColumnsToRow columns
271− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': columns) =
272− column ::: ty ': column1 ::: ty1 ': ColumnsToRow columns
273− ColumnsToRow (column ::: _ :=> ty ': columns) =
274− column ::: ty ': ColumnsToRow columns
275− ColumnsToRow '[] = '[]
276−
277−-- | `TableToColumns` removes table constraints.
278−type family TableToColumns (table :: TableType) :: ColumnsType where
279− TableToColumns (constraints :=> columns) = columns
280−
281−-- | Convert a table to a row type.
282−type family TableToRow (table :: TableType) :: RowType where
283− TableToRow tab = ColumnsToRow (TableToColumns tab)
284−
285−-- | Numeric Postgres types.
286−type PGNum =
287− '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]
288−
289−-- | Floating Postgres types.
290−type PGFloating = '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]
291−
292−-- | Integral Postgres types.
293−type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8]
294−
295−-- | `PGTypeOf` forgets about @NULL@ and any column constraints.
296−type family PGTypeOf (ty :: NullityType) :: PGType where
297− PGTypeOf (nullity pg) = pg
298−
299−-- | Equality constraint on the underlying `PGType` of two columns.
300−class SamePGType
301− (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where
302−instance ty0 ~ ty1 => SamePGType
303− (alias0 ::: def0 :=> nullity0 ty0)
304− (alias1 ::: def1 :=> nullity1 ty1)
305−
306−-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.
307−type family AllNotNull (columns :: ColumnsType) :: Constraint where
308− AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
309− AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
310− AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
311− AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
312− AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
313− AllNotNull (_ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns
314− AllNotNull '[] = ()
315−
316−-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some
317−-- @NOT NULL@.
318−type family NotAllNull (columns :: ColumnsType) :: Constraint where
319− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
320− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
321− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
322− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
323− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()
324− NotAllNull (_ ::: _ :=> 'NotNull _ ': _) = ()
325− NotAllNull (_ ::: _ :=> 'Null _ ': columns) = NotAllNull columns
326−
327−-- | `NullifyType` is an idempotent that nullifies a `NullityType`.
328−type family NullifyType (ty :: NullityType) :: NullityType where
329− NullifyType ('Null ty) = 'Null ty
330− NullifyType ('NotNull ty) = 'Null ty
331−
332−-- | `NullifyRow` is an idempotent that nullifies a `RowType`.
333−type family NullifyRow (columns :: RowType) :: RowType where
334− NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': columns) =
335− column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': column4 ::: NullifyType ty4 ': column5 ::: NullifyType ty5 ': NullifyRow columns
336− NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': columns) =
337− column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': column4 ::: NullifyType ty4 ': NullifyRow columns
338− NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': columns) =
339− column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': NullifyRow columns
340− NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': columns) =
341− column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': NullifyRow columns
342− NullifyRow (column ::: ty ': column1 ::: ty1 ': columns) =
343− column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': NullifyRow columns
344− NullifyRow (column ::: ty ': columns) =
345− column ::: NullifyType ty ': NullifyRow columns
346− NullifyRow '[] = '[]
347−
348−-- | `NullifyFrom` is an idempotent that nullifies a `FromType`
349−-- used to nullify the left or right hand side of an outer join
350−-- in a `Squeal.PostgreSQL.Query.FromClause`.
351−type family NullifyFrom (tables :: FromType) :: FromType where
352− NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': table5 ::: columns5 ': tables) =
353− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': table4 ::: NullifyRow columns5 ': table5 ::: NullifyRow columns4 ': NullifyFrom tables
354− NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': tables) =
355− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': table4 ::: NullifyRow columns4 ': NullifyFrom tables
356− NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': tables) =
357− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': NullifyFrom tables
358− NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': tables) =
359− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': NullifyFrom tables
360− NullifyFrom (table ::: columns ': table1 ::: columns1 ': tables) =
361− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': NullifyFrom tables
362− NullifyFrom (table ::: columns ': tables) =
363− table ::: NullifyRow columns ': NullifyFrom tables
364− NullifyFrom '[] = '[]
365−
366−-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in
367−-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@
368−-- `Squeal.PostgreSQL.Definition.addColumn`.
369−type family Create alias x xs where
370− Create alias x '[] = '[alias ::: x]
371− Create alias x (alias ::: y ': xs) = TypeError
372− ('Text "Create: alias "
373− ':<>: 'ShowType alias
374− ':<>: 'Text "already exists")
375− Create alias y (x ': xs) = x ': Create alias y xs
376−
377−type family CreateIfNotExists alias x xs where
378− CreateIfNotExists alias x '[] = '[alias ::: x]
379− CreateIfNotExists alias x (alias ::: y ': xs) = alias ::: y ': xs
380− CreateIfNotExists alias y (x ': xs) = x ': CreateIfNotExists alias y xs
381−
382−type family CreateOrReplace alias x xs where
383− CreateOrReplace alias x '[] = '[alias ::: x]
384− CreateOrReplace alias x (alias ::: x ': xs) = alias ::: x ': xs
385− CreateOrReplace alias x (alias ::: y ': xs) = TypeError
386− ('Text "CreateOrReplace: expected type "
387− ':<>: 'ShowType x
388− ':<>: 'Text " but alias "
389− ':<>: 'ShowType alias
390− ':<>: 'Text " has type "
391− ':<>: 'ShowType y)
392− CreateOrReplace alias y (x ': xs) = x ': CreateOrReplace alias y xs
393−
394−-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@
395−-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements
396−-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.
397−type family Drop alias xs where
398− Drop alias '[] = TypeError
399− ('Text "Drop: alias "
400− ':<>: 'ShowType alias
401− ':<>: 'Text " does not exist" )
402− Drop alias (alias ::: x ': xs) = xs
403− Drop alias (x ': xs) = x ': Drop alias xs
404−
405−type family DropSchemum alias sch xs where
406− DropSchemum alias sch '[] = TypeError
407− ('Text "DropSchemum: alias "
408− ':<>: 'ShowType alias
409− ':<>: 'Text " does not exist" )
410− DropSchemum alias sch (alias ::: sch x ': xs) = xs
411− DropSchemum alias sch0 (alias ::: sch1 x ': xs) = TypeError
412− ('Text "DropSchemum: expected schemum "
413− ':<>: 'ShowType sch0
414− ':<>: 'Text " but alias "
415− ':<>: 'ShowType alias
416− ':<>: 'Text " has schemum "
417− ':<>: 'ShowType sch1)
418− DropSchemum alias sch (x ': xs) = x ': DropSchemum alias sch xs
419−
420−type family DropIfExists alias xs where
421− DropIfExists alias '[] = '[]
422− DropIfExists alias (alias ::: x ': xs) = xs
423− DropIfExists alias (x ': xs) = x ': DropIfExists alias xs
424−
425−type family DropSchemumIfExists alias sch xs where
426− DropSchemumIfExists alias sch '[] = '[]
427− DropSchemumIfExists alias sch (alias ::: sch x ': xs) = xs
428− DropSchemumIfExists alias sch0 (alias ::: sch1 x ': xs) = TypeError
429− ('Text "DropSchemumIfExists: expected schemum "
430− ':<>: 'ShowType sch1
431− ':<>: 'Text " but alias "
432− ':<>: 'ShowType alias
433− ':<>: 'Text " has schemum "
434− ':<>: 'ShowType sch0)
435− DropSchemumIfExists alias sch (x ': xs) = x ': DropSchemumIfExists alias sch xs
436−
437−-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@
438−-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable`
439−-- and `Squeal.PostgreSQL.Definition.alterColumn`.
440−type family Alter alias x xs where
441− Alter alias x '[] = TypeError
442− ('Text "Alter: alias "
443− ':<>: 'ShowType alias
444− ':<>: 'Text " does not exist" )
445− Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
446− Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs
447−
448−type family AlterIfExists alias x xs where
449− AlterIfExists alias x '[] = '[]
450− AlterIfExists alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs
451− AlterIfExists alias x1 (x0 ': xs) = x0 ': AlterIfExists alias x1 xs
452−
453−-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@
454−-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and
455−-- `Squeal.PostgreSQL.Definition.renameColumn`.
456−type family Rename alias0 alias1 xs where
457− Rename alias0 alias1 '[] = TypeError
458− ('Text "Rename: alias "
459− ':<>: 'ShowType alias0
460− ':<>: 'Text " does not exist" )
461− Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
462− Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs
463−
464−type family RenameIfExists alias0 alias1 xs where
465− RenameIfExists alias x '[] = '[]
466− RenameIfExists alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs
467− RenameIfExists alias0 alias1 (x ': xs) = x ': RenameIfExists alias0 alias1 xs
468−
469−-- | Check if a `TableConstraint` involves a column
470−type family ConstraintInvolves column constraint where
471− ConstraintInvolves column ('Check columns) = column `Elem` columns
472− ConstraintInvolves column ('Unique columns) = column `Elem` columns
473− ConstraintInvolves column ('PrimaryKey columns) = column `Elem` columns
474− ConstraintInvolves column ('ForeignKey columns tab refcolumns)
475− = column `Elem` columns
476−
477−-- | Drop all `TableConstraint`s that involve a column
478−type family DropIfConstraintsInvolve column constraints where
479− DropIfConstraintsInvolve column '[] = '[]
480− DropIfConstraintsInvolve column (alias ::: constraint ': constraints)
481− = If (ConstraintInvolves column constraint)
482− (DropIfConstraintsInvolve column constraints)
483− (alias ::: constraint ': DropIfConstraintsInvolve column constraints)
484−
485−-- | A `SchemumType` is a user-defined type, either a `Table`,
486−-- `View` or `Typedef`.
487−data SchemumType
488− = Table TableType
489− | View RowType
490− | Typedef PGType
491− | Index IndexType
492− | Function FunctionType
493− | Operator OperatorType
494− | UnsafeSchemum Symbol
495−
496−type FunctionType = ([NullityType], ReturnsType)
497−
498−data IndexType
499− = Btree
500− | Hash
501− | Gist
502− | Spgist
503− | Gin
504− | Brin
505−
506−data ReturnsType
507− = Returns NullityType
508− | ReturnsTable RowType
509−
510−data OperatorType
511− = BinaryOp NullityType NullityType NullityType
512− | LeftOp NullityType NullityType
513− | RightOp NullityType NullityType
514−
515−{- | The schema of a database consists of a list of aliased,
516−user-defined `SchemumType`s.
517−
518−>>> :{
519−type family Schema :: SchemaType where
520− Schema =
521− '[ "users" ::: 'Table (
522− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>
523− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
524− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
525− ])
526− , "emails" ::: 'Table (
527− '[ "pk_emails" ::: 'PrimaryKey '["id"]
528− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]
529− ] :=>
530− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
531− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4
532− , "email" ::: 'NoDef :=> 'Null 'PGtext
533− ])
534− ]
535−:}
536−-}
537−type SchemaType = [(Symbol,SchemumType)]
538−
539−{- |
540−A database contains one or more named schemas, which in turn contain tables.
541−The same object name can be used in different schemas without conflict;
542−for example, both schema1 and myschema can contain tables named mytable.
543−Unlike databases, schemas are not rigidly separated:
544−a user can access objects in any of the schemas in the database they are connected to,
545−if they have privileges to do so.
546−
547−There are several reasons why one might want to use schemas:
548−
549− * To allow many users to use one database without interfering with each other.
550− * To organize database objects into logical groups to make them more manageable.
551− * Third-party applications can be put into separate schemas
552− so they do not collide with the names of other objects.
553−-}
554−type SchemasType = [(Symbol,SchemaType)]
555−
556−-- | A type family to use for a single schema database.
557−type family Public (schema :: SchemaType) :: SchemasType
558− where Public schema = '["public" ::: schema]
559−
560−-- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas
561−-- the overloaded label, `fromLabel` is used for column references,
562−-- `label`s are used for enum terms. A `label` is called with
563−-- type application like `label @"beef"`.
564−class IsPGlabel (label :: Symbol) expr where label :: expr
565−instance label ~ label1
566− => IsPGlabel label (PGlabel label1) where label = PGlabel
567−instance labels ~ '[label]
568− => IsPGlabel label (NP PGlabel labels) where label = PGlabel :* Nil
569−-- | A `PGlabel` unit type with an `IsPGlabel` instance
570−data PGlabel (label :: Symbol) = PGlabel
571−instance KnownSymbol label => RenderSQL (PGlabel label) where
572− renderSQL _ = "\'" <> renderSymbol @label <> "\'"
573−instance All KnownSymbol labels => RenderSQL (NP PGlabel labels) where
574− renderSQL
575− = commaSeparated
576− . hcollapse
577− . hcmap (Proxy @KnownSymbol) (K . renderSQL)
578−
579−-- | Is a type a valid JSON key?
580−type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]
581−
582−-- | Is a type a valid JSON type?
583−type PGJsonType = '[ 'PGjson, 'PGjsonb ]
584−
585−-- | Utility class for `AllUnique` to provide nicer error messages.
586−class IsNotElem x isElem where
587−instance IsNotElem x 'False where
588−instance (TypeError ( 'Text "Cannot assign to "
589− ':<>: 'ShowType alias
590− ':<>: 'Text " more than once"))
591− => IsNotElem '(alias, a) 'True where
592−
593−-- | No elem of @xs@ appears more than once, in the context of assignment.
594−class AllUnique (xs :: [(Symbol, a)]) where
595−instance AllUnique '[] where
596−instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where
squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hsdeleted−252
@@ -1,252 +0,0 @@
1−{-|
2−Module: Squeal.PostgreSQL.Transaction
3−Description: Squeal transaction control language
4−Copyright: (c) Eitan Chatav, 2019
5−Maintainer: eitan@morphism.tech
6−Stability: experimental
7−
8−Squeal transaction control language.
9−-}
10−
11−{-# LANGUAGE
12− DataKinds
13− , FlexibleContexts
14− , LambdaCase
15− , OverloadedStrings
16− , TypeInType
17−#-}
18−
19−module Squeal.PostgreSQL.Transaction
20− ( -- * Transaction
21− transactionally
22− , transactionally_
23− , transactionallyRetry
24− , ephemerally
25− , ephemerally_
26− , begin
27− , commit
28− , rollback
29− -- * Transaction Mode
30− , TransactionMode (..)
31− , defaultMode
32− , longRunningMode
33− , IsolationLevel (..)
34− , AccessMode (..)
35− , DeferrableMode (..)
36− ) where
37−
38−import UnliftIO
39−
40−import Squeal.PostgreSQL.Manipulation
41−import Squeal.PostgreSQL.Render
42−import Squeal.PostgreSQL.PQ
43−
44−{- | Run a computation `transactionally`;
45−first `begin`,
46−then run the computation,
47−`onException` `rollback` and rethrow the exception,
48−otherwise `commit` and `return` the result.
49−-}
50−transactionally
51− :: (MonadUnliftIO tx, MonadPQ schemas tx)
52− => TransactionMode
53− -> tx x -- ^ run inside a transaction
54− -> tx x
55−transactionally mode tx = mask $ \restore -> do
56− manipulate_ $ begin mode
57− result <- restore tx `onException` (manipulate_ rollback)
58− manipulate_ commit
59− return result
60−
61−-- | Run a computation `transactionally_`, in `defaultMode`.
62−transactionally_
63− :: (MonadUnliftIO tx, MonadPQ schemas tx)
64− => tx x -- ^ run inside a transaction
65− -> tx x
66−transactionally_ = transactionally defaultMode
67−
68−{- |
69−`transactionallyRetry` a computation;
70−
71−* first `begin`,
72−* then `try` the computation,
73− - if it raises a serialization failure then `rollback` and restart the transaction,
74− - if it raises any other exception then `rollback` and rethrow the exception,
75− - otherwise `commit` and `return` the result.
76−-}
77−transactionallyRetry
78− :: (MonadUnliftIO tx, MonadPQ schemas tx)
79− => TransactionMode
80− -> tx x -- ^ run inside a transaction
81− -> tx x
82−transactionallyRetry mode tx = mask $ \restore ->
83− loop . try $ do
84− x <- restore tx
85− manipulate_ commit
86− return x
87− where
88− loop attempt = do
89− manipulate_ $ begin mode
90− attempt >>= \case
91− Left (PQException (PQState _ (Just "40001") _)) -> do
92− manipulate_ rollback
93− loop attempt
94− Left err -> do
95− manipulate_ rollback
96− throwIO err
97− Right x -> return x
98−
99−{- | Run a computation `ephemerally`;
100−Like `transactionally` but always `rollback`, useful in testing.
101−-}
102−ephemerally
103− :: (MonadUnliftIO tx, MonadPQ schemas tx)
104− => TransactionMode
105− -> tx x -- ^ run inside an ephemeral transaction
106− -> tx x
107−ephemerally mode tx = mask $ \restore -> do
108− manipulate_ $ begin mode
109− result <- restore tx `onException` (manipulate_ rollback)
110− manipulate_ rollback
111− return result
112−
113−{- | Run a computation `ephemerally` in `defaultMode`. -}
114−ephemerally_
115− :: (MonadUnliftIO tx, MonadPQ schemas tx)
116− => tx x -- ^ run inside an ephemeral transaction
117− -> tx x
118−ephemerally_ = ephemerally defaultMode
119−
120−-- | @BEGIN@ a transaction.
121−begin :: TransactionMode -> Manipulation_ schemas () ()
122−begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode
123−
124−-- | @COMMIT@ a transaction.
125−commit :: Manipulation_ schemas () ()
126−commit = UnsafeManipulation "COMMIT"
127−
128−-- | @ROLLBACK@ a transaction.
129−rollback :: Manipulation_ schemas () ()
130−rollback = UnsafeManipulation "ROLLBACK"
131−
132−-- | The available transaction characteristics are the transaction `IsolationLevel`,
133−-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.
134−data TransactionMode = TransactionMode
135− { isolationLevel :: IsolationLevel
136− , accessMode :: AccessMode
137− , deferrableMode :: DeferrableMode
138− } deriving (Show, Eq)
139−
140−-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
141−-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.
142−defaultMode :: TransactionMode
143−defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable
144−
145−-- | `TransactionMode` with a `Serializable` `IsolationLevel`,
146−-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.
147−-- This mode is well suited for long-running reports or backups.
148−longRunningMode :: TransactionMode
149−longRunningMode = TransactionMode Serializable ReadOnly Deferrable
150−
151−-- | Render a `TransactionMode`.
152−instance RenderSQL TransactionMode where
153− renderSQL mode =
154− "ISOLATION LEVEL"
155− <+> renderSQL (isolationLevel mode)
156− <+> renderSQL (accessMode mode)
157− <+> renderSQL (deferrableMode mode)
158−
159−-- | The SQL standard defines four levels of transaction isolation.
160−-- The most strict is `Serializable`, which is defined by the standard in a paragraph
161−-- which says that any concurrent execution of a set of `Serializable` transactions is
162−-- guaranteed to produce the same effect as running them one at a time in some order.
163−-- The other three levels are defined in terms of phenomena, resulting from interaction
164−-- between concurrent transactions, which must not occur at each level.
165−-- The phenomena which are prohibited at various levels are:
166−--
167−-- __Dirty read__: A transaction reads data written by a concurrent uncommitted transaction.
168−--
169−-- __Nonrepeatable read__: A transaction re-reads data it has previously read and finds that data
170−-- has been modified by another transaction (that committed since the initial read).
171−--
172−-- __Phantom read__: A transaction re-executes a query returning a set of rows that satisfy
173−-- a search condition and finds that the set of rows satisfying the condition
174−-- has changed due to another recently-committed transaction.
175−--
176−-- __Serialization anomaly__: The result of successfully committing a group of transactions is inconsistent
177−-- with all possible orderings of running those transactions one at a time.
178−--
179−-- In PostgreSQL, you can request any of the four standard transaction
180−-- isolation levels, but internally only three distinct isolation levels are implemented,
181−-- i.e. PostgreSQL's `ReadUncommitted` mode behaves like `ReadCommitted`.
182−-- This is because it is the only sensible way to map the standard isolation levels to
183−-- PostgreSQL's multiversion concurrency control architecture.
184−data IsolationLevel
185− = Serializable
186− -- ^ Dirty read is not possible.
187− -- Nonrepeatable read is not possible.
188− -- Phantom read is not possible.
189− -- Serialization anomaly is not possible.
190− | RepeatableRead
191− -- ^ Dirty read is not possible.
192− -- Nonrepeatable read is not possible.
193− -- Phantom read is not possible.
194− -- Serialization anomaly is possible.
195− | ReadCommitted
196− -- ^ Dirty read is not possible.
197− -- Nonrepeatable read is possible.
198− -- Phantom read is possible.
199− -- Serialization anomaly is possible.
200− | ReadUncommitted
201− -- ^ Dirty read is not possible.
202− -- Nonrepeatable read is possible.
203− -- Phantom read is possible.
204− -- Serialization anomaly is possible.
205− deriving (Show, Eq)
206−
207−-- | Render an `IsolationLevel`.
208−instance RenderSQL IsolationLevel where
209− renderSQL = \case
210− Serializable -> "SERIALIZABLE"
211− ReadCommitted -> "READ COMMITTED"
212− ReadUncommitted -> "READ UNCOMMITTED"
213− RepeatableRead -> "REPEATABLE READ"
214−
215−-- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`.
216−-- `ReadWrite` is the default. When a transaction is `ReadOnly`,
217−-- the following SQL commands are disallowed:
218−-- @INSERT@, @UPDATE@, @DELETE@, and @COPY FROM@
219−-- if the table they would write to is not a temporary table;
220−-- all @CREATE@, @ALTER@, and @DROP@ commands;
221−-- @COMMENT@, @GRANT@, @REVOKE@, @TRUNCATE@;
222−-- and @EXPLAIN ANALYZE@ and @EXECUTE@ if the command they would execute is among those listed.
223−-- This is a high-level notion of `ReadOnly` that does not prevent all writes to disk.
224−data AccessMode
225− = ReadWrite
226− | ReadOnly
227− deriving (Show, Eq)
228−
229−-- | Render an `AccessMode`.
230−instance RenderSQL AccessMode where
231− renderSQL = \case
232− ReadWrite -> "READ WRITE"
233− ReadOnly -> "READ ONLY"
234−
235−-- | The `Deferrable` transaction property has no effect
236−-- unless the transaction is also `Serializable` and `ReadOnly`.
237−-- When all three of these properties are selected for a transaction,
238−-- the transaction may block when first acquiring its snapshot,
239−-- after which it is able to run without the normal overhead of a
240−-- `Serializable` transaction and without any risk of contributing
241−-- to or being canceled by a serialization failure.
242−-- This `longRunningMode` is well suited for long-running reports or backups.
243−data DeferrableMode
244− = Deferrable
245− | NotDeferrable
246− deriving (Show, Eq)
247−
248−-- | Render a `DeferrableMode`.
249−instance RenderSQL DeferrableMode where
250− renderSQL = \case
251− Deferrable -> "DEFERRABLE"
252− NotDeferrable -> "NOT DEFERRABLE"
squeal-postgresql/test/Doc.hsdeleted−6
@@ -1,6 +0,0 @@
1−module Main (main) where
2−
3−import Test.DocTest
4−
5−main :: IO ()
6−main = doctest [ "-isrc", "src" ]
squeal-postgresql/test/Property.hsdeleted−166
@@ -1,166 +0,0 @@
1−{-# LANGUAGE
2− DataKinds
3− , GADTs
4− , LambdaCase
5− , OverloadedLabels
6− , OverloadedStrings
7− , TypeApplications
8− , TypeOperators
9−#-}
10−
11−module Main (main) where
12−
13−import Control.Monad.Trans
14−import Data.ByteString (ByteString)
15−import Data.ByteString.Char8 (unpack)
16−import Data.Scientific (fromFloatDigits)
17−import Data.Fixed (Fixed(MkFixed), Micro, Pico)
18−import Data.String (IsString(fromString))
19−import Data.Time
20−import Squeal.PostgreSQL hiding (check, defaultMain, Group)
21−import Hedgehog hiding (Range)
22−import qualified Hedgehog.Gen as Gen
23−import qualified Hedgehog.Main as Main
24−import qualified Hedgehog.Range as Range
25−
26−main :: IO ()
27−main = Main.defaultMain [checkSequential roundtrips]
28−
29−roundtrips :: Group
30−roundtrips = Group "roundtrips"
31− [ roundtrip int2 genInt16
32− , roundtrip int4 genInt32
33− , roundtrip int8 genInt64
34− , roundtrip bool Gen.bool
35− , roundtrip numeric genScientific
36− , roundtrip float4 genFloat
37− , roundtrip float8 genDouble
38− , roundtripOn normalizeTimeOfDay time genTimeOfDay
39− -- , roundtrip timetz genTimeWithZone normalizeTimeWithZone
40− , roundtripOn normalizeLocalTime timestamp genLocalTime
41− , roundtrip timestamptz genUTCTime
42− , roundtrip date genDay
43− , roundtrip interval genDiffTime
44− , roundtripOn normalizeIntRange int4range (genRange genInt32)
45− , roundtripOn normalizeIntRange int8range (genRange genInt64)
46− , roundtrip numrange (genRange genScientific)
47− , roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime)
48− , roundtrip tstzrange (genRange genUTCTime)
49− , roundtripOn normalizeIntRange daterange (genRange genDay)
50− ]
51− where
52− genInt16 = Gen.int16 Range.exponentialBounded
53− genInt32 = Gen.int32 Range.exponentialBounded
54− genInt64 = Gen.int64 Range.exponentialBounded
55− genScientific = fromFloatDigits <$> genFloat
56− genPosFloat = Gen.float
57− (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
58− genFloat = Gen.prune $ Gen.choice
59− [ genPosFloat
60− , negate <$> genPosFloat
61− , Gen.element [0,1/0] ]
62− genPosDouble = Gen.double
63− (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)
64− genDouble = Gen.prune $ Gen.choice
65− [ genPosDouble
66− , negate <$> genPosDouble
67− , Gen.element [0,1/0] ]
68− genRange gen = do
69− lb <- gen
70− ub <- Gen.filter (lb <) gen
71− Gen.element
72− [ Empty, singleton lb, whole
73− , lb <=..<= ub , lb <=..< ub, lb <..<= ub, lb <..< ub
74− , atLeast lb, moreThan lb, atMost ub, lessThan ub ]
75− genDay = do
76− y <- toInteger <$> Gen.int (Range.constant 2000 2019)
77− m <- Gen.int (Range.constant 1 12)
78− d <- Gen.int (Range.constant 1 28)
79− return $ fromGregorian y m d
80− genDiffTime = secondsToDiffTime . toInteger <$>
81− Gen.int (Range.constant 0 86401)
82− genUTCTime = UTCTime <$> genDay <*> genDiffTime
83− genTimeOfDay = do
84− h <- Gen.int (Range.constant 0 23)
85− m <- Gen.int (Range.constant 0 59)
86− s <- MkFixed . toInteger <$> Gen.int (Range.constant 0 59)
87− return $ TimeOfDay h m s
88− genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
89− -- genTimeZone = Gen.element $ map (read @TimeZone)
90− -- [ "UTC", "UT", "GMT", "EST", "EDT", "CST"
91− -- , "CDT", "MST", "MDT", "PST", "PDT" ]
92− -- genTimeWithZone = (,) <$> genTimeOfDay <*> genTimeZone
93−
94−roundtrip
95− :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)
96− => TypeExpression schemas ('NotNull ty)
97− -> Gen x
98− -> (PropertyName, Property)
99−roundtrip = roundtripOn id
100−
101−roundtripOn
102− :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)
103− => (x -> x)
104− -> TypeExpression schemas ('NotNull ty)
105− -> Gen x
106− -> (PropertyName, Property)
107−roundtripOn norm ty gen = propertyWithName $ do
108− x <- forAll gen
109− Just (Only y) <- lift . withConnection connectionString $
110− firstRow =<< runQueryParams
111− (values_ (parameter @1 ty `as` #fromOnly)) (Only x)
112− norm x === y
113− where
114− propertyWithName prop =
115− (fromString (unpack (renderSQL ty)), property prop)
116−
117−maxPosFloat :: RealFloat a => a
118−maxPosFloat = x
119− where
120− n = floatDigits x
121− b = floatRadix x
122− (_, u) = floatRange x
123− x = encodeFloat (b^n - 1) (u - n)
124−
125−minPosFloat :: RealFloat a => a
126−minPosFloat = x
127− where
128− n = floatDigits x
129− b = floatRadix x
130− (l, _) = floatRange x
131− x = encodeFloat (b^n - 1) (l - n - 1)
132−
133−connectionString :: ByteString
134−connectionString = "host=localhost port=5432 dbname=exampledb"
135−
136−normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int
137−normalizeIntRange = \case
138− Empty -> Empty
139− NonEmpty l u ->
140− let
141− l' = normalizeL l
142− u' = normalizeU u
143− in if emptyNormalized l' u' then Empty else NonEmpty l' u'
144− where
145− normalizeL = \case
146− Open l -> Closed (succ l)
147− normalized -> normalized
148− normalizeU = \case
149− Closed u -> Open (succ u)
150− normalized -> normalized
151− emptyNormalized (Closed l) (Open u) = l >= u
152− emptyNormalized _ _ = False
153−
154−normalizeTimeOfDay :: TimeOfDay -> TimeOfDay
155−normalizeTimeOfDay (TimeOfDay h m s) = TimeOfDay h m
156− . fromRational @Pico
157− . toRational @Micro
158− . fromRational @Micro
159− . toRational @Pico
160− $ s
161−
162−normalizeLocalTime :: LocalTime -> LocalTime
163−normalizeLocalTime (LocalTime d t) = LocalTime d (normalizeTimeOfDay t)
164−
165−-- normalizeTimeWithZone :: (TimeOfDay, TimeZone) -> (TimeOfDay, TimeZone)
166−-- normalizeTimeWithZone (t, z) = (normalizeTimeOfDay t, z)
squeal-postgresql/test/Spec.hsdeleted−136
@@ -1,136 +0,0 @@
1−{-# LANGUAGE
2− DataKinds
3− , DeriveAnyClass
4− , DeriveGeneric
5− , DerivingStrategies
6− , DuplicateRecordFields
7− , FlexibleContexts
8− , OverloadedLabels
9− , OverloadedLists
10− , OverloadedStrings
11− , TypeApplications
12− , TypeFamilies
13− , TypeInType
14− , TypeOperators
15−#-}
16−
17−module Main (main) where
18−
19−import Control.Concurrent.Async (replicateConcurrently)
20−import Data.ByteString (ByteString)
21−import Data.Int (Int32)
22−import Data.Text (Text)
23−import Test.Hspec
24−
25−import qualified Generics.SOP as SOP
26−import qualified GHC.Generics as GHC
27−
28−import Squeal.PostgreSQL
29−
30−main :: IO ()
31−main = hspec spec
32−
33−type Schemas = Public
34− '[ "users" ::: 'Table (
35− '[ "pk_users" ::: 'PrimaryKey '["id"]
36− , "unique_names" ::: 'Unique '["name"]
37− ] :=>
38− '[ "id" ::: 'Def :=> 'NotNull 'PGint4
39− , "name" ::: 'NoDef :=> 'NotNull 'PGtext ] ) ]
40−
41−data User = User
42− { userName :: Text
43− } deriving stock (Eq, Show, GHC.Generic)
44− deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
45−
46−insertUser :: Manipulation_ Schemas User ()
47−insertUser = insertInto_ #users
48− (Values_ (Default `as` #id :* Set (param @1) `as` #name))
49−
50−setup :: Definition (Public '[]) Schemas
51−setup =
52− createTable #users
53− ( serial `as` #id :*
54− notNullable text `as` #name )
55− ( primaryKey #id `as` #pk_users :*
56− unique #name `as` #unique_names )
57−
58−teardown :: Definition Schemas (Public '[])
59−teardown = dropTable #users
60−
61−silence :: MonadPQ schemas pq => pq ()
62−silence = manipulate_ $
63− UnsafeManipulation "SET client_min_messages TO WARNING;"
64−
65−setupDB :: IO ()
66−setupDB = withConnection connectionString $
67− silence & pqThen (define setup)
68−
69−dropDB :: IO ()
70−dropDB = withConnection connectionString $
71− silence & pqThen (define teardown)
72−
73−connectionString :: ByteString
74−connectionString = "host=localhost port=5432 dbname=exampledb"
75−
76−spec :: Spec
77−spec = before_ setupDB . after_ dropDB $ do
78−
79− describe "Exceptions" $ do
80−
81− let
82− testUser = User "TestUser"
83− newUser = manipulateParams_ insertUser
84− insertUserTwice = newUser testUser >> newUser testUser
85− err23505 = PQException $ PQState FatalError (Just "23505")
86− (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")
87−
88− it "should be thrown for constraint violation" $
89− withConnection connectionString insertUserTwice
90− `shouldThrow` (== err23505)
91−
92− it "should be rethrown for constraint violation in a transaction" $
93− withConnection connectionString (transactionally_ insertUserTwice)
94− `shouldThrow` (== err23505)
95−
96− describe "Pools" $
97−
98− it "should manage concurrent transactions" $ do
99− pool <- createConnectionPool
100− "host=localhost port=5432 dbname=exampledb" 1 0.5 10
101− let
102− query :: Query_ (Public '[]) () (Only Char)
103− query = values_ (literal 'a' `as` #fromOnly)
104− session = usingConnectionPool pool . transactionally_ $ do
105− result <- runQuery query
106− Just (Only chr) <- firstRow result
107− return chr
108− chrs <- replicateConcurrently 10 session
109− chrs `shouldSatisfy` all (== 'a')
110−
111− describe "Ranges" $
112−
113− it "should correctly decode ranges" $ do
114−
115− rangesOut <- withConnection connectionString $ do
116− let
117− query :: Query_ (Public '[]) () (Only (Range Int32))
118− query = values
119− ( range int4range (atLeast 3) `as` #fromOnly )
120− [ range int4range (3 <=..< 5) `as` #fromOnly
121− , range int4range Empty `as` #fromOnly
122− , range int4range whole `as` #fromOnly ]
123− getRows =<< runQuery query
124− (fromOnly <$> rangesOut :: [Range Int32]) `shouldBe`
125− [ atLeast 3, 3 <=..< 5, Empty, whole ]
126−
127− describe "Parameters" $ do
128−
129− it "should run queries that don't reference all their parameters" $ do
130−
131− out <- withConnection connectionString $ do
132− let
133− query :: Query_ (Public '[]) (Char,Int32) (Only Int32)
134− query = values_ (param @2 `as` #fromOnly)
135− firstRow =<< runQueryParams query ('a', 3 :: Int32)
136− (fromOnly <$> out :: Maybe Int32) `shouldBe` Just 3
squeal-presentation-raveline.mddeleted−794
@@ -1,794 +0,0 @@
1−# Squeal
2−
3−_A bridge between SQL and Haskell_
4−
5−by [@Raveline](https://github.com/raveline)
6−
7−---
8−
9−# Rationale
10−
11−Using `postgresql-simple` you have a typical "Trial, error, despair" workflow:
12−
13−- Write query manually or semi-automatically
14−
15−- Write haskell code using the query
16−
17−- Pray that the query syntax is correct
18−
19−- Pray that it returns what you want
20−
21−- Realize the inefficiency of prayer when it comes to SQL
22−
23−- Iterate till it works
24−
25−---
26−
27−![Can't take this anymore](http://gif.eraveline.eu/static/img/0x16e.gif)
28−
29−---
30−
31−# Use your best friend: GHC
32−
33−Squeal provides several eDSL to make your SQL typesafe:
34−
35−- Type level eDSL to express schema;
36−
37−- Value level eDSL to manipulate schema (plus migration, yeehaw !);
38−
39−- Type level eDSL to express queries;
40−
41−- Value level eDSL to perform queries
42−
43−However, it's not an ORM. There's no caching, lazy loading - you retain control over your memory. Also, joins - and mostly aggregation after joins - have to be handled manually.
44−
45−---
46−
47−# Part I. Schema & migration
48−
49−---
50−
51−# The Schema
52−
53−- The schema will be used to validate _everything_: migration, queries, etc.
54−
55−- A schema is mostly a collection of tables.
56−
57−- In this presentation, we will create a very basic database modeling a parliament. We will store _members of parliament_ and _parliamentary groups_.
58−
59−- A simple Schema to represent a Parliament could be:
60−
61−```haskell
62−type Schema = '[ "mp" ::: 'Table MemberOfParliament
63− , "groupp" ::: 'Table ParliamentGroup ]
64−```
65−
66−---
67−
68−> _note_ We need the `DataKinds` extension to be able to express heterogenous lists containing
69−> specific types like this one.
70−
71−> You can perfectly call your table "group" and not "groupp" even though it is a
72−> keyword in SQL - Squeal queries will be properly escaped.
73−
74−---
75−
76−# A small example
77−
78−```haskell
79−type ParliamentaryGroup =
80− '[ "pk_groupp" ::: 'PrimaryKey '["groupp_id"]]
81− :=>
82− '[ "groupp_id" ::: 'NoDef :=> 'NotNull 'PGuuid
83− , "name" ::: 'NoDef :=> 'NotNull 'PGtext
84− ]
85−```
86−
87−- That's a whole simple table defined in one go.
88−
89−- `:::` lets us define a column or a constraint.
90−
91−- `:=>` associates the constraints to the column.
92−
93−- Let's split constraints and column to study the syntax a bit more.
94−
95−---
96−
97−> _note_ We are using `:::` and `:=>` to quickly express associations when writing
98−> our schema. We need the `TypeOperators` extension.]
99−
100−---
101−
102−![What does this means ?!](http://gif.eraveline.eu/static/img/0x27e.gif)
103−
104−---
105−
106−# Defining a table
107−
108−```haskell
109−type MemberOfParliament =
110− '[ "pk_mp" ::: 'PrimaryKey '["mp_id"]
111− , "fk_mp_groupp" ::: 'ForeignKey '["mp_group"] "groupp" '["groupp_id"]
112− ] :=> MpCols
113−```
114−
115−- A table is a collection of constraints associated to a collection of columns.
116−
117−- We defined a table named "mp".
118−
119−- It has a constraint named "pk_mp", defining its primary key on column "mp_id".
120−
121−- It has a constraint named "fk_mp_groupp" defining a foreign key on column "mg_group", connected to the column "groupp_id" of table "groupp".
122−
123−- These constraints will be associated to the columns defined in `MpCols`.
124−
125−---
126−
127−# Defining columns
128−
129−```haskell
130−type MpCols =
131− '[ "mp_id" ::: 'NoDef :=> 'NotNull 'PGuuid
132− , "first_name" ::: 'NoDef :=> 'NotNull 'PGtext
133− , "last_name" ::: 'NoDef :=> 'NotNull 'PGtext
134− ]
135−```
136−
137−- A listing of column associate, for each element:
138−
139− * a name;
140−
141− * the mention of an eventual default value;
142−
143− * the nullability;
144−
145− * the type (obviously).
146−
147−---
148−
149−> _note_ GHC is already helping. If I named the "mp_id" column differently,
150−> GHC would yell because I promised a primary key constraint on a column named `mp_id`, so there must be one.]
151−
152−---
153−
154−# Implementating the schema
155−
156−- We will carry this schema type pretty much everywhere.
157−
158−- But before we play with this schema, we need to implement it.
159−
160−---
161−
162−```haskell
163−setup :: Definition '[] Schema
164−setup =
165− createTable #groupp
166− ( notNullable uuid `as` #groupp_id
167− :* notNullable text `as` #name)
168− ( primaryKey #groupp_id `as` #pk_groupp )
169− >>> createTable #mp
170− ( notNullable uuid `as` #mp_id
171− :* notNullable text `as` #first_name
172− :* notNullable text `as` #last_name
173− :* notNullable text `as` #mp_group)
174− ( primaryKey #mp_id `as` #pk_mp
175− :* foreignKey #mp_group #groupp #groupp_id
176− OnDeleteCascade OnUpdateCascade
177− `as` #fk_mp_groupp)
178−```
179−
180−---
181−
182−# Damn, that's verbose
183−
184−- Yes. But you need verbosity to get type safety.
185−
186−- On the plus side, it's fairly straightforward.
187−
188−- You use `:*` to compose the element of the heterogenous list of columns.
189−
190−- You use `>>>` to compose table creation.
191−
192−> _note_ The compiler will catch any mistype between Schema and
193−> definition; wrong nullability, wrong type, wrong name, etc.
194−
195−---
196−
197−> _note_ You'll also need `OverloadedLabels`, for naming stuff.
198−> This is mostly to avoid having to write manual proxies all
199−> the time and for convenience.
200−
201−---
202−
203−# Setting up the schema
204−
205−- Squeal comes with a very good migration manager, handling _upgrades_ AND
206−_downgrades_.
207−
208−- A migration is a simple type:
209−
210−```haskell
211−Migration io schema0 schema1
212−```
213−
214−- The first parameter is a BaseMonad (typically, IO).
215−
216−- The second parameter is "the current schema of your DB".
217−
218−- The last one is "what you will migrate to".
219−
220−- The `Definition` type used to define upgrade and downgrade functions use the
221− same logic (from one schema to the other).
222−
223−---
224−
225−# Defining our first migration
226−
227−- We have the setup bit, we need the teardown:
228−
229−```haskell
230−tearDown :: Definition Schema '[]
231−tearDown = dropTable #mp >>> dropTable #groupp
232−```
233−
234−> _note_ GHC will also detect the _proper_ order of what you typed in
235−> downgrade and upgrade should there be any conflict (with foreign keys).
236−
237−```haskell
238−initDB :: Migration IO '[] Schema
239−initDB =
240− Migration { name = "Schema creation"
241− , up = void $ define setup
242− , down = void $ define tearDown }
243−```
244−
245−---
246−
247−# Simple migrator example
248−
249−```haskell
250−main :: IO ()
251−main = do
252− printSQL setup
253− void $ withConnection connectionString $
254− migrateUp $ single initDB
255−```
256−
257−- We print the migration query; you can do this for all queries generated through Squeal.
258−
259−- We use `migrateUp` to perform the migration.
260−
261−- You can run several migration at the same time, to run only one use `single`.
262−
263−---
264−
265−![That was easy](http://gif.eraveline.eu/static/img/0x47f.gif)
266−
267−---
268−
269−# Part II. Insertions
270−
271−---
272−
273−# Manipulations & Queries
274−
275−Besides the specific case of migration, you will mostly perform:
276−
277−- `Manipulation` : inserting, updating and deleting data.
278−
279−- `Query` : fetching data.
280−
281−- Both types are parametric over the same things:
282−
283− * A schema
284−
285− * Input parameters
286−
287− * Output
288−
289−- Simplified, they look like this:
290−
291−```haskell
292−Manipulation schema params columns
293−
294−Query schema params columns
295−```
296−
297−
298−---
299−
300−# Our Haskell model
301−
302−```haskell
303−type Parliament = [Group]
304−
305−data Group =
306− Group { name :: Text
307− , members :: [MemberOfParliament] }
308−
309−data MemberOfParliament =
310− MemberOfParliament { firstName :: Text
311− , lastName :: Text }
312−```
313−
314−> _note_ We didn't use anything from Squeal.
315−> The model can be entirely separated from the persistence layer.
316−
317−---
318−
319−# Inserting a Parliamentary Group
320−
321−- A group is very simple: it's a uuid and a name. Let's define our params:
322−
323−```haskell
324−type GroupInsertionParams = '[ 'NotNull 'PGuuid
325− , 'NotNull 'PGtext ]
326−```
327−
328−- Params are not named, but they are indexed. You just need nullability and type.
329−
330−---
331−
332−```haskell
333−groupInsertion :: Manipulation Schema GroupInsertionParams '[]
334−groupInsertion =
335− insertRow_ #groupp ( Set (param @1) `as` #groupp_id
336− :* Set (param @2) `as` #name )
337−```
338−
339−---
340−
341−- `TypeApplication` lets us use the index of parameters (counting from 1).
342−
343−- Once again: all this is checked by the compiler. Wrong name, wrong type... you'll get a compile error.
344−
345−- `insertRow_` is a simplified version of `insertRow`. `insertRow` lets you express a `RETURNING` clause and the expected behaviour in case of conflict.
346−
347−---
348−
349−_Inserting a Member of Parliament_
350−# Doing an INSERT INTO ... SELECT
351−
352−- We could create a naive query that takes MP uuid, first name, last name and group uuid...
353−
354−---
355−
356−- But that's boring. So let's use the `INSERT INTO ... SELECT`.
357−
358−---
359−
360−- We will build a query that will return as constants our MP's uuid, first name and last name...
361−
362−---
363−
364−- ... and fetch the uuid of a group given the name of the group.
365−
366−---
367−
368−- There's a `insertQuery` utility function for that. All we have to do is write the `select` !
369−
370−```haskell
371−mpInsertion :: Manipulation Schema MpParams '[]
372−mpInsertion =
373− insertQuery_ #mp selectGroup -- we just have to write selectGroup !
374−```
375−
376−---
377−
378−_Inserting a Member of Parliament_
379−# The query type
380−
381−- A query looks just like a `Manipulation`:
382−
383−```haskell
384−Query schema params returns
385−```
386−
387−- Returns use a special syntax, that demands names, nullability and types:
388−
389−```haskell
390−type ExampleReturnType = '[ "some_column" ::: 'NotNull 'PGuuid
391− , "other_column" ::: 'Null 'PGtext ]
392−```
393−
394−- It is not the same as the column definition we used in the schema. That one also expects that you specify, for each column, an eventual default:
395−
396−```haskell
397−type ExampleSchemaCols =
398− '[ "some_column" ::: 'NoDef :=> 'NotNull 'PGuuid
399− , "other_column" ::: 'NoDef :=> 'Null 'PGtext ]
400−```
401−
402−---
403−
404−_Inserting a Member of Parliament_
405−# Don't rewrite column definitions
406−
407−- We want our return type to be "all columns from table MP expressed as return type".
408−
409−- But we cannot reuse our neat `MpCols` alias, since the type do not match as we've just seen.
410−
411−- Hopefully, there's a neat Type Family that will let you convert any table you defined to the type of the equivalent row: `TableToRow`.
412−
413−- We finally have the signature for our SELECT query.
414−
415−```haskell
416−selectGroup :: Query Schema MpParams (TableToRow MemberOfParliament)
417−```
418−
419−---
420−
421−_Inserting a Member of Parliament_
422−# Our final Select query
423−
424−- Our intermediate query looks like this:
425−
426−```haskell
427−selectGroup =
428− select
429− ( param @1 `as` #mp_id
430− :* param @2 `as` #first_name
431− :* param @3 `as` #last_name
432− :* #groupp ! #groupp_id `as` #mp_group
433− )
434− ( from (table #groupp)
435− & where_ ( #groupp ! #name .== param @4 )
436− )
437−```
438−
439−- The first three columns are constant defined through our params;
440−
441−- ... we alias the column name using `as`...
442−
443−- ... and when we need the result from the table we use the `#table ! #column` syntax.
444−
445−- We'll go back to the "from" block later.
446−
447−---
448−
449−# Dealing with the connection context
450−
451−- Queries are runned in a connection context:
452−
453− * When dealing with a single-connection context, use the type `PQ`.
454−
455− * When dealing with a pool of connection, use the type `PoolPQ`.
456−
457−- Or get rid of the context and use `mtl` style, with the typeclass `MonadPQ`.
458−
459−- We'll use that to demonstrate how to actually run our queries.
460−
461−---
462−
463−# Inserting a whole group
464−
465−```haskell
466−insertGroup :: (MonadPQ Schema m, MonadBaseControl IO m) => Group -> m ()
467−insertGroup g@(Group name _) = do
468− uuid' <- liftBase nextRandom
469− void $ manipulateParams groupInsertion (uuid', name)
470− insertMps g
471−```
472−
473−- Remember that we defined a group as a name and a list of MPs.
474−
475−- We are in `MonadBaseControl`, so we cannot use `liftIO`, we need `liftBase`.
476−
477−- To perform a simple insertion, use `manipulateParams`. It takes into parameter
478−instances of `ToParam`, but you will typically use tuples or Generic-SOP.
479−
480−---
481−
482−# Inserting a bunch of MPs
483−
484−```haskell
485−insertMps :: (MonadPQ Schema m, MonadBaseControl IO m) => Group -> m ()
486−insertMps (Group groupName mps) =
487− let tuplify Mp{..} = (, firstName, lastName, groupName) <$> nextRandom
488− params = traverse tuplify mps
489− in void $ liftBase params >>= traversePrepared mpInsertion
490−```
491−
492−- This time, we want to do a `preparedStatement`. We'll use `traversePrepare`
493−which behaves like `manipulateParams`, but expect a list of `ToParam`
494−instances.
495−
496−- We build our tuple manually again, mostly because we want to generate UUID on
497−the fly and we don't want to have them in our model.
498−
499−---
500−
501−# Inserting a whole parliament
502−
503−```haskell
504−insertParliament ::
505− (MonadPQ Schema m, MonadBaseControl IO m) => Parliament -> m ()
506−insertParliament = traverse_ insertGroup
507−```
508−
509−- That's simple enough !
510−
511−- If we want to be a bit safer, though, we can wrap this call in a
512−`transactionally_` function, which will put all that in a transaction.
513−
514−---
515−
516−![Very simple](https://media1.tenor.com/images/0188c63209aced59f1583e1ca94e509e/tenor.gif?itemid=3550689)
517−
518−
519−---
520−
521−# Part III. Selects
522−
523−---
524−
525−# Composable queries
526−
527−- Building basic queries is easy, and is well documented.
528−
529−- However, the real interest of a tool like Squeal is in DRYness, and the documentation is still lacking in "how-to" related to composability.
530−
531−- I'll build an example showing how column selections and from clause can be factorized.
532−
533−- We want to write two queries:
534−
535− * One to get all members of a specific group.
536−
537− * One to get all the parliament.
538−
539−---
540−
541−# Decomposing a `Query`
542−
543−- A query typically stars with `select` (variants are available).
544−
545−- It then takes:
546−
547− * A heterogenous list of fields with a scary signature;
548−
549− * A virtual table (the from clause and filter clauses), called a `TableExpression`.
550−
551−- And return fields. Ours will look like this:
552−
553−```haskell
554−type GroupRowResult =
555− '[ "groupName" ::: 'NotNull 'PGtext
556− , "firstName" ::: 'NotNull 'PGtext
557− , "lastName" ::: 'NotNull 'PGtext ]
558−```
559−
560−---
561−
562−# The Table Expression
563−
564−- It necessarily contains a `fromClause` (table, view or subquery, plus optional joins).
565−
566−- You can add where, groups, "HAVING" clause, order, etc.
567−
568−- `from` creates a basic `TableExpression` that you extend through various function to add clauses.
569−
570−- For our queries, we will share a common `FromClause`.
571−
572−---
573−
574−# The From Clause
575−
576−```
577−FromClause schema params from
578−```
579−
580−- We need Schema, input parameters and a `FromType` giving the available fields of the expression.
581−
582−- In our case, we'll join the table `mp` and the table `groupp`, meaning the `from` will be all fields of these tables.
583−
584−- We can use `TableToRow` to be more DRY:
585−
586−```haskell
587−type BaseParliamentSelection =
588− '[ "g" ::: TableToRow GroupCols
589− , "m" ::: TableToRow MpCols ]
590−```
591−
592−> _note_ We've also put everything with table aliases: "g" and "m".
593−
594−---
595−
596−# Writing our from clause
597−
598−```haskell
599−baseParliamentTables ::
600− FromClause Schema (param :: [NullityType]) BaseParliamentSelection
601−baseParliamentTables =
602− table
603− (#groupp `as` #g)
604− & innerJoin
605− (table (#mp `as` #m))
606− (#m ! #mp_group .== #g ! #groupp_id)
607−```
608−
609−- When picking "from" something, you need to specify the type with a function: `table` for a table, `view` for a view, etc.
610−
611−- All joins are available. `innerJoin` is the most basic one. It takes the joined table and the joining condition.
612−
613−- We have to specifiy the type of `param` (current limitation of the lib), even though _any_ params will be compatible with this, so we can plug `where` clauses depending on params should we need to !
614−
615−---
616−
617−# Typing the common selection
618−
619−- Both our querie will need the same fields. This has to be factorized too.
620−
621−- The scary signature of selection fields:
622−
623−```haskell
624−NP (Aliased (Expression schema from grouping params)) cols
625−```
626−
627−- `NP` is for heterogenous lists ("n-ary product").
628−
629−- `from` is the virtual table type, so our `BaseParliamentSelection`.
630−
631−- `grouping` is there to make a distinction between aggregated / unaggregated queries.
632−
633−- And finally, cols is the return type.
634−
635−---
636−
637−# Our common selection
638−
639−```haskell
640−groupSelection ::
641− NP (Aliased (Expression Schema BaseParliamentSelection 'Ungrouped param))
642− GroupRowResult
643−groupSelection =
644− #g ! #name `as` #groupName
645− :* #m ! #first_name `as` #firstName
646− :* #m ! #last_name `as` #lastName
647−```
648−
649−- I hope you like big signatures.
650−
651−- But it's what let GHC checks that all alias and columns are available.
652−
653−- And that you're returning what you really intend to return.
654−
655−---
656−
657−# Putting it all together
658−
659−```haskell
660−selectParliament :: Query Schema '[] GroupRowResult
661−selectParliament =
662− select groupSelection (from baseParliamentTables)
663−```
664−
665−```haskell
666−selectGroupMembers :: Query Schema '[ 'NotNull 'PGtext] GroupRowResult
667−selectGroupMembers =
668− select groupSelection
669− (from baseParliamentTables
670− & where_ (#g ! #name .== param @1))
671−```
672−
673−- That is fairly DRY. And _entirely typesafe_.
674−
675−---
676−
677−# Actually fetching the data
678−
679−- We'll build an intermediary datatype representing our rows.
680−
681−- We'll make it match our row.
682−
683−- And we'll add generic-SOP so that we can build them from query results.
684−
685−```haskell
686−type GroupRowResult =
687− '[ "groupName" ::: 'NotNull 'PGtext
688− , "firstName" ::: 'NotNull 'PGtext
689− , "lastName" ::: 'NotNull 'PGtext ]
690−```
691−
692−```haskell
693−data GroupRow =
694− GroupRow { groupName :: Text
695− , firstName :: Text
696− , lastName :: Text }
697− deriving (Generic)
698−
699−instance SOP.Generic GroupRow
700−instance SOP.HasDatatypeInfo GroupRow
701−```
702−
703−---
704−
705−# Aggregate result logic
706−
707−- We will get tabular, SQL data.
708−
709−- Our results will be `[GroupRow]`.
710−
711−- We'll build `Groups` from this:
712−
713−```haskell
714−buildGroup :: NE.NonEmpty GroupRow -> Group
715−buildGroup grs =
716− let buildMP (GroupRow _ f l) = Mp f l
717− name = groupName . NE.head $ grs
718− members = NE.toList (buildMP <$> grs)
719− in Group{..}
720−
721−rowToGroups :: [GroupRow] -> [Group]
722−rowToGroups =
723− let grouped = fmap NE.fromList . L.groupBy ((==) `on` groupName)
724− in fmap buildGroup . grouped
725−```
726−
727−---
728−
729−# Finally calling our queries
730−
731−- Query with params will use `runQueryParams`.
732−
733−- Query without params will use `runQuery`.
734−
735−- Result is inside a `MonadPQ` and of type `K` from generic-sop.
736−
737−- You get your actual result using `getRows`. Exemple:
738−
739−```haskell
740−getParliament :: (MonadPQ Schema m, MonadBaseControl IO m) => m [Group]
741−getParliament = do
742− res <- runQuery selectParliament
743− rows <- getRows res
744− pure $ rowToGroups rows
745−```
746−
747−- In real life of course you'll write:
748−
749−```haskell
750−getParliament =
751− rowToGroups <$> (runQuery selectParliament >>= getRows)
752−```
753−
754−---
755−
756−# Our query with params
757−
758−```haskell
759−getGroupMembers ::
760− (MonadPQ Schema m, MonadBaseControl IO m) => Text -> m (Maybe Group)
761−getGroupMembers =
762− listToMaybe . rowToGroups <$>
763− (runQueryParams selectGroupMembers (Only t) >>= getRows)
764−```
765−
766−- And that's it.
767−
768−---
769−
770−![Eazy](https://media.tenor.com/images/8fc7c4077efe11b4a3a3b9ae4e643e87/tenor.gif)
771−
772−---
773−
774−# Conclusion
775−
776−---
777−
778−# Pros & Cons
779−
780−- Not everything is included: some cool stuff like array_agg and window functions are not available yet.
781−
782−- But development is _very_ active. `IN` clauses were missing but were added in the 4.0 released recently.
783−
784−- It's bleeding edge. You need latest LTS to be comfortable and psql >= 9.5.
785−
786−- It's Postgres-only but I would say that's a feature. Multi-DB tools are even more complex.
787−
788−- The author & maintainer is <3.
789−
790−- Typesafe. 'nuff said.
791−
792−---
793−
794−# Thank you !
squeal-presentation.pdfdeleted

Binary file not shown.

squeal-postgresql/Setup.hs → squeel-postgresql/Setup.hsrenamed

The content is the same.

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