dev..8d08fc1 · squeal · git.iko.soy

git.iko.soy/squeal

48 files changed+2322−4311

unifiedsplit

.circleci/config.yml+1−1

@@ -2,7 +2,7 @@ version: 2

22jobs:

33 build:

44 docker:

5− - image: haskell:8.6.5

5+ - image: haskell:8.6.3

66 - image: circleci/postgres:latest

77 environment:

88 POSTGRES_USER: root

README.md+70−59

@@ -46,11 +46,7 @@ composable and cover a large portion of SQL.

4646* transactions

4747* views

4848* array, composite and enumerated types

49−* json functions and operations

50−* multischema support

51−* correlated subqueries

52−* window functions

53−* text search

49+* json operations

5450

5551## installation

5652

@@ -76,17 +72,19 @@ First, we need some language extensions because Squeal uses modern GHC

7672features.

7773

7874```Haskell

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

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

75+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels

76+>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators

8177```

8278

8379We'll need some imports.

8480

8581```Haskell

82+>>> import Control.Monad (void)

8683>>> import Control.Monad.IO.Class (liftIO)

8784>>> import Data.Int (Int32)

8885>>> import Data.Text (Text)

8986>>> import Squeal.PostgreSQL

87+>>> import Squeal.PostgreSQL.Render

9088```

9189

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

@@ -101,27 +99,27 @@ we use `DataKinds` and `TypeOperators`.

10199

102100```Haskell

103101>>> :{

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"] ]

115102type Schema =

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

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

118−type Schemas = Public Schema

103+ '[ "users" ::: 'Table (

104+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

105+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4

106+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext

107+ ])

108+ , "emails" ::: 'Table (

109+ '[ "pk_emails" ::: 'PrimaryKey '["id"]

110+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]

111+ ] :=>

112+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4

113+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4

114+ , "email" ::: 'NoDef :=> 'Null 'PGtext

115+ ])

116+ ]

119117:}

120118```

121119

122120Notice the use of type operators.

123121

124−`:::` is used to pair an alias `Symbol` with a `SchemumType`,

122+`:::` is used to pair an alias `GHC.TypeLits.Symbol` with a `SchemumType`,

125123a `TableConstraint` or a `ColumnType`. It is intended to connote Haskell's `::`

126124operator.

127125

@@ -139,7 +137,7 @@ labels to refer to named tables and columns in our schema.

139137```Haskell

140138>>> :{

141139let

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

140+ setup :: Definition '[] Schema

143141 setup =

144142 createTable #users

145143 ( serial `as` #id :*

@@ -171,7 +169,7 @@ primary and foreign keys, making them somewhat complex. Our `teardown`

171169```Haskell

172170>>> :{

173171let

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

172+ teardown :: Definition Schema '[]

175173 teardown = dropTable #emails >>> dropTable #users

176174:}

177175

@@ -180,54 +178,54 @@ DROP TABLE "emails";

180178DROP TABLE "users";

181179```

182180

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

181+Next, we'll write `Manipulation`s to insert data into our two tables.

182+A `Manipulation` like `insertRow`, `update` or `deleteFrom`

183+has three type parameters, the schema it refers to, a list of parameters

184+it can take as input, and a list of columns it produces as output. When

196185we insert into the users table, we will need a parameter for the `name`

197186field but not for the `id` field. Since it's serial, we can use a default

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

199188need 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.

189+the emails table. Take a careful look at the type and definition of both

190+of our inserts.

202191

203192```Haskell

204193>>> :{

205194let

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

195+ insertUser :: Manipulation Schema '[ 'NotNull 'PGtext ] '[ "fromOnly" ::: 'NotNull 'PGint4 ]

196+ insertUser = insertRow #users

197+ (Default `as` #id :* Set (param @1) `as` #name)

198+ OnConflictDoNothing (Returning (#id `as` #fromOnly))

199+:}

200+

201+>>> :{

202+let

203+ insertEmail :: Manipulation Schema '[ 'NotNull 'PGint4, 'Null 'PGtext] '[]

204+ insertEmail = insertRow #emails

205+ ( Default `as` #id :*

206+ Set (param @1) `as` #user_id :*

207+ Set (param @2) `as` #email )

208+ OnConflictDoNothing (Returning Nil)

215209:}

216210

217211>>> 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"

212+INSERT INTO "users" ("id", "name") VALUES (DEFAULT, ($1 :: text)) ON CONFLICT DO NOTHING RETURNING "id" AS "fromOnly"

213+>>> printSQL insertEmail

214+INSERT INTO "emails" ("id", "user_id", "email") VALUES (DEFAULT, ($1 :: int4), ($2 :: text)) ON CONFLICT DO NOTHING

219215```

220216

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

217+Next we write a `Query` to retrieve users from the database. We're not

222218interested 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.

219+need to use an inner join to get the right result. A `Query` is like a

220+`Manipulation` with the same kind of type parameters.

225221

226222```Haskell

227223>>> :{

228224let

229− getUsers :: Query_ Schemas () User

230− getUsers = select_

225+ getUsers :: Query Schema '[]

226+ '[ "userName" ::: 'NotNull 'PGtext

227+ , "userEmail" ::: 'Null 'PGtext ]

228+ getUsers = select

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

232230 ( from (table (#users `as` #u)

233231 & innerJoin (table (#emails `as` #e))

@@ -238,7 +236,19 @@ let

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

239237```

240238

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

239+Now that we've defined the SQL side of things, we'll need a Haskell type

240+for users. We give the type `Generics.SOP.Generic` and

241+`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows

242+we receive when we run `getUsers`. Notice that the record fields of the

243+`User` type match the column names of `getUsers`.

244+

245+```Haskell

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

247+>>> instance SOP.Generic User

248+>>> instance SOP.HasDatatypeInfo User

249+```

250+

251+Let's also create some users to add to the database.

242252

243253```Haskell

244254>>> :{

@@ -263,18 +273,19 @@ transformer and when the schema doesn't change we can use `Monad` and

263273```Haskell

264274>>> :{

265275let

266− session :: PQ Schemas Schemas IO ()

276+ session :: PQ Schema Schema IO ()

267277 session = do

268− _ <- traversePrepared_ insertUser users

278+ idResults <- traversePrepared insertUser (Only . userName <$> users)

279+ ids <- traverse (fmap fromOnly . getRow 0) idResults

280+ traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))

269281 usersResult <- runQuery getUsers

270282 usersRows <- getRows usersResult

271283 liftIO $ print (usersRows :: [User])

272284in

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

285+ void . withConnection "host=localhost port=5432 dbname=exampledb" $

274286 define setup

275287 & pqThen session

276288 & pqThen (define teardown)

277289:}

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

279−-}

280291```

RELEASE NOTES.md−400

@@ -1,405 +1,5 @@

11## RELEASE NOTES

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−

4033### Version 0.4

4044

4055Version 0.4 strengthens Squeal's type system, adds

squeal-postgresql/exe/Example.hs+7−9

@@ -11,6 +11,7 @@

1111

1212module Main (main, main2) where

1313

14+import Control.Monad (void)

1415import Control.Monad.IO.Class (MonadIO (..))

1516import Data.Int (Int16, Int32)

1617import Data.Monoid ((<>))

@@ -38,7 +39,6 @@ type Schema =

3839 , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4

3940 , "email" ::: 'NoDef :=> 'Null 'PGtext

4041 ])

41− , "positive" ::: 'Typedef 'PGfloat4

4242 ]

4343

4444type Schemas = Public Schema

@@ -53,25 +53,23 @@ setup =

5353 >>>

5454 createTable #emails

5555 ( serial `as` #id :*

56− hask @Int32 `as` #user_id :*

57− hask @(Maybe Text) `as` #email )

56+ (int & notNullable) `as` #user_id :*

57+ (text & nullable) `as` #email )

5858 ( primaryKey #id `as` #pk_emails :*

5959 foreignKey #user_id #users #id

6060 OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

61− >>>

62− createDomain #positive real (#value .> 0 .&& (#value & isNotNull))

6361

6462teardown :: Definition Schemas (Public '[])

65−teardown = dropType #positive >>> dropTable #emails >>> dropTable #users

63+teardown = dropTable #emails >>> dropTable #users

6664

6765insertUser :: Manipulation_ Schemas (Text, VarArray (Vector (Maybe Int16))) (Only Int32)

6866insertUser = insertInto #users

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

67+ (Values_ (defaultAs #id :* param @1 `as` #name :* param @2 `as` #vec))

7068 (OnConflict (OnConstraint #pk_users) DoNothing) (Returning_ (#id `as` #fromOnly))

7169

7270insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()

7371insertEmail = insertInto_ #emails

74− (Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email))

72+ (Values_ (defaultAs #id :* param @1 `as` #user_id :* param @2 `as` #email))

7573

7674getUsers :: Query_ Schemas () User

7775getUsers = select_

@@ -119,7 +117,7 @@ main = do

119117

120118main2 :: IO ()

121119main2 =

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

120+ void . withConnection "host=localhost port=5432 dbname=exampledb" $

123121 define setup

124122 & pqThen session

125123 & pqThen (define teardown)

squeal-postgresql/squeal-postgresql.cabal+13−38

@@ -1,5 +1,5 @@

11name: squeal-postgresql

2−version: 0.5.1.0

2+version: 0.4.9.0

33synopsis: Squeal PostgreSQL Library

44description: Squeal is a type-safe embedding of PostgreSQL in Haskell

55homepage: https://github.com/morphismtech/squeal

@@ -25,13 +25,6 @@ library

2525 Squeal.PostgreSQL.Alias

2626 Squeal.PostgreSQL.Binary

2727 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

3528 Squeal.PostgreSQL.Expression

3629 Squeal.PostgreSQL.Expression.Aggregate

3730 Squeal.PostgreSQL.Expression.Collection

@@ -42,8 +35,7 @@ library

4235 Squeal.PostgreSQL.Expression.Math

4336 Squeal.PostgreSQL.Expression.Null

4437 Squeal.PostgreSQL.Expression.Parameter

45− Squeal.PostgreSQL.Expression.Range

46− Squeal.PostgreSQL.Expression.Set

38+ Squeal.PostgreSQL.Expression.SetOf

4739 Squeal.PostgreSQL.Expression.Sort

4840 Squeal.PostgreSQL.Expression.Subquery

4941 Squeal.PostgreSQL.Expression.Text

@@ -62,7 +54,7 @@ library

6254 Squeal.PostgreSQL.Schema

6355 Squeal.PostgreSQL.Transaction

6456 default-language: Haskell2010

65− ghc-options: -Wall

57+ ghc-options: -Wall -Werror

6658 build-depends:

6759 aeson >= 1.2.4.0

6860 , base >= 4.11.1.0 && < 5.0

@@ -70,8 +62,7 @@ library

7062 , bytestring >= 0.10.8.2

7163 , bytestring-strict-builder >= 0.4.5

7264 , deepseq >= 1.4.3.0

73− , free-categories >= 0.1.0.0

74− , generics-sop >= 0.3.2.0 && < 0.5.0.0

65+ , generics-sop >= 0.3.2.0

7566 , mmorph >= 1.1.1

7667 , mtl >= 2.2.2

7768 , network-ip >= 0.3.0.2

@@ -88,50 +79,34 @@ library

8879 , uuid-types >= 1.0.3

8980 , vector >= 0.12.0.1

9081

91−test-suite doctest

82+test-suite squeal-postgresql-doctest

9283 default-language: Haskell2010

9384 type: exitcode-stdio-1.0

9485 hs-source-dirs: test

9586 ghc-options: -Wall

96− main-is: Doc.hs

87+ main-is: DocTest.hs

9788 build-depends:

9889 base >= 4.10.0.0

9990 , doctest >= 0.11.4

100− , squeal-postgresql

101−

102−test-suite properties

103− default-language: Haskell2010

104− type: exitcode-stdio-1.0

105− hs-source-dirs: test

106− ghc-options: -Wall

107− main-is: Property.hs

108− build-depends:

109− base >= 4.10.0.0

110− , bytestring >= 0.10.8.2

111− , hedgehog >= 1.0

112− , mtl >= 2.2.2

113− , scientific >= 0.3.5.3

114− , squeal-postgresql

115− , time >= 1.8.0.2

11691

117−test-suite spec

92+test-suite squeal-postgresql-specs

11893 default-language: Haskell2010

11994 type: exitcode-stdio-1.0

120− hs-source-dirs: test

121− ghc-options: -Wall

122− main-is: Spec.hs

95+ hs-source-dirs: test/Specs

96+ ghc-options: -Wall -main-is Specs

97+ main-is: Specs.hs

98+ other-modules: ExceptionHandling

12399 build-depends:

124100 base >= 4.10.0.0

125− , async >= 2.2.2

126101 , bytestring >= 0.10.8.2

127102 , generics-sop >= 0.3.1.0

128103 , hspec >= 2.4.8

129− , mtl >= 2.2.2

130104 , squeal-postgresql

131105 , text >= 1.2.2.2

106+ , transformers >= 0.5.2.0

132107 , vector >= 0.12.0.1

133108

134−executable example

109+executable squeal-postgresql-example

135110 default-language: Haskell2010

136111 hs-source-dirs: exe

137112 ghc-options: -Wall

squeal-postgresql/src/Squeal/PostgreSQL.hs+84−63

@@ -11,15 +11,17 @@ Let's see an example!

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

1212features.

1313

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

14+>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels

1515>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators -XGADTs

1616

1717We'll need some imports.

1818

19+>>> import Control.Monad (void)

1920>>> import Control.Monad.IO.Class (liftIO)

2021>>> import Data.Int (Int32)

2122>>> import Data.Text (Text)

2223>>> import Squeal.PostgreSQL

24+>>> import Squeal.PostgreSQL.Render

2325

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

2527

@@ -102,23 +104,25 @@ let

102104DROP TABLE "emails";

103105DROP TABLE "users";

104106

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

107+Next, we'll write `Manipulation`s to insert data into our two tables.

108+A `Manipulation` like `insertInto`, `update` or `deleteFrom`

109+has three type parameters, the schema it refers to, a list of parameters

110+it can take as input, and a list of columns it produces as output. When

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

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

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

119114need 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.

115+the emails table. Take a careful look at the type and definition of both

116+of our inserts.

117+

118+We'll need a Haskell type for users. We give the type `Generics.SOP.Generic` and

119+`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows

120+we receive when we run @getUsers@. Notice that the record fields of the

121+@User@ type match the column names of @getUsers@.

122+

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

124+>>> instance SOP.Generic User

125+>>> instance SOP.HasDatatypeInfo User

122126

123127>>> :{

124128let

@@ -126,20 +130,19 @@ let

126130 insertUser = with (u `as` #u) e

127131 where

128132 u = insertInto #users

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

133+ (Values_ (defaultAs #id :* param @1 `as` #name))

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

135+ e = insertInto_ #emails

136+ (Select (defaultAs #id :* #u ! #id `as` #user_id :* #u ! #email) (from (common #u)))

134137:}

135138

136139>>> printSQL insertUser

137140WITH "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"

138141

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

142+Next we write a `Query` to retrieve users from the database. We're not

140143interested 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.

144+need to use an inner join to get the right result. A `Query` is like a

145+`Manipulation` with the same kind of type parameters.

143146

144147>>> :{

145148let

@@ -183,51 +186,69 @@ let

183186 usersRows <- getRows usersResult

184187 liftIO $ print (usersRows :: [User])

185188in

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

189+ void . withConnection "host=localhost port=5432 dbname=exampledb" $

187190 define setup

188191 & pqThen session

189192 & pqThen (define teardown)

190193:}

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

192195-}

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

196+module Squeal.PostgreSQL

197+ ( module Squeal.PostgreSQL.Alias

198+ , module Squeal.PostgreSQL.Binary

199+ , module Squeal.PostgreSQL.Definition

200+ , module Squeal.PostgreSQL.Expression

201+ , module Squeal.PostgreSQL.Expression.Aggregate

202+ , module Squeal.PostgreSQL.Expression.Collection

203+ , module Squeal.PostgreSQL.Expression.Comparison

204+ , module Squeal.PostgreSQL.Expression.Json

205+ , module Squeal.PostgreSQL.Expression.Literal

206+ , module Squeal.PostgreSQL.Expression.Logic

207+ , module Squeal.PostgreSQL.Expression.Math

208+ , module Squeal.PostgreSQL.Expression.Null

209+ , module Squeal.PostgreSQL.Expression.Parameter

210+ , module Squeal.PostgreSQL.Expression.SetOf

211+ , module Squeal.PostgreSQL.Expression.Sort

212+ , module Squeal.PostgreSQL.Expression.Subquery

213+ , module Squeal.PostgreSQL.Expression.Text

214+ , module Squeal.PostgreSQL.Expression.TextSearch

215+ , module Squeal.PostgreSQL.Expression.Time

216+ , module Squeal.PostgreSQL.Expression.Type

217+ , module Squeal.PostgreSQL.Expression.Window

218+ , module Squeal.PostgreSQL.List

219+ , module Squeal.PostgreSQL.Manipulation

220+ , module Squeal.PostgreSQL.PG

221+ , module Squeal.PostgreSQL.PQ

222+ , module Squeal.PostgreSQL.Query

223+ , module Squeal.PostgreSQL.Schema

224+ , module Squeal.PostgreSQL.Transaction

225+ ) where

226+

227+import Squeal.PostgreSQL.Alias

228+import Squeal.PostgreSQL.Binary

229+import Squeal.PostgreSQL.Definition

230+import Squeal.PostgreSQL.Expression

231+import Squeal.PostgreSQL.Expression.Aggregate

232+import Squeal.PostgreSQL.Expression.Collection

233+import Squeal.PostgreSQL.Expression.Comparison

234+import Squeal.PostgreSQL.Expression.Json

235+import Squeal.PostgreSQL.Expression.Literal

236+import Squeal.PostgreSQL.Expression.Logic

237+import Squeal.PostgreSQL.Expression.Math

238+import Squeal.PostgreSQL.Expression.Null

239+import Squeal.PostgreSQL.Expression.Parameter

240+import Squeal.PostgreSQL.Expression.SetOf

241+import Squeal.PostgreSQL.Expression.Sort

242+import Squeal.PostgreSQL.Expression.Subquery

243+import Squeal.PostgreSQL.Expression.Text

244+import Squeal.PostgreSQL.Expression.TextSearch

245+import Squeal.PostgreSQL.Expression.Time

246+import Squeal.PostgreSQL.Expression.Type

247+import Squeal.PostgreSQL.Expression.Window

248+import Squeal.PostgreSQL.List

249+import Squeal.PostgreSQL.Manipulation

250+import Squeal.PostgreSQL.PG

251+import Squeal.PostgreSQL.PQ

252+import Squeal.PostgreSQL.Query

253+import Squeal.PostgreSQL.Schema

254+import Squeal.PostgreSQL.Transaction

squeal-postgresql/src/Squeal/PostgreSQL/Alias.hs+9

@@ -46,6 +46,7 @@ module Squeal.PostgreSQL.Alias

4646 , HasIn

4747 , QualifiedAlias (..)

4848 , IsQualified (..)

49+ , DefaultAliasable (..)

4950 -- * Grouping

5051 , Grouping (..)

5152 , GroupedBy

@@ -188,6 +189,14 @@ choose which subfields to update.

188189class HasIn fields field where

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

190191

192+{- |

193+The `DefaultAliasable` class is intended to help with Scrap your Nils

194+for default inserts and updates.

195+-}

196+class KnownSymbol alias

197+ => DefaultAliasable alias aliased | aliased -> alias where

198+ defaultAs :: Alias alias -> aliased

199+

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

192201-- a list of @subfields@.

193202class

squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+67−193

@@ -39,7 +39,7 @@ the input and output should be equal.

3939

4040>>> let input = Row 2 "hi" (Just True)

4141>>> :{

42−withConnection "host=localhost port=5432 dbname=exampledb" $ do

42+void . withConnection "host=localhost port=5432 dbname=exampledb" $ do

4343 result <- runQueryParams roundTrip input

4444 Just output <- firstRow result

4545 liftIO . print $ input == output

@@ -78,7 +78,7 @@ let

7878>>> :set -XOverloadedLists

7979>>> let input = Row (VarArray [1,2]) (FixArray (Just 1,Nothing)) (FixArray ((1,2),(3,4),(5,6)))

8080>>> :{

81−withConnection "host=localhost port=5432 dbname=exampledb" $ do

81+void . withConnection "host=localhost port=5432 dbname=exampledb" $ do

8282 result <- runQueryParams roundTrip input

8383 Just output <- firstRow result

8484 liftIO . print $ input == output

@@ -170,7 +170,7 @@ let

170170 Just output <- firstRow result

171171 liftIO . print $ input == output

172172in

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

173+ void . withConnection "host=localhost port=5432 dbname=exampledb" $

174174 define setup

175175 & pqThen session

176176 & pqThen (define teardown)

@@ -215,10 +215,6 @@ module Squeal.PostgreSQL.Binary

215215 , FromFixArray (..)

216216 -- * Only

217217 , Only (..)

218− -- * Oid

219− , OidOf (..)

220− , OidOfParam (..)

221− , OidOfField (..)

222218 ) where

223219

224220import BinaryParser

@@ -232,7 +228,6 @@ import Data.Time

232228import Data.UUID.Types

233229import Data.Vector (Vector)

234230import Data.Word

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

236231import Generics.SOP

237232import Generics.SOP.Record

238233import GHC.TypeLits

@@ -246,7 +241,6 @@ import qualified Data.Text.Lazy as Lazy (Text)

246241import qualified Data.Text as Strict (Text)

247242import qualified Data.Text as Strict.Text

248243import qualified Data.Vector as Vector

249−import qualified Database.PostgreSQL.LibPQ as LibPQ

250244import qualified GHC.Generics as GHC

251245import qualified PostgreSQL.Binary.Decoding as Decoding

252246import qualified PostgreSQL.Binary.Encoding as Encoding

@@ -277,9 +271,11 @@ class ToParam (x :: Type) (pg :: PGType) where

277271 toParam :: x -> K Encoding.Encoding pg

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

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

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

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

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

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

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

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

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

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

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

@@ -312,26 +308,24 @@ instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where

312308instance Aeson.ToJSON x => ToParam (Jsonb x) 'PGjsonb where

313309 toParam = K . Encoding.jsonb_bytes

314310 . Lazy.ByteString.toStrict . Aeson.encode . getJsonb

315−instance (ToNullityParam x ty, ty ~ nullity pg, OidOf pg)

311+instance (ToNullityParam x ty, ty ~ nullity pg, HasOid pg)

316312 => ToParam (VarArray [x]) ('PGvararray ty) where

317313 toParam = K

318− . Encoding.array_foldable

319− (getOid (oidOf @pg)) (unK . toNullityParam @x @ty)

314+ . Encoding.array_foldable (oid @pg) (unK . toNullityParam @x @ty)

320315 . getVarArray

321−instance (ToParam x pg, OidOf pg)

316+instance (ToParam x pg, HasOid pg)

322317 => ToParam (VarArray (Vector x)) ('PGvararray ('NotNull pg)) where

323318 toParam = K

324− . Encoding.array_vector (getOid (oidOf @pg)) (unK . toParam @x @pg)

319+ . Encoding.array_vector (oid @pg) (unK . toParam @x @pg)

325320 . getVarArray

326−instance (ToParam x pg, OidOf pg)

321+instance (ToParam x pg, HasOid pg)

327322 => ToParam (VarArray (Vector (Maybe x))) ('PGvararray ('Null pg)) where

328323 toParam = K

329− . Encoding.nullableArray_vector

330− (getOid (oidOf @pg)) (unK . toParam @x @pg)

324+ . Encoding.nullableArray_vector (oid @pg) (unK . toParam @x @pg)

331325 . getVarArray

332−instance (ToFixArray x dims ty, ty ~ nullity pg, OidOf pg)

326+instance (ToFixArray x dims ty, ty ~ nullity pg, HasOid pg)

333327 => ToParam (FixArray x) ('PGfixarray dims ty) where

334− toParam = K . Encoding.array (getOid (oidOf @pg))

328+ toParam = K . Encoding.array (oid @pg)

335329 . unK . unK . toFixArray @x @dims @ty . getFixArray

336330instance

337331 ( IsEnumType x

@@ -356,7 +350,7 @@ instance

356350 ( SListI fields

357351 , IsRecord x xs

358352 , AllZip ToField xs fields

359− , All OidOfField fields

353+ , All HasAliasedOid fields

360354 ) => ToParam (Composite x) ('PGcomposite fields) where

361355 toParam =

362356 let

@@ -364,7 +358,7 @@ instance

364358 encoders = htrans (Proxy @ToField) toField

365359

366360 composite

367− :: All OidOfField row

361+ :: All HasAliasedOid row

368362 => NP (K (Maybe Encoding.Encoding)) row

369363 -> K Encoding.Encoding ('PGcomposite row)

370364 composite fields = K $

@@ -381,139 +375,26 @@ instance

381375 int32BE (fromIntegral (lengthSList (Proxy @xs))) <>

382376 let

383377 each

384− :: OidOfField field

378+ :: HasAliasedOid field

385379 => K (Maybe Encoding.Encoding) field

386380 -> Encoding.Encoding

387381 each (K field :: K (Maybe Encoding.Encoding) field) =

388− word32BE (getOid (oidOfField @field))

382+ word32BE (aliasedOid @field)

389383 <> case field of

390384 Nothing -> int64BE (-1)

391385 Just value ->

392386 int32BE (fromIntegral (builderLength value))

393387 <> value

394388 in

395− hcfoldMap (Proxy @OidOfField) each fields

389+ hcfoldMap (Proxy @HasAliasedOid) each fields

396390

397391 in

398392 composite . encoders . toRecord . getComposite

399393

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

394+class HasAliasedOid (field :: (Symbol, NullityType)) where

395+ aliasedOid :: Word32

396+instance HasOid ty => HasAliasedOid (alias ::: nullity ty) where

397+ aliasedOid = oid @ty

517398

518399-- | A `ToNullityParam` constraint gives an encoding of a Haskell `Type` into

519400-- into the binary format of a PostgreSQL `NullityType`.

@@ -582,7 +463,6 @@ instance FromValue 'PGbool Bool where fromValue = Decoding.bool

582463instance FromValue 'PGint2 Int16 where fromValue = Decoding.int

583464instance FromValue 'PGint4 Int32 where fromValue = Decoding.int

584465instance FromValue 'PGint8 Int64 where fromValue = Decoding.int

585−instance FromValue 'PGoid Word32 where fromValue = Decoding.int

586466instance FromValue 'PGfloat4 Float where fromValue = Decoding.float4

587467instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8

588468instance FromValue 'PGnumeric Scientific where fromValue = Decoding.numeric

@@ -769,53 +649,50 @@ instance

769649 = fmap fromRecord

770650 . hsequence'

771651 . 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)

652+instance (FromField (col ::: pg) (col ::: hask))

653+ => FromRow '[col ::: pg] (P (col ::: hask)) where

654+ fromRow (pg :* Nil) = (unComp . fromField) pg

655+instance

656+ ( row ~ Join row1 row2

657+ , FromRow row1 hask1

658+ , FromRow row2 hask2

659+ , SListI row

660+ ) => FromRow row (hask1, hask2) where

661+ fromRow row = case disjoin @row1 @row2 row of

662+ (row1, row2) -> (,) <$> fromRow row1 <*> fromRow row2

663+instance

664+ ( row ~ Join row1 row23

665+ , FromRow row1 hask1

666+ , FromRow row23 (hask2, hask3)

667+ , SListI row

668+ ) => FromRow row (hask1, hask2, hask3) where

669+ fromRow row = case disjoin @row1 @row23 row of

670+ (row1, row23) -> do

671+ hask1 <- fromRow row1

672+ (hask2, hask3) <- fromRow row23

673+ return (hask1, hask2, hask3)

674+instance

675+ ( row ~ Join row1 row234

676+ , FromRow row1 hask1

677+ , FromRow row234 (hask2, hask3, hask4)

678+ , SListI row

679+ ) => FromRow row (hask1, hask2, hask3, hask4) where

680+ fromRow row = case disjoin @row1 @row234 row of

681+ (row1, row234) -> do

682+ hask1 <- fromRow row1

683+ (hask2, hask3, hask4) <- fromRow row234

684+ return (hask1, hask2, hask3, hask4)

685+instance

686+ ( row ~ Join row1 row2345

687+ , FromRow row1 hask1

688+ , FromRow row2345 (hask2, hask3, hask4, hask5)

689+ , SListI row

690+ ) => FromRow row (hask1, hask2, hask3, hask4, hask5) where

691+ fromRow row = case disjoin @row1 @row2345 row of

692+ (row1, row2345) -> do

693+ hask1 <- fromRow row1

694+ (hask2, hask3, hask4, hask5) <- fromRow row2345

695+ return (hask1, hask2, hask3, hask4, hask5)

819696

820697-- | `Only` is a 1-tuple type, useful for encoding a single parameter with

821698-- `toParams` or decoding a single value with `fromRow`.

@@ -843,6 +720,3 @@ replicateMN

843720 => m x -> m (NP I xs)

844721replicateMN mx = hsequence' $

845722 hcpure (Proxy :: Proxy ((~) x)) (Comp (I <$> mx))

846−

847−getOid :: LibPQ.Oid -> Word32

848−getOid (LibPQ.Oid (CUInt oid)) = oid

squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+1016−12

@@ -11,15 +11,13 @@ Squeal data definition language.

1111{-# LANGUAGE

1212 AllowAmbiguousTypes

1313 , ConstraintKinds

14− , DeriveAnyClass

1514 , DeriveGeneric

16− , DerivingStrategies

1715 , FlexibleContexts

1816 , FlexibleInstances

1917 , GADTs

18+ , GeneralizedNewtypeDeriving

2019 , LambdaCase

2120 , MultiParamTypeClasses

22− , OverloadedLabels

2321 , OverloadedStrings

2422 , RankNTypes

2523 , ScopedTypeVariables

@@ -27,25 +25,83 @@ Squeal data definition language.

2725 , TypeInType

2826 , TypeOperators

2927 , UndecidableSuperClasses

30− , UndecidableInstances

3128#-}

3229

3330module Squeal.PostgreSQL.Definition

3431 ( -- * Definition

3532 Definition (..)

3633 , (>>>)

37− , manipDefinition

34+ -- * Tables

35+ -- ** Create

36+ , createSchema

37+ , createSchemaIfNotExists

38+ , createTable

39+ , createTableIfNotExists

40+ , createView

41+ , createTypeEnum

42+ , createTypeEnumFrom

43+ , createTypeComposite

44+ , createTypeCompositeFrom

45+ , createDomain

46+ , TableConstraintExpression (..)

47+ , check

48+ , unique

49+ , primaryKey

50+ , foreignKey

51+ , ForeignKeyed

52+ , OnDeleteClause (..)

53+ , OnUpdateClause (..)

54+ -- ** Drop

55+ , dropSchema

56+ , dropTable

57+ , dropView

58+ , dropType

59+ -- ** Alter

60+ , alterTable

61+ , alterTableRename

62+ , AlterTable (..)

63+ , addConstraint

64+ , dropConstraint

65+ , AddColumn (..)

66+ , dropColumn

67+ , renameColumn

68+ , alterColumn

69+ , AlterColumn (..)

70+ , setDefault

71+ , dropDefault

72+ , setNotNull

73+ , dropNotNull

74+ , alterType

75+ -- * Columns

76+ , ColumnTypeExpression (..)

77+ , nullable

78+ , notNullable

79+ , default_

80+ , serial2

81+ , smallserial

82+ , serial4

83+ , serial

84+ , serial8

85+ , bigserial

3886 ) where

3987

4088import Control.Category

4189import Control.DeepSeq

4290import Data.ByteString

4391import Data.Monoid

92+import GHC.TypeLits

4493import Prelude hiding ((.), id)

4594

95+import qualified Generics.SOP as SOP

4696import qualified GHC.Generics as GHC

4797

48−import Squeal.PostgreSQL.Manipulation

98+import Squeal.PostgreSQL.Alias

99+import Squeal.PostgreSQL.Expression

100+import Squeal.PostgreSQL.Expression.Logic

101+import Squeal.PostgreSQL.Expression.Type

102+import Squeal.PostgreSQL.List

103+import Squeal.PostgreSQL.PG

104+import Squeal.PostgreSQL.Query

49105import Squeal.PostgreSQL.Render

50106import Squeal.PostgreSQL.Schema

51107

@@ -73,10 +129,958 @@ instance Category Definition where

73129 ddl1 . ddl0 = UnsafeDefinition $

74130 renderSQL ddl0 <> "\n" <> renderSQL ddl1

75131

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

132+{-----------------------------------------

133+CREATE statements

134+-----------------------------------------}

135+

136+createSchema

137+ :: KnownSymbol sch

138+ => Alias sch

139+ -> Definition schemas (Create sch '[] schemas)

140+createSchema sch = UnsafeDefinition $

141+ "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"

142+

143+createSchemaIfNotExists

144+ :: (KnownSymbol sch, Has sch schemas schema)

145+ => Alias sch

81146 -> Definition schemas schemas

82−manipDefinition = UnsafeDefinition . (<> ";") . renderSQL

147+createSchemaIfNotExists sch = UnsafeDefinition $

148+ "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"

149+ <+> renderSQL sch <> ";"

150+

151+{- | `createTable` adds a table to the schema.

152+

153+>>> :set -XOverloadedLabels

154+>>> :{

155+type Table = '[] :=>

156+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4

157+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]

158+:}

159+

160+>>> :{

161+let

162+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])

163+ setup = createTable #tab

164+ (nullable int `as` #a :* nullable real `as` #b) Nil

165+in printSQL setup

166+:}

167+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);

168+-}

169+createTable

170+ :: ( KnownSymbol sch

171+ , KnownSymbol tab

172+ , columns ~ (col ': cols)

173+ , SOP.SListI columns

174+ , SOP.SListI constraints

175+ , Has sch schemas0 schema0

176+ , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )

177+ => QualifiedAlias sch tab -- ^ the name of the table to add

178+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns

179+ -- ^ the names and datatype of each column

180+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints

181+ -- ^ constraints that must hold for the table

182+ -> Definition schemas0 schemas1

183+createTable tab columns constraints = UnsafeDefinition $

184+ "CREATE TABLE" <+> renderCreation tab columns constraints

185+

186+{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.

187+Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.

188+`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in

189+the `Category` of `Definition`s.

190+

191+>>> :set -XOverloadedLabels -XTypeApplications

192+>>> :{

193+type Table = '[] :=>

194+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4

195+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]

196+:}

197+

198+>>> type Schemas = Public '["tab" ::: 'Table Table]

199+

200+>>> :{

201+let

202+ setup :: Definition Schemas Schemas

203+ setup = createTableIfNotExists #tab

204+ (nullable int `as` #a :* nullable real `as` #b) Nil

205+in printSQL setup

206+:}

207+CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);

208+-}

209+createTableIfNotExists

210+ :: ( Has sch schemas schema

211+ , Has tab schema ('Table (constraints :=> columns))

212+ , SOP.SListI columns

213+ , SOP.SListI constraints )

214+ => QualifiedAlias sch tab -- ^ the name of the table to add

215+ -> NP (Aliased (ColumnTypeExpression schemas)) columns

216+ -- ^ the names and datatype of each column

217+ -> NP (Aliased (TableConstraintExpression sch tab schemas)) constraints

218+ -- ^ constraints that must hold for the table

219+ -> Definition schemas schemas

220+createTableIfNotExists tab columns constraints = UnsafeDefinition $

221+ "CREATE TABLE IF NOT EXISTS"

222+ <+> renderCreation tab columns constraints

223+

224+-- helper function for `createTable` and `createTableIfNotExists`

225+renderCreation

226+ :: ( KnownSymbol sch

227+ , KnownSymbol tab

228+ , SOP.SListI columns

229+ , SOP.SListI constraints )

230+ => QualifiedAlias sch tab -- ^ the name of the table to add

231+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns

232+ -- ^ the names and datatype of each column

233+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints

234+ -- ^ constraints that must hold for the table

235+ -> ByteString

236+renderCreation tab columns constraints = renderSQL tab

237+ <+> parenthesized

238+ ( renderCommaSeparated renderColumnDef columns

239+ <> ( case constraints of

240+ Nil -> ""

241+ _ -> ", " <>

242+ renderCommaSeparated renderConstraint constraints ) )

243+ <> ";"

244+ where

245+ renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString

246+ renderColumnDef (ty `As` column) =

247+ renderSQL column <+> renderColumnTypeExpression ty

248+ renderConstraint

249+ :: Aliased (TableConstraintExpression sch tab schemas) constraint

250+ -> ByteString

251+ renderConstraint (constraint `As` alias) =

252+ "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint

253+

254+-- | Data types are a way to limit the kind of data that can be stored in a

255+-- table. For many applications, however, the constraint they provide is

256+-- too coarse. For example, a column containing a product price should

257+-- probably only accept positive values. But there is no standard data type

258+-- that accepts only positive numbers. Another issue is that you might want

259+-- to constrain column data with respect to other columns or rows.

260+-- For example, in a table containing product information,

261+-- there should be only one row for each product number.

262+-- `TableConstraint`s give you as much control over the data in your tables

263+-- as you wish. If a user attempts to store data in a column that would

264+-- violate a constraint, an error is raised. This applies

265+-- even if the value came from the default value definition.

266+newtype TableConstraintExpression

267+ (sch :: Symbol)

268+ (tab :: Symbol)

269+ (schemas :: SchemasType)

270+ (constraint :: TableConstraint)

271+ = UnsafeTableConstraintExpression

272+ { renderTableConstraintExpression :: ByteString }

273+ deriving (GHC.Generic,Show,Eq,Ord,NFData)

274+instance RenderSQL

275+ (TableConstraintExpression sch tab schemas constraint) where

276+ renderSQL = renderTableConstraintExpression

277+

278+{-| A `check` constraint is the most generic `TableConstraint` type.

279+It allows you to specify that the value in a certain column must satisfy

280+a Boolean (truth-value) expression.

281+

282+>>> :{

283+type Schema = '[

284+ "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[

285+ "a" ::: 'NoDef :=> 'NotNull 'PGint4,

286+ "b" ::: 'NoDef :=> 'NotNull 'PGint4

287+ ])]

288+:}

289+

290+>>> :{

291+let

292+ definition :: Definition (Public '[]) (Public Schema)

293+ definition = createTable #tab

294+ ( (int & notNullable) `as` #a :*

295+ (int & notNullable) `as` #b )

296+ ( check (#a :* #b) (#a .> #b) `as` #inequality )

297+:}

298+

299+>>> printSQL definition

300+CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));

301+-}

302+check

303+ :: ( Has sch schemas schema

304+ , Has tab schema ('Table table)

305+ , HasAll aliases (TableToRow table) subcolumns )

306+ => NP Alias aliases

307+ -- ^ specify the subcolumns which are getting checked

308+ -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])

309+ -- ^ a closed `Condition` on those subcolumns

310+ -> TableConstraintExpression sch tab schemas ('Check aliases)

311+check _cols condition = UnsafeTableConstraintExpression $

312+ "CHECK" <+> parenthesized (renderSQL condition)

313+

314+{-| A `unique` constraint ensure that the data contained in a column,

315+or a group of columns, is unique among all the rows in the table.

316+

317+>>> :{

318+type Schema = '[

319+ "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[

320+ "a" ::: 'NoDef :=> 'Null 'PGint4,

321+ "b" ::: 'NoDef :=> 'Null 'PGint4

322+ ])]

323+:}

324+

325+>>> :{

326+let

327+ definition :: Definition (Public '[]) (Public Schema)

328+ definition = createTable #tab

329+ ( (int & nullable) `as` #a :*

330+ (int & nullable) `as` #b )

331+ ( unique (#a :* #b) `as` #uq_a_b )

332+:}

333+

334+>>> printSQL definition

335+CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));

336+-}

337+unique

338+ :: ( Has sch schemas schema

339+ , Has tab schema('Table table)

340+ , HasAll aliases (TableToRow table) subcolumns )

341+ => NP Alias aliases

342+ -- ^ specify subcolumns which together are unique for each row

343+ -> TableConstraintExpression sch tab schemas ('Unique aliases)

344+unique columns = UnsafeTableConstraintExpression $

345+ "UNIQUE" <+> parenthesized (renderSQL columns)

346+

347+{-| A `primaryKey` constraint indicates that a column, or group of columns,

348+can be used as a unique identifier for rows in the table.

349+This requires that the values be both unique and not null.

350+

351+>>> :{

352+type Schema = '[

353+ "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[

354+ "id" ::: 'Def :=> 'NotNull 'PGint4,

355+ "name" ::: 'NoDef :=> 'NotNull 'PGtext

356+ ])]

357+:}

358+

359+>>> :{

360+let

361+ definition :: Definition (Public '[]) (Public Schema)

362+ definition = createTable #tab

363+ ( serial `as` #id :*

364+ (text & notNullable) `as` #name )

365+ ( primaryKey #id `as` #pk_id )

366+:}

367+

368+>>> printSQL definition

369+CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));

370+-}

371+primaryKey

372+ :: ( Has sch schemas schema

373+ , Has tab schema ('Table table)

374+ , HasAll aliases (TableToColumns table) subcolumns

375+ , AllNotNull subcolumns )

376+ => NP Alias aliases

377+ -- ^ specify the subcolumns which together form a primary key.

378+ -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)

379+primaryKey columns = UnsafeTableConstraintExpression $

380+ "PRIMARY KEY" <+> parenthesized (renderSQL columns)

381+

382+{-| A `foreignKey` specifies that the values in a column

383+(or a group of columns) must match the values appearing in some row of

384+another table. We say this maintains the referential integrity

385+between two related tables.

386+

387+>>> :{

388+type Schema =

389+ '[ "users" ::: 'Table (

390+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

391+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4

392+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext

393+ ])

394+ , "emails" ::: 'Table (

395+ '[ "pk_emails" ::: 'PrimaryKey '["id"]

396+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]

397+ ] :=>

398+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4

399+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4

400+ , "email" ::: 'NoDef :=> 'Null 'PGtext

401+ ])

402+ ]

403+:}

404+

405+>>> :{

406+let

407+ setup :: Definition (Public '[]) (Public Schema)

408+ setup =

409+ createTable #users

410+ ( serial `as` #id :*

411+ (text & notNullable) `as` #name )

412+ ( primaryKey #id `as` #pk_users ) >>>

413+ createTable #emails

414+ ( serial `as` #id :*

415+ (int & notNullable) `as` #user_id :*

416+ (text & nullable) `as` #email )

417+ ( primaryKey #id `as` #pk_emails :*

418+ foreignKey #user_id #users #id

419+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

420+in printSQL setup

421+:}

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

423+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);

424+

425+A `foreignKey` can even be a table self-reference.

426+

427+>>> :{

428+type Schema =

429+ '[ "employees" ::: 'Table (

430+ '[ "employees_pk" ::: 'PrimaryKey '["id"]

431+ , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]

432+ ] :=>

433+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4

434+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext

435+ , "employer_id" ::: 'NoDef :=> 'Null 'PGint4

436+ ])

437+ ]

438+:}

439+

440+>>> :{

441+let

442+ setup :: Definition (Public '[]) (Public Schema)

443+ setup =

444+ createTable #employees

445+ ( serial `as` #id :*

446+ (text & notNullable) `as` #name :*

447+ (integer & nullable) `as` #employer_id )

448+ ( primaryKey #id `as` #employees_pk :*

449+ foreignKey #employer_id #employees #id

450+ OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )

451+in printSQL setup

452+:}

453+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);

454+-}

455+foreignKey

456+ :: (ForeignKeyed schemas sch schema child parent

457+ table reftable

458+ columns refcolumns

459+ constraints cols

460+ reftys tys )

461+ => NP Alias columns

462+ -- ^ column or columns in the table

463+ -> Alias parent

464+ -- ^ reference table

465+ -> NP Alias refcolumns

466+ -- ^ reference column or columns in the reference table

467+ -> OnDeleteClause

468+ -- ^ what to do when reference is deleted

469+ -> OnUpdateClause

470+ -- ^ what to do when reference is updated

471+ -> TableConstraintExpression sch child schemas

472+ ('ForeignKey columns parent refcolumns)

473+foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $

474+ "FOREIGN KEY" <+> parenthesized (renderSQL keys)

475+ <+> "REFERENCES" <+> renderSQL parent

476+ <+> parenthesized (renderSQL refs)

477+ <+> renderSQL ondel

478+ <+> renderSQL onupd

479+

480+-- | A constraint synonym between types involved in a foreign key constraint.

481+type ForeignKeyed schemas

482+ sch

483+ schema

484+ child parent

485+ table reftable

486+ columns refcolumns

487+ constraints cols

488+ reftys tys =

489+ ( Has sch schemas schema

490+ , Has child schema ('Table table)

491+ , Has parent schema ('Table reftable)

492+ , HasAll columns (TableToColumns table) tys

493+ , reftable ~ (constraints :=> cols)

494+ , HasAll refcolumns cols reftys

495+ , SOP.AllZip SamePGType tys reftys

496+ , Uniquely refcolumns constraints )

497+

498+-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.

499+data OnDeleteClause

500+ = OnDeleteNoAction

501+ -- ^ if any referencing rows still exist when the constraint is checked,

502+ -- an error is raised

503+ | OnDeleteRestrict -- ^ prevents deletion of a referenced row

504+ | OnDeleteCascade

505+ -- ^ specifies that when a referenced row is deleted,

506+ -- row(s) referencing it should be automatically deleted as well

507+ deriving (GHC.Generic,Show,Eq,Ord)

508+instance NFData OnDeleteClause

509+-- | Render `OnDeleteClause`.

510+instance RenderSQL OnDeleteClause where

511+ renderSQL = \case

512+ OnDeleteNoAction -> "ON DELETE NO ACTION"

513+ OnDeleteRestrict -> "ON DELETE RESTRICT"

514+ OnDeleteCascade -> "ON DELETE CASCADE"

515+

516+-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked

517+-- when a referenced column is changed (updated).

518+data OnUpdateClause

519+ = OnUpdateNoAction

520+ -- ^ if any referencing rows has not changed when the constraint is checked,

521+ -- an error is raised

522+ | OnUpdateRestrict -- ^ prevents update of a referenced row

523+ | OnUpdateCascade

524+ -- ^ the updated values of the referenced column(s) should be copied

525+ -- into the referencing row(s)

526+ deriving (GHC.Generic,Show,Eq,Ord)

527+instance NFData OnUpdateClause

528+

529+-- | Render `OnUpdateClause`.

530+instance RenderSQL OnUpdateClause where

531+ renderSQL = \case

532+ OnUpdateNoAction -> "ON UPDATE NO ACTION"

533+ OnUpdateRestrict -> "ON UPDATE RESTRICT"

534+ OnUpdateCascade -> "ON UPDATE CASCADE"

535+

536+{-----------------------------------------

537+DROP statements

538+-----------------------------------------}

539+

540+-- >>> :{

541+-- let

542+-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]

543+-- definition = dropSchema #muh_schema

544+-- :}

545+--

546+-- >>> printSQL definition

547+-- DROP SCHEMA "muh_schema";

548+dropSchema

549+ :: Has sch schemas schema

550+ => Alias sch

551+ -> Definition schemas (Drop sch schemas)

552+dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"

553+

554+-- | `dropTable` removes a table from the schema.

555+--

556+-- >>> :{

557+-- let

558+-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])

559+-- definition = dropTable #muh_table

560+-- :}

561+--

562+-- >>> printSQL definition

563+-- DROP TABLE "muh_table";

564+dropTable

565+ :: ( Has sch schemas schema

566+ , Has tab schema ('Table table))

567+ => QualifiedAlias sch tab -- ^ table to remove

568+ -> Definition schemas (Alter sch (Drop tab schema) schemas)

569+dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"

570+

571+{-----------------------------------------

572+ALTER statements

573+-----------------------------------------}

574+

575+-- | `alterTable` changes the definition of a table from the schema.

576+alterTable

577+ :: (Has sch schemas schema, Has tab schema ('Table table0))

578+ => QualifiedAlias sch tab -- ^ table to alter

579+ -> AlterTable sch tab schemas table1 -- ^ alteration to perform

580+ -> Definition schemas (Alter sch (Alter tab ('Table table1) schema) schemas)

581+alterTable tab alteration = UnsafeDefinition $

582+ "ALTER TABLE"

583+ <+> renderSQL tab

584+ <+> renderAlterTable alteration

585+ <> ";"

586+

587+-- | `alterTableRename` changes the name of a table from the schema.

588+--

589+-- >>> printSQL $ alterTableRename #foo #bar

590+-- ALTER TABLE "foo" RENAME TO "bar";

591+alterTableRename

592+ :: (KnownSymbol table0, KnownSymbol table1)

593+ => Alias table0 -- ^ table to rename

594+ -> Alias table1 -- ^ what to rename it

595+ -> Definition schema (Rename table0 table1 schema)

596+alterTableRename table0 table1 = UnsafeDefinition $

597+ "ALTER TABLE" <+> renderSQL table0

598+ <+> "RENAME TO" <+> renderSQL table1 <> ";"

599+

600+-- | An `AlterTable` describes the alteration to perform on the columns

601+-- of a table.

602+newtype AlterTable

603+ (sch :: Symbol)

604+ (tab :: Symbol)

605+ (schemas :: SchemasType)

606+ (table :: TableType) =

607+ UnsafeAlterTable {renderAlterTable :: ByteString}

608+ deriving (GHC.Generic,Show,Eq,Ord,NFData)

609+

610+-- | An `addConstraint` adds a table constraint.

611+--

612+-- >>> :{

613+-- let

614+-- definition :: Definition

615+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

616+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

617+-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))

618+-- in printSQL definition

619+-- :}

620+-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));

621+addConstraint

622+ :: ( KnownSymbol alias

623+ , Has sch schemas schema

624+ , Has tab schema ('Table table0)

625+ , table0 ~ (constraints :=> columns)

626+ , table1 ~ (Create alias constraint constraints :=> columns) )

627+ => Alias alias

628+ -> TableConstraintExpression sch tab schemas constraint

629+ -- ^ constraint to add

630+ -> AlterTable sch tab schemas table1

631+addConstraint alias constraint = UnsafeAlterTable $

632+ "ADD" <+> "CONSTRAINT" <+> renderSQL alias

633+ <+> renderSQL constraint

634+

635+-- | A `dropConstraint` drops a table constraint.

636+--

637+-- >>> :{

638+-- let

639+-- definition :: Definition

640+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

641+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

642+-- definition = alterTable #tab (dropConstraint #positive)

643+-- in printSQL definition

644+-- :}

645+-- ALTER TABLE "tab" DROP CONSTRAINT "positive";

646+dropConstraint

647+ :: ( KnownSymbol constraint

648+ , Has sch schemas schema

649+ , Has tab schema ('Table table0)

650+ , table0 ~ (constraints :=> columns)

651+ , table1 ~ (Drop constraint constraints :=> columns) )

652+ => Alias constraint

653+ -- ^ constraint to drop

654+ -> AlterTable sch tab schemas table1

655+dropConstraint constraint = UnsafeAlterTable $

656+ "DROP" <+> "CONSTRAINT" <+> renderSQL constraint

657+

658+-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.

659+class AddColumn ty where

660+ -- | `addColumn` adds a new column, initially filled with whatever

661+ -- default value is given or with @NULL@.

662+ --

663+ -- >>> :{

664+ -- let

665+ -- definition :: Definition

666+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]

667+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>

668+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

669+ -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]

670+ -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))

671+ -- in printSQL definition

672+ -- :}

673+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';

674+ --

675+ -- >>> :{

676+ -- let

677+ -- definition :: Definition

678+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]

679+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>

680+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

681+ -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]

682+ -- definition = alterTable #tab (addColumn #col2 (text & nullable))

683+ -- in printSQL definition

684+ -- :}

685+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;

686+ addColumn

687+ :: ( KnownSymbol column

688+ , Has sch schemas schema

689+ , Has tab schema ('Table table0)

690+ , table0 ~ (constraints :=> columns) )

691+ => Alias column -- ^ column to add

692+ -> ColumnTypeExpression schemas ty -- ^ type of the new column

693+ -> AlterTable sch tab schemas (constraints :=> Create column ty columns)

694+ addColumn column ty = UnsafeAlterTable $

695+ "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty

696+instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)

697+instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)

698+

699+-- | A `dropColumn` removes a column. Whatever data was in the column

700+-- disappears. Table constraints involving the column are dropped, too.

701+-- However, if the column is referenced by a foreign key constraint of

702+-- another table, PostgreSQL will not silently drop that constraint.

703+--

704+-- >>> :{

705+-- let

706+-- definition :: Definition

707+-- '["public" ::: '["tab" ::: 'Table ('[] :=>

708+-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

709+-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]

710+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]

711+-- definition = alterTable #tab (dropColumn #col2)

712+-- in printSQL definition

713+-- :}

714+-- ALTER TABLE "tab" DROP COLUMN "col2";

715+dropColumn

716+ :: ( KnownSymbol column

717+ , Has sch schemas schema

718+ , Has tab schema ('Table table0)

719+ , table0 ~ (constraints :=> columns)

720+ , table1 ~ (constraints :=> Drop column columns) )

721+ => Alias column -- ^ column to remove

722+ -> AlterTable sch tab schemas table1

723+dropColumn column = UnsafeAlterTable $

724+ "DROP COLUMN" <+> renderSQL column

725+

726+-- | A `renameColumn` renames a column.

727+--

728+-- >>> :{

729+-- let

730+-- definition :: Definition

731+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]

732+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]

733+-- definition = alterTable #tab (renameColumn #foo #bar)

734+-- in printSQL definition

735+-- :}

736+-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";

737+renameColumn

738+ :: ( KnownSymbol column0

739+ , KnownSymbol column1

740+ , Has sch schemas schema

741+ , Has tab schema ('Table table0)

742+ , table0 ~ (constraints :=> columns)

743+ , table1 ~ (constraints :=> Rename column0 column1 columns) )

744+ => Alias column0 -- ^ column to rename

745+ -> Alias column1 -- ^ what to rename the column

746+ -> AlterTable sch tab schemas table1

747+renameColumn column0 column1 = UnsafeAlterTable $

748+ "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1

749+

750+-- | An `alterColumn` alters a single column.

751+alterColumn

752+ :: ( KnownSymbol column

753+ , Has sch schemas schema

754+ , Has tab schema ('Table table0)

755+ , table0 ~ (constraints :=> columns)

756+ , Has column columns ty0

757+ , table1 ~ (constraints :=> Alter column ty1 columns))

758+ => Alias column -- ^ column to alter

759+ -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform

760+ -> AlterTable sch tab schemas table1

761+alterColumn column alteration = UnsafeAlterTable $

762+ "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration

763+

764+-- | An `AlterColumn` describes the alteration to perform on a single column.

765+newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =

766+ UnsafeAlterColumn {renderAlterColumn :: ByteString}

767+ deriving (GHC.Generic,Show,Eq,Ord,NFData)

768+

769+-- | A `setDefault` sets a new default for a column. Note that this doesn't

770+-- affect any existing rows in the table, it just changes the default for

771+-- future insert and update commands.

772+--

773+-- >>> :{

774+-- let

775+-- definition :: Definition

776+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]

777+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]

778+-- definition = alterTable #tab (alterColumn #col (setDefault 5))

779+-- in printSQL definition

780+-- :}

781+-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;

782+setDefault

783+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set

784+ -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)

785+setDefault expression = UnsafeAlterColumn $

786+ "SET DEFAULT" <+> renderExpression expression

787+

788+-- | A `dropDefault` removes any default value for a column.

789+--

790+-- >>> :{

791+-- let

792+-- definition :: Definition

793+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]

794+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]

795+-- definition = alterTable #tab (alterColumn #col dropDefault)

796+-- in printSQL definition

797+-- :}

798+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;

799+dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)

800+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"

801+

802+-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.

803+-- The constraint will be checked immediately, so the table data must satisfy

804+-- the constraint before it can be added.

805+--

806+-- >>> :{

807+-- let

808+-- definition :: Definition

809+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]

810+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

811+-- definition = alterTable #tab (alterColumn #col setNotNull)

812+-- in printSQL definition

813+-- :}

814+-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;

815+setNotNull

816+ :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)

817+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"

818+

819+-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.

820+--

821+-- >>> :{

822+-- let

823+-- definition :: Definition

824+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

825+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]

826+-- definition = alterTable #tab (alterColumn #col dropNotNull)

827+-- in printSQL definition

828+-- :}

829+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;

830+dropNotNull

831+ :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)

832+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"

833+

834+-- | An `alterType` converts a column to a different data type.

835+-- This will succeed only if each existing entry in the column can be

836+-- converted to the new type by an implicit cast.

837+--

838+-- >>> :{

839+-- let

840+-- definition :: Definition

841+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

842+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]

843+-- definition =

844+-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))

845+-- in printSQL definition

846+-- :}

847+-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;

848+alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty

849+alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty

850+

851+{- | Create a view.

852+>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]

853+>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]

854+>>> :{

855+let

856+ definition :: Definition

857+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]

858+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]

859+ definition =

860+ createView #bc (select_ (#b :* #c) (from (table #abc)))

861+in printSQL definition

862+:}

863+CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";

864+-}

865+createView

866+ :: (KnownSymbol sch, KnownSymbol vw, Has sch schemas schema)

867+ => QualifiedAlias sch vw -- ^ the name of the view to add

868+ -> Query '[] '[] schemas '[] view -- ^ query

869+ -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)

870+createView alias query = UnsafeDefinition $

871+ "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"

872+ <+> renderQuery query <> ";"

873+

874+-- | Drop a view.

875+--

876+-- >>> :{

877+-- let

878+-- definition :: Definition

879+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])

880+-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]

881+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]

882+-- definition = dropView #bc

883+-- in printSQL definition

884+-- :}

885+-- DROP VIEW "bc";

886+dropView

887+ :: (Has sch schemas schema, Has vw schema ('View view))

888+ => QualifiedAlias sch vw -- ^ view to remove

889+ -> Definition schemas (Alter sch (Drop vw schema) schemas)

890+dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"

891+

892+-- | Enumerated types are created using the `createTypeEnum` command, for example

893+--

894+-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])

895+-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');

896+createTypeEnum

897+ :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)

898+ => QualifiedAlias sch enum

899+ -- ^ name of the user defined enumerated type

900+ -> NP PGlabel labels

901+ -- ^ labels of the enumerated type

902+ -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)

903+createTypeEnum enum labels = UnsafeDefinition $

904+ "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>

905+ parenthesized (renderSQL labels) <> ";"

906+

907+-- | Enumerated types can also be generated from a Haskell type, for example

908+--

909+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic

910+-- >>> instance SOP.Generic Schwarma

911+-- >>> instance SOP.HasDatatypeInfo Schwarma

912+-- >>> :{

913+-- let

914+-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]

915+-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma

916+-- in

917+-- printSQL createSchwarma

918+-- :}

919+-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');

920+createTypeEnumFrom

921+ :: forall hask sch enum schemas schema.

922+ ( SOP.Generic hask

923+ , SOP.All KnownSymbol (LabelsPG hask)

924+ , KnownSymbol enum

925+ , Has sch schemas schema )

926+ => QualifiedAlias sch enum

927+ -- ^ name of the user defined enumerated type

928+ -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)

929+createTypeEnumFrom enum = createTypeEnum enum

930+ (SOP.hpure label :: NP PGlabel (LabelsPG hask))

931+

932+{- | `createTypeComposite` creates a composite type. The composite type is

933+specified by a list of attribute names and data types.

934+

935+>>> :{

936+type PGcomplex = 'PGcomposite

937+ '[ "real" ::: 'NotNull 'PGfloat8

938+ , "imaginary" ::: 'NotNull 'PGfloat8 ]

939+:}

940+

941+>>> :{

942+let

943+ setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]

944+ setup = createTypeComposite #complex

945+ (float8 `as` #real :* float8 `as` #imaginary)

946+in printSQL setup

947+:}

948+CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);

949+-}

950+createTypeComposite

951+ :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)

952+ => QualifiedAlias sch ty

953+ -- ^ name of the user defined composite type

954+ -> NP (Aliased (TypeExpression schemas)) fields

955+ -- ^ list of attribute names and data types

956+ -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)

957+createTypeComposite ty fields = UnsafeDefinition $

958+ "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized

959+ (renderCommaSeparated renderField fields) <> ";"

960+ where

961+ renderField :: Aliased (TypeExpression schemas) x -> ByteString

962+ renderField (typ `As` alias) =

963+ renderSQL alias <+> renderSQL typ

964+

965+-- | Composite types can also be generated from a Haskell type, for example

966+--

967+-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic

968+-- >>> instance SOP.Generic Complex

969+-- >>> instance SOP.HasDatatypeInfo Complex

970+-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]

971+-- >>> :{

972+-- let

973+-- createComplex :: Definition (Public '[]) (Public Schema)

974+-- createComplex = createTypeCompositeFrom @Complex #complex

975+-- in

976+-- printSQL createComplex

977+-- :}

978+-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);

979+createTypeCompositeFrom

980+ :: forall hask sch ty schemas schema.

981+ ( SOP.All (FieldTyped schemas) (RowPG hask)

982+ , KnownSymbol ty

983+ , Has sch schemas schema )

984+ => QualifiedAlias sch ty

985+ -- ^ name of the user defined composite type

986+ -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)

987+createTypeCompositeFrom ty = createTypeComposite ty

988+ (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype

989+ :: NP (Aliased (TypeExpression schemas)) (RowPG hask))

990+

991+{-|

992+`createDomain` creates a new domain. A domain is essentially a data type

993+with constraints (restrictions on the allowed set of values).

994+

995+Domains are useful for abstracting common constraints on fields

996+into a single location for maintenance. For example, several tables might

997+contain email address columns, all requiring the same `check` constraint

998+to verify the address syntax. Define a domain rather than setting up

999+each table's constraint individually.

1000+

1001+>>> :{

1002+let

1003+ createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])

1004+ createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))

1005+in printSQL createPositive

1006+:}

1007+CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));

1008+-}

1009+createDomain

1010+ :: (Has sch schemas schema, KnownSymbol dom)

1011+ => QualifiedAlias sch dom

1012+ -> (forall nullity. TypeExpression schemas (nullity ty))

1013+ -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])

1014+ -> Definition schemas (Alter sch (Create alias ('Typedef ty) schema) schemas)

1015+createDomain dom ty condition =

1016+ UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom

1017+ <+> "AS" <+> renderTypeExpression ty

1018+ <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"

1019+

1020+class FieldTyped schemas ty where

1021+ fieldtype :: Aliased (TypeExpression schemas) ty

1022+instance (KnownSymbol alias, PGTyped schemas ty)

1023+ => FieldTyped schemas (alias ::: ty) where

1024+ fieldtype = pgtype `As` Alias

1025+

1026+-- | Drop a type.

1027+--

1028+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic

1029+-- >>> instance SOP.Generic Schwarma

1030+-- >>> instance SOP.HasDatatypeInfo Schwarma

1031+-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))

1032+-- DROP TYPE "schwarma";

1033+dropType

1034+ :: (Has sch schemas schema, Has td schema ('Typedef ty))

1035+ => QualifiedAlias sch td

1036+ -- ^ name of the user defined type

1037+ -> Definition schemas (Alter sch (Drop td schema) schemas)

1038+dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"

1039+

1040+-- | `ColumnTypeExpression`s are used in `createTable` commands.

1041+newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)

1042+ = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }

1043+ deriving (GHC.Generic,Show,Eq,Ord,NFData)

1044+instance RenderSQL (ColumnTypeExpression schemas ty) where

1045+ renderSQL = renderColumnTypeExpression

1046+

1047+-- | used in `createTable` commands as a column constraint to note that

1048+-- @NULL@ may be present in a column

1049+nullable

1050+ :: TypeExpression schemas (nullity ty)

1051+ -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)

1052+nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"

1053+

1054+-- | used in `createTable` commands as a column constraint to ensure

1055+-- @NULL@ is not present in a column

1056+notNullable

1057+ :: TypeExpression schemas (nullity ty)

1058+ -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)

1059+notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"

1060+

1061+-- | used in `createTable` commands as a column constraint to give a default

1062+default_

1063+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty

1064+ -> ColumnTypeExpression schemas ('NoDef :=> ty)

1065+ -> ColumnTypeExpression schemas ('Def :=> ty)

1066+default_ x ty = UnsafeColumnTypeExpression $

1067+ renderSQL ty <+> "DEFAULT" <+> renderExpression x

1068+

1069+-- | not a true type, but merely a notational convenience for creating

1070+-- unique identifier columns with type `PGint2`

1071+serial2, smallserial

1072+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)

1073+serial2 = UnsafeColumnTypeExpression "serial2"

1074+smallserial = UnsafeColumnTypeExpression "smallserial"

1075+-- | not a true type, but merely a notational convenience for creating

1076+-- unique identifier columns with type `PGint4`

1077+serial4, serial

1078+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)

1079+serial4 = UnsafeColumnTypeExpression "serial4"

1080+serial = UnsafeColumnTypeExpression "serial"

1081+-- | not a true type, but merely a notational convenience for creating

1082+-- unique identifier columns with type `PGint8`

1083+serial8, bigserial

1084+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)

1085+serial8 = UnsafeColumnTypeExpression "serial8"

1086+bigserial = UnsafeColumnTypeExpression "bigserial"

squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hsdeleted−238

@@ -1,238 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Definition.Function

3−Description: Create and drop function and operator definitions

4−Copyright: (c) Eitan Chatav, 2017

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Create and drop function and operator definitions.

9−-}

10−

11−{-# LANGUAGE

12− AllowAmbiguousTypes

13− , ConstraintKinds

14− , DeriveAnyClass

15− , DeriveGeneric

16− , DerivingStrategies

17− , FlexibleContexts

18− , FlexibleInstances

19− , GADTs

20− , LambdaCase

21− , MultiParamTypeClasses

22− , OverloadedLabels

23− , OverloadedStrings

24− , RankNTypes

25− , ScopedTypeVariables

26− , TypeApplications

27− , TypeInType

28− , TypeOperators

29− , UndecidableSuperClasses

30−#-}

31−

32−module Squeal.PostgreSQL.Definition.Function

33− ( createFunction

34− , createOrReplaceFunction

35− , createSetFunction

36− , createOrReplaceSetFunction

37− , createBinaryOp

38− , createLeftOp

39− , createRightOp

40− , dropFunction

41− , dropFunctionIfExists

42− , dropOperator

43− , dropOperatorIfExists

44− , FunctionDefinition(..)

45− , languageSqlExpr

46− , languageSqlQuery

47− ) where

48−

49−import Control.DeepSeq

50−import Data.ByteString

51−import GHC.TypeLits

52−

53−import qualified Generics.SOP as SOP

54−import qualified GHC.Generics as GHC

55−

56−import Squeal.PostgreSQL.Alias

57−import Squeal.PostgreSQL.Definition

58−import Squeal.PostgreSQL.Expression

59−import Squeal.PostgreSQL.Expression.Type

60−import Squeal.PostgreSQL.List

61−import Squeal.PostgreSQL.Query

62−import Squeal.PostgreSQL.Render

63−import Squeal.PostgreSQL.Schema

64−

65−-- $setup

66−-- >>> import Squeal.PostgreSQL

67−

68−createFunction

69− :: ( Has sch schemas schema

70− , KnownSymbol fun

71− , SOP.SListI args )

72− => QualifiedAlias sch fun

73− -> NP (TypeExpression schemas) args

74− -> TypeExpression schemas ret

75− -> FunctionDefinition schemas args ('Returns ret)

76− -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'Returns ret)) schema) schemas)

77−createFunction fun args ret fundef = UnsafeDefinition $

78− "CREATE" <+> "FUNCTION" <+> renderSQL fun

79− <+> parenthesized (renderCommaSeparated renderSQL args)

80− <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"

81−

82−createOrReplaceFunction

83− :: ( Has sch schemas schema

84− , KnownSymbol fun

85− , SOP.SListI args )

86− => QualifiedAlias sch fun

87− -> NP (TypeExpression schemas) args

88− -> TypeExpression schemas ret

89− -> FunctionDefinition schemas args ('Returns ret)

90− -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'Returns ret)) schema) schemas)

91−createOrReplaceFunction fun args ret fundef = UnsafeDefinition $

92− "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun

93− <+> parenthesized (renderCommaSeparated renderSQL args)

94− <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"

95−

96−languageSqlExpr

97− :: Expression '[] '[] 'Ungrouped schemas args '[] ret

98− -> FunctionDefinition schemas args ('Returns ret)

99−languageSqlExpr expr = UnsafeFunctionDefinition $

100− "language sql as"

101− <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$"

102−

103−languageSqlQuery

104− :: Query '[] '[] schemas args rets

105− -> FunctionDefinition schemas args ('ReturnsTable rets)

106−languageSqlQuery qry = UnsafeFunctionDefinition $

107− "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"

108−

109−createSetFunction

110− :: ( Has sch schemas schema

111− , KnownSymbol fun

112− , SOP.SListI args

113− , SOP.SListI rets )

114− => QualifiedAlias sch fun

115− -> NP (TypeExpression schemas) args

116− -> NP (Aliased (TypeExpression schemas)) rets

117− -> FunctionDefinition schemas args ('ReturnsTable rets)

118− -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)

119−createSetFunction fun args rets fundef = UnsafeDefinition $

120− "CREATE" <+> "FUNCTION" <+> renderSQL fun

121− <+> parenthesized (renderCommaSeparated renderSQL args)

122− <+> "RETURNS" <+> "TABLE"

123− <+> parenthesized (renderCommaSeparated renderRet rets)

124− <+> renderSQL fundef <> ";"

125− where

126− renderRet :: Aliased (TypeExpression s) r -> ByteString

127− renderRet (ty `As` col) = renderSQL col <+> renderSQL ty

128−

129−createOrReplaceSetFunction

130− :: ( Has sch schemas schema

131− , KnownSymbol fun

132− , SOP.SListI args

133− , SOP.SListI rets )

134− => QualifiedAlias sch fun

135− -> NP (TypeExpression schemas) args

136− -> NP (Aliased (TypeExpression schemas)) rets

137− -> FunctionDefinition schemas args ('ReturnsTable rets)

138− -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)

139−createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $

140− "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun

141− <+> parenthesized (renderCommaSeparated renderSQL args)

142− <+> "RETURNS" <+> "TABLE"

143− <+> parenthesized (renderCommaSeparated renderRet rets)

144− <+> renderSQL fundef <> ";"

145− where

146− renderRet :: Aliased (TypeExpression s) r -> ByteString

147− renderRet (ty `As` col) = renderSQL col <+> renderSQL ty

148−

149−createBinaryOp

150− :: forall op fun sch schemas schema x y z.

151− ( Has sch schemas schema

152− , Has fun schema ('Function ('[x,y] :=> 'Returns z))

153− , KnownSymbol op )

154− => QualifiedAlias sch fun

155− -> TypeExpression schemas x

156− -> TypeExpression schemas y

157− -> Definition schemas

158− (Alter sch (Create op ('Operator ('BinaryOp x y z)) schema) schemas)

159−createBinaryOp fun x y = UnsafeDefinition $

160− "CREATE" <+> "OPERATOR" <+> renderSymbol @op

161− <+> parenthesized (commaSeparated opdef)

162− where

163− opdef =

164− [ "FUNCTION" <+> "=" <+> renderSQL fun

165− , "LEFTARG" <+> "=" <+> renderSQL x

166− , "RIGHTARG" <+> "=" <+> renderSQL y ]

167−

168−createLeftOp

169− :: forall op fun sch schemas schema x y.

170− ( Has sch schemas schema

171− , Has fun schema ('Function ('[x] :=> 'Returns y))

172− , KnownSymbol op )

173− => QualifiedAlias sch fun

174− -> TypeExpression schemas x

175− -> Definition schemas

176− (Alter sch (Create op ('Operator ('LeftOp x y)) schema) schemas)

177−createLeftOp fun x = UnsafeDefinition $

178− "CREATE" <+> "OPERATOR" <+> renderSymbol @op

179− <+> parenthesized (commaSeparated opdef)

180− where

181− opdef =

182− [ "FUNCTION" <+> "=" <+> renderSQL fun

183− , "RIGHTARG" <+> "=" <+> renderSQL x ]

184−

185−createRightOp

186− :: forall op fun sch schemas schema x y.

187− ( Has sch schemas schema

188− , Has fun schema ('Function ('[x] :=> 'Returns y))

189− , KnownSymbol op )

190− => QualifiedAlias sch fun

191− -> TypeExpression schemas x

192− -> Definition schemas

193− (Alter sch (Create op ('Operator ('RightOp x y)) schema) schemas)

194−createRightOp fun x = UnsafeDefinition $

195− "CREATE" <+> "OPERATOR" <+> renderSymbol @op

196− <+> parenthesized (commaSeparated opdef)

197− where

198− opdef =

199− [ "FUNCTION" <+> "=" <+> renderSQL fun

200− , "LEFTARG" <+> "=" <+> renderSQL x ]

201−

202−dropFunction

203− :: (Has sch schemas schema, KnownSymbol fun)

204− => QualifiedAlias sch fun

205− -- ^ name of the user defined function

206− -> Definition schemas (Alter sch (DropSchemum fun 'Function schema) schemas)

207−dropFunction fun = UnsafeDefinition $

208− "DROP" <+> "FUNCTION" <+> renderSQL fun <> ";"

209−

210−dropFunctionIfExists

211− :: (Has sch schemas schema, KnownSymbol fun)

212− => QualifiedAlias sch fun

213− -- ^ name of the user defined function

214− -> Definition schemas (Alter sch (DropSchemumIfExists fun 'Function schema) schemas)

215−dropFunctionIfExists fun = UnsafeDefinition $

216− "DROP FUNCTION IF EXISTS" <+> renderSQL fun <> ";"

217−

218−dropOperator

219− :: (Has sch schemas schema, KnownSymbol op)

220− => QualifiedAlias sch op

221− -- ^ name of the user defined operator

222− -> Definition schemas (Alter sch (DropSchemum op 'Operator schema) schemas)

223−dropOperator op = UnsafeDefinition $

224− "DROP" <+> "OPERATOR" <+> renderSQL op <> ";"

225−

226−dropOperatorIfExists

227− :: (Has sch schemas schema, KnownSymbol op)

228− => QualifiedAlias sch op

229− -- ^ name of the user defined operator

230− -> Definition schemas (Alter sch (DropSchemumIfExists op 'Operator schema) schemas)

231−dropOperatorIfExists op = UnsafeDefinition $

232− "DROP OPERATOR IF EXISTS" <+> renderSQL op <> ";"

233−

234−newtype FunctionDefinition schemas args ret = UnsafeFunctionDefinition

235− { renderFunctionDefinition :: ByteString }

236− deriving (Eq,Show,GHC.Generic,NFData)

237−instance RenderSQL (FunctionDefinition schemas args ret) where

238− renderSQL = renderFunctionDefinition

squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hsdeleted−159

@@ -1,159 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Definition.Index

3−Description: Create and drop index definitions

4−Copyright: (c) Eitan Chatav, 2017

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Create and drop index definitions.

9−-}

10−

11−{-# LANGUAGE

12− AllowAmbiguousTypes

13− , ConstraintKinds

14− , DeriveAnyClass

15− , DeriveGeneric

16− , DerivingStrategies

17− , FlexibleContexts

18− , FlexibleInstances

19− , GADTs

20− , LambdaCase

21− , MultiParamTypeClasses

22− , OverloadedLabels

23− , OverloadedStrings

24− , RankNTypes

25− , ScopedTypeVariables

26− , TypeApplications

27− , TypeInType

28− , TypeOperators

29− , UndecidableSuperClasses

30−#-}

31−

32−module Squeal.PostgreSQL.Definition.Index

33− ( createIndex

34− , createIndexIfNotExists

35− , dropIndex

36− , dropIndexIfExists

37− , IndexMethod (..)

38− , btree

39− , hash

40− , gist

41− , spgist

42− , gin

43− , brin

44− ) where

45−

46−import Data.ByteString

47−import GHC.TypeLits

48−

49−import qualified GHC.Generics as GHC

50−

51−import Squeal.PostgreSQL.Alias

52−import Squeal.PostgreSQL.Definition

53−import Squeal.PostgreSQL.Expression.Sort

54−import Squeal.PostgreSQL.Render

55−import Squeal.PostgreSQL.Schema

56−

57−-- $setup

58−-- >>> import Squeal.PostgreSQL

59−

60−{- |

61−>>> :{

62−type Table = '[] :=>

63− '[ "a" ::: 'NoDef :=> 'Null 'PGint4

64− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]

65−:}

66−

67−>>> :{

68−let

69− setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree])

70− setup =

71− createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>>

72− createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast]

73−in printSQL setup

74−:}

75−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);

76−CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST);

77−-}

78−createIndex

79− :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)

80− => Alias ix

81− -> QualifiedAlias sch tab

82− -> IndexMethod method

83− -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]

84− -> Definition schemas (Alter sch (Create ix ('Index method) schema) schemas)

85−createIndex ix tab method cols = UnsafeDefinition $

86− "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab

87− <+> "USING" <+> renderSQL method

88− <+> parenthesized (commaSeparated (renderIndex <$> cols))

89− <> ";"

90− where

91− renderIndex = \case

92− Asc expression -> parenthesized (renderSQL expression) <+> "ASC"

93− Desc expression -> parenthesized (renderSQL expression) <+> "DESC"

94− AscNullsFirst expression -> parenthesized (renderSQL expression)

95− <+> "ASC NULLS FIRST"

96− DescNullsFirst expression -> parenthesized (renderSQL expression)

97− <+> "DESC NULLS FIRST"

98− AscNullsLast expression -> parenthesized (renderSQL expression)

99− <+> "ASC NULLS LAST"

100− DescNullsLast expression -> parenthesized (renderSQL expression)

101− <+> "DESC NULLS LAST"

102−

103−createIndexIfNotExists

104− :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)

105− => Alias ix

106− -> QualifiedAlias sch tab

107− -> IndexMethod method

108− -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]

109− -> Definition schemas (Alter sch (CreateIfNotExists ix ('Index method) schema) schemas)

110−createIndexIfNotExists ix tab method cols = UnsafeDefinition $

111− "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab

112− <+> "USING" <+> renderSQL method

113− <+> parenthesized (commaSeparated (renderIndex <$> cols))

114− <> ";"

115− where

116− renderIndex = \case

117− Asc expression -> parenthesized (renderSQL expression) <+> "ASC"

118− Desc expression -> parenthesized (renderSQL expression) <+> "DESC"

119− AscNullsFirst expression -> parenthesized (renderSQL expression)

120− <+> "ASC NULLS FIRST"

121− DescNullsFirst expression -> parenthesized (renderSQL expression)

122− <+> "DESC NULLS FIRST"

123− AscNullsLast expression -> parenthesized (renderSQL expression)

124− <+> "ASC NULLS LAST"

125− DescNullsLast expression -> parenthesized (renderSQL expression)

126− <+> "DESC NULLS LAST"

127−

128−newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString}

129− deriving stock (Eq, Ord, Show, GHC.Generic)

130−instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod

131−btree :: IndexMethod 'Btree

132−btree = UnsafeIndexMethod "btree"

133−hash :: IndexMethod 'Hash

134−hash = UnsafeIndexMethod "hash"

135−gist :: IndexMethod 'Gist

136−gist = UnsafeIndexMethod "gist"

137−spgist :: IndexMethod 'Spgist

138−spgist = UnsafeIndexMethod "spgist"

139−gin :: IndexMethod 'Gin

140−gin = UnsafeIndexMethod "gin"

141−brin :: IndexMethod 'Brin

142−brin = UnsafeIndexMethod "brin"

143−

144−-- |

145−-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[]))

146−-- DROP INDEX "ix";

147−dropIndex

148− :: (Has sch schemas schema, KnownSymbol ix)

149− => QualifiedAlias sch ix

150− -- ^ name of the user defined index

151− -> Definition schemas (Alter sch (DropSchemum ix 'Index schema) schemas)

152−dropIndex ix = UnsafeDefinition $ "DROP" <+> "INDEX" <+> renderSQL ix <> ";"

153−

154−dropIndexIfExists

155− :: (Has sch schemas schema, KnownSymbol ix)

156− => QualifiedAlias sch ix

157− -- ^ name of the user defined index

158− -> Definition schemas (Alter sch (DropSchemumIfExists ix 'Index schema) schemas)

159−dropIndexIfExists ix = UnsafeDefinition $ "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";"

squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hsdeleted−96

@@ -1,96 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Definition.Schema

3−Description: Create and drop schema definitions

4−Copyright: (c) Eitan Chatav, 2017

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Create and drop schema definitions.

9−-}

10−

11−{-# LANGUAGE

12− AllowAmbiguousTypes

13− , ConstraintKinds

14− , DeriveAnyClass

15− , DeriveGeneric

16− , DerivingStrategies

17− , FlexibleContexts

18− , FlexibleInstances

19− , GADTs

20− , LambdaCase

21− , MultiParamTypeClasses

22− , OverloadedLabels

23− , OverloadedStrings

24− , RankNTypes

25− , ScopedTypeVariables

26− , TypeApplications

27− , TypeInType

28− , TypeOperators

29− , UndecidableSuperClasses

30−#-}

31−

32−module Squeal.PostgreSQL.Definition.Schema

33− ( createSchema

34− , createSchemaIfNotExists

35− , dropSchema

36− , dropSchemaIfExists

37− ) where

38−

39−import GHC.TypeLits

40−

41−import Squeal.PostgreSQL.Alias

42−import Squeal.PostgreSQL.Definition

43−import Squeal.PostgreSQL.Render

44−import Squeal.PostgreSQL.Schema

45−

46−-- $setup

47−-- >>> import Squeal.PostgreSQL

48−

49−{- |

50−`createSchema` enters a new schema into the current database.

51−The schema name must be distinct from the name of any existing schema

52−in the current database.

53−

54−A schema is essentially a namespace: it contains named objects

55−(tables, data types, functions, and operators) whose names

56−can duplicate those of other objects existing in other schemas.

57−Named objects are accessed by `QualifiedAlias`es with the schema

58−name as a prefix.

59−-}

60−createSchema

61− :: KnownSymbol sch

62− => Alias sch

63− -> Definition schemas (Create sch '[] schemas)

64−createSchema sch = UnsafeDefinition $

65− "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"

66−

67−{- | Idempotent version of `createSchema`. -}

68−createSchemaIfNotExists

69− :: (KnownSymbol sch, Has sch schemas schema)

70− => Alias sch

71− -> Definition schemas (CreateIfNotExists sch '[] schemas)

72−createSchemaIfNotExists sch = UnsafeDefinition $

73− "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"

74− <+> renderSQL sch <> ";"

75−

76−-- | >>> :{

77−-- let

78−-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]

79−-- definition = dropSchema #muh_schema

80−-- :}

81−--

82−-- >>> printSQL definition

83−-- DROP SCHEMA "muh_schema";

84−dropSchema

85− :: KnownSymbol sch

86− => Alias sch

87− -- ^ user defined schema

88− -> Definition schemas (Drop sch schemas)

89−dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"

90−

91−dropSchemaIfExists

92− :: KnownSymbol sch

93− => Alias sch

94− -- ^ user defined schema

95− -> Definition schemas (DropIfExists sch schemas)

96−dropSchemaIfExists sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"

squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hsdeleted−500

@@ -1,500 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Definition.Table

3−Description: Create, drop and alter table definitions

4−Copyright: (c) Eitan Chatav, 2017

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Create, drop and alter table definitions.

9−-}

10−

11−{-# LANGUAGE

12− AllowAmbiguousTypes

13− , ConstraintKinds

14− , DeriveAnyClass

15− , DeriveGeneric

16− , DerivingStrategies

17− , FlexibleContexts

18− , FlexibleInstances

19− , GADTs

20− , LambdaCase

21− , MultiParamTypeClasses

22− , OverloadedLabels

23− , OverloadedStrings

24− , RankNTypes

25− , ScopedTypeVariables

26− , TypeApplications

27− , TypeInType

28− , TypeOperators

29− , UndecidableSuperClasses

30−#-}

31−

32−module Squeal.PostgreSQL.Definition.Table

33− ( createTable

34− , createTableIfNotExists

35− , dropTable

36− , dropTableIfExists

37− , alterTable

38− , alterTableIfExists

39− , alterTableRename

40− , alterTableIfExistsRename

41− , AlterTable (..)

42− , addConstraint

43− , dropConstraint

44− , AddColumn (..)

45− , dropColumn

46− , renameColumn

47− , alterColumn

48− , AlterColumn (..)

49− , setDefault

50− , dropDefault

51− , setNotNull

52− , dropNotNull

53− , alterType

54− ) where

55−

56−import Control.DeepSeq

57−import Data.ByteString

58−import GHC.TypeLits

59−

60−import qualified Generics.SOP as SOP

61−import qualified GHC.Generics as GHC

62−

63−import Squeal.PostgreSQL.Alias

64−import Squeal.PostgreSQL.Definition

65−import Squeal.PostgreSQL.Definition.Table.Constraint

66−import Squeal.PostgreSQL.Expression

67−import Squeal.PostgreSQL.Expression.Type

68−import Squeal.PostgreSQL.List

69−import Squeal.PostgreSQL.Render

70−import Squeal.PostgreSQL.Schema

71−

72−-- $setup

73−-- >>> import Squeal.PostgreSQL

74−

75−{- | `createTable` adds a table to the schema.

76−

77−>>> :set -XOverloadedLabels

78−>>> :{

79−type Table = '[] :=>

80− '[ "a" ::: 'NoDef :=> 'Null 'PGint4

81− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]

82−:}

83−

84−>>> :{

85−let

86− setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])

87− setup = createTable #tab

88− (nullable int `as` #a :* nullable real `as` #b) Nil

89−in printSQL setup

90−:}

91−CREATE TABLE "tab" ("a" int NULL, "b" real NULL);

92−-}

93−createTable

94− :: ( KnownSymbol sch

95− , KnownSymbol tab

96− , columns ~ (col ': cols)

97− , SOP.SListI columns

98− , SOP.SListI constraints

99− , Has sch schemas0 schema0

100− , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )

101− => QualifiedAlias sch tab -- ^ the name of the table to add

102− -> NP (Aliased (ColumnTypeExpression schemas0)) columns

103− -- ^ the names and datatype of each column

104− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints

105− -- ^ constraints that must hold for the table

106− -> Definition schemas0 schemas1

107−createTable tab columns constraints = UnsafeDefinition $

108− "CREATE TABLE" <+> renderCreation tab columns constraints

109−

110−{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.

111−Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.

112−`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in

113−the `Category` of `Definition`s.

114−

115−>>> :set -XOverloadedLabels -XTypeApplications

116−>>> :{

117−type Table = '[] :=>

118− '[ "a" ::: 'NoDef :=> 'Null 'PGint4

119− , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]

120−:}

121−

122−>>> type Schemas = Public '["tab" ::: 'Table Table]

123−

124−>>> :{

125−let

126− setup :: Definition Schemas Schemas

127− setup = createTableIfNotExists #tab

128− (nullable int `as` #a :* nullable real `as` #b) Nil

129−in printSQL setup

130−:}

131−CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);

132−-}

133−createTableIfNotExists

134− :: ( KnownSymbol sch

135− , KnownSymbol tab

136− , columns ~ (col ': cols)

137− , SOP.SListI columns

138− , SOP.SListI constraints

139− , Has sch schemas0 schema0

140− , schemas1 ~ Alter sch (CreateIfNotExists tab ('Table (constraints :=> columns)) schema0) schemas0 )

141− => QualifiedAlias sch tab -- ^ the name of the table to add

142− -> NP (Aliased (ColumnTypeExpression schemas0)) columns

143− -- ^ the names and datatype of each column

144− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints

145− -- ^ constraints that must hold for the table

146− -> Definition schemas0 schemas1

147−createTableIfNotExists tab columns constraints = UnsafeDefinition $

148− "CREATE TABLE IF NOT EXISTS"

149− <+> renderCreation tab columns constraints

150−

151−-- helper function for `createTable` and `createTableIfNotExists`

152−renderCreation

153− :: ( KnownSymbol sch

154− , KnownSymbol tab

155− , SOP.SListI columns

156− , SOP.SListI constraints )

157− => QualifiedAlias sch tab -- ^ the name of the table to add

158− -> NP (Aliased (ColumnTypeExpression schemas0)) columns

159− -- ^ the names and datatype of each column

160− -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints

161− -- ^ constraints that must hold for the table

162− -> ByteString

163−renderCreation tab columns constraints = renderSQL tab

164− <+> parenthesized

165− ( renderCommaSeparated renderColumnDef columns

166− <> ( case constraints of

167− Nil -> ""

168− _ -> ", " <>

169− renderCommaSeparated renderConstraint constraints ) )

170− <> ";"

171− where

172− renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString

173− renderColumnDef (ty `As` column) =

174− renderSQL column <+> renderColumnTypeExpression ty

175− renderConstraint

176− :: Aliased (TableConstraintExpression sch tab schemas) constraint

177− -> ByteString

178− renderConstraint (constraint `As` alias) =

179− "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint

180−

181−-- | `dropTable` removes a table from the schema.

182−--

183−-- >>> :{

184−-- let

185−-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])

186−-- definition = dropTable #muh_table

187−-- :}

188−--

189−-- >>> printSQL definition

190−-- DROP TABLE "muh_table";

191−dropTable

192− :: ( Has sch schemas schema

193− , KnownSymbol tab )

194− => QualifiedAlias sch tab -- ^ table to remove

195− -> Definition schemas (Alter sch (DropSchemum tab 'Table schema) schemas)

196−dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"

197−

198−dropTableIfExists

199− :: ( Has sch schemas schema

200− , KnownSymbol tab)

201− => QualifiedAlias sch tab -- ^ table to remove

202− -> Definition schemas (Alter sch (DropSchemumIfExists tab 'Table schema) schemas)

203−dropTableIfExists tab = UnsafeDefinition $ "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";"

204−

205−-- | `alterTable` changes the definition of a table from the schema.

206−alterTable

207− :: (Has sch schemas schema, KnownSymbol tab)

208− => QualifiedAlias sch tab -- ^ table to alter

209− -> AlterTable sch tab schemas table -- ^ alteration to perform

210− -> Definition schemas (Alter sch (Alter tab ('Table table) schema) schemas)

211−alterTable tab alteration = UnsafeDefinition $

212− "ALTER TABLE"

213− <+> renderSQL tab

214− <+> renderAlterTable alteration

215− <> ";"

216−

217−-- | `alterTable` changes the definition of a table from the schema.

218−alterTableIfExists

219− :: (Has sch schemas schema, KnownSymbol tab)

220− => QualifiedAlias sch tab -- ^ table to alter

221− -> AlterTable sch tab schemas table -- ^ alteration to perform

222− -> Definition schemas (Alter sch (AlterIfExists tab ('Table table) schema) schemas)

223−alterTableIfExists tab alteration = UnsafeDefinition $

224− "ALTER TABLE IF EXISTS"

225− <+> renderSQL tab

226− <+> renderAlterTable alteration

227− <> ";"

228−

229−-- | `alterTableRename` changes the name of a table from the schema.

230−--

231−-- >>> printSQL $ alterTableRename #foo #bar

232−-- ALTER TABLE "foo" RENAME TO "bar";

233−alterTableRename

234− :: (KnownSymbol tab0, KnownSymbol tab1)

235− => Alias tab0 -- ^ table to rename

236− -> Alias tab1 -- ^ what to rename it

237− -> Definition schema (Rename tab0 tab1 schema)

238−alterTableRename tab0 tab1 = UnsafeDefinition $

239− "ALTER TABLE" <+> renderSQL tab0

240− <+> "RENAME TO" <+> renderSQL tab1 <> ";"

241−

242−alterTableIfExistsRename

243− :: (KnownSymbol tab0, KnownSymbol tab1)

244− => Alias tab0 -- ^ table to rename

245− -> Alias tab1 -- ^ what to rename it

246− -> Definition schema (RenameIfExists tab0 tab1 schema)

247−alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $

248− "ALTER TABLE IF EXISTS" <+> renderSQL tab0

249− <+> "RENAME TO" <+> renderSQL tab1 <> ";"

250−

251−-- | An `AlterTable` describes the alteration to perform on the columns

252−-- of a table.

253−newtype AlterTable

254− (sch :: Symbol)

255− (tab :: Symbol)

256− (schemas :: SchemasType)

257− (table :: TableType) =

258− UnsafeAlterTable {renderAlterTable :: ByteString}

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

260−

261−-- | An `addConstraint` adds a table constraint.

262−--

263−-- >>> :{

264−-- let

265−-- definition :: Definition

266−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

267−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

268−-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))

269−-- in printSQL definition

270−-- :}

271−-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));

272−addConstraint

273− :: ( KnownSymbol alias

274− , Has sch schemas schema

275− , Has tab schema ('Table table0)

276− , table0 ~ (constraints :=> columns)

277− , table1 ~ (Create alias constraint constraints :=> columns) )

278− => Alias alias

279− -> TableConstraintExpression sch tab schemas constraint

280− -- ^ constraint to add

281− -> AlterTable sch tab schemas table1

282−addConstraint alias constraint = UnsafeAlterTable $

283− "ADD" <+> "CONSTRAINT" <+> renderSQL alias

284− <+> renderSQL constraint

285−

286−-- | A `dropConstraint` drops a table constraint.

287−--

288−-- >>> :{

289−-- let

290−-- definition :: Definition

291−-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

292−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

293−-- definition = alterTable #tab (dropConstraint #positive)

294−-- in printSQL definition

295−-- :}

296−-- ALTER TABLE "tab" DROP CONSTRAINT "positive";

297−dropConstraint

298− :: ( KnownSymbol constraint

299− , Has sch schemas schema

300− , Has tab schema ('Table table0)

301− , table0 ~ (constraints :=> columns)

302− , table1 ~ (Drop constraint constraints :=> columns) )

303− => Alias constraint

304− -- ^ constraint to drop

305− -> AlterTable sch tab schemas table1

306−dropConstraint constraint = UnsafeAlterTable $

307− "DROP" <+> "CONSTRAINT" <+> renderSQL constraint

308−

309−-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.

310−class AddColumn ty where

311− -- | `addColumn` adds a new column, initially filled with whatever

312− -- default value is given or with @NULL@.

313− --

314− -- >>> :{

315− -- let

316− -- definition :: Definition

317− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]

318− -- '["public" ::: '["tab" ::: 'Table ('[] :=>

319− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

320− -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]

321− -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))

322− -- in printSQL definition

323− -- :}

324− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';

325− --

326− -- >>> :{

327− -- let

328− -- definition :: Definition

329− -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]

330− -- '["public" ::: '["tab" ::: 'Table ('[] :=>

331− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

332− -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]

333− -- definition = alterTable #tab (addColumn #col2 (text & nullable))

334− -- in printSQL definition

335− -- :}

336− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;

337− addColumn

338− :: ( KnownSymbol column

339− , Has sch schemas schema

340− , Has tab schema ('Table table0)

341− , table0 ~ (constraints :=> columns) )

342− => Alias column -- ^ column to add

343− -> ColumnTypeExpression schemas ty -- ^ type of the new column

344− -> AlterTable sch tab schemas (constraints :=> Create column ty columns)

345− addColumn column ty = UnsafeAlterTable $

346− "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty

347−instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)

348−instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)

349−

350−-- | A `dropColumn` removes a column. Whatever data was in the column

351−-- disappears. Table constraints involving the column are dropped, too.

352−-- However, if the column is referenced by a foreign key constraint of

353−-- another table, PostgreSQL will not silently drop that constraint.

354−--

355−-- >>> :{

356−-- let

357−-- definition :: Definition

358−-- '["public" ::: '["tab" ::: 'Table ('[] :=>

359−-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

360−-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]

361−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]

362−-- definition = alterTable #tab (dropColumn #col2)

363−-- in printSQL definition

364−-- :}

365−-- ALTER TABLE "tab" DROP COLUMN "col2";

366−dropColumn

367− :: ( KnownSymbol column

368− , Has sch schemas schema

369− , Has tab schema ('Table table0)

370− , table0 ~ (constraints :=> columns)

371− , table1 ~ (constraints :=> Drop column columns) )

372− => Alias column -- ^ column to remove

373− -> AlterTable sch tab schemas table1

374−dropColumn column = UnsafeAlterTable $

375− "DROP COLUMN" <+> renderSQL column

376−

377−-- | A `renameColumn` renames a column.

378−--

379−-- >>> :{

380−-- let

381−-- definition :: Definition

382−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]

383−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]

384−-- definition = alterTable #tab (renameColumn #foo #bar)

385−-- in printSQL definition

386−-- :}

387−-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";

388−renameColumn

389− :: ( KnownSymbol column0

390− , KnownSymbol column1

391− , Has sch schemas schema

392− , Has tab schema ('Table table0)

393− , table0 ~ (constraints :=> columns)

394− , table1 ~ (constraints :=> Rename column0 column1 columns) )

395− => Alias column0 -- ^ column to rename

396− -> Alias column1 -- ^ what to rename the column

397− -> AlterTable sch tab schemas table1

398−renameColumn column0 column1 = UnsafeAlterTable $

399− "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1

400−

401−-- | An `alterColumn` alters a single column.

402−alterColumn

403− :: ( KnownSymbol column

404− , Has sch schemas schema

405− , Has tab schema ('Table table0)

406− , table0 ~ (constraints :=> columns)

407− , Has column columns ty0

408− , table1 ~ (constraints :=> Alter column ty1 columns))

409− => Alias column -- ^ column to alter

410− -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform

411− -> AlterTable sch tab schemas table1

412−alterColumn column alteration = UnsafeAlterTable $

413− "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration

414−

415−-- | An `AlterColumn` describes the alteration to perform on a single column.

416−newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =

417− UnsafeAlterColumn {renderAlterColumn :: ByteString}

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

419−

420−-- | A `setDefault` sets a new default for a column. Note that this doesn't

421−-- affect any existing rows in the table, it just changes the default for

422−-- future insert and update commands.

423−--

424−-- >>> :{

425−-- let

426−-- definition :: Definition

427−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]

428−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]

429−-- definition = alterTable #tab (alterColumn #col (setDefault 5))

430−-- in printSQL definition

431−-- :}

432−-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;

433−setDefault

434− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set

435− -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)

436−setDefault expression = UnsafeAlterColumn $

437− "SET DEFAULT" <+> renderExpression expression

438−

439−-- | A `dropDefault` removes any default value for a column.

440−--

441−-- >>> :{

442−-- let

443−-- definition :: Definition

444−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]

445−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]

446−-- definition = alterTable #tab (alterColumn #col dropDefault)

447−-- in printSQL definition

448−-- :}

449−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;

450−dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)

451−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"

452−

453−-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.

454−-- The constraint will be checked immediately, so the table data must satisfy

455−-- the constraint before it can be added.

456−--

457−-- >>> :{

458−-- let

459−-- definition :: Definition

460−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]

461−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

462−-- definition = alterTable #tab (alterColumn #col setNotNull)

463−-- in printSQL definition

464−-- :}

465−-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;

466−setNotNull

467− :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)

468−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"

469−

470−-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.

471−--

472−-- >>> :{

473−-- let

474−-- definition :: Definition

475−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

476−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]

477−-- definition = alterTable #tab (alterColumn #col dropNotNull)

478−-- in printSQL definition

479−-- :}

480−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;

481−dropNotNull

482− :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)

483−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"

484−

485−-- | An `alterType` converts a column to a different data type.

486−-- This will succeed only if each existing entry in the column can be

487−-- converted to the new type by an implicit cast.

488−--

489−-- >>> :{

490−-- let

491−-- definition :: Definition

492−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

493−-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]

494−-- definition =

495−-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))

496−-- in printSQL definition

497−-- :}

498−-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;

499−alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty

500−alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty

squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table/Constraint.hsdeleted−339

@@ -1,339 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Definition.Table.Constraint

3−Description: Table constraint expressions

4−Copyright: (c) Eitan Chatav, 2017

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Table constraint expressions.

9−-}

10−

11−{-# LANGUAGE

12− AllowAmbiguousTypes

13− , ConstraintKinds

14− , DeriveAnyClass

15− , DeriveGeneric

16− , DerivingStrategies

17− , FlexibleContexts

18− , FlexibleInstances

19− , GADTs

20− , LambdaCase

21− , MultiParamTypeClasses

22− , OverloadedLabels

23− , OverloadedStrings

24− , RankNTypes

25− , ScopedTypeVariables

26− , TypeApplications

27− , TypeInType

28− , TypeOperators

29− , UndecidableSuperClasses

30−#-}

31−

32−module Squeal.PostgreSQL.Definition.Table.Constraint

33− ( TableConstraintExpression (..)

34− , check

35− , unique

36− , primaryKey

37− , foreignKey

38− , ForeignKeyed

39− , OnDeleteClause (..)

40− , OnUpdateClause (..)

41− ) where

42−

43−import Control.DeepSeq

44−import Data.ByteString

45−import GHC.TypeLits

46−

47−import qualified Generics.SOP as SOP

48−import qualified GHC.Generics as GHC

49−

50−import Squeal.PostgreSQL.Alias

51−import Squeal.PostgreSQL.Expression.Logic

52−import Squeal.PostgreSQL.List

53−import Squeal.PostgreSQL.Render

54−import Squeal.PostgreSQL.Schema

55−

56−-- $setup

57−-- >>> import Squeal.PostgreSQL

58−

59−-- | Data types are a way to limit the kind of data that can be stored in a

60−-- table. For many applications, however, the constraint they provide is

61−-- too coarse. For example, a column containing a product price should

62−-- probably only accept positive values. But there is no standard data type

63−-- that accepts only positive numbers. Another issue is that you might want

64−-- to constrain column data with respect to other columns or rows.

65−-- For example, in a table containing product information,

66−-- there should be only one row for each product number.

67−-- `TableConstraint`s give you as much control over the data in your tables

68−-- as you wish. If a user attempts to store data in a column that would

69−-- violate a constraint, an error is raised. This applies

70−-- even if the value came from the default value definition.

71−newtype TableConstraintExpression

72− (sch :: Symbol)

73− (tab :: Symbol)

74− (schemas :: SchemasType)

75− (constraint :: TableConstraint)

76− = UnsafeTableConstraintExpression

77− { renderTableConstraintExpression :: ByteString }

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

79−instance RenderSQL

80− (TableConstraintExpression sch tab schemas constraint) where

81− renderSQL = renderTableConstraintExpression

82−

83−{-| A `check` constraint is the most generic `TableConstraint` type.

84−It allows you to specify that the value in a certain column must satisfy

85−a Boolean (truth-value) expression.

86−

87−>>> :{

88−type Schema = '[

89− "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[

90− "a" ::: 'NoDef :=> 'NotNull 'PGint4,

91− "b" ::: 'NoDef :=> 'NotNull 'PGint4

92− ])]

93−:}

94−

95−>>> :{

96−let

97− definition :: Definition (Public '[]) (Public Schema)

98− definition = createTable #tab

99− ( (int & notNullable) `as` #a :*

100− (int & notNullable) `as` #b )

101− ( check (#a :* #b) (#a .> #b) `as` #inequality )

102−:}

103−

104−>>> printSQL definition

105−CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));

106−-}

107−check

108− :: ( Has sch schemas schema

109− , Has tab schema ('Table table)

110− , HasAll aliases (TableToRow table) subcolumns )

111− => NP Alias aliases

112− -- ^ specify the subcolumns which are getting checked

113− -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])

114− -- ^ a closed `Condition` on those subcolumns

115− -> TableConstraintExpression sch tab schemas ('Check aliases)

116−check _cols condition = UnsafeTableConstraintExpression $

117− "CHECK" <+> parenthesized (renderSQL condition)

118−

119−{-| A `unique` constraint ensure that the data contained in a column,

120−or a group of columns, is unique among all the rows in the table.

121−

122−>>> :{

123−type Schema = '[

124− "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[

125− "a" ::: 'NoDef :=> 'Null 'PGint4,

126− "b" ::: 'NoDef :=> 'Null 'PGint4

127− ])]

128−:}

129−

130−>>> :{

131−let

132− definition :: Definition (Public '[]) (Public Schema)

133− definition = createTable #tab

134− ( (int & nullable) `as` #a :*

135− (int & nullable) `as` #b )

136− ( unique (#a :* #b) `as` #uq_a_b )

137−:}

138−

139−>>> printSQL definition

140−CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));

141−-}

142−unique

143− :: ( Has sch schemas schema

144− , Has tab schema('Table table)

145− , HasAll aliases (TableToRow table) subcolumns )

146− => NP Alias aliases

147− -- ^ specify subcolumns which together are unique for each row

148− -> TableConstraintExpression sch tab schemas ('Unique aliases)

149−unique columns = UnsafeTableConstraintExpression $

150− "UNIQUE" <+> parenthesized (renderSQL columns)

151−

152−{-| A `primaryKey` constraint indicates that a column, or group of columns,

153−can be used as a unique identifier for rows in the table.

154−This requires that the values be both unique and not null.

155−

156−>>> :{

157−type Schema = '[

158− "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[

159− "id" ::: 'Def :=> 'NotNull 'PGint4,

160− "name" ::: 'NoDef :=> 'NotNull 'PGtext

161− ])]

162−:}

163−

164−>>> :{

165−let

166− definition :: Definition (Public '[]) (Public Schema)

167− definition = createTable #tab

168− ( serial `as` #id :*

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

170− ( primaryKey #id `as` #pk_id )

171−:}

172−

173−>>> printSQL definition

174−CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));

175−-}

176−primaryKey

177− :: ( Has sch schemas schema

178− , Has tab schema ('Table table)

179− , HasAll aliases (TableToColumns table) subcolumns

180− , AllNotNull subcolumns )

181− => NP Alias aliases

182− -- ^ specify the subcolumns which together form a primary key.

183− -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)

184−primaryKey columns = UnsafeTableConstraintExpression $

185− "PRIMARY KEY" <+> parenthesized (renderSQL columns)

186−

187−{-| A `foreignKey` specifies that the values in a column

188−(or a group of columns) must match the values appearing in some row of

189−another table. We say this maintains the referential integrity

190−between two related tables.

191−

192−>>> :{

193−type Schema =

194− '[ "users" ::: 'Table (

195− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

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

197− , "name" ::: 'NoDef :=> 'NotNull 'PGtext

198− ])

199− , "emails" ::: 'Table (

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

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

202− ] :=>

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

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

205− , "email" ::: 'NoDef :=> 'Null 'PGtext

206− ])

207− ]

208−:}

209−

210−>>> :{

211−let

212− setup :: Definition (Public '[]) (Public Schema)

213− setup =

214− createTable #users

215− ( serial `as` #id :*

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

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

218− createTable #emails

219− ( serial `as` #id :*

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

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

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

223− foreignKey #user_id #users #id

224− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

225−in printSQL setup

226−:}

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

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

229−

230−A `foreignKey` can even be a table self-reference.

231−

232−>>> :{

233−type Schema =

234− '[ "employees" ::: 'Table (

235− '[ "employees_pk" ::: 'PrimaryKey '["id"]

236− , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]

237− ] :=>

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

239− , "name" ::: 'NoDef :=> 'NotNull 'PGtext

240− , "employer_id" ::: 'NoDef :=> 'Null 'PGint4

241− ])

242− ]

243−:}

244−

245−>>> :{

246−let

247− setup :: Definition (Public '[]) (Public Schema)

248− setup =

249− createTable #employees

250− ( serial `as` #id :*

251− (text & notNullable) `as` #name :*

252− (integer & nullable) `as` #employer_id )

253− ( primaryKey #id `as` #employees_pk :*

254− foreignKey #employer_id #employees #id

255− OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )

256−in printSQL setup

257−:}

258−CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE);

259−-}

260−foreignKey

261− :: (ForeignKeyed schemas sch schema child parent

262− table reftable

263− columns refcolumns

264− constraints cols

265− reftys tys )

266− => NP Alias columns

267− -- ^ column or columns in the table

268− -> Alias parent

269− -- ^ reference table

270− -> NP Alias refcolumns

271− -- ^ reference column or columns in the reference table

272− -> OnDeleteClause

273− -- ^ what to do when reference is deleted

274− -> OnUpdateClause

275− -- ^ what to do when reference is updated

276− -> TableConstraintExpression sch child schemas

277− ('ForeignKey columns parent refcolumns)

278−foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $

279− "FOREIGN KEY" <+> parenthesized (renderSQL keys)

280− <+> "REFERENCES" <+> renderSQL parent

281− <+> parenthesized (renderSQL refs)

282− <+> renderSQL ondel

283− <+> renderSQL onupd

284−

285−-- | A constraint synonym between types involved in a foreign key constraint.

286−type ForeignKeyed schemas

287− sch

288− schema

289− child parent

290− table reftable

291− columns refcolumns

292− constraints cols

293− reftys tys =

294− ( Has sch schemas schema

295− , Has child schema ('Table table)

296− , Has parent schema ('Table reftable)

297− , HasAll columns (TableToColumns table) tys

298− , reftable ~ (constraints :=> cols)

299− , HasAll refcolumns cols reftys

300− , SOP.AllZip SamePGType tys reftys

301− , Uniquely refcolumns constraints )

302−

303−-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.

304−data OnDeleteClause

305− = OnDeleteNoAction

306− -- ^ if any referencing rows still exist when the constraint is checked,

307− -- an error is raised

308− | OnDeleteRestrict -- ^ prevents deletion of a referenced row

309− | OnDeleteCascade

310− -- ^ specifies that when a referenced row is deleted,

311− -- row(s) referencing it should be automatically deleted as well

312− deriving (GHC.Generic,Show,Eq,Ord)

313−instance NFData OnDeleteClause

314−-- | Render `OnDeleteClause`.

315−instance RenderSQL OnDeleteClause where

316− renderSQL = \case

317− OnDeleteNoAction -> "ON DELETE NO ACTION"

318− OnDeleteRestrict -> "ON DELETE RESTRICT"

319− OnDeleteCascade -> "ON DELETE CASCADE"

320−

321−-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked

322−-- when a referenced column is changed (updated).

323−data OnUpdateClause

324− = OnUpdateNoAction

325− -- ^ if any referencing rows has not changed when the constraint is checked,

326− -- an error is raised

327− | OnUpdateRestrict -- ^ prevents update of a referenced row

328− | OnUpdateCascade

329− -- ^ the updated values of the referenced column(s) should be copied

330− -- into the referencing row(s)

331− deriving (GHC.Generic,Show,Eq,Ord)

332−instance NFData OnUpdateClause

333−

334−-- | Render `OnUpdateClause`.

335−instance RenderSQL OnUpdateClause where

336− renderSQL = \case

337− OnUpdateNoAction -> "ON UPDATE NO ACTION"

338− OnUpdateRestrict -> "ON UPDATE RESTRICT"

339− OnUpdateCascade -> "ON UPDATE CASCADE"

squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hsdeleted−229

@@ -1,229 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Definition.Type

3−Description: Create and drop type definitions

4−Copyright: (c) Eitan Chatav, 2017

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Create and drop type definitions.

9−-}

10−

11−{-# LANGUAGE

12− AllowAmbiguousTypes

13− , ConstraintKinds

14− , DeriveAnyClass

15− , DeriveGeneric

16− , DerivingStrategies

17− , FlexibleContexts

18− , FlexibleInstances

19− , GADTs

20− , LambdaCase

21− , MultiParamTypeClasses

22− , OverloadedLabels

23− , OverloadedStrings

24− , RankNTypes

25− , ScopedTypeVariables

26− , TypeApplications

27− , TypeInType

28− , TypeOperators

29− , UndecidableSuperClasses

30−#-}

31−

32−module Squeal.PostgreSQL.Definition.Type

33− ( createTypeEnum

34− , createTypeEnumFrom

35− , createTypeComposite

36− , createTypeCompositeFrom

37− , createTypeRange

38− , createDomain

39− , dropType

40− , dropTypeIfExists

41− ) where

42−

43−import Data.ByteString

44−import Data.Monoid

45−import GHC.TypeLits

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

47−

48−import qualified Generics.SOP as SOP

49−

50−import Squeal.PostgreSQL.Alias

51−import Squeal.PostgreSQL.Expression.Logic

52−import Squeal.PostgreSQL.Expression.Type

53−import Squeal.PostgreSQL.Definition

54−import Squeal.PostgreSQL.List

55−import Squeal.PostgreSQL.PG

56−import Squeal.PostgreSQL.Render

57−import Squeal.PostgreSQL.Schema

58−

59−-- $setup

60−-- >>> import Squeal.PostgreSQL

61−-- >>> import qualified GHC.Generics as GHC

62−-- >>> import qualified Generics.SOP as SOP

63−

64−-- | Enumerated types are created using the `createTypeEnum` command, for example

65−--

66−-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])

67−-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');

68−createTypeEnum

69− :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)

70− => QualifiedAlias sch enum

71− -- ^ name of the user defined enumerated type

72− -> NP PGlabel labels

73− -- ^ labels of the enumerated type

74− -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)

75−createTypeEnum enum labels = UnsafeDefinition $

76− "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>

77− parenthesized (renderSQL labels) <> ";"

78−

79−-- | Enumerated types can also be generated from a Haskell type, for example

80−--

81−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic

82−-- >>> instance SOP.Generic Schwarma

83−-- >>> instance SOP.HasDatatypeInfo Schwarma

84−-- >>> :{

85−-- let

86−-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]

87−-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma

88−-- in

89−-- printSQL createSchwarma

90−-- :}

91−-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');

92−createTypeEnumFrom

93− :: forall hask sch enum schemas schema.

94− ( SOP.Generic hask

95− , SOP.All KnownSymbol (LabelsPG hask)

96− , KnownSymbol enum

97− , Has sch schemas schema )

98− => QualifiedAlias sch enum

99− -- ^ name of the user defined enumerated type

100− -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)

101−createTypeEnumFrom enum = createTypeEnum enum

102− (SOP.hpure label :: NP PGlabel (LabelsPG hask))

103−

104−{- | `createTypeComposite` creates a composite type. The composite type is

105−specified by a list of attribute names and data types.

106−

107−>>> :{

108−type PGcomplex = 'PGcomposite

109− '[ "real" ::: 'NotNull 'PGfloat8

110− , "imaginary" ::: 'NotNull 'PGfloat8 ]

111−:}

112−

113−>>> :{

114−let

115− setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]

116− setup = createTypeComposite #complex

117− (float8 `as` #real :* float8 `as` #imaginary)

118−in printSQL setup

119−:}

120−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);

121−-}

122−createTypeComposite

123− :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)

124− => QualifiedAlias sch ty

125− -- ^ name of the user defined composite type

126− -> NP (Aliased (TypeExpression schemas)) fields

127− -- ^ list of attribute names and data types

128− -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)

129−createTypeComposite ty fields = UnsafeDefinition $

130− "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized

131− (renderCommaSeparated renderField fields) <> ";"

132− where

133− renderField :: Aliased (TypeExpression schemas) x -> ByteString

134− renderField (typ `As` alias) =

135− renderSQL alias <+> renderSQL typ

136−

137−-- | Composite types can also be generated from a Haskell type, for example

138−--

139−-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic

140−-- >>> instance SOP.Generic Complex

141−-- >>> instance SOP.HasDatatypeInfo Complex

142−-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]

143−-- >>> :{

144−-- let

145−-- createComplex :: Definition (Public '[]) (Public Schema)

146−-- createComplex = createTypeCompositeFrom @Complex #complex

147−-- in

148−-- printSQL createComplex

149−-- :}

150−-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);

151−createTypeCompositeFrom

152− :: forall hask sch ty schemas schema.

153− ( SOP.All (FieldTyped schemas) (RowPG hask)

154− , KnownSymbol ty

155− , Has sch schemas schema )

156− => QualifiedAlias sch ty

157− -- ^ name of the user defined composite type

158− -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)

159−createTypeCompositeFrom ty = createTypeComposite ty

160− (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype

161− :: NP (Aliased (TypeExpression schemas)) (RowPG hask))

162−

163−{-|

164−`createDomain` creates a new domain. A domain is essentially a data type

165−with constraints (restrictions on the allowed set of values).

166−

167−Domains are useful for abstracting common constraints on fields

168−into a single location for maintenance. For example, several tables might

169−contain email address columns, all requiring the same `check` constraint

170−to verify the address syntax. Define a domain rather than setting up

171−each table's constraint individually.

172−

173−>>> :{

174−let

175− createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])

176− createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))

177−in printSQL createPositive

178−:}

179−CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));

180−-}

181−createDomain

182− :: (Has sch schemas schema, KnownSymbol dom)

183− => QualifiedAlias sch dom

184− -> (forall null. TypeExpression schemas (null ty))

185− -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])

186− -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)

187−createDomain dom ty condition =

188− UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom

189− <+> "AS" <+> renderTypeExpression ty

190− <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"

191−

192−{- |

193−>>> :{

194−let

195− createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)])

196− createSmallIntRange = createTypeRange #int2range int2

197−in printSQL createSmallIntRange

198−:}

199−CREATE TYPE "int2range" AS RANGE (subtype = int2);

200−-}

201−createTypeRange

202− :: (Has sch schemas schema, KnownSymbol range)

203− => QualifiedAlias sch range

204− -> (forall null. TypeExpression schemas (null ty))

205− -> Definition schemas (Alter sch (Create range ('Typedef ('PGrange ty)) schema) schemas)

206−createTypeRange range ty = UnsafeDefinition $

207− "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>

208− parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";"

209−

210−-- | Drop a type.

211−--

212−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic

213−-- >>> instance SOP.Generic Schwarma

214−-- >>> instance SOP.HasDatatypeInfo Schwarma

215−-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))

216−-- DROP TYPE "schwarma";

217−dropType

218− :: (Has sch schemas schema, KnownSymbol td)

219− => QualifiedAlias sch td

220− -- ^ name of the user defined type

221− -> Definition schemas (Alter sch (DropSchemum td 'Typedef schema) schemas)

222−dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"

223−

224−dropTypeIfExists

225− :: (Has sch schemas schema, KnownSymbol td)

226− => QualifiedAlias sch td

227− -- ^ name of the user defined type

228− -> Definition schemas (Alter sch (DropSchemumIfExists td 'Typedef schema) schemas)

229−dropTypeIfExists tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"

squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hsdeleted−104

@@ -1,104 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Definition.View

3−Description: Create and drop view definitions

4−Copyright: (c) Eitan Chatav, 2017

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Create and drop view definitions.

9−-}

10−

11−{-# LANGUAGE

12− AllowAmbiguousTypes

13− , ConstraintKinds

14− , DeriveAnyClass

15− , DeriveGeneric

16− , DerivingStrategies

17− , FlexibleContexts

18− , FlexibleInstances

19− , GADTs

20− , LambdaCase

21− , MultiParamTypeClasses

22− , OverloadedLabels

23− , OverloadedStrings

24− , RankNTypes

25− , ScopedTypeVariables

26− , TypeApplications

27− , TypeInType

28− , TypeOperators

29− , UndecidableSuperClasses

30−#-}

31−

32−module Squeal.PostgreSQL.Definition.View

33− ( createView

34− , createOrReplaceView

35− , dropView

36− , dropViewIfExists

37− ) where

38−

39−import GHC.TypeLits

40−

41−import Squeal.PostgreSQL.Alias

42−import Squeal.PostgreSQL.Definition

43−import Squeal.PostgreSQL.Query

44−import Squeal.PostgreSQL.Render

45−import Squeal.PostgreSQL.Schema

46−

47−-- $setup

48−-- >>> import Squeal.PostgreSQL

49−

50−{- | Create a view.

51−>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]

52−>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]

53−>>> :{

54−let

55− definition :: Definition

56− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]

57− '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]

58− definition =

59− createView #bc (select_ (#b :* #c) (from (table #abc)))

60−in printSQL definition

61−:}

62−CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";

63−-}

64−createView

65− :: (Has sch schemas schema, KnownSymbol vw)

66− => QualifiedAlias sch vw -- ^ the name of the view to add

67− -> Query '[] '[] schemas '[] view -- ^ query

68− -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)

69−createView alias query = UnsafeDefinition $

70− "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"

71− <+> renderQuery query <> ";"

72−

73−createOrReplaceView

74− :: (Has sch schemas schema, KnownSymbol vw)

75− => QualifiedAlias sch vw -- ^ the name of the view to add

76− -> Query '[] '[] schemas '[] view -- ^ query

77− -> Definition schemas (Alter sch (CreateOrReplace vw ('View view) schema) schemas)

78−createOrReplaceView alias query = UnsafeDefinition $

79− "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS"

80− <+> renderQuery query <> ";"

81−

82−-- | Drop a view.

83−--

84−-- >>> :{

85−-- let

86−-- definition :: Definition

87−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])

88−-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]

89−-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]

90−-- definition = dropView #bc

91−-- in printSQL definition

92−-- :}

93−-- DROP VIEW "bc";

94−dropView

95− :: (Has sch schemas schema, KnownSymbol vw)

96− => QualifiedAlias sch vw -- ^ view to remove

97− -> Definition schemas (Alter sch (DropSchemum vw 'View schema) schemas)

98−dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"

99−

100−dropViewIfExists

101− :: (Has sch schemas schema, KnownSymbol vw)

102− => QualifiedAlias sch vw -- ^ view to remove

103− -> Definition schemas (Alter sch (DropIfExists vw schema) schemas)

104−dropViewIfExists vw = UnsafeDefinition $ "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";"

squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+17−91

@@ -34,26 +34,17 @@ module Squeal.PostgreSQL.Expression

3434 ( -- * Expression

3535 Expression (..)

3636 , Expr

37− , type (-->)

38− , FunctionDB

37+ , (:-->)

3938 , unsafeFunction

40− , function

41− , unsafeLeftOp

42− , leftOp

43− , unsafeRightOp

44− , rightOp

39+ , unsafeUnaryOpL

40+ , unsafeUnaryOpR

4541 , Operator

46− , OperatorDB

4742 , unsafeBinaryOp

48− , binaryOp

4943 , FunctionVar

5044 , unsafeFunctionVar

51− , type (--->)

52− , FunctionNDB

45+ , FunctionN

5346 , unsafeFunctionN

54− , functionN

5547 , PGSubset (..)

56− , PGIntersect (..)

5748 -- * Re-export

5849 , (&)

5950 , K (..)

@@ -145,54 +136,31 @@ type Operator x1 x2 y

145136 -> Expression outer commons grp schemas params from y

146137 -- ^ output

147138

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−

157139-- | A @RankNType@ for functions with a single argument.

158140-- These could be either function calls or unary operators.

159141-- This is a subtype of the usual Haskell function type `Prelude.->`,

160142-- indeed a subcategory as it is closed under the usual

161143-- `Prelude..` and `Prelude.id`.

162−type (-->) x y

144+type (:-->) x y

163145 = forall outer commons grp schemas params from

164146 . Expression outer commons grp schemas params from x

165147 -- ^ input

166148 -> Expression outer commons grp schemas params from y

167149 -- ^ output

168150

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−

176151{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.

177152Use the `*:` operator to end your argument lists, like so.

178153

179154>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))

180155fun(TRUE, FALSE, LOCALTIME, TRUE)

181156-}

182−type (--->) xs y

157+type FunctionN xs y

183158 = forall outer commons grp schemas params from

184159 . NP (Expression outer commons grp schemas params from) xs

185160 -- ^ inputs

186161 -> Expression outer commons grp schemas params from y

187162 -- ^ output

188163

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−

196164{- | A @RankNType@ for functions with a variable-length list of

197165homogeneous arguments and at least 1 more argument.

198166-}

@@ -318,63 +286,28 @@ unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2

318286unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $

319287 renderSQL x <+> op <+> renderSQL y

320288

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

289+-- | >>> printSQL $ unsafeUnaryOpL "NOT" true

329290-- (NOT TRUE)

330−unsafeLeftOp :: ByteString -> x --> y

331−unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x

291+unsafeUnaryOpL :: ByteString -> x :--> y

292+unsafeUnaryOpL op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x

332293

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"

294+-- | >>> printSQL $ true & unsafeUnaryOpR "IS NOT TRUE"

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

296+unsafeUnaryOpR :: ByteString -> x :--> y

297+unsafeUnaryOpR op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op

351298

352299-- | >>> printSQL $ unsafeFunction "f" true

353300-- f(TRUE)

354−unsafeFunction :: ByteString -> x --> y

301+unsafeFunction :: ByteString -> x :--> y

355302unsafeFunction fun x = UnsafeExpression $

356303 fun <> parenthesized (renderSQL x)

357304

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−

364305-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')

365306-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')

366−unsafeFunctionN :: SListI xs => ByteString -> xs ---> y

307+unsafeFunctionN :: SListI xs => ByteString -> FunctionN xs y

367308unsafeFunctionN fun xs = UnsafeExpression $

368309 fun <> parenthesized (renderCommaSeparated renderSQL xs)

369310

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−

378311instance ty `In` PGNum

379312 => Num (Expression outer commons grp schemas params from (null ty)) where

380313 (+) = unsafeBinaryOp "+"

@@ -420,21 +353,14 @@ instance (ty `In` PGNum, ty `In` PGFloating) => Floating

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

421354

422355-- | Contained by operators

423−class PGSubset ty where

424− (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

356+class PGSubset container where

357+ (@>) :: Operator (null0 container) (null1 container) ('Null 'PGbool)

425358 (@>) = unsafeBinaryOp "@>"

426− (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

359+ (<@) :: Operator (null0 container) (null1 container) ('Null 'PGbool)

427360 (<@) = unsafeBinaryOp "<@"

428361instance PGSubset 'PGjsonb

429362instance PGSubset 'PGtsquery

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

438364

439365instance IsString

440366 (Expression outer commons grp schemas params from (null 'PGtext)) where

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hs+4−19

@@ -26,7 +26,6 @@ Aggregate functions

2626module Squeal.PostgreSQL.Expression.Aggregate

2727 ( Aggregate (..)

2828 , Distinction (..)

29− , PGSum

3029 , PGAvg

3130 ) where

3231

@@ -80,14 +79,15 @@ class Aggregate expr1 exprN aggr

8079

8180 -- | >>> :{

8281 -- let

83− -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric)

82+ -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('NotNull 'PGnumeric)

8483 -- expression = sum_ (Distinct #col)

8584 -- in printSQL expression

8685 -- :}

8786 -- sum(DISTINCT "col")

8887 sum_

89− :: expr1 (null ty)

90− -> aggr ('Null (PGSum ty))

88+ :: ty `In` PGNum

89+ => expr1 (null ty)

90+ -> aggr ('NotNull ty)

9191

9292 -- | input values, including nulls, concatenated into an array

9393 arrayAgg

@@ -434,21 +434,6 @@ unsafeAggregateN

434434 -> Expression outer commons ('Grouped bys) schemas params from y

435435unsafeAggregateN fun xs = UnsafeExpression $ fun <> parenthesized (renderSQL xs)

436436

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−

452437-- | A type family that calculates `PGAvg` type of a `PGType`.

453438type family PGAvg ty where

454439 PGAvg 'PGint2 = 'PGnumeric

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hs+5−15

@@ -1,13 +1,3 @@

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−

111{-# LANGUAGE

122 AllowAmbiguousTypes

133 , DataKinds

@@ -42,7 +32,7 @@ import qualified Generics.SOP as SOP

4232

4333import Squeal.PostgreSQL.Alias

4434import Squeal.PostgreSQL.Expression

45−import Squeal.PostgreSQL.Expression.Set

35+import Squeal.PostgreSQL.Expression.SetOf

4636import Squeal.PostgreSQL.List

4737import Squeal.PostgreSQL.Render

4838import Squeal.PostgreSQL.Schema

@@ -111,20 +101,20 @@ array2 xss = UnsafeExpression $ "ARRAY" <>

111101

112102-- | >>> printSQL $ cardinality (array [null_, false, true])

113103-- cardinality(ARRAY[NULL, FALSE, TRUE])

114−cardinality :: null ('PGvararray ty) --> null 'PGint8

104+cardinality :: null ('PGvararray ty) :--> null 'PGint8

115105cardinality = unsafeFunction "cardinality"

116106

117107-- | >>> printSQL $ array [null_, false, true] & index 2

118108-- (ARRAY[NULL, FALSE, TRUE])[2]

119109index

120110 :: Word64 -- ^ index

121− -> null ('PGvararray ty) --> NullifyType ty

111+ -> null ('PGvararray ty) :--> NullifyType ty

122112index n expr = UnsafeExpression $

123113 parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"

124114

125115-- | Expand an array to a set of rows

126−unnest :: SetFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]

127−unnest = unsafeSetFunction

116+unnest :: SetOfFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]

117+unnest = unsafeSetOfFunction

128118

129119-- | A row constructor is an expression that builds a row value

130120-- (also called a composite value) using values for its member fields.

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs+12−12

@@ -162,45 +162,45 @@ isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"

162162>>> printSQL $ true & isTrue

163163(TRUE IS TRUE)

164164-}

165−isTrue :: null0 'PGbool --> null1 'PGbool

166−isTrue = unsafeRightOp "IS TRUE"

165+isTrue :: null0 'PGbool :--> null1 'PGbool

166+isTrue = unsafeUnaryOpR "IS TRUE"

167167

168168{- | is false or unknown

169169

170170>>> printSQL $ true & isNotTrue

171171(TRUE IS NOT TRUE)

172172-}

173−isNotTrue :: null0 'PGbool --> null1 'PGbool

174−isNotTrue = unsafeRightOp "IS NOT TRUE"

173+isNotTrue :: null0 'PGbool :--> null1 'PGbool

174+isNotTrue = unsafeUnaryOpR "IS NOT TRUE"

175175

176176{- | is false

177177

178178>>> printSQL $ true & isFalse

179179(TRUE IS FALSE)

180180-}

181−isFalse :: null0 'PGbool --> null1 'PGbool

182−isFalse = unsafeRightOp "IS FALSE"

181+isFalse :: null0 'PGbool :--> null1 'PGbool

182+isFalse = unsafeUnaryOpR "IS FALSE"

183183

184184{- | is true or unknown

185185

186186>>> printSQL $ true & isNotFalse

187187(TRUE IS NOT FALSE)

188188-}

189−isNotFalse :: null0 'PGbool --> null1 'PGbool

190−isNotFalse = unsafeRightOp "IS NOT FALSE"

189+isNotFalse :: null0 'PGbool :--> null1 'PGbool

190+isNotFalse = unsafeUnaryOpR "IS NOT FALSE"

191191

192192{- | is unknown

193193

194194>>> printSQL $ true & isUnknown

195195(TRUE IS UNKNOWN)

196196-}

197−isUnknown :: null0 'PGbool --> null1 'PGbool

198−isUnknown = unsafeRightOp "IS UNKNOWN"

197+isUnknown :: null0 'PGbool :--> null1 'PGbool

198+isUnknown = unsafeUnaryOpR "IS UNKNOWN"

199199

200200{- | is true or false

201201

202202>>> printSQL $ true & isNotUnknown

203203(TRUE IS NOT UNKNOWN)

204204-}

205−isNotUnknown :: null0 'PGbool --> null1 'PGbool

206−isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"

205+isNotUnknown :: null0 'PGbool :--> null1 'PGbool

206+isNotUnknown = unsafeUnaryOpR "IS NOT UNKNOWN"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hs+175−109

@@ -1,13 +1,3 @@

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−

111{-# LANGUAGE

122 DataKinds

133 , FlexibleContexts

@@ -21,7 +11,6 @@ Json and Jsonb functions and operators

2111 , TypeApplications

2212 , TypeOperators

2313 , UndecidableInstances

24− , UndecidableSuperClasses

2514#-}

2615

2716module Squeal.PostgreSQL.Expression.Json

@@ -43,13 +32,19 @@ module Squeal.PostgreSQL.Expression.Json

4332 , rowToJson

4433 , jsonBuildArray

4534 , jsonbBuildArray

46− , JsonBuildObject (..)

35+ , PGBuildObject

36+ , jsonBuildObject

37+ , jsonbBuildObject

4738 , jsonObject

4839 , jsonbObject

4940 , jsonZipObject

5041 , jsonbZipObject

5142 , jsonArrayLength

5243 , jsonbArrayLength

44+ , jsonExtractPath

45+ , jsonbExtractPath

46+ , jsonExtractPathAsText

47+ , jsonbExtractPathAsText

5348 , jsonTypeof

5449 , jsonbTypeof

5550 , jsonStripNulls

@@ -64,12 +59,10 @@ module Squeal.PostgreSQL.Expression.Json

6459 , jsonbEachText

6560 , jsonObjectKeys

6661 , jsonbObjectKeys

67− , JsonPopulateFunction

6862 , jsonPopulateRecord

6963 , jsonbPopulateRecord

7064 , jsonPopulateRecordSet

7165 , jsonbPopulateRecordSet

72− , JsonToRecordFunction

7366 , jsonToRecord

7467 , jsonbToRecord

7568 , jsonToRecordSet

@@ -81,7 +74,7 @@ import GHC.TypeLits

8174

8275import Squeal.PostgreSQL.Alias

8376import Squeal.PostgreSQL.Expression

84−import Squeal.PostgreSQL.Expression.Set

77+import Squeal.PostgreSQL.Expression.SetOf

8578import Squeal.PostgreSQL.Expression.Type

8679import Squeal.PostgreSQL.List

8780import Squeal.PostgreSQL.Query

@@ -156,18 +149,18 @@ infixl 9 .?&

156149

157150-- | Delete a key or keys from a JSON object, or remove an array element.

158151--

159−-- If the right operand is

152+-- If the right operand is..

160153--

161−-- @ text @: Delete key / value pair or string element from left operand.

162−-- Key / value pairs are matched based on their key value,

154+-- @ text @: Delete key/value pair or string element from left operand. Key/value pairs

155+-- are matched based on their key value.

163156--

164−-- @ text[] @: Delete multiple key / value pairs or string elements

165−-- from left operand. Key / value pairs are matched based on their key value,

157+-- @ text[] @: Delete multiple key/value pairs or string elements

158+-- from left operand. Key/value pairs are matched based on their key value.

166159--

167160-- @ integer @: Delete the array element with specified index (Negative integers

168161-- count from the end). Throws an error if top level container is not an array.

169162(.-.)

170− :: key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]

163+ :: (key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]) -- hlint error without parens here

171164 => Operator (null 'PGjsonb) (null key) (null 'PGjsonb)

172165infixl 6 .-.

173166(.-.) = unsafeBinaryOp "-"

@@ -188,7 +181,7 @@ Table 9.45: JSON creation functions

188181-- otherwise, a scalar value is produced. For any scalar type other than a

189182-- number, a Boolean, or a null value, the text representation will be used, in

190183-- such a fashion that it is a valid json value.

191−toJson :: null ty --> null 'PGjson

184+toJson :: null ty :--> null 'PGjson

192185toJson = unsafeFunction "to_json"

193186

194187-- | Returns the value as jsonb. Arrays and composites are converted

@@ -197,42 +190,48 @@ toJson = unsafeFunction "to_json"

197190-- otherwise, a scalar value is produced. For any scalar type other than a

198191-- number, a Boolean, or a null value, the text representation will be used, in

199192-- such a fashion that it is a valid jsonb value.

200−toJsonb :: null ty --> null 'PGjsonb

193+toJsonb :: null ty :--> null 'PGjsonb

201194toJsonb = unsafeFunction "to_jsonb"

202195

203196-- | Returns the array as a JSON array. A PostgreSQL multidimensional array

204197-- becomes a JSON array of arrays.

205−arrayToJson :: null ('PGvararray ty) --> null 'PGjson

198+arrayToJson :: null ('PGvararray ty) :--> null 'PGjson

206199arrayToJson = unsafeFunction "array_to_json"

207200

208201-- | Returns the row as a JSON object.

209−rowToJson :: null ('PGcomposite ty) --> null 'PGjson

202+rowToJson :: null ('PGcomposite ty) :--> null 'PGjson

210203rowToJson = unsafeFunction "row_to_json"

211204

212205-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic

213206-- argument list.

214−jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson

207+jsonBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjson)

215208jsonBuildArray = unsafeFunctionN "json_build_array"

216209

217210-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a

218211-- variadic argument list.

219−jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb

212+jsonbBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjsonb)

220213jsonbBuildArray = unsafeFunctionN "jsonb_build_array"

221214

215+class PGBuildObject tys where

216+instance PGBuildObject '[]

217+instance (PGBuildObject tys, key `In` PGJsonKey)

218+ => PGBuildObject ('NotNull key ': value ': tys)

219+

222220-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic

223221-- argument list. The elements of the argument list must alternate between text

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

223+jsonBuildObject

224+ :: (SOP.SListI elems, PGBuildObject elems)

225+ => FunctionN elems (null 'PGjson)

226+jsonBuildObject = unsafeFunctionN "json_build_object"

227+

228+-- | Builds a possibly-heterogeneously-typed (binary) JSON object out of a

229+-- variadic argument list. The elements of the argument list must alternate

230+-- between keys and values.

231+jsonbBuildObject

232+ :: (SOP.SListI elems, PGBuildObject elems)

233+ => FunctionN elems (null 'PGjsonb)

234+jsonbBuildObject = unsafeFunctionN "jsonb_build_object"

236235

237236-- | Builds a JSON object out of a text array.

238237-- The array must have two dimensions

@@ -240,7 +239,7 @@ instance (JsonBuildObject tys, key `In` PGJsonKey)

240239-- which are taken as a key/value pair.

241240jsonObject

242241 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))

243− --> null 'PGjson

242+ :--> null 'PGjson

244243jsonObject = unsafeFunction "json_object"

245244

246245-- | Builds a binary JSON object out of a text array.

@@ -249,24 +248,24 @@ jsonObject = unsafeFunction "json_object"

249248-- which are taken as a key/value pair.

250249jsonbObject

251250 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))

252− --> null 'PGjsonb

251+ :--> null 'PGjsonb

253252jsonbObject = unsafeFunction "jsonb_object"

254253

255254-- | This is an alternate form of 'jsonObject' that takes two arrays; one for

256255-- keys and one for values, that are zipped pairwise to create a JSON object.

257−jsonZipObject ::

256+jsonZipObject :: FunctionN

258257 '[ null ('PGvararray ('NotNull 'PGtext))

259258 , null ('PGvararray ('NotNull 'PGtext)) ]

260− ---> null 'PGjson

259+ ( null 'PGjson )

261260jsonZipObject = unsafeFunctionN "json_object"

262261

263262-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for

264263-- keys and one for values, that are zipped pairwise to create a binary JSON

265264-- object.

266−jsonbZipObject ::

265+jsonbZipObject :: FunctionN

267266 '[ null ('PGvararray ('NotNull 'PGtext))

268267 , null ('PGvararray ('NotNull 'PGtext)) ]

269− ---> null 'PGjsonb

268+ ( null 'PGjsonb )

270269jsonbZipObject = unsafeFunctionN "jsonb_object"

271270

272271{-----------------------------------------

@@ -274,72 +273,121 @@ Table 9.46: JSON processing functions

274273-----------------------------------------}

275274

276275-- | Returns the number of elements in the outermost JSON array.

277−jsonArrayLength :: null 'PGjson --> null 'PGint4

276+jsonArrayLength :: null 'PGjson :--> null 'PGint4

278277jsonArrayLength = unsafeFunction "json_array_length"

279278

280279-- | Returns the number of elements in the outermost binary JSON array.

281−jsonbArrayLength :: null 'PGjsonb --> null 'PGint4

280+jsonbArrayLength :: null 'PGjsonb :--> null 'PGint4

282281jsonbArrayLength = unsafeFunction "jsonb_array_length"

283282

283+-- | Returns JSON value pointed to by the given path (equivalent to #>

284+-- operator).

285+jsonExtractPath

286+ :: SOP.SListI elems

287+ => Expression outer commons grp schemas params from (null 'PGjson)

288+ -> NP (Expression outer commons grp schemas params from) elems

289+ -> Expression outer commons grp schemas params from (null 'PGjsonb)

290+jsonExtractPath x xs =

291+ unsafeFunctionN "json_extract_path" (x :* xs)

292+

293+-- | Returns JSON value pointed to by the given path (equivalent to #>

294+-- operator).

295+jsonbExtractPath

296+ :: SOP.SListI elems

297+ => Expression outer commons grp schemas params from (null 'PGjsonb)

298+ -> NP (Expression outer commons grp schemas params from) elems

299+ -> Expression outer commons grp schemas params from (null 'PGjsonb)

300+jsonbExtractPath x xs =

301+ unsafeFunctionN "jsonb_extract_path" (x :* xs)

302+

303+-- | Returns JSON value pointed to by the given path (equivalent to #>

304+-- operator), as text.

305+jsonExtractPathAsText

306+ :: SOP.SListI elems

307+ => Expression outer commons grp schemas params from (null 'PGjson)

308+ -> NP (Expression outer commons grp schemas params from) elems

309+ -> Expression outer commons grp schemas params from (null 'PGjson)

310+jsonExtractPathAsText x xs =

311+ unsafeFunctionN "json_extract_path_text" (x :* xs)

312+

313+-- | Returns JSON value pointed to by the given path (equivalent to #>

314+-- operator), as text.

315+jsonbExtractPathAsText

316+ :: SOP.SListI elems

317+ => Expression outer commons grp schemas params from (null 'PGjsonb)

318+ -> NP (Expression outer commons grp schemas params from) elems

319+ -> Expression outer commons grp schemas params from (null 'PGjsonb)

320+jsonbExtractPathAsText x xs =

321+ unsafeFunctionN "jsonb_extract_path_text" (x :* xs)

322+

284323-- | Returns the type of the outermost JSON value as a text string. Possible

285324-- types are object, array, string, number, boolean, and null.

286−jsonTypeof :: null 'PGjson --> null 'PGtext

325+jsonTypeof :: null 'PGjson :--> null 'PGtext

287326jsonTypeof = unsafeFunction "json_typeof"

288327

289328-- | Returns the type of the outermost binary JSON value as a text string.

290329-- Possible types are object, array, string, number, boolean, and null.

291−jsonbTypeof :: null 'PGjsonb --> null 'PGtext

330+jsonbTypeof :: null 'PGjsonb :--> null 'PGtext

292331jsonbTypeof = unsafeFunction "jsonb_typeof"

293332

294333-- | Returns its argument with all object fields that have null values omitted.

295334-- Other null values are untouched.

296−jsonStripNulls :: null 'PGjson --> null 'PGjson

335+jsonStripNulls :: null 'PGjson :--> null 'PGjson

297336jsonStripNulls = unsafeFunction "json_strip_nulls"

298337

299338-- | Returns its argument with all object fields that have null values omitted.

300339-- Other null values are untouched.

301−jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb

340+jsonbStripNulls :: null 'PGjsonb :--> null 'PGjsonb

302341jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"

303342

304343-- | @ jsonbSet target path new_value create_missing @

305344--

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

345+-- Returns target with the section designated by path replaced by new_value,

346+-- or with new_value added if create_missing is true ( default is true) and the

309347-- item designated by path does not exist. As with the path orientated

310348-- operators, negative integers that appear in path count from the end of JSON

311349-- arrays.

312−jsonbSet ::

313− '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))

314− , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb

315−jsonbSet = unsafeFunctionN "jsonbSet"

350+jsonbSet

351+ :: Expression outer commons grp schemas params from (null 'PGjsonb)

352+ -> Expression outer commons grp schemas params from (null ('PGvararray ('NotNull 'PGtext)))

353+ -> Expression outer commons grp schemas params from (null 'PGjsonb)

354+ -> Maybe (Expression outer commons grp schemas params from (null 'PGbool))

355+ -> Expression outer commons grp schemas params from (null 'PGjsonb)

356+jsonbSet tgt path val createMissing = case createMissing of

357+ Just m -> unsafeFunctionN "jsonb_set" (tgt :* path :* val :* m :* Nil)

358+ Nothing -> unsafeFunctionN "jsonb_set" (tgt :* path :* val :* Nil)

316359

317360-- | @ jsonbInsert target path new_value insert_after @

318361--

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

362+-- Returns target with new_value inserted. If target section designated by

363+-- path is in a JSONB array, new_value will be inserted before target or after

364+-- if insert_after is true (default is false). If target section designated by

365+-- path is in JSONB object, new_value will be inserted only if target does not

324366-- exist. As with the path orientated operators, negative integers that appear

325367-- 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"

368+jsonbInsert

369+ :: Expression outer commons grp schemas params from (null 'PGjsonb)

370+ -> Expression outer commons grp schemas params from (null ('PGvararray ('NotNull 'PGtext)))

371+ -> Expression outer commons grp schemas params from (null 'PGjsonb)

372+ -> Maybe (Expression outer commons grp schemas params from (null 'PGbool))

373+ -> Expression outer commons grp schemas params from (null 'PGjsonb)

374+jsonbInsert tgt path val insertAfter = case insertAfter of

375+ Just i -> unsafeFunctionN "jsonb_insert" (tgt :* path :* val :* i :* Nil)

376+ Nothing -> unsafeFunctionN "jsonb_insert" (tgt :* path :* val :* Nil)

330377

331378-- | Returns its argument as indented JSON text.

332−jsonbPretty :: null 'PGjsonb --> null 'PGtext

379+jsonbPretty :: null 'PGjsonb :--> null 'PGtext

333380jsonbPretty = unsafeFunction "jsonb_pretty"

334381

382+

335383{- | Expands the outermost JSON object into a set of key/value pairs.

336384

337385>>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))

338386SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))

339387-}

340−jsonEach :: SetFunction "json_each" (null 'PGjson)

388+jsonEach :: SetOfFunction "json_each" (null 'PGjson)

341389 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]

342−jsonEach = unsafeSetFunction

390+jsonEach = unsafeSetOfFunction

343391

344392{- | Expands the outermost binary JSON object into a set of key/value pairs.

345393

@@ -347,9 +395,9 @@ jsonEach = unsafeSetFunction

347395SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))

348396-}

349397jsonbEach

350− :: SetFunction "jsonb_each" (nullity 'PGjsonb)

398+ :: SetOfFunction "jsonb_each" (nullity 'PGjsonb)

351399 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]

352−jsonbEach = unsafeSetFunction

400+jsonbEach = unsafeSetOfFunction

353401

354402{- | Expands the outermost JSON object into a set of key/value pairs.

355403

@@ -357,9 +405,9 @@ jsonbEach = unsafeSetFunction

357405SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))

358406-}

359407jsonEachText

360− :: SetFunction "json_each_text" (null 'PGjson)

408+ :: SetOfFunction "json_each_text" (null 'PGjson)

361409 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]

362−jsonEachText = unsafeSetFunction

410+jsonEachText = unsafeSetOfFunction

363411

364412{- | Expands the outermost binary JSON object into a set of key/value pairs.

365413

@@ -367,9 +415,9 @@ jsonEachText = unsafeSetFunction

367415SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))

368416-}

369417jsonbEachText

370− :: SetFunction "jsonb_each_text" (null 'PGjsonb)

418+ :: SetOfFunction "jsonb_each_text" (null 'PGjsonb)

371419 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]

372−jsonbEachText = unsafeSetFunction

420+jsonbEachText = unsafeSetOfFunction

373421

374422{- | Returns set of keys in the outermost JSON object.

375423

@@ -377,9 +425,9 @@ jsonbEachText = unsafeSetFunction

377425json_object_keys(('{"a":"foo","b":"bar"}' :: json))

378426-}

379427jsonObjectKeys

380− :: SetFunction "json_object_keys" (nullity 'PGjson)

428+ :: SetOfFunction "json_object_keys" (nullity 'PGjson)

381429 '["json_object_keys" ::: 'NotNull 'PGtext]

382−jsonObjectKeys = unsafeSetFunction

430+jsonObjectKeys = unsafeSetOfFunction

383431

384432{- | Returns set of keys in the outermost JSON object.

385433

@@ -387,57 +435,59 @@ jsonObjectKeys = unsafeSetFunction

387435jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))

388436-}

389437jsonbObjectKeys

390− :: SetFunction "jsonb_object_keys" (null 'PGjsonb)

438+ :: SetOfFunction "jsonb_object_keys" (null 'PGjsonb)

391439 '["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]

440+jsonbObjectKeys = unsafeSetOfFunction

402441

403442unsafePopulateFunction

404− :: forall fun ty

405− . KnownSymbol fun => Alias fun -> JsonPopulateFunction fun ty

443+ :: forall fun schemas null outer commons params ty row

444+ . KnownSymbol fun

445+ => Alias fun

446+ -> TypeExpression schemas (null ('PGcomposite row))

447+ -> Expression outer commons 'Ungrouped schemas params '[] ty

448+ -> FromClause outer commons schemas params '[fun ::: row]

406449unsafePopulateFunction _fun ty expr = UnsafeFromClause $ renderSymbol @fun

407450 <> parenthesized ("null::" <> renderSQL ty <> ", " <> renderSQL expr)

408451

409452-- | Expands the JSON expression to a row whose columns match the record

410453-- type defined by the given table.

411−jsonPopulateRecord :: JsonPopulateFunction "json_populate_record" 'PGjson

454+jsonPopulateRecord

455+ :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type

456+ -> Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json object

457+ -> FromClause outer commons schemas params '["json_populate_record" ::: row]

412458jsonPopulateRecord = unsafePopulateFunction #json_populate_record

413459

414460-- | Expands the binary JSON expression to a row whose columns match the record

415461-- type defined by the given table.

416−jsonbPopulateRecord :: JsonPopulateFunction "jsonb_populate_record" 'PGjsonb

462+jsonbPopulateRecord

463+ :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type

464+ -> Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object

465+ -> FromClause outer commons schemas params '["jsonb_populate_record" ::: row]

417466jsonbPopulateRecord = unsafePopulateFunction #jsonb_populate_record

418467

419468-- | Expands the outermost array of objects in the given JSON expression to a

420469-- set of rows whose columns match the record type defined by the given table.

421−jsonPopulateRecordSet :: JsonPopulateFunction "json_populate_record_set" 'PGjson

470+jsonPopulateRecordSet

471+ :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type

472+ -> Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json array

473+ -> FromClause outer commons schemas params '["json_populate_record_set" ::: row]

422474jsonPopulateRecordSet = unsafePopulateFunction #json_populate_record_set

423475

424476-- | Expands the outermost array of objects in the given binary JSON expression

425477-- to a set of rows whose columns match the record type defined by the given

426478-- table.

427−jsonbPopulateRecordSet :: JsonPopulateFunction "jsonb_populate_record_set" 'PGjsonb

479+jsonbPopulateRecordSet

480+ :: TypeExpression schemas (nullity ('PGcomposite row)) -- ^ row type

481+ -> Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb array

482+ -> FromClause outer commons schemas params '["jsonb_populate_record_set" ::: row]

428483jsonbPopulateRecordSet = unsafePopulateFunction #jsonb_populate_record_set

429484

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

485+unsafeRecordFunction

486+ :: (SOP.SListI record, json `In` PGJsonType)

487+ => ByteString

488+ -> Expression outer commons 'Ungrouped schemas params '[] (nullity json)

489+ -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)

490+ -> FromClause outer commons schemas params '[tab ::: record]

441491unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $

442492 fun <> parenthesized (renderSQL expr) <+> "AS" <+> renderSQL tab

443493 <> parenthesized (renderCommaSeparated renderTy types)

@@ -446,17 +496,33 @@ unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $

446496 renderTy (ty `As` alias) = renderSQL alias <+> renderSQL ty

447497

448498-- | Builds an arbitrary record from a JSON object.

449−jsonToRecord :: JsonToRecordFunction 'PGjson

499+jsonToRecord

500+ :: SOP.SListI record

501+ => Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json object

502+ -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)

503+ -> FromClause outer commons schemas params '[tab ::: record]

450504jsonToRecord = unsafeRecordFunction "json_to_record"

451505

452506-- | Builds an arbitrary record from a binary JSON object.

453−jsonbToRecord :: JsonToRecordFunction 'PGjsonb

507+jsonbToRecord

508+ :: SOP.SListI record

509+ => Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb object

510+ -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)

511+ -> FromClause outer commons schemas params '[tab ::: record]

454512jsonbToRecord = unsafeRecordFunction "jsonb_to_record"

455513

456514-- | Builds an arbitrary set of records from a JSON array of objects.

457−jsonToRecordSet :: JsonToRecordFunction 'PGjson

515+jsonToRecordSet

516+ :: SOP.SListI record

517+ => Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjson) -- ^ json array

518+ -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)

519+ -> FromClause outer commons schemas params '[tab ::: record]

458520jsonToRecordSet = unsafeRecordFunction "json_to_record_set"

459521

460522-- | Builds an arbitrary set of records from a binary JSON array of objects.

461−jsonbToRecordSet :: JsonToRecordFunction 'PGjsonb

523+jsonbToRecordSet

524+ :: SOP.SListI record

525+ => Expression outer commons 'Ungrouped schemas params '[] (nullity 'PGjsonb) -- ^ jsonb array

526+ -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: record)

527+ -> FromClause outer commons schemas params '[tab ::: record]

462528jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs+2−2

@@ -47,8 +47,8 @@ false = UnsafeExpression "FALSE"

4747

4848-- | >>> printSQL $ not_ true

4949-- (NOT TRUE)

50−not_ :: null 'PGbool --> null 'PGbool

51−not_ = unsafeLeftOp "NOT"

50+not_ :: null 'PGbool :--> null 'PGbool

51+not_ = unsafeUnaryOpL "NOT"

5252

5353-- | >>> printSQL $ true .&& false

5454-- (TRUE AND FALSE)

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs+7−4

@@ -29,6 +29,7 @@ import Squeal.PostgreSQL.Schema

2929

3030-- $setup

3131-- >>> import Squeal.PostgreSQL

32+-- >>> import Squeal.PostgreSQL.Render

3233

3334-- | >>> :{

3435-- let

@@ -37,7 +38,9 @@ import Squeal.PostgreSQL.Schema

3738-- in printSQL expression

3839-- :}

3940-- atan2(pi(), 2)

40−atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float

41+atan2_

42+ :: float `In` PGFloating

43+ => FunctionN '[ null float, null float] (null float)

4144atan2_ = unsafeFunctionN "atan2"

4245

4346

@@ -76,7 +79,7 @@ rem_ = unsafeBinaryOp "%"

7679-- in printSQL expression

7780-- :}

7881-- trunc(pi())

79−trunc :: frac `In` PGFloating => null frac --> null frac

82+trunc :: frac `In` PGFloating => null frac :--> null frac

8083trunc = unsafeFunction "trunc"

8184

8285-- | >>> :{

@@ -86,7 +89,7 @@ trunc = unsafeFunction "trunc"

8689-- in printSQL expression

8790-- :}

8891-- round(pi())

89−round_ :: frac `In` PGFloating => null frac --> null frac

92+round_ :: frac `In` PGFloating => null frac :--> null frac

9093round_ = unsafeFunction "round"

9194

9295-- | >>> :{

@@ -96,5 +99,5 @@ round_ = unsafeFunction "round"

9699-- in printSQL expression

97100-- :}

98101-- ceiling(pi())

99−ceiling_ :: frac `In` PGFloating => null frac --> null frac

102+ceiling_ :: frac `In` PGFloating => null frac :--> null frac

100103ceiling_ = unsafeFunction "ceiling"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hs+4−4

@@ -44,7 +44,7 @@ null_ = UnsafeExpression "NULL"

4444--

4545-- >>> printSQL $ notNull true

4646-- TRUE

47−notNull :: 'NotNull ty --> 'Null ty

47+notNull :: 'NotNull ty :--> 'Null ty

4848notNull = UnsafeExpression . renderSQL

4949

5050-- | return the leftmost value which is not NULL

@@ -69,12 +69,12 @@ fromNull notNullx nullx = coalesce [nullx] notNullx

6969

7070-- | >>> printSQL $ null_ & isNull

7171-- NULL IS NULL

72−isNull :: 'Null ty --> null 'PGbool

72+isNull :: 'Null ty :--> null 'PGbool

7373isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"

7474

7575-- | >>> printSQL $ null_ & isNotNull

7676-- NULL IS NOT NULL

77−isNotNull :: 'Null ty --> null 'PGbool

77+isNotNull :: 'Null ty :--> null 'PGbool

7878isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"

7979

8080-- | analagous to `maybe` using @IS NULL@

@@ -100,5 +100,5 @@ matchNull y f x = ifThenElse (isNull x) y

100100>>> printSQL expr

101101NULLIF(FALSE, ($1 :: bool))

102102-}

103−nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty

103+nullIf :: FunctionN '[ 'NotNull ty, 'NotNull ty] ('Null ty)

104104nullIf = unsafeFunctionN "NULLIF"

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.hs → squeal-postgresql/src/Squeal/PostgreSQL/Expression/SetOf.hsrenamed+24−57

@@ -1,5 +1,5 @@

11{-|

2−Module: Squeal.PostgreSQL.Expression.Set

2+Module: Squeal.PostgreSQL.Expression.SetOf

33Description: Set returning functions

44Copyright: (c) Eitan Chatav, 2019

55Maintainer: eitan@morphism.tech

@@ -20,18 +20,14 @@ Set returning functions

2020 , TypeOperators

2121#-}

2222

23−module Squeal.PostgreSQL.Expression.Set

23+module Squeal.PostgreSQL.Expression.SetOf

2424 ( generateSeries

2525 , generateSeriesStep

2626 , generateSeriesTimestamp

27− , SetFunction

28− , unsafeSetFunction

29− , SetFunctionDB

30− , setFunction

31− , SetFunctionN

32− , unsafeSetFunctionN

33− , SetFunctionNDB

34− , setFunctionN

27+ , SetOfFunction

28+ , unsafeSetOfFunction

29+ , SetOfFunctionN

30+ , unsafeSetOfFunctionN

3531 ) where

3632

3733import GHC.TypeLits

@@ -48,75 +44,46 @@ import Squeal.PostgreSQL.Schema

4844{- |

4945A @RankNType@ for set returning functions with 1 argument.

5046-}

51−type SetFunction fun ty row

47+type SetOfFunction fun ty setof

5248 = forall outer commons schemas params

5349 . Expression outer commons 'Ungrouped schemas params '[] ty

5450 -- ^ 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]

51+ -> FromClause outer commons schemas params '[fun ::: setof]

6352 -- ^ output

6453

6554-- | 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 $

55+unsafeSetOfFunction

56+ :: forall fun ty setof. KnownSymbol fun

57+ => SetOfFunction fun ty setof -- ^ set returning function

58+unsafeSetOfFunction x = UnsafeFromClause $

7059 renderSymbol @fun <> parenthesized (renderSQL x)

7160

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−

7961{- |

8062A @RankNType@ for set returning functions with multiple argument.

8163-}

82−type SetFunctionN fun tys row

64+type SetOfFunctionN fun tys setof

8365 = forall outer commons schemas params

8466 . NP (Expression outer commons 'Ungrouped schemas params '[]) tys

8567 -- ^ inputs

86− -> FromClause outer commons schemas params '[fun ::: row]

68+ -> FromClause outer commons schemas params '[fun ::: setof]

8769 -- ^ output

8870

8971-- | 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 $

72+unsafeSetOfFunctionN

73+ :: forall fun tys setof. (SOP.SListI tys, KnownSymbol fun)

74+ => SetOfFunctionN fun tys setof -- ^ set returning function

75+unsafeSetOfFunctionN xs = UnsafeFromClause $

9476 renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)

9577

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−

11178{- | @generateSeries (start *: stop)@

11279

11380Generate a series of values, from @start@ to @stop@ with a step size of one

11481-}

11582generateSeries

11683 :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]

117− => SetFunctionN "generate_series" '[ null ty, null ty]

84+ => SetOfFunctionN "generate_series" '[ null ty, null ty]

11885 '["generate_series" ::: null ty] -- ^ set returning function

119−generateSeries = unsafeSetFunctionN

86+generateSeries = unsafeSetOfFunctionN

12087

12188{- | @generateSeries (start :* stop *: step)@

12289

@@ -124,9 +91,9 @@ Generate a series of values, from @start@ to @stop@ with a step size of @step@

12491-}

12592generateSeriesStep

12693 :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]

127− => SetFunctionN "generate_series" '[null ty, null ty, null ty]

94+ => SetOfFunctionN "generate_series" '[null ty, null ty, null ty]

12895 '["generate_series" ::: null ty] -- ^ set returning function

129−generateSeriesStep = unsafeSetFunctionN

96+generateSeriesStep = unsafeSetOfFunctionN

13097

13198{- | @generateSeries (start :* stop *: step)@

13299

@@ -134,6 +101,6 @@ Generate a series of values, from @start@ to @stop@ with a step size of @step@

134101-}

135102generateSeriesTimestamp

136103 :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]

137− => SetFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]

104+ => SetOfFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]

138105 '["generate_series" ::: null ty] -- ^ set returning function

139−generateSeriesTimestamp = unsafeSetFunctionN

106+generateSeriesTimestamp = unsafeSetOfFunctionN

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hs+3−2

@@ -33,6 +33,7 @@ import Squeal.PostgreSQL.Schema

3333

3434-- $setup

3535-- >>> import Squeal.PostgreSQL

36+-- >>> import Squeal.PostgreSQL.Render

3637

3738{- |

3839The argument of `exists` is an arbitrary subquery. The subquery is evaluated

@@ -80,8 +81,8 @@ using the given `Operator`, which must yield a Boolean result. The result of `su

8081if any `true` result is obtained. The result is `false` if no true result is found

8182(including the case where the subquery returns no rows).

8283

83−>>> printSQL $ subAny "foo" like (values_ ("foobar" `as` #foo))

84−(E'foo' LIKE ANY (SELECT * FROM (VALUES (E'foobar')) AS t ("foo")))

84+>>> printSQL $ subAll "foo" like (values_ ("foobar" `as` #foo))

85+(E'foo' LIKE ALL (SELECT * FROM (VALUES (E'foobar')) AS t ("foo")))

8586-}

8687subAny

8788 :: Expression outer commons grp schemas params from ty1 -- ^ expression

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs+4−3

@@ -27,20 +27,21 @@ import Squeal.PostgreSQL.Schema

2727

2828-- $setup

2929-- >>> import Squeal.PostgreSQL

30+-- >>> import Squeal.PostgreSQL.Render

3031

3132-- | >>> printSQL $ lower "ARRRGGG"

3233-- lower(E'ARRRGGG')

33−lower :: null 'PGtext --> null 'PGtext

34+lower :: null 'PGtext :--> null 'PGtext

3435lower = unsafeFunction "lower"

3536

3637-- | >>> printSQL $ upper "eeee"

3738-- upper(E'eeee')

38−upper :: null 'PGtext --> null 'PGtext

39+upper :: null 'PGtext :--> null 'PGtext

3940upper = unsafeFunction "upper"

4041

4142-- | >>> printSQL $ charLength "four"

4243-- char_length(E'four')

43−charLength :: null 'PGtext --> null 'PGint4

44+charLength :: null 'PGtext :--> null 'PGint4

4445charLength = unsafeFunction "char_length"

4546

4647-- | The `like` expression returns true if the @string@ matches

squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs+21−20

@@ -55,8 +55,8 @@ import Squeal.PostgreSQL.Schema

5555(.|) = unsafeBinaryOp "||"

5656

5757-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`

58−(.!) :: null 'PGtsquery --> null 'PGtsquery

59−(.!) = unsafeLeftOp "!!"

58+(.!) :: null 'PGtsquery :--> null 'PGtsquery

59+(.!) = unsafeUnaryOpL "!!"

6060

6161-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by

6262-- `Squeal.PostgreSQL.Expression.Type.tsquery`

@@ -66,50 +66,51 @@ import Squeal.PostgreSQL.Schema

6666-- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector`

6767arrayToTSvector

6868 :: null ('PGvararray ('NotNull 'PGtext))

69− --> null 'PGtsvector

69+ :--> null 'PGtsvector

7070arrayToTSvector = unsafeFunction "array_to_tsvector"

7171

7272-- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`

73−tsvectorLength :: null 'PGtsvector --> null 'PGint4

73+tsvectorLength :: null 'PGtsvector :--> null 'PGint4

7474tsvectorLength = unsafeFunction "length"

7575

7676-- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`

77−numnode :: null 'PGtsquery --> null 'PGint4

77+numnode :: null 'PGtsquery :--> null 'PGint4

7878numnode = unsafeFunction "numnode"

7979

8080-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation

81−plainToTSquery :: null 'PGtext --> null 'PGtsquery

81+plainToTSquery :: null 'PGtext :--> null 'PGtsquery

8282plainToTSquery = unsafeFunction "plainto_tsquery"

8383

8484-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase,

8585-- ignoring punctuation

86−phraseToTSquery :: null 'PGtext --> null 'PGtsquery

86+phraseToTSquery :: null 'PGtext :--> null 'PGtsquery

8787phraseToTSquery = unsafeFunction "phraseto_tsquery"

8888

8989-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query

90−websearchToTSquery :: null 'PGtext --> null 'PGtsquery

90+websearchToTSquery :: null 'PGtext :--> null 'PGtsquery

9191websearchToTSquery = unsafeFunction "websearch_to_tsquery"

9292

9393-- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`

94−queryTree :: null 'PGtsquery --> null 'PGtext

94+queryTree :: null 'PGtsquery :--> null 'PGtext

9595queryTree = unsafeFunction "query_tree"

9696

9797-- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`

98−toTSquery :: null 'PGtext --> null 'PGtsquery

98+toTSquery :: null 'PGtext :--> null 'PGtsquery

9999toTSquery = unsafeFunction "to_tsquery"

100100

101101-- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector`

102102toTSvector

103103 :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]

104− => null ty --> null 'PGtsvector

104+ => null ty :--> null 'PGtsvector

105105toTSvector = unsafeFunction "to_tsvector"

106106

107107-- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`

108−setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector

108+setWeight

109+ :: FunctionN '[null 'PGtsvector, null ('PGchar 1)] (null 'PGtsvector)

109110setWeight = unsafeFunctionN "set_weight"

110111

111112-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`

112−strip :: null 'PGtsvector --> null 'PGtsvector

113+strip :: null 'PGtsvector :--> null 'PGtsvector

113114strip = unsafeFunction "strip"

114115

115116-- | @jsonToTSvector (document *: filter)@

@@ -122,7 +123,7 @@ strip = unsafeFunction "strip"

122123-- "boolean" (to include all Boolean values in the string format "true"/"false"),

123124-- "key" (to include all keys) or "all" (to include all above).

124125-- 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 :: FunctionN '[null 'PGjson, null 'PGjson] (null 'PGtsvector)

126127jsonToTSvector = unsafeFunctionN "json_to_tsvector"

127128

128129-- | @jsonbToTSvector (document *: filter)@

@@ -135,23 +136,23 @@ jsonToTSvector = unsafeFunctionN "json_to_tsvector"

135136-- "boolean" (to include all Boolean values in the string format "true"/"false"),

136137-- "key" (to include all keys) or "all" (to include all above).

137138-- 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 :: FunctionN '[null 'PGjsonb, null 'PGjsonb] (null 'PGtsvector)

139140jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"

140141

141142-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`

142−tsDelete ::

143+tsDelete :: FunctionN

143144 '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]

144− ---> null 'PGtsvector

145+ (null 'PGtsvector)

145146tsDelete = unsafeFunctionN "ts_delete"

146147

147148-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`

148−tsFilter ::

149+tsFilter :: FunctionN

149150 '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]

150− ---> null 'PGtsvector

151+ (null 'PGtsvector)

151152tsFilter = unsafeFunctionN "ts_filter"

152153

153154-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match

154155tsHeadline

155156 :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]

156− => '[null document, null 'PGtsquery] ---> null 'PGtext

157+ => FunctionN '[null document, null 'PGtsquery] (null 'PGtext)

157158tsHeadline = unsafeFunctionN "ts_headline"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs+12−7

@@ -17,7 +17,6 @@ Date/Time functions and operators

1717 , OverloadedStrings

1818 , PolyKinds

1919 , RankNTypes

20− , TypeOperators

2120#-}

2221

2322module Squeal.PostgreSQL.Expression.Time

@@ -86,7 +85,9 @@ Create date from year, month and day fields

8685>>> printSQL (makeDate (1984 :* 7 *: 3))

8786make_date(1984, 7, 3)

8887-}

89−makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate

88+makeDate :: FunctionN

89+ '[ null 'PGint4, null 'PGint4, null 'PGint4 ]

90+ ( null 'PGdate )

9091makeDate = unsafeFunctionN "make_date"

9192

9293{-|

@@ -95,7 +96,9 @@ Create time from hour, minute and seconds fields

9596>>> printSQL (makeTime (8 :* 15 *: 23.5))

9697make_time(8, 15, 23.5)

9798-}

98−makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime

99+makeTime :: FunctionN

100+ '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ]

101+ ( null 'PGtime )

99102makeTime = unsafeFunctionN "make_time"

100103

101104{-|

@@ -104,9 +107,10 @@ Create timestamp from year, month, day, hour, minute and seconds fields

104107>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))

105108make_timestamp(2013, 7, 15, 8, 15, 23.5)

106109-}

107−makeTimestamp ::

110+makeTimestamp :: FunctionN

108111 '[ null 'PGint4, null 'PGint4, null 'PGint4

109− , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp

112+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ]

113+ ( null 'PGtimestamp )

110114makeTimestamp = unsafeFunctionN "make_timestamp"

111115

112116{-|

@@ -117,9 +121,10 @@ the current time zone is used

117121>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))

118122make_timestamptz(2013, 7, 15, 8, 15, 23.5)

119123-}

120−makeTimestamptz ::

124+makeTimestamptz :: FunctionN

121125 '[ null 'PGint4, null 'PGint4, null 'PGint4

122− , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz

126+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ]

127+ ( null 'PGtimestamptz )

123128makeTimestamptz = unsafeFunctionN "make_timestamptz"

124129

125130{-|

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hs+5−168

@@ -23,16 +23,12 @@ Type expressions.

2323 , ScopedTypeVariables

2424 , TypeApplications

2525 , TypeOperators

26− , UndecidableInstances

2726#-}

2827

2928module Squeal.PostgreSQL.Expression.Type

30− ( -- * type casting

31− cast

32− , astype

33− , inferredtype

34− -- * type expressions

35− , TypeExpression (..)

29+ ( TypeExpression (..)

30+ , cast

31+ , PGTyped (..)

3632 , typedef

3733 , typetable

3834 , typeview

@@ -58,11 +54,9 @@ module Squeal.PostgreSQL.Expression.Type

5854 , bytea

5955 , timestamp

6056 , timestampWithTimeZone

61− , timestamptz

6257 , date

6358 , time

6459 , timeWithTimeZone

65− , timetz

6660 , interval

6761 , uuid

6862 , inet

@@ -72,29 +66,6 @@ module Squeal.PostgreSQL.Expression.Type

7266 , fixarray

7367 , tsvector

7468 , 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 (..)

9869 ) where

9970

10071import Control.DeepSeq

@@ -108,7 +79,6 @@ import qualified Generics.SOP as SOP

10879

10980import Squeal.PostgreSQL.Alias

11081import Squeal.PostgreSQL.Expression

111−import Squeal.PostgreSQL.PG

11282import Squeal.PostgreSQL.Render

11383import Squeal.PostgreSQL.Schema

11484

@@ -130,29 +100,6 @@ cast

130100cast ty x = UnsafeExpression $ parenthesized $

131101 renderSQL x <+> "::" <+> renderSQL ty

132102

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

156103

157104{-----------------------------------------

158105type expressions

@@ -170,7 +117,6 @@ instance RenderSQL (TypeExpression schemas ty) where

170117typedef

171118 :: (Has sch schemas schema, Has td schema ('Typedef ty))

172119 => QualifiedAlias sch td

173− -- ^ type alias

174120 -> TypeExpression schemas (null ty)

175121typedef = UnsafeTypeExpression . renderSQL

176122

@@ -179,7 +125,6 @@ typedef = UnsafeTypeExpression . renderSQL

179125typetable

180126 :: (Has sch schemas schema, Has tab schema ('Table table))

181127 => QualifiedAlias sch tab

182− -- ^ table alias

183128 -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))

184129typetable = UnsafeTypeExpression . renderSQL

185130

@@ -188,7 +133,6 @@ typetable = UnsafeTypeExpression . renderSQL

188133typeview

189134 :: (Has sch schemas schema, Has vw schema ('View view))

190135 => QualifiedAlias sch vw

191− -- ^ view alias

192136 -> TypeExpression schemas (null ('PGcomposite view))

193137typeview = UnsafeTypeExpression . renderSQL

194138

@@ -245,9 +189,8 @@ bytea = UnsafeTypeExpression "bytea"

245189timestamp :: TypeExpression schemas (null 'PGtimestamp)

246190timestamp = UnsafeTypeExpression "timestamp"

247191-- | date and time, including time zone

248−timestampWithTimeZone, timestamptz :: TypeExpression schemas (null 'PGtimestamptz)

192+timestampWithTimeZone :: TypeExpression schemas (null 'PGtimestamptz)

249193timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

250−timestamptz = UnsafeTypeExpression "timestamptz"

251194-- | calendar date (year, month, day)

252195date :: TypeExpression schemas (null 'PGdate)

253196date = UnsafeTypeExpression "date"

@@ -255,9 +198,8 @@ date = UnsafeTypeExpression "date"

255198time :: TypeExpression schemas (null 'PGtime)

256199time = UnsafeTypeExpression "time"

257200-- | time of day, including time zone

258−timeWithTimeZone, timetz :: TypeExpression schemas (null 'PGtimetz)

201+timeWithTimeZone :: TypeExpression schemas (null 'PGtimetz)

259202timeWithTimeZone = UnsafeTypeExpression "time with time zone"

260−timetz = UnsafeTypeExpression "timetz"

261203-- | time span

262204interval :: TypeExpression schemas (null 'PGinterval)

263205interval = UnsafeTypeExpression "interval"

@@ -304,28 +246,6 @@ tsvector = UnsafeTypeExpression "tsvector"

304246-- | text search document

305247tsquery :: TypeExpression schemas (null 'PGtsquery)

306248tsquery = 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"

329249

330250-- | `pgtype` is a demoted version of a `PGType`

331251class PGTyped schemas (ty :: NullityType) where

@@ -361,86 +281,3 @@ instance (SOP.All KnownNat dims, PGTyped schemas ty)

361281 pgtype = fixarray @dims (pgtype @schemas @ty)

362282instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector

363283instance 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/List.hs+46−17

@@ -33,16 +33,16 @@ module Squeal.PostgreSQL.List

3333 , Join

3434 , disjoin

3535 , Additional (..)

36− , Path (..)

37− , CFunctor (..)

38− , CFoldable (..)

39− , CFree (..)

36+ , AlignedList (..)

37+ , single

38+ , extractList

39+ , mapAligned

4040 , Elem

4141 , In

4242 , Length

4343 ) where

4444

45−import Control.Category.Free

45+import Control.Category

4646import Data.Function ((&))

4747import Data.Kind

4848import Data.Type.Bool

@@ -50,6 +50,8 @@ import GHC.TypeLits

5050

5151import Generics.SOP as SOP

5252

53+import Squeal.PostgreSQL.Render

54+

5355-- | `Join` is simply promoted `++` and is used in @JOIN@s in

5456-- `Squeal.PostgreSQL.Query.FromClause`s.

5557type family Join xs ys where

@@ -76,6 +78,42 @@ instance Additional (NP expr) where

7678 Nil -> ys

7779 x :* xs -> x :* (xs & also ys)

7880

81+-- | An `AlignedList` is a type-aligned list or free category.

82+data AlignedList p x0 x1 where

83+ Done :: AlignedList p x x

84+ (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2

85+infixr 7 :>>

86+instance Category (AlignedList p) where

87+ id = Done

88+ (.) list = \case

89+ Done -> list

90+ step :>> steps -> step :>> (steps >>> list)

91+instance (forall t0 t1. RenderSQL (p t0 t1))

92+ => RenderSQL (AlignedList p x0 x1) where

93+ renderSQL = \case

94+ Done -> ""

95+ step :>> Done -> renderSQL step

96+ step :>> steps -> renderSQL step <> ", " <> renderSQL steps

97+

98+-- | `extractList` turns an `AlignedList` into a standard list.

99+extractList :: (forall a0 a1. p a0 a1 -> b) -> AlignedList p x0 x1 -> [b]

100+extractList f = \case

101+ Done -> []

102+ step :>> steps -> (f step):extractList f steps

103+

104+-- | `mapAligned` applies a function to each element of an `AlignedList`.

105+mapAligned

106+ :: (forall z0 z1. p z0 z1 -> q z0 z1)

107+ -> AlignedList p x0 x1

108+ -> AlignedList q x0 x1

109+mapAligned f = \case

110+ Done -> Done

111+ x :>> xs -> f x :>> mapAligned f xs

112+

113+-- | A `single` step.

114+single :: p x0 x1 -> AlignedList p x0 x1

115+single step = step :>> Done

116+

79117-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.

80118(*:) :: f x -> f y -> NP f '[x,y]

81119x *: y = x :* y :* Nil

@@ -84,18 +122,13 @@ infixl 9 *:

84122-- | @Elem@ is a promoted `Data.List.elem`.

85123type family Elem x xs where

86124 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

125+ Elem x (x ': xs) = 'True

93126 Elem x (_ ': xs) = Elem x xs

94127

95128-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.

96129type family In x xs :: Constraint where

97130 In x xs = If (Elem x xs) (() :: Constraint)

98− (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs))

131+ (TypeError ('ShowType x ':<>: 'Text "is not in " ':<>: 'ShowType xs))

99132

100133{- | Calculate the `Length` of a type level list

101134

@@ -104,9 +137,5 @@ Length '[Char,String,Bool,Double] :: Nat

104137= 4

105138-}

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

140+ Length (x : xs) = 1 + Length xs

112141 Length '[] = 0

squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+153−155

@@ -18,7 +18,6 @@ Squeal data manipulation language.

1818 , MultiParamTypeClasses

1919 , OverloadedStrings

2020 , PatternSynonyms

21− , QuantifiedConstraints

2221 , RankNTypes

2322 , ScopedTypeVariables

2423 , TypeApplications

@@ -30,9 +29,19 @@ Squeal data manipulation language.

3029

3130module Squeal.PostgreSQL.Manipulation

3231 ( -- * Manipulation

33− Manipulation_

34− , Manipulation (..)

32+ Manipulation (..)

33+ , Manipulation_

3534 , queryStatement

35+ , QueryClause (..)

36+ , pattern Values_

37+ , DefaultAliasable (..)

38+ , ColumnExpression (..)

39+ , ReturningClause (..)

40+ , pattern Returning_

41+ , ConflictClause (..)

42+ , ConflictTarget (..)

43+ , ConflictAction (..)

44+ , UsingClause (..)

3645 -- * Insert

3746 , insertInto

3847 , insertInto_

@@ -42,21 +51,12 @@ module Squeal.PostgreSQL.Manipulation

4251 -- * Delete

4352 , deleteFrom

4453 , deleteFrom_

45− -- * Clauses

46− , Optional (..)

47− , QueryClause (..)

48− , pattern Values_

49− , ReturningClause (..)

50− , pattern Returning_

51− , ConflictClause (..)

52− , ConflictTarget (..)

53− , ConflictAction (..)

54− , UsingClause (..)

5554 ) where

5655

5756import Control.DeepSeq

5857import Data.ByteString hiding (foldr)

5958import Data.Kind (Type)

59+import GHC.TypeLits (KnownSymbol)

6060

6161import qualified Generics.SOP as SOP

6262import qualified GHC.Generics as GHC

@@ -72,65 +72,21 @@ import Squeal.PostgreSQL.Schema

7272

7373-- $setup

7474-- >>> import Squeal.PostgreSQL

75−-- >>> import Data.Int

76−-- >>> import Data.Time

7775

7876{- |

7977A `Manipulation` is a statement which may modify data in the database,

8078but does not alter its schemas. Examples are inserts, updates and deletes.

8179A `Query` is also considered a `Manipulation` even though it does not modify data.

8280

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−

12581simple insert:

12682

12783>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]

12884>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]

12985>>> :{

13086let

131− manipulation :: Manipulation_ (Public Schema) () ()

87+ manipulation :: Manipulation '[] (Public Schema) '[] '[]

13288 manipulation =

133− insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))

89+ insertInto_ #tab (Values_ (2 `as` #col1 :* defaultAs #col2))

13490in printSQL manipulation

13591:}

13692INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)

@@ -141,9 +97,9 @@ parameterized insert:

14197>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]

14298>>> :{

14399let

144− manipulation :: Manipulation_ (Public Schema) (Int32, Int32) ()

100+ manipulation :: Manipulation '[] (Public Schema) '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]

145101 manipulation =

146− insertInto_ #tab (Values_ (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2))

102+ insertInto_ #tab (Values_ (param @1 `as` #col1 :* param @2 `as` #col2))

147103in printSQL manipulation

148104:}

149105INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))

@@ -152,9 +108,9 @@ returning insert:

152108

153109>>> :{

154110let

155− manipulation :: Manipulation_ (Public Schema) () (Only Int32)

111+ manipulation :: Manipulation '[] (Public Schema) '[] '["fromOnly" ::: 'NotNull 'PGint4]

156112 manipulation =

157− insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2))

113+ insertInto #tab (Values_ (2 `as` #col1 :* 3 `as` #col2))

158114 OnConflictDoRaise (Returning (#col1 `as` #fromOnly))

159115in printSQL manipulation

160116:}

@@ -167,12 +123,12 @@ upsert:

167123>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)]

168124>>> :{

169125let

170− manipulation :: Manipulation_ (Public CustomersSchema) () ()

126+ manipulation :: Manipulation '[] (Public CustomersSchema) '[] '[]

171127 manipulation =

172128 insertInto #customers

173− (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email))

129+ (Values_ ("John Smith" `as` #name :* "john@smith.com" `as` #email))

174130 (OnConflict (OnConstraint #uq)

175− (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) []))

131+ (DoUpdate (((#excluded ! #email) <> "; " <> (#customers ! #email)) `as` #email) []))

176132 (Returning_ Nil)

177133in printSQL manipulation

178134:}

@@ -182,7 +138,7 @@ query insert:

182138

183139>>> :{

184140let

185− manipulation :: Manipulation_ (Public Schema) () ()

141+ manipulation :: Manipulation '[] (Public Schema) '[] '[]

186142 manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab))))

187143in printSQL manipulation

188144:}

@@ -192,8 +148,8 @@ update:

192148

193149>>> :{

194150let

195− manipulation :: Manipulation_ (Public Schema) () ()

196− manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)

151+ manipulation :: Manipulation '[] (Public Schema) '[] '[]

152+ manipulation = update_ #tab (2 `as` #col1) (#col1 ./= #col2)

197153in printSQL manipulation

198154:}

199155UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")

@@ -202,7 +158,9 @@ delete:

202158

203159>>> :{

204160let

205− manipulation :: Manipulation_ (Public Schema) () (Row Int32 Int32)

161+ manipulation :: Manipulation '[] (Public Schema) '[]

162+ '[ "col1" ::: 'NotNull 'PGint4

163+ , "col2" ::: 'NotNull 'PGint4 ]

206164 manipulation = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star)

207165in printSQL manipulation

208166:}

@@ -213,13 +171,13 @@ delete and using clause:

213171>>> :{

214172type Schema3 =

215173 '[ "tab" ::: 'Table ('[] :=> Columns)

216− , "other_tab" ::: 'Table ('[] :=> Columns)

217− , "third_tab" ::: 'Table ('[] :=> Columns) ]

174+ , "other_tab" ::: 'Table ('[] :=> Columns)

175+ , "third_tab" ::: 'Table ('[] :=> Columns) ]

218176:}

219177

220178>>> :{

221179let

222− manipulation :: Manipulation_ (Public Schema3) () ()

180+ manipulation :: Manipulation '[] (Public Schema3) '[] '[]

223181 manipulation =

224182 deleteFrom #tab (Using (table #other_tab & also (table #third_tab)))

225183 ( (#tab ! #col2 .== #other_tab ! #col2)

@@ -235,7 +193,7 @@ with manipulation:

235193>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]

236194>>> :{

237195let

238− manipulation :: Manipulation_ (Public ProductsSchema) (Only Day) ()

196+ manipulation :: Manipulation '[] (Public ProductsSchema) '[ 'NotNull 'PGdate] '[]

239197 manipulation = with

240198 (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del)

241199 (insertInto_ #products_deleted (Subquery (select Star (from (common #del)))))

@@ -243,13 +201,26 @@ in printSQL manipulation

243201:}

244202WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del"

245203-}

204+newtype Manipulation

205+ (commons :: FromType)

206+ (schemas :: SchemasType)

207+ (params :: [NullityType])

208+ (columns :: RowType)

209+ = UnsafeManipulation { renderManipulation :: ByteString }

210+ deriving (GHC.Generic,Show,Eq,Ord,NFData)

211+instance RenderSQL (Manipulation commons schemas params columns) where

212+ renderSQL = renderManipulation

213+instance With Manipulation where

214+ with Done manip = manip

215+ with ctes manip = UnsafeManipulation $

216+ "WITH" <+> renderSQL ctes <+> renderSQL manip

217+

246218type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type) where

247219 Manipulation_ schemas params row = Manipulation '[] schemas (TuplePG params) (RowPG row)

248220

249221-- | Convert a `Query` into a `Manipulation`.

250222queryStatement

251223 :: Query '[] commons schemas params columns

252− -- ^ `Query` to embed as a `Manipulation`

253224 -> Manipulation commons schemas params columns

254225queryStatement q = UnsafeManipulation $ renderSQL q

255226

@@ -272,13 +243,9 @@ insertInto

272243 , SOP.SListI columns

273244 , SOP.SListI row1 )

274245 => QualifiedAlias sch tab

275− -- ^ table

276246 -> QueryClause commons schemas params columns

277− -- ^ what to insert

278247 -> ConflictClause tab commons schemas params table

279− -- ^ what to do in case of conflict

280248 -> ReturningClause commons schemas params '[tab ::: row0] row1

281− -- ^ what to return

282249 -> Manipulation commons schemas params row1

283250insertInto tab qry conflict ret = UnsafeManipulation $

284251 "INSERT" <+> "INTO" <+> renderSQL tab

@@ -286,7 +253,6 @@ insertInto tab qry conflict ret = UnsafeManipulation $

286253 <> renderSQL conflict

287254 <> renderSQL ret

288255

289−-- | Like `insertInto` but with `OnConflictDoRaise` and `no` `ReturningClause`.

290256insertInto_

291257 :: ( Has sch schemas schema

292258 , Has tab schema ('Table table)

@@ -294,33 +260,25 @@ insertInto_

294260 , row ~ TableToRow table

295261 , SOP.SListI columns )

296262 => QualifiedAlias sch tab

297− -- ^ table

298263 -> QueryClause commons schemas params columns

299− -- ^ what to insert

300264 -> Manipulation commons schemas params '[]

301265insertInto_ tab qry =

302266 insertInto tab qry OnConflictDoRaise (Returning_ Nil)

303267

304−-- | A `QueryClause` describes what to `insertInto` a table.

305268data QueryClause commons schemas params columns where

306269 Values

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

271+ => NP (ColumnExpression 'Ungrouped schemas params '[]) columns

272+ -> [NP (ColumnExpression 'Ungrouped schemas params '[]) columns]

312273 -> QueryClause commons schemas params columns

313274 Select

314275 :: SOP.SListI columns

315− => NP (Aliased (Optional (Expression '[] commons grp schemas params from))) columns

316− -- ^ row of values

276+ => NP (ColumnExpression grp schemas params from) columns

317277 -> TableExpression '[] commons grp schemas params from

318− -- ^ from a table expression

319278 -> QueryClause commons schemas params columns

320279 Subquery

321280 :: ColumnsToRow columns ~ row

322281 => Query '[] commons schemas params row

323− -- ^ subquery to insert

324282 -> QueryClause commons schemas params columns

325283

326284instance RenderSQL (QueryClause commons schemas params columns) where

@@ -339,41 +297,109 @@ instance RenderSQL (QueryClause commons schemas params columns) where

339297 Subquery qry -> renderQuery qry

340298 where

341299 renderSQLPartMaybe, renderValuePartMaybe

342− :: Aliased (Optional (Expression '[] commons grp schemas params from)) column

343− -> Maybe ByteString

300+ :: ColumnExpression grp schemas params from column -> Maybe ByteString

344301 renderSQLPartMaybe = \case

345− Default `As` _ -> Nothing

346− Set _ `As` name -> Just $ renderSQL name

302+ DefaultAs _ -> Nothing

303+ Specific (_ `As` name) -> Just $ renderSQL name

347304 renderValuePartMaybe = \case

348− Default `As` _ -> Nothing

349− Set value `As` _ -> Just $ renderExpression value

305+ DefaultAs _ -> Nothing

306+ Specific (value `As` _) -> Just $ renderExpression value

350307 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

308+ :: ColumnExpression grp schemas params from column -> ByteString

309+ renderSQLPart = \case

310+ DefaultAs name -> renderSQL name

311+ Specific (_ `As` name) -> renderSQL name

312+ renderValuePart = \case

313+ DefaultAs _ -> "DEFAULT"

314+ Specific (value `As` _) -> renderExpression value

355315

356−-- | `Values_` describes a single `NP` list of `Aliased` `Optional` `Expression`s

357−-- whose `ColumnsType` must match the tables'.

358316pattern Values_

359317 :: SOP.SListI columns

360− => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns

361− -- ^ row of values

318+ => NP (ColumnExpression 'Ungrouped schemas params '[]) columns

362319 -> QueryClause commons schemas params columns

363320pattern Values_ vals = Values vals []

364321

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

322+data ColumnExpression grp schemas params from column where

323+ DefaultAs

324+ :: KnownSymbol col

325+ => Alias col

326+ -> ColumnExpression grp schemas params from (col ::: 'Def :=> ty)

327+ Specific

328+ :: Aliased (Expression '[] '[] grp schemas params from) (col ::: ty)

329+ -> ColumnExpression grp schemas params from (col ::: defness :=> ty)

330+

331+instance (KnownSymbol col, column ~ (col ::: defness :=> ty))

332+ => Aliasable col

333+ (Expression '[] '[] grp schemas params from ty)

334+ (ColumnExpression grp schemas params from column) where

335+ expression `as` col = Specific (expression `As` col)

336+instance (KnownSymbol col, columns ~ '[col ::: defness :=> ty])

337+ => Aliasable col

338+ (Expression '[] '[] grp schemas params from ty)

339+ (NP (ColumnExpression grp schemas params from) columns) where

340+ expression `as` col = expression `as` col :* Nil

341+instance (KnownSymbol col, column ~ (col ::: 'Def :=> ty))

342+ => DefaultAliasable col (ColumnExpression grp schemas params from column) where

343+ defaultAs = DefaultAs

344+instance (KnownSymbol col, columns ~ '[col ::: 'Def :=> ty])

345+ => DefaultAliasable col (NP (ColumnExpression grp schemas params from) columns) where

346+ defaultAs col = defaultAs col :* Nil

347+

348+instance (HasUnique tab from row, Has col row ty, column ~ (col ::: defness :=> ty))

349+ => IsLabel col (ColumnExpression 'Ungrouped schemas params from column) where

350+ fromLabel = fromLabel @col `as` Alias

351+instance (HasUnique tab from row, Has col row ty, columns ~ '[col ::: defness :=> ty])

352+ => IsLabel col

353+ (NP (ColumnExpression 'Ungrouped schemas params from) columns) where

354+ fromLabel = fromLabel @col `as` Alias

355+

356+instance (Has tab from row, Has col row ty, column ~ (col ::: defness :=> ty))

357+ => IsQualified tab col (ColumnExpression 'Ungrouped schemas params from column) where

358+ tab ! col = tab ! col `as` col

359+instance (Has tab from row, Has col row ty, columns ~ '[col ::: defness :=> ty])

360+ => IsQualified tab col (NP (ColumnExpression 'Ungrouped schemas params from) columns) where

361+ tab ! col = tab ! col `as` col

362+

363+instance

364+ ( HasUnique tab from row

365+ , Has col row ty

366+ , GroupedBy tab col bys

367+ , column ~ (col ::: defness :=> ty)

368+ ) => IsLabel col

369+ (ColumnExpression ('Grouped bys) schemas params from column) where

370+ fromLabel = fromLabel @col `as` Alias

371+instance

372+ ( HasUnique tab from row

373+ , Has col row ty

374+ , GroupedBy tab col bys

375+ , columns ~ '[col ::: defness :=> ty]

376+ ) => IsLabel col

377+ (NP (ColumnExpression ('Grouped bys) schemas params from) columns) where

378+ fromLabel = fromLabel @col `as` Alias

379+

380+instance

381+ ( Has tab from row

382+ , Has col row ty

383+ , GroupedBy tab col bys

384+ , column ~ (col ::: defness :=> ty)

385+ ) => IsQualified tab col

386+ (ColumnExpression ('Grouped bys) schemas params from column) where

387+ tab ! col = tab ! col `as` col

388+instance

389+ ( Has tab from row

390+ , Has col row ty

391+ , GroupedBy tab col bys

392+ , columns ~ '[col ::: defness :=> ty]

393+ ) => IsQualified tab col

394+ (NP (ColumnExpression ('Grouped bys) schemas params from) columns) where

395+ tab ! col = tab ! col :* Nil

396+

397+instance RenderSQL (ColumnExpression grp schemas params from column) where

374398 renderSQL = \case

375− Default -> "DEFAULT"

376− Set expr -> renderSQL expr

399+ DefaultAs col ->

400+ renderSQL col <+> "=" <+> "DEFAULT"

401+ Specific (expression `As` col) ->

402+ renderSQL col <+> "=" <+> renderSQL expression

377403

378404-- | A `ReturningClause` computes and return value(s) based

379405-- on each row actually inserted, updated or deleted. This is primarily

@@ -383,7 +409,7 @@ instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where

383409-- deleted will be returned. For example, if a row was locked

384410-- but not updated because an `OnConflict` `DoUpdate` condition was not satisfied,

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

412+-- in the row. Use @Returning Nil@ in the common case where no return

387413-- values are desired.

388414newtype ReturningClause commons schemas params from row =

389415 Returning (Selection '[] commons 'Ungrouped schemas params from row)

@@ -393,11 +419,9 @@ instance RenderSQL (ReturningClause commons schemas params from row) where

393419 Returning (List Nil) -> ""

394420 Returning selection -> " RETURNING" <+> renderSQL selection

395421

396−-- | `Returning` a `List`

397422pattern Returning_

398423 :: SOP.SListI row

399424 => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row

400− -- ^ row of values

401425 -> ReturningClause commons schemas params from row

402426pattern Returning_ list = Returning (List list)

403427

@@ -410,9 +434,7 @@ data ConflictClause tab commons schemas params table where

410434 OnConflictDoRaise :: ConflictClause tab commons schemas params table

411435 OnConflict

412436 :: ConflictTarget constraints

413− -- ^ conflict target

414437 -> ConflictAction tab commons schemas params columns

415− -- ^ conflict action

416438 -> ConflictClause tab commons schemas params (constraints :=> columns)

417439

418440-- | Render a `ConflictClause`.

@@ -423,17 +445,6 @@ instance SOP.SListI (TableToColumns table)

423445 OnConflict target action -> " ON CONFLICT"

424446 <+> renderSQL target <+> renderSQL action

425447

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

437448data ConflictAction tab commons schemas params columns where

438449 DoNothing :: ConflictAction tab commons schemas params columns

439450 DoUpdate

@@ -442,9 +453,8 @@ data ConflictAction tab commons schemas params columns where

442453 , columns ~ (col0 ': cols)

443454 , SOP.All (HasIn columns) subcolumns

444455 , AllUnique subcolumns )

445− => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]))) subcolumns

456+ => NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]) subcolumns

446457 -> [Condition '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]]

447− -- ^ WHERE `Condition`s

448458 -> ConflictAction tab commons schemas params columns

449459

450460instance RenderSQL (ConflictAction tab commons schemas params columns) where

@@ -452,17 +462,11 @@ instance RenderSQL (ConflictAction tab commons schemas params columns) where

452462 DoNothing -> "DO NOTHING"

453463 DoUpdate updates whs'

454464 -> "DO UPDATE SET"

455− <+> renderCommaSeparated renderUpdate updates

465+ <+> renderCommaSeparated renderSQL updates

456466 <> case whs' of

457467 [] -> ""

458468 wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)

459469

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−

466470-- | A `ConflictTarget` specifies the constraint violation that triggers a

467471-- `ConflictAction`.

468472data ConflictTarget constraints where

@@ -485,6 +489,7 @@ UPDATE statements

485489update

486490 :: ( SOP.SListI columns

487491 , SOP.SListI row1

492+ , db ~ (commons :=> schemas)

488493 , Has sch schemas schema

489494 , Has tab schema ('Table table)

490495 , row0 ~ TableToRow table

@@ -492,7 +497,7 @@ update

492497 , SOP.All (HasIn columns) subcolumns

493498 , AllUnique subcolumns )

494499 => QualifiedAlias sch tab -- ^ table to update

495− -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row0]))) subcolumns

500+ -> NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row0]) subcolumns

496501 -- ^ modified values to replace old values

497502 -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]

498503 -- ^ condition under which to perform update on a row

@@ -502,13 +507,14 @@ update tab columns wh returning = UnsafeManipulation $

502507 "UPDATE"

503508 <+> renderSQL tab

504509 <+> "SET"

505− <+> renderCommaSeparated renderUpdate columns

510+ <+> renderCommaSeparated renderSQL columns

506511 <+> "WHERE" <+> renderSQL wh

507512 <> renderSQL returning

508513

509514-- | Update a row returning `Nil`.

510515update_

511516 :: ( SOP.SListI columns

517+ , db ~ (commons :=> schemas)

512518 , Has sch schemas schema

513519 , Has tab schema ('Table table)

514520 , row ~ TableToRow table

@@ -516,7 +522,7 @@ update_

516522 , SOP.All (HasIn columns) subcolumns

517523 , AllUnique subcolumns )

518524 => QualifiedAlias sch tab -- ^ table to update

519− -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row]))) subcolumns

525+ -> NP (ColumnExpression 'Ungrouped schemas params '[tab ::: row]) subcolumns

520526 -- ^ modified values to replace old values

521527 -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]

522528 -- ^ condition under which to perform update on a row

@@ -527,25 +533,16 @@ update_ tab columns wh = update tab columns wh (Returning_ Nil)

527533DELETE statements

528534-----------------------------------------}

529535

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.

539536data UsingClause commons schemas params from where

540537 NoUsing :: UsingClause commons schemas params '[]

541538 Using

542539 :: FromClause '[] commons schemas params from

543− -- ^ what to use

544540 -> UsingClause commons schemas params from

545541

546542-- | Delete rows from a table.

547543deleteFrom

548544 :: ( SOP.SListI row1

545+ , db ~ (commons :=> schemas)

549546 , Has sch schemas schema

550547 , Has tab schema ('Table table)

551548 , row0 ~ TableToRow table

@@ -567,7 +564,8 @@ deleteFrom tab using wh returning = UnsafeManipulation $

567564

568565-- | Delete rows returning `Nil`.

569566deleteFrom_

570− :: ( Has sch schemas schema

567+ :: ( db ~ (commons :=> schemas)

568+ , Has sch schemas schema

571569 , Has tab schema ('Table table)

572570 , row ~ TableToRow table

573571 , columns ~ TableToColumns table )

squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+47−53

@@ -66,7 +66,7 @@ let

6666 }

6767:}

6868

69−Now that we have a couple migrations we can chain them together into a `Path`.

69+Now that we have a couple migrations we can chain them together into an `AlignedList`.

7070

7171>>> let migrations = makeUsers :>> makeEmails :>> Done

7272

@@ -164,21 +164,7 @@ import qualified Data.Text.IO as Text (putStrLn)

164164import qualified Generics.SOP as SOP

165165import qualified GHC.Generics as GHC

166166

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

167+import Squeal.PostgreSQL

182168

183169-- | A `Migration` is a named "isomorphism" over a given category.

184170-- It should contain an inverse pair of `up` and `down`

@@ -192,34 +178,34 @@ data Migration p schemas0 schemas1 = Migration

192178

193179{- |

194180A `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

181+an `AlignedList` of `Migration`s over @p@. This includes the category of pure

196182SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.

197183-}

198184class Category p => Migratory p where

199185

200186 {- |

201− Run a `Path` of `Migration`s.

187+ Run an `AlignedList` of `Migration`s.

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

189+ In a transaction for each each `Migration`, query to see if the `Migration` has been executed;

190+ if not, execute the `Migration` and insert a row in the `MigrationsTable`.

205191 -}

206192 migrateUp

207− :: Path (Migration p) schemas0 schemas1

193+ :: AlignedList (Migration p) schemas0 schemas1

208194 -> PQ schemas0 schemas1 IO ()

209195

210196 {- |

211− Rewind a `Path` of `Migration`s.

197+ Rewind an `AlignedList` of `Migration`s.

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

199+ In a transaction for each each `Migration`, query to see if the `Migration` has been executed;

200+ if so, rewind the `Migration` and delete its row in the `MigrationsTable`.

215201 -}

216202 migrateDown

217− :: Path (Migration p) schemas0 schemas1

203+ :: AlignedList (Migration p) schemas0 schemas1

218204 -> PQ schemas1 schemas0 IO ()

219205

220206instance Migratory Definition where

221− migrateUp = migrateUp . cmap pureMigration

222− migrateDown = migrateDown . cmap pureMigration

207+ migrateUp = migrateUp . mapAligned pureMigration

208+ migrateDown = migrateDown . mapAligned pureMigration

223209

224210{- | `Terminally` turns an indexed monad transformer and the monad it transforms

225211into a category by restricting the return type to @()@ and permuting the type variables.

@@ -251,8 +237,8 @@ terminally = Terminally . void

251237-- | A `pureMigration` turns a `Migration` involving only pure SQL

252238-- `Definition`s into a `Migration` that may be combined with arbitrary `IO`.

253239pureMigration

254− :: Migration Definition schemas0 schemas1

255− -> Migration (Terminally PQ IO) schemas0 schemas1

240+ :: Migration Definition schema0 schema1

241+ -> Migration (Terminally PQ IO) schema0 schema1

256242pureMigration migration = Migration

257243 { name = name migration

258244 , up = terminally . define $ up migration

@@ -261,62 +247,70 @@ pureMigration migration = Migration

261247

262248instance Migratory (Terminally PQ IO) where

263249

264− migrateUp migration = unsafePQ . transactionally_ $ do

250+ migrateUp migration = unsafePQ $

265251 define createMigrations

266− upMigrations migration

252+ & pqBind okResult

253+ & pqThen (transactionally_ (upMigrations migration))

267254

268255 where

269256

270257 upMigrations

271− :: Path (Migration (Terminally PQ IO)) schemas0 schemas1

258+ :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1

272259 -> PQ MigrationsSchemas MigrationsSchemas IO ()

273260 upMigrations = \case

274261 Done -> return ()

275− step :>> steps -> upMigration step >> upMigrations steps

262+ step :>> steps -> upMigration step & pqThen (upMigrations steps)

276263

277264 upMigration

278265 :: Migration (Terminally PQ IO) schemas0 schemas1

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

267+ upMigration step =

268+ queryExecuted step

269+ & pqBind ( \ executed -> unless (executed == 1)

270+ $ unsafePQ (runTerminally (up step))

271+ & pqThen (manipulateParams insertMigration (Only (name step)))

272+ -- insert execution record

273+ & pqBind okResult )

285274

286275 queryExecuted

287276 :: Migration (Terminally PQ IO) schemas0 schemas1

288277 -> PQ MigrationsSchemas MigrationsSchemas IO Row

289278 queryExecuted step = do

290279 result <- runQueryParams selectMigration (Only (name step))

280+ okResult result

291281 ntuples result

292282

293− migrateDown migrations = unsafePQ . transactionally_ $ do

283+ migrateDown migrations = unsafePQ $

294284 define createMigrations

295− downMigrations migrations

285+ & pqBind okResult

286+ & pqThen (transactionally_ (downMigrations migrations))

296287

297288 where

298289

299290 downMigrations

300− :: Path (Migration (Terminally PQ IO)) schemas0 schemas1

291+ :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1

301292 -> PQ MigrationsSchemas MigrationsSchemas IO ()

302293 downMigrations = \case

303294 Done -> return ()

304− step :>> steps -> downMigrations steps >> downMigration step

295+ step :>> steps -> downMigrations steps & pqThen (downMigration step)

305296

306297 downMigration

307298 :: Migration (Terminally PQ IO) schemas0 schemas1

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

300+ downMigration step =

301+ queryExecuted step

302+ & pqBind ( \ executed -> unless (executed == 0)

303+ $ unsafePQ (runTerminally (down step))

304+ & pqThen (manipulateParams deleteMigration (Only (name step)))

305+ -- delete execution record

306+ & pqBind okResult )

314307

315308 queryExecuted

316309 :: Migration (Terminally PQ IO) schemas0 schemas1

317310 -> PQ MigrationsSchemas MigrationsSchemas IO Row

318311 queryExecuted step = do

319312 result <- runQueryParams selectMigration (Only (name step))

313+ okResult result

320314 ntuples result

321315

322316unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x

@@ -353,7 +347,7 @@ createMigrations =

353347-- the time at which it was inserted.

354348insertMigration :: Manipulation_ MigrationsSchemas (Only Text) ()

355349insertMigration = insertInto_ #schema_migrations

356− (Values_ (Set (param @1) `as` #name :* Default `as` #executed_at))

350+ (Values_ ((param @1) `as` #name :* defaultAs #executed_at))

357351

358352-- | Deletes a `Migration` from the `MigrationsTable`, returning

359353-- the time at which it was inserted.

@@ -363,8 +357,8 @@ deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)

363357-- | Selects a `Migration` from the `MigrationsTable`, returning

364358-- the time at which it was inserted.

365359selectMigration

366− :: Query_ MigrationsSchemas (Only Text) (Only UTCTime)

367−selectMigration = select_ (#executed_at `as` #fromOnly)

360+ :: Query_ MigrationsSchemas (Only Text) (P ("executed_at" ::: UTCTime))

361+selectMigration = select_ #executed_at

368362 $ from (table (#schema_migrations))

369363 & where_ (#name .== param @1)

370364

@@ -384,7 +378,7 @@ defaultMain

384378 :: Migratory p

385379 => ByteString

386380 -- ^ connection string

387− -> Path (Migration p) db0 db1

381+ -> AlignedList (Migration p) db0 db1

388382 -- ^ migrations

389383 -> IO ()

390384defaultMain connectTo migrations = do

@@ -405,12 +399,12 @@ defaultMain connectTo migrations = do

405399 migrateStatus :: PQ schema schema IO ()

406400 migrateStatus = unsafePQ $ do

407401 runNames <- getRunMigrationNames

408− let names = ctoList name migrations

402+ let names = extractList name migrations

409403 unrunNames = names \\ runNames

410404 liftIO $ displayRunned runNames >> displayUnrunned unrunNames

411405

412406 suppressNotices :: PQ schema schema IO ()

413− suppressNotices = manipulate_ $

407+ suppressNotices = void . manipulate $

414408 UnsafeManipulation "SET client_min_messages TO WARNING;"

415409

416410 readCommandFromArgs :: IO (Maybe MigrateCommand)

squeal-postgresql/src/Squeal/PostgreSQL/PG.hs+42−41

@@ -10,20 +10,18 @@ Stability: experimental

1010-}

1111{-# LANGUAGE

1212 AllowAmbiguousTypes

13− , DeriveAnyClass

1413 , DeriveFoldable

1514 , DeriveFunctor

1615 , DeriveGeneric

1716 , DeriveTraversable

18− , DerivingStrategies

1917 , DefaultSignatures

2018 , FlexibleContexts

2119 , FlexibleInstances

2220 , FunctionalDependencies

2321 , GADTs

2422 , LambdaCase

25− , MultiParamTypeClasses

2623 , OverloadedStrings

24+ , MultiParamTypeClasses

2725 , ScopedTypeVariables

2826 , TypeApplications

2927 , TypeFamilies

@@ -47,7 +45,7 @@ module Squeal.PostgreSQL.PG

4745 , Enumerated (..)

4846 , VarArray (..)

4947 , FixArray (..)

50− , LibPQ.Oid (..)

48+ , SOP.P (..)

5149 -- * Type families

5250 , LabelsPG

5351 , DimPG

@@ -66,6 +64,7 @@ import Data.Int (Int16, Int32, Int64)

6664import Data.Scientific (Scientific)

6765import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)

6866import Data.Vector (Vector)

67+import Data.Word (Word16, Word32, Word64)

6968import Data.UUID.Types (UUID)

7069import GHC.TypeLits

7170import Network.IP.Addr (NetAddr, IP)

@@ -74,13 +73,13 @@ import qualified Data.ByteString.Lazy as Lazy (ByteString)

7473import qualified Data.ByteString as Strict (ByteString)

7574import qualified Data.Text.Lazy as Lazy (Text)

7675import qualified Data.Text as Strict (Text)

77−import qualified Database.PostgreSQL.LibPQ as LibPQ

7876import qualified GHC.Generics as GHC

7977import qualified Generics.SOP as SOP

8078import qualified Generics.SOP.Record as SOP

8179import qualified Generics.SOP.Type.Metadata as Type

8280

8381import Squeal.PostgreSQL.Alias

82+import Squeal.PostgreSQL.List

8483import Squeal.PostgreSQL.Schema

8584

8685-- $setup

@@ -108,7 +107,11 @@ type instance PG Int32 = 'PGint4

108107-- | `PGint8`

109108type instance PG Int64 = 'PGint8

110109-- | `PGint2`

111−type instance PG LibPQ.Oid = 'PGoid

110+type instance PG Word16 = 'PGint2

111+-- | `PGint4`

112+type instance PG Word32 = 'PGint4

113+-- | `PGint8`

114+type instance PG Word64 = 'PGint8

112115-- | `PGnumeric`

113116type instance PG Scientific = 'PGnumeric

114117-- | `PGfloat4`

@@ -172,22 +175,37 @@ have `SOP.Generic` and `SOP.HasDatatypeInfo` instances;

172175>>> :kind! RowPG Person

173176RowPG Person :: [(Symbol, NullityType)]

174177= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]

178+

179+Or to tuples of `SOP.P` types;

180+

181+>>> :kind! RowPG (SOP.P ("id" ::: Int32), SOP.P ("foreign_id" ::: Int32))

182+RowPG (SOP.P ("id" ::: Int32), SOP.P ("foreign_id" ::: Int32)) :: [(Symbol,

183+ NullityType)]

184+= '[ '("id", 'NotNull 'PGint4), "foreign_id" ::: 'NotNull 'PGint4]

185+

186+Or to tuples which mix `SOP.P` types and record types.

187+

188+>>> :kind! RowPG (SOP.P ("id" ::: Int32), Person, SOP.P ("foreign_id" ::: Int32))

189+RowPG (SOP.P ("id" ::: Int32), Person, SOP.P ("foreign_id" ::: Int32)) :: [(Symbol,

190+ NullityType)]

191+= '[ '("id", 'NotNull 'PGint4), '("name", 'NotNull 'PGtext),

192+ '("age", 'NotNull 'PGint4), "foreign_id" ::: 'NotNull 'PGint4]

175193-}

176194type family RowPG (hask :: Type) :: RowType where

195+ RowPG (hask1, hask2) = Join (RowPG hask1) (RowPG hask2)

196+ RowPG (hask1, hask2, hask3) =

197+ Join (RowPG hask1) (RowPG (hask2, hask3))

198+ RowPG (hask1, hask2, hask3, hask4) =

199+ Join (RowPG hask1) (RowPG (hask2, hask3, hask4))

200+ RowPG (hask1, hask2, hask3, hask4, hask5) =

201+ Join (RowPG hask1) (RowPG (hask2, hask3, hask4, hask5))

202+ RowPG (SOP.P (col ::: ty)) = '[col ::: NullPG ty]

177203 RowPG hask = RowOf (SOP.RecordCodeOf hask)

178204

179205-- | `RowOf` applies `NullPG` to the fields of a list.

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

190207 RowOf '[] = '[]

208+ RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record

191209

192210{- | `NullPG` turns a Haskell type into a `NullityType`.

193211

@@ -214,17 +232,8 @@ type family TuplePG (hask :: Type) :: [NullityType] where

214232

215233-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.

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

227235 TupleOf '[] = '[]

236+ TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple

228237

229238-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`

230239-- and if it's a simple product returns it, otherwise giving a `TypeError`.

@@ -311,7 +320,7 @@ let

311320>>> let input = Only (Money 20020)

312321

313322>>> :{

314−withConnection "host=localhost port=5432 dbname=exampledb" $ do

323+void . withConnection "host=localhost port=5432 dbname=exampledb" $ do

315324 result <- runQueryParams roundTrip input

316325 Just output <- firstRow result

317326 liftIO . print $ input == output

@@ -319,8 +328,7 @@ withConnection "host=localhost port=5432 dbname=exampledb" $ do

319328True

320329-}

321330newtype Money = Money { cents :: Int64 }

322− deriving stock (Eq, Ord, Show, Read, GHC.Generic)

323− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)

331+ deriving (Eq, Ord, Show, Read, GHC.Generic)

324332-- | `PGmoney`

325333type instance PG Money = 'PGmoney

326334

@@ -328,8 +336,7 @@ type instance PG Money = 'PGmoney

328336type it's applied to should be stored as a `PGjson`.

329337-}

330338newtype Json hask = Json {getJson :: hask}

331− deriving stock (Eq, Ord, Show, Read, GHC.Generic)

332− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)

339+ deriving (Eq, Ord, Show, Read, GHC.Generic)

333340-- | `PGjson`

334341type instance PG (Json hask) = 'PGjson

335342

@@ -337,8 +344,7 @@ type instance PG (Json hask) = 'PGjson

337344type it's applied to should be stored as a `PGjsonb`.

338345-}

339346newtype Jsonb hask = Jsonb {getJsonb :: hask}

340− deriving stock (Eq, Ord, Show, Read, GHC.Generic)

341− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)

347+ deriving (Eq, Ord, Show, Read, GHC.Generic)

342348-- | `PGjsonb`

343349type instance PG (Jsonb hask) = 'PGjsonb

344350

@@ -346,8 +352,7 @@ type instance PG (Jsonb hask) = 'PGjsonb

346352type it's applied to should be stored as a `PGcomposite`.

347353-}

348354newtype Composite record = Composite {getComposite :: record}

349− deriving stock (Eq, Ord, Show, Read, GHC.Generic)

350− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)

355+ deriving (Eq, Ord, Show, Read, GHC.Generic)

351356-- | `PGcomposite` @(@`RowPG` @hask)@

352357type instance PG (Composite hask) = 'PGcomposite (RowPG hask)

353358

@@ -355,8 +360,7 @@ type instance PG (Composite hask) = 'PGcomposite (RowPG hask)

355360type it's applied to should be stored as a `PGenum`.

356361-}

357362newtype Enumerated enum = Enumerated {getEnumerated :: enum}

358− deriving stock (Eq, Ord, Show, Read, GHC.Generic)

359− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)

363+ deriving (Eq, Ord, Show, Read, GHC.Generic)

360364-- | `PGenum` @(@`LabelsPG` @hask)@

361365type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)

362366

@@ -368,11 +372,9 @@ PG (VarArray (Vector Double)) :: PGType

368372= 'PGvararray ('NotNull 'PGfloat8)

369373-}

370374newtype VarArray arr = VarArray {getVarArray :: arr}

371− deriving stock (Eq, Ord, Show, Read, GHC.Generic)

372− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)

375+ deriving (Eq, Ord, Show, Read, GHC.Generic)

373376-- | `PGvararray` @(@`NullPG` @hask)@

374377type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)

375−type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask)

376378

377379{- | The `FixArray` newtype is an indication that the Haskell

378380type it's applied to should be stored as a `PGfixarray`.

@@ -382,7 +384,6 @@ PG (FixArray ((Double, Double), (Double, Double))) :: PGType

382384= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)

383385-}

384386newtype FixArray arr = FixArray {getFixArray :: arr}

385− deriving stock (Eq, Ord, Show, Read, GHC.Generic)

386− deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)

387+ deriving (Eq, Ord, Show, Read, GHC.Generic)

387388-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@

388389type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)

squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+24−73

@@ -68,17 +68,15 @@ module Squeal.PostgreSQL.PQ

6868 , okResult

6969 , catchSqueal

7070 , handleSqueal

71− , trySqueal

7271 ) where

7372

7473import Control.Exception (Exception, throw)

7574import Control.Monad.Except

7675import Control.Monad.Morph

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

76+import UnliftIO (MonadUnliftIO (..), bracket, catch, handle)

7877import Data.ByteString (ByteString)

7978import Data.Foldable

8079import Data.Function ((&))

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

8280import Data.Kind

8381import Data.Text (pack, Text)

8482import Data.Traversable

@@ -87,7 +85,6 @@ import PostgreSQL.Binary.Encoding (encodingBytes)

8785

8886import qualified Control.Monad.Fail as Fail

8987import qualified Database.PostgreSQL.LibPQ as LibPQ

90−import qualified PostgreSQL.Binary.Encoding as Encoding

9188

9289import Squeal.PostgreSQL.Binary

9390import Squeal.PostgreSQL.Definition

@@ -248,16 +245,13 @@ class IndexedMonadTransPQ pq where

248245 -> x -> pq schemas0 schemas2 m z

249246 pqAndThen g f x = pqBind g (f x)

250247

251− -- | Run a `Definition` with `LibPQ.exec`.

248+ -- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law

252249 --

253− -- It should be functorial in effect.

254− --

255− -- @define id = return ()@

256− -- @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@

250+ -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@

257251 define

258252 :: MonadIO io

259253 => Definition schemas0 schemas1

260− -> pq schemas0 schemas1 io ()

254+ -> pq schemas0 schemas1 io (K LibPQ.Result '[])

261255

262256instance IndexedMonadTransPQ PQ where

263257

@@ -275,7 +269,7 @@ instance IndexedMonadTransPQ PQ where

275269 case resultMaybe of

276270 Nothing -> throw $ ResultException

277271 "define: LibPQ.exec returned no results"

278− Just result -> K <$> okResult_ result

272+ Just result -> return $ K (K result)

279273

280274{- | `MonadPQ` is an @mtl@ style constraint, similar to

281275`Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` to

@@ -284,12 +278,8 @@ instance IndexedMonadTransPQ PQ where

284278 with a `ToParams` constraint. It calls `LibPQ.execParams` and

285279 doesn't afraid of anything.

286280

287−* `manipulateParams_` is like `manipulateParams` for a returning-free statement.

288−

289281* `manipulate` is like `manipulateParams` for a parameter-free statement.

290282

291−* `manipulate_` is like `manipulate` for a returning-free statement.

292−

293283* `runQueryParams` is like `manipulateParams` for query statements.

294284

295285* `runQuery` is like `runQueryParams` for a parameter-free statement.

@@ -303,7 +293,7 @@ instance IndexedMonadTransPQ PQ where

303293* `forPrepared` is a flipped `traversePrepared`

304294

305295* `traversePrepared_` is like `traversePrepared` but works on `Foldable`

306− containers for a returning-free statement.

296+ containers and returns unit.

307297

308298* `forPrepared_` is a flipped `traversePrepared_`.

309299

@@ -317,34 +307,24 @@ a default instance.

317307-}

318308class Monad pq => MonadPQ schemas pq | pq -> schemas where

319309 manipulateParams

320− :: (ToParams x params, All OidOfParam params)

310+ :: ToParams x params

321311 => Manipulation '[] schemas params ys

322312 -- ^ `insertInto`, `update` or `deleteFrom`

323313 -> x -> pq (K LibPQ.Result ys)

324314 default manipulateParams

325315 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)

326− => (ToParams x params, All OidOfParam params)

316+ => ToParams x params

327317 => Manipulation '[] schemas params ys

328318 -- ^ `insertInto`, `update` or `deleteFrom`

329319 -> x -> pq (K LibPQ.Result ys)

330320 manipulateParams manipulation params = lift $

331321 manipulateParams manipulation params

332322

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−

340323 manipulate :: Manipulation '[] schemas '[] ys -> pq (K LibPQ.Result ys)

341324 manipulate statement = manipulateParams statement ()

342325

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

344− manipulate_ = void . manipulate

345−

346326 runQueryParams

347− :: (ToParams x params, All OidOfParam params)

327+ :: ToParams x params

348328 => Query '[] '[] schemas params ys

349329 -- ^ `select` and friends

350330 -> x -> pq (K LibPQ.Result ys)

@@ -357,19 +337,19 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where

357337 runQuery q = runQueryParams q ()

358338

359339 traversePrepared

360− :: (ToParams x params, Traversable list, All OidOfParam params)

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

361341 => Manipulation '[] schemas params ys

362342 -- ^ `insertInto`, `update`, or `deleteFrom`, and friends

363343 -> list x -> pq (list (K LibPQ.Result ys))

364344 default traversePrepared

365345 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)

366− => (ToParams x params, Traversable list, All OidOfParam params)

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

367347 => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))

368348 traversePrepared manipulation params = lift $

369349 traversePrepared manipulation params

370350

371351 forPrepared

372− :: (ToParams x params, Traversable list, All OidOfParam params)

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

373353 => list x

374354 -> Manipulation '[] schemas params ys

375355 -- ^ `insertInto`, `update` or `deleteFrom`

@@ -377,13 +357,13 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where

377357 forPrepared = flip traversePrepared

378358

379359 traversePrepared_

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

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

381361 => Manipulation '[] schemas params '[]

382362 -- ^ `insertInto`, `update` or `deleteFrom`

383363 -> list x -> pq ()

384364 default traversePrepared_

385365 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)

386− => (ToParams x params, Foldable list, All OidOfParam params)

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

387367 => Manipulation '[] schemas params '[]

388368 -- ^ `insertInto`, `update` or `deleteFrom`

389369 -> list x -> pq ()

@@ -391,7 +371,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where

391371 traversePrepared_ manipulation params

392372

393373 forPrepared_

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

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

395375 => list x

396376 -> Manipulation '[] schemas params '[]

397377 -- ^ `insertInto`, `update` or `deleteFrom`

@@ -411,17 +391,9 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)

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

412392 PQ $ \ (K conn) -> do

413393 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

394+ toParam' encoding =

395+ (LibPQ.invalidOid, encodingBytes encoding, LibPQ.Binary)

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

425397 q' = q <> ";"

426398 resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary

427399 case resultMaybe of

@@ -434,22 +406,15 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)

434406 traversePrepared

435407 (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =

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

409+ let temp = "temporary_statement"

410+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing

446411 case prepResultMaybe of

447412 Nothing -> throw $ ResultException

448413 "traversePrepared: LibPQ.prepare returned no results"

449414 Just prepResult -> okResult_ prepResult

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

451416 let

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

417+ toParam' encoding = (encodingBytes encoding,LibPQ.Binary)

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

454419 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary

455420 case resultMaybe of

@@ -468,15 +433,8 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)

468433 traversePrepared_

469434 (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =

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

436+ let temp = "temporary_statement"

437+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing

480438 case prepResultMaybe of

481439 Nothing -> throw $ ResultException

482440 "traversePrepared_: LibPQ.prepare returned no results"

@@ -684,7 +642,7 @@ okResult_ result = liftIO $ do

684642 msg <- LibPQ.resultErrorMessage result

685643 throw . PQException $ PQState status stateCode msg

686644

687−-- | Check if a `LibPQ.Result`'s status is either `LibPQ.CommandOk`

645+-- | Check if a `Result`'s status is either `LibPQ.CommandOk`

688646-- or `LibPQ.TuplesOk` otherwise `throw` a `PQException`.

689647okResult :: MonadIO io => K LibPQ.Result row -> io ()

690648okResult = okResult_ . unK

@@ -703,10 +661,3 @@ handleSqueal

703661 => (SquealException -> io a) -- ^ handler

704662 -> io a -> io a

705663handleSqueal = handle

706−

707−-- | `Either` return a `SquealException` or a result.

708−trySqueal

709− :: MonadUnliftIO io

710− => io a

711− -> io (Either SquealException a)

712−trySqueal = try

squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+99−67

@@ -1,33 +1,11 @@

11{-|

2−Module: Squeal.PostgreSQL.Pool

3−Description: Connection pools

2+Module: Squeal.PostgreSQL.Definition

3+Description: Pooled connections

44Copyright: (c) Eitan Chatav, 2017

55Maintainer: eitan@morphism.tech

66Stability: experimental

8−Connection pools.

9−

10−Typical use case would be to create your pool using `createConnectionPool`

11−and run anything that requires the pool connection with `usingConnectionPool`.

12−

13−Here's a simplified example:

14−

15−>>> import Squeal.PostgreSQL

16−

17−>>> :{

18−do

19− let

20− query :: Query_ (Public '[]) () (Only Char)

21− query = values_ (literal 'a' `as` #fromOnly)

22− pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb" 1 0.5 10

23− chr <- usingConnectionPool pool $ do

24− result <- runQuery query

25− Just (Only a) <- firstRow result

26− return a

27− destroyConnectionPool pool

28− putChar chr

29−:}

30−a

8+A `MonadPQ` for pooled connections.

319-}

3210

3311{-# LANGUAGE

@@ -45,19 +23,51 @@ a

4523

4624module Squeal.PostgreSQL.Pool

4725 ( -- * Pools

48− Pool

26+ PoolPQ (..)

4927 , createConnectionPool

50− , usingConnectionPool

51− , destroyConnectionPool

28+ , Pool

29+ , destroyAllResources

5230 ) where

5331

32+import Control.Monad.Trans

5433import Data.ByteString

5534import Data.Time

56−import Generics.SOP (K(..), unK)

35+import Generics.SOP (K(..))

5736import UnliftIO (MonadUnliftIO (..))

5837import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)

5938

39+import qualified Control.Monad.Fail as Fail

40+

6041import Squeal.PostgreSQL.PQ

42+import Squeal.PostgreSQL.Schema

43+

44+{- | `PoolPQ` @schemas@ should be a drop-in replacement for `PQ` @schemas schemas@.

45+

46+Typical use case would be to create your pool using `createConnectionPool` and run anything that requires the pool connection with it.

47+

48+Here's a simplified example:

49+

50+>>> import Squeal.PostgreSQL

51+>>> :{

52+do

53+ let

54+ query :: Query_ (Public '[]) () (Only Char)

55+ query = values_ $ literal 'a' `as` #fromOnly

56+ session :: PoolPQ (Public '[]) IO Char

57+ session = do

58+ result <- runQuery query

59+ Just (Only chr) <- firstRow result

60+ return chr

61+ pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb" 1 0.5 10

62+ chr <- runPoolPQ session pool

63+ destroyAllResources pool

64+ putChar chr

65+:}

66+a

67+-}

68+newtype PoolPQ (schemas :: SchemasType) m x =

69+ PoolPQ { runPoolPQ :: Pool (K Connection schemas) -> m x }

70+ deriving Functor

6171

6272-- | Create a striped pool of connections.

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

@@ -82,41 +92,63 @@ createConnectionPool

8292createConnectionPool conninfo stripes idle maxResrc =

8393 createPool (connectdb conninfo) finish stripes idle maxResrc

8494

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

95+-- | `Applicative` instance for `PoolPQ`.

96+instance Monad m => Applicative (PoolPQ schemas m) where

97+ pure x = PoolPQ $ \ _ -> pure x

98+ PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do

99+ f' <- f pool

100+ x' <- x pool

101+ return $ f' x'

102+

103+-- | `Monad` instance for `PoolPQ`.

104+instance Monad m => Monad (PoolPQ schemas m) where

105+ return = pure

106+ PoolPQ x >>= f = PoolPQ $ \ pool -> do

107+ x' <- x pool

108+ runPoolPQ (f x') pool

109+

110+-- | `Fail.MonadFail` instance for `PoolPQ`.

111+instance Monad m => Fail.MonadFail (PoolPQ schemas m) where

112+ fail = Fail.fail

113+

114+-- | `MonadTrans` instance for `PoolPQ`.

115+instance MonadTrans (PoolPQ schemas) where

116+ lift m = PoolPQ $ \ _pool -> m

117+

118+-- | `MonadPQ` instance for `PoolPQ`.

119+instance MonadUnliftIO io => MonadPQ schemas (PoolPQ schemas io) where

120+ manipulateParams manipulation params = PoolPQ $ \ pool -> do

121+ withResource pool $ \ conn -> do

122+ (K result :: K (K Result ys) schemas) <- flip unPQ conn $

123+ manipulateParams manipulation params

124+ return result

125+ traversePrepared manipulation params = PoolPQ $ \ pool ->

126+ withResource pool $ \ conn -> do

127+ (K result :: K (list (K Result ys)) schemas) <- flip unPQ conn $

128+ traversePrepared manipulation params

129+ return result

130+ traversePrepared_ manipulation params = PoolPQ $ \ pool -> do

131+ withResource pool $ \ conn -> do

132+ (_ :: K () schemas) <- flip unPQ conn $

133+ traversePrepared_ manipulation params

134+ return ()

135+ liftPQ m = PoolPQ $ \ pool ->

136+ withResource pool $ \ conn -> do

137+ (K result :: K result schemas) <- flip unPQ conn $

138+ liftPQ m

139+ return result

140+

141+-- | 'MonadIO' instance for 'PoolPQ'.

142+instance (MonadIO m)

143+ => MonadIO (PoolPQ schemas m) where

144+ liftIO = lift . liftIO

145+

146+-- | 'MonadUnliftIO' instance for 'PoolPQ'.

147+instance (MonadUnliftIO m)

148+ => MonadUnliftIO (PoolPQ schemas m) where

149+ withRunInIO

150+ :: ((forall a . PoolPQ schemas m a -> IO a) -> IO b)

151+ -> PoolPQ schemas m b

152+ withRunInIO inner = PoolPQ $ \pool ->

153+ withRunInIO $ \(run :: (forall x . m x -> IO x)) ->

154+ inner (\poolpq -> run $ runPoolPQ poolpq pool)

squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+83−214

@@ -32,15 +32,13 @@ Squeal queries.

3232

3333module Squeal.PostgreSQL.Query

3434 ( -- * Queries

35− Query_

36− , Query (..)

35+ Query (..)

36+ , Query_

3737 -- ** Select

3838 , select

3939 , select_

4040 , selectDistinct

4141 , selectDistinct_

42− , selectDistinctOn

43− , selectDistinctOn_

4442 , Selection (..)

4543 -- ** Values

4644 , values

@@ -55,7 +53,6 @@ module Squeal.PostgreSQL.Query

5553 -- ** With

5654 , With (..)

5755 , CommonTableExpression (..)

58− , withRecursive

5956 -- * Table Expressions

6057 , TableExpression (..)

6158 , from

@@ -103,55 +100,10 @@ import Squeal.PostgreSQL.Schema

103100

104101-- $setup

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

110103

111104{- |

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

105+The process of retrieving or the command to retrieve data from a database

106+is called a `Query`. Let's see some examples of queries.

155107

156108simple query:

157109

@@ -159,7 +111,7 @@ simple query:

159111>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]

160112>>> :{

161113let

162− query :: Query_ (Public Schema) () (Row Int32 Int32)

114+ query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]

163115 query = select Star (from (table #tab))

164116in printSQL query

165117:}

@@ -169,21 +121,21 @@ restricted query:

169121

170122>>> :{

171123let

172− query :: Query_ (Public Schema) () (Row Int32 Int32)

124+ query :: Query '[] '[] (Public Schema) '[] '["sum" ::: 'NotNull 'PGint4, "col1" ::: 'NotNull 'PGint4]

173125 query =

174− select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2)

126+ select_ ((#col1 + #col2) `as` #sum :* #col1)

175127 ( from (table #tab)

176128 & where_ (#col1 .> #col2)

177129 & where_ (#col2 .> 0) )

178130in printSQL query

179131:}

180−SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))

132+SELECT ("col1" + "col2") AS "sum", "col1" AS "col1" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))

181133

182134subquery:

183135

184136>>> :{

185137let

186− query :: Query_ (Public Schema) () (Row Int32 Int32)

138+ query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]

187139 query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))

188140in printSQL query

189141:}

@@ -193,7 +145,7 @@ limits and offsets:

193145

194146>>> :{

195147let

196− query :: Query_ (Public Schema) () (Row Int32 Int32)

148+ query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]

197149 query = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)

198150in printSQL query

199151:}

@@ -203,7 +155,7 @@ parameterized query:

203155

204156>>> :{

205157let

206− query :: Query_ (Public Schema) (Only Int32) (Row Int32 Int32)

158+ query :: Query '[] '[] (Public Schema) '[ 'NotNull 'PGint4] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]

207159 query = select Star (from (table #tab) & where_ (#col1 .> param @1))

208160in printSQL query

209161:}

@@ -213,21 +165,21 @@ aggregation query:

213165

214166>>> :{

215167let

216− query :: Query_ (Public Schema) () (Row Int64 Int32)

168+ query :: Query '[] '[] (Public Schema) '[] '["sum" ::: 'NotNull 'PGint4, "col1" ::: 'NotNull 'PGint4 ]

217169 query =

218− select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2)

170+ select_ (sum_ (All #col2) `as` #sum :* #col1)

219171 ( from (table (#tab `as` #table1))

220172 & groupBy #col1

221− & having (sum_ (Distinct #col2) .> 1) )

173+ & having (#col1 + sum_ (Distinct #col2) .> 1) )

222174in printSQL query

223175:}

224−SELECT COALESCE(sum(ALL "col2"), 0) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > 1)

176+SELECT sum(ALL "col2") AS "sum", "col1" AS "col1" FROM "tab" AS "table1" GROUP BY "col1" HAVING (("col1" + sum(DISTINCT "col2")) > 1)

225177

226178sorted query:

227179

228180>>> :{

229181let

230− query :: Query_ (Public Schema) () (Row Int32 Int32)

182+ query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]

231183 query = select Star (from (table #tab) & orderBy [#col1 & Asc])

232184in printSQL query

233185:}

@@ -235,12 +187,14 @@ SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC

235187

236188joins:

237189

190+>>> :set -XFlexibleContexts

238191>>> :{

239192type OrdersColumns =

240193 '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

241− , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4

242− , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4

243− , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4 ]

194+ , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4

195+ , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4

196+ , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4

197+ ]

244198:}

245199

246200>>> :{

@@ -256,27 +210,22 @@ type OrdersConstraints =

256210>>> :{

257211type OrdersSchema =

258212 '[ "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

213+ , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns)

214+ , "shippers" ::: 'Table (ShippersConstraints :=> NamesColumns) ]

271215:}

272216

273217>>> :{

274218let

275− query :: Query_ (Public OrdersSchema) () Order

219+ query :: Query '[] '[] (Public OrdersSchema)

220+ '[]

221+ '[ "order_price" ::: 'NotNull 'PGfloat4

222+ , "customer_name" ::: 'NotNull 'PGtext

223+ , "shipper_name" ::: 'NotNull 'PGtext

224+ ]

276225 query = select_

277− ( #o ! #price `as` #price :*

278− #c ! #name `as` #customerName :*

279− #s ! #name `as` #shipperName )

226+ ( #o ! #price `as` #order_price :*

227+ #c ! #name `as` #customer_name :*

228+ #s ! #name `as` #shipper_name )

280229 ( from (table (#orders `as` #o)

281230 & innerJoin (table (#customers `as` #c))

282231 (#o ! #customer_id .== #c ! #id)

@@ -284,16 +233,14 @@ let

284233 (#o ! #shipper_id .== #s ! #id)) )

285234in printSQL query

286235:}

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

236+SELECT "o"."price" AS "order_price", "c"."name" AS "customer_name", "s"."name" AS "shipper_name" FROM "orders" AS "o" INNER JOIN "customers" AS "c" ON ("o"."customer_id" = "c"."id") INNER JOIN "shippers" AS "s" ON ("o"."shipper_id" = "s"."id")

288237

289238self-join:

290239

291240>>> :{

292241let

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

242+ query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]

243+ query = select (#t1 & DotStar) (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))

297244in printSQL query

298245:}

299246SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2"

@@ -302,19 +249,17 @@ value queries:

302249

303250>>> :{

304251let

305− query :: Query_ schemas () (Row String Bool)

306− query = values

307− ("true" `as` #col1 :* true `as` #col2)

308− ["false" `as` #col1 :* false `as` #col2]

252+ query :: Query '[] commons schemas '[] '["foo" ::: 'NotNull 'PGint2, "bar" ::: 'NotNull 'PGbool]

253+ query = values (1 `as` #foo :* true `as` #bar) [2 `as` #foo :* false `as` #bar]

309254in printSQL query

310255:}

311−SELECT * FROM (VALUES (E'true', TRUE), (E'false', FALSE)) AS t ("col1", "col2")

256+SELECT * FROM (VALUES (1, TRUE), (2, FALSE)) AS t ("foo", "bar")

312257

313258set operations:

314259

315260>>> :{

316261let

317− query :: Query_ (Public Schema) () (Row Int32 Int32)

262+ query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]

318263 query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))

319264in printSQL query

320265:}

@@ -324,7 +269,7 @@ with queries:

324269

325270>>> :{

326271let

327− query :: Query_ (Public Schema) () (Row Int32 Int32)

272+ query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]

328273 query = with (

329274 select Star (from (table #tab)) `as` #cte1 :>>

330275 select Star (from (common #cte1)) `as` #cte2

@@ -337,35 +282,40 @@ window function queries

337282

338283>>> :{

339284let

340− query :: Query_ (Public Schema) () (Row Int32 Int64)

285+ query :: Query '[] '[] (Public Schema) '[] ["col1" ::: 'NotNull 'PGint4, "rank" ::: 'NotNull 'PGint8]

341286 query = select

342− (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))

287+ (#col1 & Also (rank `as` #rank `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))

343288 (from (table #tab))

344289in printSQL query

345290:}

346−SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "col2" FROM "tab" AS "tab"

291+SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "rank" FROM "tab" AS "tab"

347292

348293correlated subqueries

349294

350295>>> :{

351296let

352− query :: Query_ (Public Schema) () (Only Int32)

297+ query :: Query '[] '[] (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4]

353298 query =

354− select (#col1 `as` #fromOnly) (from (table (#tab `as` #t1))

299+ select #col1 (from (table (#tab `as` #t1))

355300 & where_ (exists (

356301 select Star (from (table (#tab `as` #t2))

357302 & where_ (#t2 ! #col2 .== #t1 ! #col1)))))

358303in printSQL query

359304:}

360−SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))

361−

305+SELECT "col1" AS "col1" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))

362306-}

363−type family Query_

307+newtype Query

308+ (outer :: FromType)

309+ (commons :: FromType)

364310 (schemas :: SchemasType)

365− (parameters :: Type)

366− (row :: Type) where

367− Query_ schemas params row =

368− Query '[] '[] schemas (TuplePG params) (RowPG row)

311+ (params :: [NullityType])

312+ (row :: RowType)

313+ = UnsafeQuery { renderQuery :: ByteString }

314+ deriving (GHC.Generic,Show,Eq,Ord,NFData)

315+instance RenderSQL (Query outer commons schemas params row) where renderSQL = renderQuery

316+

317+type family Query_ (schemas :: SchemasType) (params :: Type) (row :: Type) where

318+ Query_ schemas params row = Query '[] '[] schemas (TuplePG params) (RowPG row)

369319

370320-- | The results of two queries can be combined using the set operation

371321-- `union`. Duplicate rows are eliminated.

@@ -530,7 +480,7 @@ instance IsString

530480select

531481 :: (SListI row, row ~ (x ': xs))

532482 => Selection outer commons grp schemas params from row

533− -- ^ selection

483+ -- ^ select list

534484 -> TableExpression outer commons grp schemas params from

535485 -- ^ intermediate virtual table

536486 -> Query outer commons schemas params row

@@ -539,24 +489,20 @@ select selection tabexpr = UnsafeQuery $

539489 <+> renderSQL selection

540490 <+> renderSQL tabexpr

541491

542−-- | Like `select` but takes an `NP` list of `Expression`s instead

543−-- of a general `Selection`.

544492select_

545493 :: (SListI row, row ~ (x ': xs))

546494 => NP (Aliased (Expression outer commons grp schemas params from)) row

547− -- ^ select list

548495 -> TableExpression outer commons grp schemas params from

549− -- ^ intermediate virtual table

550496 -> Query outer commons schemas params row

551−select_ = select . List

497+select_ list = select (List list)

552498

553499-- | After the select list has been processed, the result table can

554500-- be subject to the elimination of duplicate rows using `selectDistinct`.

555501selectDistinct

556502 :: (SListI columns, columns ~ (col ': cols))

557− => Selection outer commons grp schemas params from columns

558− -- ^ selection

559− -> TableExpression outer commons grp schemas params from

503+ => Selection outer commons 'Ungrouped schemas params from columns

504+ -- ^ select list

505+ -> TableExpression outer commons 'Ungrouped schemas params from

560506 -- ^ intermediate virtual table

561507 -> Query outer commons schemas params columns

562508selectDistinct selection tabexpr = UnsafeQuery $

@@ -564,65 +510,14 @@ selectDistinct selection tabexpr = UnsafeQuery $

564510 <+> renderSQL selection

565511 <+> renderSQL tabexpr

566512

567−-- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead

568−-- of a general `Selection`.

569513selectDistinct_

570514 :: (SListI columns, columns ~ (col ': cols))

571− => NP (Aliased (Expression outer commons grp schemas params from)) columns

515+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns

572516 -- ^ 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

517+ -> TableExpression outer commons 'Ungrouped schemas params from

623518 -- ^ intermediate virtual table

624519 -> Query outer commons schemas params columns

625−selectDistinctOn_ distincts = selectDistinctOn distincts . List

520+selectDistinct_ list = select (List list)

626521

627522-- | `values` computes a row value or set of row values

628523-- specified by value expressions. It is most commonly used

@@ -757,7 +652,7 @@ instance RenderSQL (TableExpression outer commons grp schemas params from) where

757652from

758653 :: FromClause outer commons schemas params from -- ^ table reference

759654 -> TableExpression outer commons 'Ungrouped schemas params from

760−from tab = TableExpression tab [] noGroups NoHaving [] [] []

655+from tab = TableExpression tab [] NoGroups NoHaving [] [] []

761656

762657-- | A `where_` is an endomorphism of `TableExpression`s which adds a

763658-- search condition to the `whereClause`.

@@ -778,7 +673,7 @@ groupBy

778673groupBy bys rels = TableExpression

779674 { fromClause = fromClause rels

780675 , whereClause = whereClause rels

781− , groupByClause = group bys

676+ , groupByClause = Group bys

782677 , havingClause = Having []

783678 , orderByClause = []

784679 , limitClause = limitClause rels

@@ -992,20 +887,19 @@ instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])

992887-- done on @NoGroups@ while all output `Expression`s must be aggregated

993888-- in @Group Nil@. In general, all output `Expression`s in the

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

890+data GroupByClause grp from where

891+ NoGroups :: GroupByClause 'Ungrouped from

892+ Group

893+ :: SListI bys

894+ => NP (By from) bys

895+ -> GroupByClause ('Grouped bys) from

896+

897+-- | Renders a `GroupByClause`.

998898instance 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'

899+ renderSQL = \case

900+ NoGroups -> ""

901+ Group Nil -> ""

902+ Group bys -> " GROUP BY" <+> renderCommaSeparated renderSQL bys

1009903

1010904-- | A `HavingClause` is used to eliminate groups that are not of interest.

1011905-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`

@@ -1049,8 +943,8 @@ instance

1049943 , commons1 ~ (cte ::: common ': commons)

1050944 ) => Aliasable cte

1051945 (statement commons schemas params common)

1052− (Path (CommonTableExpression statement schemas params) commons commons1) where

1053− statement `as` cte = csingleton (statement `as` cte)

946+ (AlignedList (CommonTableExpression statement schemas params) commons commons1) where

947+ statement `as` cte = single (statement `as` cte)

1054948

1055949instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL

1056950 (CommonTableExpression statement schemas params commons0 commons1) where

@@ -1062,7 +956,7 @@ instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL

1062956-- defining temporary tables that exist just for one query.

1063957class With statement where

1064958 with

1065− :: Path (CommonTableExpression statement schemas params) commons0 commons1

959+ :: AlignedList (CommonTableExpression statement schemas params) commons0 commons1

1066960 -- ^ common table expressions

1067961 -> statement commons1 schemas params row

1068962 -- ^ larger query

@@ -1070,29 +964,4 @@ class With statement where

1070964instance With (Query outer) where

1071965 with Done query = query

1072966 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

967+ "WITH" <+> renderSQL ctes <+> renderSQL query

squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+60−161

@@ -44,10 +44,6 @@ module Squeal.PostgreSQL.Schema

4444 , ColumnsType

4545 , TableType

4646 , SchemumType (..)

47− , IndexType (..)

48− , FunctionType

49− , OperatorType (..)

50− , ReturnsType (..)

5147 , SchemaType

5248 , SchemasType

5349 , Public

@@ -62,21 +58,15 @@ module Squeal.PostgreSQL.Schema

6258 , PGlabel (..)

6359 -- * Data Definitions

6460 , Create

65− , CreateIfNotExists

66− , CreateOrReplace

6761 , Drop

68− , DropSchemum

69− , DropIfExists

70− , DropSchemumIfExists

7162 , Alter

72− , AlterIfExists

7363 , Rename

74− , RenameIfExists

7564 , ConstraintInvolves

7665 , DropIfConstraintsInvolve

7766 , IsNotElem

7867 , AllUnique

7968 -- * Type Classifications

69+ , HasOid (..)

8070 , PGNum

8171 , PGIntegral

8272 , PGFloating

@@ -100,19 +90,17 @@ import Control.Category

10090import Data.Kind

10191import Data.Monoid hiding (All)

10292import Data.Type.Bool

93+import Data.Word (Word32)

10394import Generics.SOP

10495import GHC.TypeLits

10596import Prelude hiding (id, (.))

10697

10798import Squeal.PostgreSQL.Alias

108−import Squeal.PostgreSQL.List

10999import Squeal.PostgreSQL.Render

110100

111−-- $setup

112−-- >>> import Squeal.PostgreSQL

113−

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

115102--

103+-- >>> import Squeal.PostgreSQL.Schema

116104-- >>> :kind 'PGbool

117105-- 'PGbool :: PGType

118106data PGType

@@ -143,11 +131,37 @@ data PGType

143131 | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.

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

145133 | 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).

134+ | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for

149135 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types

150136

137+-- | The object identifier of a `PGType`.

138+--

139+-- >>> :set -XTypeApplications

140+-- >>> oid @'PGbool

141+-- 16

142+class HasOid (ty :: PGType) where oid :: Word32

143+instance HasOid 'PGbool where oid = 16

144+instance HasOid 'PGint2 where oid = 21

145+instance HasOid 'PGint4 where oid = 23

146+instance HasOid 'PGint8 where oid = 20

147+instance HasOid 'PGnumeric where oid = 1700

148+instance HasOid 'PGfloat4 where oid = 700

149+instance HasOid 'PGfloat8 where oid = 701

150+instance HasOid ('PGchar n) where oid = 18

151+instance HasOid ('PGvarchar n) where oid = 1043

152+instance HasOid 'PGtext where oid = 25

153+instance HasOid 'PGbytea where oid = 17

154+instance HasOid 'PGtimestamp where oid = 1114

155+instance HasOid 'PGtimestamptz where oid = 1184

156+instance HasOid 'PGdate where oid = 1082

157+instance HasOid 'PGtime where oid = 1083

158+instance HasOid 'PGtimetz where oid = 1266

159+instance HasOid 'PGinterval where oid = 1186

160+instance HasOid 'PGuuid where oid = 2950

161+instance HasOid 'PGinet where oid = 869

162+instance HasOid 'PGjson where oid = 114

163+instance HasOid 'PGjsonb where oid = 3802

164+

151165-- | `NullityType` encodes the potential presence or definite absence of a

152166-- @NULL@ allowing operations which are sensitive to such to be well typed.

153167--

@@ -260,19 +274,9 @@ type FromType = [(Symbol,RowType)]

260274

261275-- | `ColumnsToRow` removes column constraints.

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

275277 ColumnsToRow '[] = '[]

278+ ColumnsToRow (column ::: constraint :=> ty ': columns) =

279+ column ::: ty ': ColumnsToRow columns

276280

277281-- | `TableToColumns` removes table constraints.

278282type family TableToColumns (table :: TableType) :: ColumnsType where

@@ -282,6 +286,15 @@ type family TableToColumns (table :: TableType) :: ColumnsType where

282286type family TableToRow (table :: TableType) :: RowType where

283287 TableToRow tab = ColumnsToRow (TableToColumns tab)

284288

289+-- | @Elem@ is a promoted `Data.List.elem`.

290+type family Elem x xs where

291+ Elem x '[] = 'False

292+ Elem x (x ': xs) = 'True

293+ Elem x (_ ': xs) = Elem x xs

294+

295+-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.

296+type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True

297+

285298-- | Numeric Postgres types.

286299type PGNum =

287300 '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]

@@ -305,24 +318,14 @@ instance ty0 ~ ty1 => SamePGType

305318

306319-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.

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

314321 AllNotNull '[] = ()

322+ AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns

315323

316324-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some

317325-- @NOT NULL@.

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

327+ NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()

328+ NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns

326329

327330-- | `NullifyType` is an idempotent that nullifies a `NullityType`.

328331type family NullifyType (ty :: NullityType) :: NullityType where

@@ -331,37 +334,17 @@ type family NullifyType (ty :: NullityType) :: NullityType where

331334

332335-- | `NullifyRow` is an idempotent that nullifies a `RowType`.

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

337+ NullifyRow '[] = '[]

344338 NullifyRow (column ::: ty ': columns) =

345339 column ::: NullifyType ty ': NullifyRow columns

346− NullifyRow '[] = '[]

347340

348341-- | `NullifyFrom` is an idempotent that nullifies a `FromType`

349342-- used to nullify the left or right hand side of an outer join

350343-- in a `Squeal.PostgreSQL.Query.FromClause`.

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

345+ NullifyFrom '[] = '[]

362346 NullifyFrom (table ::: columns ': tables) =

363347 table ::: NullifyRow columns ': NullifyFrom tables

364− NullifyFrom '[] = '[]

365348

366349-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in

367350-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@

@@ -371,101 +354,30 @@ type family Create alias x xs where

371354 Create alias x (alias ::: y ': xs) = TypeError

372355 ('Text "Create: alias "

373356 ':<>: 'ShowType alias

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

357+ ':<>: 'Text "already in use")

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

376359

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−

394360-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@

395361-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements

396362-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.

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

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

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

404366

405−type family DropSchemum alias sch xs where

406− DropSchemum alias sch '[] = TypeError

407− ('Text "DropSchemum: alias "

408− ':<>: 'ShowType alias

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

410− DropSchemum alias sch (alias ::: sch x ': xs) = xs

411− DropSchemum alias sch0 (alias ::: sch1 x ': xs) = TypeError

412− ('Text "DropSchemum: expected schemum "

413− ':<>: 'ShowType sch0

414− ':<>: 'Text " but alias "

415− ':<>: 'ShowType alias

416− ':<>: 'Text " has schemum "

417− ':<>: 'ShowType sch1)

418− DropSchemum alias sch (x ': xs) = x ': DropSchemum alias sch xs

419−

420−type family DropIfExists alias xs where

421− DropIfExists alias '[] = '[]

422− DropIfExists alias (alias ::: x ': xs) = xs

423− DropIfExists alias (x ': xs) = x ': DropIfExists alias xs

424−

425−type family DropSchemumIfExists alias sch xs where

426− DropSchemumIfExists alias sch '[] = '[]

427− DropSchemumIfExists alias sch (alias ::: sch x ': xs) = xs

428− DropSchemumIfExists alias sch0 (alias ::: sch1 x ': xs) = TypeError

429− ('Text "DropSchemumIfExists: expected schemum "

430− ':<>: 'ShowType sch1

431− ':<>: 'Text " but alias "

432− ':<>: 'ShowType alias

433− ':<>: 'Text " has schemum "

434− ':<>: 'ShowType sch0)

435− DropSchemumIfExists alias sch (x ': xs) = x ': DropSchemumIfExists alias sch xs

436−

437367-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@

438368-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable`

439369-- and `Squeal.PostgreSQL.Definition.alterColumn`.

440370type family Alter alias x xs where

441− Alter alias x '[] = TypeError

442− ('Text "Alter: alias "

443− ':<>: 'ShowType alias

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

445371 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs

446372 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs

447373

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−

453374-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@

454375-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and

455376-- `Squeal.PostgreSQL.Definition.renameColumn`.

456377type family Rename alias0 alias1 xs where

457− Rename alias0 alias1 '[] = TypeError

458− ('Text "Rename: alias "

459− ':<>: 'ShowType alias0

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

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

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

463380

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−

469381-- | Check if a `TableConstraint` involves a column

470382type family ConstraintInvolves column constraint where

471383 ConstraintInvolves column ('Check columns) = column `Elem` columns

@@ -482,35 +394,22 @@ type family DropIfConstraintsInvolve column constraints where

482394 (DropIfConstraintsInvolve column constraints)

483395 (alias ::: constraint ': DropIfConstraintsInvolve column constraints)

484396

397+{- | Calculate the `Length` of a type level list

398+

399+>>> :kind! Length '[Char,String,Bool,Double]

400+Length '[Char,String,Bool,Double] :: Nat

401+= 4

402+-}

403+type family Length (xs :: [k]) :: Nat where

404+ Length (x : xs) = 1 + Length xs

405+ Length '[] = 0

406+

485407-- | A `SchemumType` is a user-defined type, either a `Table`,

486408-- `View` or `Typedef`.

487409data SchemumType

488410 = Table TableType

489411 | View RowType

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

514413

515414{- | The schema of a database consists of a list of aliased,

516415user-defined `SchemumType`s.

squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+15−36

@@ -21,8 +21,6 @@ module Squeal.PostgreSQL.Transaction

2121 transactionally

2222 , transactionally_

2323 , transactionallyRetry

24− , ephemerally

25− , ephemerally_

2624 , begin

2725 , commit

2826 , rollback

@@ -35,6 +33,7 @@ module Squeal.PostgreSQL.Transaction

3533 , DeferrableMode (..)

3634 ) where

3735

36+import Control.Monad

3837import UnliftIO

3938

4039import Squeal.PostgreSQL.Manipulation

@@ -53,9 +52,9 @@ transactionally

5352 -> tx x -- ^ run inside a transaction

5453 -> tx x

5554transactionally mode tx = mask $ \restore -> do

56− manipulate_ $ begin mode

57− result <- restore tx `onException` (manipulate_ rollback)

58− manipulate_ commit

55+ begin mode

56+ result <- restore tx `onException` rollback

57+ commit

5958 return result

6059

6160-- | Run a computation `transactionally_`, in `defaultMode`.

@@ -82,52 +81,32 @@ transactionallyRetry

8281transactionallyRetry mode tx = mask $ \restore ->

8382 loop . try $ do

8483 x <- restore tx

85− manipulate_ commit

84+ commit

8685 return x

8786 where

8887 loop attempt = do

89− manipulate_ $ begin mode

88+ begin mode

9089 attempt >>= \case

9190 Left (PQException (PQState _ (Just "40001") _)) -> do

92− manipulate_ rollback

91+ rollback

9392 loop attempt

9493 Left err -> do

95− manipulate_ rollback

94+ rollback

9695 throwIO err

9796 Right x -> return x

9897

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−

12098-- | @BEGIN@ a transaction.

121−begin :: TransactionMode -> Manipulation_ schemas () ()

122−begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode

99+begin :: MonadPQ schemas tx => TransactionMode -> tx ()

100+begin mode = void . manipulate . UnsafeManipulation $

101+ "BEGIN" <+> renderSQL mode <> ";"

123102

124103-- | @COMMIT@ a transaction.

125−commit :: Manipulation_ schemas () ()

126−commit = UnsafeManipulation "COMMIT"

104+commit :: MonadPQ schemas tx => tx ()

105+commit = void . manipulate $ UnsafeManipulation "COMMIT;"

127106

128107-- | @ROLLBACK@ a transaction.

129−rollback :: Manipulation_ schemas () ()

130−rollback = UnsafeManipulation "ROLLBACK"

108+rollback :: MonadPQ schemas tx => tx ()

109+rollback = void . manipulate $ UnsafeManipulation "ROLLBACK;"

131110

132111-- | The available transaction characteristics are the transaction `IsolationLevel`,

133112-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.

squeal-postgresql/src/Squeal/PostgreSQL/Tutorial.hsnew file+39

@@ -0,0 +1,39 @@

1+{-|

2+Module: Squeal.PostgreSQL.Tutorail

3+Description: Squeal tutorial module

4+Copyright: (c) Eitan Chatav, 2017

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+== `P` records

10+A `P` record is an ad-hoc, anonymous record constructed

11+as a tuple of `P`s, a datatype from `Generics.SOP.Record`, like so:

12+

13+>>> type Rec = (P ("foo" ::: Double), P ("bar" ::: Char))

14+

15+Let's see what the image of `Rec` is under the `RowPG` type family.

16+

17+>>> :kind! RowPG Rec

18+RowPG Rec :: [(Symbol, NullityType)]

19+= '[ '("foo", 'NotNull 'PGfloat8), "bar" ::: 'NotNull ('PGchar 1)]

20+

21+`P` records are ad-hoc, anonymous records so unlike Haskell records

22+you don't have to define them outside of their use site, for instance

23+in the row type parameter of a `Query_` type family.

24+

25+>>> :{

26+let

27+ query :: Query_ schemas () (P ("foo" ::: Double))

28+ query = values_ (1 `as` #foo)

29+in printSQL query

30+:}

31+SELECT * FROM (VALUES (1)) AS t ("foo")

32+

33+You can even mix `P` records with normal Haskell records, which is very

34+useful for creating entity types, Haskell records with associated ids.

35+

36+>>> data Row = Row {foo :: Double, bar :: Char} deriving (GHC.Generic)

37+-}

38+

39+module Squeal.PostgreSQL.Tutorial where

squeal-postgresql/test/Doc.hsdeleted−6

@@ -1,6 +0,0 @@

1−module Main (main) where

2−

3−import Test.DocTest

4−

5−main :: IO ()

6−main = doctest [ "-isrc", "src" ]

squeal-postgresql/test/DocTest.hsnew file+18

@@ -0,0 +1,18 @@

1+module Main (main) where

3+import Test.DocTest

5+main :: IO ()

6+main = doctest

7+ [ "-isrc"

8+ , "src/Squeal/PostgreSQL.hs"

9+ , "src/Squeal/PostgreSQL/Binary.hs"

10+ , "src/Squeal/PostgreSQL/Definition.hs"

11+ , "src/Squeal/PostgreSQL/Manipulation.hs"

12+ , "src/Squeal/PostgreSQL/Query.hs"

13+ , "src/Squeal/PostgreSQL/Expression.hs"

14+ , "src/Squeal/PostgreSQL/PQ.hs"

15+ , "src/Squeal/PostgreSQL/Migration.hs"

16+ , "src/Squeal/PostgreSQL/Transaction.hs"

17+ , "src/Squeal/PostgreSQL/Pool.hs"

18+ ]

squeal-postgresql/test/Property.hsdeleted−166

@@ -1,166 +0,0 @@

1−{-# LANGUAGE

2− DataKinds

3− , GADTs

4− , LambdaCase

5− , OverloadedLabels

6− , OverloadedStrings

7− , TypeApplications

8− , TypeOperators

9−#-}

10−

11−module Main (main) where

12−

13−import Control.Monad.Trans

14−import Data.ByteString (ByteString)

15−import Data.ByteString.Char8 (unpack)

16−import Data.Scientific (fromFloatDigits)

17−import Data.Fixed (Fixed(MkFixed), Micro, Pico)

18−import Data.String (IsString(fromString))

19−import Data.Time

20−import Squeal.PostgreSQL hiding (check, defaultMain, Group)

21−import Hedgehog hiding (Range)

22−import qualified Hedgehog.Gen as Gen

23−import qualified Hedgehog.Main as Main

24−import qualified Hedgehog.Range as Range

25−

26−main :: IO ()

27−main = Main.defaultMain [checkSequential roundtrips]

28−

29−roundtrips :: Group

30−roundtrips = Group "roundtrips"

31− [ roundtrip int2 genInt16

32− , roundtrip int4 genInt32

33− , roundtrip int8 genInt64

34− , roundtrip bool Gen.bool

35− , roundtrip numeric genScientific

36− , roundtrip float4 genFloat

37− , roundtrip float8 genDouble

38− , roundtripOn normalizeTimeOfDay time genTimeOfDay

39− -- , roundtrip timetz genTimeWithZone normalizeTimeWithZone

40− , roundtripOn normalizeLocalTime timestamp genLocalTime

41− , roundtrip timestamptz genUTCTime

42− , roundtrip date genDay

43− , roundtrip interval genDiffTime

44− , roundtripOn normalizeIntRange int4range (genRange genInt32)

45− , roundtripOn normalizeIntRange int8range (genRange genInt64)

46− , roundtrip numrange (genRange genScientific)

47− , roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime)

48− , roundtrip tstzrange (genRange genUTCTime)

49− , roundtripOn normalizeIntRange daterange (genRange genDay)

50− ]

51− where

52− genInt16 = Gen.int16 Range.exponentialBounded

53− genInt32 = Gen.int32 Range.exponentialBounded

54− genInt64 = Gen.int64 Range.exponentialBounded

55− genScientific = fromFloatDigits <$> genFloat

56− genPosFloat = Gen.float

57− (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)

58− genFloat = Gen.prune $ Gen.choice

59− [ genPosFloat

60− , negate <$> genPosFloat

61− , Gen.element [0,1/0] ]

62− genPosDouble = Gen.double

63− (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)

64− genDouble = Gen.prune $ Gen.choice

65− [ genPosDouble

66− , negate <$> genPosDouble

67− , Gen.element [0,1/0] ]

68− genRange gen = do

69− lb <- gen

70− ub <- Gen.filter (lb <) gen

71− Gen.element

72− [ Empty, singleton lb, whole

73− , lb <=..<= ub , lb <=..< ub, lb <..<= ub, lb <..< ub

74− , atLeast lb, moreThan lb, atMost ub, lessThan ub ]

75− genDay = do

76− y <- toInteger <$> Gen.int (Range.constant 2000 2019)

77− m <- Gen.int (Range.constant 1 12)

78− d <- Gen.int (Range.constant 1 28)

79− return $ fromGregorian y m d

80− genDiffTime = secondsToDiffTime . toInteger <$>

81− Gen.int (Range.constant 0 86401)

82− genUTCTime = UTCTime <$> genDay <*> genDiffTime

83− genTimeOfDay = do

84− h <- Gen.int (Range.constant 0 23)

85− m <- Gen.int (Range.constant 0 59)

86− s <- MkFixed . toInteger <$> Gen.int (Range.constant 0 59)

87− return $ TimeOfDay h m s

88− genLocalTime = LocalTime <$> genDay <*> genTimeOfDay

89− -- genTimeZone = Gen.element $ map (read @TimeZone)

90− -- [ "UTC", "UT", "GMT", "EST", "EDT", "CST"

91− -- , "CDT", "MST", "MDT", "PST", "PDT" ]

92− -- genTimeWithZone = (,) <$> genTimeOfDay <*> genTimeZone

93−

94−roundtrip

95− :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)

96− => TypeExpression schemas ('NotNull ty)

97− -> Gen x

98− -> (PropertyName, Property)

99−roundtrip = roundtripOn id

100−

101−roundtripOn

102− :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)

103− => (x -> x)

104− -> TypeExpression schemas ('NotNull ty)

105− -> Gen x

106− -> (PropertyName, Property)

107−roundtripOn norm ty gen = propertyWithName $ do

108− x <- forAll gen

109− Just (Only y) <- lift . withConnection connectionString $

110− firstRow =<< runQueryParams

111− (values_ (parameter @1 ty `as` #fromOnly)) (Only x)

112− norm x === y

113− where

114− propertyWithName prop =

115− (fromString (unpack (renderSQL ty)), property prop)

116−

117−maxPosFloat :: RealFloat a => a

118−maxPosFloat = x

119− where

120− n = floatDigits x

121− b = floatRadix x

122− (_, u) = floatRange x

123− x = encodeFloat (b^n - 1) (u - n)

124−

125−minPosFloat :: RealFloat a => a

126−minPosFloat = x

127− where

128− n = floatDigits x

129− b = floatRadix x

130− (l, _) = floatRange x

131− x = encodeFloat (b^n - 1) (l - n - 1)

132−

133−connectionString :: ByteString

134−connectionString = "host=localhost port=5432 dbname=exampledb"

135−

136−normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int

137−normalizeIntRange = \case

138− Empty -> Empty

139− NonEmpty l u ->

140− let

141− l' = normalizeL l

142− u' = normalizeU u

143− in if emptyNormalized l' u' then Empty else NonEmpty l' u'

144− where

145− normalizeL = \case

146− Open l -> Closed (succ l)

147− normalized -> normalized

148− normalizeU = \case

149− Closed u -> Open (succ u)

150− normalized -> normalized

151− emptyNormalized (Closed l) (Open u) = l >= u

152− emptyNormalized _ _ = False

153−

154−normalizeTimeOfDay :: TimeOfDay -> TimeOfDay

155−normalizeTimeOfDay (TimeOfDay h m s) = TimeOfDay h m

156− . fromRational @Pico

157− . toRational @Micro

158− . fromRational @Micro

159− . toRational @Pico

160− $ s

161−

162−normalizeLocalTime :: LocalTime -> LocalTime

163−normalizeLocalTime (LocalTime d t) = LocalTime d (normalizeTimeOfDay t)

164−

165−-- normalizeTimeWithZone :: (TimeOfDay, TimeZone) -> (TimeOfDay, TimeZone)

166−-- normalizeTimeWithZone (t, z) = (normalizeTimeOfDay t, z)

squeal-postgresql/test/Spec.hsdeleted−136

@@ -1,136 +0,0 @@

1−{-# LANGUAGE

2− DataKinds

3− , DeriveAnyClass

4− , DeriveGeneric

5− , DerivingStrategies

6− , DuplicateRecordFields

7− , FlexibleContexts

8− , OverloadedLabels

9− , OverloadedLists

10− , OverloadedStrings

11− , TypeApplications

12− , TypeFamilies

13− , TypeInType

14− , TypeOperators

15−#-}

16−

17−module Main (main) where

18−

19−import Control.Concurrent.Async (replicateConcurrently)

20−import Data.ByteString (ByteString)

21−import Data.Int (Int32)

22−import Data.Text (Text)

23−import Test.Hspec

24−

25−import qualified Generics.SOP as SOP

26−import qualified GHC.Generics as GHC

27−

28−import Squeal.PostgreSQL

29−

30−main :: IO ()

31−main = hspec spec

32−

33−type Schemas = Public

34− '[ "users" ::: 'Table (

35− '[ "pk_users" ::: 'PrimaryKey '["id"]

36− , "unique_names" ::: 'Unique '["name"]

37− ] :=>

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

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

40−

41−data User = User

42− { userName :: Text

43− } deriving stock (Eq, Show, GHC.Generic)

44− deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)

45−

46−insertUser :: Manipulation_ Schemas User ()

47−insertUser = insertInto_ #users

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

49−

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

51−setup =

52− createTable #users

53− ( serial `as` #id :*

54− notNullable text `as` #name )

55− ( primaryKey #id `as` #pk_users :*

56− unique #name `as` #unique_names )

57−

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

59−teardown = dropTable #users

60−

61−silence :: MonadPQ schemas pq => pq ()

62−silence = manipulate_ $

63− UnsafeManipulation "SET client_min_messages TO WARNING;"

64−

65−setupDB :: IO ()

66−setupDB = withConnection connectionString $

67− silence & pqThen (define setup)

68−

69−dropDB :: IO ()

70−dropDB = withConnection connectionString $

71− silence & pqThen (define teardown)

72−

73−connectionString :: ByteString

74−connectionString = "host=localhost port=5432 dbname=exampledb"

75−

76−spec :: Spec

77−spec = before_ setupDB . after_ dropDB $ do

78−

79− describe "Exceptions" $ do

80−

81− let

82− testUser = User "TestUser"

83− newUser = manipulateParams_ insertUser

84− insertUserTwice = newUser testUser >> newUser testUser

85− err23505 = PQException $ PQState FatalError (Just "23505")

86− (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")

87−

88− it "should be thrown for constraint violation" $

89− withConnection connectionString insertUserTwice

90− `shouldThrow` (== err23505)

91−

92− it "should be rethrown for constraint violation in a transaction" $

93− withConnection connectionString (transactionally_ insertUserTwice)

94− `shouldThrow` (== err23505)

95−

96− describe "Pools" $

97−

98− it "should manage concurrent transactions" $ do

99− pool <- createConnectionPool

100− "host=localhost port=5432 dbname=exampledb" 1 0.5 10

101− let

102− query :: Query_ (Public '[]) () (Only Char)

103− query = values_ (literal 'a' `as` #fromOnly)

104− session = usingConnectionPool pool . transactionally_ $ do

105− result <- runQuery query

106− Just (Only chr) <- firstRow result

107− return chr

108− chrs <- replicateConcurrently 10 session

109− chrs `shouldSatisfy` all (== 'a')

110−

111− describe "Ranges" $

112−

113− it "should correctly decode ranges" $ do

114−

115− rangesOut <- withConnection connectionString $ do

116− let

117− query :: Query_ (Public '[]) () (Only (Range Int32))

118− query = values

119− ( range int4range (atLeast 3) `as` #fromOnly )

120− [ range int4range (3 <=..< 5) `as` #fromOnly

121− , range int4range Empty `as` #fromOnly

122− , range int4range whole `as` #fromOnly ]

123− getRows =<< runQuery query

124− (fromOnly <$> rangesOut :: [Range Int32]) `shouldBe`

125− [ atLeast 3, 3 <=..< 5, Empty, whole ]

126−

127− describe "Parameters" $ do

128−

129− it "should run queries that don't reference all their parameters" $ do

130−

131− out <- withConnection connectionString $ do

132− let

133− query :: Query_ (Public '[]) (Char,Int32) (Only Int32)

134− query = values_ (param @2 `as` #fromOnly)

135− firstRow =<< runQueryParams query ('a', 3 :: Int32)

136− (fromOnly <$> out :: Maybe Int32) `shouldBe` Just 3

squeal-postgresql/test/Specs/ExceptionHandling.hsnew file+126

@@ -0,0 +1,126 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DuplicateRecordFields #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE OverloadedLabels #-}

6+{-# LANGUAGE OverloadedLists #-}

7+{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE TypeApplications #-}

9+{-# LANGUAGE TypeFamilies #-}

10+{-# LANGUAGE TypeInType #-}

11+{-# LANGUAGE TypeOperators #-}

12+module ExceptionHandling

13+ ( specs

14+ , User (..)

15+ )

16+where

17+

18+import Control.Monad (void)

19+import Control.Monad.IO.Class (MonadIO (..))

20+import qualified Data.ByteString.Char8 as Char8

21+import Data.Int (Int16)

22+import Data.Text (Text)

23+import Data.Vector (Vector)

24+import qualified Generics.SOP as SOP

25+import qualified GHC.Generics as GHC

26+import Squeal.PostgreSQL

27+import Squeal.PostgreSQL.Migration

28+import Test.Hspec

29+

30+type Schema =

31+ '[ "users" ::: 'Table (

32+ '[ "pk_users" ::: 'PrimaryKey '["id"]

33+ , "unique_names" ::: 'Unique '["name"]

34+ ] :=>

35+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4

36+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext

37+ , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))

38+ ])

39+ , "emails" ::: 'Table (

40+ '[ "pk_emails" ::: 'PrimaryKey '["id"]

41+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]

42+ ] :=>

43+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4

44+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4

45+ , "email" ::: 'NoDef :=> 'Null 'PGtext

46+ ])

47+ ]

48+

49+type Schemas = Public Schema

50+

51+data User =

52+ User { userName :: Text

53+ , userEmail :: Maybe Text

54+ , userVec :: VarArray (Vector (Maybe Int16)) }

55+ deriving (Show, GHC.Generic)

56+instance SOP.Generic User

57+instance SOP.HasDatatypeInfo User

58+

59+insertUser :: Manipulation '[] Schemas '[ 'NotNull 'PGtext, 'NotNull ('PGvararray ('Null 'PGint2))]

60+ '[ "fromOnly" ::: 'NotNull 'PGint4 ]

61+insertUser = insertInto #users

62+ (Values_ (defaultAs #id :* param @1 `as` #name :* param @2 `as` #vec))

63+ OnConflictDoRaise (Returning (#id `as` #fromOnly))

64+

65+setup :: Definition (Public '[]) Schemas

66+setup =

67+ createTable #users

68+ ( serial `as` #id :*

69+ (text & notNullable) `as` #name :*

70+ (vararray int2 & notNullable) `as` #vec )

71+ ( primaryKey #id `as` #pk_users

72+ :* unique #name `as` #unique_names )

73+ >>>

74+ createTable #emails

75+ ( serial `as` #id :*

76+ (int & notNullable) `as` #user_id :*

77+ (text & nullable) `as` #email )

78+ ( primaryKey #id `as` #pk_emails :*

79+ foreignKey #user_id #users #id

80+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

81+

82+teardown :: Definition Schemas (Public '[])

83+teardown = dropTable #emails >>> dropTable #users

84+

85+migration :: Migration Definition (Public '[]) Schemas

86+migration = Migration { name = "test"

87+ , up = setup

88+ , down = teardown }

89+

90+setupDB :: IO ()

91+setupDB = void . withConnection connectionString $

92+ manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")

93+ & pqThen (migrateUp (single migration))

94+

95+dropDB :: IO ()

96+dropDB = void . withConnection connectionString $

97+ manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")

98+ & pqThen (migrateDown (single migration))

99+

100+connectionString :: Char8.ByteString

101+connectionString = "host=localhost port=5432 dbname=exampledb"

102+

103+testUser :: User

104+testUser = User "TestUser" Nothing (VarArray [])

105+

106+newUser :: (MonadIO m, MonadPQ Schemas m) => User -> m ()

107+newUser u = void $ manipulateParams insertUser (userName u, userVec u)

108+

109+insertUserTwice :: (MonadIO m, MonadPQ Schemas m) => m ()

110+insertUserTwice = newUser testUser >> newUser testUser

111+

112+specs :: SpecWith ()

113+specs = before_ setupDB $ after_ dropDB $

114+ describe "Exceptions" $ do

115+

116+ let

117+ dupKeyErr = PQException $ PQState FatalError (Just "23505")

118+ (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")

119+

120+ it "should be thrown for unique constraint violation in a manipulation" $

121+ withConnection connectionString insertUserTwice

122+ `shouldThrow` (== dupKeyErr)

123+

124+ it "should be rethrown for unique constraint violation in a manipulation by a transaction" $

125+ withConnection connectionString (transactionally_ insertUserTwice)

126+ `shouldThrow` (== dupKeyErr)

squeal-postgresql/test/Specs/Specs.hsnew file+7

@@ -0,0 +1,7 @@

1+module Specs where

3+import Test.Hspec

4+import qualified ExceptionHandling

6+main :: IO ()

7+main = hspec ExceptionHandling.specs

stack.yaml+1−3

@@ -1,8 +1,6 @@

1−resolver: nightly-2019-07-14

1+resolver: lts-13.8

22packages:

33- squeal-postgresql

55extra-deps:

66- unliftio-pool-0.2.1.0

7−- github: morphismtech/free-categories

8− commit: c0e555fbefb5c21619e532264c4dfeac556d0630