dev..c59b6ff · squeal · git.iko.soy

git.iko.soy/squeal

59 files changed+2350−14223

unifiedsplit

.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+2−275

@@ -2,279 +2,6 @@

33![squeal-icon](http://www.emoticonswallpapers.com/emotion/cute-big-pig/cute-pig-smiley-046.gif)

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/squeal.svg?style=svg&circle-token=a699a654ef50db2c3744fb039cf2087c484d1226)](https://circleci.com/gh/echatav/squeal)

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 squeal 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+12

@@ -0,0 +1,12 @@

1+dependencies:

2+ cache_directories:

3+ - "~/.stack"

4+ - ".stack-work"

5+ override:

6+ - stack upgrade

7+ - stack update

8+ - stack setup

9+ - stack test --no-run-tests

10+test:

11+ override:

12+ - stack test

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 @@

2−

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.hs+62−96

@@ -1,107 +1,41 @@

1+{-# OPTIONS_GHC -fno-warn-unused-imports #-}

12{-# LANGUAGE

23 DataKinds

34 , DeriveGeneric

4− , FlexibleContexts

5+ , FlexibleInstances

6+ , MultiParamTypeClasses

57 , OverloadedLabels

68 , OverloadedStrings

7− , OverloadedLists

89 , TypeApplications

910 , TypeOperators

11+ , TypeSynonymInstances

1012#-}

1113

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)

14+module Main (main,col1,col2) where

1915

16+import Control.Category ((>>>))

17+import Control.Monad.Base

18+import Data.Function ((&))

19+import Data.Int

20+import Data.Monoid

21+import Generics.SOP hiding (from)

2022import Squeal.PostgreSQL

2123

2224import qualified Data.ByteString.Char8 as Char8

23−import qualified Generics.SOP as SOP

2425import qualified GHC.Generics as GHC

2526

2627type 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

28+ '[ "students" ::: '["name" ::: 'Required ('NotNull 'PGtext)]

29+ , "table1" :::

30+ '[ "col1" ::: 'Required ('NotNull 'PGint4)

31+ , "col2" ::: 'Required ('NotNull 'PGint4)

32+ ]

4233 ]

4334

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)) }

35+data Table1Row = Table1Row { col1 :: Int32, col2 :: Int32 }

8436 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])

37+instance Generic Table1Row

38+instance HasDatatypeInfo Table1Row

10539

10640main :: IO ()

10741main = do

@@ -111,15 +45,47 @@ main = do

11145 Char8.putStrLn $ "connecting to " <> connectionString

11246 connection0 <- connectdb connectionString

11347 Char8.putStrLn "setting up schema"

114− connection1 <- execPQ (define setup) connection0

115− connection2 <- execPQ session connection1

48+ connection1 <- flip execPQ (connection0 :: Connection '[]) $ define $

49+ createTable #students ((text & notNull) `As` #name :* Nil ) []

50+ >>>

51+ createTable #table1

52+ ((int4 & notNull) `As` #col1 :* (int4 & notNull) `As` #col2 :* Nil) []

53+ connection2 <- flip execPQ (connection1 :: Connection Schema) $ do

54+ let

55+ insert :: Manipulation Schema

56+ '[ 'Required ('NotNull 'PGint4)

57+ , 'Required ('NotNull 'PGint4)

58+ , 'Required ('NotNull 'PGint4)

59+ , 'Required ('NotNull 'PGint4)

60+ ] '[]

61+ insert =

62+ insertInto #table1

63+ ( Values

64+ (param (Proxy @1) `As` #col1 :* param (Proxy @2) `As` #col2 :* Nil)

65+ [param (Proxy @3) `As` #col1 :* param (Proxy @4) `As` #col2 :* Nil]

66+ ) Conflict (Returning Nil)

67+ liftBase $ Char8.putStrLn "manipulating"

68+ _insertResult <- manipulateParams insert

69+ (1::Int32,2::Int32,3::Int32,4::Int32)

70+ liftBase $ Char8.putStrLn "querying"

71+ result <- query $

72+ selectStar (from (Table (#table1 `As` #table1)))

73+ value00 <- getValue (RowNumber 0) (columnNumber @0) result

74+ value01 <- getValue (RowNumber 0) (columnNumber @1) result

75+ value10 <- getValue (RowNumber 1) (columnNumber @0) result

76+ value11 <- getValue (RowNumber 1) (columnNumber @1) result

77+ row0 <- getRow (RowNumber 0) result

78+ row1 <- getRow (RowNumber 1) result

79+ rows <- getRows result

80+ liftBase $ do

81+ print (value00 :: Int32)

82+ print (value01 :: Int32)

83+ print (value10 :: Int32)

84+ print (value11 :: Int32)

85+ print (row0 :: Table1Row)

86+ print (row1 :: Table1Row)

87+ print (rows :: [Table1Row])

11688 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)

89+ connection3 <- flip execPQ (connection2 :: Connection Schema) $ define $

90+ dropTable #table1 >>> dropTable #students

91+ finish (connection3 :: Connection '[])

squeal-postgresql/squeal-postgresql.cabal+42−118

@@ -1,147 +1,71 @@

11name: squeal-postgresql

2−version: 0.5.1.0

2+version: 0.0.0.1

33synopsis: 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

4+description: Squeal is a type-safe embedding of PostgreSQL and libpq in Haskell

5+homepage: https://github.com/echatav/squeal

96author: Eitan Chatav

107maintainer: eitan.chatav@gmail.com

8+copyright: 2017 Morphism, LLC

129category: Database

1310build-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

11+cabal-version: >=1.10

2012

2113library

2214 hs-source-dirs: src

2315 exposed-modules:

2416 Squeal.PostgreSQL

25− Squeal.PostgreSQL.Alias

2617 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

5918 Squeal.PostgreSQL.PQ

60− Squeal.PostgreSQL.Render

61− Squeal.PostgreSQL.Query

19+ Squeal.PostgreSQL.Statement

6220 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

10321 default-language: Haskell2010

104− type: exitcode-stdio-1.0

105− hs-source-dirs: test

106− ghc-options: -Wall

107− main-is: Property.hs

22+ ghc-options: -Wall -Werror -fprint-explicit-kinds

10823 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

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

11640

117−test-suite spec

41+test-suite squeal-postgresql-test

11842 default-language: Haskell2010

11943 type: exitcode-stdio-1.0

12044 hs-source-dirs: test

121− ghc-options: -Wall

45+ ghc-options: -Wall -Werror

12246 main-is: Spec.hs

47+ other-modules:

48+ Squeal.PostgreSQL.StatementSpec

12349 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

50+ base

51+ , generics-sop

52+ , hspec

13053 , squeal-postgresql

131− , text >= 1.2.2.2

132− , vector >= 0.12.0.1

13354

134−executable example

55+executable squeal-postgresql-example

13556 default-language: Haskell2010

13657 hs-source-dirs: exe

137− ghc-options: -Wall

58+ ghc-options: -Wall -Werror

13859 main-is: Example.hs

13960 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

61+ base

62+ , bytestring

63+ , generics-sop

64+ , mtl

14465 , squeal-postgresql

145− , text >= 1.2.2.2

146− , transformers >= 0.5.2.0

147− , vector >= 0.12.0.1

66+ , transformers

67+ , transformers-base

68+

69+source-repository head

70+ type: git

71+ location: https://github.com/echatav/squeal

squeal-postgresql/src/Squeal/PostgreSQL.hs+11−233

@@ -1,233 +1,11 @@

1−{-|

2−Module: Squeal.PostgreSQL

3−Description: Squeal export module

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Squeal is a deep embedding of [PostgreSQL](https://www.postgresql.org) in Haskell.

9−Let's see an example!

10−

11−First, we need some language extensions because Squeal uses modern GHC

12−features.

13−

14−>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels -XFlexibleContexts

15−>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs

16−

17−We'll need some imports.

18−

19−>>> import Control.Monad.IO.Class (liftIO)

20−>>> import Data.Int (Int32)

21−>>> import Data.Text (Text)

22−>>> import Squeal.PostgreSQL

23−

24−We'll use generics to easily convert between Haskell and PostgreSQL values.

25−

26−>>> import qualified Generics.SOP as SOP

27−>>> import qualified GHC.Generics as GHC

28−

29−The first step is to define the schema of our database. This is where

30−we use @DataKinds@ and @TypeOperators@.

31−

32−>>> :{

33−type UsersColumns =

34− '[ "id" ::: 'Def :=> 'NotNull 'PGint4

35− , "name" ::: 'NoDef :=> 'NotNull 'PGtext ]

36−type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]

37−type EmailsColumns =

38− '[ "id" ::: 'Def :=> 'NotNull 'PGint4

39− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4

40− , "email" ::: 'NoDef :=> 'Null 'PGtext ]

41−type EmailsConstraints =

42− '[ "pk_emails" ::: 'PrimaryKey '["id"]

43− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"] ]

44−type Schema =

45− '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns)

46− , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ]

47−type Schemas = Public Schema

48−:}

49−

50−Notice the use of type operators.

51−

52−`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemasType`, a `SchemumType`,

53−a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's @::@

54−operator.

55−

56−`:=>` is used to pair `TableConstraints` with a `ColumnsType`,

57−yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,

58−yielding a `ColumnType`. It is intended to connote Haskell's @=>@ operator

59−

60−Next, we'll write `Definition`s to set up and tear down the schema. In

61−Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`

62−has two type parameters, corresponding to the schema

63−before being run and the schema after. We can compose definitions using `>>>`.

64−Here and in the rest of our commands we make use of overloaded

65−labels to refer to named tables and columns in our schema.

66−

67−>>> :{

68−let

69− setup :: Definition (Public '[]) Schemas

70− setup =

71− createTable #users

72− ( serial `as` #id :*

73− (text & notNullable) `as` #name )

74− ( primaryKey #id `as` #pk_users ) >>>

75− createTable #emails

76− ( serial `as` #id :*

77− (int & notNullable) `as` #user_id :*

78− (text & nullable) `as` #email )

79− ( primaryKey #id `as` #pk_emails :*

80− foreignKey #user_id #users #id

81− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

82−:}

83−

84−We can easily see the generated SQL is unsurprising looking.

85−

86−>>> printSQL setup

87−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));

88−CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);

89−

90−Notice that @setup@ starts with an empty public schema @(Public '[])@ and produces @Schemas@.

91−In our `createTable` commands we included `TableConstraint`s to define

92−primary and foreign keys, making them somewhat complex. Our @teardown@

93−`Definition` is simpler.

94−

95−>>> :{

96−let

97− teardown :: Definition Schemas (Public '[])

98− teardown = dropTable #emails >>> dropTable #users

99−:}

100−

101−>>> printSQL teardown

102−DROP TABLE "emails";

103−DROP TABLE "users";

104−

105−We'll need a Haskell type for @User@s. We give the type `Generics.SOP.Generic` and

106−`Generics.SOP.HasDatatypeInfo` instances so that we can encode and decode @User@s.

107−

108−>>> data User = User { userName :: Text, userEmail :: Maybe Text } deriving (Show, GHC.Generic)

109−>>> instance SOP.Generic User

110−>>> instance SOP.HasDatatypeInfo User

111−

112−Next, we'll write `Manipulation_`s to insert @User@s into our two tables.

113−A `Manipulation_` like `insertInto`, `update` or `deleteFrom`

114−has three type parameters, the schemas it refers to, input parameters

115−and an output row. When

116−we insert into the users table, we will need a parameter for the @name@

117−field but not for the @id@ field. Since it's serial, we can use a default

118−value. However, since the emails table refers to the users table, we will

119−need to retrieve the user id that the insert generates and insert it into

120−the emails table. We can do this in a single `Manipulation_` by using a

121−`with` statement.

122−

123−>>> :{

124−let

125− insertUser :: Manipulation_ Schemas User ()

126− insertUser = with (u `as` #u) e

127− where

128− u = insertInto #users

129− (Values_ (Default `as` #id :* Set (param @1) `as` #name))

130− OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))

131− e = insertInto_ #emails $ Select

132− (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)

133− (from (common #u))

134−:}

135−

136−>>> printSQL insertUser

137−WITH "u" AS (INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) RETURNING "id" AS "id", ($2 :: text) AS "email") INSERT INTO "emails" ("user_id", "email") SELECT "u"."id", "u"."email" FROM "u" AS "u"

138−

139−Next we write a `Query_` to retrieve users from the database. We're not

140−interested in the ids here, just the usernames and email addresses. We

141−need to use an `innerJoin` to get the right result. A `Query_` is like a

142−`Manipulation_` with the same kind of type parameters.

143−

144−>>> :{

145−let

146− getUsers :: Query_ Schemas () User

147− getUsers = select_

148− (#u ! #name `as` #userName :* #e ! #email `as` #userEmail)

149− ( from (table (#users `as` #u)

150− & innerJoin (table (#emails `as` #e))

151− (#u ! #id .== #e ! #user_id)) )

152−:}

153−

154−>>> printSQL getUsers

155−SELECT "u"."name" AS "userName", "e"."email" AS "userEmail" FROM "users" AS "u" INNER JOIN "emails" AS "e" ON ("u"."id" = "e"."user_id")

156−

157−Let's create some users to add to the database.

158−

159−>>> :{

160−let

161− users :: [User]

162− users =

163− [ User "Alice" (Just "alice@gmail.com")

164− , User "Bob" Nothing

165− , User "Carole" (Just "carole@hotmail.com")

166− ]

167−:}

168−

169−Now we can put together all the pieces into a program. The program

170−connects to the database, sets up the schema, inserts the user data

171−(using prepared statements as an optimization), queries the user

172−data and prints it out and finally closes the connection. We can thread

173−the changing schema information through by using the indexed `PQ` monad

174−transformer and when the schema doesn't change we can use `Monad` and

175−`MonadPQ` functionality.

176−

177−>>> :{

178−let

179− session :: PQ Schemas Schemas IO ()

180− session = do

181− _ <- traversePrepared_ insertUser users

182− usersResult <- runQuery getUsers

183− usersRows <- getRows usersResult

184− liftIO $ print (usersRows :: [User])

185−in

186− withConnection "host=localhost port=5432 dbname=exampledb" $

187− define setup

188− & pqThen session

189− & pqThen (define teardown)

190−:}

191−[User {userName = "Alice", userEmail = Just "alice@gmail.com"},User {userName = "Bob", userEmail = Nothing},User {userName = "Carole", userEmail = Just "carole@hotmail.com"}]

192−-}

193−module Squeal.PostgreSQL (module X, RenderSQL(..), printSQL) where

194−

195−import Squeal.PostgreSQL.Alias as X

196−import Squeal.PostgreSQL.Binary as X

197−import Squeal.PostgreSQL.Definition as X

198−import Squeal.PostgreSQL.Definition.Function as X

199−import Squeal.PostgreSQL.Definition.Index as X

200−import Squeal.PostgreSQL.Definition.Schema as X

201−import Squeal.PostgreSQL.Definition.Table as X

202−import Squeal.PostgreSQL.Definition.Table.Constraint as X

203−import Squeal.PostgreSQL.Definition.Type as X

204−import Squeal.PostgreSQL.Definition.View as X

205−import Squeal.PostgreSQL.Expression as X

206−import Squeal.PostgreSQL.Expression.Aggregate as X

207−import Squeal.PostgreSQL.Expression.Collection as X

208−import Squeal.PostgreSQL.Expression.Comparison as X

209−import Squeal.PostgreSQL.Expression.Json as X

210−import Squeal.PostgreSQL.Expression.Literal as X

211−import Squeal.PostgreSQL.Expression.Logic as X

212−import Squeal.PostgreSQL.Expression.Math as X

213−import Squeal.PostgreSQL.Expression.Null as X

214−import Squeal.PostgreSQL.Expression.Parameter as X

215−import Squeal.PostgreSQL.Expression.Range as X

216−import Squeal.PostgreSQL.Expression.Set as X

217−import Squeal.PostgreSQL.Expression.Sort as X

218−import Squeal.PostgreSQL.Expression.Subquery as X

219−import Squeal.PostgreSQL.Expression.Text as X

220−import Squeal.PostgreSQL.Expression.TextSearch as X

221−import Squeal.PostgreSQL.Expression.Time as X

222−import Squeal.PostgreSQL.Expression.Type as X

223−import Squeal.PostgreSQL.Expression.Window as X

224−import Squeal.PostgreSQL.List as X

225−import Squeal.PostgreSQL.Manipulation as X

226−import Squeal.PostgreSQL.Migration as X

227−import Squeal.PostgreSQL.PG as X

228−import Squeal.PostgreSQL.Pool as X

229−import Squeal.PostgreSQL.PQ as X

230−import Squeal.PostgreSQL.Query as X

231−import Squeal.PostgreSQL.Render (RenderSQL(..), printSQL)

232−import Squeal.PostgreSQL.Schema as X

233−import Squeal.PostgreSQL.Transaction as X

1+module Squeal.PostgreSQL

2+ ( module Squeal.PostgreSQL.Binary

3+ , module Squeal.PostgreSQL.PQ

4+ , module Squeal.PostgreSQL.Schema

5+ , module Squeal.PostgreSQL.Statement

6+ ) where

8+import Squeal.PostgreSQL.Binary

9+import Squeal.PostgreSQL.PQ

10+import Squeal.PostgreSQL.Schema

11+import Squeal.PostgreSQL.Statement

squeal-postgresql/src/Squeal/PostgreSQL/Alias.hsdeleted−249

@@ -1,249 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Alias

3−Description: Aliases

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−This module embeds Postgres's alias system in Haskell in

9−a typesafe fashion. Thanks to GHC's @OverloadedLabels@ extension,

10−Squeal can reference aliases by prepending with a @#@.

11−-}

12−

13−{-# LANGUAGE

14− AllowAmbiguousTypes

15− , ConstraintKinds

16− , DeriveAnyClass

17− , DeriveGeneric

18− , FlexibleContexts

19− , FlexibleInstances

20− , FunctionalDependencies

21− , GADTs

22− , LambdaCase

23− , OverloadedStrings

24− , QuantifiedConstraints

25− , RankNTypes

26− , ScopedTypeVariables

27− , StandaloneDeriving

28− , TypeApplications

29− , TypeFamilyDependencies

30− , TypeInType

31− , TypeOperators

32− , UndecidableInstances

33− , UndecidableSuperClasses

34−#-}

35−

36−module Squeal.PostgreSQL.Alias

37− ( (:::)

38− , Alias (..)

39− , IsLabel (..)

40− , Aliased (As)

41− , Aliasable (as)

42− , renderAliased

43− , Has

44− , HasUnique

45− , HasAll

46− , HasIn

47− , QualifiedAlias (..)

48− , IsQualified (..)

49− -- * Grouping

50− , Grouping (..)

51− , GroupedBy

52− ) where

53−

54−import Control.DeepSeq

55−import Data.ByteString (ByteString)

56−import Data.String (fromString)

57−import GHC.OverloadedLabels

58−import GHC.TypeLits

59−

60−import qualified Generics.SOP as SOP

61−import qualified GHC.Generics as GHC

62−

63−import Squeal.PostgreSQL.List

64−import Squeal.PostgreSQL.Render

65−

66−-- $setup

67−-- >>> import Squeal.PostgreSQL

68−

69−-- | The alias operator `:::` is like a promoted version of `As`,

70−-- a type level pair between an alias and some type.

71−type (:::) (alias :: Symbol) ty = '(alias,ty)

72−infixr 6 :::

73−

74−

75−-- | `Grouping` is an auxiliary namespace, created by

76−-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used

77−-- for typesafe aggregation

78−data Grouping

79− = Ungrouped -- ^ no aggregation permitted

80− | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped

81−

82−{- | A `GroupedBy` constraint indicates that a table qualified column is

83−a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,

84−may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.

85−-}

86−class (KnownSymbol table, KnownSymbol column)

87− => GroupedBy table column bys where

88−instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)

89− => GroupedBy table column ('(table,column) ': bys)

90−instance {-# OVERLAPPABLE #-}

91− ( KnownSymbol table

92− , KnownSymbol column

93− , GroupedBy table column bys

94− ) => GroupedBy table column (tabcol ': bys)

95−

96−-- | `Alias`es are proxies for a type level string or `Symbol`

97−-- and have an `IsLabel` instance so that with @-XOverloadedLabels@

98−--

99−-- >>> :set -XOverloadedLabels

100−-- >>> #foobar :: Alias "foobar"

101−-- Alias

102−data Alias (alias :: Symbol) = Alias

103− deriving (Eq,GHC.Generic,Ord,Show,NFData)

104−instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where

105− fromLabel = Alias

106−instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where

107− fromLabel = fromLabel SOP.:* Nil

108−-- | >>> printSQL (#jimbob :: Alias "jimbob")

109−-- "jimbob"

110−instance KnownSymbol alias => RenderSQL (Alias alias) where

111− renderSQL = doubleQuoted . fromString . symbolVal

112−

113−-- >>> printSQL (#jimbob :* #kandi :: NP Alias '["jimbob", "kandi"])

114−-- "jimbob", "kandi"

115−instance SOP.All KnownSymbol aliases => RenderSQL (NP Alias aliases) where

116− renderSQL

117− = commaSeparated

118− . SOP.hcollapse

119− . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderSQL)

120−

121−-- | The `As` operator is used to name an expression. `As` is like a demoted

122−-- version of `:::`.

123−--

124−-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)

125−-- As (Just "hello") Alias

126−data Aliased expression aliased where

127− As

128− :: KnownSymbol alias

129− => expression ty

130− -> Alias alias

131− -> Aliased expression (alias ::: ty)

132−deriving instance Show (expression ty)

133− => Show (Aliased expression (alias ::: ty))

134−deriving instance Eq (expression ty)

135− => Eq (Aliased expression (alias ::: ty))

136−deriving instance Ord (expression ty)

137− => Ord (Aliased expression (alias ::: ty))

138−instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)

139− => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where

140− fromLabel = fromLabel @alias2 `As` fromLabel @alias1

141−

142−-- | The `Aliasable` class provides a way to scrap your `Nil`s

143−-- in an `NP` list of `Aliased` expressions.

144−class KnownSymbol alias => Aliasable alias expression aliased

145− | aliased -> expression

146− , aliased -> alias

147− where as :: expression -> Alias alias -> aliased

148−instance (KnownSymbol alias, aliased ~ (alias ::: ty)) => Aliasable alias

149− (expression ty)

150− (Aliased expression aliased)

151− where

152− as = As

153−instance (KnownSymbol alias, tys ~ '[alias ::: ty]) => Aliasable alias

154− (expression ty)

155− (NP (Aliased expression) tys)

156− where

157− expression `as` alias = expression `As` alias SOP.:* Nil

158−

159−-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")

160−-- >>> renderAliased renderMaybe (Just (3::Int) `As` #an_int)

161−-- "Just AS \"an_int\""

162−renderAliased

163− :: (forall ty. expression ty -> ByteString)

164− -> Aliased expression aliased

165− -> ByteString

166−renderAliased render (expression `As` alias) =

167− render expression <> " AS " <> renderSQL alias

168−

169−-- | @HasUnique alias fields field@ is a constraint that proves that

170−-- @fields@ is a singleton of @alias ::: field@.

171−type HasUnique alias fields field = fields ~ '[alias ::: field]

172−

173−-- | @Has alias fields field@ is a constraint that proves that

174−-- @fields@ has a field of @alias ::: field@, inferring @field@

175−-- from @alias@ and @fields@.

176−class KnownSymbol alias =>

177− Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)

178− | alias fields -> field where

179−instance {-# OVERLAPPING #-} KnownSymbol alias

180− => Has alias (alias ::: field ': fields) field

181−instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)

182− => Has alias (field' ': fields) field

183−

184−{-| @HasIn fields (alias ::: field)@ is a constraint that proves that

185−@fields@ has a field of @alias ::: field@. It is used in @UPDATE@s to

186−choose which subfields to update.

187−-}

188−class HasIn fields field where

189−instance (Has alias fields field) => HasIn fields (alias ::: field) where

190−

191−-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer

192−-- a list of @subfields@.

193−class

194− ( SOP.All KnownSymbol aliases

195− ) => HasAll

196− (aliases :: [Symbol])

197− (fields :: [(Symbol,kind)])

198− (subfields :: [(Symbol,kind)])

199− | aliases fields -> subfields where

200−instance {-# OVERLAPPING #-} HasAll '[] fields '[]

201−instance {-# OVERLAPPABLE #-}

202− (Has alias fields field, HasAll aliases fields subfields)

203− => HasAll (alias ': aliases) fields (alias ::: field ': subfields)

204−

205−-- | Analagous to `IsLabel`, the constraint

206−-- `IsQualified` defines `!` for a column alias qualified

207−-- by a table alias.

208−class IsQualified table column expression where

209− (!) :: Alias table -> Alias column -> expression

210− infixl 9 !

211−instance IsQualified table column (Alias table, Alias column) where (!) = (,)

212−

213−{-| `QualifiedAlias`es enables multi-schema support by allowing a reference

214−to a `Squeal.PostgreSQL.Schema.Table`, `Squeal.PostgreSQL.Schema.Typedef`

215−or `Squeal.PostgreSQL.Schema.View` to be qualified by their schemas. By default,

216−a qualifier of @public@ is provided.

217−

218−>>> :{

219−let

220− alias1 :: QualifiedAlias "sch" "tab"

221− alias1 = #sch ! #tab

222− alias2 :: QualifiedAlias "public" "vw"

223− alias2 = #vw

224−in printSQL alias1 >> printSQL alias2

225−:}

226−"sch"."tab"

227−"vw"

228−-}

229−data QualifiedAlias (qualifier :: Symbol) (alias :: Symbol) = QualifiedAlias

230− deriving (Eq,GHC.Generic,Ord,Show,NFData)

231−instance (q ~ q', a ~ a') => IsQualified q a (QualifiedAlias q' a') where

232− _!_ = QualifiedAlias

233−instance (q' ~ "public", a ~ a') => IsLabel a (QualifiedAlias q' a') where

234− fromLabel = QualifiedAlias

235−instance (q0 ~ q1, a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>

236− IsQualified q0 a0 (Aliased (QualifiedAlias q1) (a1 ::: a2)) where

237− _!_ = QualifiedAlias `As` Alias

238−instance (q ~ "public", a0 ~ a1, a1 ~ a2, KnownSymbol a2) =>

239− IsLabel a0 (Aliased (QualifiedAlias q) (a1 ::: a2)) where

240− fromLabel = QualifiedAlias `As` Alias

241−

242−instance (KnownSymbol q, KnownSymbol a)

243− => RenderSQL (QualifiedAlias q a) where

244− renderSQL _ =

245− let

246− qualifier = renderSQL (Alias @q)

247− alias = renderSQL (Alias @a)

248− in

249− if qualifier == "\"public\"" then alias else qualifier <> "." <> alias

squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+102−774

@@ -1,296 +1,62 @@

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−

1811{-# LANGUAGE

182− AllowAmbiguousTypes

2+ DataKinds

3+ , DefaultSignatures

1834 , DeriveFoldable

1845 , DeriveFunctor

1856 , DeriveGeneric

1867 , DeriveTraversable

187− , DefaultSignatures

1888 , FlexibleContexts

1899 , FlexibleInstances

190− , FunctionalDependencies

19110 , GADTs

19211 , LambdaCase

193− , OverloadedStrings

12+ , KindSignatures

19413 , MultiParamTypeClasses

19514 , ScopedTypeVariables

19615 , TypeApplications

19716 , TypeFamilies

198− , TypeInType

19917 , TypeOperators

20018 , UndecidableInstances

201− , UndecidableSuperClasses

20219#-}

20320

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

21+module Squeal.PostgreSQL.Binary where

22322

224−import BinaryParser

225−import ByteString.StrictBuilder (builderLength, int32BE, int64BE, word32BE)

226−import Control.Arrow (left)

227−import Control.Monad

23+import Data.Aeson hiding (Null)

24+import Data.Bits

22825import Data.Int

229−import Data.Kind

23026import Data.Scientific

23127import Data.Time

232−import Data.UUID.Types

233−import Data.Vector (Vector)

23428import Data.Word

235−import Foreign.C.Types (CUInt(CUInt))

29+import Data.UUID

23630import Generics.SOP

237−import Generics.SOP.Record

238−import GHC.TypeLits

23931import Network.IP.Addr

24032

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

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

25038import qualified GHC.Generics as GHC

25139import qualified PostgreSQL.Binary.Decoding as Decoding

25240import qualified PostgreSQL.Binary.Encoding as Encoding

25341

254−import Squeal.PostgreSQL.Alias

255−import Squeal.PostgreSQL.List

256−import Squeal.PostgreSQL.PG

25742import Squeal.PostgreSQL.Schema

25843

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

44+class ToParam x (pg :: PGType) where toParam :: x -> K Encoding.Encoding pg

27845instance ToParam Bool 'PGbool where toParam = K . Encoding.bool

27946instance ToParam Int16 'PGint2 where toParam = K . Encoding.int2_int16

47+instance ToParam Word16 'PGint2 where toParam = K . Encoding.int2_word16

28048instance ToParam Int32 'PGint4 where toParam = K . Encoding.int4_int32

49+instance ToParam Word32 'PGint4 where toParam = K . Encoding.int4_word32

28150instance ToParam Int64 'PGint8 where toParam = K . Encoding.int8_int64

282−instance ToParam Oid 'PGoid where toParam = K . Encoding.int4_word32 . getOid

51+instance ToParam Word64 'PGint8 where toParam = K . Encoding.int8_word64

28352instance ToParam Float 'PGfloat4 where toParam = K . Encoding.float4

28453instance ToParam Double 'PGfloat8 where toParam = K . Encoding.float8

28554instance ToParam Scientific 'PGnumeric where toParam = K . Encoding.numeric

286−instance ToParam Money 'PGmoney where toParam = K . Encoding.int8_int64 . cents

28755instance ToParam UUID 'PGuuid where toParam = K . Encoding.uuid

28856instance ToParam (NetAddr IP) 'PGinet where toParam = K . Encoding.inet

28957instance ToParam Char ('PGchar 1) where toParam = K . Encoding.char_utf8

29058instance ToParam Strict.Text 'PGtext where toParam = K . Encoding.text_strict

29159instance 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

29460instance ToParam Strict.ByteString 'PGbytea where

29561 toParam = K . Encoding.bytea_strict

29662instance ToParam Lazy.ByteString 'PGbytea where

@@ -304,545 +70,107 @@ instance ToParam LocalTime 'PGtimestamp where

30470instance ToParam UTCTime 'PGtimestamptz where

30571 toParam = K . Encoding.timestamptz_int

30672instance 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)

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 (optionality ('NotNull pg)) where

79+ toColumnParam = K . Just . Encoding.encodingBytes . unK . toParam @x @pg

80+instance ToParam x pg => ToColumnParam (Maybe x) (optionality ('Null pg)) where

81+ toColumnParam = K . fmap (Encoding.encodingBytes . unK . toParam @x @pg)

82+

83+class SListI tys => ToParams x (tys :: [ColumnType]) where

84+ toParams :: x -> NP (K (Maybe Strict.ByteString)) tys

85+instance (SListI tys, IsProductType x xs, AllZip ToColumnParam xs tys)

57086 => ToParams x tys where

57187 toParams

572− = htrans (Proxy @ToNullityParam) (toNullityParam . unI)

88+ = htrans (Proxy @ToColumnParam) (toColumnParam . unI)

57389 . unZ . unSOP . from

57490

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

91+class FromValue (pg :: PGType) y where

92+ fromValue :: proxy pg -> Decoding.Value y

93+instance FromValue 'PGbool Bool where fromValue _ = Decoding.bool

94+instance (Integral int, Bits int) => FromValue 'PGint2 int where

95+ fromValue _ = Decoding.int

96+instance (Integral int, Bits int) => FromValue 'PGint4 int where

97+ fromValue _ = Decoding.int

98+instance (Integral int, Bits int) => FromValue 'PGint8 int where

99+ fromValue _ = Decoding.int

100+instance FromValue 'PGfloat4 Float where fromValue _ = Decoding.float4

101+instance FromValue 'PGfloat8 Double where fromValue _ = Decoding.float8

102+instance FromValue 'PGnumeric Scientific where fromValue _ = Decoding.numeric

103+instance FromValue 'PGuuid UUID where fromValue _ = Decoding.uuid

104+instance FromValue 'PGinet (NetAddr IP) where fromValue _ = Decoding.inet

105+instance FromValue ('PGchar 1) Char where fromValue _ = Decoding.char

106+instance FromValue 'PGtext Strict.Text where fromValue _ = Decoding.text_strict

107+instance FromValue 'PGtext Lazy.Text where fromValue _ = Decoding.text_lazy

597108instance FromValue 'PGbytea Strict.ByteString where

598− fromValue = Decoding.bytea_strict

109+ fromValue _ = Decoding.bytea_strict

599110instance 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

111+ fromValue _ = Decoding.bytea_lazy

112+instance FromValue 'PGdate Day where fromValue _ = Decoding.date

113+instance FromValue 'PGtime TimeOfDay where fromValue _ = Decoding.time_int

603114instance FromValue 'PGtimetz (TimeOfDay, TimeZone) where

604− fromValue = Decoding.timetz_int

115+ fromValue _ = Decoding.timetz_int

605116instance FromValue 'PGtimestamp LocalTime where

606− fromValue = Decoding.timestamp_int

117+ fromValue _ = Decoding.timestamp_int

607118instance FromValue 'PGtimestamptz UTCTime where

608− fromValue = Decoding.timestamptz_int

119+ fromValue _ = Decoding.timestamptz_int

609120instance 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))

121+ fromValue _ = Decoding.interval_int

122+instance FromValue 'PGjson Value where fromValue _ = Decoding.json_ast

123+instance FromValue 'PGjsonb Value where fromValue _ = Decoding.jsonb_ast

702124

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

125+class FromColumnValue (colty :: (Symbol,ColumnType)) y where

126+ fromColumnValue :: K (Maybe Strict.ByteString) colty -> y

711127instance 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

128+ => FromColumnValue (column ::: ('Required ('NotNull pg))) y where

129+ fromColumnValue = \case

130+ K Nothing -> error "fromColumnValue: saw NULL when expecting NOT NULL"

131+ K (Just bytes) ->

132+ let

133+ errOrValue =

134+ Decoding.valueParser (fromValue @pg @y Proxy) bytes

135+ err str = error $ "fromColumnValue: " ++ Strict.unpack str

136+ in

137+ either err id errOrValue

717138instance 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)

139+ => FromColumnValue (column ::: ('Required ('Null pg))) (Maybe y) where

140+ fromColumnValue (K nullOrBytes)

141+ = either err id

142+ . Decoding.valueParser (fromValue @pg @y Proxy)

143+ <$> nullOrBytes

144+ where

145+ err str = error $ "fromColumnValue: " ++ Strict.unpack str

146+

147+class SListI columns => FromRow (columns :: [(Symbol,ColumnType)]) y where

148+ fromRow :: NP (K (Maybe Strict.ByteString)) columns -> y

734149instance

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

150+ ( SListI columns, IsProductType y ys

151+ , AllZip FromColumnValue columns ys

152+ , HasDatatypeInfo y

153+ , SameFields (DatatypeInfoOf y) columns

154+ ) => FromRow columns y where

768155 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 }

156+ = to . SOP . Z . htrans (Proxy @FromColumnValue) (I . fromColumnValue)

157+

158+class SameField

159+ (fieldInfo :: Type.FieldInfo) (columnty :: (Symbol,ColumnType)) where

160+instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty)

161+

162+type family SameFields

163+ (datatypeInfo :: Type.DatatypeInfo) (columns :: [(Symbol,ColumnType)]) where

164+ SameFields

165+ ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields])

166+ columns

167+ = AllZip SameField fields columns

168+ SameFields

169+ ('Type.Newtype _module _datatype ('Type.Record _constructor '[field]))

170+ '[column]

171+ = SameField field column

172+

173+newtype Only x = Only { only :: x }

830174 deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)

831175instance Generic (Only x)

832176instance 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.hs+272−598

@@ -1,712 +1,386 @@

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−

211{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

222{-# LANGUAGE

23− DefaultSignatures

3+ DataKinds

4+ , DefaultSignatures

245 , FunctionalDependencies

6+ , PolyKinds

7+ , DeriveFunctor

258 , FlexibleContexts

269 , FlexibleInstances

27− , InstanceSigs

10+ , MagicHash

11+ , MultiParamTypeClasses

2812 , OverloadedStrings

2913 , RankNTypes

3014 , ScopedTypeVariables

3115 , TypeApplications

3216 , TypeFamilies

33− , TypeInType

3417 , TypeOperators

3518 , UndecidableInstances

3619#-}

3720

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)

21+module Squeal.PostgreSQL.PQ where

22+

23+import Control.Exception.Lifted

24+import Control.Monad.Base

7525import Control.Monad.Except

76−import Control.Monad.Morph

77−import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try)

26+import Control.Monad.Trans.Control

7827import Data.ByteString (ByteString)

7928import Data.Foldable

8029import Data.Function ((&))

81−import Data.Functor ((<&>))

82−import Data.Kind

83−import Data.Text (pack, Text)

30+import Data.Monoid

8431import Data.Traversable

8532import Generics.SOP

86−import PostgreSQL.Binary.Encoding (encodingBytes)

33+import GHC.Exts hiding (fromList)

34+import GHC.TypeLits

8735

88−import qualified Control.Monad.Fail as Fail

8936import qualified Database.PostgreSQL.LibPQ as LibPQ

90−import qualified PostgreSQL.Binary.Encoding as Encoding

9137

9238import Squeal.PostgreSQL.Binary

93−import Squeal.PostgreSQL.Definition

94−import Squeal.PostgreSQL.Manipulation

95−import Squeal.PostgreSQL.Query

39+import Squeal.PostgreSQL.Statement

9640import Squeal.PostgreSQL.Schema

9741

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`.

42+newtype Connection (schema :: [(Symbol,[(Symbol,ColumnType)])]) =

43+ Connection { unConnection :: LibPQ.Connection }

44+

16945newtype 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`.

46+ (schema0 :: [(Symbol,[(Symbol,ColumnType)])])

47+ (schema1 :: [(Symbol,[(Symbol,ColumnType)])])

48+ (m :: * -> *)

49+ (x :: *) =

50+ PQ { runPQ :: Connection schema0 -> m (x, Connection schema1) }

51+ deriving Functor

52+

53+evalPQ :: Functor m => PQ schema0 schema1 m x -> Connection schema0 -> m x

54+evalPQ (PQ pq) = fmap fst . pq

55+

19256execPQ

19357 :: 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

58+ => PQ schema0 schema1 m x

59+ -> Connection schema0

60+ -> m (Connection schema1)

61+execPQ (PQ pq) = fmap snd . pq

62+

63+pqAp

64+ :: Monad m

65+ => PQ schema0 schema1 m (x -> y)

66+ -> PQ schema1 schema2 m x

67+ -> PQ schema0 schema2 m y

68+pqAp (PQ f) (PQ x) = PQ $ \ conn -> do

69+ (f', conn') <- f conn

70+ (x', conn'') <- x conn'

71+ return (f' x', conn'')

72+

73+pqBind

74+ :: Monad m

75+ => (x -> PQ schema1 schema2 m y)

76+ -> PQ schema0 schema1 m x

77+ -> PQ schema0 schema2 m y

78+pqBind f (PQ x) = PQ $ \ conn -> do

79+ (x', conn') <- x conn

80+ runPQ (f x') conn'

81+

82+pqThen

83+ :: Monad m

84+ => PQ schema1 schema2 m y

85+ -> PQ schema0 schema1 m x

86+ -> PQ schema0 schema2 m y

87+pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)

88+

89+define

90+ :: MonadBase IO io

91+ => Definition schema0 schema1

92+ -> PQ schema0 schema1 io (Result '[])

93+define (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do

94+ resultMaybe <- liftBase $ LibPQ.exec conn q

95+ case resultMaybe of

96+ Nothing -> error

97+ "define: LibPQ.exec returned no results"

98+ Just result -> return (Result result, Connection conn)

99+

100+pqThenDefine

101+ :: MonadBase IO io

102+ => Definition schema1 schema2

103+ -> PQ schema0 schema1 io x

104+ -> PQ schema0 schema2 io (Result '[])

105+pqThenDefine = pqThen . define

106+

107+class Monad pq => MonadPQ schema pq | pq -> schema where

198108

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

319109 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)

110+ :: ToParams x params

111+ => Manipulation schema params ys -> x -> pq (Result ys)

324112 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)

113+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

114+ => ToParams x params

115+ => Manipulation schema params ys -> x -> pq (Result ys)

330116 manipulateParams manipulation params = lift $

331117 manipulateParams manipulation params

332118

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)

119+ manipulate :: Manipulation schema '[] ys -> pq (Result ys)

341120 manipulate statement = manipulateParams statement ()

342121

343− manipulate_ :: Manipulation '[] schemas '[] '[] -> pq ()

344− manipulate_ = void . manipulate

122+ queryParams

123+ :: ToParams x params

124+ => Query schema params ys -> x -> pq (Result ys)

125+ queryParams = manipulateParams . queryStatement

345126

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 ()

127+ query :: Query schema '[] ys -> pq (Result ys)

128+ query q = queryParams q ()

358129

359130 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))

131+ :: (ToParams x params, Traversable list)

132+ => Manipulation schema params ys -> list x -> pq (list (Result ys))

364133 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))

134+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

135+ => (ToParams x params, Traversable list)

136+ => Manipulation schema params ys -> list x -> pq (list (Result ys))

368137 traversePrepared manipulation params = lift $

369138 traversePrepared manipulation params

370139

371140 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))

141+ :: (ToParams x params, Traversable list)

142+ => list x -> Manipulation schema params ys -> pq (list (Result ys))

377143 forPrepared = flip traversePrepared

378144

379145 traversePrepared_

380− :: (ToParams x params, Foldable list, All OidOfParam params)

381− => Manipulation '[] schemas params '[]

382− -- ^ `insertInto`, `update` or `deleteFrom`

383− -> list x -> pq ()

146+ :: (ToParams x params, Foldable list)

147+ => Manipulation schema params ys -> list x -> pq ()

384148 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 ()

149+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

150+ => (ToParams x params, Foldable list)

151+ => Manipulation schema params ys -> list x -> pq ()

390152 traversePrepared_ manipulation params = lift $

391153 traversePrepared_ manipulation params

392154

393155 forPrepared_

394− :: (ToParams x params, Foldable list, All OidOfParam params)

395− => list x

396− -> Manipulation '[] schemas params '[]

397− -- ^ `insertInto`, `update` or `deleteFrom`

398− -> pq ()

156+ :: (ToParams x params, Traversable list)

157+ => list x -> Manipulation schema params ys -> pq ()

399158 forPrepared_ = flip traversePrepared_

400159

401160 liftPQ :: (LibPQ.Connection -> IO a) -> pq a

402161 default liftPQ

403− :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)

162+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

404163 => (LibPQ.Connection -> IO a) -> pq a

405164 liftPQ = lift . liftPQ

406165

407−instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)

408− => MonadPQ schemas (PQ schemas0 schemas1 io) where

166+instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where

409167

410168 manipulateParams

411− (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =

412− PQ $ \ (K conn) -> do

169+ (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =

170+ PQ $ \ (Connection conn) -> do

413171 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

172+ toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)

173+ params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))

174+ resultMaybe <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary

427175 case resultMaybe of

428− Nothing -> throw $ ResultException

176+ Nothing -> error

429177 "manipulateParams: LibPQ.execParams returned no results"

430− Just result -> do

431− okResult_ result

432− return $ K (K result)

178+ Just result -> return (Result result, Connection conn)

433179

434180 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')

181+ (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

182+ PQ $ \ (Connection conn) -> do

183+ let temp = "temporary_statement"

184+ prepResultMaybe <- liftBase $ LibPQ.prepare conn temp q Nothing

446185 case prepResultMaybe of

447− Nothing -> throw $ ResultException

186+ Nothing -> error

448187 "traversePrepared: LibPQ.prepare returned no results"

449− Just prepResult -> okResult_ prepResult

188+ Just _prepResult -> return () -- todo: check status of prepResult

450189 results <- for list $ \ params -> do

451190 let

452− toParam' encoding = (encodingBytes encoding, LibPQ.Binary)

191+ toParam' bytes = (bytes,LibPQ.Binary)

453192 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

454− resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary

193+ resultMaybe <- liftBase $

194+ LibPQ.execPrepared conn temp params' LibPQ.Binary

455195 case resultMaybe of

456− Nothing -> throw $ ResultException

196+ Nothing -> error

457197 "traversePrepared: LibPQ.execParams returned no results"

458− Just result -> do

459− okResult_ result

460− return $ K result

461− deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

198+ Just result -> return $ Result result

199+ deallocResultMaybe <- liftBase $

200+ LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

462201 case deallocResultMaybe of

463− Nothing -> throw $ ResultException

202+ Nothing -> error

464203 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

465− Just deallocResult -> okResult_ deallocResult

466− return (K results)

204+ Just _deallocResult -> return ()

205+ -- todo: check status of deallocResult

206+ return (results, Connection conn)

467207

468208 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')

209+ (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

210+ PQ $ \ (Connection conn) -> do

211+ let temp = "temporary_statement"

212+ prepResultMaybe <- liftBase $ LibPQ.prepare conn temp q Nothing

480213 case prepResultMaybe of

481− Nothing -> throw $ ResultException

214+ Nothing -> error

482215 "traversePrepared_: LibPQ.prepare returned no results"

483− Just prepResult -> okResult_ prepResult

216+ Just _prepResult -> return () -- todo: check status of prepResult

484217 for_ list $ \ params -> do

485218 let

486− toParam' encoding = (encodingBytes encoding, LibPQ.Binary)

219+ toParam' bytes = (bytes,LibPQ.Binary)

487220 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

488− resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary

221+ resultMaybe <- liftBase $

222+ LibPQ.execPrepared conn temp params' LibPQ.Binary

489223 case resultMaybe of

490− Nothing -> throw $ ResultException

224+ Nothing -> error

491225 "traversePrepared_: LibPQ.execParams returned no results"

492− Just result -> okResult_ result

493− deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

226+ Just _result -> return ()

227+ deallocResultMaybe <- liftBase $

228+ LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

494229 case deallocResultMaybe of

495− Nothing -> throw $ ResultException

230+ Nothing -> error

496231 "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)

232+ Just _deallocResult -> return ()

233+ -- todo: check status of deallocResult

234+ return ((), Connection conn)

235+

236+ liftPQ pq = PQ $ \ (Connection conn) -> do

237+ y <- liftBase $ pq conn

238+ return (y, Connection conn)

239+

240+instance Monad m => Applicative (PQ schema schema m) where

241+ pure x = PQ $ \ conn -> pure (x, conn)

519242 (<*>) = pqAp

520243

521−instance (Monad m, schemas0 ~ schemas1)

522− => Monad (PQ schemas0 schemas1 m) where

244+instance Monad m => Monad (PQ schema schema m) where

523245 return = pure

524246 (>>=) = flip pqBind

525247

526−instance (Monad m, schemas0 ~ schemas1)

527− => Fail.MonadFail (PQ schemas0 schemas1 m) where

528− fail = Fail.fail

248+instance MonadTrans (PQ schema schema) where

249+ lift m = PQ $ \ conn -> do

250+ x <- m

251+ return (x, conn)

529252

530−instance schemas0 ~ schemas1 => MFunctor (PQ schemas0 schemas1) where

531− hoist f (PQ pq) = PQ (f . pq)

253+instance MonadBase b m => MonadBase b (PQ schema schema m) where

254+ liftBase = lift . liftBase

532255

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

256+type PQRun schema =

257+ forall m x. Monad m => PQ schema schema m x -> m (x, Connection schema)

258+

259+pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a

260+pqliftWith f = PQ $ \ conn ->

261+ fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)

262+

263+instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where

264+ type StM (PQ schema schema m) x = StM m (x, Connection schema)

265+ liftBaseWith f =

266+ pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run

267+ restoreM = PQ . const . restoreM

268+

269+connectdb :: MonadBase IO io => ByteString -> io (Connection schema)

270+connectdb = fmap Connection . liftBase . LibPQ.connectdb

271+

272+finish :: MonadBase IO io => Connection schema -> io ()

273+finish = liftBase . LibPQ.finish . unConnection

274+

275+withConnection

276+ :: forall schema io x

277+ . MonadBaseControl IO io

278+ => ByteString

279+ -> (Connection schema -> io x)

280+ -> io x

281+withConnection connString = bracket (connectdb connString) finish

282+

283+newtype Result (xs :: [(Symbol,ColumnType)])

284+ = Result { unResult :: LibPQ.Result }

285+

286+newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }

287+

288+newtype ColumnNumber n cs c =

289+ UnsafeColumnNumber { getColumnNumber :: LibPQ.Column }

290+

291+class KnownNat n => HasColumnNumber n columns column

292+ | n columns -> column where

293+ columnNumber :: ColumnNumber n columns column

294+ columnNumber =

295+ UnsafeColumnNumber . fromIntegral $ natVal' (proxy# :: Proxy# n)

296+instance {-# OVERLAPPING #-} HasColumnNumber 0 (column1:columns) column1

297+instance {-# OVERLAPPABLE #-}

298+ (KnownNat n, HasColumnNumber (n-1) columns column)

299+ => HasColumnNumber n (column' : columns) column

300+

301+getValue

302+ :: (FromColumnValue colty y, MonadBase IO io)

303+ => RowNumber

304+ -> ColumnNumber n columns colty

305+ -> Result columns

563306 -> io y

564−getRow r (K result :: K LibPQ.Result columns) = liftIO $ do

307+getValue

308+ (RowNumber r)

309+ (UnsafeColumnNumber c :: ColumnNumber n columns colty)

310+ (Result result)

311+ = fmap (fromColumnValue @colty . K) $ liftBase $ do

312+ numRows <- LibPQ.ntuples result

313+ when (numRows < r) $ error $

314+ "getValue: expected at least " <> show r <> "rows but only saw "

315+ <> show numRows

316+ LibPQ.getvalue result r c

317+

318+getRow

319+ :: (FromRow columns y, MonadBase IO io)

320+ => RowNumber -> Result columns -> io y

321+getRow (RowNumber r) (Result result :: Result columns) = liftBase $do

565322 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)

323+ when (numRows < r) $ error $

324+ "getRow: expected at least " <> show r <> "rows but only saw "

325+ <> show numRows

569326 let len = fromIntegral (lengthSList (Proxy @columns))

327+ numCols <- LibPQ.nfields result

328+ when (numCols /= len) $ error $

329+ "getRow: expected at least " <> show len <> "columns but only saw "

330+ <> show numCols

570331 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

571332 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.

333+ Nothing -> error "getRow: found unexpected length"

334+ Just row -> return $ fromRow @columns row

335+

581336nextRow

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

337+ :: (FromRow columns y, MonadBase IO io)

338+ => Result columns -> RowNumber -> io (Maybe (RowNumber,y))

339+nextRow (Result result :: Result columns) (RowNumber r) = liftBase $ do

340+ numRows <- LibPQ.ntuples result -- todo: cache this

341+ if numRows < r then return Nothing else do

589342 let len = fromIntegral (lengthSList (Proxy @columns))

343+ numCols <- LibPQ.nfields result -- todo: cache this

344+ when (numCols /= len) $ error $

345+ "nextRow: expected at least " <> show len <> "columns but only saw "

346+ <> show numCols

590347 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

591348 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

349+ Nothing -> error "nextRow: found unexpected length"

350+ Just row -> return $ Just (RowNumber (r+1), fromRow @columns row)

351+

352+getRows :: (FromRow columns y, MonadBase IO io) => Result columns -> io [y]

353+getRows (Result result :: Result columns) = liftBase $ do

603354 let len = fromIntegral (lengthSList (Proxy @columns))

355+ numCols <- LibPQ.nfields result

356+ when (numCols /= len) $ error $

357+ "getRow: expected at least " <> show len <> "columns but only saw "

358+ <> show numCols

604359 numRows <- LibPQ.ntuples result

605360 for [0 .. numRows - 1] $ \ r -> do

606361 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

607362 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

363+ Nothing -> error "getRows: found unexpected length"

364+ Just row -> return $ fromRow @columns row

365+

366+getRowMaybe

367+ :: (FromRow columns y, MonadBase IO io)

368+ => RowNumber -> Result columns -> io (Maybe y)

369+getRowMaybe (RowNumber r) (Result result :: Result columns) = liftBase $do

619370 numRows <- LibPQ.ntuples result

620− if numRows <= 0 then return Nothing else do

371+ if numRows < r then return Nothing else do

621372 let len = fromIntegral (lengthSList (Proxy @columns))

622− row' <- traverse (LibPQ.getvalue result 0) [0 .. len - 1]

373+ numCols <- LibPQ.nfields result

374+ when (numCols /= len) $ error $

375+ "getRow: expected at least " <> show len <> "columns but only saw "

376+ <> show numCols

377+ row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

623378 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

379+ Nothing -> error "getRow: found unexpected length"

380+ Just row -> return . Just $ fromRow @columns row

628381

629−-- | Lifts actions on results from @LibPQ@.

630382liftResult

631− :: MonadIO io

383+ :: MonadBase IO io

632384 => (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

385+ -> Result results -> io x

386+liftResult f (Result result) = liftBase $ f result

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.hs+143−556

@@ -1,596 +1,183 @@

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−-}

131{-# LANGUAGE

14− AllowAmbiguousTypes

15− , ConstraintKinds

16− , DeriveAnyClass

17− , DeriveGeneric

2+ DataKinds

183 , FlexibleContexts

194 , FlexibleInstances

20− , FunctionalDependencies

215 , GADTs

22− , LambdaCase

6+ , MagicHash

7+ , MultiParamTypeClasses

238 , OverloadedStrings

24− , QuantifiedConstraints

9+ , PolyKinds

2510 , RankNTypes

2611 , ScopedTypeVariables

27− , StandaloneDeriving

2812 , TypeApplications

29− , TypeFamilyDependencies

30− , TypeInType

13+ , TypeFamilies

3114 , TypeOperators

32− , UndecidableInstances

33− , UndecidableSuperClasses

3415#-}

3516

3617module 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

18+ ( PGType (..)

19+ , PGNum (..)

8120 , PGIntegral

8221 , PGFloating

83− , PGTypeOf

84− , PGJsonType

85− , PGJsonKey

86− , SamePGType

22+ , (:::)

23+ , Alias (Alias)

24+ , renderAlias

25+ , Aliased (As)

26+ , renderAliased

27+ , IsTableColumn (..)

28+ , NullityType (..)

29+ , ColumnType (..)

30+ , Grouping (..)

31+ , SameTypes

8732 , AllNotNull

8833 , NotAllNull

89− -- * Nullifications

9034 , NullifyType

91− , NullifyRow

92− , NullifyFrom

93− -- * Table Conversions

94− , TableToColumns

95− , ColumnsToRow

96− , TableToRow

35+ , NullifyColumns

36+ , NullifyTables

37+ , BaseType

38+ , Create

39+ , Drop

40+ , Alter

41+ , Rename

42+ , Join

43+ , module GHC.OverloadedLabels

44+ , module GHC.TypeLits

9745 ) where

9846

99−import Control.Category

100−import Data.Kind

101−import Data.Monoid hiding (All)

102−import Data.Type.Bool

103−import Generics.SOP

47+import Data.ByteString

48+import Data.Monoid

49+import Data.String

50+import GHC.Exts

51+import GHC.OverloadedLabels

10452import GHC.TypeLits

105−import Prelude hiding (id, (.))

106−

107−import Squeal.PostgreSQL.Alias

108−import Squeal.PostgreSQL.List

109−import Squeal.PostgreSQL.Render

11053

111−-- $setup

112−-- >>> import Squeal.PostgreSQL

113−

114−-- | `PGType` is the promoted datakind of PostgreSQL types.

115−--

116−-- >>> :kind 'PGbool

117−-- 'PGbool :: PGType

11854data 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

55+ = PGbool

56+ | PGint2

57+ | PGint4

58+ | PGint8

59+ | PGnumeric

60+ | PGfloat4

61+ | PGfloat8

62+ | PGchar Nat

63+ | PGvarchar Nat

64+ | PGtext

65+ | PGbytea

66+ | PGtimestamp

67+ | PGtimestamptz

68+ | PGdate

69+ | PGtime

70+ | PGtimetz

71+ | PGinterval

72+ | PGuuid

73+ | PGinet

74+ | PGjson

75+ | PGjsonb

76+

77+class PGNum (ty :: PGType) where

78+ decimal :: proxy ty -> Bool

79+instance PGNum 'PGint2 where decimal _ = False

80+instance PGNum 'PGint4 where decimal _ = False

81+instance PGNum 'PGint8 where decimal _ = False

82+instance PGNum 'PGnumeric where decimal _ = True

83+instance PGNum 'PGfloat4 where decimal _ = True

84+instance PGNum 'PGfloat8 where decimal _ = True

85+

86+class PGNum ty => PGIntegral (ty :: PGType) where

87+instance PGIntegral 'PGint2

88+instance PGIntegral 'PGint4

89+instance PGIntegral 'PGint8

90+

91+class PGNum ty => PGFloating (ty :: PGType) where

92+instance PGFloating 'PGnumeric

93+instance PGFloating 'PGfloat4

94+instance PGFloating 'PGfloat8

95+

96+type (:::) (alias :: Symbol) (ty :: polykind) = '(alias,ty)

97+

98+data Alias (alias :: Symbol) = Alias

99+

100+renderAlias :: KnownSymbol alias => Alias alias -> ByteString

101+renderAlias = fromString . symbolVal

102+

103+instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where

104+ fromLabel = Alias

105+

106+data Aliased expression aliased where

107+ As

108+ :: KnownSymbol alias

109+ => expression ty

110+ -> Alias alias

111+ -> Aliased expression (alias ::: ty)

112+

113+renderAliased

114+ :: (forall ty. expression ty -> ByteString)

115+ -> Aliased expression aliased

116+ -> ByteString

117+renderAliased render (expression `As` alias) =

118+ render expression <> " AS " <> renderAlias alias

119+

120+class IsTableColumn table column expression where

121+ (!) :: Alias table -> Alias column -> expression

122+ infixl 9 !

123+instance IsTableColumn table column (Alias table, Alias column) where (!) = (,)

124+

125+data NullityType = Null PGType | NotNull PGType

126+

127+data ColumnType = Optional NullityType | Required NullityType

128+

129+data Grouping

130+ = Ungrouped

131+ | Grouped [(Symbol,Symbol)]

132+

133+type family BaseType (ty :: ColumnType) where

134+ BaseType (optionality (nullity pg)) = pg

135+

136+type family SameTypes columns0 columns1 :: Constraint where

137+ SameTypes '[] '[] = ()

138+ SameTypes ((column0 ::: ty0) ': columns0) ((column1 ::: ty1) ': columns1)

139+ = (ty0 ~ ty1, SameTypes columns0 columns1)

140+

141+type family AllNotNull columns :: Constraint where

314142 AllNotNull '[] = ()

143+ AllNotNull ((column ::: (optionality ('NotNull ty))) ': columns)

144+ = AllNotNull columns

315145

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

146+type family NotAllNull columns :: Constraint where

147+ NotAllNull ((column ::: (optionality ('NotNull ty))) ': columns) = ()

148+ NotAllNull ((column ::: (optionality ('Null ty))) ': columns)

149+ = NotAllNull columns

326150

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

151+type family NullifyType (ty :: ColumnType) where

152+ NullifyType (optionality ('Null ty)) = optionality ('Null ty)

153+ NullifyType (optionality ('NotNull ty)) = optionality ('Null ty)

331154

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 '[] = '[]

155+type family NullifyColumns columns where

156+ NullifyColumns '[] = '[]

157+ NullifyColumns ((column ::: ty) ': columns) =

158+ (column ::: NullifyType ty) ': NullifyColumns columns

347159

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 '[] = '[]

160+type family NullifyTables tables where

161+ NullifyTables '[] = '[]

162+ NullifyTables ((column ::: ty) ': columns) =

163+ (column ::: NullifyColumns ty) ': NullifyTables columns

365164

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`.

369165type family Create alias x xs where

370166 Create alias x '[] = '[alias ::: x]

371− Create alias x (alias ::: y ': xs) = TypeError

372− ('Text "Create: alias "

373− ':<>: 'ShowType alias

374− ':<>: 'Text "already exists")

375167 Create alias y (x ': xs) = x ': Create alias y xs

376168

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.

397169type 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

170+ Drop alias ((alias ::: x) ': xs) = xs

403171 Drop alias (x ': xs) = x ': Drop alias xs

404172

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

173+type family Alter alias xs x where

174+ Alter alias ((alias ::: x0) ': xs) x1 = (alias ::: x1) ': xs

175+ Alter alias (x0 ': xs) x1 = x0 ': Alter alias xs x1

424176

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`.

456177type family Rename alias0 alias1 xs where

457− Rename alias0 alias1 '[] = TypeError

458− ('Text "Rename: alias "

459− ':<>: 'ShowType alias0

460− ':<>: 'Text " does not exist" )

461178 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs

462179 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs

463180

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

181+type family Join xs ys where

182+ Join '[] ys = ys

183+ Join (x ': xs) ys = x ': Join xs ys

squeal-postgresql/src/Squeal/PostgreSQL/Statement.hsnew file+1372

@@ -0,0 +1,1372 @@

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 Squeal.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 Squeal.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+ :: Alias column

67+ -> Expression params '[table ::: columns] 'Ungrouped ty

68+ getColumn column = UnsafeExpression $ renderAlias 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 (Alias @column)

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 '[] 'Ungrouped ('Optional (nullity ty))

84+def = UnsafeExpression "DEFAULT"

85+

86+unDef

87+ :: Expression params '[] 'Ungrouped ('Required (nullity ty))

88+ -> Expression params '[] 'Ungrouped ('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 ty))]

101+ -> Expression params tables grouping ('Required ('NotNull ty))

102+ -> Expression params tables grouping ('Required ('NotNull ty))

103+coalesce nullxs notNullx = UnsafeExpression $

104+ "COALESCE" <> parenthesized (commaSeparated

105+ ((renderExpression <$> nullxs) <> [renderExpression notNullx]))

106+

107+fromNull

108+ :: Expression params tables grouping ('Required ('NotNull ty))

109+ -> Expression params tables grouping ('Required ('Null ty))

110+ -> Expression params tables grouping ('Required ('NotNull ty))

111+fromNull notNullx nullx = coalesce [nullx] notNullx

112+

113+isNull

114+ :: Expression params tables grouping ('Required ('Null ty))

115+ -> Condition params tables grouping

116+isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL"

117+

118+isn'tNull

119+ :: Expression params tables grouping ('Required ('Null ty))

120+ -> Condition params tables grouping

121+isn'tNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL"

122+

123+matchNull

124+ :: Expression params tables grouping ('Required nullty)

125+ -> ( Expression params tables grouping ('Required ('NotNull ty))

126+ -> Expression params tables grouping ('Required nullty) )

127+ -> Expression params tables grouping ('Required ('Null ty))

128+ -> Expression params tables grouping ('Required nullty)

129+matchNull y f x = ifThenElse (isNull x) y

130+ (f (UnsafeExpression (renderExpression y)))

131+

132+nullIf

133+ :: Expression params tables grouping ('Required ('NotNull ty))

134+ -> Expression params tables grouping ('Required ('NotNull ty))

135+ -> Expression params tables grouping ('Required ('Null ty))

136+nullIf x y = UnsafeExpression $ parenthesized $

137+ renderExpression x <> ", " <> renderExpression y

138+

139+greatest

140+ :: [Expression params tables grouping ('Required nullty)]

141+ -> Expression params table grouping ('Required nullty)

142+greatest xs = UnsafeExpression $ "GREATEST("

143+ <> commaSeparated (renderExpression <$> xs) <> ")"

144+

145+least

146+ :: [Expression params tables grouping ('Required nullty)]

147+ -> Expression params table grouping ('Required nullty)

148+least xs = UnsafeExpression $ "LEAST("

149+ <> commaSeparated (renderExpression <$> xs) <> ")"

150+

151+unsafeBinaryOp

152+ :: ByteString

153+ -> Expression params tables grouping ('Required ty0)

154+ -> Expression params tables grouping ('Required ty1)

155+ -> Expression params tables grouping ('Required ty2)

156+unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $

157+ renderExpression x <+> op <+> renderExpression y

158+

159+unsafeUnaryOp

160+ :: ByteString

161+ -> Expression params tables grouping ('Required ty0)

162+ -> Expression params tables grouping ('Required ty1)

163+unsafeUnaryOp op x = UnsafeExpression $ parenthesized $

164+ op <+> renderExpression x

165+

166+unsafeFunction

167+ :: ByteString

168+ -> Expression params tables grouping ('Required xty)

169+ -> Expression params tables grouping ('Required yty)

170+unsafeFunction fun x = UnsafeExpression $

171+ fun <> parenthesized (renderExpression x)

172+

173+instance PGNum ty

174+ => Num (Expression params tables grouping ('Required (nullity ty))) where

175+ (+) = unsafeBinaryOp "+"

176+ (-) = unsafeBinaryOp "-"

177+ (*) = unsafeBinaryOp "*"

178+ abs = unsafeFunction "abs"

179+ signum = unsafeFunction "sign"

180+ fromInteger

181+ = UnsafeExpression

182+ . (<> if decimal (Proxy :: Proxy ty) then "." else "")

183+ . fromString

184+ . show

185+

186+instance PGFloating ty => Fractional

187+ (Expression params tables grouping ('Required (nullity ty))) where

188+ (/) = unsafeBinaryOp "/"

189+ fromRational x = fromInteger (numerator x) / fromInteger (denominator x)

190+

191+instance (PGFloating ty, PGTyped ty) => Floating

192+ (Expression params tables grouping ('Required (nullity ty))) where

193+ pi = UnsafeExpression "pi()"

194+ exp = unsafeFunction "exp"

195+ log = unsafeFunction "ln"

196+ sqrt = unsafeFunction "sqrt"

197+ b ** x = UnsafeExpression $

198+ "power(" <> renderExpression b <> ", " <> renderExpression x <> ")"

199+ logBase b y = cast pgtype $ logBaseNumeric b y

200+ where

201+ logBaseNumeric

202+ :: Expression params tables grouping ('Required (nullity ty))

203+ -> Expression params tables grouping ('Required (nullity ty))

204+ -> Expression params tables grouping ('Required (nullity 'PGnumeric))

205+ logBaseNumeric b' y' = UnsafeExpression $ mconcat

206+ [ "log("

207+ , renderExpression (cast numeric b')

208+ , ", "

209+ , renderExpression (cast numeric y')

210+ , ")"

211+ ]

212+ sin = unsafeFunction "sin"

213+ cos = unsafeFunction "cos"

214+ tan = unsafeFunction "tan"

215+ asin = unsafeFunction "asin"

216+ acos = unsafeFunction "acos"

217+ atan = unsafeFunction "atan"

218+ sinh x = (exp x - exp (-x)) / 2

219+ cosh x = (exp x + exp (-x)) / 2

220+ tanh x = sinh x / cosh x

221+ asinh x = log (x + sqrt (x*x + 1))

222+ acosh x = log (x + sqrt (x*x - 1))

223+ atanh x = log ((1 + x) / (1 - x)) / 2

224+

225+atan2

226+ :: PGFloating float

227+ => Expression params tables grouping ('Required (nullity float))

228+ -> Expression params tables grouping ('Required (nullity float))

229+ -> Expression params tables grouping ('Required (nullity float))

230+atan2 y x = UnsafeExpression $

231+ "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"

232+

233+cast

234+ :: TypeExpression ('Required ('Null ty1))

235+ -> Expression params tables grouping ('Required (nullity ty0))

236+ -> Expression params tables grouping ('Required (nullity ty1))

237+cast ty x = UnsafeExpression $ parenthesized $

238+ renderExpression x <+> "::" <+> renderTypeExpression ty

239+

240+div

241+ :: PGIntegral int

242+ => Expression params tables grouping ('Required (nullity int))

243+ -> Expression params tables grouping ('Required (nullity int))

244+ -> Expression params tables grouping ('Required (nullity int))

245+div = unsafeBinaryOp "/"

246+

247+mod

248+ :: PGIntegral int

249+ => Expression params tables grouping ('Required (nullity int))

250+ -> Expression params tables grouping ('Required (nullity int))

251+ -> Expression params tables grouping ('Required (nullity int))

252+mod = unsafeBinaryOp "%"

253+

254+trunc

255+ :: PGFloating frac

256+ => Expression params tables grouping ('Required (nullity frac))

257+ -> Expression params tables grouping ('Required (nullity frac))

258+trunc = unsafeFunction "trunc"

259+

260+round_

261+ :: PGFloating frac

262+ => Expression params tables grouping ('Required (nullity frac))

263+ -> Expression params tables grouping ('Required (nullity frac))

264+round_ = unsafeFunction "round"

265+

266+ceiling_

267+ :: PGFloating frac

268+ => Expression params tables grouping ('Required (nullity frac))

269+ -> Expression params tables grouping ('Required (nullity frac))

270+ceiling_ = unsafeFunction "ceiling"

271+

272+instance IsString

273+ (Expression params tables grouping ('Required (nullity 'PGtext))) where

274+ fromString str = UnsafeExpression $

275+ "E\'" <> fromString (escape =<< str) <> "\'"

276+ where

277+ escape = \case

278+ '\NUL' -> "\\0"

279+ '\'' -> "''"

280+ '"' -> "\\\""

281+ '\b' -> "\\b"

282+ '\n' -> "\\n"

283+ '\r' -> "\\r"

284+ '\t' -> "\\t"

285+ '\\' -> "\\\\"

286+ c -> [c]

287+

288+type Condition params tables grouping =

289+ Expression params tables grouping ('Required ('NotNull 'PGbool))

290+

291+true :: Condition params tables grouping

292+true = UnsafeExpression "TRUE"

293+

294+false :: Condition params tables grouping

295+false = UnsafeExpression "FALSE"

296+

297+not_

298+ :: Condition params tables grouping

299+ -> Condition params tables grouping

300+not_ = unsafeUnaryOp "NOT"

301+

302+(&&*)

303+ :: Condition params tables grouping

304+ -> Condition params tables grouping

305+ -> Condition params tables grouping

306+(&&*) = unsafeBinaryOp "AND"

307+

308+(||*)

309+ :: Condition params tables grouping

310+ -> Condition params tables grouping

311+ -> Condition params tables grouping

312+(||*) = unsafeBinaryOp "OR"

313+

314+caseWhenThenElse

315+ :: [ ( Condition params tables grouping

316+ , Expression params tables grouping ('Required ty)

317+ ) ]

318+ -> Expression params tables grouping ('Required ty)

319+ -> Expression params tables grouping ('Required ty)

320+caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat

321+ [ "CASE"

322+ , mconcat

323+ [ mconcat

324+ [ " WHEN ", renderExpression when_

325+ , " THEN ", renderExpression then_

326+ ]

327+ | (when_,then_) <- whenThens

328+ ]

329+ , " ELSE ", renderExpression else_

330+ , " END"

331+ ]

332+

333+ifThenElse

334+ :: Condition params tables grouping

335+ -> Expression params tables grouping ('Required ty)

336+ -> Expression params tables grouping ('Required ty)

337+ -> Expression params tables grouping ('Required ty)

338+ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_

339+

340+(==*)

341+ :: Expression params tables grouping ('Required (nullity ty))

342+ -> Expression params tables grouping ('Required (nullity ty))

343+ -> Expression params tables grouping ('Required (nullity 'PGbool))

344+(==*) = unsafeBinaryOp "="

345+infix 4 ==*

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+infix 4 /=*

353+

354+(>=*)

355+ :: Expression params tables grouping ('Required (nullity ty))

356+ -> Expression params tables grouping ('Required (nullity ty))

357+ -> Expression params tables grouping ('Required (nullity 'PGbool))

358+(>=*) = unsafeBinaryOp ">="

359+infix 4 >=*

360+

361+(<*)

362+ :: Expression params tables grouping ('Required (nullity ty))

363+ -> Expression params tables grouping ('Required (nullity ty))

364+ -> Expression params tables grouping ('Required (nullity 'PGbool))

365+(<*) = unsafeBinaryOp "<"

366+infix 4 <*

367+

368+(<=*)

369+ :: Expression params tables grouping ('Required (nullity ty))

370+ -> Expression params tables grouping ('Required (nullity ty))

371+ -> Expression params tables grouping ('Required (nullity 'PGbool))

372+(<=*) = unsafeBinaryOp "<="

373+infix 4 <=*

374+

375+(>*)

376+ :: Expression params tables grouping ('Required (nullity ty))

377+ -> Expression params tables grouping ('Required (nullity ty))

378+ -> Expression params tables grouping ('Required (nullity 'PGbool))

379+(>*) = unsafeBinaryOp ">"

380+infix 4 >*

381+

382+currentDate

383+ :: Expression params tables grouping ('Required (nullity 'PGdate))

384+currentDate = UnsafeExpression "CURRENT_DATE"

385+

386+currentTime

387+ :: Expression params tables grouping ('Required (nullity 'PGtimetz))

388+currentTime = UnsafeExpression "CURRENT_TIME"

389+

390+currentTimestamp

391+ :: Expression params tables grouping ('Required (nullity 'PGtimestamptz))

392+currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"

393+

394+localTime

395+ :: Expression params tables grouping ('Required (nullity 'PGtime))

396+localTime = UnsafeExpression "LOCALTIME"

397+

398+localTimestamp

399+ :: Expression params tables grouping ('Required (nullity 'PGtimestamp))

400+localTimestamp = UnsafeExpression "LOCALTIMESTAMP"

401+

402+data SortExpression params tables grouping where

403+ Asc

404+ :: Expression params tables grouping ('Required ('NotNull ty))

405+ -> SortExpression params tables grouping

406+ Desc

407+ :: Expression params tables grouping ('Required ('NotNull ty))

408+ -> SortExpression params tables grouping

409+ AscNullsFirst

410+ :: Expression params tables grouping ('Required ('Null ty))

411+ -> SortExpression params tables grouping

412+ AscNullsLast

413+ :: Expression params tables grouping ('Required ('Null ty))

414+ -> SortExpression params tables grouping

415+ DescNullsFirst

416+ :: Expression params tables grouping ('Required ('Null ty))

417+ -> SortExpression params tables grouping

418+ DescNullsLast

419+ :: Expression params tables grouping ('Required ('Null ty))

420+ -> SortExpression params tables grouping

421+

422+renderSortExpression :: SortExpression params tables grouping -> ByteString

423+renderSortExpression = \case

424+ Asc expression -> renderExpression expression <+> "ASC"

425+ Desc expression -> renderExpression expression <+> "DESC"

426+ AscNullsFirst expression -> renderExpression expression

427+ <+> "ASC NULLS FIRST"

428+ DescNullsFirst expression -> renderExpression expression

429+ <+> "DESC NULLS FIRST"

430+ AscNullsLast expression -> renderExpression expression <+> "ASC NULLS LAST"

431+ DescNullsLast expression -> renderExpression expression <+> "DESC NULLS LAST"

432+

433+

434+{-----------------------------------------

435+aggregation

436+-----------------------------------------}

437+

438+data By

439+ (tables :: [(Symbol,[(Symbol,ColumnType)])])

440+ (tabcol :: (Symbol,Symbol)) where

441+ By

442+ :: (tables ~ '[table ::: columns], HasColumn column columns ty)

443+ => Alias column

444+ -> By tables '(table, column)

445+ By2

446+ :: (HasTable table tables columns, HasColumn column columns ty)

447+ => (Alias table, Alias column)

448+ -> By tables '(table, column)

449+

450+renderBy :: By tables tabcolty -> ByteString

451+renderBy = \case

452+ By column -> renderAlias column

453+ By2 (table, column) -> renderAlias table <> "." <> renderAlias column

454+

455+data GroupByClause tables grouping where

456+ NoGroups :: GroupByClause tables 'Ungrouped

457+ Group

458+ :: SListI bys

459+ => NP (By tables) bys

460+ -> GroupByClause tables ('Grouped bys)

461+

462+renderGroupByClause :: GroupByClause tables grouping -> ByteString

463+renderGroupByClause = \case

464+ NoGroups -> ""

465+ Group Nil -> ""

466+ Group bys -> " GROUP BY" <+> renderCommaSeparated renderBy bys

467+

468+data HavingClause params tables grouping where

469+ NoHaving :: HavingClause params tables 'Ungrouped

470+ Having

471+ :: [Condition params tables ('Grouped bys)]

472+ -> HavingClause params tables ('Grouped bys)

473+

474+renderHavingClause :: HavingClause params tables grouping -> ByteString

475+renderHavingClause = \case

476+ NoHaving -> ""

477+ Having [] -> ""

478+ Having conditions ->

479+ " HAVING" <+> commaSeparated (renderExpression <$> conditions)

480+

481+class (KnownSymbol table, KnownSymbol column)

482+ => GroupedBy table column bys where

483+ getGroup1

484+ :: (tables ~ '[table ::: columns], HasColumn column columns ty)

485+ => Alias column

486+ -> Expression params tables ('Grouped bys) ty

487+ getGroup1 column = UnsafeExpression $ renderAlias column

488+ getGroup2

489+ :: (HasTable table tables columns, HasColumn column columns ty)

490+ => Alias table

491+ -> Alias column

492+ -> Expression params tables ('Grouped bys) ty

493+ getGroup2 table column = UnsafeExpression $

494+ renderAlias table <> "." <> renderAlias column

495+instance {-# OVERLAPPING #-} (KnownSymbol table, KnownSymbol column)

496+ => GroupedBy table column ('(table,column) ': bys)

497+instance {-# OVERLAPPABLE #-}

498+ ( KnownSymbol table

499+ , KnownSymbol column

500+ , GroupedBy table column bys

501+ ) => GroupedBy table column (tabcol ': bys)

502+

503+instance

504+ ( tables ~ '[table ::: columns]

505+ , HasColumn column columns ty

506+ , GroupedBy table column bys

507+ ) => IsLabel column

508+ (Expression params tables ('Grouped bys) ty) where

509+ fromLabel = getGroup1 (Alias @column)

510+

511+instance

512+ ( HasTable table tables columns

513+ , HasColumn column columns ty

514+ , GroupedBy table column bys

515+ ) => IsTableColumn table column

516+ (Expression params tables ('Grouped bys) ty) where (!) = getGroup2

517+

518+unsafeAggregate

519+ :: ByteString

520+ -> Expression params tables 'Ungrouped ('Required xty)

521+ -> Expression params tables ('Grouped bys) ('Required yty)

522+unsafeAggregate fun x = UnsafeExpression $ mconcat

523+ [fun, "(", renderExpression x, ")"]

524+

525+sum_

526+ :: PGNum ty

527+ => Expression params tables 'Ungrouped ('Required (nullity ty))

528+ -> Expression params tables ('Grouped bys) ('Required (nullity ty))

529+sum_ = unsafeAggregate "sum"

530+

531+avgInt

532+ :: PGIntegral int

533+ => Expression params tables 'Ungrouped ('Required (nullity int))

534+ -> Expression params tables ('Grouped bys) ('Required (nullity 'PGnumeric))

535+avgInt = unsafeAggregate "avg"

536+

537+avgFloat

538+ :: PGFloating float

539+ => Expression params tables 'Ungrouped ('Required (nullity float))

540+ -> Expression params tables ('Grouped bys) ('Required (nullity 'PGfloat8))

541+avgFloat = unsafeAggregate "avg"

542+

543+bitAnd

544+ :: PGIntegral int

545+ => Expression params tables 'Ungrouped ('Required (nullity int))

546+ -> Expression params tables ('Grouped bys) ('Required (nullity int))

547+bitAnd = unsafeAggregate "bit_and"

548+

549+bitOr

550+ :: PGIntegral int

551+ => Expression params tables 'Ungrouped ('Required (nullity int))

552+ -> Expression params tables ('Grouped bys) ('Required (nullity int))

553+bitOr = unsafeAggregate "bit_or"

554+

555+boolAnd

556+ :: Expression params tables 'Ungrouped ('Required (nullity 'PGbool))

557+ -> Expression params tables ('Grouped bys) ('Required (nullity 'PGbool))

558+boolAnd = unsafeAggregate "bool_and"

559+

560+boolOr

561+ :: Expression params tables 'Ungrouped ('Required (nullity 'PGbool))

562+ -> Expression params tables ('Grouped bys) ('Required (nullity 'PGbool))

563+boolOr = unsafeAggregate "bool_or"

564+

565+countStar

566+ :: Expression params table ('Grouped bys) ('Required ('NotNull 'PGint8))

567+countStar = UnsafeExpression "count(*)"

568+

569+count

570+ :: Expression params tables 'Ungrouped ('Required ty)

571+ -> Expression params tables ('Grouped bys) ('Required ('NotNull 'PGint8))

572+count = unsafeAggregate "count"

573+

574+every

575+ :: Expression params tables 'Ungrouped ('Required (nullity 'PGbool))

576+ -> Expression params tables ('Grouped bys) ('Required (nullity 'PGbool))

577+every = unsafeAggregate "every"

578+

579+jsonAgg

580+ :: Expression params tables 'Ungrouped ('Required ty)

581+ -> Expression params tables ('Grouped bys) ('Required ('NotNull 'PGjson))

582+jsonAgg = unsafeAggregate "json_agg"

583+

584+jsonbAgg

585+ :: Expression params tables 'Ungrouped ('Required ty)

586+ -> Expression params tables ('Grouped bys) ('Required ('NotNull 'PGjsonb))

587+jsonbAgg = unsafeAggregate "jsonb_agg"

588+

589+jsonObjectAgg

590+ :: Expression params tables 'Ungrouped ('Required ('NotNull keyty))

591+ -> Expression params tables 'Ungrouped ('Required valty)

592+ -> Expression params tables ('Grouped bys) ('Required ('NotNull 'PGjson))

593+jsonObjectAgg k v = UnsafeExpression $

594+ "json_object_agg(" <> renderExpression k

595+ <> ", " <> renderExpression v <> ")"

596+

597+jsonbObjectAgg

598+ :: Expression params tables 'Ungrouped ('Required ('NotNull keyty))

599+ -> Expression params tables 'Ungrouped ('Required valty)

600+ -> Expression params tables ('Grouped bys) ('Required ('NotNull 'PGjsonb))

601+jsonbObjectAgg k v = UnsafeExpression $

602+ "jsonb_object_agg(" <> renderExpression k

603+ <> ", " <> renderExpression v <> ")"

604+

605+max_

606+ :: Expression params tables 'Ungrouped ('Required (nullity ty))

607+ -> Expression params tables ('Grouped bys) ('Required (nullity ty))

608+max_ = unsafeAggregate "max"

609+

610+min_

611+ :: Expression params tables 'Ungrouped ('Required (nullity ty))

612+ -> Expression params tables ('Grouped bys) ('Required (nullity ty))

613+min_ = unsafeAggregate "min"

614+

615+{-----------------------------------------

616+tables

617+-----------------------------------------}

618+

619+newtype Table

620+ (schema :: [(Symbol,[(Symbol,ColumnType)])])

621+ (columns :: [(Symbol,ColumnType)])

622+ = UnsafeTable { renderTable :: ByteString }

623+ deriving (Show,Eq)

624+

625+class KnownSymbol table => HasTable table tables columns

626+ | table tables -> columns where

627+ getTable :: Alias table -> Table tables columns

628+ getTable table = UnsafeTable $ renderAlias table

629+instance {-# OVERLAPPING #-} KnownSymbol table

630+ => HasTable table ((table ::: columns) ': tables) columns

631+instance {-# OVERLAPPABLE #-}

632+ (KnownSymbol table, HasTable table schema columns)

633+ => HasTable table (table' ': schema) columns

634+

635+instance HasTable table schema columns

636+ => IsLabel table (Table schema columns) where

637+ fromLabel = getTable (Alias @table)

638+

639+data FromClause params schema tables where

640+ Table

641+ :: Aliased (Table schema) table

642+ -> FromClause params schema '[table]

643+ Subquery

644+ :: Aliased (Query schema params) table

645+ -> FromClause params schema '[table]

646+ CrossJoin

647+ :: FromClause params schema right

648+ -> FromClause params schema left

649+ -> FromClause params schema (Join left right)

650+ InnerJoin

651+ :: FromClause params schema right

652+ -> Condition params (Join left right) 'Ungrouped

653+ -> FromClause params schema left

654+ -> FromClause params schema (Join left right)

655+ LeftOuterJoin

656+ :: FromClause params schema right

657+ -> Condition params (Join left right) 'Ungrouped

658+ -> FromClause params schema left

659+ -> FromClause params schema (Join left (NullifyTables right))

660+ RightOuterJoin

661+ :: FromClause params schema right

662+ -> Condition params (Join left right) 'Ungrouped

663+ -> FromClause params schema left

664+ -> FromClause params schema (Join (NullifyTables left) right)

665+ FullOuterJoin

666+ :: FromClause params schema right

667+ -> Condition params (Join left right) 'Ungrouped

668+ -> FromClause params schema left

669+ -> FromClause params schema

670+ (Join (NullifyTables left) (NullifyTables right))

671+

672+renderFromClause :: FromClause params schema tables -> ByteString

673+renderFromClause = \case

674+ Table table -> renderAliased renderTable table

675+ Subquery selection -> renderAliased renderQuery selection

676+ CrossJoin right left ->

677+ renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right

678+ InnerJoin right on left -> renderJoin "INNER JOIN" right on left

679+ LeftOuterJoin right on left -> renderJoin "LEFT OUTER JOIN" right on left

680+ RightOuterJoin right on left -> renderJoin "RIGHT OUTER JOIN" right on left

681+ FullOuterJoin right on left -> renderJoin "FULL OUTER JOIN" right on left

682+ where

683+ renderJoin op right on left =

684+ renderFromClause left <+> op <+> renderFromClause right

685+ <+> "ON" <+> renderExpression on

686+

687+data TableExpression

688+ (params :: [ColumnType])

689+ (schema :: [(Symbol,[(Symbol,ColumnType)])])

690+ (tables :: [(Symbol,[(Symbol,ColumnType)])])

691+ (grouping :: Grouping)

692+ = TableExpression

693+ { fromClause :: FromClause params schema tables

694+ , whereClause :: [Condition params tables 'Ungrouped]

695+ , groupByClause :: GroupByClause tables grouping

696+ , havingClause :: HavingClause params tables grouping

697+ , orderByClause :: [SortExpression params tables grouping]

698+ , limitClause :: [Word64]

699+ , offsetClause :: [Word64]

700+ }

701+

702+renderTableExpression

703+ :: TableExpression params schema tables grouping

704+ -> ByteString

705+renderTableExpression

706+ (TableExpression tables whs' grps' hvs' srts' lims' offs') = mconcat

707+ [ "FROM ", renderFromClause tables

708+ , renderWheres whs'

709+ , renderGroupByClause grps'

710+ , renderHavingClause hvs'

711+ , renderSorts srts'

712+ , renderLimits lims'

713+ , renderOffsets offs'

714+ ]

715+ where

716+ renderWheres = \case

717+ [] -> ""

718+ wh:[] -> " WHERE" <+> renderExpression wh

719+ wh:whs -> " WHERE" <+> renderExpression (foldr (&&*) wh whs)

720+ renderSorts = \case

721+ [] -> ""

722+ srts -> " SORT BY"

723+ <+> commaSeparated (renderSortExpression <$> srts)

724+ renderLimits = \case

725+ [] -> ""

726+ lims -> " LIMIT" <+> fromString (show (minimum lims))

727+ renderOffsets = \case

728+ [] -> ""

729+ offs -> " OFFSET" <+> fromString (show (sum offs))

730+

731+from

732+ :: FromClause params schema tables

733+ -> TableExpression params schema tables 'Ungrouped

734+from tables = TableExpression tables [] NoGroups NoHaving [] [] []

735+

736+where_

737+ :: Condition params tables 'Ungrouped

738+ -> TableExpression params schema tables grouping

739+ -> TableExpression params schema tables grouping

740+where_ wh tables = tables {whereClause = wh : whereClause tables}

741+

742+group

743+ :: SListI bys

744+ => NP (By tables) bys

745+ -> TableExpression params schema tables 'Ungrouped

746+ -> TableExpression params schema tables ('Grouped bys)

747+group bys tables = TableExpression

748+ { fromClause = fromClause tables

749+ , whereClause = whereClause tables

750+ , groupByClause = Group bys

751+ , havingClause = Having []

752+ , orderByClause = []

753+ , limitClause = limitClause tables

754+ , offsetClause = offsetClause tables

755+ }

756+

757+having

758+ :: Condition params tables ('Grouped bys)

759+ -> TableExpression params schema tables ('Grouped bys)

760+ -> TableExpression params schema tables ('Grouped bys)

761+having hv tables = tables

762+ { havingClause = case havingClause tables of Having hvs -> Having (hv:hvs) }

763+

764+orderBy

765+ :: [SortExpression params tables grouping]

766+ -> TableExpression params schema tables grouping

767+ -> TableExpression params schema tables grouping

768+orderBy srts tables = tables {orderByClause = orderByClause tables ++ srts}

769+

770+limit

771+ :: Word64

772+ -> TableExpression params schema tables grouping

773+ -> TableExpression params schema tables grouping

774+limit lim tables = tables {limitClause = lim : limitClause tables}

775+

776+offset

777+ :: Word64

778+ -> TableExpression params schema tables grouping

779+ -> TableExpression params schema tables grouping

780+offset off tables = tables {offsetClause = off : offsetClause tables}

781+

782+{-----------------------------------------

783+type expressions

784+-----------------------------------------}

785+

786+newtype TypeExpression (ty :: ColumnType)

787+ = UnsafeTypeExpression { renderTypeExpression :: ByteString }

788+ deriving (Show,Eq)

789+

790+bool :: TypeExpression ('Required ('Null 'PGbool))

791+bool = UnsafeTypeExpression "bool"

792+int2 :: TypeExpression ('Required ('Null 'PGint2))

793+int2 = UnsafeTypeExpression "int2"

794+smallint :: TypeExpression ('Required ('Null 'PGint2))

795+smallint = UnsafeTypeExpression "smallint"

796+int4 :: TypeExpression ('Required ('Null 'PGint4))

797+int4 = UnsafeTypeExpression "int4"

798+int :: TypeExpression ('Required ('Null 'PGint4))

799+int = UnsafeTypeExpression "int"

800+integer :: TypeExpression ('Required ('Null 'PGint4))

801+integer = UnsafeTypeExpression "integer"

802+int8 :: TypeExpression ('Required ('Null 'PGint8))

803+int8 = UnsafeTypeExpression "int8"

804+bigint :: TypeExpression ('Required ('Null 'PGint8))

805+bigint = UnsafeTypeExpression "bigint"

806+numeric :: TypeExpression ('Required ('Null 'PGnumeric))

807+numeric = UnsafeTypeExpression "numeric"

808+float4 :: TypeExpression ('Required ('Null 'PGfloat4))

809+float4 = UnsafeTypeExpression "float4"

810+real :: TypeExpression ('Required ('Null 'PGfloat4))

811+real = UnsafeTypeExpression "real"

812+float8 :: TypeExpression ('Required ('Null 'PGfloat8))

813+float8 = UnsafeTypeExpression "float8"

814+doublePrecision :: TypeExpression ('Required ('Null 'PGfloat8))

815+doublePrecision = UnsafeTypeExpression "double precision"

816+serial2 :: TypeExpression ('Optional ('NotNull 'PGint2))

817+serial2 = UnsafeTypeExpression "serial2"

818+smallserial :: TypeExpression ('Optional ('NotNull 'PGint2))

819+smallserial = UnsafeTypeExpression "smallserial"

820+serial4 :: TypeExpression ('Optional ('NotNull 'PGint4))

821+serial4 = UnsafeTypeExpression "serial4"

822+serial :: TypeExpression ('Optional ('NotNull 'PGint4))

823+serial = UnsafeTypeExpression "serial"

824+serial8 :: TypeExpression ('Optional ('NotNull 'PGint8))

825+serial8 = UnsafeTypeExpression "serial8"

826+bigserial :: TypeExpression ('Optional ('NotNull 'PGint8))

827+bigserial = UnsafeTypeExpression "bigserial"

828+text :: TypeExpression ('Required ('Null 'PGtext))

829+text = UnsafeTypeExpression "text"

830+char

831+ :: KnownNat n

832+ => proxy n

833+ -> TypeExpression ('Required ('Null ('PGchar n)))

834+char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"

835+character

836+ :: KnownNat n

837+ => proxy n

838+ -> TypeExpression ('Required ('Null ('PGchar n)))

839+character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"

840+varchar

841+ :: KnownNat n

842+ => proxy n

843+ -> TypeExpression ('Required ('Null ('PGvarchar n)))

844+varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"

845+characterVarying

846+ :: KnownNat n

847+ => proxy n

848+ -> TypeExpression ('Required ('Null ('PGvarchar n)))

849+characterVarying p = UnsafeTypeExpression $

850+ "character varying(" <> renderNat p <> ")"

851+bytea :: TypeExpression ('Required ('Null ('PGbytea)))

852+bytea = UnsafeTypeExpression "bytea"

853+timestamp :: TypeExpression ('Required ('Null ('PGtimestamp)))

854+timestamp = UnsafeTypeExpression "timestamp"

855+timestampWithTimeZone :: TypeExpression ('Required ('Null ('PGtimestamptz)))

856+timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

857+date :: TypeExpression ('Required ('Null ('PGdate)))

858+date = UnsafeTypeExpression "date"

859+time :: TypeExpression ('Required ('Null ('PGtime)))

860+time = UnsafeTypeExpression "time"

861+timeWithTimeZone :: TypeExpression ('Required ('Null ('PGtimetz)))

862+timeWithTimeZone = UnsafeTypeExpression "time with time zone"

863+interval :: TypeExpression ('Required ('Null ('PGinterval)))

864+interval = UnsafeTypeExpression "interval"

865+uuid :: TypeExpression ('Required ('Null ('PGuuid)))

866+uuid = UnsafeTypeExpression "uuid"

867+json :: TypeExpression ('Required ('Null ('PGjson)))

868+json = UnsafeTypeExpression "json"

869+jsonb :: TypeExpression ('Required ('Null ('PGjsonb)))

870+jsonb = UnsafeTypeExpression "jsonb"

871+

872+notNull

873+ :: TypeExpression (optionality ('Null ty))

874+ -> TypeExpression (optionality ('NotNull ty))

875+notNull ty = UnsafeTypeExpression $ renderTypeExpression ty <+> "NOT NULL"

876+default_

877+ :: Expression '[] '[] 'Ungrouped ('Required ty)

878+ -> TypeExpression ('Required ty)

879+ -> TypeExpression ('Optional ty)

880+default_ x ty = UnsafeTypeExpression $

881+ renderTypeExpression ty <+> "DEFAULT" <+> renderExpression x

882+

883+class PGTyped (ty :: PGType) where

884+ pgtype :: TypeExpression ('Required ('Null ty))

885+instance PGTyped 'PGbool where pgtype = bool

886+instance PGTyped 'PGint2 where pgtype = int2

887+instance PGTyped 'PGint4 where pgtype = int4

888+instance PGTyped 'PGint8 where pgtype = int8

889+instance PGTyped 'PGnumeric where pgtype = numeric

890+instance PGTyped 'PGfloat4 where pgtype = float4

891+instance PGTyped 'PGfloat8 where pgtype = float8

892+instance PGTyped 'PGtext where pgtype = text

893+instance KnownNat n => PGTyped ('PGchar n) where pgtype = char (Proxy @n)

894+instance KnownNat n => PGTyped ('PGvarchar n) where pgtype = varchar (Proxy @n)

895+instance PGTyped 'PGbytea where pgtype = bytea

896+instance PGTyped 'PGtimestamp where pgtype = timestamp

897+instance PGTyped 'PGtimestamptz where pgtype = timestampWithTimeZone

898+instance PGTyped 'PGdate where pgtype = date

899+instance PGTyped 'PGtime where pgtype = time

900+instance PGTyped 'PGtimetz where pgtype = timeWithTimeZone

901+instance PGTyped 'PGinterval where pgtype = interval

902+instance PGTyped 'PGuuid where pgtype = uuid

903+instance PGTyped 'PGjson where pgtype = json

904+instance PGTyped 'PGjsonb where pgtype = jsonb

905+

906+{-----------------------------------------

907+statements

908+-----------------------------------------}

909+

910+newtype Definition

911+ (schema0 :: [(Symbol,[(Symbol,ColumnType)])])

912+ (schema1 :: [(Symbol,[(Symbol,ColumnType)])])

913+ = UnsafeDefinition { renderDefinition :: ByteString }

914+

915+instance Category Definition where

916+ id = UnsafeDefinition ";"

917+ ddl1 . ddl0 = UnsafeDefinition $

918+ renderDefinition ddl0 <+> renderDefinition ddl1

919+

920+newtype Manipulation

921+ (schema :: [(Symbol,[(Symbol,ColumnType)])])

922+ (params :: [ColumnType])

923+ (columns :: [(Symbol,ColumnType)])

924+ = UnsafeManipulation { renderManipulation :: ByteString }

925+

926+newtype Query

927+ (schema :: [(Symbol,[(Symbol,ColumnType)])])

928+ (params :: [ColumnType])

929+ (columns :: [(Symbol,ColumnType)])

930+ = UnsafeQuery { renderQuery :: ByteString }

931+

932+queryStatement

933+ :: Query schema params columns

934+ -> Manipulation schema params columns

935+queryStatement q = UnsafeManipulation $ renderQuery q <> ";"

936+

937+union, unionAll, intersect, intersectAll, except, exceptAll

938+ :: Query schema params columns

939+ -> Query schema params columns

940+ -> Query schema params columns

941+q1 `union` q2 = UnsafeQuery $

942+ parenthesized (renderQuery q1)

943+ <+> "UNION"

944+ <+> parenthesized (renderQuery q2)

945+q1 `unionAll` q2 = UnsafeQuery $

946+ parenthesized (renderQuery q1)

947+ <+> "UNION" <+> "ALL"

948+ <+> parenthesized (renderQuery q2)

949+q1 `intersect` q2 = UnsafeQuery $

950+ parenthesized (renderQuery q1)

951+ <+> "INTERSECT"

952+ <+> parenthesized (renderQuery q2)

953+q1 `intersectAll` q2 = UnsafeQuery $

954+ parenthesized (renderQuery q1)

955+ <+> "INTERSECT" <+> "ALL"

956+ <+> parenthesized (renderQuery q2)

957+q1 `except` q2 = UnsafeQuery $

958+ parenthesized (renderQuery q1)

959+ <+> "EXCEPT"

960+ <+> parenthesized (renderQuery q2)

961+q1 `exceptAll` q2 = UnsafeQuery $

962+ parenthesized (renderQuery q1)

963+ <+> "EXCEPT" <+> "ALL"

964+ <+> parenthesized (renderQuery q2)

965+

966+{-----------------------------------------

967+SELECT statements

968+-----------------------------------------}

969+

970+select

971+ :: SListI columns

972+ => NP (Aliased (Expression params tables grouping)) (column ': columns)

973+ -> TableExpression params schema tables grouping

974+ -> Query schema params (column ': columns)

975+select list tabs = UnsafeQuery $

976+ "SELECT"

977+ <+> renderCommaSeparated (renderAliased renderExpression) list

978+ <+> renderTableExpression tabs

979+

980+selectStar

981+ :: tables ~ '[table ::: columns]

982+ => TableExpression params schema tables 'Ungrouped

983+ -> Query schema params columns

984+selectStar tabs = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression tabs

985+

986+selectDotStar

987+ :: HasTable table tables columns

988+ => Alias table

989+ -> TableExpression params schema tables 'Ungrouped

990+ -> Query schema params columns

991+selectDotStar table tables = UnsafeQuery $

992+ "SELECT" <+> renderAlias table <> ".*" <+> renderTableExpression tables

993+

994+selectRow

995+ :: SListI columns

996+ => NP (Aliased (Expression params '[] 'Ungrouped)) columns

997+ -> Query schema params columns

998+selectRow row = UnsafeQuery $

999+ "SELECT" <+> renderCommaSeparated (renderAliased renderExpression) row

1000+

1001+{-----------------------------------------

1002+CREATE statements

1003+-----------------------------------------}

1004+

1005+createTable

1006+ :: (KnownSymbol table, SListI columns)

1007+ => Alias table

1008+ -> NP (Aliased TypeExpression) (column ': columns)

1009+ -> [TableConstraint schema (column ': columns)]

1010+ -> Definition schema (Create table (column ': columns) schema)

1011+createTable table columns constraints = UnsafeDefinition $

1012+ "CREATE TABLE" <+> renderAlias table

1013+ <+> parenthesized

1014+ ( renderCommaSeparated renderColumnDef columns

1015+ <> renderConstraints constraints )

1016+ <> ";"

1017+ where

1018+ renderColumnDef :: Aliased TypeExpression x -> ByteString

1019+ renderColumnDef (ty `As` column) =

1020+ renderAlias column <+> renderTypeExpression ty

1021+ renderConstraints :: [TableConstraint schema columns] -> ByteString

1022+ renderConstraints = \case

1023+ [] -> ""

1024+ _ -> ", " <> commaSeparated (renderTableConstraint <$> constraints)

1025+

1026+data TableConstraint

1027+ (schema :: [(Symbol,[(Symbol,ColumnType)])])

1028+ (columns :: [(Symbol,ColumnType)])

1029+ = UnsafeTableConstraint { renderTableConstraint :: ByteString }

1030+

1031+check

1032+ :: Condition '[] '[table ::: columns] 'Ungrouped

1033+ -> TableConstraint schema columns

1034+check condition = UnsafeTableConstraint $

1035+ "CHECK" <+> parenthesized (renderExpression condition)

1036+

1037+data Column

1038+ (columns :: [(Symbol,ColumnType)])

1039+ (columnty :: (Symbol,ColumnType))

1040+ where

1041+ Column

1042+ :: HasColumn column columns ty

1043+ => Alias column

1044+ -> Column columns (column ::: ty)

1045+

1046+renderColumn :: Column columns columnty -> ByteString

1047+renderColumn (Column column) = renderAlias column

1048+

1049+unique

1050+ :: SListI subcolumns

1051+ => NP (Column columns) subcolumns

1052+ -> TableConstraint schema columns

1053+unique columns = UnsafeTableConstraint $

1054+ "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)

1055+

1056+primaryKey

1057+ :: (SListI subcolumns, AllNotNull subcolumns)

1058+ => NP (Column columns) subcolumns

1059+ -> TableConstraint schema columns

1060+primaryKey columns = UnsafeTableConstraint $

1061+ "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)

1062+

1063+foreignKey

1064+ :: ( HasTable reftable schema refcolumns

1065+ , SameTypes subcolumns refsubcolumns

1066+ , NotAllNull subcolumns

1067+ , SListI subcolumns

1068+ , SListI refsubcolumns)

1069+ => NP (Column columns) subcolumns

1070+ -> Alias reftable

1071+ -> NP (Column refcolumns) refsubcolumns

1072+ -> OnDelete

1073+ -> OnUpdate

1074+ -> TableConstraint schema columns

1075+foreignKey columns reftable refcolumns onDelete onUpdate =

1076+ UnsafeTableConstraint $

1077+ "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)

1078+ <+> "REFERENCES" <+> renderAlias reftable

1079+ <+> parenthesized (renderCommaSeparated renderColumn refcolumns)

1080+ <+> renderOnDelete onDelete

1081+ <+> renderOnUpdate onUpdate

1082+

1083+data OnDelete

1084+ = OnDeleteNoAction

1085+ | OnDeleteRestrict

1086+ | OnDeleteCascade

1087+

1088+renderOnDelete :: OnDelete -> ByteString

1089+renderOnDelete = \case

1090+ OnDeleteNoAction -> "ON DELETE NO ACTION"

1091+ OnDeleteRestrict -> "ON DELETE RESTRICT"

1092+ OnDeleteCascade -> "ON DELETE CASCADE"

1093+

1094+data OnUpdate

1095+ = OnUpdateNoAction

1096+ | OnUpdateRestrict

1097+ | OnUpdateCascade

1098+

1099+renderOnUpdate :: OnUpdate -> ByteString

1100+renderOnUpdate = \case

1101+ OnUpdateNoAction -> "ON UPDATE NO ACTION"

1102+ OnUpdateRestrict -> "ON UPDATE RESTRICT"

1103+ OnUpdateCascade -> "ON UPDATE CASCADE"

1104+

1105+{-----------------------------------------

1106+DROP statements

1107+-----------------------------------------}

1108+

1109+dropTable

1110+ :: KnownSymbol table

1111+ => Alias table

1112+ -> Definition schema (Drop table schema)

1113+dropTable table = UnsafeDefinition $ "DROP TABLE" <+> renderAlias table <> ";"

1114+

1115+{-----------------------------------------

1116+ALTER statements

1117+-----------------------------------------}

1118+

1119+alterTable

1120+ :: HasTable table schema columns0

1121+ => Alias table

1122+ -> AlterTable columns0 columns1

1123+ -> Definition schema (Alter table schema columns1)

1124+alterTable table alteration = UnsafeDefinition $

1125+ "ALTER TABLE"

1126+ <+> renderAlias table

1127+ <+> renderAlterTable alteration

1128+ <> ";"

1129+

1130+alterTableRename

1131+ :: (KnownSymbol table0, KnownSymbol table1)

1132+ => Alias table0

1133+ -> Alias table1

1134+ -> Definition schema (Rename table0 table1 schema)

1135+alterTableRename table0 table1 = UnsafeDefinition $

1136+ "ALTER TABLE" <+> renderAlias table0

1137+ <+> "RENAME TO" <+> renderAlias table1 <> ";"

1138+

1139+data AlterTable

1140+ (columns0 :: [(Symbol, ColumnType)])

1141+ (columns1 :: [(Symbol, ColumnType)]) =

1142+ UnsafeAlterTable {renderAlterTable :: ByteString}

1143+

1144+addColumnDefault

1145+ :: KnownSymbol column

1146+ => Alias column

1147+ -> TypeExpression ('Optional ty)

1148+ -> AlterTable columns (Create column ('Optional ty) columns)

1149+addColumnDefault column ty = UnsafeAlterTable $

1150+ "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty

1151+

1152+addColumnNull

1153+ :: KnownSymbol column

1154+ => Alias column

1155+ -> TypeExpression ('Required ('Null ty))

1156+ -> AlterTable columns ((column ::: 'Required ('Null ty)) ': columns)

1157+addColumnNull column ty = UnsafeAlterTable $

1158+ "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty

1159+

1160+dropColumn

1161+ :: KnownSymbol column

1162+ => Alias column

1163+ -> AlterTable columns (Drop column columns)

1164+dropColumn column = UnsafeAlterTable $

1165+ "DROP COLUMN" <+> renderAlias column

1166+

1167+renameColumn

1168+ :: (KnownSymbol column0, KnownSymbol column1)

1169+ => Alias column0

1170+ -> Alias column1

1171+ -> AlterTable columns (Rename column0 column1 columns)

1172+renameColumn column0 column1 = UnsafeAlterTable $

1173+ "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1

1174+

1175+alterColumn

1176+ :: (KnownSymbol column, HasColumn column columns ty0)

1177+ => Alias column

1178+ -> AlterColumn ty0 ty1

1179+ -> AlterTable columns (Alter column columns ty1)

1180+alterColumn column alteration = UnsafeAlterTable $

1181+ "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration

1182+

1183+data AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) =

1184+ UnsafeAlterColumn {renderAlterColumn :: ByteString}

1185+

1186+setDefault

1187+ :: Expression '[] '[] 'Ungrouped ('Required ty)

1188+ -> AlterColumn ('Required ty) ('Optional ty)

1189+setDefault expression = UnsafeAlterColumn $

1190+ "SET DEFAULT" <+> renderExpression expression

1191+

1192+dropDefault :: AlterColumn ('Optional ty) ('Required ty)

1193+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"

1194+

1195+setNotNull

1196+ :: AlterColumn (optionality ('Null ty)) (optionality ('NotNull ty))

1197+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"

1198+

1199+dropNotNull

1200+ :: AlterColumn (optionality ('NotNull ty)) (optionality ('Null ty))

1201+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"

1202+

1203+alterType

1204+ :: TypeExpression (optionality (nullity ty1))

1205+ -> AlterColumn (optionality (nullity ty0)) (optionality (nullity ty1))

1206+alterType ty = UnsafeAlterColumn $ "TYPE " <> renderTypeExpression ty

1207+

1208+{-----------------------------------------

1209+INSERT statements

1210+-----------------------------------------}

1211+

1212+insertInto

1213+ :: (SListI columns, SListI results, HasTable table schema columns)

1214+ => Alias table

1215+ -> ValuesClause schema params columns

1216+ -> ConflictClause params columns

1217+ -> ReturningClause params columns results

1218+ -> Manipulation schema params results

1219+insertInto table insert conflict returning = UnsafeManipulation $

1220+ "INSERT" <+> "INTO" <+> renderAlias table

1221+ <+> renderValuesClause insert

1222+ <> renderConflictClause conflict

1223+ <> renderReturningClause returning

1224+

1225+data ValuesClause

1226+ (schema :: [(Symbol,[(Symbol,ColumnType)])])

1227+ (params :: [ColumnType])

1228+ (columns :: [(Symbol,ColumnType)])

1229+ = Values

1230+ (NP (Aliased (Expression params '[] 'Ungrouped)) columns)

1231+ [NP (Aliased (Expression params '[] 'Ungrouped)) columns]

1232+ | ValuesQuery (Query schema params columns)

1233+

1234+renderValuesClause

1235+ :: SListI columns

1236+ => ValuesClause schema params columns

1237+ -> ByteString

1238+renderValuesClause = \case

1239+ Values row rows ->

1240+ parenthesized (renderCommaSeparated renderAliasPart row)

1241+ <+> "VALUES"

1242+ <+> commaSeparated

1243+ (parenthesized . renderCommaSeparated renderValuePart <$> row:rows)

1244+ where

1245+ renderAliasPart, renderValuePart

1246+ :: Aliased (Expression params '[] 'Ungrouped) ty -> ByteString

1247+ renderAliasPart (_ `As` name) = renderAlias name

1248+ renderValuePart (value `As` _) = renderExpression value

1249+ ValuesQuery q -> renderQuery q

1250+

1251+data ReturningClause

1252+ (params :: [ColumnType])

1253+ (columns :: [(Symbol,ColumnType)])

1254+ (results :: [(Symbol,ColumnType)])

1255+ where

1256+ ReturningStar :: ReturningClause params columns columns

1257+ Returning

1258+ :: NP

1259+ (Aliased (Expression params '[table ::: columns] 'Ungrouped))

1260+ results

1261+ -> ReturningClause params columns results

1262+

1263+renderReturningClause

1264+ :: SListI results

1265+ => ReturningClause params columns results

1266+ -> ByteString

1267+renderReturningClause = \case

1268+ ReturningStar -> " RETURNING *;"

1269+ Returning Nil -> ";"

1270+ Returning results -> " RETURNING"

1271+ <+> renderCommaSeparated (renderAliased renderExpression) results <> ";"

1272+

1273+data ConflictClause params columns where

1274+ Conflict :: ConflictClause params columns

1275+ OnConflictDoNothing :: ConflictClause params columns

1276+ OnConflictDoUpdate

1277+ :: NP (Aliased (UpdateExpression params columns)) columns

1278+ -> Maybe (Condition params '[table ::: columns] 'Ungrouped)

1279+ -> ConflictClause params columns

1280+

1281+renderConflictClause

1282+ :: SListI columns

1283+ => ConflictClause params columns

1284+ -> ByteString

1285+renderConflictClause = \case

1286+ Conflict -> ""

1287+ OnConflictDoNothing -> " ON CONFLICT DO NOTHING"

1288+ OnConflictDoUpdate updates whMaybe

1289+ -> " ON CONFLICT DO UPDATE SET"

1290+ <+> renderCommaSeparatedMaybe renderUpdateExpression updates

1291+ <> case whMaybe of

1292+ Nothing -> ""

1293+ Just wh -> " WHERE" <+> renderExpression wh

1294+

1295+{-----------------------------------------

1296+UPDATE statements

1297+-----------------------------------------}

1298+

1299+data UpdateExpression params columns ty

1300+ = Same

1301+ | Set (forall table. Expression params '[table ::: columns] 'Ungrouped ty)

1302+

1303+renderUpdateExpression

1304+ :: Aliased (UpdateExpression params columns) column

1305+ -> Maybe ByteString

1306+renderUpdateExpression = \case

1307+ Same `As` _ -> Nothing

1308+ Set expression `As` column -> Just $

1309+ renderAlias column <+> "=" <+> renderExpression expression

1310+

1311+update

1312+ :: (HasTable table schema columns, SListI columns, SListI results)

1313+ => Alias table

1314+ -> NP (Aliased (UpdateExpression params columns)) columns

1315+ -> Condition params '[tab ::: columns] 'Ungrouped

1316+ -> ReturningClause params columns results

1317+ -> Manipulation schema params results

1318+update table columns wh returning = UnsafeManipulation $

1319+ "UPDATE"

1320+ <+> renderAlias table

1321+ <+> "SET"

1322+ <+> renderCommaSeparatedMaybe renderUpdateExpression columns

1323+ <+> "WHERE" <+> renderExpression wh

1324+ <> renderReturningClause returning

1325+

1326+{-----------------------------------------

1327+DELETE statements

1328+-----------------------------------------}

1329+

1330+deleteFrom

1331+ :: HasTable table schema columns

1332+ => Alias table

1333+ -> Condition params '[table ::: columns] 'Ungrouped

1334+ -> Manipulation schema params '[]

1335+deleteFrom table wh = UnsafeManipulation $

1336+ "DELETE FROM" <+> renderAlias table

1337+ <+> "WHERE" <+> renderExpression wh <> ";"

1338+

1339+{-----------------------------------------

1340+render helper functions

1341+-----------------------------------------}

1342+

1343+parenthesized :: ByteString -> ByteString

1344+parenthesized str = "(" <> str <> ")"

1345+

1346+(<+>) :: ByteString -> ByteString -> ByteString

1347+str1 <+> str2 = str1 <> " " <> str2

1348+

1349+commaSeparated :: [ByteString] -> ByteString

1350+commaSeparated = ByteString.intercalate ", "

1351+

1352+renderCommaSeparated

1353+ :: SListI xs

1354+ => (forall x. expression x -> ByteString)

1355+ -> NP expression xs -> ByteString

1356+renderCommaSeparated render

1357+ = commaSeparated

1358+ . hcollapse

1359+ . hmap (K . render)

1360+

1361+renderCommaSeparatedMaybe

1362+ :: SListI xs

1363+ => (forall x. expression x -> Maybe ByteString)

1364+ -> NP expression xs -> ByteString

1365+renderCommaSeparatedMaybe render

1366+ = commaSeparated

1367+ . catMaybes

1368+ . hcollapse

1369+ . hmap (K . render)

1370+

1371+renderNat :: KnownNat n => proxy n -> ByteString

1372+renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))

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.hs+1−136

@@ -1,136 +1 @@

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

1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

squeal-postgresql/test/Squeal/PostgreSQL/StatementSpec.hsnew file+330

@@ -0,0 +1,330 @@

1+{-# LANGUAGE

2+ DataKinds

3+ , MagicHash

4+ , OverloadedLabels

5+ , OverloadedStrings

6+ , TypeApplications

7+ , TypeOperators

8+#-}

10+module Squeal.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 Squeal.PostgreSQL.Statement

18+import Squeal.PostgreSQL.Schema

19+

20+spec :: Spec

21+spec = do

22+ let

23+ qry `queryRenders` str = queryStatement 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 (Returning Nil)

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) (Returning Nil)

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) Nothing)

145+ (Returning Nil)

146+ statement `manipulationRenders`

147+ "INSERT INTO table1 (col1, col2) VALUES (2, 4)\

148+ \ ON CONFLICT DO UPDATE\

149+ \ SET col1 = 2;"

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+ (Just (#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 (Returning Nil)

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+ OnDeleteCascade OnUpdateRestrict

273+ , unique (Column #email :* Nil)

274+ , check (#email /=* "")

275+ ]

276+ statement `definitionRenders`

277+ "CREATE TABLE users\

278+ \ (id serial, username text NOT NULL,\

279+ \ PRIMARY KEY (id));\

280+ \ \

281+ \CREATE TABLE emails\

282+ \ (id serial,\

283+ \ userid integer NOT NULL,\

284+ \ email text NOT NULL,\

285+ \ PRIMARY KEY (id),\

286+ \ FOREIGN KEY (userid) REFERENCES users (id)\

287+ \ ON DELETE CASCADE ON UPDATE RESTRICT,\

288+ \ UNIQUE (email),\

289+ \ CHECK ((email <> E'')));"

290+ it "should render DROP TABLE statements" $ do

291+ let

292+ statement :: Definition Tables '[]

293+ statement = dropTable #table1

294+ statement `definitionRenders` "DROP TABLE table1;"

295+

296+type Columns =

297+ '[ "col1" ::: 'Required ('NotNull 'PGint4)

298+ , "col2" ::: 'Required ('NotNull 'PGint4)

299+ ]

300+type Tables = '[ "table1" ::: Columns ]

301+type SumAndCol1 =

302+ '[ "sum" ::: 'Required ('NotNull 'PGint4)

303+ , "col1" ::: 'Required ('NotNull 'PGint4)

304+ ]

305+type StudentsColumns = '["name" ::: 'Required ('NotNull 'PGtext)]

306+type StudentsTable = '["students" ::: StudentsColumns]

307+type OrderColumns =

308+ '[ "orderID" ::: 'Required ('NotNull 'PGint4)

309+ , "orderVal" ::: 'Required ('NotNull 'PGtext)

310+ , "customerID" ::: 'Required ('NotNull 'PGint4)

311+ , "shipperID" ::: 'Required ('NotNull 'PGint4)

312+ ]

313+type CustomerColumns =

314+ '[ "customerID" ::: 'Required ('NotNull 'PGint4)

315+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)

316+ ]

317+type ShipperColumns =

318+ '[ "shipperID" ::: 'Required ('NotNull 'PGint4)

319+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)

320+ ]

321+type JoinTables =

322+ '[ "orders" ::: OrderColumns

323+ , "customers" ::: CustomerColumns

324+ , "shippers" ::: ShipperColumns

325+ ]

326+type ValueColumns =

327+ '[ "orderVal" ::: 'Required ('NotNull 'PGtext)

328+ , "customerVal" ::: 'Required ('NotNull 'PGfloat4)

329+ , "shipperVal" ::: 'Required ('NotNull 'PGbool)

330+ ]

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.

stack.yaml+1−6

@@ -1,8 +1,3 @@

1−resolver: nightly-2019-07-14

1+resolver: nightly-2017-08-15

22packages:

33- squeal-postgresql

4−

5−extra-deps:

6−- unliftio-pool-0.2.1.0

7−- github: morphismtech/free-categories

8− commit: c0e555fbefb5c21619e532264c4dfeac556d0630