dev..41cf532 · squeal · git.iko.soy

git.iko.soy/squeal

47 files changed+1995−3929

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+5−7

@@ -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,16 +53,14 @@ 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

@@ -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+81−59

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

@@ -136,10 +140,10 @@ let

136140>>> printSQL insertUser

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

138142

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

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

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

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

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

143147

144148>>> :{

145149let

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

183187 usersRows <- getRows usersResult

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

185189in

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

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

187191 define setup

188192 & pqThen session

189193 & pqThen (define teardown)

190194:}

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

192196-}

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

197+module Squeal.PostgreSQL

198+ ( module Squeal.PostgreSQL.Alias

199+ , module Squeal.PostgreSQL.Binary

200+ , module Squeal.PostgreSQL.Definition

201+ , module Squeal.PostgreSQL.Expression

202+ , module Squeal.PostgreSQL.Expression.Aggregate

203+ , module Squeal.PostgreSQL.Expression.Collection

204+ , module Squeal.PostgreSQL.Expression.Comparison

205+ , module Squeal.PostgreSQL.Expression.Json

206+ , module Squeal.PostgreSQL.Expression.Literal

207+ , module Squeal.PostgreSQL.Expression.Logic

208+ , module Squeal.PostgreSQL.Expression.Math

209+ , module Squeal.PostgreSQL.Expression.Null

210+ , module Squeal.PostgreSQL.Expression.Parameter

211+ , module Squeal.PostgreSQL.Expression.SetOf

212+ , module Squeal.PostgreSQL.Expression.Sort

213+ , module Squeal.PostgreSQL.Expression.Subquery

214+ , module Squeal.PostgreSQL.Expression.Text

215+ , module Squeal.PostgreSQL.Expression.TextSearch

216+ , module Squeal.PostgreSQL.Expression.Time

217+ , module Squeal.PostgreSQL.Expression.Type

218+ , module Squeal.PostgreSQL.Expression.Window

219+ , module Squeal.PostgreSQL.List

220+ , module Squeal.PostgreSQL.Manipulation

221+ , module Squeal.PostgreSQL.PG

222+ , module Squeal.PostgreSQL.PQ

223+ , module Squeal.PostgreSQL.Query

224+ , module Squeal.PostgreSQL.Schema

225+ , module Squeal.PostgreSQL.Transaction

226+ ) where

227+

228+import Squeal.PostgreSQL.Alias

229+import Squeal.PostgreSQL.Binary

230+import Squeal.PostgreSQL.Definition

231+import Squeal.PostgreSQL.Expression

232+import Squeal.PostgreSQL.Expression.Aggregate

233+import Squeal.PostgreSQL.Expression.Collection

234+import Squeal.PostgreSQL.Expression.Comparison

235+import Squeal.PostgreSQL.Expression.Json

236+import Squeal.PostgreSQL.Expression.Literal

237+import Squeal.PostgreSQL.Expression.Logic

238+import Squeal.PostgreSQL.Expression.Math

239+import Squeal.PostgreSQL.Expression.Null

240+import Squeal.PostgreSQL.Expression.Parameter

241+import Squeal.PostgreSQL.Expression.SetOf

242+import Squeal.PostgreSQL.Expression.Sort

243+import Squeal.PostgreSQL.Expression.Subquery

244+import Squeal.PostgreSQL.Expression.Text

245+import Squeal.PostgreSQL.Expression.TextSearch

246+import Squeal.PostgreSQL.Expression.Time

247+import Squeal.PostgreSQL.Expression.Type

248+import Squeal.PostgreSQL.Expression.Window

249+import Squeal.PostgreSQL.List

250+import Squeal.PostgreSQL.Manipulation

251+import Squeal.PostgreSQL.PG

252+import Squeal.PostgreSQL.PQ

253+import Squeal.PostgreSQL.Query

254+import Squeal.PostgreSQL.Schema

255+import Squeal.PostgreSQL.Transaction

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+1028−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,970 @@ 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+{- |

137+`createSchema` enters a new schema into the current database.

138+The schema name must be distinct from the name of any existing schema

139+in the current database.

140+

141+A schema is essentially a namespace: it contains named objects

142+(tables, data types, functions, and operators) whose names

143+can duplicate those of other objects existing in other schemas.

144+Named objects are accessed by `QualifiedAlias`es with the schema

145+name as a prefix.

146+-}

147+createSchema

148+ :: KnownSymbol sch

149+ => Alias sch

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

151+createSchema sch = UnsafeDefinition $

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

153+

154+{- | Idempotent version of `createSchema`. -}

155+createSchemaIfNotExists

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

157+ => Alias sch

81158 -> Definition schemas schemas

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

159+createSchemaIfNotExists sch = UnsafeDefinition $

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

161+ <+> renderSQL sch <> ";"

162+

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

164+

165+>>> :set -XOverloadedLabels

166+>>> :{

167+type Table = '[] :=>

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

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

170+:}

171+

172+>>> :{

173+let

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

175+ setup = createTable #tab

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

177+in printSQL setup

178+:}

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

180+-}

181+createTable

182+ :: ( KnownSymbol sch

183+ , KnownSymbol tab

184+ , columns ~ (col ': cols)

185+ , SOP.SListI columns

186+ , SOP.SListI constraints

187+ , Has sch schemas0 schema0

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

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

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

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

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

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

194+ -> Definition schemas0 schemas1

195+createTable tab columns constraints = UnsafeDefinition $

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

197+

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

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

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

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

202+

203+>>> :set -XOverloadedLabels -XTypeApplications

204+>>> :{

205+type Table = '[] :=>

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

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

208+:}

209+

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

211+

212+>>> :{

213+let

214+ setup :: Definition Schemas Schemas

215+ setup = createTableIfNotExists #tab

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

217+in printSQL setup

218+:}

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

220+-}

221+createTableIfNotExists

222+ :: ( Has sch schemas schema

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

224+ , SOP.SListI columns

225+ , SOP.SListI constraints )

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

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

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

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

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

231+ -> Definition schemas schemas

232+createTableIfNotExists tab columns constraints = UnsafeDefinition $

233+ "CREATE TABLE IF NOT EXISTS"

234+ <+> renderCreation tab columns constraints

235+

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

237+renderCreation

238+ :: ( KnownSymbol sch

239+ , KnownSymbol tab

240+ , SOP.SListI columns

241+ , SOP.SListI constraints )

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

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

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

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

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

247+ -> ByteString

248+renderCreation tab columns constraints = renderSQL tab

249+ <+> parenthesized

250+ ( renderCommaSeparated renderColumnDef columns

251+ <> ( case constraints of

252+ Nil -> ""

253+ _ -> ", " <>

254+ renderCommaSeparated renderConstraint constraints ) )

255+ <> ";"

256+ where

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

258+ renderColumnDef (ty `As` column) =

259+ renderSQL column <+> renderColumnTypeExpression ty

260+ renderConstraint

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

262+ -> ByteString

263+ renderConstraint (constraint `As` alias) =

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

265+

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

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

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

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

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

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

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

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

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

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

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

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

278+newtype TableConstraintExpression

279+ (sch :: Symbol)

280+ (tab :: Symbol)

281+ (schemas :: SchemasType)

282+ (constraint :: TableConstraint)

283+ = UnsafeTableConstraintExpression

284+ { renderTableConstraintExpression :: ByteString }

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

286+instance RenderSQL

287+ (TableConstraintExpression sch tab schemas constraint) where

288+ renderSQL = renderTableConstraintExpression

289+

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

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

292+a Boolean (truth-value) expression.

293+

294+>>> :{

295+type Schema = '[

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

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

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

299+ ])]

300+:}

301+

302+>>> :{

303+let

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

305+ definition = createTable #tab

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

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

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

309+:}

310+

311+>>> printSQL definition

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

313+-}

314+check

315+ :: ( Has sch schemas schema

316+ , Has tab schema ('Table table)

317+ , HasAll aliases (TableToRow table) subcolumns )

318+ => NP Alias aliases

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

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

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

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

323+check _cols condition = UnsafeTableConstraintExpression $

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

325+

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

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

328+

329+>>> :{

330+type Schema = '[

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

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

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

334+ ])]

335+:}

336+

337+>>> :{

338+let

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

340+ definition = createTable #tab

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

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

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

344+:}

345+

346+>>> printSQL definition

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

348+-}

349+unique

350+ :: ( Has sch schemas schema

351+ , Has tab schema('Table table)

352+ , HasAll aliases (TableToRow table) subcolumns )

353+ => NP Alias aliases

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

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

356+unique columns = UnsafeTableConstraintExpression $

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

358+

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

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

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

362+

363+>>> :{

364+type Schema = '[

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

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

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

368+ ])]

369+:}

370+

371+>>> :{

372+let

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

374+ definition = createTable #tab

375+ ( serial `as` #id :*

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

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

378+:}

379+

380+>>> printSQL definition

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

382+-}

383+primaryKey

384+ :: ( Has sch schemas schema

385+ , Has tab schema ('Table table)

386+ , HasAll aliases (TableToColumns table) subcolumns

387+ , AllNotNull subcolumns )

388+ => NP Alias aliases

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

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

391+primaryKey columns = UnsafeTableConstraintExpression $

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

393+

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

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

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

397+between two related tables.

398+

399+>>> :{

400+type Schema =

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

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

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

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

405+ ])

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

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

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

409+ ] :=>

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

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

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

413+ ])

414+ ]

415+:}

416+

417+>>> :{

418+let

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

420+ setup =

421+ createTable #users

422+ ( serial `as` #id :*

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

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

425+ createTable #emails

426+ ( serial `as` #id :*

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

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

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

430+ foreignKey #user_id #users #id

431+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

432+in printSQL setup

433+:}

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

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

436+

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

438+

439+>>> :{

440+type Schema =

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

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

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

444+ ] :=>

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

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

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

448+ ])

449+ ]

450+:}

451+

452+>>> :{

453+let

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

455+ setup =

456+ createTable #employees

457+ ( serial `as` #id :*

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

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

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

461+ foreignKey #employer_id #employees #id

462+ OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )

463+in printSQL setup

464+:}

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

466+-}

467+foreignKey

468+ :: (ForeignKeyed schemas sch schema child parent

469+ table reftable

470+ columns refcolumns

471+ constraints cols

472+ reftys tys )

473+ => NP Alias columns

474+ -- ^ column or columns in the table

475+ -> Alias parent

476+ -- ^ reference table

477+ -> NP Alias refcolumns

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

479+ -> OnDeleteClause

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

481+ -> OnUpdateClause

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

483+ -> TableConstraintExpression sch child schemas

484+ ('ForeignKey columns parent refcolumns)

485+foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $

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

487+ <+> "REFERENCES" <+> renderSQL parent

488+ <+> parenthesized (renderSQL refs)

489+ <+> renderSQL ondel

490+ <+> renderSQL onupd

491+

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

493+type ForeignKeyed schemas

494+ sch

495+ schema

496+ child parent

497+ table reftable

498+ columns refcolumns

499+ constraints cols

500+ reftys tys =

501+ ( Has sch schemas schema

502+ , Has child schema ('Table table)

503+ , Has parent schema ('Table reftable)

504+ , HasAll columns (TableToColumns table) tys

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

506+ , HasAll refcolumns cols reftys

507+ , SOP.AllZip SamePGType tys reftys

508+ , Uniquely refcolumns constraints )

509+

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

511+data OnDeleteClause

512+ = OnDeleteNoAction

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

514+ -- an error is raised

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

516+ | OnDeleteCascade

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

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

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

520+instance NFData OnDeleteClause

521+-- | Render `OnDeleteClause`.

522+instance RenderSQL OnDeleteClause where

523+ renderSQL = \case

524+ OnDeleteNoAction -> "ON DELETE NO ACTION"

525+ OnDeleteRestrict -> "ON DELETE RESTRICT"

526+ OnDeleteCascade -> "ON DELETE CASCADE"

527+

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

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

530+data OnUpdateClause

531+ = OnUpdateNoAction

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

533+ -- an error is raised

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

535+ | OnUpdateCascade

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

537+ -- into the referencing row(s)

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

539+instance NFData OnUpdateClause

540+

541+-- | Render `OnUpdateClause`.

542+instance RenderSQL OnUpdateClause where

543+ renderSQL = \case

544+ OnUpdateNoAction -> "ON UPDATE NO ACTION"

545+ OnUpdateRestrict -> "ON UPDATE RESTRICT"

546+ OnUpdateCascade -> "ON UPDATE CASCADE"

547+

548+{-----------------------------------------

549+DROP statements

550+-----------------------------------------}

551+

552+-- | >>> :{

553+-- let

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

555+-- definition = dropSchema #muh_schema

556+-- :}

557+--

558+-- >>> printSQL definition

559+-- DROP SCHEMA "muh_schema";

560+dropSchema

561+ :: Has sch schemas schema

562+ => Alias sch

563+ -> Definition schemas (Drop sch schemas)

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

565+

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

567+--

568+-- >>> :{

569+-- let

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

571+-- definition = dropTable #muh_table

572+-- :}

573+--

574+-- >>> printSQL definition

575+-- DROP TABLE "muh_table";

576+dropTable

577+ :: ( Has sch schemas schema

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

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

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

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

582+

583+{-----------------------------------------

584+ALTER statements

585+-----------------------------------------}

586+

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

588+alterTable

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

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

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

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

593+alterTable tab alteration = UnsafeDefinition $

594+ "ALTER TABLE"

595+ <+> renderSQL tab

596+ <+> renderAlterTable alteration

597+ <> ";"

598+

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

600+--

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

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

603+alterTableRename

604+ :: (KnownSymbol table0, KnownSymbol table1)

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

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

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

608+alterTableRename table0 table1 = UnsafeDefinition $

609+ "ALTER TABLE" <+> renderSQL table0

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

611+

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

613+-- of a table.

614+newtype AlterTable

615+ (sch :: Symbol)

616+ (tab :: Symbol)

617+ (schemas :: SchemasType)

618+ (table :: TableType) =

619+ UnsafeAlterTable {renderAlterTable :: ByteString}

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

621+

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

623+--

624+-- >>> :{

625+-- let

626+-- definition :: Definition

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

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

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

630+-- in printSQL definition

631+-- :}

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

633+addConstraint

634+ :: ( KnownSymbol alias

635+ , Has sch schemas schema

636+ , Has tab schema ('Table table0)

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

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

639+ => Alias alias

640+ -> TableConstraintExpression sch tab schemas constraint

641+ -- ^ constraint to add

642+ -> AlterTable sch tab schemas table1

643+addConstraint alias constraint = UnsafeAlterTable $

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

645+ <+> renderSQL constraint

646+

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

648+--

649+-- >>> :{

650+-- let

651+-- definition :: Definition

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

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

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

655+-- in printSQL definition

656+-- :}

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

658+dropConstraint

659+ :: ( KnownSymbol constraint

660+ , Has sch schemas schema

661+ , Has tab schema ('Table table0)

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

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

664+ => Alias constraint

665+ -- ^ constraint to drop

666+ -> AlterTable sch tab schemas table1

667+dropConstraint constraint = UnsafeAlterTable $

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

669+

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

671+class AddColumn ty where

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

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

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" ::: 'Def :=> 'Null 'PGtext ])]]

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

683+ -- in printSQL definition

684+ -- :}

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

686+ --

687+ -- >>> :{

688+ -- let

689+ -- definition :: Definition

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

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

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

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

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

695+ -- in printSQL definition

696+ -- :}

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

698+ addColumn

699+ :: ( KnownSymbol column

700+ , Has sch schemas schema

701+ , Has tab schema ('Table table0)

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

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

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

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

706+ addColumn column ty = UnsafeAlterTable $

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

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

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

710+

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

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

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

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

715+--

716+-- >>> :{

717+-- let

718+-- definition :: Definition

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

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

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

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

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

724+-- in printSQL definition

725+-- :}

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

727+dropColumn

728+ :: ( KnownSymbol column

729+ , Has sch schemas schema

730+ , Has tab schema ('Table table0)

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

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

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

734+ -> AlterTable sch tab schemas table1

735+dropColumn column = UnsafeAlterTable $

736+ "DROP COLUMN" <+> renderSQL column

737+

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

739+--

740+-- >>> :{

741+-- let

742+-- definition :: Definition

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

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

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

746+-- in printSQL definition

747+-- :}

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

749+renameColumn

750+ :: ( KnownSymbol column0

751+ , KnownSymbol column1

752+ , Has sch schemas schema

753+ , Has tab schema ('Table table0)

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

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

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

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

758+ -> AlterTable sch tab schemas table1

759+renameColumn column0 column1 = UnsafeAlterTable $

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

761+

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

763+alterColumn

764+ :: ( KnownSymbol column

765+ , Has sch schemas schema

766+ , Has tab schema ('Table table0)

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

768+ , Has column columns ty0

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

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

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

772+ -> AlterTable sch tab schemas table1

773+alterColumn column alteration = UnsafeAlterTable $

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

775+

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

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

778+ UnsafeAlterColumn {renderAlterColumn :: ByteString}

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

780+

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

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

783+-- future insert and update commands.

784+--

785+-- >>> :{

786+-- let

787+-- definition :: Definition

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

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

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

791+-- in printSQL definition

792+-- :}

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

794+setDefault

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

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

797+setDefault expression = UnsafeAlterColumn $

798+ "SET DEFAULT" <+> renderExpression expression

799+

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

801+--

802+-- >>> :{

803+-- let

804+-- definition :: Definition

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

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

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

808+-- in printSQL definition

809+-- :}

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

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

812+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"

813+

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

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

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

817+--

818+-- >>> :{

819+-- let

820+-- definition :: Definition

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

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

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

824+-- in printSQL definition

825+-- :}

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

827+setNotNull

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

829+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"

830+

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

832+--

833+-- >>> :{

834+-- let

835+-- definition :: Definition

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

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

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

839+-- in printSQL definition

840+-- :}

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

842+dropNotNull

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

844+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"

845+

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

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

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

849+--

850+-- >>> :{

851+-- let

852+-- definition :: Definition

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

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

855+-- definition =

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

857+-- in printSQL definition

858+-- :}

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

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

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

862+

863+{- | Create a view.

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

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

866+>>> :{

867+let

868+ definition :: Definition

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

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

871+ definition =

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

873+in printSQL definition

874+:}

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

876+-}

877+createView

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

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

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

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

882+createView alias query = UnsafeDefinition $

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

884+ <+> renderQuery query <> ";"

885+

886+-- | Drop a view.

887+--

888+-- >>> :{

889+-- let

890+-- definition :: Definition

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

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

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

894+-- definition = dropView #bc

895+-- in printSQL definition

896+-- :}

897+-- DROP VIEW "bc";

898+dropView

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

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

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

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

903+

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

905+--

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

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

908+createTypeEnum

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

910+ => QualifiedAlias sch enum

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

912+ -> NP PGlabel labels

913+ -- ^ labels of the enumerated type

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

915+createTypeEnum enum labels = UnsafeDefinition $

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

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

918+

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

920+--

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

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

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

924+-- >>> :{

925+-- let

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

927+-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma

928+-- in

929+-- printSQL createSchwarma

930+-- :}

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

932+createTypeEnumFrom

933+ :: forall hask sch enum schemas schema.

934+ ( SOP.Generic hask

935+ , SOP.All KnownSymbol (LabelsPG hask)

936+ , KnownSymbol enum

937+ , Has sch schemas schema )

938+ => QualifiedAlias sch enum

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

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

941+createTypeEnumFrom enum = createTypeEnum enum

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

943+

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

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

946+

947+>>> :{

948+type PGcomplex = 'PGcomposite

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

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

951+:}

952+

953+>>> :{

954+let

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

956+ setup = createTypeComposite #complex

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

958+in printSQL setup

959+:}

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

961+-}

962+createTypeComposite

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

964+ => QualifiedAlias sch ty

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

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

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

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

969+createTypeComposite ty fields = UnsafeDefinition $

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

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

972+ where

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

974+ renderField (typ `As` alias) =

975+ renderSQL alias <+> renderSQL typ

976+

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

978+--

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

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

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

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

983+-- >>> :{

984+-- let

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

986+-- createComplex = createTypeCompositeFrom @Complex #complex

987+-- in

988+-- printSQL createComplex

989+-- :}

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

991+createTypeCompositeFrom

992+ :: forall hask sch ty schemas schema.

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

994+ , KnownSymbol ty

995+ , Has sch schemas schema )

996+ => QualifiedAlias sch ty

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

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

999+createTypeCompositeFrom ty = createTypeComposite ty

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

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

1002+

1003+{-|

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

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

1006+

1007+Domains are useful for abstracting common constraints on fields

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

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

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

1011+each table's constraint individually.

1012+

1013+>>> :{

1014+let

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

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

1017+in printSQL createPositive

1018+:}

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

1020+-}

1021+createDomain

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

1023+ => QualifiedAlias sch dom

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

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

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

1027+createDomain dom ty condition =

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

1029+ <+> "AS" <+> renderTypeExpression ty

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

1031+

1032+class FieldTyped schemas ty where

1033+ fieldtype :: Aliased (TypeExpression schemas) ty

1034+instance (KnownSymbol alias, PGTyped schemas ty)

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

1036+ fieldtype = pgtype `As` Alias

1037+

1038+-- | Drop a type.

1039+--

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

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

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

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

1044+-- DROP TYPE "schwarma";

1045+dropType

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

1047+ => QualifiedAlias sch td

1048+ -- ^ name of the user defined type

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

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

1051+

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

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

1054+ = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }

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

1056+instance RenderSQL (ColumnTypeExpression schemas ty) where

1057+ renderSQL = renderColumnTypeExpression

1058+

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

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

1061+nullable

1062+ :: TypeExpression schemas (nullity ty)

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

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

1065+

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

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

1068+notNullable

1069+ :: TypeExpression schemas (nullity ty)

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

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

1072+

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

1074+default_

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

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

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

1078+default_ x ty = UnsafeColumnTypeExpression $

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

1080+

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

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

1083+serial2, smallserial

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

1085+serial2 = UnsafeColumnTypeExpression "serial2"

1086+smallserial = UnsafeColumnTypeExpression "smallserial"

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

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

1089+serial4, serial

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

1091+serial4 = UnsafeColumnTypeExpression "serial4"

1092+serial = UnsafeColumnTypeExpression "serial"

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

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

1095+serial8, bigserial

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

1097+serial8 = UnsafeColumnTypeExpression "serial8"

1098+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−5

@@ -42,7 +42,7 @@ import qualified Generics.SOP as SOP

4242

4343import Squeal.PostgreSQL.Alias

4444import Squeal.PostgreSQL.Expression

45−import Squeal.PostgreSQL.Expression.Set

45+import Squeal.PostgreSQL.Expression.SetOf

4646import Squeal.PostgreSQL.List

4747import Squeal.PostgreSQL.Render

4848import Squeal.PostgreSQL.Schema

@@ -111,20 +111,20 @@ array2 xss = UnsafeExpression $ "ARRAY" <>

111111

112112-- | >>> printSQL $ cardinality (array [null_, false, true])

113113-- cardinality(ARRAY[NULL, FALSE, TRUE])

114−cardinality :: null ('PGvararray ty) --> null 'PGint8

114+cardinality :: null ('PGvararray ty) :--> null 'PGint8

115115cardinality = unsafeFunction "cardinality"

116116

117117-- | >>> printSQL $ array [null_, false, true] & index 2

118118-- (ARRAY[NULL, FALSE, TRUE])[2]

119119index

120120 :: Word64 -- ^ index

121− -> null ('PGvararray ty) --> NullifyType ty

121+ -> null ('PGvararray ty) :--> NullifyType ty

122122index n expr = UnsafeExpression $

123123 parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"

124124

125125-- | Expand an array to a set of rows

126−unnest :: SetFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]

127−unnest = unsafeSetFunction

126+unnest :: SetOfFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]

127+unnest = unsafeSetOfFunction

128128

129129-- | A row constructor is an expression that builds a row value

130130-- (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+47−40

@@ -81,7 +81,7 @@ import GHC.TypeLits

8181

8282import Squeal.PostgreSQL.Alias

8383import Squeal.PostgreSQL.Expression

84−import Squeal.PostgreSQL.Expression.Set

84+import Squeal.PostgreSQL.Expression.SetOf

8585import Squeal.PostgreSQL.Expression.Type

8686import Squeal.PostgreSQL.List

8787import Squeal.PostgreSQL.Query

@@ -188,7 +188,7 @@ Table 9.45: JSON creation functions

188188-- otherwise, a scalar value is produced. For any scalar type other than a

189189-- number, a Boolean, or a null value, the text representation will be used, in

190190-- such a fashion that it is a valid json value.

191−toJson :: null ty --> null 'PGjson

191+toJson :: null ty :--> null 'PGjson

192192toJson = unsafeFunction "to_json"

193193

194194-- | Returns the value as jsonb. Arrays and composites are converted

@@ -197,26 +197,26 @@ toJson = unsafeFunction "to_json"

197197-- otherwise, a scalar value is produced. For any scalar type other than a

198198-- number, a Boolean, or a null value, the text representation will be used, in

199199-- such a fashion that it is a valid jsonb value.

200−toJsonb :: null ty --> null 'PGjsonb

200+toJsonb :: null ty :--> null 'PGjsonb

201201toJsonb = unsafeFunction "to_jsonb"

202202

203203-- | Returns the array as a JSON array. A PostgreSQL multidimensional array

204204-- becomes a JSON array of arrays.

205−arrayToJson :: null ('PGvararray ty) --> null 'PGjson

205+arrayToJson :: null ('PGvararray ty) :--> null 'PGjson

206206arrayToJson = unsafeFunction "array_to_json"

207207

208208-- | Returns the row as a JSON object.

209−rowToJson :: null ('PGcomposite ty) --> null 'PGjson

209+rowToJson :: null ('PGcomposite ty) :--> null 'PGjson

210210rowToJson = unsafeFunction "row_to_json"

211211

212212-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic

213213-- argument list.

214−jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson

214+jsonBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjson)

215215jsonBuildArray = unsafeFunctionN "json_build_array"

216216

217217-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a

218218-- variadic argument list.

219−jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb

219+jsonbBuildArray :: SOP.SListI tuple => FunctionN tuple (null 'PGjsonb)

220220jsonbBuildArray = unsafeFunctionN "jsonb_build_array"

221221

222222-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic

@@ -224,10 +224,10 @@ jsonbBuildArray = unsafeFunctionN "jsonb_build_array"

224224-- and values.

225225class SOP.SListI tys => JsonBuildObject tys where

226226

227− jsonBuildObject :: tys ---> null 'PGjson

227+ jsonBuildObject :: FunctionN tys (null 'PGjson)

228228 jsonBuildObject = unsafeFunctionN "json_build_object"

229229

230− jsonbBuildObject :: tys ---> null 'PGjsonb

230+ jsonbBuildObject :: FunctionN tys (null 'PGjsonb)

231231 jsonbBuildObject = unsafeFunctionN "jsonb_build_object"

232232

233233instance JsonBuildObject '[]

@@ -240,7 +240,7 @@ instance (JsonBuildObject tys, key `In` PGJsonKey)

240240-- which are taken as a key/value pair.

241241jsonObject

242242 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))

243− --> null 'PGjson

243+ :--> null 'PGjson

244244jsonObject = unsafeFunction "json_object"

245245

246246-- | Builds a binary JSON object out of a text array.

@@ -249,24 +249,24 @@ jsonObject = unsafeFunction "json_object"

249249-- which are taken as a key/value pair.

250250jsonbObject

251251 :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))

252− --> null 'PGjsonb

252+ :--> null 'PGjsonb

253253jsonbObject = unsafeFunction "jsonb_object"

254254

255255-- | This is an alternate form of 'jsonObject' that takes two arrays; one for

256256-- keys and one for values, that are zipped pairwise to create a JSON object.

257−jsonZipObject ::

257+jsonZipObject :: FunctionN

258258 '[ null ('PGvararray ('NotNull 'PGtext))

259259 , null ('PGvararray ('NotNull 'PGtext)) ]

260− ---> null 'PGjson

260+ ( null 'PGjson )

261261jsonZipObject = unsafeFunctionN "json_object"

262262

263263-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for

264264-- keys and one for values, that are zipped pairwise to create a binary JSON

265265-- object.

266−jsonbZipObject ::

266+jsonbZipObject :: FunctionN

267267 '[ null ('PGvararray ('NotNull 'PGtext))

268268 , null ('PGvararray ('NotNull 'PGtext)) ]

269− ---> null 'PGjsonb

269+ ( null 'PGjsonb )

270270jsonbZipObject = unsafeFunctionN "jsonb_object"

271271

272272{-----------------------------------------

@@ -274,31 +274,31 @@ Table 9.46: JSON processing functions

274274-----------------------------------------}

275275

276276-- | Returns the number of elements in the outermost JSON array.

277−jsonArrayLength :: null 'PGjson --> null 'PGint4

277+jsonArrayLength :: null 'PGjson :--> null 'PGint4

278278jsonArrayLength = unsafeFunction "json_array_length"

279279

280280-- | Returns the number of elements in the outermost binary JSON array.

281−jsonbArrayLength :: null 'PGjsonb --> null 'PGint4

281+jsonbArrayLength :: null 'PGjsonb :--> null 'PGint4

282282jsonbArrayLength = unsafeFunction "jsonb_array_length"

283283

284284-- | Returns the type of the outermost JSON value as a text string. Possible

285285-- types are object, array, string, number, boolean, and null.

286−jsonTypeof :: null 'PGjson --> null 'PGtext

286+jsonTypeof :: null 'PGjson :--> null 'PGtext

287287jsonTypeof = unsafeFunction "json_typeof"

288288

289289-- | Returns the type of the outermost binary JSON value as a text string.

290290-- Possible types are object, array, string, number, boolean, and null.

291−jsonbTypeof :: null 'PGjsonb --> null 'PGtext

291+jsonbTypeof :: null 'PGjsonb :--> null 'PGtext

292292jsonbTypeof = unsafeFunction "jsonb_typeof"

293293

294294-- | Returns its argument with all object fields that have null values omitted.

295295-- Other null values are untouched.

296−jsonStripNulls :: null 'PGjson --> null 'PGjson

296+jsonStripNulls :: null 'PGjson :--> null 'PGjson

297297jsonStripNulls = unsafeFunction "json_strip_nulls"

298298

299299-- | Returns its argument with all object fields that have null values omitted.

300300-- Other null values are untouched.

301−jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb

301+jsonbStripNulls :: null 'PGjsonb :--> null 'PGjsonb

302302jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"

303303

304304-- | @ jsonbSet target path new_value create_missing @

@@ -309,9 +309,12 @@ jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"

309309-- item designated by path does not exist. As with the path orientated

310310-- operators, negative integers that appear in path count from the end of JSON

311311-- arrays.

312−jsonbSet ::

313− '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))

314− , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb

312+jsonbSet

313+ :: FunctionN

314+ '[ null 'PGjsonb

315+ , null ('PGvararray ('NotNull 'PGtext))

316+ , null 'PGjsonb

317+ , null 'PGbool ] (null 'PGjsonb)

315318jsonbSet = unsafeFunctionN "jsonbSet"

316319

317320-- | @ jsonbInsert target path new_value insert_after @

@@ -323,23 +326,27 @@ jsonbSet = unsafeFunctionN "jsonbSet"

323326-- path is in JSONB object, @new_value@ will be inserted only if target does not

324327-- exist. As with the path orientated operators, negative integers that appear

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

330+ :: FunctionN

331+ '[ null 'PGjsonb

332+ , null ('PGvararray ('NotNull 'PGtext))

333+ , null 'PGjsonb

334+ , null 'PGbool ] (null 'PGjsonb)

329335jsonbInsert = unsafeFunctionN "jsonb_insert"

330336

331337-- | Returns its argument as indented JSON text.

332−jsonbPretty :: null 'PGjsonb --> null 'PGtext

338+jsonbPretty :: null 'PGjsonb :--> null 'PGtext

333339jsonbPretty = unsafeFunction "jsonb_pretty"

334340

341+

335342{- | Expands the outermost JSON object into a set of key/value pairs.

336343

337344>>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))

338345SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))

339346-}

340−jsonEach :: SetFunction "json_each" (null 'PGjson)

347+jsonEach :: SetOfFunction "json_each" (null 'PGjson)

341348 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]

342−jsonEach = unsafeSetFunction

349+jsonEach = unsafeSetOfFunction

343350

344351{- | Expands the outermost binary JSON object into a set of key/value pairs.

345352

@@ -347,9 +354,9 @@ jsonEach = unsafeSetFunction

347354SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))

348355-}

349356jsonbEach

350− :: SetFunction "jsonb_each" (nullity 'PGjsonb)

357+ :: SetOfFunction "jsonb_each" (nullity 'PGjsonb)

351358 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]

352−jsonbEach = unsafeSetFunction

359+jsonbEach = unsafeSetOfFunction

353360

354361{- | Expands the outermost JSON object into a set of key/value pairs.

355362

@@ -357,9 +364,9 @@ jsonbEach = unsafeSetFunction

357364SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))

358365-}

359366jsonEachText

360− :: SetFunction "json_each_text" (null 'PGjson)

367+ :: SetOfFunction "json_each_text" (null 'PGjson)

361368 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]

362−jsonEachText = unsafeSetFunction

369+jsonEachText = unsafeSetOfFunction

363370

364371{- | Expands the outermost binary JSON object into a set of key/value pairs.

365372

@@ -367,9 +374,9 @@ jsonEachText = unsafeSetFunction

367374SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))

368375-}

369376jsonbEachText

370− :: SetFunction "jsonb_each_text" (null 'PGjsonb)

377+ :: SetOfFunction "jsonb_each_text" (null 'PGjsonb)

371378 '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]

372−jsonbEachText = unsafeSetFunction

379+jsonbEachText = unsafeSetOfFunction

373380

374381{- | Returns set of keys in the outermost JSON object.

375382

@@ -377,9 +384,9 @@ jsonbEachText = unsafeSetFunction

377384json_object_keys(('{"a":"foo","b":"bar"}' :: json))

378385-}

379386jsonObjectKeys

380− :: SetFunction "json_object_keys" (nullity 'PGjson)

387+ :: SetOfFunction "json_object_keys" (nullity 'PGjson)

381388 '["json_object_keys" ::: 'NotNull 'PGtext]

382−jsonObjectKeys = unsafeSetFunction

389+jsonObjectKeys = unsafeSetOfFunction

383390

384391{- | Returns set of keys in the outermost JSON object.

385392

@@ -387,9 +394,9 @@ jsonObjectKeys = unsafeSetFunction

387394jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))

388395-}

389396jsonbObjectKeys

390− :: SetFunction "jsonb_object_keys" (null 'PGjsonb)

397+ :: SetOfFunction "jsonb_object_keys" (null 'PGjsonb)

391398 '["jsonb_object_keys" ::: 'NotNull 'PGtext]

392−jsonbObjectKeys = unsafeSetFunction

399+jsonbObjectKeys = unsafeSetOfFunction

393400

394401-- | Build rows from Json types.

395402type JsonPopulateFunction fun json

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

@@ -23,16 +23,13 @@ Type expressions.

2323 , ScopedTypeVariables

2424 , TypeApplications

2525 , TypeOperators

26− , UndecidableInstances

2726#-}

2827

2928module Squeal.PostgreSQL.Expression.Type

30− ( -- * type casting

31− cast

29+ ( TypeExpression (..)

30+ , cast

3231 , astype

33− , inferredtype

34− -- * type expressions

35− , TypeExpression (..)

32+ , PGTyped (..)

3633 , typedef

3734 , typetable

3835 , typeview

@@ -58,11 +55,9 @@ module Squeal.PostgreSQL.Expression.Type

5855 , bytea

5956 , timestamp

6057 , timestampWithTimeZone

61− , timestamptz

6258 , date

6359 , time

6460 , timeWithTimeZone

65− , timetz

6661 , interval

6762 , uuid

6863 , inet

@@ -72,29 +67,6 @@ module Squeal.PostgreSQL.Expression.Type

7267 , fixarray

7368 , tsvector

7469 , 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 (..)

9870 ) where

9971

10072import Control.DeepSeq

@@ -108,7 +80,6 @@ import qualified Generics.SOP as SOP

10880

10981import Squeal.PostgreSQL.Alias

11082import Squeal.PostgreSQL.Expression

111−import Squeal.PostgreSQL.PG

11283import Squeal.PostgreSQL.Render

11384import Squeal.PostgreSQL.Schema

11485

@@ -142,18 +113,6 @@ astype

142113 -> Expression outer commons grp schemas params from ty

143114astype = cast

144115

145−-- | `inferredtype` will add a type annotation to an `Expression`

146−-- which can be useful for fixing the storage type of a value.

147−--

148−-- >>> printSQL (inferredtype true)

149−-- (TRUE :: bool)

150−inferredtype

151− :: PGTyped schemas ty

152− => Expression outer common grp schemas params from ty

153− -- ^ value

154− -> Expression outer common grp schemas params from ty

155−inferredtype = astype pgtype

156−

157116{-----------------------------------------

158117type expressions

159118-----------------------------------------}

@@ -170,7 +129,6 @@ instance RenderSQL (TypeExpression schemas ty) where

170129typedef

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

172131 => QualifiedAlias sch td

173− -- ^ type alias

174132 -> TypeExpression schemas (null ty)

175133typedef = UnsafeTypeExpression . renderSQL

176134

@@ -179,7 +137,6 @@ typedef = UnsafeTypeExpression . renderSQL

179137typetable

180138 :: (Has sch schemas schema, Has tab schema ('Table table))

181139 => QualifiedAlias sch tab

182− -- ^ table alias

183140 -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))

184141typetable = UnsafeTypeExpression . renderSQL

185142

@@ -188,7 +145,6 @@ typetable = UnsafeTypeExpression . renderSQL

188145typeview

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

190147 => QualifiedAlias sch vw

191− -- ^ view alias

192148 -> TypeExpression schemas (null ('PGcomposite view))

193149typeview = UnsafeTypeExpression . renderSQL

194150

@@ -245,9 +201,8 @@ bytea = UnsafeTypeExpression "bytea"

245201timestamp :: TypeExpression schemas (null 'PGtimestamp)

246202timestamp = UnsafeTypeExpression "timestamp"

247203-- | date and time, including time zone

248−timestampWithTimeZone, timestamptz :: TypeExpression schemas (null 'PGtimestamptz)

204+timestampWithTimeZone :: TypeExpression schemas (null 'PGtimestamptz)

249205timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

250−timestamptz = UnsafeTypeExpression "timestamptz"

251206-- | calendar date (year, month, day)

252207date :: TypeExpression schemas (null 'PGdate)

253208date = UnsafeTypeExpression "date"

@@ -255,9 +210,8 @@ date = UnsafeTypeExpression "date"

255210time :: TypeExpression schemas (null 'PGtime)

256211time = UnsafeTypeExpression "time"

257212-- | time of day, including time zone

258−timeWithTimeZone, timetz :: TypeExpression schemas (null 'PGtimetz)

213+timeWithTimeZone :: TypeExpression schemas (null 'PGtimetz)

259214timeWithTimeZone = UnsafeTypeExpression "time with time zone"

260−timetz = UnsafeTypeExpression "timetz"

261215-- | time span

262216interval :: TypeExpression schemas (null 'PGinterval)

263217interval = UnsafeTypeExpression "interval"

@@ -304,28 +258,6 @@ tsvector = UnsafeTypeExpression "tsvector"

304258-- | text search document

305259tsquery :: TypeExpression schemas (null 'PGtsquery)

306260tsquery = 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"

329261

330262-- | `pgtype` is a demoted version of a `PGType`

331263class PGTyped schemas (ty :: NullityType) where

@@ -361,86 +293,3 @@ instance (SOP.All KnownNat dims, PGTyped schemas ty)

361293 pgtype = fixarray @dims (pgtype @schemas @ty)

362294instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector

363295instance 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+28−42

@@ -99,7 +99,7 @@ instance RenderSQL (Manipulation commons schemas params columns) where

9999instance With Manipulation where

100100 with Done manip = manip

101101 with ctes manip = UnsafeManipulation $

102− "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL manip

102+ "WITH" <+> renderSQL ctes <+> renderSQL manip

103103

104104{- |

105105The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`,

@@ -113,14 +113,8 @@ using `Squeal.PostgreSQL.PQ.manipulate`.

113113Generally, @parameters@ will be a Haskell tuple or record whose entries

114114may be referenced using positional

115115`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−:}

116+Haskell record or a generalized record using tuples of `P` types and normal Haskell

117+records, whose entries will be targeted using overloaded labels.

124118

125119simple insert:

126120

@@ -202,7 +196,8 @@ delete:

202196

203197>>> :{

204198let

205− manipulation :: Manipulation_ (Public Schema) () (Row Int32 Int32)

199+ manipulation :: Manipulation_ (Public Schema) ()

200+ (P ("col1" ::: Int32), P ("col2" ::: Int32))

206201 manipulation = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star)

207202in printSQL manipulation

208203:}

@@ -249,7 +244,6 @@ type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type

249244-- | Convert a `Query` into a `Manipulation`.

250245queryStatement

251246 :: Query '[] commons schemas params columns

252− -- ^ `Query` to embed as a `Manipulation`

253247 -> Manipulation commons schemas params columns

254248queryStatement q = UnsafeManipulation $ renderSQL q

255249

@@ -272,13 +266,9 @@ insertInto

272266 , SOP.SListI columns

273267 , SOP.SListI row1 )

274268 => QualifiedAlias sch tab

275− -- ^ table

276269 -> QueryClause commons schemas params columns

277− -- ^ what to insert

278270 -> ConflictClause tab commons schemas params table

279− -- ^ what to do in case of conflict

280271 -> ReturningClause commons schemas params '[tab ::: row0] row1

281− -- ^ what to return

282272 -> Manipulation commons schemas params row1

283273insertInto tab qry conflict ret = UnsafeManipulation $

284274 "INSERT" <+> "INTO" <+> renderSQL tab

@@ -286,7 +276,7 @@ insertInto tab qry conflict ret = UnsafeManipulation $

286276 <> renderSQL conflict

287277 <> renderSQL ret

288278

289−-- | Like `insertInto` but with `OnConflictDoRaise` and `no` `ReturningClause`.

279+-- | Like `insertInto` but with `OnConflictDoRaise` and no `ReturningClause`.

290280insertInto_

291281 :: ( Has sch schemas schema

292282 , Has tab schema ('Table table)

@@ -294,33 +284,30 @@ insertInto_

294284 , row ~ TableToRow table

295285 , SOP.SListI columns )

296286 => QualifiedAlias sch tab

297− -- ^ table

298287 -> QueryClause commons schemas params columns

299− -- ^ what to insert

300288 -> Manipulation commons schemas params '[]

301289insertInto_ tab qry =

302290 insertInto tab qry OnConflictDoRaise (Returning_ Nil)

303291

304292-- | A `QueryClause` describes what to `insertInto` a table.

305293data QueryClause commons schemas params columns where

294+ -- | `Values` describes `NP` lists of `Aliased` `Optional` `Expression`s

295+ -- whose `ColumnsType` must match the tables'.

306296 Values

307297 :: SOP.SListI columns

308298 => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns

309− -- ^ row of values

310299 -> [NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns]

311− -- ^ additional rows of values

312300 -> QueryClause commons schemas params columns

301+ -- | `Select` describes a subquery that permits use of `Optional` `Expression`s.

313302 Select

314303 :: SOP.SListI columns

315304 => NP (Aliased (Optional (Expression '[] commons grp schemas params from))) columns

316− -- ^ row of values

317305 -> TableExpression '[] commons grp schemas params from

318− -- ^ from a table expression

319306 -> QueryClause commons schemas params columns

307+ -- | `Subquery` describes a subquery whose `RowType` must match the tables'.

320308 Subquery

321309 :: ColumnsToRow columns ~ row

322310 => Query '[] commons schemas params row

323− -- ^ subquery to insert

324311 -> QueryClause commons schemas params columns

325312

326313instance RenderSQL (QueryClause commons schemas params columns) where

@@ -358,7 +345,6 @@ instance RenderSQL (QueryClause commons schemas params columns) where

358345pattern Values_

359346 :: SOP.SListI columns

360347 => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns

361− -- ^ row of values

362348 -> QueryClause commons schemas params columns

363349pattern Values_ vals = Values vals []

364350

@@ -383,7 +369,7 @@ instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where

383369-- deleted will be returned. For example, if a row was locked

384370-- but not updated because an `OnConflict` `DoUpdate` condition was not satisfied,

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

372+-- in the row. Use @Returning Nil@ in the common case where no return

387373-- values are desired.

388374newtype ReturningClause commons schemas params from row =

389375 Returning (Selection '[] commons 'Ungrouped schemas params from row)

@@ -397,7 +383,6 @@ instance RenderSQL (ReturningClause commons schemas params from row) where

397383pattern Returning_

398384 :: SOP.SListI row

399385 => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row

400− -- ^ row of values

401386 -> ReturningClause commons schemas params from row

402387pattern Returning_ list = Returning (List list)

403388

@@ -410,9 +395,7 @@ data ConflictClause tab commons schemas params table where

410395 OnConflictDoRaise :: ConflictClause tab commons schemas params table

411396 OnConflict

412397 :: ConflictTarget constraints

413− -- ^ conflict target

414398 -> ConflictAction tab commons schemas params columns

415− -- ^ conflict action

416399 -> ConflictClause tab commons schemas params (constraints :=> columns)

417400

418401-- | Render a `ConflictClause`.

@@ -430,12 +413,12 @@ the exact details of the `update` action to be performed in case of a conflict.

430413The `Set` and WHERE `Condition`s in `OnConflict` `DoUpdate` have access to the

431414existing row using the table's name (or an alias), and to rows proposed

432415for 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.

436416-}

437417data ConflictAction tab commons schemas params columns where

418+ -- | `OnConflict` `DoNothing` simply avoids inserting a row as its alternative action.

438419 DoNothing :: ConflictAction tab commons schemas params columns

420+ -- | `OnConflict` `DoUpdate` updates the existing row that conflicts

421+ -- with the row proposed for insertion as its alternative action.

439422 DoUpdate

440423 :: ( row ~ ColumnsToRow columns

441424 , SOP.SListI columns

@@ -485,6 +468,7 @@ UPDATE statements

485468update

486469 :: ( SOP.SListI columns

487470 , SOP.SListI row1

471+ , db ~ (commons :=> schemas)

488472 , Has sch schemas schema

489473 , Has tab schema ('Table table)

490474 , row0 ~ TableToRow table

@@ -509,6 +493,7 @@ update tab columns wh returning = UnsafeManipulation $

509493-- | Update a row returning `Nil`.

510494update_

511495 :: ( SOP.SListI columns

496+ , db ~ (commons :=> schemas)

512497 , Has sch schemas schema

513498 , Has tab schema ('Table table)

514499 , row ~ TableToRow table

@@ -527,25 +512,25 @@ update_ tab columns wh = update tab columns wh (Returning_ Nil)

527512DELETE statements

528513-----------------------------------------}

529514

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.

515+-- | Specify additional tables.

539516data UsingClause commons schemas params from where

517+ -- | No `UsingClause`

540518 NoUsing :: UsingClause commons schemas params '[]

519+ -- | An `also` list of table expressions, allowing columns

520+ -- from other tables to appear in the WHERE condition.

521+ -- This is similar to the list of tables that can be specified

522+ -- in the FROM Clause of a SELECT statement;

523+ -- for example, an alias for the table name can be specified.

524+ -- Do not repeat the target table in the `Using` list,

525+ -- unless you wish to set up a self-join.

541526 Using

542527 :: FromClause '[] commons schemas params from

543− -- ^ what to use

544528 -> UsingClause commons schemas params from

545529

546530-- | Delete rows from a table.

547531deleteFrom

548532 :: ( SOP.SListI row1

533+ , db ~ (commons :=> schemas)

549534 , Has sch schemas schema

550535 , Has tab schema ('Table table)

551536 , row0 ~ TableToRow table

@@ -567,7 +552,8 @@ deleteFrom tab using wh returning = UnsafeManipulation $

567552

568553-- | Delete rows returning `Nil`.

569554deleteFrom_

570− :: ( Has sch schemas schema

555+ :: ( db ~ (commons :=> schemas)

556+ , Has sch schemas schema

571557 , Has tab schema ('Table table)

572558 , row ~ TableToRow table

573559 , columns ~ TableToColumns table )

squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+17−31

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

203189 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;

204190 if not, `up` the `Migration` and insert its `name` 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.

213199 In one transaction, for each each `Migration` query to see if the `Migration` has been executed;

214200 if so, `down` the `Migration` and delete its `name` 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

@@ -268,7 +254,7 @@ instance Migratory (Terminally PQ IO) where

268254 where

269255

270256 upMigrations

271− :: Path (Migration (Terminally PQ IO)) schemas0 schemas1

257+ :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1

272258 -> PQ MigrationsSchemas MigrationsSchemas IO ()

273259 upMigrations = \case

274260 Done -> return ()

@@ -297,7 +283,7 @@ instance Migratory (Terminally PQ IO) where

297283 where

298284

299285 downMigrations

300− :: Path (Migration (Terminally PQ IO)) schemas0 schemas1

286+ :: AlignedList (Migration (Terminally PQ IO)) schemas0 schemas1

301287 -> PQ MigrationsSchemas MigrationsSchemas IO ()

302288 downMigrations = \case

303289 Done -> return ()

@@ -363,8 +349,8 @@ deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)

363349-- | Selects a `Migration` from the `MigrationsTable`, returning

364350-- the time at which it was inserted.

365351selectMigration

366− :: Query_ MigrationsSchemas (Only Text) (Only UTCTime)

367−selectMigration = select_ (#executed_at `as` #fromOnly)

352+ :: Query_ MigrationsSchemas (Only Text) (P ("executed_at" ::: UTCTime))

353+selectMigration = select_ #executed_at

368354 $ from (table (#schema_migrations))

369355 & where_ (#name .== param @1)

370356

@@ -384,7 +370,7 @@ defaultMain

384370 :: Migratory p

385371 => ByteString

386372 -- ^ connection string

387− -> Path (Migration p) db0 db1

373+ -> AlignedList (Migration p) db0 db1

388374 -- ^ migrations

389375 -> IO ()

390376defaultMain connectTo migrations = do

@@ -405,7 +391,7 @@ defaultMain connectTo migrations = do

405391 migrateStatus :: PQ schema schema IO ()

406392 migrateStatus = unsafePQ $ do

407393 runNames <- getRunMigrationNames

408− let names = ctoList name migrations

394+ let names = extractList name migrations

409395 unrunNames = names \\ runNames

410396 liftIO $ displayRunned runNames >> displayUnrunned unrunNames

411397

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+20−52

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

@@ -317,13 +314,13 @@ a default instance.

317314-}

318315class Monad pq => MonadPQ schemas pq | pq -> schemas where

319316 manipulateParams

320− :: (ToParams x params, All OidOfParam params)

317+ :: ToParams x params

321318 => Manipulation '[] schemas params ys

322319 -- ^ `insertInto`, `update` or `deleteFrom`

323320 -> x -> pq (K LibPQ.Result ys)

324321 default manipulateParams

325322 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)

326− => (ToParams x params, All OidOfParam params)

323+ => ToParams x params

327324 => Manipulation '[] schemas params ys

328325 -- ^ `insertInto`, `update` or `deleteFrom`

329326 -> x -> pq (K LibPQ.Result ys)

@@ -331,7 +328,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where

331328 manipulateParams manipulation params

332329

333330 manipulateParams_

334− :: (ToParams x params, All OidOfParam params)

331+ :: ToParams x params

335332 => Manipulation '[] schemas params '[]

336333 -- ^ `insertInto`, `update` or `deleteFrom`

337334 -> x -> pq ()

@@ -344,7 +341,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where

344341 manipulate_ = void . manipulate

345342

346343 runQueryParams

347− :: (ToParams x params, All OidOfParam params)

344+ :: ToParams x params

348345 => Query '[] '[] schemas params ys

349346 -- ^ `select` and friends

350347 -> x -> pq (K LibPQ.Result ys)

@@ -357,19 +354,19 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where

357354 runQuery q = runQueryParams q ()

358355

359356 traversePrepared

360− :: (ToParams x params, Traversable list, All OidOfParam params)

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

361358 => Manipulation '[] schemas params ys

362359 -- ^ `insertInto`, `update`, or `deleteFrom`, and friends

363360 -> list x -> pq (list (K LibPQ.Result ys))

364361 default traversePrepared

365362 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)

366− => (ToParams x params, Traversable list, All OidOfParam params)

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

367364 => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))

368365 traversePrepared manipulation params = lift $

369366 traversePrepared manipulation params

370367

371368 forPrepared

372− :: (ToParams x params, Traversable list, All OidOfParam params)

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

373370 => list x

374371 -> Manipulation '[] schemas params ys

375372 -- ^ `insertInto`, `update` or `deleteFrom`

@@ -377,13 +374,13 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where

377374 forPrepared = flip traversePrepared

378375

379376 traversePrepared_

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

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

381378 => Manipulation '[] schemas params '[]

382379 -- ^ `insertInto`, `update` or `deleteFrom`

383380 -> list x -> pq ()

384381 default traversePrepared_

385382 :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)

386− => (ToParams x params, Foldable list, All OidOfParam params)

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

387384 => Manipulation '[] schemas params '[]

388385 -- ^ `insertInto`, `update` or `deleteFrom`

389386 -> list x -> pq ()

@@ -391,7 +388,7 @@ class Monad pq => MonadPQ schemas pq | pq -> schemas where

391388 traversePrepared_ manipulation params

392389

393390 forPrepared_

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

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

395392 => list x

396393 -> Manipulation '[] schemas params '[]

397394 -- ^ `insertInto`, `update` or `deleteFrom`

@@ -411,17 +408,9 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)

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

412409 PQ $ \ (K conn) -> do

413410 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

411+ toParam' encoding =

412+ (LibPQ.invalidOid, encodingBytes encoding, LibPQ.Binary)

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

425414 q' = q <> ";"

426415 resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary

427416 case resultMaybe of

@@ -434,22 +423,15 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)

434423 traversePrepared

435424 (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =

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

426+ let temp = "temporary_statement"

427+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing

446428 case prepResultMaybe of

447429 Nothing -> throw $ ResultException

448430 "traversePrepared: LibPQ.prepare returned no results"

449431 Just prepResult -> okResult_ prepResult

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

451433 let

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

434+ toParam' encoding = (encodingBytes encoding,LibPQ.Binary)

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

454436 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary

455437 case resultMaybe of

@@ -468,15 +450,8 @@ instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)

468450 traversePrepared_

469451 (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =

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

453+ let temp = "temporary_statement"

454+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing

480455 case prepResultMaybe of

481456 Nothing -> throw $ ResultException

482457 "traversePrepared_: LibPQ.prepare returned no results"

@@ -684,7 +659,7 @@ okResult_ result = liftIO $ do

684659 msg <- LibPQ.resultErrorMessage result

685660 throw . PQException $ PQState status stateCode msg

686661

687−-- | Check if a `LibPQ.Result`'s status is either `LibPQ.CommandOk`

662+-- | Check if a `Result`'s status is either `LibPQ.CommandOk`

688663-- or `LibPQ.TuplesOk` otherwise `throw` a `PQException`.

689664okResult :: MonadIO io => K LibPQ.Result row -> io ()

690665okResult = okResult_ . unK

@@ -703,10 +678,3 @@ handleSqueal

703678 => (SquealException -> io a) -- ^ handler

704679 -> io a -> io a

705680handleSqueal = 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+54−116

@@ -39,8 +39,6 @@ module Squeal.PostgreSQL.Query

3939 , select_

4040 , selectDistinct

4141 , selectDistinct_

42− , selectDistinctOn

43− , selectDistinctOn_

4442 , Selection (..)

4543 -- ** Values

4644 , values

@@ -142,24 +140,18 @@ using `Squeal.PostgreSQL.PQ.runQuery`.

142140Generally, @parameters@ will be a Haskell tuple or record whose entries

143141may be referenced using positional

144142`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a

145−Haskell record, whose entries will be targeted using overloaded labels.

143+Haskell record or a generalized record using tuples of `P` types and normal Haskell

144+records, whose entries will be targeted using overloaded labels.

146145

147146Let's see some examples of queries.

148147

149−>>> :set -XDeriveAnyClass -XDerivingStrategies

150−>>> :{

151−data Row a b = Row { col1 :: a, col2 :: b }

152− deriving stock (GHC.Generic)

153− deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)

154−:}

155−

156148simple query:

157149

158150>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]

159151>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]

160152>>> :{

161153let

162− query :: Query_ (Public Schema) () (Row Int32 Int32)

154+ query :: Query_ (Public Schema) () (P ("col1" ::: Int32), P ("col2" ::: Int32))

163155 query = select Star (from (table #tab))

164156in printSQL query

165157:}

@@ -169,21 +161,21 @@ restricted query:

169161

170162>>> :{

171163let

172− query :: Query_ (Public Schema) () (Row Int32 Int32)

164+ query :: Query_ (Public Schema) () (Sum Int32, P ("col1" ::: Int32))

173165 query =

174− select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2)

166+ select_ ((#col1 + #col2) `as` #getSum :* #col1)

175167 ( from (table #tab)

176168 & where_ (#col1 .> #col2)

177169 & where_ (#col2 .> 0) )

178170in printSQL query

179171:}

180−SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))

172+SELECT ("col1" + "col2") AS "getSum", "col1" AS "col1" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))

181173

182174subquery:

183175

184176>>> :{

185177let

186− query :: Query_ (Public Schema) () (Row Int32 Int32)

178+ query :: Query_ (Public Schema) () (P ("col1" ::: Int32), P ("col2" ::: Int32))

187179 query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))

188180in printSQL query

189181:}

@@ -193,7 +185,7 @@ limits and offsets:

193185

194186>>> :{

195187let

196− query :: Query_ (Public Schema) () (Row Int32 Int32)

188+ query :: Query_ (Public Schema) () (P ("col1" ::: Int32), P ("col2" ::: Int32))

197189 query = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)

198190in printSQL query

199191:}

@@ -203,7 +195,7 @@ parameterized query:

203195

204196>>> :{

205197let

206− query :: Query_ (Public Schema) (Only Int32) (Row Int32 Int32)

198+ query :: Query_ (Public Schema) (Only Int32) (P ("col1" ::: Int32), P ("col2" ::: Int32))

207199 query = select Star (from (table #tab) & where_ (#col1 .> param @1))

208200in printSQL query

209201:}

@@ -213,21 +205,21 @@ aggregation query:

213205

214206>>> :{

215207let

216− query :: Query_ (Public Schema) () (Row Int64 Int32)

208+ query :: Query_ (Public Schema) () (Sum Int32, P ("col1" ::: Int32))

217209 query =

218− select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2)

210+ select_ (sum_ (All #col2) `as` #getSum :* #col1)

219211 ( from (table (#tab `as` #table1))

220212 & groupBy #col1

221− & having (sum_ (Distinct #col2) .> 1) )

213+ & having (#col1 + sum_ (Distinct #col2) .> 1) )

222214in printSQL query

223215:}

224−SELECT COALESCE(sum(ALL "col2"), 0) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > 1)

216+SELECT sum(ALL "col2") AS "getSum", "col1" AS "col1" FROM "tab" AS "table1" GROUP BY "col1" HAVING (("col1" + sum(DISTINCT "col2")) > 1)

225217

226218sorted query:

227219

228220>>> :{

229221let

230− query :: Query_ (Public Schema) () (Row Int32 Int32)

222+ query :: Query_ (Public Schema) () (P ("col1" ::: Int32), P ("col2" ::: Int32))

231223 query = select Star (from (table #tab) & orderBy [#col1 & Asc])

232224in printSQL query

233225:}

@@ -290,10 +282,8 @@ self-join:

290282

291283>>> :{

292284let

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

285+ query :: Query_ (Public Schema) () (P ("col1" ::: Int32), P ("col2" ::: Int32))

286+ query = select (#t1 & DotStar) (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))

297287in printSQL query

298288:}

299289SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2"

@@ -302,19 +292,17 @@ value queries:

302292

303293>>> :{

304294let

305− query :: Query_ schemas () (Row String Bool)

306− query = values

307− ("true" `as` #col1 :* true `as` #col2)

308− ["false" `as` #col1 :* false `as` #col2]

295+ query :: Query_ schemas () (P ("foo" ::: Int32), P ("bar" ::: Bool))

296+ query = values (1 `as` #foo :* true `as` #bar) [2 `as` #foo :* false `as` #bar]

309297in printSQL query

310298:}

311−SELECT * FROM (VALUES (E'true', TRUE), (E'false', FALSE)) AS t ("col1", "col2")

299+SELECT * FROM (VALUES (1, TRUE), (2, FALSE)) AS t ("foo", "bar")

312300

313301set operations:

314302

315303>>> :{

316304let

317− query :: Query_ (Public Schema) () (Row Int32 Int32)

305+ query :: Query_ (Public Schema) () (P ("col1" ::: Int32), P ("col2" ::: Int32))

318306 query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))

319307in printSQL query

320308:}

@@ -324,7 +312,7 @@ with queries:

324312

325313>>> :{

326314let

327− query :: Query_ (Public Schema) () (Row Int32 Int32)

315+ query :: Query_ (Public Schema) () (P ("col1" ::: Int32), P ("col2" ::: Int32))

328316 query = with (

329317 select Star (from (table #tab)) `as` #cte1 :>>

330318 select Star (from (common #cte1)) `as` #cte2

@@ -337,27 +325,27 @@ window function queries

337325

338326>>> :{

339327let

340− query :: Query_ (Public Schema) () (Row Int32 Int64)

328+ query :: Query_ (Public Schema) () (P ("col1" ::: Int32), P ("rank" ::: Int64))

341329 query = select

342− (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))

330+ (#col1 & Also (rank `as` #rank `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))

343331 (from (table #tab))

344332in printSQL query

345333:}

346−SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "col2" FROM "tab" AS "tab"

334+SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "rank" FROM "tab" AS "tab"

347335

348336correlated subqueries

349337

350338>>> :{

351339let

352− query :: Query_ (Public Schema) () (Only Int32)

340+ query :: Query_ (Public Schema) () (P ("col1" ::: Int32))

353341 query =

354− select (#col1 `as` #fromOnly) (from (table (#tab `as` #t1))

342+ select #col1 (from (table (#tab `as` #t1))

355343 & where_ (exists (

356344 select Star (from (table (#tab `as` #t2))

357345 & where_ (#t2 ! #col2 .== #t1 ! #col1)))))

358346in printSQL query

359347:}

360−SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))

348+SELECT "col1" AS "col1" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))

361349

362350-}

363351type family Query_

@@ -554,9 +542,9 @@ select_ = select . List

554542-- be subject to the elimination of duplicate rows using `selectDistinct`.

555543selectDistinct

556544 :: (SListI columns, columns ~ (col ': cols))

557− => Selection outer commons grp schemas params from columns

545+ => Selection outer commons 'Ungrouped schemas params from columns

558546 -- ^ selection

559− -> TableExpression outer commons grp schemas params from

547+ -> TableExpression outer commons 'Ungrouped schemas params from

560548 -- ^ intermediate virtual table

561549 -> Query outer commons schemas params columns

562550selectDistinct selection tabexpr = UnsafeQuery $

@@ -568,62 +556,13 @@ selectDistinct selection tabexpr = UnsafeQuery $

568556-- of a general `Selection`.

569557selectDistinct_

570558 :: (SListI columns, columns ~ (col ': cols))

571− => NP (Aliased (Expression outer commons grp schemas params from)) columns

559+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns

572560 -- ^ select list

573− -> TableExpression outer commons grp schemas params from

561+ -> TableExpression outer commons 'Ungrouped schemas params from

574562 -- ^ intermediate virtual table

575563 -> Query outer commons schemas params columns

576564selectDistinct_ = selectDistinct . List

577565

578−{-|

579−`selectDistinctOn` keeps only the first row of each set of rows where

580−the given expressions evaluate to equal. The DISTINCT ON expressions are

581−interpreted using the same rules as for ORDER BY. ORDER BY is used to

582−ensure that the desired row appears first.

583−

584−The DISTINCT ON expression(s) must match the leftmost ORDER BY expression(s).

585−The ORDER BY clause will normally contain additional expression(s) that

586−determine the desired precedence of rows within each DISTINCT ON group.

587−

588−In order to guarantee they match and reduce redundancy, this function

589−will prepend the The DISTINCT ON expressions to the ORDER BY clause.

590−-}

591−selectDistinctOn

592− :: (SListI columns, columns ~ (col ': cols))

593− => [SortExpression outer commons grp schemas params from]

594− -- ^ DISTINCT ON expression(s) and prepended to ORDER BY clause

595− -> Selection outer commons grp schemas params from columns

596− -- ^ selection

597− -> TableExpression outer commons grp schemas params from

598− -- ^ intermediate virtual table

599− -> Query outer commons schemas params columns

600−selectDistinctOn distincts selection tab = UnsafeQuery $

601− "SELECT DISTINCT ON"

602− <+> parenthesized (commaSeparated (renderDistinctOn <$> distincts))

603− <+> renderSQL selection

604− <+> renderSQL (tab {orderByClause = distincts <> orderByClause tab})

605− where

606− renderDistinctOn = \case

607− Asc expression -> renderSQL expression

608− Desc expression -> renderSQL expression

609− AscNullsFirst expression -> renderSQL expression

610− DescNullsFirst expression -> renderSQL expression

611− AscNullsLast expression -> renderSQL expression

612− DescNullsLast expression -> renderSQL expression

613−

614−-- | Like `selectDistinctOn` but takes an `NP` list of `Expression`s instead

615−-- of a general `Selection`.

616−selectDistinctOn_

617− :: (SListI columns, columns ~ (col ': cols))

618− => [SortExpression outer commons grp schemas params from]

619− -- ^ distinct on and return the first row in ordering

620− -> NP (Aliased (Expression outer commons grp schemas params from)) columns

621− -- ^ selection

622− -> TableExpression outer commons grp schemas params from

623− -- ^ intermediate virtual table

624− -> Query outer commons schemas params columns

625−selectDistinctOn_ distincts = selectDistinctOn distincts . List

626−

627566-- | `values` computes a row value or set of row values

628567-- specified by value expressions. It is most commonly used

629568-- to generate a “constant table” within a larger command,

@@ -757,7 +696,7 @@ instance RenderSQL (TableExpression outer commons grp schemas params from) where

757696from

758697 :: FromClause outer commons schemas params from -- ^ table reference

759698 -> TableExpression outer commons 'Ungrouped schemas params from

760−from tab = TableExpression tab [] noGroups NoHaving [] [] []

699+from tab = TableExpression tab [] NoGroups NoHaving [] [] []

761700

762701-- | A `where_` is an endomorphism of `TableExpression`s which adds a

763702-- search condition to the `whereClause`.

@@ -778,7 +717,7 @@ groupBy

778717groupBy bys rels = TableExpression

779718 { fromClause = fromClause rels

780719 , whereClause = whereClause rels

781− , groupByClause = group bys

720+ , groupByClause = Group bys

782721 , havingClause = Having []

783722 , orderByClause = []

784723 , limitClause = limitClause rels

@@ -992,20 +931,19 @@ instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])

992931-- done on @NoGroups@ while all output `Expression`s must be aggregated

993932-- in @Group Nil@. In general, all output `Expression`s in the

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

934+data GroupByClause grp from where

935+ NoGroups :: GroupByClause 'Ungrouped from

936+ Group

937+ :: SListI bys

938+ => NP (By from) bys

939+ -> GroupByClause ('Grouped bys) from

940+

941+-- | Renders a `GroupByClause`.

998942instance 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'

943+ renderSQL = \case

944+ NoGroups -> ""

945+ Group Nil -> ""

946+ Group bys -> " GROUP BY" <+> renderCommaSeparated renderSQL bys

1009947

1010948-- | A `HavingClause` is used to eliminate groups that are not of interest.

1011949-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`

@@ -1049,8 +987,8 @@ instance

1049987 , commons1 ~ (cte ::: common ': commons)

1050988 ) => Aliasable cte

1051989 (statement commons schemas params common)

1052− (Path (CommonTableExpression statement schemas params) commons commons1) where

1053− statement `as` cte = csingleton (statement `as` cte)

990+ (AlignedList (CommonTableExpression statement schemas params) commons commons1) where

991+ statement `as` cte = single (statement `as` cte)

1054992

1055993instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL

1056994 (CommonTableExpression statement schemas params commons0 commons1) where

@@ -1062,7 +1000,7 @@ instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL

10621000-- defining temporary tables that exist just for one query.

10631001class With statement where

10641002 with

1065− :: Path (CommonTableExpression statement schemas params) commons0 commons1

1003+ :: AlignedList (CommonTableExpression statement schemas params) commons0 commons1

10661004 -- ^ common table expressions

10671005 -> statement commons1 schemas params row

10681006 -- ^ larger query

@@ -1070,23 +1008,23 @@ class With statement where

10701008instance With (Query outer) where

10711009 with Done query = query

10721010 with ctes query = UnsafeQuery $

1073− "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL query

1011+ "WITH" <+> renderSQL ctes <+> renderSQL query

10741012

10751013{- |

10761014>>> import Data.Monoid (Sum (..))

1077−>>> import Data.Int (Int64)

1015+>>> import Data.Int (Int32)

10781016>>> :{

10791017 let

1080− query :: Query_ schema () (Sum Int64)

1018+ query :: Query_ schema () (Sum Int32)

10811019 query = withRecursive

1082− ( values_ ((1 & astype int) `as` #n)

1020+ ( values_ (1 `as` #n)

10831021 `unionAll`

10841022 select_ ((#n + 1) `as` #n)

10851023 (from (common #t) & where_ (#n .< 100)) `as` #t )

1086− ( select_ (fromNull 0 (sum_ (All #n)) `as` #getSum) (from (common #t) & groupBy Nil))

1024+ ( select_ (sum_ (All #n) `as` #getSum) (from (common #t) & groupBy Nil))

10871025 in printSQL query

10881026:}

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"

1027+WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES (1)) AS t ("n")) UNION ALL (SELECT ("n" + 1) AS "n" FROM "t" AS "t" WHERE ("n" < 100))) SELECT sum(ALL "n") AS "getSum" FROM "t" AS "t"

10901028-}

10911029withRecursive

10921030 :: Aliased (Query outer (recursive ': commons) schemas params) recursive

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+6−5

@@ -97,22 +97,23 @@ transactionallyRetry mode tx = mask $ \restore ->

9797 Right x -> return x

9898

9999{- | Run a computation `ephemerally`;

100−Like `transactionally` but always `rollback`, useful in testing.

100+First `begin`, then run the computation, `rollback` and `return`

101+its result.

101102-}

102103ephemerally

103− :: (MonadUnliftIO tx, MonadPQ schemas tx)

104+ :: (MonadIO tx, MonadPQ schemas tx)

104105 => TransactionMode

105106 -> tx x -- ^ run inside an ephemeral transaction

106107 -> tx x

107−ephemerally mode tx = mask $ \restore -> do

108+ephemerally mode tx = do

108109 manipulate_ $ begin mode

109− result <- restore tx `onException` (manipulate_ rollback)

110+ result <- tx

110111 manipulate_ rollback

111112 return result

112113

113114{- | Run a computation `ephemerally` in `defaultMode`. -}

114115ephemerally_

115− :: (MonadUnliftIO tx, MonadPQ schemas tx)

116+ :: (MonadIO tx, MonadPQ schemas tx)

116117 => tx x -- ^ run inside an ephemeral transaction

117118 -> tx x

118119ephemerally_ = ephemerally defaultMode

squeal-postgresql/src/Squeal/PostgreSQL/Tutorial.hsnew file+39

@@ -0,0 +1,39 @@

1+{-|

2+Module: Squeal.PostgreSQL.Tutorial

3+Description: Squeal tutorial module

4+Copyright: (c) Eitan Chatav, 2019

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_ (Default `as` #id :* Set (param @1) `as` #name :* Set (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