dev..e7e9693 · squeal · git.iko.soy

git.iko.soy/squeal

52 files changed+4316−12099

unifiedsplit

.circleci/config.yml+2−3

@@ -2,10 +2,9 @@ version: 2

22jobs:

33 build:

44 docker:

5− - image: haskell:8.6.5

5+ - image: haskell:latest

66 - image: circleci/postgres:latest

77 environment:

8− POSTGRES_USER: root

98 POSTGRES_DB: exampledb

109 steps:

1110 - checkout

@@ -14,7 +13,7 @@ jobs:

1413 - dependency-cache

1514 - run: apt-get update && apt-get install -y libpq-dev xz-utils make

1615 - run: stack upgrade && stack update

17− - run: stack build --fast

16+ - run: stack build

1817 - run: stack test

1918 - run: stack haddock

2019 - save_cache:

README.md+119−126

@@ -44,13 +44,6 @@ composable and cover a large portion of SQL.

4444* linear, invertible migrations

4545* connection pools

4646* transactions

47−* views

48−* array, composite and enumerated types

49−* json functions and operations

50−* multischema support

51−* correlated subqueries

52−* window functions

53−* text search

5447

5548## installation

5649

@@ -58,16 +51,10 @@ composable and cover a large portion of SQL.

5851

5952## testing

6053

61−Start postgres on localhost port `5432` and create a database named `exampledb`.

54+start postgres on localhost port `5432` and create a database named `exampledb`.

6255

6356`stack test`

6457

65−## contributing

66−

67−We welcome contributors.

68−Please make pull requests on the `dev` branch instead of `master`.

69−The `Issues` page is a good place to communicate.

70−

7158## usage

7259

7360Let's see an example!

@@ -75,15 +62,16 @@ Let's see an example!

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

7663features.

7764

78−```Haskell

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

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

65+```haskell

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

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

8168```

8269

8370We'll need some imports.

8471

85−```Haskell

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

72+```haskell

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

74+>>> import Control.Monad.Base (liftBase)

8775>>> import Data.Int (Int32)

8876>>> import Data.Text (Text)

8977>>> import Squeal.PostgreSQL

@@ -91,7 +79,7 @@ We'll need some imports.

9179

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

9381

94−```Haskell

82+```haskell

9583>>> import qualified Generics.SOP as SOP

9684>>> import qualified GHC.Generics as GHC

9785```

@@ -99,152 +87,155 @@ We'll use generics to easily convert between Haskell and PostgreSQL values.

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

10088we use `DataKinds` and `TypeOperators`.

10189

102−```Haskell

90+```haskell

10391>>> :{

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

11592type Schema =

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

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

118−type Schemas = Public Schema

93+ '[ "users" :::

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

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

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

97+ ]

98+ , "emails" :::

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

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

101+ ] :=>

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

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

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

105+ ]

106+ ]

119107:}

120108```

121109

122−Notice the use of type operators.

123−

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

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

126−operator.

127−

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

110+Notice the use of type operators. `:::` is used

111+to pair an alias `Symbol` with either a `TableType` or a `ColumnType`.

112+`:=>` is used to pair a `TableConstraint`s with a `ColumnsType`,

129113yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,

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

114+yielding a `ColumnType`.

131115

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

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

134−has two type parameters, corresponding to the schema

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

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

117+Squeal, a `Definition` is a `createTable`, `alterTable` or `dropTable`

118+command and has two type parameters, corresponding to the schema

119+before being run and the schema after. We can compose definitions using

120+`>>>`. Here and in the rest of our commands we make use of overloaded

137121labels to refer to named tables and columns in our schema.

138122

139−```Haskell

123+```haskell

140124>>> :{

141125let

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

143− setup =

144− createTable #users

145− ( serial `as` #id :*

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

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

148− createTable #emails

149− ( serial `as` #id :*

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

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

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

153− foreignKey #user_id #users #id

154− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

126+ setup :: Definition '[] Schema

127+ setup =

128+ createTable #users

129+ ( serial `As` #id :*

130+ (text & notNull) `As` #name :* Nil )

131+ ( primaryKey #id `As` #pk_users :* Nil ) >>>

132+ createTable #emails

133+ ( serial `As` #id :*

134+ (int & notNull) `As` #user_id :*

135+ (text & null') `As` #email :* Nil )

136+ ( primaryKey #id `As` #pk_emails :*

137+ foreignKey #user_id #users #id

138+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )

155139:}

156140```

157141

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

142+We can easily see the generated SQL is unsuprising looking.

159143

160−```Haskell

161−>>> printSQL setup

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

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

144+```haskell

145+>>> renderDefinition setup

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

164147```

165148

166149Notice that `setup` starts with an empty schema `'[]` and produces `Schema`.

167150In our `createTable` commands we included `TableConstraint`s to define

168−primary and foreign keys, making them somewhat complex. Our `teardown`

151+primary and foreign keys, making them somewhat complex. Our tear down

169152`Definition` is simpler.

170153

171−```Haskell

154+```haskell

172155>>> :{

173156let

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

157+ teardown :: Definition Schema '[]

175158 teardown = dropTable #emails >>> dropTable #users

176159:}

177−

178−>>> printSQL teardown

179−DROP TABLE "emails";

180−DROP TABLE "users";

181−```

182−

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

184−`SOP.HasDatatypeInfo` instances so that we can encode and decode `User`s.

185−

186−```Haskell

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

188−>>> instance SOP.Generic User

189−>>> instance SOP.HasDatatypeInfo User

160+>>> renderDefinition teardown

161+"DROP TABLE emails; DROP TABLE users;"

190162```

191163

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

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

165+A `Manipulation` is an `insertRow` (or other inserts), `update`

166+or `deleteFrom` command and

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

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

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

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

170+field but not for the `id` field. Since it's optional, we can use a default

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

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

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

174+of our inserts.

202175

203−```Haskell

176+```haskell

204177>>> :{

205178let

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

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

180+ insertUser = insertRow #users

181+ (Default `As` #id :* Set (param @1) `As` #name :* Nil)

182+ OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))

215183:}

216−

217−>>> printSQL insertUser

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

184+>>> :{

185+let

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

187+ insertEmail = insertRow #emails

188+ ( Default `As` #id :*

189+ Set (param @1) `As` #user_id :*

190+ Set (param @2) `As` #email :* Nil )

191+ OnConflictDoNothing (Returning Nil)

192+:}

193+>>> renderManipulation insertUser

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

195+>>> renderManipulation insertEmail

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

219197```

220198

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

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

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

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

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

225203

226−```Haskell

204+```haskell

227205>>> :{

228206let

229− getUsers :: Query_ Schemas () User

230− getUsers = select_

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

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

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

207+ getUsers :: Query Schema '[]

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

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

210+ getUsers = select

211+ (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)

212+ ( from (table (#users `As` #u)

213+ & innerJoin (table (#emails `As` #e))

234214 (#u ! #id .== #e ! #user_id)) )

235215:}

216+>>> renderQuery getUsers

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

218+```

219+

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

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

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

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

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

236225

237−>>> printSQL getUsers

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

226+```haskell

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

228+>>> instance SOP.Generic User

229+>>> instance SOP.HasDatatypeInfo User

239230```

240231

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

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

242233

243−```Haskell

234+```haskell

244235>>> :{

245236let

246237 users :: [User]

247− users =

238+ users =

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

249240 , User "Bob" Nothing

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

@@ -260,21 +251,23 @@ the changing schema information through by using the indexed `PQ` monad

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

261252`MonadPQ` functionality.

262253

263−```Haskell

254+```haskell

264255>>> :{

265256let

266− session :: PQ Schemas Schemas IO ()

257+ session :: PQ Schema Schema IO ()

267258 session = do

268− _ <- traversePrepared_ insertUser users

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

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

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

269262 usersResult <- runQuery getUsers

270263 usersRows <- getRows usersResult

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

272−in

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

274− define setup

275− & pqThen session

276− & pqThen (define teardown)

264+ liftBase $ print (usersRows :: [User])

265+:}

266+>>> :{

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

268+ define setup

269+ & pqThen session

270+ & pqThen (define teardown)

277271:}

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

279−-}

280273```

RELEASE NOTES.md−1077

@@ -1,1082 +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−

403−### Version 0.4

404−

405−Version 0.4 strengthens Squeal's type system, adds

406−support for multidimensional arrays, improves support

407−for container type, improves `with` statements,

408−improves runtime exceptions, accomodates SQL's three-valued logic,

409−adds subquery expressions, and adds table and view type expressions.

410−

411−**Types**

412−

413−Squeal 0.4 renames some kinds to aid intuition:

414−

415−```Haskell

416−type RowType = [(Symbol, NullityType)] -- previously RelationType

417−type FromType = [(Symbol, RowType)] -- previously RelationsType

418−```

419−

420−Null safety for array and composite types is gained by having the base

421−type of an array be a `NullityType` and the base type of a composite

422−a `RowType`.

423−

424−```Haskell

425−data PGType

426− = ..

427− | PGvararray NullityType

428− | PGfixarray Nat NullityType

429− | PGcomposite RowType

430−```

431−

432−Squeal embeds Postgres types into Haskell using data kinds and type-in-type:

433−

434−```Haskell

435−data PGType = PGbool | ..

436−data NullityType = Null PGType | NotNull PGType

437−type RowType = [(Symbol, NullityType)] -- previously RelationType

438−type FromType = [(Symbol, RowType)] -- previously RelationsType

439−```

440−

441−In another sense, we can embed Haskell types

442−into Postgres types by providing type families:

443−

444−```Haskell

445−type family PG (hask :: Type) :: PGType

446−type family NullPG (hask :: Type) :: NullityType

447−type family TuplePG (hask :: Type) :: [NullityType]

448−type family RowPG (hask :: Type) :: RowType

449−```

450−

451−Let's look at these one by one.

452−

453−`PG` was introduced in Squeal 0.3. It was a closed type family that

454−associates some Haskell types to their obvious corresponding Postgres

455−types like `PG Double = 'PGfloat8`. It only worked on base types,

456−no arrays or composites. Squeal 0.4 extends it to

457−such container types and makes it an open type family so that

458−users can make their own type instances.

459−

460−`NullPG` had a different name before but it does the obvious

461−thing for Haskell with `Maybe`s:

462−

463−```Haskell

464−type family NullPG hask where

465− NullPG (Maybe hask) = 'Null (PG hask)

466− NullPG hask = 'NotNull (PG hask)

467−```

468−

469−`TuplePG` uses generics to turn tuple types (including records)

470−into lists of `NullityType`s in the logical way, e.g.

471−`TuplePG (Bool, Day) = '[ 'PGbool, 'PGdate]`.

472−

473−`RowPG` also uses generics to turn record types into a `RowType` in the logical way, e.g.

474−

475−```Haskell

476−>>> data Person = Person { name :: Text, age :: Int32 } deriving GHC.Generic

477−>>> instance SOP.Generic Person

478−>>> instance SOP.HasDatatypeInfo Person

479−>>> :kind! TuplePG Person

480−TuplePG Person :: [NullityType]

481−= '['NotNull 'PGtext, 'NotNull 'PGint4]

482−>>> :kind! RowPG Person

483−RowPG Person :: [(Symbol, NullityType)]

484−= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]

485−```

486−

487−We've already seen a hint of why these types are useful in one construction

488−from Squeal 0.3. Creating composite types in Postgres directly from a Haskell

489−record type essentially uses `RowPG`. Another important use is in simplifying

490−the type signatures for a `Query` or `Manipulation`. Very often, you will have

491−a tuple type corresponding to the parameters and a record type corresponding

492−to the returned columns of a `Query` or `Manipulation`. Instead of writing

493−boilerplate signature you can reuse these with the help of `TuplePG` and `RowPG`

494−

495−For instance:

496−

497−```Haskell

498−>>> :{

499−let

500− query :: Query '["user" ::: 'View (RowPG Person)] (TuplePG (Only Int32)) (RowPG Person)

501− query = selectStar (from (view #user) & where_ (#age .> param @1))

502−:}

503−```

504−

505−**Arrays**

506−

507−In addition to being able to encode and decode basic Haskell types

508−like `Int16` and `Text`, Squeal 0.4 permits you to encode and decode Haskell types to

509−Postgres array types. The `Vector` type corresponds to to variable length arrays.

510−And thanks to an idea from [Mike Ledger](https://github.com/mikeplus64),

511−homogeneous tuples correspond to fixed length arrays. We can even

512−create multi-dimensional fixed length arrays. Let's see an example.

513−

514−```Haskell

515−>>> :{

516−data Row = Row

517− { col1 :: Vector Int16

518− , col2 :: (Maybe Int16,Maybe Int16)

519− , col3 :: ((Int16,Int16),(Int16,Int16),(Int16,Int16))

520− } deriving (Eq, GHC.Generic)

521−:}

522−

523−>>> instance Generic Row

524−>>> instance HasDatatypeInfo Row

525−```

526−

527−Define a simple round trip query.

528−

529−```Haskell

530−>>> :{

531−let

532− roundTrip :: Query '[] (TuplePG Row) (RowPG Row)

533− roundTrip = values_ $

534− parameter @1 (int2 & vararray) `as` #col1 :*

535− parameter @2 (int2 & fixarray @2) `as` #col2 :*

536− parameter @3 (int2 & fixarray @2 & fixarray @3) `as` #col3

537−:}

538−

539−>>> :set -XOverloadedLists

540−>>> let input = Row [1,2] (Just 1,Nothing) ((1,2),(3,4),(5,6))

541−>>> :{

542−void . withConnection "host=localhost port=5432 dbname=exampledb" $ do

543− result <- runQueryParams roundTrip input

544− Just output <- firstRow result

545− liftBase . print $ input == output

546−:}

547−True

548−```

549−

550−**Containers**

551−

552−Squeal aims to provide a correspondence between Haskell types and Postgres types.

553−In particular, Haskell ADTs with nullary constructors can correspond to

554−Postgres enum types and Haskell record types can correspond to Postgres

555−composite types. However, it's not always obvious that that's how a user

556−will choose to store values of those types. So Squeal 0.4 introduces newtypes

557−whose purpose is to specify how a user wants to store values of a type.

558−

559−```Haskell

560−newtype Json hask = Json {getJson :: hask}

561−newtype Jsonb hask = Jsonb {getJsonb :: hask}

562−newtype Composite record = Composite {getComposite :: record}

563−newtype Enumerated enum = Enumerated {getEnumerated :: enum}

564−```

565−

566−Let's see an example:

567−

568−```Haskell

569−>>> data Schwarma = Beef | Lamb | Chicken deriving (Eq, Show, GHC.Generic)

570−>>> instance SOP.Generic Schwarma

571−>>> instance SOP.HasDatatypeInfo Schwarma

572−>>>

573−>>> data Person = Person {name :: Text, age :: Int32} deriving (Eq, Show, GHC.Generic)

574−>>> instance SOP.Generic Person

575−>>> instance SOP.HasDatatypeInfo Person

576−>>> instance Aeson.FromJSON Person

577−>>> instance Aeson.ToJSON Person

578−```

579−

580−We can create the equivalent Postgres types directly from their Haskell types.

581−

582−```Haskell

583−>>> :{

584−type Schema =

585− '[ "schwarma" ::: 'Typedef (PG (Enumerated Schwarma))

586− , "person" ::: 'Typedef (PG (Composite Person))

587− ]

588−:}

589−

590−>>> :{

591−let

592− setup :: Definition '[] Schema

593− setup =

594− createTypeEnumFrom @Schwarma #schwarma >>>

595− createTypeCompositeFrom @Person #person

596−:}

597−```

598−

599−Let's demonstrate how to associate our Haskell types `Schwarma` and `Person`

600−with enumerated, composite or json types in Postgres. First create a Haskell

601−`Row` type using the `Enumerated`, `Composite` and `Json` newtypes as fields.

602−

603−```Haskell

604−>>> :{

605−data Row = Row

606− { schwarma :: Enumerated Schwarma

607− , person1 :: Composite Person

608− , person2 :: Json Person

609− } deriving (Eq, GHC.Generic)

610−:}

611−

612−>>> instance Generic Row

613−>>> instance HasDatatypeInfo Row

614−>>> :{

615−let

616− input = Row

617− (Enumerated Chicken)

618− (Composite (Person "Faisal" 24))

619− (Json (Person "Ahmad" 48))

620−:}

621−```

622−

623−Once again, define a round trip query.

624−

625−```Haskell

626−>>> :{

627−let

628− roundTrip :: Query Schema (TuplePG Row) (RowPG Row)

629− roundTrip = values_ $

630− parameter @1 (typedef #schwarma) `as` #schwarma :*

631− parameter @2 (typedef #person) `as` #person1 :*

632− parameter @3 json `as` #person2

633−:}

634−```

635−

636−Finally, we can drop our type definitions.

637−

638−```Haskell

639−>>> :{

640−let

641− teardown :: Definition Schema '[]

642− teardown = dropType #schwarma >>> dropType #person

643−:}

644−```

645−

646−Now let's run it.

647−

648−```Haskell

649−>>> :{

650−let

651− session = do

652− result <- runQueryParams roundTrip input

653− Just output <- firstRow result

654− liftBase . print $ input == output

655−in

656− void . withConnection "host=localhost port=5432 dbname=exampledb" $

657− define setup

658− & pqThen session

659− & pqThen (define teardown)

660−:}

661−True

662−```

663−

664−**With**

665−

666−Squeal 0.3 supported WITH statements but there's a couple problems with them.

667−Here's the type signature for `with` in Squeal 0.3.

668−

669−```Haskell

670−with

671− :: SOP.SListI commons

672− => NP (Aliased (Manipulation schema params)) (common ': commons)

673− -- ^ common table expressions

674− -> Manipulation (With (common ': commons) schema) params results

675− -> Manipulation schema params results

676−```

677−

678−The first problem is that `with` only works with `Manipulations`.

679−It can work on `Query`s by using `queryStatement` but it still will

680−return a `Manipulation`. We can fix this issue by making `with` a

681−method of a type class with instances for both `Query` and `Manipulation`.

682−

683−The second problem is that all the common table expressions

684−refer the base schema, whereas in SQL, each subsequent CTE can

685−refer to previous CTEs as well. But this can be fixed! First define a datatype:

686−

687−```Haskell

688−data CommonTableExpression statement params schema0 schema1 where

689− CommonTableExpression

690− :: Aliased (statement schema params) (alias ::: cte)

691− -> CommonTableExpression statement params schema (alias ::: 'View cte ': schema)

692−```

693−

694−It's just a wrapper around an aliased statement, where the statement

695−could be either a `Query` or `Manipulation`, but it augments the schema

696−by adding a view to it. It almost looks like a morphism between schemas

697−but there is no way yet to compose them. Luckily, Squeal already has

698−a datatype for this, which is used for migrations, the `AlignedList`

699−type which is really the "free category". So we can then define a `With` type class:

700−

701−```Haskell

702−class With statement where

703− with

704− :: AlignedList (CommonTableExpression statement params) schema0 schema1

705− -> statement schema1 params row

706− -> statement schema0 params row

707−```

708−

709−By giving `Aliasable` instances to CTEs and aligned singleton lists of CTEs (i.e. scrap-your-nils), we get a nice syntax for WITH statements in Squeal.

710−

711−Here's an example of using `with` for a `Query` and a `Manipulation`:

712−

713−```Haskell

714−>>> :{

715−let

716− query :: Query

717− '[ "t1" ::: 'View

718− '[ "c1" ::: 'NotNull 'PGtext

719− , "c2" ::: 'NotNull 'PGtext] ]

720− '[]

721− '[ "c1" ::: 'NotNull 'PGtext

722− , "c2" ::: 'NotNull 'PGtext ]

723− query = with (

724− selectStar (from (view #t1)) `as` #t2 :>>

725− selectStar (from (view #t2)) `as` #t3

726− ) (selectStar (from (view #t3)))

727−in printSQL query

728−:}

729−WITH "t2" AS (SELECT * FROM "t1" AS "t1"), "t3" AS (SELECT * FROM "t2" AS "t2") SELECT * FROM "t3" AS "t3"

730−

731−>>> type ProductsTable = '[] :=> '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]

732−

733−>>> :{

734−let

735− manipulation :: Manipulation

736− '[ "products" ::: 'Table ProductsTable

737− , "products_deleted" ::: 'Table ProductsTable

738− ] '[ 'NotNull 'PGdate] '[]

739− manipulation = with

740− (deleteFrom #products (#date .< param @1) ReturningStar `as` #deleted_rows)

741− (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rows `as` #t)))))

742−in printSQL manipulation

743−:}

744−WITH "deleted_rows" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "deleted_rows" AS "t"

745−```

746−

747−**Three Valued Logic**

748−

749−In previous versions of Squeal, conditions followed classical two valued logic

750−of `true` and `false`.

751−

752−```Haskell

753−-- Squeal 0.3

754−type Condition schema from grouping params =

755− Expression schema from grouping params ('NotNull 'PGbool)

756−```

757−

758−I had thought that three valued logic, which is what SQL uses, was confusing.

759−However, multiple users reported being confused at being forced to do `NULL`

760−handling, particularly in their left joins. Since the original motivation

761−of being less confusing evaporated I decided to switch to three valued logic

762−of `true`, `false` and `null_`.

763−

764−```Haskell

765−-- Squeal 0.4

766−type Condition schema from grouping params =

767− Expression schema from grouping params ('Null 'PGbool)

768−```

769−

770−**Subquery Expressions**

771−

772−Squeal 0.4 adds support for subquery expressions such as `IN` and `op ANY/ALL`.

773−

774−**Row Types**

775−

776−Squeal 0.4 adds functions to define type expressions from tables and views

777−and a type expression for user defined types, `typetable`, `typeview` and

778−`typedef`.

779−

780−**Runtime Exceptions**

781−

782−Squeal now has an exception type which gives details on the sort of error

783−encountered and handler functions.

784−

785−```Haskell

786−data SquealException

787− = PQException

788− { sqlExecStatus :: LibPQ.ExecStatus

789− , sqlStateCode :: Maybe ByteString

790− -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html

791− , sqlErrorMessage :: Maybe ByteString

792− }

793− | ResultException Text

794− | ParseException Text

795− deriving (Eq, Show)

796−instance Exception SquealException

797−

798−catchSqueal

799− :: MonadBaseControl IO io

800− => io a

801− -> (SquealException -> io a) -- ^ handler

802− -> io a

803−

804−handleSqueal

805− :: MonadBaseControl IO io

806− => (SquealException -> io a) -- ^ handler

807− -> io a -> io a

808−```

809−

810−**Additional Changes**

811−

812−Squeal 0.4 adds `field` and `index` functions to get components of composite

813−and array expressions.

814−

815−Squeal 0.4 adds a dependency on `records-sop` to offload a lot of boilerplate

816−type family logic that was needed for `RowPG`.

817−

818−The above changes required major and minor changes to Squeal DSL functions.

819−Please consult the documentation.

820−

821−### Version 0.3.2 - August 4, 2018

822−

823−Version 0.3.2 features extensive support for `JSON` functionality with

824−more than 50 new functions.

825−This work is entirely due to [Mike Ledger](https://github.com/mikeplus64)

826−who has been making terrific contributions to Squeal. Thanks!

827−We also got some examples in the documentation for pools submitted by

828−[Raveline](https://github.com/Raveline). I'm so pleased to be

829−getting pull requests and issue submissions from you all!

830−

831−### Version 0.3.1 - July 7, 2018

832−

833−Version 0.3.1 of Squeal enables the "Scrap your Nils" trick for

834−heterogeneous lists of `Alias`es, `Aliased` expressions, `PGlabel`s and `By`s

835−with the typeclasses `IsLabel`, `IsQualified`, `IsPGlabel`,

836−and the new `Aliasable` typeclass, to eliminate all need of using `Nil` in a list.

837−There were a couple minor name changes, i.e. the function `group` was renamed to `groupBy`.

838−Please consult the documentation.

839−

840−### Version 0.3 - June 26, 2018

841−

842−Version 0.3 of Squeal adds views as well as composite and enumerated types to Squeal.

843−To support these features, a new kind `SchemumType` was added.

844−

845−```Haskell

846−data SchemumType

847− = Table TableType

848− | View RelationType

849− | Typedef PGType

850−```

851−

852−As a consequence, you will have to update your schema definitions like so:

853−

854−```Haskell

855−-- Squeal 0.2

856−type Schema =

857− '[ "users" :::

858− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

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

860− , "name" ::: 'NoDef :=> 'NotNull 'PGtext

861− ]

862− ]

863−

864−-- Squeal 0.3

865−type Schema =

866− '[ "users" ::: 'Table (

867− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

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

869− , "name" ::: 'NoDef :=> 'NotNull 'PGtext

870− ])

871− ]

872−```

873−

874−**Views**

875−

876−You can now create, drop, and query views.

877−

878−```Haskell

879−>>> :{

880−type ABC =

881− ('[] :: TableConstraints) :=>

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

883− , "b" ::: 'NoDef :=> 'Null 'PGint4

884− , "c" ::: 'NoDef :=> 'Null 'PGint4

885− ]

886−type BC =

887− '[ "b" ::: 'Null 'PGint4

888− , "c" ::: 'Null 'PGint4

889− ]

890−:}

891−

892−>>> :{

893−let

894− definition :: Definition '["abc" ::: 'Table ABC ] '["abc" ::: 'Table ABC, "bc" ::: 'View BC]

895− definition = createView #bc (select (#b :* #c :* Nil) (from (table #abc)))

896−in printSQL definition

897−:}

898−CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";

899−

900−>>> :{

901−let

902− definition :: Definition '["abc" ::: 'Table ABC, "bc" ::: 'View BC] '["abc" ::: 'Table ABC]

903− definition = dropView #bc

904−in printSQL definition

905−:}

906−DROP VIEW "bc";

907−

908−>>> :{

909−let

910− query :: Query '["abc" ::: 'Table ABC, "bc" ::: 'View BC] '[] BC

911− query = selectStar (from (view #bc))

912−in printSQL query

913−:}

914−SELECT * FROM "bc" AS "bc"

915−```

916−

917−**Enumerated Types**

918−

919−PostgreSQL has a powerful type system. It even allows for user defined types.

920−For instance, you can define enumerated types which are data types that comprise

921−a static, ordered set of values. They are equivalent to Haskell algebraic data

922−types whose constructors are nullary. An example of an enum type might be the days of the week,

923−or a set of status values for a piece of data.

924−

925−Enumerated types are created using the `createTypeEnum` command, for example:

926−

927−```Haskell

928−>>> :{

929−let

930− definition :: Definition '[] '["mood" ::: 'Typedef ('PGenum '["sad", "ok", "happy"])]

931− definition = createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil)

932−:}

933−>>> printSQL definition

934−CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');

935−```

936−

937−Enumerated types can also be generated from a Haskell algebraic data type with nullary constructors, for example:

938−

939−```Haskell

940−>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic

941−>>> instance SOP.Generic Schwarma

942−>>> instance SOP.HasDatatypeInfo Schwarma

943−

944−>>> :kind! EnumFrom Schwarma

945−EnumFrom Schwarma :: PGType

946−= 'PGenum '["Beef", "Lamb", "Chicken"]

947−

948−>>> :{

949−let

950− definition :: Definition '[] '["schwarma" ::: 'Typedef (EnumFrom Schwarma)]

951− definition = createTypeEnumFrom @Schwarma #schwarma

952−:}

953−>>> printSQL definition

954−CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');

955−```

956−

957−You can express values of an enum type using `label`, which is an overloaded method

958−of the `IsPGlabel` typeclass.

959−

960−```Haskell

961−>>> :{

962−let

963− expression :: Expression sch rels grp params ('NotNull (EnumFrom Schwarma))

964− expression = label @"Chicken"

965−in printSQL expression

966−:}

967−'Chicken'

968−```

969−

970−**Composite Types**

971−

972−In addition to enum types, you can define composite types.

973−A composite type represents the structure of a row or record;

974−it is essentially just a list of field names and their data types.

975−

976−

977−`createTypeComposite` creates a composite type. The composite type is

978−specified by a list of attribute names and data types.

979−

980−```Haskell

981−>>> :{

982−let

983− definition :: Definition '[] '["complex" ::: 'Typedef ('PGcomposite '["real" ::: 'PGfloat8, "imaginary" ::: 'PGfloat8])]

984− definition = createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil)

985−:}

986−>>> printSQL definition

987−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);

988−```

989−

990−Composite types are almost equivalent to Haskell record types.

991−However, because of the potential presence of `NULL`

992−all the record fields must be `Maybe`s of basic types.

993−Composite types can be generated from a Haskell record type, for example:

994−

995−```Haskell

996−>>> data Complex = Complex {real :: Maybe Double, imaginary :: Maybe Double} deriving GHC.Generic

997−>>> instance SOP.Generic Complex

998−>>> instance SOP.HasDatatypeInfo Complex

999−

1000−>>> :kind! CompositeFrom Complex

1001−CompositeFrom Complex :: PGType

1002−= 'PGcomposite '['("real", 'PGfloat8), '("imaginary", 'PGfloat8)]

1003−

1004−>>> :{

1005−let

1006− definition :: Definition '[] '["complex" ::: 'Typedef (CompositeFrom Complex)]

1007− definition = createTypeCompositeFrom @Complex #complex

1008−in printSQL definition

1009−:}

1010−CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);

1011−```

1012−

1013−A row constructor is an expression that builds a row value

1014−(also called a composite value) using values for its member fields.

1015−

1016−```Haskell

1017−>>> :{

1018−let

1019− i :: Expression '[] '[] 'Ungrouped '[] ('NotNull (CompositeFrom Complex))

1020− i = row (0 `As` #real :* 1 `As` #imaginary :* Nil)

1021−:}

1022−>>> printSQL i

1023−ROW(0, 1)

1024−```

1025−

1026−You can also use `(&)` to apply a field label to a composite value.

1027−

1028−```Haskell

1029−>>> :{

1030−let

1031− expr :: Expression '[] '[] 'Ungrouped '[] ('Null 'PGfloat8)

1032− expr = i & #imaginary

1033−in printSQL expr

1034−:}

1035−(ROW(0, 1)).imaginary

1036−```

1037−

1038−Both composite and enum types can be automatically encoded from and decoded to their equivalent Haskell types.

1039−And they can be dropped.

1040−

1041−```Haskell

1042−>>> :{

1043−let

1044− definition :: Definition '["mood" ::: 'Typedef ('PGenum '["sad", "ok", "happy"])] '[]

1045− definition = dropType #mood

1046−:}

1047−>>> printSQL definition

1048−DROP TYPE "mood";

1049−```

1050−

1051−**Additional Changes**

1052−

1053−Squeal 0.3 also introduces a typeclass `HasAll` similar to `Has` but for a list of aliases.

1054−This makes it possible to clean up some unfortunately messy Squeal 0.2 definitions.

1055−

1056−```Haskell

1057−-- Squeal 0.2

1058−>>> unique (Column #a :* Column #b :* Nil)

1059−

1060−-- Squeal 0.3

1061−>>> unique (#a :* #b :* Nil)

1062−```

1063−

1064−Squeal 0.3 also adds `IsLabel` instances for `Aliased` expressions and tables as well as

1065−heterogeneous lists, allowing for some more economy of code.

1066−

1067−```Haskell

1068−-- Squeal 0.2 (or 0.3)

1069−>>> select (#a `As` #a :* Nil) (from (table (#t `As` #t)))

1070−

1071−-- Squeal 0.3

1072−>>> select #a (from (table #t))

1073−```

1074−

1075−Squeal 0.3 also fixes a bug that prevented joined queries on self-referencing tables.

1076−

1077−The above changes required major and minor changes to Squeal DSL functions.

1078−Please consult the documentation.

1079−

10803### Version 0.2.1 - April 7, 2018

10814

10825This minor update fixes an issue where alias identifiers could conflict with

scrap-your-nils.mddeleted−60

@@ -1,60 +0,0 @@

1−## Scrap your Nils

2−

3−One of the most useful types I've come across in Haskell is the type of

4−"heterogeneous lists". This is the same as the [Rec](http://hackage.haskell.org/package/vinyl-0.8.1.1/docs/Data-Vinyl-Core.html)

5−datatype from the [vinyl](http://hackage.haskell.org/package/vinyl) library.

6−It's also the same as the [NP](http://hackage.haskell.org/package/generics-sop-0.3.2.0/docs/Generics-SOP-NP.html)

7−datatype from the [generics-sop](http://hackage.haskell.org/package/generics-sop) library.

8−Squeal makes heavy use of this type.

9−

10−```Haskell

11−>>> import Generics.SOP (NP(..))

12−>>> :i NP

13−type role NP representational nominal

14−data NP (a :: k -> *) (b :: [k]) where

15− Nil :: forall k (a :: k -> *). NP a '[]

16− (:*) :: forall k (a :: k -> *) (x :: k) (xs :: [k]).

17− (a x) -> (NP a xs) -> NP a (x : xs)

18− -- Defined in ‘Generics.SOP.NP’

19−```

20−

21−This type allows us to construct "product" types, where the types of the individual

22−"terms" are hosted at the type level.

23−

24−```Haskell

25−>>> :set -XDataKinds

26−>>> import Generics.SOP (I(..))

27−>>> let example = I "foo" :* I pi :* Nil :: NP I '[String, Double]

28−>>> example

29−I "foo" :* I 3.141592653589793 :* Nil

30−```

31−

32−One thing Squeal uses `NP` for is to form lists of aliases,

33−using GHC's `OverloadedLabels` extension, hosting the names

34−of the aliases themselves at the type level.

35−

36−```Haskell

37−>>> :set -XKindSignatures -XOverloadedLabels -XFlexibleInstances -XMultiParamTypeClasses

38−>>> import GHC.TypeLits

39−>>> import GHC.OverloadedLabels

40−>>> data Alias (alias :: Symbol) = Alias deriving (Eq,Ord,Show)

41−>>> instance IsLabel label (Alias label) where fromLabel = Alias

42−>>> let aliases = #foo :* #bar :* Nil :: NP Alias '["foo", "bar"]

43−```

44−

45−However, it's very ugly to have to end every list with `:* Nil`.

46−When I announced the release of Squeal, people rightly [complained](https://www.reddit.com/r/haskell/comments/6yr5v6/announcing_squeal_a_deep_embedding_of_sql_in/dmq8vvn)

47−about the syntactic noise. Luckily, there's a neat trick we can use to get rid of it.

48−Making an `IsLabel` instance not only for elements of our list

49−but also for lists of length 1, we can ask GHC to interpret

50−the last label as a list.

51−

52−```Haskell

53−>>> instance IsLabel label (NP Alias '[label]) where fromLabel = Alias :* Nil

54−>>> let aliases' = #foo :* #bar :: NP Alias '["foo", "bar"]

55−```

56−

57−Version 0.3.1 of Squeal enables the "Scrap your Nils" trick for

58−heterogeneous lists of `Alias`es, `Aliased` expressions, `PGlabel`s and `By`s

59−with the typeclasses `IsLabel`, `IsQualified`, `IsPGlabel`,

60−and the new `Aliasable` typeclass, to eliminate all need of using `Nil` in a list.

squeal-postgresql/exe/Example.hs+49−46

@@ -11,7 +11,8 @@

1111

1212module Main (main, main2) where

1313

14−import Control.Monad.IO.Class (MonadIO (..))

14+import Control.Monad (void)

15+import Control.Monad.Base (liftBase, MonadBase)

1516import Data.Int (Int16, Int32)

1617import Data.Monoid ((<>))

1718import Data.Text (Text)

@@ -28,7 +29,7 @@ type Schema =

2829 '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

2930 '[ "id" ::: 'Def :=> 'NotNull 'PGint4

3031 , "name" ::: 'NoDef :=> 'NotNull 'PGtext

31− , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray ('Null 'PGint2))

32+ , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2)

3233 ])

3334 , "emails" ::: 'Table (

3435 '[ "pk_emails" ::: 'PrimaryKey '["id"]

@@ -38,70 +39,72 @@ type Schema =

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

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

4041 ])

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

4242 ]

4343

44−type Schemas = Public Schema

45−

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

47−setup =

44+setup :: Definition '[] Schema

45+setup =

4846 createTable #users

49− ( serial `as` #id :*

50− (text & notNullable) `as` #name :*

51− (vararray int2 & notNullable) `as` #vec )

52− ( primaryKey #id `as` #pk_users )

47+ ( serial `As` #id :*

48+ (text & notNull) `As` #name :*

49+ (vararray int2 & notNull) `As` #vec :* Nil )

50+ ( primaryKey #id `As` #pk_users :* Nil )

5351 >>>

5452 createTable #emails

55− ( serial `as` #id :*

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

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

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

53+ ( serial `As` #id :*

54+ (int & notNull) `As` #user_id :*

55+ (text & null') `As` #email :* Nil )

56+ ( primaryKey #id `As` #pk_emails :*

5957 foreignKey #user_id #users #id

60− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

61− >>>

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

63−

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

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

66−

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

68−insertUser = insertInto #users

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

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

71−

72−insertEmail :: Manipulation_ Schemas (Int32, Maybe Text) ()

73−insertEmail = insertInto_ #emails

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

75−

76−getUsers :: Query_ Schemas () User

77−getUsers = select_

78− (#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec)

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

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

58+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )

59+

60+teardown :: Definition Schema '[]

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

62+

63+insertUser :: Manipulation Schema '[ 'NotNull 'PGtext, 'NotNull ('PGvararray 'PGint2)]

64+ '[ "fromOnly" ::: 'NotNull 'PGint4 ]

65+insertUser = insertRows #users

66+ (Default `As` #id :* Set (param @1) `As` #name :* Set (param @2) `As` #vec :* Nil) []

67+ OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))

68+

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

70+insertEmail = insertRows #emails

71+ ( Default `As` #id :*

72+ Set (param @1) `As` #user_id :*

73+ Set (param @2) `As` #email :* Nil ) []

74+ OnConflictDoNothing (Returning Nil)

75+

76+getUsers :: Query Schema '[]

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

78+ , "userEmail" ::: 'Null 'PGtext

79+ , "userVec" ::: 'NotNull ('PGvararray 'PGint2)]

80+getUsers = select

81+ (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* #u ! #vec `As` #userVec :* Nil)

82+ ( from (table (#users `As` #u)

83+ & innerJoin (table (#emails `As` #e))

8184 (#u ! #id .== #e ! #user_id)) )

8285

83−data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: VarArray (Vector (Maybe Int16)) }

86+data User = User { userName :: Text, userEmail :: Maybe Text, userVec :: Vector (Maybe Int16) }

8487 deriving (Show, GHC.Generic)

8588instance SOP.Generic User

8689instance SOP.HasDatatypeInfo User

8790

8891users :: [User]

89−users =

90− [ User "Alice" (Just "alice@gmail.com") (VarArray [Nothing, Just 1])

91− , User "Bob" Nothing (VarArray [Just 2, Nothing])

92− , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3])

92+users =

93+ [ User "Alice" (Just "alice@gmail.com") [Nothing, Just 1]

94+ , User "Bob" Nothing [Just 2, Nothing]

95+ , User "Carole" (Just "carole@hotmail.com") [Just 3]

9396 ]

9497

95−session :: (MonadIO pq, MonadPQ Schemas pq) => pq ()

98+session :: (MonadBase IO pq, MonadPQ Schema pq) => pq ()

9699session = do

97− liftIO $ Char8.putStrLn "manipulating"

100+ liftBase $ Char8.putStrLn "manipulating"

98101 idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])

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

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

101− liftIO $ Char8.putStrLn "querying"

104+ liftBase $ Char8.putStrLn "querying"

102105 usersResult <- runQuery getUsers

103106 usersRows <- getRows usersResult

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

107+ liftBase $ print (usersRows :: [User])

105108

106109main :: IO ()

107110main = do

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

119122

120123main2 :: IO ()

121124main2 =

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

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

123126 define setup

124127 & pqThen session

125128 & pqThen (define teardown)

squeal-postgresql/squeal-postgresql.cabal+12−74

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

11name: squeal-postgresql

2−version: 0.5.1.0

2+version: 0.2.1.0

33synopsis: Squeal PostgreSQL Library

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

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

@@ -22,116 +22,53 @@ library

2222 hs-source-dirs: src

2323 exposed-modules:

2424 Squeal.PostgreSQL

25− Squeal.PostgreSQL.Alias

2625 Squeal.PostgreSQL.Binary

2726 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

3527 Squeal.PostgreSQL.Expression

36− Squeal.PostgreSQL.Expression.Aggregate

37− Squeal.PostgreSQL.Expression.Collection

38− Squeal.PostgreSQL.Expression.Comparison

39− Squeal.PostgreSQL.Expression.Json

40− Squeal.PostgreSQL.Expression.Literal

41− Squeal.PostgreSQL.Expression.Logic

42− Squeal.PostgreSQL.Expression.Math

43− Squeal.PostgreSQL.Expression.Null

44− Squeal.PostgreSQL.Expression.Parameter

45− Squeal.PostgreSQL.Expression.Range

46− Squeal.PostgreSQL.Expression.Set

47− Squeal.PostgreSQL.Expression.Sort

48− Squeal.PostgreSQL.Expression.Subquery

49− Squeal.PostgreSQL.Expression.Text

50− Squeal.PostgreSQL.Expression.TextSearch

51− Squeal.PostgreSQL.Expression.Time

52− Squeal.PostgreSQL.Expression.Type

53− Squeal.PostgreSQL.Expression.Window

54− Squeal.PostgreSQL.List

5528 Squeal.PostgreSQL.Manipulation

5629 Squeal.PostgreSQL.Migration

5730 Squeal.PostgreSQL.Pool

58− Squeal.PostgreSQL.PG

5931 Squeal.PostgreSQL.PQ

6032 Squeal.PostgreSQL.Render

6133 Squeal.PostgreSQL.Query

6234 Squeal.PostgreSQL.Schema

6335 Squeal.PostgreSQL.Transaction

6436 default-language: Haskell2010

65− ghc-options: -Wall

37+ ghc-options: -Wall -fprint-explicit-kinds

6638 build-depends:

6739 aeson >= 1.2.4.0

68− , base >= 4.11.1.0 && < 5.0

69− , binary-parser >= 0.5.5

40+ , base >= 4.10.1.0 && < 5.0

41+ , binary-parser

7042 , bytestring >= 0.10.8.2

71− , bytestring-strict-builder >= 0.4.5

7243 , deepseq >= 1.4.3.0

73− , free-categories >= 0.1.0.0

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

44+ , generics-sop >= 0.3.2.0

45+ , lifted-base >= 0.2.3.12

7546 , mmorph >= 1.1.1

47+ , monad-control >= 1.0.2.3

7648 , mtl >= 2.2.2

7749 , network-ip >= 0.3.0.2

7850 , postgresql-binary >= 0.12.1

7951 , postgresql-libpq >= 0.9.4.1

80− , records-sop >= 0.1.0.0

8152 , resource-pool >= 0.2.3.2

8253 , scientific >= 0.3.5.3

8354 , text >= 1.2.3.0

8455 , time >= 1.8.0.2

8556 , transformers >= 0.5.2.0

86− , unliftio >= 0.2.10

87− , unliftio-pool >= 0.2.1.0

57+ , transformers-base >= 0.4.4

8858 , uuid-types >= 1.0.3

8959 , vector >= 0.12.0.1

9060

91−test-suite doctest

61+test-suite squeal-postgresql-doctest

9262 default-language: Haskell2010

9363 type: exitcode-stdio-1.0

9464 hs-source-dirs: test

9565 ghc-options: -Wall

96− main-is: Doc.hs

66+ main-is: DocTest.hs

9767 build-depends:

9868 base >= 4.10.0.0

9969 , doctest >= 0.11.4

100− , squeal-postgresql

101−

102−test-suite properties

103− default-language: Haskell2010

104− type: exitcode-stdio-1.0

105− hs-source-dirs: test

106− ghc-options: -Wall

107− main-is: Property.hs

108− build-depends:

109− base >= 4.10.0.0

110− , bytestring >= 0.10.8.2

111− , hedgehog >= 1.0

112− , mtl >= 2.2.2

113− , scientific >= 0.3.5.3

114− , squeal-postgresql

115− , time >= 1.8.0.2

116−

117−test-suite spec

118− default-language: Haskell2010

119− type: exitcode-stdio-1.0

120− hs-source-dirs: test

121− ghc-options: -Wall

122− main-is: Spec.hs

123− build-depends:

124− base >= 4.10.0.0

125− , async >= 2.2.2

126− , bytestring >= 0.10.8.2

127− , generics-sop >= 0.3.1.0

128− , hspec >= 2.4.8

129− , mtl >= 2.2.2

130− , squeal-postgresql

131− , text >= 1.2.2.2

132− , vector >= 0.12.0.1

13370

134−executable example

71+executable squeal-postgresql-example

13572 default-language: Haskell2010

13673 hs-source-dirs: exe

13774 ghc-options: -Wall

@@ -144,4 +81,5 @@ executable example

14481 , squeal-postgresql

14582 , text >= 1.2.2.2

14683 , transformers >= 0.5.2.0

84+ , transformers-base >= 0.4.4

14785 , vector >= 0.12.0.1

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

@@ -1,233 +1,222 @@

1−{-|

2−Module: Squeal.PostgreSQL

3−Description: Squeal export module

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

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

9−Let's see an example!

10−

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

12−features.

13−

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

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

16−

17−We'll need some imports.

18−

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

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

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

22−>>> import Squeal.PostgreSQL

23−

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

25−

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

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

28−

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

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

31−

32−>>> :{

33−type UsersColumns =

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

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

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

37−type EmailsColumns =

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

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

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

41−type EmailsConstraints =

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

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

44−type Schema =

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

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

47−type Schemas = Public Schema

48−:}

49−

50−Notice the use of type operators.

51−

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

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

54−operator.

55−

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

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

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

59−

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

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

62−has two type parameters, corresponding to the schema

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

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

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

66−

67−>>> :{

68−let

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

70− setup =

71− createTable #users

72− ( serial `as` #id :*

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

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

75− createTable #emails

76− ( serial `as` #id :*

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

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

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

80− foreignKey #user_id #users #id

81− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

82−:}

83−

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

85−

86−>>> printSQL setup

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

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

89−

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

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

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

93−`Definition` is simpler.

94−

95−>>> :{

96−let

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

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

99−:}

100−

101−>>> printSQL teardown

102−DROP TABLE "emails";

103−DROP TABLE "users";

104−

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

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

107−

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

109−>>> instance SOP.Generic User

110−>>> instance SOP.HasDatatypeInfo User

111−

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

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

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

115−and an output row. When

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

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

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

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

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

121−`with` statement.

122−

123−>>> :{

124−let

125− insertUser :: Manipulation_ Schemas User ()

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

127− where

128− u = insertInto #users

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

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

131− e = insertInto_ #emails $ Select

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

133− (from (common #u))

134−:}

135−

136−>>> printSQL insertUser

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

138−

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

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

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

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

143−

144−>>> :{

145−let

146− getUsers :: Query_ Schemas () User

147− getUsers = select_

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

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

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

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

152−:}

153−

154−>>> printSQL getUsers

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

156−

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

158−

159−>>> :{

160−let

161− users :: [User]

162− users =

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

164− , User "Bob" Nothing

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

166− ]

167−:}

168−

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

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

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

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

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

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

175−`MonadPQ` functionality.

176−

177−>>> :{

178−let

179− session :: PQ Schemas Schemas IO ()

180− session = do

181− _ <- traversePrepared_ insertUser users

182− usersResult <- runQuery getUsers

183− usersRows <- getRows usersResult

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

185−in

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

187− define setup

188− & pqThen session

189− & pqThen (define teardown)

190−:}

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

192−-}

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

194−

195−import Squeal.PostgreSQL.Alias as X

196−import Squeal.PostgreSQL.Binary as X

197−import Squeal.PostgreSQL.Definition as X

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

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

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

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

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

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

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

205−import Squeal.PostgreSQL.Expression as X

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

224−import Squeal.PostgreSQL.List as X

225−import Squeal.PostgreSQL.Manipulation as X

226−import Squeal.PostgreSQL.Migration as X

227−import Squeal.PostgreSQL.PG as X

228−import Squeal.PostgreSQL.Pool as X

229−import Squeal.PostgreSQL.PQ as X

230−import Squeal.PostgreSQL.Query as X

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

232−import Squeal.PostgreSQL.Schema as X

233−import Squeal.PostgreSQL.Transaction as X

1+-- | Module: Squeal.PostgreSQL

2+-- Description: Squeel export module

3+-- Copyright: (c) Eitan Chatav, 2017

4+-- Maintainer: eitan@morphism.tech

5+-- Stability: experimental

6+--

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

8+-- Let's see an example!

9+--

10+-- First, we need some language extensions because Squeal uses modern GHC

11+-- features.

12+--

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

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

15+--

16+-- We'll need some imports.

17+--

18+-- >>> import Control.Monad (void)

19+-- >>> import Control.Monad.Base (liftBase)

20+-- >>> import Data.Int (Int32)

21+-- >>> import Data.Text (Text)

22+-- >>> import Squeal.PostgreSQL

23+--

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

25+--

26+-- >>> import qualified Generics.SOP as SOP

27+-- >>> import qualified GHC.Generics as GHC

28+--

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

30+-- we use @DataKinds@ and @TypeOperators@.

31+--

32+-- >>> :{

33+-- type Schema =

34+-- '[ "users" ::: 'Table (

35+-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

36+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4

37+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext

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

50+-- Notice the use of type operators. `:::` is used

51+-- to pair an alias `Symbol` with either a `TableType` or a `ColumnType`.

52+-- `:=>` is used to pair a `TableConstraint`s with a `ColumnsType`,

53+-- yielding a `TableType`, or to pair a `ColumnConstraint` with a `NullityType`,

54+-- yielding a `ColumnType`.

55+--

56+-- Next, we'll write `Definition`s to set up and tear down the schema. In

57+-- Squeal, a `Definition` is a `createTable`, `alterTable` or `dropTable`

58+-- command and has two type parameters, corresponding to the schema

59+-- before being run and the schema after. We can compose definitions using

60+-- `>>>`. Here and in the rest of our commands we make use of overloaded

61+-- labels to refer to named tables and columns in our schema.

62+--

63+-- >>> :{

64+-- let

65+-- setup :: Definition '[] Schema

66+-- setup =

67+-- createTable #users

68+-- ( serial `As` #id :*

69+-- (text & notNull) `As` #name :* Nil )

70+-- ( primaryKey #id `As` #pk_users :* Nil ) >>>

71+-- createTable #emails

72+-- ( serial `As` #id :*

73+-- (int & notNull) `As` #user_id :*

74+-- (text & null') `As` #email :* Nil )

75+-- ( primaryKey #id `As` #pk_emails :*

76+-- foreignKey #user_id #users #id

77+-- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )

78+-- :}

79+--

80+-- We can easily see the generated SQL is unsuprising looking.

81+--

82+-- >>> renderDefinition setup

83+-- "CREATE TABLE \"users\" (\"id\" serial, \"name\" text NOT NULL, CONSTRAINT \"pk_users\" PRIMARY KEY (\"id\")); CREATE TABLE \"emails\" (\"id\" serial, \"user_id\" int NOT NULL, \"email\" text NULL, CONSTRAINT \"pk_emails\" PRIMARY KEY (\"id\"), CONSTRAINT \"fk_user_id\" FOREIGN KEY (\"user_id\") REFERENCES \"users\" (\"id\") ON DELETE CASCADE ON UPDATE CASCADE);"

84+--

85+-- Notice that @setup@ starts with an empty schema @'[]@ and produces @Schema@.

86+-- In our `createTable` commands we included `TableConstraint`s to define

87+-- primary and foreign keys, making them somewhat complex. Our tear down

88+-- `Definition` is simpler.

89+--

90+-- >>> :{

91+-- let

92+-- teardown :: Definition Schema '[]

93+-- teardown = dropTable #emails >>> dropTable #users

94+-- :}

95+--

96+-- >>> renderDefinition teardown

97+-- "DROP TABLE \"emails\"; DROP TABLE \"users\";"

98+--

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

100+-- A `Manipulation` is an `insertRow` (or other inserts), `update`

101+-- or `deleteFrom` command and

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

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

104+-- we insert into the users table, we will need a parameter for the @name@

105+-- field but not for the @id@ field. Since it's optional, we can use a default

106+-- value. However, since the emails table refers to the users table, we will

107+-- need to retrieve the user id that the insert generates and insert it into

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

109+-- of our inserts.

110+--

111+-- >>> :{

112+-- let

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

114+-- insertUser = insertRow #users

115+-- (Default `As` #id :* Set (param @1) `As` #name :* Nil)

116+-- OnConflictDoNothing (Returning (#id `As` #fromOnly :* Nil))

117+-- :}

118+--

119+-- >>> :{

120+-- let

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

122+-- insertEmail = insertRow #emails

123+-- ( Default `As` #id :*

124+-- Set (param @1) `As` #user_id :*

125+-- Set (param @2) `As` #email :* Nil )

126+-- OnConflictDoNothing (Returning Nil)

127+-- :}

128+--

129+-- >>> renderManipulation insertUser

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

131+-- >>> renderManipulation insertEmail

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

133+--

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

135+-- interested in the ids here, just the usernames and email addresses. We

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

137+-- `Manipulation` with the same kind of type parameters.

138+--

139+-- >>> :{

140+-- let

141+-- getUsers :: Query Schema '[]

142+-- '[ "userName" ::: 'NotNull 'PGtext

143+-- , "userEmail" ::: 'Null 'PGtext ]

144+-- getUsers = select

145+-- (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)

146+-- ( from (table (#users `As` #u)

147+-- & innerJoin (table (#emails `As` #e))

148+-- (#u ! #id .== #e ! #user_id)) )

149+-- :}

150+--

151+-- >>> renderQuery getUsers

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

153+--

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

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

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

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

158+-- @User@ type match the column names of @getUsers@.

159+--

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

161+-- >>> instance SOP.Generic User

162+-- >>> instance SOP.HasDatatypeInfo User

163+--

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

165+--

166+-- >>> :{

167+-- let

168+-- users :: [User]

169+-- users =

170+-- [ User "Alice" (Just "alice@gmail.com")

171+-- , User "Bob" Nothing

172+-- , User "Carole" (Just "carole@hotmail.com")

173+-- ]

174+-- :}

175+--

176+-- Now we can put together all the pieces into a program. The program

177+-- connects to the database, sets up the schema, inserts the user data

178+-- (using prepared statements as an optimization), queries the user

179+-- data and prints it out and finally closes the connection. We can thread

180+-- the changing schema information through by using the indexed `PQ` monad

181+-- transformer and when the schema doesn't change we can use `Monad` and

182+-- `MonadPQ` functionality.

183+--

184+-- >>> :{

185+-- let

186+-- session :: PQ Schema Schema IO ()

187+-- session = do

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

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

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

191+-- usersResult <- runQuery getUsers

192+-- usersRows <- getRows usersResult

193+-- liftBase $ print (usersRows :: [User])

194+-- :}

195+--

196+-- >>> :{

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

198+-- define setup

199+-- & pqThen session

200+-- & pqThen (define teardown)

201+-- :}

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

203+

204+module Squeal.PostgreSQL

205+ ( module Squeal.PostgreSQL.Binary

206+ , module Squeal.PostgreSQL.Definition

207+ , module Squeal.PostgreSQL.Expression

208+ , module Squeal.PostgreSQL.Manipulation

209+ , module Squeal.PostgreSQL.PQ

210+ , module Squeal.PostgreSQL.Query

211+ , module Squeal.PostgreSQL.Schema

212+ , module Squeal.PostgreSQL.Transaction

213+ ) where

214+

215+import Squeal.PostgreSQL.Binary

216+import Squeal.PostgreSQL.Definition

217+import Squeal.PostgreSQL.Expression

218+import Squeal.PostgreSQL.Manipulation

219+import Squeal.PostgreSQL.PQ

220+import Squeal.PostgreSQL.Query

221+import Squeal.PostgreSQL.Schema

222+import Squeal.PostgreSQL.Transaction

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

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

1−{-|

2−Module: Squeal.PostgreSQL.Alias

3−Description: Aliases

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

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

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

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

11−-}

12−

13−{-# LANGUAGE

14− AllowAmbiguousTypes

15− , ConstraintKinds

16− , DeriveAnyClass

17− , DeriveGeneric

18− , FlexibleContexts

19− , FlexibleInstances

20− , FunctionalDependencies

21− , GADTs

22− , LambdaCase

23− , OverloadedStrings

24− , QuantifiedConstraints

25− , RankNTypes

26− , ScopedTypeVariables

27− , StandaloneDeriving

28− , TypeApplications

29− , TypeFamilyDependencies

30− , TypeInType

31− , TypeOperators

32− , UndecidableInstances

33− , UndecidableSuperClasses

34−#-}

35−

36−module Squeal.PostgreSQL.Alias

37− ( (:::)

38− , Alias (..)

39− , IsLabel (..)

40− , Aliased (As)

41− , Aliasable (as)

42− , renderAliased

43− , Has

44− , HasUnique

45− , HasAll

46− , HasIn

47− , QualifiedAlias (..)

48− , IsQualified (..)

49− -- * Grouping

50− , Grouping (..)

51− , GroupedBy

52− ) where

53−

54−import Control.DeepSeq

55−import Data.ByteString (ByteString)

56−import Data.String (fromString)

57−import GHC.OverloadedLabels

58−import GHC.TypeLits

59−

60−import qualified Generics.SOP as SOP

61−import qualified GHC.Generics as GHC

62−

63−import Squeal.PostgreSQL.List

64−import Squeal.PostgreSQL.Render

65−

66−-- $setup

67−-- >>> import Squeal.PostgreSQL

68−

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

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

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

72−infixr 6 :::

73−

74−

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

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

77−-- for typesafe aggregation

78−data Grouping

79− = Ungrouped -- ^ no aggregation permitted

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

81−

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

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

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

85−-}

86−class (KnownSymbol table, KnownSymbol column)

87− => GroupedBy table column bys where

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

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

90−instance {-# OVERLAPPABLE #-}

91− ( KnownSymbol table

92− , KnownSymbol column

93− , GroupedBy table column bys

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

95−

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

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

98−--

99−-- >>> :set -XOverloadedLabels

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

101−-- Alias

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

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

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

105− fromLabel = Alias

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

107− fromLabel = fromLabel SOP.:* Nil

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

109−-- "jimbob"

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

111− renderSQL = doubleQuoted . fromString . symbolVal

112−

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

114−-- "jimbob", "kandi"

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

116− renderSQL

117− = commaSeparated

118− . SOP.hcollapse

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

120−

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

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

123−--

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

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

126−data Aliased expression aliased where

127− As

128− :: KnownSymbol alias

129− => expression ty

130− -> Alias alias

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

132−deriving instance Show (expression ty)

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

134−deriving instance Eq (expression ty)

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

136−deriving instance Ord (expression ty)

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

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

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

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

141−

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

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

144−class KnownSymbol alias => Aliasable alias expression aliased

145− | aliased -> expression

146− , aliased -> alias

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

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

149− (expression ty)

150− (Aliased expression aliased)

151− where

152− as = As

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

154− (expression ty)

155− (NP (Aliased expression) tys)

156− where

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

158−

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

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

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

162−renderAliased

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

164− -> Aliased expression aliased

165− -> ByteString

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

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

168−

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

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

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

172−

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

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

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

176−class KnownSymbol alias =>

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

178− | alias fields -> field where

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

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

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

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

183−

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

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

186−choose which subfields to update.

187−-}

188−class HasIn fields field where

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

190−

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

192−-- a list of @subfields@.

193−class

194− ( SOP.All KnownSymbol aliases

195− ) => HasAll

196− (aliases :: [Symbol])

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

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

199− | aliases fields -> subfields where

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

201−instance {-# OVERLAPPABLE #-}

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

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

204−

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

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

207−-- by a table alias.

208−class IsQualified table column expression where

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

210− infixl 9 !

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

212−

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

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

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

216−a qualifier of @public@ is provided.

217−

218−>>> :{

219−let

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

221− alias1 = #sch ! #tab

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

223− alias2 = #vw

224−in printSQL alias1 >> printSQL alias2

225−:}

226−"sch"."tab"

227−"vw"

228−-}

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

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

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

232− _!_ = QualifiedAlias

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

234− fromLabel = QualifiedAlias

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

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

237− _!_ = QualifiedAlias `As` Alias

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

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

240− fromLabel = QualifiedAlias `As` Alias

241−

242−instance (KnownSymbol q, KnownSymbol a)

243− => RenderSQL (QualifiedAlias q a) where

244− renderSQL _ =

245− let

246− qualifier = renderSQL (Alias @q)

247− alias = renderSQL (Alias @a)

248− in

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

squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+195−682

@@ -5,226 +5,48 @@ Copyright: (c) Eitan Chatav, 2017

55Maintainer: eitan@morphism.tech

66Stability: experimental

8−This module provides binary encoding and decoding between Haskell and PostgreSQL types.

9−

10−Instances are governed by the `SOP.Generic` and `SOP.HasDatatypeInfo` typeclasses, so you absolutely

11−do not need to define your own instances to decode retrieved rows into Haskell values or

12−to encode Haskell values into statement parameters.

13−

14−Let's see some examples. We'll need some imports

15−

16−>>> import Data.Int (Int16)

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

18−>>> import Control.Monad (void)

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

20−>>> import Squeal.PostgreSQL

21−

22−Define a Haskell datatype @Row@ that will serve as both the input and output of a simple

23−round trip query.

24−

25−>>> data Row = Row { col1 :: Int16, col2 :: Text, col3 :: Maybe Bool } deriving (Eq, GHC.Generic)

26−>>> instance Generic Row

27−>>> instance HasDatatypeInfo Row

28−>>> :{

29−let

30− roundTrip :: Query_ (Public '[]) Row Row

31− roundTrip = values_ $

32− parameter @1 int2 `as` #col1 :*

33− parameter @2 text `as` #col2 :*

34− parameter @3 bool `as` #col3

35−:}

36−

37−So long as we can encode the parameters and then decode the result of the query,

38−the input and output should be equal.

39−

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

41−>>> :{

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

43− result <- runQueryParams roundTrip input

44− Just output <- firstRow result

45− liftIO . print $ input == output

46−:}

47−True

48−

49−In addition to being able to encode and decode basic Haskell types

50−like `Int16` and `Data.Text.Text`, Squeal permits you to encode and decode Haskell types to

51−Postgres array, enumerated and composite types and json. Let's see another example,

52−this time using the `Vector` type which corresponds to variable length arrays

53−and homogeneous tuples which correspond to fixed length arrays. We can even

54−create multi-dimensional fixed length arrays.

55−

56−>>> :{

57−data Row = Row

58− { col1 :: VarArray (Vector Int16)

59− , col2 :: FixArray (Maybe Int16,Maybe Int16)

60− , col3 :: FixArray ((Int16,Int16),(Int16,Int16),(Int16,Int16))

61− } deriving (Eq, GHC.Generic)

62−:}

63−

64−>>> instance Generic Row

65−>>> instance HasDatatypeInfo Row

66−

67−Once again, we define a simple round trip query.

68−

69−>>> :{

70−let

71− roundTrip :: Query_ (Public '[]) Row Row

72− roundTrip = values_ $

73− parameter @1 (int2 & vararray) `as` #col1 :*

74− parameter @2 (int2 & fixarray @'[2]) `as` #col2 :*

75− parameter @3 (int2 & fixarray @'[3,2]) `as` #col3

76−:}

77−

78−>>> :set -XOverloadedLists

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

80−>>> :{

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

82− result <- runQueryParams roundTrip input

83− Just output <- firstRow result

84− liftIO . print $ input == output

85−:}

86−True

87−

88−Enumerated (enum) types are data types that comprise a static, ordered set of values.

89−They are equivalent to Haskell algebraic data types whose constructors are nullary.

90−An example of an enum type might be the days of the week,

91−or a set of status values for a piece of data.

92−

93−>>> data Schwarma = Beef | Lamb | Chicken deriving (Eq, Show, GHC.Generic)

94−>>> instance Generic Schwarma

95−>>> instance HasDatatypeInfo Schwarma

96−

97−A composite type represents the structure of a row or record;

98−it is essentially just a list of field names and their data types.

99−

100−>>> data Person = Person {name :: Text, age :: Int32} deriving (Eq, Show, GHC.Generic)

101−>>> instance Generic Person

102−>>> instance HasDatatypeInfo Person

103−>>> instance Aeson.FromJSON Person

104−>>> instance Aeson.ToJSON Person

105−

106−We can create the equivalent Postgres types directly from their Haskell types.

107−

108−>>> :{

109−type Schema =

110− '[ "schwarma" ::: 'Typedef (PG (Enumerated Schwarma))

111− , "person" ::: 'Typedef (PG (Composite Person))

112− ]

113−:}

114−

115−>>> :{

116−let

117− setup :: Definition (Public '[]) (Public Schema)

118− setup =

119− createTypeEnumFrom @Schwarma #schwarma >>>

120− createTypeCompositeFrom @Person #person

121−:}

122−

123−Let's demonstrate how to associate our Haskell types @Schwarma@ and @Person@

124−with enumerated, composite or json types in Postgres. First create a Haskell

125−@Row@ type using the `Enumerated`, `Composite` and `Json` newtypes as fields.

126−

127−>>> :{

128−data Row = Row

129− { schwarma :: Enumerated Schwarma

130− , person1 :: Composite Person

131− , person2 :: Json Person

132− } deriving (Eq, GHC.Generic)

133−:}

134−

135−>>> instance Generic Row

136−>>> instance HasDatatypeInfo Row

137−>>> :{

138−let

139− input = Row

140− (Enumerated Chicken)

141− (Composite (Person "Faisal" 24))

142− (Json (Person "Ahmad" 48))

143−:}

144−

145−Once again, define a round trip query.

146−

147−>>> :{

148−let

149− roundTrip :: Query_ (Public Schema) Row Row

150− roundTrip = values_ $

151− parameter @1 (typedef #schwarma) `as` #schwarma :*

152− parameter @2 (typedef #person) `as` #person1 :*

153− parameter @3 json `as` #person2

154−:}

155−

156−Finally, we can drop our type definitions.

157−

158−>>> :{

159−let

160− teardown :: Definition (Public Schema) (Public '[])

161− teardown = dropType #schwarma >>> dropType #person

162−:}

163−

164−Now let's run it.

165−

166−>>> :{

167−let

168− session = do

169− result <- runQueryParams roundTrip input

170− Just output <- firstRow result

171− liftIO . print $ input == output

172−in

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

174− define setup

175− & pqThen session

176− & pqThen (define teardown)

177−:}

178−True

8+Binary encoding and decoding between Haskell and PostgreSQL types.

1799-}

18010

18111{-# LANGUAGE

182− AllowAmbiguousTypes

12+ ConstraintKinds

13+ , DataKinds

14+ , DefaultSignatures

18315 , DeriveFoldable

18416 , DeriveFunctor

18517 , DeriveGeneric

18618 , DeriveTraversable

187− , DefaultSignatures

18819 , FlexibleContexts

18920 , FlexibleInstances

190− , FunctionalDependencies

19121 , GADTs

19222 , LambdaCase

193− , OverloadedStrings

23+ , KindSignatures

19424 , MultiParamTypeClasses

19525 , ScopedTypeVariables

19626 , TypeApplications

19727 , TypeFamilies

28+ , TypeFamilyDependencies

19829 , TypeInType

19930 , TypeOperators

20031 , UndecidableInstances

201− , UndecidableSuperClasses

20232#-}

20333

20434module Squeal.PostgreSQL.Binary

20535 ( -- * Encoding

20636 ToParam (..)

37+ , ToColumnParam (..)

20738 , ToParams (..)

208− , ToNullityParam (..)

209− , ToField (..)

210− , ToFixArray (..)

21139 -- * Decoding

21240 , FromValue (..)

41+ , FromColumnValue (..)

21342 , FromRow (..)

214− , FromField (..)

215− , FromFixArray (..)

21643 -- * Only

21744 , Only (..)

218− -- * Oid

219− , OidOf (..)

220− , OidOfParam (..)

221− , OidOfField (..)

22245 ) where

22346

22447import BinaryParser

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

226−import Control.Arrow (left)

227−import Control.Monad

48+import Data.Aeson hiding (Null)

49+import Data.Char (toUpper)

22850import Data.Int

22951import Data.Kind

23052import Data.Scientific

@@ -232,28 +54,20 @@ import Data.Time

23254import Data.UUID.Types

23355import Data.Vector (Vector)

23456import Data.Word

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

23657import Generics.SOP

237−import Generics.SOP.Record

23858import GHC.TypeLits

23959import Network.IP.Addr

60+import Text.Read (readMaybe)

24061

241−import qualified Data.Aeson as Aeson

242−import qualified Data.ByteString.Lazy as Lazy (ByteString)

243−import qualified Data.ByteString.Lazy as Lazy.ByteString

244−import qualified Data.ByteString as Strict (ByteString)

245−import qualified Data.Text.Lazy as Lazy (Text)

246−import qualified Data.Text as Strict (Text)

247−import qualified Data.Text as Strict.Text

62+import qualified Data.ByteString.Lazy as Lazy

63+import qualified Data.ByteString as Strict hiding (pack, unpack)

64+import qualified Data.Text.Lazy as Lazy

65+import qualified Data.Text as Strict

24866import qualified Data.Vector as Vector

249−import qualified Database.PostgreSQL.LibPQ as LibPQ

25067import qualified GHC.Generics as GHC

25168import qualified PostgreSQL.Binary.Decoding as Decoding

25269import qualified PostgreSQL.Binary.Encoding as Encoding

25370

254−import Squeal.PostgreSQL.Alias

255−import Squeal.PostgreSQL.List

256−import Squeal.PostgreSQL.PG

25771import Squeal.PostgreSQL.Schema

25872

25973-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into

@@ -277,20 +91,19 @@ class ToParam (x :: Type) (pg :: PGType) where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

291106instance ToParam Lazy.Text 'PGtext where toParam = K . Encoding.text_lazy

292−instance ToParam String 'PGtext where

293− toParam = K . Encoding.text_strict . Strict.Text.pack

294107instance ToParam Strict.ByteString 'PGbytea where

295108 toParam = K . Encoding.bytea_strict

296109instance ToParam Lazy.ByteString 'PGbytea where

@@ -304,256 +117,43 @@ instance ToParam LocalTime 'PGtimestamp where

304117instance ToParam UTCTime 'PGtimestamptz where

305118 toParam = K . Encoding.timestamptz_int

306119instance ToParam DiffTime 'PGinterval where toParam = K . Encoding.interval_int

307−instance ToParam Aeson.Value 'PGjson where toParam = K . Encoding.json_ast

308−instance ToParam Aeson.Value 'PGjsonb where toParam = K . Encoding.jsonb_ast

309−instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where

310− toParam = K . Encoding.json_bytes

311− . Lazy.ByteString.toStrict . Aeson.encode . getJson

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

313− toParam = K . Encoding.jsonb_bytes

314− . Lazy.ByteString.toStrict . Aeson.encode . getJsonb

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

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

317− toParam = K

318− . Encoding.array_foldable

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

320− . getVarArray

321−instance (ToParam x pg, OidOf pg)

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

323− toParam = K

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

325− . getVarArray

326−instance (ToParam x pg, OidOf pg)

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

328− toParam = K

329− . Encoding.nullableArray_vector

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

331− . getVarArray

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

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

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

335− . unK . unK . toFixArray @x @dims @ty . getFixArray

120+instance ToParam Value 'PGjson where toParam = K . Encoding.json_ast

121+instance ToParam Value 'PGjsonb where toParam = K . Encoding.jsonb_ast

122+instance (HasOid pg, ToParam x pg)

123+ => ToParam (Vector (Maybe x)) ('PGvararray pg) where

124+ toParam = K . Encoding.nullableArray_vector

125+ (oid @pg) (unK . toParam @x @pg)

336126instance

337127 ( IsEnumType x

338− , HasDatatypeInfo x

339− , LabelsPG x ~ labels

340− ) => ToParam (Enumerated x) ('PGenum labels) where

341− toParam =

342− let

343− gshowConstructor :: NP ConstructorInfo xss -> SOP I xss -> String

344− gshowConstructor Nil _ = ""

345− gshowConstructor (constructor :* _) (SOP (Z _)) =

346− constructorName constructor

347− gshowConstructor (_ :* constructors) (SOP (S xs)) =

348− gshowConstructor constructors (SOP xs)

349− in

350− K . Encoding.text_strict

351− . Strict.Text.pack

352− . gshowConstructor (constructorInfo (datatypeInfo (Proxy @x)))

353− . from

354− . getEnumerated

355−instance

356− ( SListI fields

357− , IsRecord x xs

358− , AllZip ToField xs fields

359− , All OidOfField fields

360− ) => ToParam (Composite x) ('PGcomposite fields) where

361− toParam =

362− let

363−

364− encoders = htrans (Proxy @ToField) toField

365−

366− composite

367− :: All OidOfField row

368− => NP (K (Maybe Encoding.Encoding)) row

369− -> K Encoding.Encoding ('PGcomposite row)

370− composite fields = K $

371− -- <number of fields: 4 bytes>

372− -- [for each field]

373− -- <OID of field's type: sizeof(Oid) bytes>

374− -- [if value is NULL]

375− -- <-1: 4 bytes>

376− -- [else]

377− -- <length of value: 4 bytes>

378− -- <value: <length> bytes>

379− -- [end if]

380− -- [end for]

381− int32BE (fromIntegral (lengthSList (Proxy @xs))) <>

382− let

383− each

384− :: OidOfField field

385− => K (Maybe Encoding.Encoding) field

386− -> Encoding.Encoding

387− each (K field :: K (Maybe Encoding.Encoding) field) =

388− word32BE (getOid (oidOfField @field))

389− <> case field of

390− Nothing -> int64BE (-1)

391− Just value ->

392− int32BE (fromIntegral (builderLength value))

393− <> value

394− in

395− hcfoldMap (Proxy @OidOfField) each fields

396−

397− in

398− composite . encoders . toRecord . getComposite

399−

400−-- | The object identifier of a `PGType`.

401−--

402−-- >>> :set -XTypeApplications

403−-- >>> oidOf @'PGbool

404−-- Oid 16

405−class OidOf (ty :: PGType) where oidOf :: LibPQ.Oid

406−instance OidOf 'PGbool where oidOf = LibPQ.Oid 16

407−instance OidOf ('PGfixarray ns (null 'PGbool)) where oidOf = LibPQ.Oid 1000

408−instance OidOf ('PGvararray (null 'PGbool)) where oidOf = LibPQ.Oid 1000

409−instance OidOf 'PGint2 where oidOf = LibPQ.Oid 21

410−instance OidOf ('PGfixarray ns (null 'PGint2)) where oidOf = LibPQ.Oid 1005

411−instance OidOf ('PGvararray (null 'PGint2)) where oidOf = LibPQ.Oid 1005

412−instance OidOf 'PGint4 where oidOf = LibPQ.Oid 23

413−instance OidOf ('PGfixarray ns (null 'PGint4)) where oidOf = LibPQ.Oid 1007

414−instance OidOf ('PGvararray (null 'PGint4)) where oidOf = LibPQ.Oid 1007

415−instance OidOf 'PGint8 where oidOf = LibPQ.Oid 20

416−instance OidOf ('PGfixarray ns (null 'PGint8)) where oidOf = LibPQ.Oid 1016

417−instance OidOf ('PGvararray (null 'PGint8)) where oidOf = LibPQ.Oid 1016

418−instance OidOf 'PGnumeric where oidOf = LibPQ.Oid 1700

419−instance OidOf ('PGfixarray ns (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231

420−instance OidOf ('PGvararray (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231

421−instance OidOf 'PGfloat4 where oidOf = LibPQ.Oid 700

422−instance OidOf ('PGfixarray ns (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021

423−instance OidOf ('PGvararray (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021

424−instance OidOf 'PGfloat8 where oidOf = LibPQ.Oid 701

425−instance OidOf ('PGfixarray ns (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022

426−instance OidOf ('PGvararray (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022

427−instance OidOf 'PGmoney where oidOf = LibPQ.Oid 790

428−instance OidOf ('PGfixarray ns (null 'PGmoney)) where oidOf = LibPQ.Oid 791

429−instance OidOf ('PGvararray (null 'PGmoney)) where oidOf = LibPQ.Oid 791

430−instance OidOf ('PGchar n) where oidOf = LibPQ.Oid 18

431−instance OidOf ('PGfixarray ns (null ('PGchar n))) where oidOf = LibPQ.Oid 1002

432−instance OidOf ('PGvararray (null ('PGchar n))) where oidOf = LibPQ.Oid 1002

433−instance OidOf ('PGvarchar n) where oidOf = LibPQ.Oid 1043

434−instance OidOf ('PGfixarray ns (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015

435−instance OidOf ('PGvararray (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015

436−instance OidOf 'PGtext where oidOf = LibPQ.Oid 25

437−instance OidOf ('PGfixarray ns (null 'PGtext)) where oidOf = LibPQ.Oid 1009

438−instance OidOf ('PGvararray (null 'PGtext)) where oidOf = LibPQ.Oid 1009

439−instance OidOf 'PGbytea where oidOf = LibPQ.Oid 17

440−instance OidOf ('PGfixarray ns (null 'PGbytea)) where oidOf = LibPQ.Oid 1001

441−instance OidOf ('PGvararray (null 'PGbytea)) where oidOf = LibPQ.Oid 1001

442−instance OidOf 'PGtimestamp where oidOf = LibPQ.Oid 1114

443−instance OidOf ('PGfixarray ns (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115

444−instance OidOf ('PGvararray (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115

445−instance OidOf 'PGtimestamptz where oidOf = LibPQ.Oid 1184

446−instance OidOf ('PGfixarray ns (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185

447−instance OidOf ('PGvararray (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185

448−instance OidOf 'PGdate where oidOf = LibPQ.Oid 1082

449−instance OidOf ('PGfixarray ns (null 'PGdate)) where oidOf = LibPQ.Oid 1182

450−instance OidOf ('PGvararray (null 'PGdate)) where oidOf = LibPQ.Oid 1182

451−instance OidOf 'PGtime where oidOf = LibPQ.Oid 1083

452−instance OidOf ('PGfixarray ns (null 'PGtime)) where oidOf = LibPQ.Oid 1183

453−instance OidOf ('PGvararray (null 'PGtime)) where oidOf = LibPQ.Oid 1183

454−instance OidOf 'PGtimetz where oidOf = LibPQ.Oid 1266

455−instance OidOf ('PGfixarray ns (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270

456−instance OidOf ('PGvararray (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270

457−instance OidOf 'PGinterval where oidOf = LibPQ.Oid 1186

458−instance OidOf ('PGfixarray ns (null 'PGinterval)) where oidOf = LibPQ.Oid 1187

459−instance OidOf ('PGvararray (null 'PGinterval)) where oidOf = LibPQ.Oid 1187

460−instance OidOf 'PGuuid where oidOf = LibPQ.Oid 2950

461−instance OidOf ('PGfixarray ns (null 'PGuuid)) where oidOf = LibPQ.Oid 2951

462−instance OidOf ('PGvararray (null 'PGuuid)) where oidOf = LibPQ.Oid 2951

463−instance OidOf 'PGinet where oidOf = LibPQ.Oid 869

464−instance OidOf ('PGfixarray ns (null 'PGinet)) where oidOf = LibPQ.Oid 1041

465−instance OidOf ('PGvararray (null 'PGinet)) where oidOf = LibPQ.Oid 1041

466−instance OidOf 'PGjson where oidOf = LibPQ.Oid 114

467−instance OidOf ('PGfixarray ns (null 'PGjson)) where oidOf = LibPQ.Oid 199

468−instance OidOf ('PGvararray (null 'PGjson)) where oidOf = LibPQ.Oid 199

469−instance OidOf 'PGjsonb where oidOf = LibPQ.Oid 3802

470−instance OidOf ('PGfixarray ns (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807

471−instance OidOf ('PGvararray (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807

472−instance OidOf 'PGtsvector where oidOf = LibPQ.Oid 3614

473−instance OidOf ('PGfixarray ns (null 'PGtsvector)) where oidOf = LibPQ.Oid 3643

474−instance OidOf ('PGvararray (null 'PGtsvector)) where oidOf = LibPQ.Oid 3643

475−instance OidOf 'PGtsquery where oidOf = LibPQ.Oid 3615

476−instance OidOf ('PGfixarray ns (null 'PGtsquery)) where oidOf = LibPQ.Oid 3645

477−instance OidOf ('PGvararray (null 'PGtsquery)) where oidOf = LibPQ.Oid 3645

478−instance OidOf 'PGoid where oidOf = LibPQ.Oid 26

479−instance OidOf ('PGfixarray ns (null 'PGoid)) where oidOf = LibPQ.Oid 1028

480−instance OidOf ('PGvararray (null 'PGoid)) where oidOf = LibPQ.Oid 1028

481−instance OidOf ('PGrange 'PGint4) where oidOf = LibPQ.Oid 3904

482−instance OidOf ('PGfixarray ns (null ('PGrange 'PGint4))) where oidOf = LibPQ.Oid 3905

483−instance OidOf ('PGvararray (null ('PGrange 'PGint4))) where oidOf = LibPQ.Oid 3905

484−instance OidOf ('PGrange 'PGint8) where oidOf = LibPQ.Oid 3926

485−instance OidOf ('PGfixarray ns (null ('PGrange 'PGint8))) where oidOf = LibPQ.Oid 3927

486−instance OidOf ('PGvararray (null ('PGrange 'PGint8))) where oidOf = LibPQ.Oid 3927

487−instance OidOf ('PGrange 'PGnumeric) where oidOf = LibPQ.Oid 3906

488−instance OidOf ('PGfixarray ns (null ('PGrange 'PGnumeric))) where oidOf = LibPQ.Oid 3907

489−instance OidOf ('PGvararray (null ('PGrange 'PGnumeric))) where oidOf = LibPQ.Oid 3907

490−instance OidOf ('PGrange 'PGtimestamp) where oidOf = LibPQ.Oid 3908

491−instance OidOf ('PGfixarray ns (null ('PGrange 'PGtimestamp))) where oidOf = LibPQ.Oid 3909

492−instance OidOf ('PGvararray (null ('PGrange 'PGtimestamp))) where oidOf = LibPQ.Oid 3909

493−instance OidOf ('PGrange 'PGtimestamptz) where oidOf = LibPQ.Oid 3910

494−instance OidOf ('PGfixarray ns (null ('PGrange 'PGtimestamptz))) where oidOf = LibPQ.Oid 3911

495−instance OidOf ('PGvararray (null ('PGrange 'PGtimestamptz))) where oidOf = LibPQ.Oid 3911

496−instance OidOf ('PGrange 'PGdate) where oidOf = LibPQ.Oid 3912

497−instance OidOf ('PGfixarray ns (null ('PGrange 'PGdate))) where oidOf = LibPQ.Oid 3913

498−instance OidOf ('PGvararray (null ('PGrange 'PGdate))) where oidOf = LibPQ.Oid 3913

499−instance {-# OVERLAPPABLE #-} OidOf ('PGrange ty) where oidOf = LibPQ.invalidOid

500−instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGrange ty))) where oidOf = LibPQ.invalidOid

501−instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGrange ty))) where oidOf = LibPQ.invalidOid

502−instance {-# OVERLAPPABLE #-} OidOf ('PGcomposite row) where oidOf = LibPQ.invalidOid

503−instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGcomposite row))) where oidOf = LibPQ.invalidOid

504−instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGcomposite row))) where oidOf = LibPQ.invalidOid

505−instance {-# OVERLAPPABLE #-} OidOf ('PGenum labels) where oidOf = LibPQ.invalidOid

506−instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGenum labels))) where oidOf = LibPQ.invalidOid

507−instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGenum labels))) where oidOf = LibPQ.invalidOid

508−

509−class OidOfParam (ty :: NullityType) where oidOfParam :: Oid

510−instance OidOf ty => OidOfParam (null ty) where oidOfParam = oidOf @ty

511−

512−-- | Lifts a `OidOf` constraint to a field.

513−class OidOfField (field :: (Symbol, NullityType)) where

514− oidOfField :: Oid

515−instance OidOf ty => OidOfField (alias ::: nullity ty) where

516− oidOfField = oidOf @ty

517−

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

519−-- into the binary format of a PostgreSQL `NullityType`.

520−class ToNullityParam (x :: Type) (ty :: NullityType) where

521− toNullityParam :: x -> K (Maybe Encoding.Encoding) ty

522−instance ToParam x pg => ToNullityParam x ('NotNull pg) where

523− toNullityParam = K . Just . unK . toParam @x @pg

524−instance ToParam x pg => ToNullityParam (Maybe x) ('Null pg) where

525− toNullityParam = K . fmap (unK . toParam @x @pg)

526−

527−-- | A `ToField` constraint lifts the `ToParam` parser

528−-- to an encoding of a @(Symbol, Type)@ to a @(Symbol, NullityType)@,

529−-- encoding `Null`s to `Maybe`s. You should not define instances for

530−-- `FromField`, just use the provided instances.

531−class ToField (x :: (Symbol, Type)) (field :: (Symbol, NullityType)) where

532− toField :: P x -> K (Maybe Encoding.Encoding) field

533−instance ToNullityParam x ty => ToField (alias ::: x) (alias ::: ty) where

534− toField (P x) = K . unK $ toNullityParam @x @ty x

535−

536−-- | A `ToFixArray` constraint gives an encoding of a Haskell `Type`

537−-- into the binary format of a PostgreSQL fixed-length array.

538−-- You should not define instances for

539−-- `ToFixArray`, just use the provided instances.

540−class ToFixArray (x :: Type) (dims :: [Nat]) (array :: NullityType) where

541− toFixArray :: x -> K (K Encoding.Array dims) array

542−instance ToNullityParam x ty => ToFixArray x '[] ty where

543− toFixArray = K . K . maybe Encoding.nullArray Encoding.encodingArray . unK

544− . toNullityParam @x @ty

545−instance

546− ( IsProductType product xs

547− , Length xs ~ dim

548− , All ((~) x) xs

549− , ToFixArray x dims ty )

550− => ToFixArray product (dim ': dims) ty where

551− toFixArray = K . K . Encoding.dimensionArray foldlN

552− (unK . unK . toFixArray @x @dims @ty) . unZ . unSOP . from

128+ , Show x

129+ -- , SameLabels (DatatypeInfoOf y) labels

130+ --

131+ -- uncomment above constraint when GHC issue #11671 is fixed

132+ -- Allow labels starting with uppercase with OverloadedLabels

133+ -- https://ghc.haskell.org/trac/ghc/ticket/11671?cversion=0&cnum_hist=8

134+ ) => ToParam x ('PGenum labels) where

135+ toParam = K . Encoding.text_strict . Strict.pack . show

136+-- | A `ToColumnParam` constraint lifts the `ToParam` encoding

137+-- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should

138+-- not define instances of `ToColumnParam`, just use the provided instances.

139+class ToColumnParam (x :: Type) (ty :: NullityType) where

140+ -- | >>> toColumnParam @Int16 @('NotNull 'PGint2) 0

141+ -- K (Just "\NUL\NUL")

142+ --

143+ -- >>> toColumnParam @(Maybe Int16) @('Null 'PGint2) (Just 0)

144+ -- K (Just "\NUL\NUL")

145+ --

146+ -- >>> toColumnParam @(Maybe Int16) @('Null 'PGint2) Nothing

147+ -- K Nothing

148+ toColumnParam :: x -> K (Maybe Strict.ByteString) ty

149+instance ToParam x pg => ToColumnParam x ('NotNull pg) where

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

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

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

553153

554154-- | A `ToParams` constraint generically sequences the encodings of `Type`s

555155-- of the fields of a tuple or record to a row of `ColumnType`s. You should

556−-- not define instances of `ToParams`. Instead define `SOP.Generic` instances

156+-- not define instances of `ToParams`. Instead define `Generic` instances

557157-- which in turn provide `ToParams` instances.

558158class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where

559159 -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2]

@@ -565,257 +165,186 @@ class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where

565165 -- >>> instance Generic Tuple

566166 -- >>> toParams @Tuple @Params (Tuple False (Just 0))

567167 -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil

568− toParams :: x -> NP (K (Maybe Encoding.Encoding)) tys

569−instance (SListI tys, IsProductType x xs, AllZip ToNullityParam xs tys)

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

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

570170 => ToParams x tys where

571171 toParams

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

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

573173 . unZ . unSOP . from

574174

575175-- | A `FromValue` constraint gives a parser from the binary format of

576176-- a PostgreSQL `PGType` into a Haskell `Type`.

577177class FromValue (pg :: PGType) (y :: Type) where

578178 -- | >>> newtype Id = Id { getId :: Int16 } deriving Show

579− -- >>> instance FromValue 'PGint2 Id where fromValue = Id <$> fromValue @'PGint2

580− fromValue :: Decoding.Value y

581−instance FromValue 'PGbool Bool where fromValue = Decoding.bool

582−instance FromValue 'PGint2 Int16 where fromValue = Decoding.int

583−instance FromValue 'PGint4 Int32 where fromValue = Decoding.int

584−instance FromValue 'PGint8 Int64 where fromValue = Decoding.int

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

586−instance FromValue 'PGfloat4 Float where fromValue = Decoding.float4

587−instance FromValue 'PGfloat8 Double where fromValue = Decoding.float8

588−instance FromValue 'PGnumeric Scientific where fromValue = Decoding.numeric

589−instance FromValue 'PGmoney Money where fromValue = Money <$> Decoding.int

590−instance FromValue 'PGuuid UUID where fromValue = Decoding.uuid

591−instance FromValue 'PGinet (NetAddr IP) where fromValue = Decoding.inet

592−instance FromValue ('PGchar 1) Char where fromValue = Decoding.char

593−instance FromValue 'PGtext Strict.Text where fromValue = Decoding.text_strict

594−instance FromValue 'PGtext Lazy.Text where fromValue = Decoding.text_lazy

595−instance FromValue 'PGtext String where

596− fromValue = Strict.Text.unpack <$> Decoding.text_strict

179+ -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue

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

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

182+instance FromValue 'PGint2 Int16 where fromValue _ = Decoding.int

183+instance FromValue 'PGint4 Int32 where fromValue _ = Decoding.int

184+instance FromValue 'PGint8 Int64 where fromValue _ = Decoding.int

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

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

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

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

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

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

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

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

597193instance FromValue 'PGbytea Strict.ByteString where

598− fromValue = Decoding.bytea_strict

194+ fromValue _ = Decoding.bytea_strict

599195instance FromValue 'PGbytea Lazy.ByteString where

600− fromValue = Decoding.bytea_lazy

601−instance FromValue 'PGdate Day where fromValue = Decoding.date

602−instance FromValue 'PGtime TimeOfDay where fromValue = Decoding.time_int

196+ fromValue _ = Decoding.bytea_lazy

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

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

603199instance FromValue 'PGtimetz (TimeOfDay, TimeZone) where

604− fromValue = Decoding.timetz_int

200+ fromValue _ = Decoding.timetz_int

605201instance FromValue 'PGtimestamp LocalTime where

606− fromValue = Decoding.timestamp_int

202+ fromValue _ = Decoding.timestamp_int

607203instance FromValue 'PGtimestamptz UTCTime where

608− fromValue = Decoding.timestamptz_int

204+ fromValue _ = Decoding.timestamptz_int

609205instance FromValue 'PGinterval DiffTime where

610− fromValue = Decoding.interval_int

611−instance FromValue 'PGjson Aeson.Value where fromValue = Decoding.json_ast

612−instance FromValue 'PGjsonb Aeson.Value where fromValue = Decoding.jsonb_ast

613−instance Aeson.FromJSON x => FromValue 'PGjson (Json x) where

614− fromValue = Json <$>

615− Decoding.json_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)

616−instance Aeson.FromJSON x => FromValue 'PGjsonb (Jsonb x) where

617− fromValue = Jsonb <$>

618− Decoding.jsonb_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)

619−instance FromValue pg y

620− => FromValue ('PGvararray ('NotNull pg)) (VarArray (Vector y)) where

621− fromValue =

622− let

623− rep n x = VarArray <$> Vector.replicateM n x

624− in

625− Decoding.array $ Decoding.dimensionArray rep

626− (fromFixArray @'[] @('NotNull pg))

627−instance FromValue pg y

628− => FromValue ('PGvararray ('Null pg)) (VarArray (Vector (Maybe y))) where

629− fromValue =

630− let

631− rep n x = VarArray <$> Vector.replicateM n x

632− in

633− Decoding.array $ Decoding.dimensionArray rep

634− (fromFixArray @'[] @('Null pg))

635−instance FromValue pg y

636− => FromValue ('PGvararray ('NotNull pg)) (VarArray [y]) where

637− fromValue =

638− let

639− rep n x = VarArray <$> replicateM n x

640− in

641− Decoding.array $ Decoding.dimensionArray rep

642− (fromFixArray @'[] @('NotNull pg))

643−instance FromValue pg y

644− => FromValue ('PGvararray ('Null pg)) (VarArray [Maybe y]) where

645− fromValue =

646− let

647− rep n x = VarArray <$> replicateM n x

648− in

649− Decoding.array $ Decoding.dimensionArray rep

650− (fromFixArray @'[] @('Null pg))

651−instance FromFixArray dims ty y

652− => FromValue ('PGfixarray dims ty) (FixArray y) where

653− fromValue = FixArray <$> Decoding.array (fromFixArray @dims @ty @y)

206+ fromValue _ = Decoding.interval_int

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

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

209+instance FromValue pg y => FromValue ('PGvararray pg) (Vector (Maybe y)) where

210+ fromValue _ = Decoding.array

211+ (Decoding.dimensionArray Vector.replicateM

212+ (Decoding.nullableValueArray (fromValue (Proxy @pg))))

213+instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where

214+ fromValue _ = Decoding.array

215+ (Decoding.dimensionArray Vector.replicateM

216+ (Decoding.nullableValueArray (fromValue (Proxy @pg))))

654217instance

655218 ( IsEnumType y

656− , HasDatatypeInfo y

657− , LabelsPG y ~ labels

658− ) => FromValue ('PGenum labels) (Enumerated y) where

659− fromValue =

219+ , Read y

220+ -- , SameLabels (DatatypeInfoOf y) labels

221+ --

222+ -- uncomment above constraint when GHC issue #11671 is fixed

223+ -- Allow labels starting with uppercase with OverloadedLabels

224+ -- https://ghc.haskell.org/trac/ghc/ticket/11671?cversion=0&cnum_hist=8

225+ ) => FromValue ('PGenum labels) y where

226+ fromValue _ =

660227 let

661− greadConstructor

662− :: All ((~) '[]) xss

663− => NP ConstructorInfo xss

664− -> String

665− -> Maybe (SOP I xss)

666− greadConstructor Nil _ = Nothing

667− greadConstructor (constructor :* constructors) name =

668− if name == constructorName constructor

669− then Just (SOP (Z Nil))

670− else SOP . S . unSOP <$> greadConstructor constructors name

228+ upper "" = ""

229+ upper (ch:chs) = toUpper ch : chs

671230 in

672− fmap Enumerated

673− . Decoding.enum

674− $ fmap to

675− . greadConstructor (constructorInfo (datatypeInfo (Proxy @y)))

676− . Strict.Text.unpack

231+ Decoding.enum (readMaybe . upper . Strict.unpack)

677232instance

678− ( FromRow fields y

679− ) => FromValue ('PGcomposite fields) (Composite y) where

680− fromValue =

681− let

682− -- <number of fields: 4 bytes>

683− -- [for each field]

684− -- <OID of field's type: sizeof(Oid) bytes>

685− -- [if value is NULL]

686− -- <-1: 4 bytes>

687− -- [else]

688− -- <length of value: 4 bytes>

689− -- <value: <length> bytes>

690− -- [end if]

691− -- [end for]

692− composite = Decoding.valueParser $ do

693− unitOfSize 4

694− hsequence' $ hpure $ Comp $ do

695− unitOfSize 4

696− len <- sized 4 Decoding.int

697− if len == -1

698− then return (K Nothing)

699− else K . Just <$> bytesOfSize len

700− in

701− fmap Composite (Decoding.fn (fromRow @fields <=< composite))

702−

703−-- | A `FromField` constraint lifts the `FromValue` parser

704−-- to a decoding of a @(Symbol, NullityType)@ to a `Type`,

233+ ( SListI fields

234+ , IsMaybes ys

235+ , IsProductType y (Maybes ys)

236+ , AllZip FromAliasedValue fields ys

237+ , SameFields (DatatypeInfoOf y) fields

238+ ) => FromValue ('PGcomposite fields) y where

239+ fromValue = fmap (to . SOP . Z . maybes) . composite . decoders

240+

241+class IsMaybes (xs :: [Type]) where

242+ type family Maybes xs = (mxs :: [Type]) | mxs -> xs

243+ maybes :: NP Maybe xs -> NP I (Maybes xs)

244+

245+instance IsMaybes '[] where

246+ type Maybes '[] = '[]

247+ maybes Nil = Nil

248+

249+instance IsMaybes xs => IsMaybes (x ': xs) where

250+ type Maybes (x ': xs) = Maybe x ': Maybes xs

251+ maybes (x :* xs) = I x :* maybes xs

252+

253+class FromAliasedValue (pg :: (Symbol,PGType)) (y :: Type) where

254+ fromAliasedValue :: proxy pg -> Decoding.Value y

255+instance FromValue pg y => FromAliasedValue (alias ::: pg) y where

256+ fromAliasedValue _ = fromValue (Proxy @pg)

257+

258+decoders

259+ :: forall pgs ys proxy

260+ . AllZip FromAliasedValue pgs ys

261+ => proxy ('PGcomposite pgs)

262+ -> NP Decoding.Value ys

263+decoders _ = htrans (Proxy @FromAliasedValue) fromAliasedValue

264+ (hpure Proxy :: NP Proxy pgs)

265+

266+composite

267+ :: SListI ys

268+ => NP Decoding.Value ys

269+ -> Decoding.Value (NP Maybe ys)

270+composite fields = do

271+-- [for each field]

272+-- <OID of field's type: sizeof(Oid) bytes>

273+-- [if value is NULL]

274+-- <-1: 4 bytes>

275+-- [else]

276+-- <length of value: 4 bytes>

277+-- <value: <length> bytes>

278+-- [end if]

279+-- [end for]

280+-- <number of fields: 4 bytes>

281+ unitOfSize 4

282+ let

283+ each field = do

284+ unitOfSize 4

285+ len <- sized 4 Decoding.int

286+ if len == -1 then return Nothing else Just <$> sized len field

287+ htraverse' each fields

288+

289+-- | A `FromColumnValue` constraint lifts the `FromValue` parser

290+-- to a decoding of a @(Symbol, ColumnType)@ to a `Type`,

705291-- decoding `Null`s to `Maybe`s. You should not define instances for

706−-- `FromField`, just use the provided instances.

707−class FromField (pg :: (Symbol, NullityType)) (y :: (Symbol, Type)) where

708− fromField

709− :: K (Maybe Strict.ByteString) pg

710− -> (Either Strict.Text :.: P) y

292+-- `FromColumnValue`, just use the provided instances.

293+class FromColumnValue (colty :: (Symbol,NullityType)) (y :: Type) where

294+ -- | >>> :set -XTypeOperators -XOverloadedStrings

295+ -- >>> newtype Id = Id { getId :: Int16 } deriving Show

296+ -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue

297+ -- >>> fromColumnValue @("col" ::: 'NotNull 'PGint2) @Id (K (Just "\NUL\SOH"))

298+ -- Id {getId = 1}

299+ --

300+ -- >>> fromColumnValue @("col" ::: 'Null 'PGint2) @(Maybe Id) (K (Just "\NUL\SOH"))

301+ -- Just (Id {getId = 1})

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

711303instance FromValue pg y

712− => FromField (column ::: ('NotNull pg)) (column ::: y) where

713− fromField = Comp . \case

714− K Nothing -> Left "fromField: saw NULL when expecting NOT NULL"

715− K (Just bytestring) -> P <$>

716− Decoding.valueParser (fromValue @pg) bytestring

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

305+ fromColumnValue = \case

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

307+ K (Just bytes) ->

308+ let

309+ errOrValue =

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

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

312+ in

313+ either err id errOrValue

717314instance FromValue pg y

718− => FromField (column ::: 'Null pg) (column ::: Maybe y) where

719− fromField = Comp . \case

720− K Nothing -> Right $ P Nothing

721− K (Just bytestring) -> P . Just <$>

722− Decoding.valueParser (fromValue @pg) bytestring

723−

724−-- | A `FromFixArray` constraint gives a decoding to a Haskell `Type`

725−-- from the binary format of a PostgreSQL fixed-length array.

726−-- You should not define instances for

727−-- `FromFixArray`, just use the provided instances.

728−class FromFixArray (dims :: [Nat]) (ty :: NullityType) (y :: Type) where

729− fromFixArray :: Decoding.Array y

730−instance FromValue pg y => FromFixArray '[] ('NotNull pg) y where

731− fromFixArray = Decoding.valueArray (fromValue @pg @y)

732−instance FromValue pg y => FromFixArray '[] ('Null pg) (Maybe y) where

733− fromFixArray = Decoding.nullableValueArray (fromValue @pg @y)

734−instance

735− ( IsProductType product ys

736− , Length ys ~ dim

737− , All ((~) y) ys

738− , FromFixArray dims ty y )

739− => FromFixArray (dim ': dims) ty product where

740− fromFixArray =

741− let

742− rep _ = fmap (to . SOP . Z) . replicateMN

743− in

744− Decoding.dimensionArray rep (fromFixArray @dims @ty @y)

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

316+ fromColumnValue (K nullOrBytes)

317+ = either err id

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

319+ <$> nullOrBytes

320+ where

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

745322

746323-- | A `FromRow` constraint generically sequences the parsings of the columns

747−-- of a `RowType` into the fields of a record `Type` provided they have

324+-- of a `RelationType` into the fields of a record `Type` provided they have

748325-- the same field names. You should not define instances of `FromRow`.

749−-- Instead define `SOP.Generic` and `SOP.HasDatatypeInfo` instances which in turn

326+-- Instead define `Generic` and `HasDatatypeInfo` instances which in turn

750327-- provide `FromRow` instances.

751−class SListI result => FromRow (result :: RowType) y where

328+class SListI results => FromRow (results :: RelationType) y where

752329 -- | >>> :set -XOverloadedStrings

753330 -- >>> import Data.Text

754331 -- >>> newtype UserId = UserId { getUserId :: Int16 } deriving Show

755− -- >>> instance FromValue 'PGint2 UserId where fromValue = UserId <$> fromValue @'PGint2

332+ -- >>> instance FromValue 'PGint2 UserId where fromValue = fmap UserId . fromValue

756333 -- >>> data UserRow = UserRow { userId :: UserId, userName :: Maybe Text } deriving (Show, GHC.Generic)

757334 -- >>> instance Generic UserRow

758335 -- >>> instance HasDatatypeInfo UserRow

759336 -- >>> type User = '["userId" ::: 'NotNull 'PGint2, "userName" ::: 'Null 'PGtext]

760337 -- >>> fromRow @User @UserRow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)

761− -- Right (UserRow {userId = UserId {getUserId = 1}, userName = Just "bloodninja"})

762− fromRow :: NP (K (Maybe Strict.ByteString)) result -> Either Strict.Text y

338+ -- UserRow {userId = UserId {getUserId = 1}, userName = Just "bloodninja"}

339+ fromRow :: NP (K (Maybe Strict.ByteString)) results -> y

763340instance

764− ( SListI result

765− , IsRecord y ys

766− , AllZip FromField result ys

767− ) => FromRow result y where

341+ ( SListI results

342+ , IsProductType y ys

343+ , AllZip FromColumnValue results ys

344+ , SameFields (DatatypeInfoOf y) results

345+ ) => FromRow results y where

768346 fromRow

769− = fmap fromRecord

770− . hsequence'

771− . htrans (Proxy @FromField) fromField

772−------------------------------------------------------

773−-- P records

774−------------------------------------------------------

775−-- instance (FromField (col ::: pg) (col ::: hask))

776−-- => FromRow '[col ::: pg] (P (col ::: hask)) where

777−-- fromRow (pg :* Nil) = (unComp . fromField) pg

778−-- instance

779−-- ( row ~ Join row1 row2

780−-- , FromRow row1 hask1

781−-- , FromRow row2 hask2

782−-- , SListI row

783−-- ) => FromRow row (hask1, hask2) where

784−-- fromRow row = case disjoin @row1 @row2 row of

785−-- (row1, row2) -> (,) <$> fromRow row1 <*> fromRow row2

786−-- instance

787−-- ( row ~ Join row1 row23

788−-- , FromRow row1 hask1

789−-- , FromRow row23 (hask2, hask3)

790−-- , SListI row

791−-- ) => FromRow row (hask1, hask2, hask3) where

792−-- fromRow row = case disjoin @row1 @row23 row of

793−-- (row1, row23) -> do

794−-- hask1 <- fromRow row1

795−-- (hask2, hask3) <- fromRow row23

796−-- return (hask1, hask2, hask3)

797−-- instance

798−-- ( row ~ Join row1 row234

799−-- , FromRow row1 hask1

800−-- , FromRow row234 (hask2, hask3, hask4)

801−-- , SListI row

802−-- ) => FromRow row (hask1, hask2, hask3, hask4) where

803−-- fromRow row = case disjoin @row1 @row234 row of

804−-- (row1, row234) -> do

805−-- hask1 <- fromRow row1

806−-- (hask2, hask3, hask4) <- fromRow row234

807−-- return (hask1, hask2, hask3, hask4)

808−-- instance

809−-- ( row ~ Join row1 row2345

810−-- , FromRow row1 hask1

811−-- , FromRow row2345 (hask2, hask3, hask4, hask5)

812−-- , SListI row

813−-- ) => FromRow row (hask1, hask2, hask3, hask4, hask5) where

814−-- fromRow row = case disjoin @row1 @row2345 row of

815−-- (row1, row2345) -> do

816−-- hask1 <- fromRow row1

817−-- (hask2, hask3, hask4, hask5) <- fromRow row2345

818−-- return (hask1, hask2, hask3, hask4, hask5)

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

819348

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

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

@@ -825,24 +354,8 @@ instance

825354-- K (Just "foo") :* Nil

826355--

827356-- >>> fromRow @'["fromOnly" ::: 'Null 'PGtext] @(Only (Maybe Text)) (K (Just "bar") :* Nil)

828−-- Right (Only {fromOnly = Just "bar"})

357+-- Only {fromOnly = Just "bar"}

829358newtype Only x = Only { fromOnly :: x }

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

831360instance Generic (Only x)

832361instance HasDatatypeInfo (Only x)

833−

834−foldlN

835− :: All ((~) x) xs

836− => (z -> x -> z) -> z -> NP I xs -> z

837−foldlN f z = \case

838− Nil -> z

839− I x :* xs -> let z' = f z x in seq z' $ foldlN f z' xs

840−

841−replicateMN

842− :: forall x xs m. (All ((~) x) xs, Monad m, SListI xs)

843− => m x -> m (NP I xs)

844−replicateMN mx = hsequence' $

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

846−

847−getOid :: LibPQ.Oid -> Word32

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

squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+804−29

@@ -9,74 +9,849 @@ Squeal data definition language.

99-}

1010

1111{-# LANGUAGE

12− AllowAmbiguousTypes

13− , ConstraintKinds

14− , DeriveAnyClass

12+ ConstraintKinds

13+ , DataKinds

14+ , DeriveDataTypeable

1515 , DeriveGeneric

16− , DerivingStrategies

1716 , FlexibleContexts

1817 , FlexibleInstances

1918 , GADTs

19+ , GeneralizedNewtypeDeriving

20+ , KindSignatures

2021 , LambdaCase

2122 , MultiParamTypeClasses

22− , OverloadedLabels

2323 , OverloadedStrings

2424 , RankNTypes

2525 , ScopedTypeVariables

26+ , StandaloneDeriving

2627 , TypeApplications

2728 , TypeInType

2829 , TypeOperators

29− , UndecidableSuperClasses

30− , UndecidableInstances

3130#-}

3231

3332module Squeal.PostgreSQL.Definition

34− ( -- * Definition

35− Definition (..)

33+ ( -- * Definition

34+ Definition (UnsafeDefinition, renderDefinition)

3635 , (>>>)

37− , manipDefinition

36+ -- * Create

37+ , createTable

38+ , createTableIfNotExists

39+ , TableConstraintExpression (..)

40+ , check

41+ , unique

42+ , primaryKey

43+ , foreignKey

44+ , ForeignKeyed

45+ , OnDeleteClause (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade)

46+ , renderOnDeleteClause

47+ , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)

48+ , renderOnUpdateClause

49+ -- * Drop

50+ , dropTable

51+ -- * Alter

52+ , alterTable

53+ , alterTableRename

54+ , AlterTable (UnsafeAlterTable, renderAlterTable)

55+ , addConstraint

56+ , dropConstraint

57+ , AddColumn (addColumn)

58+ , dropColumn

59+ , renameColumn

60+ , alterColumn

61+ , AlterColumn (UnsafeAlterColumn, renderAlterColumn)

62+ , setDefault

63+ , dropDefault

64+ , setNotNull

65+ , dropNotNull

66+ , alterType

67+ -- * Views

68+ , createView

69+ , dropView

70+ -- * Types

71+ , createType

72+ , createTypeEnum

73+ , dropType

74+ , ColumnTypeExpression (..)

75+ , notNull

76+ , null'

77+ , default_

78+ , serial2

79+ , smallserial

80+ , serial4

81+ , serial

82+ , serial8

83+ , bigserial

3884 ) where

3985

4086import Control.Category

4187import Control.DeepSeq

4288import Data.ByteString

4389import Data.Monoid

90+import GHC.TypeLits

4491import Prelude hiding ((.), id)

4592

93+import qualified Generics.SOP as SOP

4694import qualified GHC.Generics as GHC

4795

48−import Squeal.PostgreSQL.Manipulation

96+import Squeal.PostgreSQL.Expression

97+import Squeal.PostgreSQL.Query

4998import Squeal.PostgreSQL.Render

5099import Squeal.PostgreSQL.Schema

51100

52−-- $setup

53−-- >>> import Squeal.PostgreSQL

54−

55101{-----------------------------------------

56102statements

57103-----------------------------------------}

58104

59−-- | A `Definition` is a statement that changes the schemas of the

105+-- | A `Definition` is a statement that changes the schema of the

60106-- database, like a `createTable`, `dropTable`, or `alterTable` command.

61107-- `Definition`s may be composed using the `>>>` operator.

62108newtype Definition

63− (schemas0 :: SchemasType)

64− (schemas1 :: SchemasType)

109+ (schema0 :: SchemaType)

110+ (schema1 :: SchemaType)

65111 = UnsafeDefinition { renderDefinition :: ByteString }

66112 deriving (GHC.Generic,Show,Eq,Ord,NFData)

67113

68−instance RenderSQL (Definition schemas0 schemas1) where

69− renderSQL = renderDefinition

70−

71114instance Category Definition where

72115 id = UnsafeDefinition ";"

73116 ddl1 . ddl0 = UnsafeDefinition $

74− renderSQL ddl0 <> "\n" <> renderSQL ddl1

75−

76−-- | A `Manipulation` without input or output can be run as a statement

77−-- along with other `Definition`s, by embedding it using `manipDefinition`.

78−manipDefinition

79− :: Manipulation '[] schemas '[] '[]

80− -- ^ no input or output

81− -> Definition schemas schemas

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

117+ renderDefinition ddl0 <+> renderDefinition ddl1

118+

119+{-----------------------------------------

120+CREATE statements

121+-----------------------------------------}

122+

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

124+--

125+-- >>> :set -XOverloadedLabels

126+-- >>> :{

127+-- renderDefinition $

128+-- createTable #tab ((int & null') `As` #a :* (real & null') `As` #b :* Nil) Nil

129+-- :}

130+-- "CREATE TABLE \"tab\" (\"a\" int NULL, \"b\" real NULL);"

131+createTable

132+ :: ( KnownSymbol table

133+ , columns ~ (col ': cols)

134+ , SOP.SListI columns

135+ , SOP.SListI constraints

136+ , schema1 ~ Create table ('Table (constraints :=> columns)) schema0 )

137+ => Alias table -- ^ the name of the table to add

138+ -> NP (Aliased (ColumnTypeExpression schema0)) columns

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

140+ -> NP (Aliased (TableConstraintExpression schema1 table)) constraints

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

142+ -> Definition schema0 schema1

143+createTable tab columns constraints = UnsafeDefinition $

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

145+

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

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

148+-- `createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in the `Category` `Definition`.

149+--

150+-- >>> :set -XOverloadedLabels -XTypeApplications

151+-- >>> type Table = '[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGfloat4]

152+-- >>> type Schema = '["tab" ::: 'Table Table]

153+-- >>> :{

154+-- renderDefinition

155+-- (createTableIfNotExists #tab ((int & null') `As` #a :* (real & null') `As` #b :* Nil) Nil :: Definition Schema Schema)

156+-- :}

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

158+createTableIfNotExists

159+ :: ( Has table schema ('Table (constraints :=> columns))

160+ , SOP.SListI columns

161+ , SOP.SListI constraints )

162+ => Alias table -- ^ the name of the table to add

163+ -> NP (Aliased (ColumnTypeExpression schema)) columns

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

165+ -> NP (Aliased (TableConstraintExpression schema table)) constraints

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

167+ -> Definition schema schema

168+createTableIfNotExists tab columns constraints = UnsafeDefinition $

169+ "CREATE TABLE IF NOT EXISTS"

170+ <+> renderCreation tab columns constraints

171+

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

173+renderCreation

174+ :: ( KnownSymbol table

175+ , SOP.SListI columns

176+ , SOP.SListI constraints )

177+ => Alias table -- ^ the name of the table to add

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

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

180+ -> NP (Aliased (TableConstraintExpression schema1 table)) constraints

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

182+ -> ByteString

183+renderCreation tab columns constraints = renderAlias tab

184+ <+> parenthesized

185+ ( renderCommaSeparated renderColumnDef columns

186+ <> ( case constraints of

187+ Nil -> ""

188+ _ -> ", " <>

189+ renderCommaSeparated renderConstraint constraints ) )

190+ <> ";"

191+ where

192+ renderColumnDef :: Aliased (ColumnTypeExpression schema) x -> ByteString

193+ renderColumnDef (ty `As` column) =

194+ renderAlias column <+> renderColumnTypeExpression ty

195+ renderConstraint

196+ :: Aliased (TableConstraintExpression schema columns) constraint

197+ -> ByteString

198+ renderConstraint (constraint `As` alias) =

199+ "CONSTRAINT" <+> renderAlias alias <+> renderTableConstraintExpression constraint

200+

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

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

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

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

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

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

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

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

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

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

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

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

213+newtype TableConstraintExpression

214+ (schema :: SchemaType)

215+ (table :: Symbol)

216+ (tableConstraint :: TableConstraint)

217+ = UnsafeTableConstraintExpression

218+ { renderTableConstraintExpression :: ByteString }

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

220+

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

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

223+-- a Boolean (truth-value) expression.

224+--

225+-- >>> :{

226+-- type Schema = '[

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

228+-- "a" ::: 'NoDef :=> 'NotNull 'PGint4,

229+-- "b" ::: 'NoDef :=> 'NotNull 'PGint4

230+-- ])]

231+-- :}

232+--

233+-- >>> :{

234+-- let

235+-- definition :: Definition '[] Schema

236+-- definition = createTable #tab

237+-- ( (int & notNull) `As` #a :*

238+-- (int & notNull) `As` #b :* Nil )

239+-- ( check (#a :* #b :* Nil) (#a .> #b) `As` #inequality :* Nil )

240+-- :}

241+--

242+-- >>> renderDefinition definition

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

244+check

245+ :: ( Has alias schema ('Table table)

246+ , HasAll aliases (TableToColumns table) subcolumns )

247+ => NP Alias aliases

248+ -> (forall tab. Condition '[tab ::: ColumnsToRelation subcolumns] 'Ungrouped '[])

249+ -> TableConstraintExpression schema alias ('Check aliases)

250+check _cols condition = UnsafeTableConstraintExpression $

251+ "CHECK" <+> parenthesized (renderExpression condition)

252+

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

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

255+--

256+-- >>> :{

257+-- type Schema = '[

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

259+-- "a" ::: 'NoDef :=> 'Null 'PGint4,

260+-- "b" ::: 'NoDef :=> 'Null 'PGint4

261+-- ])]

262+-- :}

263+--

264+-- >>> :{

265+-- let

266+-- definition :: Definition '[] Schema

267+-- definition = createTable #tab

268+-- ( (int & null') `As` #a :*

269+-- (int & null') `As` #b :* Nil )

270+-- ( unique (#a :* #b :* Nil) `As` #uq_a_b :* Nil )

271+-- :}

272+--

273+-- >>> renderDefinition definition

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

275+unique

276+ :: ( Has alias schema ('Table table)

277+ , HasAll aliases (TableToColumns table) subcolumns )

278+ => NP Alias aliases

279+ -> TableConstraintExpression schema alias ('Unique aliases)

280+unique columns = UnsafeTableConstraintExpression $

281+ "UNIQUE" <+> parenthesized (commaSeparated (renderAliases columns))

282+

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

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

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

286+--

287+-- >>> :{

288+-- type Schema = '[

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

290+-- "id" ::: 'Def :=> 'NotNull 'PGint4,

291+-- "name" ::: 'NoDef :=> 'NotNull 'PGtext

292+-- ])]

293+-- :}

294+--

295+-- >>> :{

296+-- let

297+-- definition :: Definition '[] Schema

298+-- definition = createTable #tab

299+-- ( serial `As` #id :*

300+-- (text & notNull) `As` #name :* Nil )

301+-- ( primaryKey #id `As` #pk_id :* Nil )

302+-- :}

303+--

304+-- >>> renderDefinition definition

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

306+primaryKey

307+ :: ( Has alias schema ('Table table)

308+ , HasAll aliases (TableToColumns table) subcolumns

309+ , AllNotNull subcolumns )

310+ => NP Alias aliases

311+ -> TableConstraintExpression schema alias ('PrimaryKey aliases)

312+primaryKey columns = UnsafeTableConstraintExpression $

313+ "PRIMARY KEY" <+> parenthesized (commaSeparated (renderAliases columns))

314+

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

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

317+-- another table. We say this maintains the referential integrity

318+-- between two related tables.

319+--

320+-- >>> :{

321+-- type Schema =

322+-- '[ "users" ::: 'Table (

323+-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

324+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4

325+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext

326+-- ])

327+-- , "emails" ::: 'Table (

328+-- '[ "pk_emails" ::: 'PrimaryKey '["id"]

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

330+-- ] :=>

331+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4

332+-- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4

333+-- , "email" ::: 'NoDef :=> 'Null 'PGtext

334+-- ])

335+-- ]

336+-- :}

337+--

338+-- >>> :{

339+-- let

340+-- setup :: Definition '[] Schema

341+-- setup =

342+-- createTable #users

343+-- ( serial `As` #id :*

344+-- (text & notNull) `As` #name :* Nil )

345+-- ( primaryKey #id `As` #pk_users :* Nil ) >>>

346+-- createTable #emails

347+-- ( serial `As` #id :*

348+-- (int & notNull) `As` #user_id :*

349+-- (text & null') `As` #email :* Nil )

350+-- ( primaryKey #id `As` #pk_emails :*

351+-- foreignKey #user_id #users #id

352+-- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )

353+-- in renderDefinition setup

354+-- :}

355+-- "CREATE TABLE \"users\" (\"id\" serial, \"name\" text NOT NULL, CONSTRAINT \"pk_users\" PRIMARY KEY (\"id\")); CREATE TABLE \"emails\" (\"id\" serial, \"user_id\" int NOT NULL, \"email\" text NULL, CONSTRAINT \"pk_emails\" PRIMARY KEY (\"id\"), CONSTRAINT \"fk_user_id\" FOREIGN KEY (\"user_id\") REFERENCES \"users\" (\"id\") ON DELETE CASCADE ON UPDATE CASCADE);"

356+--

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

358+--

359+-- >>> :{

360+-- type Schema =

361+-- '[ "employees" ::: 'Table (

362+-- '[ "employees_pk" ::: 'PrimaryKey '["id"]

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

364+-- ] :=>

365+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4

366+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext

367+-- , "employer_id" ::: 'NoDef :=> 'Null 'PGint4

368+-- ])

369+-- ]

370+-- :}

371+--

372+-- >>> :{

373+-- let

374+-- setup :: Definition '[] Schema

375+-- setup =

376+-- createTable #employees

377+-- ( serial `As` #id :*

378+-- (text & notNull) `As` #name :*

379+-- (integer & null') `As` #employer_id :* Nil )

380+-- ( primaryKey #id `As` #employees_pk :*

381+-- foreignKey #employer_id #employees #id

382+-- OnDeleteCascade OnUpdateCascade `As` #employees_employer_fk :* Nil )

383+-- in renderDefinition setup

384+-- :}

385+-- "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);"

386+--

387+foreignKey

388+ :: (ForeignKeyed schema child parent

389+ table reftable

390+ columns refcolumns

391+ constraints cols

392+ reftys tys )

393+ => NP Alias columns

394+ -- ^ column or columns in the table

395+ -> Alias parent

396+ -- ^ reference table

397+ -> NP Alias refcolumns

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

399+ -> OnDeleteClause

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

401+ -> OnUpdateClause

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

403+ -> TableConstraintExpression schema child

404+ ('ForeignKey columns parent refcolumns)

405+foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $

406+ "FOREIGN KEY" <+> parenthesized (commaSeparated (renderAliases keys))

407+ <+> "REFERENCES" <+> renderAlias parent

408+ <+> parenthesized (commaSeparated (renderAliases refs))

409+ <+> renderOnDeleteClause ondel

410+ <+> renderOnUpdateClause onupd

411+

412+type ForeignKeyed schema

413+ child parent

414+ table reftable

415+ columns refcolumns

416+ constraints cols

417+ reftys tys =

418+ ( Has child schema ('Table table)

419+ , Has parent schema ('Table reftable)

420+ , HasAll columns (TableToColumns table) tys

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

422+ , HasAll refcolumns cols reftys

423+ , SOP.AllZip SamePGType tys reftys

424+ , Uniquely refcolumns constraints )

425+

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

427+data OnDeleteClause

428+ = OnDeleteNoAction

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

430+ -- an error is raised

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

432+ | OnDeleteCascade

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

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

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

436+instance NFData OnDeleteClause

437+

438+-- | Render `OnDeleteClause`.

439+renderOnDeleteClause :: OnDeleteClause -> ByteString

440+renderOnDeleteClause = \case

441+ OnDeleteNoAction -> "ON DELETE NO ACTION"

442+ OnDeleteRestrict -> "ON DELETE RESTRICT"

443+ OnDeleteCascade -> "ON DELETE CASCADE"

444+

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

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

447+data OnUpdateClause

448+ = OnUpdateNoAction

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

450+ -- an error is raised

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

452+ | OnUpdateCascade

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

454+ -- into the referencing row(s)

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

456+instance NFData OnUpdateClause

457+

458+-- | Render `OnUpdateClause`.

459+renderOnUpdateClause :: OnUpdateClause -> ByteString

460+renderOnUpdateClause = \case

461+ OnUpdateNoAction -> "ON UPDATE NO ACTION"

462+ OnUpdateRestrict -> "ON UPDATE RESTRICT"

463+ OnUpdateCascade -> "ON UPDATE CASCADE"

464+

465+{-----------------------------------------

466+DROP statements

467+-----------------------------------------}

468+

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

470+--

471+-- >>> :{

472+-- let

473+-- definition :: Definition '["muh_table" ::: 'Table t] '[]

474+-- definition = dropTable #muh_table

475+-- :}

476+--

477+-- >>> renderDefinition definition

478+-- "DROP TABLE \"muh_table\";"

479+dropTable

480+ :: Has table schema ('Table t)

481+ => Alias table -- ^ table to remove

482+ -> Definition schema (Drop table schema)

483+dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderAlias tab <> ";"

484+

485+{-----------------------------------------

486+ALTER statements

487+-----------------------------------------}

488+

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

490+alterTable

491+ :: KnownSymbol alias

492+ => Alias alias -- ^ table to alter

493+ -> AlterTable alias table schema -- ^ alteration to perform

494+ -> Definition schema (Alter alias ('Table table) schema)

495+alterTable tab alteration = UnsafeDefinition $

496+ "ALTER TABLE"

497+ <+> renderAlias tab

498+ <+> renderAlterTable alteration

499+ <> ";"

500+

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

502+--

503+-- >>> renderDefinition $ alterTableRename #foo #bar

504+-- "ALTER TABLE \"foo\" RENAME TO \"bar\";"

505+alterTableRename

506+ :: (KnownSymbol table0, KnownSymbol table1)

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

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

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

510+alterTableRename table0 table1 = UnsafeDefinition $

511+ "ALTER TABLE" <+> renderAlias table0

512+ <+> "RENAME TO" <+> renderAlias table1 <> ";"

513+

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

515+-- of a table.

516+newtype AlterTable

517+ (alias :: Symbol)

518+ (table :: TableType)

519+ (schema :: SchemaType) =

520+ UnsafeAlterTable {renderAlterTable :: ByteString}

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

522+

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

524+--

525+-- >>> :{

526+-- let

527+-- definition :: Definition

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

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

530+-- definition = alterTable #tab (addConstraint #positive (check (#col :* Nil) (#col .> 0)))

531+-- in renderDefinition definition

532+-- :}

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

534+addConstraint

535+ :: ( KnownSymbol alias

536+ , Has tab schema ('Table table0)

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

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

539+ => Alias alias

540+ -> TableConstraintExpression schema tab constraint

541+ -- ^ constraint to add

542+ -> AlterTable tab table1 schema

543+addConstraint alias constraint = UnsafeAlterTable $

544+ "ADD" <+> "CONSTRAINT" <+> renderAlias alias

545+ <+> renderTableConstraintExpression constraint

546+

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

548+--

549+-- >>> :{

550+-- let

551+-- definition :: Definition

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

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

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

555+-- in renderDefinition definition

556+-- :}

557+-- "ALTER TABLE \"tab\" DROP CONSTRAINT \"positive\";"

558+dropConstraint

559+ :: ( KnownSymbol constraint

560+ , Has tab schema ('Table table0)

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

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

563+ => Alias constraint

564+ -- ^ constraint to drop

565+ -> AlterTable tab table1 schema

566+dropConstraint constraint = UnsafeAlterTable $

567+ "DROP" <+> "CONSTRAINT" <+> renderAlias constraint

568+

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

570+class AddColumn ty where

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

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

573+ --

574+ -- >>> :{

575+ -- let

576+ -- definition :: Definition

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

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

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

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

581+ -- definition = alterTable #tab (addColumn #col2 (text & null' & default_ "foo"))

582+ -- in renderDefinition definition

583+ -- :}

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

585+ --

586+ -- >>> :{

587+ -- let

588+ -- definition :: Definition

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

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

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

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

593+ -- definition = alterTable #tab (addColumn #col2 (text & null'))

594+ -- in renderDefinition definition

595+ -- :}

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

597+ addColumn

598+ :: ( KnownSymbol column

599+ , Has tab schema ('Table table0)

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

601+ , table1 ~ (constraints :=> Create column ty columns) )

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

603+ -> ColumnTypeExpression schema ty -- ^ type of the new column

604+ -> AlterTable tab table1 schema

605+ addColumn column ty = UnsafeAlterTable $

606+ "ADD COLUMN" <+> renderAlias column <+> renderColumnTypeExpression ty

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

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

609+

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

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

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

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

614+--

615+-- >>> :{

616+-- let

617+-- definition :: Definition

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

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

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

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

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

623+-- in renderDefinition definition

624+-- :}

625+-- "ALTER TABLE \"tab\" DROP COLUMN \"col2\";"

626+dropColumn

627+ :: ( KnownSymbol column

628+ , Has tab schema ('Table table0)

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

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

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

632+ -> AlterTable tab table1 schema

633+dropColumn column = UnsafeAlterTable $

634+ "DROP COLUMN" <+> renderAlias column

635+

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

637+--

638+-- >>> :{

639+-- let

640+-- definition :: Definition

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

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

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

644+-- in renderDefinition definition

645+-- :}

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

647+renameColumn

648+ :: ( KnownSymbol column0

649+ , KnownSymbol column1

650+ , Has tab schema ('Table table0)

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

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

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

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

655+ -> AlterTable tab table1 schema

656+renameColumn column0 column1 = UnsafeAlterTable $

657+ "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1

658+

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

660+alterColumn

661+ :: ( KnownSymbol column

662+ , Has tab schema ('Table table0)

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

664+ , Has column columns ty0

665+ , tables1 ~ (constraints :=> Alter column ty1 columns))

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

667+ -> AlterColumn schema ty0 ty1 -- ^ alteration to perform

668+ -> AlterTable tab table1 schema

669+alterColumn column alteration = UnsafeAlterTable $

670+ "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration

671+

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

673+newtype AlterColumn (schema :: SchemaType) (ty0 :: ColumnType) (ty1 :: ColumnType) =

674+ UnsafeAlterColumn {renderAlterColumn :: ByteString}

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

676+

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

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

679+-- future insert and update commands.

680+--

681+-- >>> :{

682+-- let

683+-- definition :: Definition

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

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

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

687+-- in renderDefinition definition

688+-- :}

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

690+setDefault

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

692+ -> AlterColumn schema (constraint :=> ty) ('Def :=> ty)

693+setDefault expression = UnsafeAlterColumn $

694+ "SET DEFAULT" <+> renderExpression expression

695+

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

697+--

698+-- >>> :{

699+-- let

700+-- definition :: Definition

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

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

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

704+-- in renderDefinition definition

705+-- :}

706+-- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" DROP DEFAULT;"

707+dropDefault :: AlterColumn schema ('Def :=> ty) ('NoDef :=> ty)

708+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"

709+

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

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

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

713+--

714+-- >>> :{

715+-- let

716+-- definition :: Definition

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

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

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

720+-- in renderDefinition definition

721+-- :}

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

723+setNotNull

724+ :: AlterColumn schema (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)

725+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"

726+

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

728+--

729+-- >>> :{

730+-- let

731+-- definition :: Definition

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

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

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

735+-- in renderDefinition definition

736+-- :}

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

738+dropNotNull

739+ :: AlterColumn schema (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)

740+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"

741+

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

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

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

745+--

746+-- >>> :{

747+-- let

748+-- definition :: Definition

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

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

751+-- definition =

752+-- alterTable #tab (alterColumn #col (alterType (numeric & notNull)))

753+-- in renderDefinition definition

754+-- :}

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

756+alterType :: ColumnTypeExpression schema ty -> AlterColumn schema ty0 ty

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

758+

759+-- | create a view...

760+-- >>> :{

761+-- let

762+-- definition :: Definition

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

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

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

766+-- definition =

767+-- createView #bc (select (#b `As` #b :* #c `As` #c :* Nil) (from (table (#abc `As` #abc))))

768+-- in renderDefinition definition

769+-- :}

770+-- "CREATE VIEW \"bc\" AS SELECT \"b\" AS \"b\", \"c\" AS \"c\" FROM \"abc\" AS \"abc\";"

771+createView

772+ :: KnownSymbol view

773+ => Alias view -- ^ the name of the table to add

774+ -> Query schema '[] relation

775+ -- ^ query

776+ -> Definition schema (Create view ('View relation) schema)

777+createView alias query = UnsafeDefinition $

778+ "CREATE" <+> "VIEW" <+> renderAlias alias <+> "AS"

779+ <+> renderQuery query <> ";"

780+

781+dropView

782+ :: Has view schema ('View v)

783+ => Alias view -- ^ view to remove

784+ -> Definition schema (Drop view schema)

785+dropView v = UnsafeDefinition $ "DROP VIEW" <+> renderAlias v <> ";"

786+

787+createTypeEnum

788+ :: (KnownSymbol enum, SOP.All KnownSymbol labels)

789+ => Alias enum

790+ -> NP Alias labels

791+ -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema)

792+createTypeEnum enum labels = UnsafeDefinition $

793+ "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+>

794+ parenthesized (commaSeparated (renderAliases labels)) <> ";"

795+

796+createType

797+ :: (KnownSymbol comp, SOP.SListI fields)

798+ => Alias comp

799+ -> NP (Aliased TypeExpression) fields

800+ -> Definition schema (Create comp ('Typedef ('PGcomposite fields)) schema)

801+createType comp fields = UnsafeDefinition $

802+ "CREATE" <+> "TYPE" <+> renderAlias comp <+> "AS" <+> parenthesized

803+ (renderCommaSeparated (renderAliasedAs renderTypeExpression) fields) <> ";"

804+

805+dropType

806+ :: Has tydef schema ('Typedef ty)

807+ => Alias tydef

808+ -> Definition schema (Drop tydef schema)

809+dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderAlias tydef <> ";"

810+

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

812+newtype ColumnTypeExpression (schema :: SchemaType) (ty :: ColumnType)

813+ = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }

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

815+

816+instance (Has alias schema ('Typedef ty))

817+ => IsLabel alias (ColumnTypeExpression schema ('NoDef :=> 'NotNull ty)) where

818+ fromLabel = UnsafeColumnTypeExpression (renderAlias (fromLabel @alias))

819+

820+null'

821+ :: TypeExpression ty

822+ -> ColumnTypeExpression schema ('NoDef :=> 'Null ty)

823+null' ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL"

824+

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

826+-- @NULL@ is not present

827+notNull

828+ :: TypeExpression ty

829+ -> ColumnTypeExpression schema (def :=> 'NotNull ty)

830+notNull ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL"

831+

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

833+default_

834+ :: Expression '[] 'Ungrouped '[] ty

835+ -> ColumnTypeExpression schema ('NoDef :=> ty)

836+ -> ColumnTypeExpression schema ('Def :=> ty)

837+default_ x ty = UnsafeColumnTypeExpression $

838+ renderColumnTypeExpression ty <+> "DEFAULT" <+> renderExpression x

839+

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

841+-- unique identifier columns with type `'PGint2`

842+serial2, smallserial

843+ :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint2)

844+serial2 = UnsafeColumnTypeExpression "serial2"

845+smallserial = UnsafeColumnTypeExpression "smallserial"

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

847+-- unique identifier columns with type `'PGint4`

848+serial4, serial

849+ :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint4)

850+serial4 = UnsafeColumnTypeExpression "serial4"

851+serial = UnsafeColumnTypeExpression "serial"

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

853+-- unique identifier columns with type `'PGint8`

854+serial8, bigserial

855+ :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint8)

856+serial8 = UnsafeColumnTypeExpression "serial8"

857+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+1090−362

@@ -1,17 +1,19 @@

11{-|

2−Module: Squeal.PostgreSQL.Expression

2+Module: Squeal.PostgreSQL.Query

33Description: Squeal expressions

4−Copyright: (c) Eitan Chatav, 2019

4+Copyright: (c) Eitan Chatav, 2017

55Maintainer: eitan@morphism.tech

66Stability: experimental

88Squeal expressions are the atoms used to build statements.

99-}

1010

11+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

1112{-# LANGUAGE

1213 AllowAmbiguousTypes

13− , ConstraintKinds

14+ , DataKinds

1415 , DeriveGeneric

16+ , DeriveDataTypeable

1517 , FlexibleContexts

1618 , FlexibleInstances

1719 , FunctionalDependencies

@@ -20,6 +22,8 @@ Squeal expressions are the atoms used to build statements.

2022 , LambdaCase

2123 , MagicHash

2224 , OverloadedStrings

25+ , PolyKinds

26+ , RankNTypes

2327 , ScopedTypeVariables

2428 , StandaloneDeriving

2529 , TypeApplications

@@ -27,356 +31,383 @@ Squeal expressions are the atoms used to build statements.

2731 , TypeInType

2832 , TypeOperators

2933 , UndecidableInstances

30− , RankNTypes

3134#-}

3235

33−module Squeal.PostgreSQL.Expression

36+module Squeal.PostgreSQL.Expression

3437 ( -- * Expression

35− Expression (..)

36− , Expr

37− , type (-->)

38− , FunctionDB

39− , unsafeFunction

40− , function

41− , unsafeLeftOp

42− , leftOp

43− , unsafeRightOp

44− , rightOp

45− , Operator

46− , OperatorDB

38+ Expression (UnsafeExpression, renderExpression)

39+ , HasParameter (param)

40+ -- ** Null

41+ , null_

42+ , unNull

43+ , coalesce

44+ , fromNull

45+ , isNull

46+ , isn'tNull

47+ , matchNull

48+ , nullIf

49+ -- ** Arrays

50+ , array

51+ -- ** Functions

4752 , unsafeBinaryOp

48− , binaryOp

49− , FunctionVar

50− , unsafeFunctionVar

51− , type (--->)

52− , FunctionNDB

53− , unsafeFunctionN

54− , functionN

55− , PGSubset (..)

56− , PGIntersect (..)

53+ , unsafeUnaryOp

54+ , unsafeFunction

55+ , atan2_

56+ , cast

57+ , quot_

58+ , rem_

59+ , trunc

60+ , round_

61+ , ceiling_

62+ , greatest

63+ , least

64+ -- ** Conditions

65+ , Condition

66+ , true

67+ , false

68+ , not_

69+ , (.&&)

70+ , (.||)

71+ , caseWhenThenElse

72+ , ifThenElse

73+ , (.==)

74+ , (./=)

75+ , (.>=)

76+ , (.<)

77+ , (.<=)

78+ , (.>)

79+ -- ** Time

80+ , currentDate

81+ , currentTime

82+ , currentTimestamp

83+ , localTime

84+ , localTimestamp

85+ -- ** Text

86+ , lower

87+ , upper

88+ , charLength

89+ , like

90+ -- ** Aggregation

91+ , unsafeAggregate, unsafeAggregateDistinct

92+ , sum_, sumDistinct

93+ , PGAvg (avg, avgDistinct)

94+ , bitAnd, bitOr, boolAnd, boolOr

95+ , bitAndDistinct, bitOrDistinct, boolAndDistinct, boolOrDistinct

96+ , countStar

97+ , count, countDistinct

98+ , every, everyDistinct

99+ , max_, maxDistinct, min_, minDistinct

100+ -- * Tables

101+ , Table (UnsafeTable, renderTable)

102+ , View (UnsafeView, renderView)

103+ -- * Types

104+ , TypeExpression (UnsafeTypeExpression, renderTypeExpression)

105+ , PGTyped (pgtype)

106+ , bool

107+ , int2

108+ , smallint

109+ , int4

110+ , int

111+ , integer

112+ , int8

113+ , bigint

114+ , numeric

115+ , float4

116+ , real

117+ , float8

118+ , doublePrecision

119+ , text

120+ , char

121+ , character

122+ , varchar

123+ , characterVarying

124+ , bytea

125+ , timestamp

126+ , timestampWithTimeZone

127+ , date

128+ , time

129+ , timeWithTimeZone

130+ , interval

131+ , uuid

132+ , inet

133+ , json

134+ , jsonb

135+ , vararray

136+ , fixarray

57137 -- * Re-export

58138 , (&)

59− , K (..)

60− , unK

139+ , NP ((:*), Nil)

61140 ) where

62141

63142import Control.Category

64143import Control.DeepSeq

65144import Data.ByteString (ByteString)

66145import Data.Function ((&))

67−import Data.Semigroup hiding (All)

146+import Data.Monoid hiding (All)

147+import Data.Ratio

68148import Data.String

69−import Generics.SOP hiding (All, from)

149+import Generics.SOP hiding (from)

70150import GHC.OverloadedLabels

71151import GHC.TypeLits

72−import Numeric

73152import Prelude hiding (id, (.))

74153

75154import qualified GHC.Generics as GHC

76155

77−import Squeal.PostgreSQL.Alias

78−import Squeal.PostgreSQL.List

79156import Squeal.PostgreSQL.Render

80157import Squeal.PostgreSQL.Schema

81158

82−-- $setup

83−-- >>> import Squeal.PostgreSQL

84−

85159{-----------------------------------------

86160column expressions

87161-----------------------------------------}

88162

89163{- | `Expression`s are used in a variety of contexts,

90−such as in the target `Squeal.PostgreSQL.Query.List` of the

91−`Squeal.PostgreSQL.Query.select` command,

164+such as in the target list of the `Squeal.PostgreSQL.Query.select` command,

92165as new column values in `Squeal.PostgreSQL.Manipulation.insertRow` or

93166`Squeal.PostgreSQL.Manipulation.update`,

94−or in search `Squeal.PostgreSQL.Logic.Condition`s in a number of commands.

167+or in search `Condition`s in a number of commands.

95168

96169The expression syntax allows the calculation of

97170values from primitive expression using arithmetic, logical,

98171and other operations.

99−

100−The type parameters of `Expression` are

101−

102−* @outer :: @ `FromType`, the @from@ clauses of any outer queries in which

103− the `Expression` is a correlated subquery expression;

104−* @commons :: @ `FromType`, the `Squeal.PostgreSQL.Query.CommonTableExpression`s

105− that are in scope for the `Expression`;

106−* @grp :: @ `Grouping`, the `Grouping` of the @from@ clause which may limit

107− which columns may be referenced by alias;

108−* @schemas :: @ `SchemasType`, the schemas of your database that are in

109− scope for the `Expression`;

110−* @from :: @ `FromType`, the @from@ clause which the `Expression` may use

111− to reference columns by alias;

112−* @ty :: @ `NullityType`, the type of the `Expression`.

113172-}

114173newtype Expression

115− (outer :: FromType)

116− (commons :: FromType)

117− (grp :: Grouping)

118− (schemas :: SchemasType)

174+ (relations :: RelationsType)

175+ (grouping :: Grouping)

119176 (params :: [NullityType])

120− (from :: FromType)

121177 (ty :: NullityType)

122178 = UnsafeExpression { renderExpression :: ByteString }

123179 deriving (GHC.Generic,Show,Eq,Ord,NFData)

124−instance RenderSQL (Expression outer commons grp schemas params from ty) where

125− renderSQL = renderExpression

126−

127−-- | An `Expr` is a closed `Expression`.

128−-- It is a F@RankNType@ but don't be scared.

129−-- Think of it as an expression which sees no

130−-- namespaces, so you can't use parameters

131−-- or alias references. It can be used as

132−-- a simple piece of more complex `Expression`s.

133−type Expr x

134− = forall outer commons grp schemas params from

135− . Expression outer commons grp schemas params from x

136− -- ^ cannot reference aliases

137−

138−-- | A @RankNType@ for binary operators.

139−type Operator x1 x2 y

140− = forall outer commons grp schemas params from

141− . Expression outer commons grp schemas params from x1

142− -- ^ left input

143− -> Expression outer commons grp schemas params from x2

144− -- ^ right input

145− -> Expression outer commons grp schemas params from y

146− -- ^ output

147−

148−type OperatorDB schemas x1 x2 y

149− = forall outer commons grp params from

150− . Expression outer commons grp schemas params from x1

151− -- ^ left input

152− -> Expression outer commons grp schemas params from x2

153− -- ^ right input

154− -> Expression outer commons grp schemas params from y

155− -- ^ output

156−

157−-- | A @RankNType@ for functions with a single argument.

158−-- These could be either function calls or unary operators.

159−-- This is a subtype of the usual Haskell function type `Prelude.->`,

160−-- indeed a subcategory as it is closed under the usual

161−-- `Prelude..` and `Prelude.id`.

162−type (-->) x y

163− = forall outer commons grp schemas params from

164− . Expression outer commons grp schemas params from x

165− -- ^ input

166− -> Expression outer commons grp schemas params from y

167− -- ^ output

168−

169−type FunctionDB schemas x y

170− = forall outer commons grp params from

171− . Expression outer commons grp schemas params from x

172− -- ^ input

173− -> Expression outer commons grp schemas params from y

174− -- ^ output

175−

176−{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.

177−Use the `*:` operator to end your argument lists, like so.

178−

179−>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))

180−fun(TRUE, FALSE, LOCALTIME, TRUE)

181−-}

182−type (--->) xs y

183− = forall outer commons grp schemas params from

184− . NP (Expression outer commons grp schemas params from) xs

185− -- ^ inputs

186− -> Expression outer commons grp schemas params from y

187− -- ^ output

188−

189−type FunctionNDB schemas xs y

190− = forall outer commons grp params from

191− . NP (Expression outer commons grp schemas params from) xs

192− -- ^ inputs

193− -> Expression outer commons grp schemas params from y

194− -- ^ output

195−

196−{- | A @RankNType@ for functions with a variable-length list of

197−homogeneous arguments and at least 1 more argument.

198−-}

199−type FunctionVar x0 x1 y

200− = forall outer commons grp schemas params from

201− . [Expression outer commons grp schemas params from x0]

202− -- ^ inputs

203− -> Expression outer commons grp schemas params from x1

204− -- ^ must have at least 1 input

205− -> Expression outer commons grp schemas params from y

206− -- ^ output

207−

208−{- | >>> printSQL (unsafeFunctionVar "greatest" [true, null_] false)

209−greatest(TRUE, NULL, FALSE)

180+

181+{- | A `HasParameter` constraint is used to indicate a value that is

182+supplied externally to a SQL statement.

183+`Squeal.PostgreSQL.PQ.manipulateParams`,

184+`Squeal.PostgreSQL.PQ.queryParams` and

185+`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values

186+separately from the SQL command string, in which case `param`s are used to

187+refer to the out-of-line data values.

210188-}

211−unsafeFunctionVar :: ByteString -> FunctionVar x0 x1 y

212−unsafeFunctionVar fun xs x = UnsafeExpression $ fun <> parenthesized

213− (commaSeparated (renderSQL <$> xs) <> ", " <> renderSQL x)

214−

215−instance (HasUnique tab (Join outer from) row, Has col row ty)

216− => IsLabel col (Expression outer commons 'Ungrouped schemas params from ty) where

217− fromLabel = UnsafeExpression $ renderSQL (Alias @col)

218−instance (HasUnique tab (Join outer from) row, Has col row ty, tys ~ '[ty])

219− => IsLabel col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where

220− fromLabel = fromLabel @col :* Nil

221−instance (HasUnique tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))

222− => IsLabel col

223− (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where

224− fromLabel = fromLabel @col `As` Alias

225−instance (HasUnique tab (Join outer from) row, Has col row ty, columns ~ '[col ::: ty])

226− => IsLabel col

227− (NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns) where

228− fromLabel = fromLabel @col :* Nil

229−

230−instance (Has tab (Join outer from) row, Has col row ty)

231− => IsQualified tab col (Expression outer commons 'Ungrouped schemas params from ty) where

232− tab ! col = UnsafeExpression $

233− renderSQL tab <> "." <> renderSQL col

234−instance (Has tab (Join outer from) row, Has col row ty, tys ~ '[ty])

235− => IsQualified tab col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where

236− tab ! col = tab ! col :* Nil

237−instance (Has tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))

238− => IsQualified tab col

239− (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where

240− tab ! col = tab ! col `As` col

241−instance (Has tab (Join outer from) row, Has col row ty, columns ~ '[col ::: ty])

242− => IsQualified tab col

243− (NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns) where

244− tab ! col = tab ! col :* Nil

189+class (PGTyped (PGTypeOf ty), KnownNat n) => HasParameter

190+ (n :: Nat)

191+ (params :: [NullityType])

192+ (ty :: NullityType)

193+ | n params -> ty where

194+ param :: Expression relations grouping params ty

195+ param = UnsafeExpression $ parenthesized $

196+ "$" <> renderNat (Proxy @n) <+> "::"

197+ <+> renderTypeExpression (pgtype @(PGTypeOf ty))

198+instance {-# OVERLAPPING #-} PGTyped (PGTypeOf ty1)

199+ => HasParameter 1 (ty1:tys) ty1

200+instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)

201+ => HasParameter n (ty' : params) ty

245202

246−instance

247− ( HasUnique tab (Join outer from) row

248− , Has col row ty

249− , GroupedBy tab col bys

250− ) => IsLabel col

251− (Expression outer commons ('Grouped bys) schemas params from ty) where

252− fromLabel = UnsafeExpression $ renderSQL (Alias @col)

253−instance

254− ( HasUnique tab (Join outer from) row

255− , Has col row ty

256− , GroupedBy tab col bys

257− , tys ~ '[ty]

258− ) => IsLabel col

259− (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where

260− fromLabel = fromLabel @col :* Nil

261−instance

262− ( HasUnique tab (Join outer from) row

263− , Has col row ty

264− , GroupedBy tab col bys

265− , column ~ (col ::: ty)

266− ) => IsLabel col

267− (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where

268− fromLabel = fromLabel @col `As` Alias

269−instance

270− ( HasUnique tab (Join outer from) row

271− , Has col row ty

272− , GroupedBy tab col bys

273− , columns ~ '[col ::: ty]

274− ) => IsLabel col

275− (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where

276− fromLabel = fromLabel @col :* Nil

203+instance (HasUnique relation relations columns, Has column columns ty)

204+ => IsLabel column (Expression relations 'Ungrouped params ty) where

205+ fromLabel = UnsafeExpression $ renderAlias (Alias @column)

277206

207+instance (Has relation relations columns, Has column columns ty)

208+ => IsQualified relation column (Expression relations 'Ungrouped params ty) where

209+ relation ! column = UnsafeExpression $

210+ renderAlias relation <> "." <> renderAlias column

211+

278212instance

279− ( Has tab (Join outer from) row

280− , Has col row ty

281− , GroupedBy tab col bys

282− ) => IsQualified tab col

283− (Expression outer commons ('Grouped bys) schemas params from ty) where

284− tab ! col = UnsafeExpression $

285− renderSQL tab <> "." <> renderSQL col

213+ ( HasUnique relation relations columns

214+ , Has column columns ty

215+ , GroupedBy relation column bys

216+ ) => IsLabel column

217+ (Expression relations ('Grouped bys) params ty) where

218+ fromLabel = UnsafeExpression $ renderAlias (Alias @column)

219+

286220instance

287− ( Has tab (Join outer from) row

288− , Has col row ty

289− , GroupedBy tab col bys

290− , tys ~ '[ty]

291− ) => IsQualified tab col

292− (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where

293− tab ! col = tab ! col :* Nil

294−instance

295− ( Has tab (Join outer from) row

296− , Has col row ty

297− , GroupedBy tab col bys

298− , column ~ (col ::: ty)

299− ) => IsQualified tab col

300− (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where

301− tab ! col = tab ! col `As` col

302−instance

303− ( Has tab (Join outer from) row

304− , Has col row ty

305− , GroupedBy tab col bys

306− , columns ~ '[col ::: ty]

307− ) => IsQualified tab col

308− (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where

309− tab ! col = tab ! col :* Nil

310−

311−instance (KnownSymbol label, label `In` labels) => IsPGlabel label

312− (Expression outer commons grp schemas params from (null ('PGenum labels))) where

313− label = UnsafeExpression $ renderSQL (PGlabel @label)

314−

315−-- | >>> printSQL $ unsafeBinaryOp "OR" true false

316−-- (TRUE OR FALSE)

317−unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2

221+ ( Has relation relations columns

222+ , Has column columns ty

223+ , GroupedBy relation column bys

224+ ) => IsQualified relation column

225+ (Expression relations ('Grouped bys) params ty) where

226+ relation ! column = UnsafeExpression $

227+ renderAlias relation <> "." <> renderAlias column

228+

229+-- | analagous to `Nothing`

230+--

231+-- >>> renderExpression $ null_

232+-- "NULL"

233+null_ :: Expression relations grouping params ('Null ty)

234+null_ = UnsafeExpression "NULL"

235+

236+-- | analagous to `Just`

237+--

238+-- >>> renderExpression $ unNull true

239+-- "TRUE"

240+unNull

241+ :: Expression relations grouping params ('NotNull ty)

242+ -- ^ not @NULL@

243+ -> Expression relations grouping params ('Null ty)

244+unNull = UnsafeExpression . renderExpression

245+

246+-- | return the leftmost value which is not NULL

247+--

248+-- >>> renderExpression $ coalesce [null_, unNull true] false

249+-- "COALESCE(NULL, TRUE, FALSE)"

250+coalesce

251+ :: [Expression relations grouping params ('Null ty)]

252+ -- ^ @NULL@s may be present

253+ -> Expression relations grouping params ('NotNull ty)

254+ -- ^ @NULL@ is absent

255+ -> Expression relations grouping params ('NotNull ty)

256+coalesce nullxs notNullx = UnsafeExpression $

257+ "COALESCE" <> parenthesized (commaSeparated

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

259+

260+-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@

261+--

262+-- >>> renderExpression $ fromNull true null_

263+-- "COALESCE(NULL, TRUE)"

264+fromNull

265+ :: Expression relations grouping params ('NotNull ty)

266+ -- ^ what to convert @NULL@ to

267+ -> Expression relations grouping params ('Null ty)

268+ -> Expression relations grouping params ('NotNull ty)

269+fromNull notNullx nullx = coalesce [nullx] notNullx

270+

271+-- | >>> renderExpression $ null_ & isNull

272+-- "NULL IS NULL"

273+isNull

274+ :: Expression relations grouping params ('Null ty)

275+ -- ^ possibly @NULL@

276+ -> Condition relations grouping params

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

278+

279+-- | >>> renderExpression $ null_ & isn'tNull

280+-- "NULL IS NOT NULL"

281+isn'tNull

282+ :: Expression relations grouping params ('Null ty)

283+ -- ^ possibly @NULL@

284+ -> Condition relations grouping params

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

286+

287+-- | analagous to `maybe` using @IS NULL@

288+--

289+-- >>> renderExpression $ matchNull true not_ null_

290+-- "CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END"

291+matchNull

292+ :: Expression relations grouping params (nullty)

293+ -- ^ what to convert @NULL@ to

294+ -> ( Expression relations grouping params ('NotNull ty)

295+ -> Expression relations grouping params (nullty) )

296+ -- ^ function to perform when @NULL@ is absent

297+ -> Expression relations grouping params ('Null ty)

298+ -> Expression relations grouping params (nullty)

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

300+ (f (UnsafeExpression (renderExpression x)))

301+

302+-- | right inverse to `fromNull`, if its arguments are equal then

303+-- `nullIf` gives @NULL@.

304+--

305+-- >>> :set -XTypeApplications -XDataKinds

306+-- >>> renderExpression @_ @_ @'[_] $ fromNull false (nullIf false (param @1))

307+-- "COALESCE(NULL IF (FALSE, ($1 :: bool)), FALSE)"

308+nullIf

309+ :: Expression relations grouping params ('NotNull ty)

310+ -- ^ @NULL@ is absent

311+ -> Expression relations grouping params ('NotNull ty)

312+ -- ^ @NULL@ is absent

313+ -> Expression relations grouping params ('Null ty)

314+nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized

315+ (renderExpression x <> ", " <> renderExpression y)

316+

317+-- | >>> renderExpression $ array [null_, unNull false, unNull true]

318+-- "ARRAY[NULL, FALSE, TRUE]"

319+array

320+ :: [Expression relations grouping params ('Null ty)]

321+ -- ^ array elements

322+ -> Expression relations grouping params (nullity ('PGvararray ty))

323+array xs = UnsafeExpression $

324+ "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]"

325+

326+label

327+ :: (KnownSymbol label, label `In` labels)

328+ => Alias label

329+ -> Expression relations grouping params (nullity ('PGenum labels))

330+label (_ :: Alias label) = UnsafeExpression $

331+ fromString $ symbolVal (Proxy @label)

332+

333+type family Nulls tys where

334+ Nulls '[] = '[]

335+ Nulls (field ::: ty ': tys) = field ::: 'Null ty ': Nulls tys

336+

337+row

338+ :: (SListI (Nulls fields))

339+ => NP (Aliased (Expression relation grouping params)) (Nulls fields)

340+ -> Expression relation grouping params (nullity ('PGcomposite fields))

341+row exprs = UnsafeExpression $ "ROW" <> parenthesized

342+ (renderCommaSeparated (\ (expr `As` _) -> renderExpression expr) exprs)

343+

344+instance Has field fields ty => IsLabel field

345+ ( Expression relation grouping params (nullity ('PGcomposite fields))

346+ -> Expression relation grouping params ('Null ty) ) where

347+ fromLabel expr = UnsafeExpression $

348+ parenthesized (renderExpression expr) <> "." <>

349+ fromString (symbolVal (Proxy @field))

350+

351+instance Monoid

352+ (Expression relations grouping params (nullity ('PGvararray ty))) where

353+ mempty = array []

354+ mappend = unsafeBinaryOp "||"

355+

356+-- | >>> renderExpression @_ @_ @'[_] $ greatest currentTimestamp [param @1]

357+-- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))"

358+greatest

359+ :: Expression relations grouping params (nullty)

360+ -- ^ needs at least 1 argument

361+ -> [Expression relations grouping params (nullty)]

362+ -- ^ or more

363+ -> Expression relations grouping params (nullty)

364+greatest x xs = UnsafeExpression $ "GREATEST("

365+ <> commaSeparated (renderExpression <$> (x:xs)) <> ")"

366+

367+-- | >>> renderExpression $ least currentTimestamp [null_]

368+-- "LEAST(CURRENT_TIMESTAMP, NULL)"

369+least

370+ :: Expression relations grouping params (nullty)

371+ -- ^ needs at least 1 argument

372+ -> [Expression relations grouping params (nullty)]

373+ -- ^ or more

374+ -> Expression relations grouping params (nullty)

375+least x xs = UnsafeExpression $ "LEAST("

376+ <> commaSeparated (renderExpression <$> (x:xs)) <> ")"

377+

378+-- | >>> renderExpression $ unsafeBinaryOp "OR" true false

379+-- "(TRUE OR FALSE)"

380+unsafeBinaryOp

381+ :: ByteString

382+ -- ^ operator

383+ -> Expression relations grouping params (ty0)

384+ -> Expression relations grouping params (ty1)

385+ -> Expression relations grouping params (ty2)

318386unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $

319− renderSQL x <+> op <+> renderSQL y

320−

321−binaryOp

322− :: forall op sch schemas schema x y z.

323− ( Has sch schemas schema

324− , Has op schema ('Operator ('BinaryOp x y z)) )

325− => OperatorDB schemas x y z

326−binaryOp = unsafeBinaryOp $ renderSymbol @op

327−

328−-- | >>> printSQL $ unsafeLeftOp "NOT" true

329−-- (NOT TRUE)

330−unsafeLeftOp :: ByteString -> x --> y

331−unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x

332−

333−leftOp

334− :: forall op sch schemas schema x y.

335− ( Has sch schemas schema

336− , Has op schema ('Operator ('LeftOp x y)) )

337− => FunctionDB schemas x y

338−leftOp = unsafeLeftOp $ renderSymbol @op

339−

340−-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE"

341−-- (TRUE IS NOT TRUE)

342−unsafeRightOp :: ByteString -> x --> y

343−unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op

344−

345−rightOp

346− :: forall op sch schemas schema x y.

347− ( Has sch schemas schema

348− , Has op schema ('Operator ('RightOp x y)) )

349− => FunctionDB schemas x y

350−rightOp = unsafeRightOp $ renderSymbol @op

351−

352−-- | >>> printSQL $ unsafeFunction "f" true

353−-- f(TRUE)

354−unsafeFunction :: ByteString -> x --> y

387+ renderExpression x <+> op <+> renderExpression y

388+

389+-- | >>> renderExpression $ unsafeUnaryOp "NOT" true

390+-- "(NOT TRUE)"

391+unsafeUnaryOp

392+ :: ByteString

393+ -- ^ operator

394+ -> Expression relations grouping params (ty0)

395+ -> Expression relations grouping params (ty1)

396+unsafeUnaryOp op x = UnsafeExpression $ parenthesized $

397+ op <+> renderExpression x

398+

399+-- | >>> renderExpression $ unsafeFunction "f" true

400+-- "f(TRUE)"

401+unsafeFunction

402+ :: ByteString

403+ -- ^ function

404+ -> Expression relations grouping params (xty)

405+ -> Expression relations grouping params (yty)

355406unsafeFunction fun x = UnsafeExpression $

356− fun <> parenthesized (renderSQL x)

357−

358−function

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

360− => QualifiedAlias sch fun

361− -> FunctionDB schemas x y

362−function = unsafeFunction . renderSQL

363−

364−-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')

365−-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')

366−unsafeFunctionN :: SListI xs => ByteString -> xs ---> y

367−unsafeFunctionN fun xs = UnsafeExpression $

368− fun <> parenthesized (renderCommaSeparated renderSQL xs)

369−

370−functionN

371− :: ( Has sch schemas schema

372− , Has fun schema ('Function (xs :=> 'Returns y))

373− , SListI xs )

374− => QualifiedAlias sch fun

375− -> FunctionNDB schemas xs y

376−functionN = unsafeFunctionN . renderSQL

377−

378−instance ty `In` PGNum

379− => Num (Expression outer commons grp schemas params from (null ty)) where

407+ fun <> parenthesized (renderExpression x)

408+

409+instance PGNum ty

410+ => Num (Expression relations grouping params (nullity ty)) where

380411 (+) = unsafeBinaryOp "+"

381412 (-) = unsafeBinaryOp "-"

382413 (*) = unsafeBinaryOp "*"

@@ -387,24 +418,19 @@ instance ty `In` PGNum

387418 . fromString

388419 . show

389420

390−instance (ty `In` PGNum, ty `In` PGFloating) => Fractional

391− (Expression outer commons grp schemas params from (null ty)) where

421+instance (PGNum ty, PGFloating ty) => Fractional

422+ (Expression relations grouping params (nullity ty)) where

392423 (/) = unsafeBinaryOp "/"

393− fromRational

394− = UnsafeExpression

395− . fromString

396− . ($ "")

397− . showFFloat Nothing

398− . fromRat @Double

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

399425

400−instance (ty `In` PGNum, ty `In` PGFloating) => Floating

401− (Expression outer commons grp schemas params from (null ty)) where

426+instance (PGNum ty, PGFloating ty) => Floating

427+ (Expression relations grouping params (nullity ty)) where

402428 pi = UnsafeExpression "pi()"

403429 exp = unsafeFunction "exp"

404430 log = unsafeFunction "ln"

405431 sqrt = unsafeFunction "sqrt"

406432 b ** x = UnsafeExpression $

407− "power(" <> renderSQL b <> ", " <> renderSQL x <> ")"

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

408434 logBase b y = log y / log b

409435 sin = unsafeFunction "sin"

410436 cos = unsafeFunction "cos"

@@ -419,54 +445,756 @@ instance (ty `In` PGNum, ty `In` PGFloating) => Floating

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

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

421447

422−-- | Contained by operators

423−class PGSubset ty where

424− (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

425− (@>) = unsafeBinaryOp "@>"

426− (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

427− (<@) = unsafeBinaryOp "<@"

428−instance PGSubset 'PGjsonb

429−instance PGSubset 'PGtsquery

430−instance PGSubset ('PGvararray ty)

431−instance PGSubset ('PGrange ty)

432−

433−class PGIntersect ty where

434− (@&&) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

435− (@&&) = unsafeBinaryOp "&&"

436−instance PGIntersect ('PGvararray ty)

437−instance PGIntersect ('PGrange ty)

448+-- | >>> :{

449+-- let

450+-- expression :: Expression relations grouping params (nullity 'PGfloat4)

451+-- expression = atan2_ pi 2

452+-- in renderExpression expression

453+-- :}

454+-- "atan2(pi(), 2)"

455+atan2_

456+ :: PGFloating float

457+ => Expression relations grouping params (nullity float)

458+ -- ^ numerator

459+ -> Expression relations grouping params (nullity float)

460+ -- ^ denominator

461+ -> Expression relations grouping params (nullity float)

462+atan2_ y x = UnsafeExpression $

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

464+

465+-- When a `cast` is applied to an `Expression` of a known type, it

466+-- represents a run-time type conversion. The cast will succeed only if a

467+-- suitable type conversion operation has been defined.

468+--

469+-- | >>> renderExpression $ true & cast int4

470+-- "(TRUE :: int4)"

471+cast

472+ :: TypeExpression ty1

473+ -- ^ type to cast as

474+ -> Expression relations grouping params (nullity ty0)

475+ -- ^ value to convert

476+ -> Expression relations grouping params (nullity ty1)

477+cast ty x = UnsafeExpression $ parenthesized $

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

479+

480+-- | integer division, truncates the result

481+--

482+-- >>> :{

483+-- let

484+-- expression :: Expression relations grouping params (nullity 'PGint2)

485+-- expression = 5 `quot_` 2

486+-- in renderExpression expression

487+-- :}

488+-- "(5 / 2)"

489+quot_

490+ :: PGIntegral int

491+ => Expression relations grouping params (nullity int)

492+ -- ^ numerator

493+ -> Expression relations grouping params (nullity int)

494+ -- ^ denominator

495+ -> Expression relations grouping params (nullity int)

496+quot_ = unsafeBinaryOp "/"

497+

498+-- | remainder upon integer division

499+--

500+-- >>> :{

501+-- let

502+-- expression :: Expression relations grouping params (nullity 'PGint2)

503+-- expression = 5 `rem_` 2

504+-- in renderExpression expression

505+-- :}

506+-- "(5 % 2)"

507+rem_

508+ :: PGIntegral int

509+ => Expression relations grouping params (nullity int)

510+ -- ^ numerator

511+ -> Expression relations grouping params (nullity int)

512+ -- ^ denominator

513+ -> Expression relations grouping params (nullity int)

514+rem_ = unsafeBinaryOp "%"

515+

516+-- | >>> :{

517+-- let

518+-- expression :: Expression relations grouping params (nullity 'PGfloat4)

519+-- expression = trunc pi

520+-- in renderExpression expression

521+-- :}

522+-- "trunc(pi())"

523+trunc

524+ :: PGFloating frac

525+ => Expression relations grouping params (nullity frac)

526+ -- ^ fractional number

527+ -> Expression relations grouping params (nullity frac)

528+trunc = unsafeFunction "trunc"

529+

530+-- | >>> :{

531+-- let

532+-- expression :: Expression relations grouping params (nullity 'PGfloat4)

533+-- expression = round_ pi

534+-- in renderExpression expression

535+-- :}

536+-- "round(pi())"

537+round_

538+ :: PGFloating frac

539+ => Expression relations grouping params (nullity frac)

540+ -- ^ fractional number

541+ -> Expression relations grouping params (nullity frac)

542+round_ = unsafeFunction "round"

543+

544+-- | >>> :{

545+-- let

546+-- expression :: Expression relations grouping params (nullity 'PGfloat4)

547+-- expression = ceiling_ pi

548+-- in renderExpression expression

549+-- :}

550+-- "ceiling(pi())"

551+ceiling_

552+ :: PGFloating frac

553+ => Expression relations grouping params (nullity frac)

554+ -- ^ fractional number

555+ -> Expression relations grouping params (nullity frac)

556+ceiling_ = unsafeFunction "ceiling"

557+

558+-- | A `Condition` is a boolean valued `Expression`. While SQL allows

559+-- conditions to have @NULL@, Squeal instead chooses to disallow @NULL@,

560+-- forcing one to handle the case of @NULL@ explicitly to produce

561+-- a `Condition`.

562+type Condition relations grouping params =

563+ Expression relations grouping params ('NotNull 'PGbool)

564+

565+-- | >>> renderExpression true

566+-- "TRUE"

567+true :: Condition relations grouping params

568+true = UnsafeExpression "TRUE"

569+

570+-- | >>> renderExpression false

571+-- "FALSE"

572+false :: Condition relations grouping params

573+false = UnsafeExpression "FALSE"

574+

575+-- | >>> renderExpression $ not_ true

576+-- "(NOT TRUE)"

577+not_

578+ :: Condition relations grouping params

579+ -> Condition relations grouping params

580+not_ = unsafeUnaryOp "NOT"

581+

582+-- | >>> renderExpression $ true .&& false

583+-- "(TRUE AND FALSE)"

584+(.&&)

585+ :: Condition relations grouping params

586+ -> Condition relations grouping params

587+ -> Condition relations grouping params

588+(.&&) = unsafeBinaryOp "AND"

589+

590+-- | >>> renderExpression $ true .|| false

591+-- "(TRUE OR FALSE)"

592+(.||)

593+ :: Condition relations grouping params

594+ -> Condition relations grouping params

595+ -> Condition relations grouping params

596+(.||) = unsafeBinaryOp "OR"

597+

598+-- | >>> :{

599+-- let

600+-- expression :: Expression relations grouping params (nullity 'PGint2)

601+-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3

602+-- in renderExpression expression

603+-- :}

604+-- "CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END"

605+caseWhenThenElse

606+ :: [ ( Condition relations grouping params

607+ , Expression relations grouping params (ty)

608+ ) ]

609+ -- ^ whens and thens

610+ -> Expression relations grouping params (ty)

611+ -- ^ else

612+ -> Expression relations grouping params (ty)

613+caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat

614+ [ "CASE"

615+ , mconcat

616+ [ mconcat

617+ [ " WHEN ", renderExpression when_

618+ , " THEN ", renderExpression then_

619+ ]

620+ | (when_,then_) <- whenThens

621+ ]

622+ , " ELSE ", renderExpression else_

623+ , " END"

624+ ]

625+

626+-- | >>> :{

627+-- let

628+-- expression :: Expression relations grouping params (nullity 'PGint2)

629+-- expression = ifThenElse true 1 0

630+-- in renderExpression expression

631+-- :}

632+-- "CASE WHEN TRUE THEN 1 ELSE 0 END"

633+ifThenElse

634+ :: Condition relations grouping params

635+ -> Expression relations grouping params (ty) -- ^ then

636+ -> Expression relations grouping params (ty) -- ^ else

637+ -> Expression relations grouping params (ty)

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

639+

640+-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`

641+-- will produce @NULL@s if one of their arguments is @NULL@.

642+--

643+-- >>> renderExpression $ unNull true .== null_

644+-- "(TRUE = NULL)"

645+(.==)

646+ :: Expression relations grouping params (nullity ty) -- ^ lhs

647+ -> Expression relations grouping params (nullity ty) -- ^ rhs

648+ -> Expression relations grouping params (nullity 'PGbool)

649+(.==) = unsafeBinaryOp "="

650+infix 4 .==

651+

652+-- | >>> renderExpression $ unNull true ./= null_

653+-- "(TRUE <> NULL)"

654+(./=)

655+ :: Expression relations grouping params (nullity ty) -- ^ lhs

656+ -> Expression relations grouping params (nullity ty) -- ^ rhs

657+ -> Expression relations grouping params (nullity 'PGbool)

658+(./=) = unsafeBinaryOp "<>"

659+infix 4 ./=

660+

661+-- | >>> renderExpression $ unNull true .>= null_

662+-- "(TRUE >= NULL)"

663+(.>=)

664+ :: Expression relations grouping params (nullity ty) -- ^ lhs

665+ -> Expression relations grouping params (nullity ty) -- ^ rhs

666+ -> Expression relations grouping params (nullity 'PGbool)

667+(.>=) = unsafeBinaryOp ">="

668+infix 4 .>=

669+

670+-- | >>> renderExpression $ unNull true .< null_

671+-- "(TRUE < NULL)"

672+(.<)

673+ :: Expression relations grouping params (nullity ty) -- ^ lhs

674+ -> Expression relations grouping params (nullity ty) -- ^ rhs

675+ -> Expression relations grouping params (nullity 'PGbool)

676+(.<) = unsafeBinaryOp "<"

677+infix 4 .<

678+

679+-- | >>> renderExpression $ unNull true .<= null_

680+-- "(TRUE <= NULL)"

681+(.<=)

682+ :: Expression relations grouping params (nullity ty) -- ^ lhs

683+ -> Expression relations grouping params (nullity ty) -- ^ rhs

684+ -> Expression relations grouping params (nullity 'PGbool)

685+(.<=) = unsafeBinaryOp "<="

686+infix 4 .<=

687+

688+-- | >>> renderExpression $ unNull true .> null_

689+-- "(TRUE > NULL)"

690+(.>)

691+ :: Expression relations grouping params (nullity ty) -- ^ lhs

692+ -> Expression relations grouping params (nullity ty) -- ^ rhs

693+ -> Expression relations grouping params (nullity 'PGbool)

694+(.>) = unsafeBinaryOp ">"

695+infix 4 .>

696+

697+-- | >>> renderExpression currentDate

698+-- "CURRENT_DATE"

699+currentDate

700+ :: Expression relations grouping params (nullity 'PGdate)

701+currentDate = UnsafeExpression "CURRENT_DATE"

702+

703+-- | >>> renderExpression currentTime

704+-- "CURRENT_TIME"

705+currentTime

706+ :: Expression relations grouping params (nullity 'PGtimetz)

707+currentTime = UnsafeExpression "CURRENT_TIME"

708+

709+-- | >>> renderExpression currentTimestamp

710+-- "CURRENT_TIMESTAMP"

711+currentTimestamp

712+ :: Expression relations grouping params (nullity 'PGtimestamptz)

713+currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"

714+

715+-- | >>> renderExpression localTime

716+-- "LOCALTIME"

717+localTime

718+ :: Expression relations grouping params (nullity 'PGtime)

719+localTime = UnsafeExpression "LOCALTIME"

720+

721+-- | >>> renderExpression localTimestamp

722+-- "LOCALTIMESTAMP"

723+localTimestamp

724+ :: Expression relations grouping params (nullity 'PGtimestamp)

725+localTimestamp = UnsafeExpression "LOCALTIMESTAMP"

726+

727+{-----------------------------------------

728+text

729+-----------------------------------------}

438730

439731instance IsString

440− (Expression outer commons grp schemas params from (null 'PGtext)) where

732+ (Expression relations grouping params (nullity 'PGtext)) where

441733 fromString str = UnsafeExpression $

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

443−instance IsString

444− (Expression outer commons grp schemas params from (null 'PGtsvector)) where

445− fromString str = UnsafeExpression . parenthesized . (<> " :: tsvector") $

446− "E\'" <> fromString (escape =<< str) <> "\'"

447−instance IsString

448− (Expression outer commons grp schemas params from (null 'PGtsquery)) where

449− fromString str = UnsafeExpression . parenthesized . (<> " :: tsquery") $

450− "E\'" <> fromString (escape =<< str) <> "\'"

451−

452−instance Semigroup

453− (Expression outer commons grp schemas params from (null ('PGvararray ty))) where

454− (<>) = unsafeBinaryOp "||"

455−instance Semigroup

456− (Expression outer commons grp schemas params from (null 'PGjsonb)) where

457− (<>) = unsafeBinaryOp "||"

458−instance Semigroup

459− (Expression outer commons grp schemas params from (null 'PGtext)) where

460− (<>) = unsafeBinaryOp "||"

461−instance Semigroup

462− (Expression outer commons grp schemas params from (null 'PGtsvector)) where

463− (<>) = unsafeBinaryOp "||"

735+ where

736+ escape = \case

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

738+ '\'' -> "''"

739+ '"' -> "\\\""

740+ '\b' -> "\\b"

741+ '\n' -> "\\n"

742+ '\r' -> "\\r"

743+ '\t' -> "\\t"

744+ '\\' -> "\\\\"

745+ c -> [c]

464746

465747instance Monoid

466− (Expression outer commons grp schemas params from (null 'PGtext)) where

748+ (Expression relations grouping params (nullity 'PGtext)) where

467749 mempty = fromString ""

468− mappend = (<>)

469−instance Monoid

470− (Expression outer commons grp schemas params from (null 'PGtsvector)) where

471− mempty = fromString ""

472− mappend = (<>)

750+ mappend = unsafeBinaryOp "||"

751+

752+-- | >>> renderExpression $ lower "ARRRGGG"

753+-- "lower(E'ARRRGGG')"

754+lower

755+ :: Expression relations grouping params (nullity 'PGtext)

756+ -- ^ string to lower case

757+ -> Expression relations grouping params (nullity 'PGtext)

758+lower = unsafeFunction "lower"

759+

760+-- | >>> renderExpression $ upper "eeee"

761+-- "upper(E'eeee')"

762+upper

763+ :: Expression relations grouping params (nullity 'PGtext)

764+ -- ^ string to upper case

765+ -> Expression relations grouping params (nullity 'PGtext)

766+upper = unsafeFunction "upper"

767+

768+-- | >>> renderExpression $ charLength "four"

769+-- "char_length(E'four')"

770+charLength

771+ :: Expression relations grouping params (nullity 'PGtext)

772+ -- ^ string to measure

773+ -> Expression relations grouping params (nullity 'PGint4)

774+charLength = unsafeFunction "char_length"

775+

776+-- | The `like` expression returns true if the @string@ matches

777+-- the supplied @pattern@. If @pattern@ does not contain percent signs

778+-- or underscores, then the pattern only represents the string itself;

779+-- in that case `like` acts like the equals operator. An underscore (_)

780+-- in pattern stands for (matches) any single character; a percent sign (%)

781+-- matches any sequence of zero or more characters.

782+--

783+-- >>> renderExpression $ "abc" `like` "a%"

784+-- "(E'abc' LIKE E'a%')"

785+like

786+ :: Expression relations grouping params (nullity 'PGtext)

787+ -- ^ string

788+ -> Expression relations grouping params (nullity 'PGtext)

789+ -- ^ pattern

790+ -> Expression relations grouping params (nullity 'PGbool)

791+like = unsafeBinaryOp "LIKE"

792+

793+{-----------------------------------------

794+aggregation

795+-----------------------------------------}

796+

797+-- | escape hatch to define aggregate functions

798+unsafeAggregate

799+ :: ByteString -- ^ aggregate function

800+ -> Expression relations 'Ungrouped params (xty)

801+ -> Expression relations ('Grouped bys) params (yty)

802+unsafeAggregate fun x = UnsafeExpression $ mconcat

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

804+

805+-- | escape hatch to define aggregate functions over distinct values

806+unsafeAggregateDistinct

807+ :: ByteString -- ^ aggregate function

808+ -> Expression relations 'Ungrouped params (xty)

809+ -> Expression relations ('Grouped bys) params (yty)

810+unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat

811+ [fun, "(DISTINCT ", renderExpression x, ")"]

812+

813+-- | >>> :{

814+-- let

815+-- expression :: Expression '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric)

816+-- expression = sum_ #col

817+-- in renderExpression expression

818+-- :}

819+-- "sum(\"col\")"

820+sum_

821+ :: PGNum ty

822+ => Expression relations 'Ungrouped params (nullity ty)

823+ -- ^ what to sum

824+ -> Expression relations ('Grouped bys) params (nullity ty)

825+sum_ = unsafeAggregate "sum"

826+

827+-- | >>> :{

828+-- let

829+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric)

830+-- expression = sumDistinct #col

831+-- in renderExpression expression

832+-- :}

833+-- "sum(DISTINCT \"col\")"

834+sumDistinct

835+ :: PGNum ty

836+ => Expression relations 'Ungrouped params (nullity ty)

837+ -- ^ what to sum

838+ -> Expression relations ('Grouped bys) params (nullity ty)

839+sumDistinct = unsafeAggregateDistinct "sum"

840+

841+-- | A constraint for `PGType`s that you can take averages of and the resulting

842+-- `PGType`.

843+class PGAvg ty avg | ty -> avg where

844+ avg, avgDistinct

845+ :: Expression relations 'Ungrouped params (nullity ty)

846+ -- ^ what to average

847+ -> Expression relations ('Grouped bys) params (nullity avg)

848+ avg = unsafeAggregate "avg"

849+ avgDistinct = unsafeAggregateDistinct "avg"

850+instance PGAvg 'PGint2 'PGnumeric

851+instance PGAvg 'PGint4 'PGnumeric

852+instance PGAvg 'PGint8 'PGnumeric

853+instance PGAvg 'PGnumeric 'PGnumeric

854+instance PGAvg 'PGfloat4 'PGfloat8

855+instance PGAvg 'PGfloat8 'PGfloat8

856+instance PGAvg 'PGinterval 'PGinterval

857+

858+-- | >>> :{

859+-- let

860+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

861+-- expression = bitAnd #col

862+-- in renderExpression expression

863+-- :}

864+-- "bit_and(\"col\")"

865+bitAnd

866+ :: PGIntegral int

867+ => Expression relations 'Ungrouped params (nullity int)

868+ -- ^ what to aggregate

869+ -> Expression relations ('Grouped bys) params (nullity int)

870+bitAnd = unsafeAggregate "bit_and"

871+

872+-- | >>> :{

873+-- let

874+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

875+-- expression = bitOr #col

876+-- in renderExpression expression

877+-- :}

878+-- "bit_or(\"col\")"

879+bitOr

880+ :: PGIntegral int

881+ => Expression relations 'Ungrouped params (nullity int)

882+ -- ^ what to aggregate

883+ -> Expression relations ('Grouped bys) params (nullity int)

884+bitOr = unsafeAggregate "bit_or"

885+

886+-- | >>> :{

887+-- let

888+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

889+-- expression = bitAndDistinct #col

890+-- in renderExpression expression

891+-- :}

892+-- "bit_and(DISTINCT \"col\")"

893+bitAndDistinct

894+ :: PGIntegral int

895+ => Expression relations 'Ungrouped params (nullity int)

896+ -- ^ what to aggregate

897+ -> Expression relations ('Grouped bys) params (nullity int)

898+bitAndDistinct = unsafeAggregateDistinct "bit_and"

899+

900+-- | >>> :{

901+-- let

902+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

903+-- expression = bitOrDistinct #col

904+-- in renderExpression expression

905+-- :}

906+-- "bit_or(DISTINCT \"col\")"

907+bitOrDistinct

908+ :: PGIntegral int

909+ => Expression relations 'Ungrouped params (nullity int)

910+ -- ^ what to aggregate

911+ -> Expression relations ('Grouped bys) params (nullity int)

912+bitOrDistinct = unsafeAggregateDistinct "bit_or"

913+

914+-- | >>> :{

915+-- let

916+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

917+-- expression = boolAnd #col

918+-- in renderExpression expression

919+-- :}

920+-- "bool_and(\"col\")"

921+boolAnd

922+ :: Expression relations 'Ungrouped params (nullity 'PGbool)

923+ -- ^ what to aggregate

924+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)

925+boolAnd = unsafeAggregate "bool_and"

926+

927+-- | >>> :{

928+-- let

929+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

930+-- expression = boolOr #col

931+-- in renderExpression expression

932+-- :}

933+-- "bool_or(\"col\")"

934+boolOr

935+ :: Expression relations 'Ungrouped params (nullity 'PGbool)

936+ -- ^ what to aggregate

937+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)

938+boolOr = unsafeAggregate "bool_or"

939+

940+-- | >>> :{

941+-- let

942+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

943+-- expression = boolAndDistinct #col

944+-- in renderExpression expression

945+-- :}

946+-- "bool_and(DISTINCT \"col\")"

947+boolAndDistinct

948+ :: Expression relations 'Ungrouped params (nullity 'PGbool)

949+ -- ^ what to aggregate

950+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)

951+boolAndDistinct = unsafeAggregateDistinct "bool_and"

952+

953+-- | >>> :{

954+-- let

955+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

956+-- expression = boolOrDistinct #col

957+-- in renderExpression expression

958+-- :}

959+-- "bool_or(DISTINCT \"col\")"

960+boolOrDistinct

961+ :: Expression relations 'Ungrouped params (nullity 'PGbool)

962+ -- ^ what to aggregate

963+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)

964+boolOrDistinct = unsafeAggregateDistinct "bool_or"

965+

966+-- | A special aggregation that does not require an input

967+--

968+-- >>> renderExpression countStar

969+-- "count(*)"

970+countStar

971+ :: Expression relations ('Grouped bys) params ('NotNull 'PGint8)

972+countStar = UnsafeExpression $ "count(*)"

973+

974+-- | >>> :{

975+-- let

976+-- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)

977+-- expression = count #col

978+-- in renderExpression expression

979+-- :}

980+-- "count(\"col\")"

981+count

982+ :: Expression relations 'Ungrouped params ty

983+ -- ^ what to count

984+ -> Expression relations ('Grouped bys) params ('NotNull 'PGint8)

985+count = unsafeAggregate "count"

986+

987+-- | >>> :{

988+-- let

989+-- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)

990+-- expression = countDistinct #col

991+-- in renderExpression expression

992+-- :}

993+-- "count(DISTINCT \"col\")"

994+countDistinct

995+ :: Expression relations 'Ungrouped params ty

996+ -- ^ what to count

997+ -> Expression relations ('Grouped bys) params ('NotNull 'PGint8)

998+countDistinct = unsafeAggregateDistinct "count"

999+

1000+-- | synonym for `boolAnd`

1001+--

1002+-- >>> :{

1003+-- let

1004+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

1005+-- expression = every #col

1006+-- in renderExpression expression

1007+-- :}

1008+-- "every(\"col\")"

1009+every

1010+ :: Expression relations 'Ungrouped params (nullity 'PGbool)

1011+ -- ^ what to aggregate

1012+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)

1013+every = unsafeAggregate "every"

1014+

1015+-- | synonym for `boolAndDistinct`

1016+--

1017+-- >>> :{

1018+-- let

1019+-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

1020+-- expression = everyDistinct #col

1021+-- in renderExpression expression

1022+-- :}

1023+-- "every(DISTINCT \"col\")"

1024+everyDistinct

1025+ :: Expression relations 'Ungrouped params (nullity 'PGbool)

1026+ -- ^ what to aggregate

1027+ -> Expression relations ('Grouped bys) params (nullity 'PGbool)

1028+everyDistinct = unsafeAggregateDistinct "every"

1029+

1030+-- | minimum and maximum aggregation

1031+max_, min_, maxDistinct, minDistinct

1032+ :: Expression relations 'Ungrouped params (nullity ty)

1033+ -- ^ what to aggregate

1034+ -> Expression relations ('Grouped bys) params (nullity ty)

1035+max_ = unsafeAggregate "max"

1036+min_ = unsafeAggregate "min"

1037+maxDistinct = unsafeAggregateDistinct "max"

1038+minDistinct = unsafeAggregateDistinct "min"

1039+

1040+{-----------------------------------------

1041+tables

1042+-----------------------------------------}

1043+

1044+-- | A `Table` from a table expression is a way

1045+-- to call a table reference by its alias.

1046+newtype Table

1047+ (schema :: SchemaType)

1048+ (columns :: RelationType)

1049+ = UnsafeTable { renderTable :: ByteString }

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

1051+instance

1052+ ( Has alias schema ('Table table)

1053+ , relation ~ ColumnsToRelation (TableToColumns table)

1054+ ) => IsLabel alias (Table schema relation) where

1055+ fromLabel = UnsafeTable $ renderAlias (Alias @alias)

1056+

1057+-- | A `View` from a table expression is a way

1058+-- to call a table reference by its alias.

1059+newtype View

1060+ (schema :: SchemaType)

1061+ (columns :: RelationType)

1062+ = UnsafeView { renderView :: ByteString }

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

1064+instance

1065+ ( Has alias schema ('View columns)

1066+ ) => IsLabel alias (View schema columns) where

1067+ fromLabel = UnsafeView $ renderAlias (Alias @alias)

1068+

1069+{-----------------------------------------

1070+type expressions

1071+-----------------------------------------}

1072+

1073+-- | `TypeExpression`s are used in `cast`s and `createTable` commands.

1074+newtype TypeExpression (ty :: PGType)

1075+ = UnsafeTypeExpression { renderTypeExpression :: ByteString }

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

1077+

1078+-- | logical Boolean (true/false)

1079+bool :: TypeExpression 'PGbool

1080+bool = UnsafeTypeExpression "bool"

1081+-- | signed two-byte integer

1082+int2, smallint :: TypeExpression 'PGint2

1083+int2 = UnsafeTypeExpression "int2"

1084+smallint = UnsafeTypeExpression "smallint"

1085+-- | signed four-byte integer

1086+int4, int, integer :: TypeExpression 'PGint4

1087+int4 = UnsafeTypeExpression "int4"

1088+int = UnsafeTypeExpression "int"

1089+integer = UnsafeTypeExpression "integer"

1090+-- | signed eight-byte integer

1091+int8, bigint :: TypeExpression 'PGint8

1092+int8 = UnsafeTypeExpression "int8"

1093+bigint = UnsafeTypeExpression "bigint"

1094+-- | arbitrary precision numeric type

1095+numeric :: TypeExpression 'PGnumeric

1096+numeric = UnsafeTypeExpression "numeric"

1097+-- | single precision floating-point number (4 bytes)

1098+float4, real :: TypeExpression 'PGfloat4

1099+float4 = UnsafeTypeExpression "float4"

1100+real = UnsafeTypeExpression "real"

1101+-- | double precision floating-point number (8 bytes)

1102+float8, doublePrecision :: TypeExpression 'PGfloat8

1103+float8 = UnsafeTypeExpression "float8"

1104+doublePrecision = UnsafeTypeExpression "double precision"

1105+-- | variable-length character string

1106+text :: TypeExpression 'PGtext

1107+text = UnsafeTypeExpression "text"

1108+-- | fixed-length character string

1109+char, character

1110+ :: (KnownNat n, 1 <= n)

1111+ => proxy n

1112+ -> TypeExpression ('PGchar n)

1113+char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"

1114+character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"

1115+-- | variable-length character string

1116+varchar, characterVarying

1117+ :: (KnownNat n, 1 <= n)

1118+ => proxy n

1119+ -> TypeExpression ('PGvarchar n)

1120+varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"

1121+characterVarying p = UnsafeTypeExpression $

1122+ "character varying(" <> renderNat p <> ")"

1123+-- | binary data ("byte array")

1124+bytea :: TypeExpression 'PGbytea

1125+bytea = UnsafeTypeExpression "bytea"

1126+-- | date and time (no time zone)

1127+timestamp :: TypeExpression 'PGtimestamp

1128+timestamp = UnsafeTypeExpression "timestamp"

1129+-- | date and time, including time zone

1130+timestampWithTimeZone :: TypeExpression 'PGtimestamptz

1131+timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

1132+-- | calendar date (year, month, day)

1133+date :: TypeExpression 'PGdate

1134+date = UnsafeTypeExpression "date"

1135+-- | time of day (no time zone)

1136+time :: TypeExpression 'PGtime

1137+time = UnsafeTypeExpression "time"

1138+-- | time of day, including time zone

1139+timeWithTimeZone :: TypeExpression 'PGtimetz

1140+timeWithTimeZone = UnsafeTypeExpression "time with time zone"

1141+-- | time span

1142+interval :: TypeExpression 'PGinterval

1143+interval = UnsafeTypeExpression "interval"

1144+-- | universally unique identifier

1145+uuid :: TypeExpression 'PGuuid

1146+uuid = UnsafeTypeExpression "uuid"

1147+-- | IPv4 or IPv6 host address

1148+inet :: TypeExpression 'PGinet

1149+inet = UnsafeTypeExpression "inet"

1150+-- | textual JSON data

1151+json :: TypeExpression 'PGjson

1152+json = UnsafeTypeExpression "json"

1153+-- | binary JSON data, decomposed

1154+jsonb :: TypeExpression 'PGjsonb

1155+jsonb = UnsafeTypeExpression "jsonb"

1156+-- | variable length array

1157+vararray

1158+ :: TypeExpression pg

1159+ -> TypeExpression ('PGvararray pg)

1160+vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"

1161+-- | fixed length array

1162+--

1163+-- >>> renderTypeExpression (fixarray (Proxy @2) json)

1164+-- "json[2]"

1165+fixarray

1166+ :: KnownNat n

1167+ => proxy n

1168+ -> TypeExpression pg

1169+ -> TypeExpression ('PGfixarray n pg)

1170+fixarray p ty = UnsafeTypeExpression $

1171+ renderTypeExpression ty <> "[" <> renderNat p <> "]"

1172+

1173+-- | `pgtype` is a demoted version of a `PGType`

1174+class PGTyped (ty :: PGType) where pgtype :: TypeExpression ty

1175+instance PGTyped 'PGbool where pgtype = bool

1176+instance PGTyped 'PGint2 where pgtype = int2

1177+instance PGTyped 'PGint4 where pgtype = int4

1178+instance PGTyped 'PGint8 where pgtype = int8

1179+instance PGTyped 'PGnumeric where pgtype = numeric

1180+instance PGTyped 'PGfloat4 where pgtype = float4

1181+instance PGTyped 'PGfloat8 where pgtype = float8

1182+instance PGTyped 'PGtext where pgtype = text

1183+instance (KnownNat n, 1 <= n)

1184+ => PGTyped ('PGchar n) where pgtype = char (Proxy @n)

1185+instance (KnownNat n, 1 <= n)

1186+ => PGTyped ('PGvarchar n) where pgtype = varchar (Proxy @n)

1187+instance PGTyped 'PGbytea where pgtype = bytea

1188+instance PGTyped 'PGtimestamp where pgtype = timestamp

1189+instance PGTyped 'PGtimestamptz where pgtype = timestampWithTimeZone

1190+instance PGTyped 'PGdate where pgtype = date

1191+instance PGTyped 'PGtime where pgtype = time

1192+instance PGTyped 'PGtimetz where pgtype = timeWithTimeZone

1193+instance PGTyped 'PGinterval where pgtype = interval

1194+instance PGTyped 'PGuuid where pgtype = uuid

1195+instance PGTyped 'PGjson where pgtype = json

1196+instance PGTyped 'PGjsonb where pgtype = jsonb

1197+instance PGTyped ty => PGTyped ('PGvararray ty) where

1198+ pgtype = vararray (pgtype @ty)

1199+instance (KnownNat n, PGTyped ty) => PGTyped ('PGfixarray n ty) where

1200+ pgtype = fixarray (Proxy @n) (pgtype @ty)

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hsdeleted−462

@@ -1,462 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.Aggregate

3−Description: Aggregate functions

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Aggregate functions

9−-}

10−

11−{-# LANGUAGE

12− DataKinds

13− , DeriveGeneric

14− , FlexibleContexts

15− , FlexibleInstances

16− , FunctionalDependencies

17− , LambdaCase

18− , MultiParamTypeClasses

19− , OverloadedStrings

20− , PolyKinds

21− , TypeFamilies

22− , TypeOperators

23− , UndecidableInstances

24−#-}

25−

26−module Squeal.PostgreSQL.Expression.Aggregate

27− ( Aggregate (..)

28− , Distinction (..)

29− , PGSum

30− , PGAvg

31− ) where

32−

33−import Control.DeepSeq

34−import Data.ByteString (ByteString)

35−import Data.Kind

36−import GHC.TypeLits

37−

38−import qualified GHC.Generics as GHC

39−import qualified Generics.SOP as SOP

40−

41−import Squeal.PostgreSQL.Alias

42−import Squeal.PostgreSQL.Expression

43−import Squeal.PostgreSQL.List

44−import Squeal.PostgreSQL.Render

45−import Squeal.PostgreSQL.Schema

46−

47−-- $setup

48−-- >>> import Squeal.PostgreSQL

49−

50−{- |

51−`Aggregate` functions compute a single result from a set of input values.

52−`Aggregate` functions can be used as `GroupedBy` `Expression`s as well

53−as `Squeal.PostgreSQL.Expression.Window.WindowFunction`s.

54−-}

55−class Aggregate expr1 exprN aggr

56− | aggr -> expr1, aggr -> exprN where

57−

58− -- | A special aggregation that does not require an input

59− --

60− -- >>> :{

61− -- let

62− -- expression :: Expression '[] commons ('Grouped bys) schemas params from ('NotNull 'PGint8)

63− -- expression = countStar

64− -- in printSQL expression

65− -- :}

66− -- count(*)

67− countStar :: aggr ('NotNull 'PGint8)

68−

69− -- | >>> :{

70− -- let

71− -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null ty]] ('NotNull 'PGint8)

72− -- expression = count (All #col)

73− -- in printSQL expression

74− -- :}

75− -- count(ALL "col")

76− count

77− :: expr1 ty

78− -- ^ what to count

79− -> aggr ('NotNull 'PGint8)

80−

81− -- | >>> :{

82− -- let

83− -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric)

84− -- expression = sum_ (Distinct #col)

85− -- in printSQL expression

86− -- :}

87− -- sum(DISTINCT "col")

88− sum_

89− :: expr1 (null ty)

90− -> aggr ('Null (PGSum ty))

91−

92− -- | input values, including nulls, concatenated into an array

93− arrayAgg

94− :: expr1 ty

95− -> aggr ('Null ('PGvararray ty))

96−

97− -- | aggregates values as a JSON array

98− jsonAgg

99− :: expr1 ty

100− -> aggr ('Null 'PGjson)

101−

102− -- | aggregates values as a JSON array

103− jsonbAgg

104− :: expr1 ty

105− -> aggr ('Null 'PGjsonb)

106−

107− {- |

108− the bitwise AND of all non-null input values, or null if none

109−

110− >>> :{

111− let

112− expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)

113− expression = bitAnd (Distinct #col)

114− in printSQL expression

115− :}

116− bit_and(DISTINCT "col")

117− -}

118− bitAnd

119− :: int `In` PGIntegral

120− => expr1 (null int)

121− -- ^ what to aggregate

122− -> aggr ('Null int)

123−

124− {- |

125− the bitwise OR of all non-null input values, or null if none

126−

127− >>> :{

128− let

129− expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)

130− expression = bitOr (All #col)

131− in printSQL expression

132− :}

133− bit_or(ALL "col")

134− -}

135− bitOr

136− :: int `In` PGIntegral

137− => expr1 (null int)

138− -- ^ what to aggregate

139− -> aggr ('Null int)

140−

141− {- |

142− true if all input values are true, otherwise false

143−

144− >>> :{

145− let

146− winFun :: WindowFunction '[] commons 'Ungrouped schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)

147− winFun = boolAnd #col

148− in printSQL winFun

149− :}

150− bool_and("col")

151− -}

152− boolAnd

153− :: expr1 (null 'PGbool)

154− -- ^ what to aggregate

155− -> aggr ('Null 'PGbool)

156−

157− {- |

158− true if at least one input value is true, otherwise false

159−

160− >>> :{

161− let

162− expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)

163− expression = boolOr (All #col)

164− in printSQL expression

165− :}

166− bool_or(ALL "col")

167− -}

168− boolOr

169− :: expr1 (null 'PGbool)

170− -- ^ what to aggregate

171− -> aggr ('Null 'PGbool)

172−

173− {- |

174− equivalent to `boolAnd`

175−

176− >>> :{

177− let

178− expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)

179− expression = every (Distinct #col)

180− in printSQL expression

181− :}

182− every(DISTINCT "col")

183− -}

184− every

185− :: expr1 (null 'PGbool)

186− -- ^ what to aggregate

187− -> aggr ('Null 'PGbool)

188−

189− {- |maximum value of expression across all input values-}

190− max_

191− :: expr1 (null ty)

192− -- ^ what to maximize

193− -> aggr ('Null ty)

194−

195− -- | minimum value of expression across all input values

196− min_

197− :: expr1 (null ty)

198− -- ^ what to minimize

199− -> aggr ('Null ty)

200−

201− -- | the average (arithmetic mean) of all input values

202− avg

203− :: expr1 (null ty)

204− -- ^ what to average

205− -> aggr ('Null (PGAvg ty))

206−

207− {- | correlation coefficient

208−

209− >>> :{

210− let

211− expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)

212− expression = corr (All (#y *: #x))

213− in printSQL expression

214− :}

215− corr(ALL "y", "x")

216− -}

217− corr

218− :: exprN '[null 'PGfloat8, null 'PGfloat8]

219− -> aggr ('Null 'PGfloat8)

220−

221− {- | population covariance

222−

223− >>> :{

224− let

225− expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)

226− expression = covarPop (All (#y *: #x))

227− in printSQL expression

228− :}

229− covar_pop(ALL "y", "x")

230− -}

231− covarPop

232− :: exprN '[null 'PGfloat8, null 'PGfloat8]

233− -> aggr ('Null 'PGfloat8)

234−

235− {- | sample covariance

236−

237− >>> :{

238− let

239− winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)

240− winFun = covarSamp (#y *: #x)

241− in printSQL winFun

242− :}

243− covar_samp("y", "x")

244− -}

245− covarSamp

246− :: exprN '[null 'PGfloat8, null 'PGfloat8]

247− -> aggr ('Null 'PGfloat8)

248−

249− {- | average of the independent variable (sum(X)/N)

250−

251− >>> :{

252− let

253− expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)

254− expression = regrAvgX (All (#y *: #x))

255− in printSQL expression

256− :}

257− regr_avgx(ALL "y", "x")

258− -}

259− regrAvgX

260− :: exprN '[null 'PGfloat8, null 'PGfloat8]

261− -> aggr ('Null 'PGfloat8)

262−

263− {- | average of the dependent variable (sum(Y)/N)

264−

265− >>> :{

266− let

267− winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)

268− winFun = regrAvgY (#y *: #x)

269− in printSQL winFun

270− :}

271− regr_avgy("y", "x")

272− -}

273− regrAvgY

274− :: exprN '[null 'PGfloat8, null 'PGfloat8]

275− -> aggr ('Null 'PGfloat8)

276−

277− {- | number of input rows in which both expressions are nonnull

278−

279− >>> :{

280− let

281− winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGint8)

282− winFun = regrCount (#y *: #x)

283− in printSQL winFun

284− :}

285− regr_count("y", "x")

286− -}

287− regrCount

288− :: exprN '[null 'PGfloat8, null 'PGfloat8]

289− -> aggr ('Null 'PGint8)

290−

291− {- | y-intercept of the least-squares-fit linear equation determined by the (X, Y) pairs

292− >>> :{

293− let

294− expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)

295− expression = regrIntercept (All (#y *: #x))

296− in printSQL expression

297− :}

298− regr_intercept(ALL "y", "x")

299− -}

300− regrIntercept

301− :: exprN '[null 'PGfloat8, null 'PGfloat8]

302− -> aggr ('Null 'PGfloat8)

303−

304− -- | @regr_r2(Y, X)@, square of the correlation coefficient

305− regrR2

306− :: exprN '[null 'PGfloat8, null 'PGfloat8]

307− -> aggr ('Null 'PGfloat8)

308−

309− -- | @regr_slope(Y, X)@, slope of the least-squares-fit linear equation

310− -- determined by the (X, Y) pairs

311− regrSlope

312− :: exprN '[null 'PGfloat8, null 'PGfloat8]

313− -> aggr ('Null 'PGfloat8)

314−

315− -- | @regr_sxx(Y, X)@, sum(X^2) - sum(X)^2/N

316− -- (“sum of squares” of the independent variable)

317− regrSxx

318− :: exprN '[null 'PGfloat8, null 'PGfloat8]

319− -> aggr ('Null 'PGfloat8)

320−

321− -- | @regr_sxy(Y, X)@, sum(X*Y) - sum(X) * sum(Y)/N

322− -- (“sum of products” of independent times dependent variable)

323− regrSxy

324− :: exprN '[null 'PGfloat8, null 'PGfloat8]

325− -> aggr ('Null 'PGfloat8)

326−

327− -- | @regr_syy(Y, X)@, sum(Y^2) - sum(Y)^2/N

328− -- (“sum of squares” of the dependent variable)

329− regrSyy

330− :: exprN '[null 'PGfloat8, null 'PGfloat8]

331− -> aggr ('Null 'PGfloat8)

332−

333− -- | historical alias for `stddevSamp`

334− stddev

335− :: expr1 (null ty)

336− -> aggr ('Null (PGAvg ty))

337−

338− -- | population standard deviation of the input values

339− stddevPop

340− :: expr1 (null ty)

341− -> aggr ('Null (PGAvg ty))

342−

343− -- | sample standard deviation of the input values

344− stddevSamp

345− :: expr1 (null ty)

346− -> aggr ('Null (PGAvg ty))

347−

348− -- | historical alias for `varSamp`

349− variance

350− :: expr1 (null ty)

351− -> aggr ('Null (PGAvg ty))

352−

353− -- | population variance of the input values

354− -- (square of the population standard deviation)

355− varPop

356− :: expr1 (null ty)

357− -> aggr ('Null (PGAvg ty))

358−

359− -- | sample variance of the input values

360− -- (square of the sample standard deviation)

361− varSamp

362− :: expr1 (null ty)

363− -> aggr ('Null (PGAvg ty))

364−

365−{- |

366−`Distinction`s are used for the input of `Aggregate` `Expression`s.

367−`All` invokes the aggregate once for each input row.

368−`Distinct` invokes the aggregate once for each distinct value of the expression

369−(or distinct set of values, for multiple expressions) found in the input

370−-}

371−data Distinction (expr :: kind -> Type) (ty :: kind)

372− = All (expr ty)

373− | Distinct (expr ty)

374− deriving (GHC.Generic,Show,Eq,Ord)

375−instance NFData (Distinction (Expression outer commons grp schemas params from) ty)

376−instance RenderSQL (Distinction (Expression outer commons grp schemas params from) ty) where

377− renderSQL = \case

378− All x -> "ALL" <+> renderSQL x

379− Distinct x -> "DISTINCT" <+> renderSQL x

380−instance SOP.SListI tys => RenderSQL

381− (Distinction (NP (Expression outer commons grp schemas params from)) tys) where

382− renderSQL = \case

383− All xs -> "ALL" <+> renderCommaSeparated renderSQL xs

384− Distinct xs -> "DISTINCT" <+> renderCommaSeparated renderSQL xs

385−

386−instance Aggregate

387− (Distinction (Expression outer commons 'Ungrouped schemas params from))

388− (Distinction (NP (Expression outer commons 'Ungrouped schemas params from)))

389− (Expression outer commons ('Grouped bys) schemas params from) where

390− countStar = UnsafeExpression "count(*)"

391− count = unsafeAggregate1 "count"

392− sum_ = unsafeAggregate1 "sum"

393− arrayAgg = unsafeAggregate1 "array_agg"

394− jsonAgg = unsafeAggregate1 "json_agg"

395− jsonbAgg = unsafeAggregate1 "jsonb_agg"

396− bitAnd = unsafeAggregate1 "bit_and"

397− bitOr = unsafeAggregate1 "bit_or"

398− boolAnd = unsafeAggregate1 "bool_and"

399− boolOr = unsafeAggregate1 "bool_or"

400− every = unsafeAggregate1 "every"

401− max_ = unsafeAggregate1 "max"

402− min_ = unsafeAggregate1 "min"

403− avg = unsafeAggregate1 "avg"

404− corr = unsafeAggregateN "corr"

405− covarPop = unsafeAggregateN "covar_pop"

406− covarSamp = unsafeAggregateN "covar_samp"

407− regrAvgX = unsafeAggregateN "regr_avgx"

408− regrAvgY = unsafeAggregateN "regr_avgy"

409− regrCount = unsafeAggregateN "regr_count"

410− regrIntercept = unsafeAggregateN "regr_intercept"

411− regrR2 = unsafeAggregateN "regr_r2"

412− regrSlope = unsafeAggregateN "regr_slope"

413− regrSxx = unsafeAggregateN "regr_sxx"

414− regrSxy = unsafeAggregateN "regr_sxy"

415− regrSyy = unsafeAggregateN "regr_syy"

416− stddev = unsafeAggregate1 "stddev"

417− stddevPop = unsafeAggregate1 "stddev_pop"

418− stddevSamp = unsafeAggregate1 "stddev_samp"

419− variance = unsafeAggregate1 "variance"

420− varPop = unsafeAggregate1 "var_pop"

421− varSamp = unsafeAggregate1 "var_samp"

422−

423−-- | escape hatch to define aggregate functions

424−unsafeAggregate1

425− :: ByteString -- ^ aggregate function

426− -> Distinction (Expression outer commons 'Ungrouped schemas params from) x

427− -> Expression outer commons ('Grouped bys) schemas params from y

428−unsafeAggregate1 fun x = UnsafeExpression $ fun <> parenthesized (renderSQL x)

429−

430−unsafeAggregateN

431− :: SOP.SListI xs

432− => ByteString -- ^ function

433− -> Distinction (NP (Expression outer commons 'Ungrouped schemas params from)) xs

434− -> Expression outer commons ('Grouped bys) schemas params from y

435−unsafeAggregateN fun xs = UnsafeExpression $ fun <> parenthesized (renderSQL xs)

436−

437−-- | A type family that calculates `PGSum``PGType` of

438−-- a given argument `PGType`.

439−type family PGSum ty where

440− PGSum 'PGint2 = 'PGint8

441− PGSum 'PGint4 = 'PGint8

442− PGSum 'PGint8 = 'PGnumeric

443− PGSum 'PGfloat4 = 'PGfloat4

444− PGSum 'PGfloat8 = 'PGfloat8

445− PGSum 'PGnumeric = 'PGnumeric

446− PGSum 'PGinterval = 'PGinterval

447− PGSum 'PGmoney = 'PGmoney

448− PGSum pg = TypeError

449− ( 'Text "Squeal type error: Cannot sum with argument type "

450− ':<>: 'ShowType pg )

451−

452−-- | A type family that calculates `PGAvg` type of a `PGType`.

453−type family PGAvg ty where

454− PGAvg 'PGint2 = 'PGnumeric

455− PGAvg 'PGint4 = 'PGnumeric

456− PGAvg 'PGint8 = 'PGnumeric

457− PGAvg 'PGnumeric = 'PGnumeric

458− PGAvg 'PGfloat4 = 'PGfloat8

459− PGAvg 'PGfloat8 = 'PGfloat8

460− PGAvg 'PGinterval = 'PGinterval

461− PGAvg pg = TypeError

462− ('Text "Squeal type error: No average for " ':<>: 'ShowType pg)

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hsdeleted−169

@@ -1,169 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.Collection

3−Description: Array and composite functions

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Array and composite functions

9−-}

10−

11−{-# LANGUAGE

12− AllowAmbiguousTypes

13− , DataKinds

14− , FlexibleContexts

15− , FlexibleInstances

16− , MultiParamTypeClasses

17− , OverloadedLabels

18− , OverloadedStrings

19− , RankNTypes

20− , ScopedTypeVariables

21− , TypeApplications

22− , TypeFamilies

23− , TypeOperators

24− , UndecidableInstances

25−#-}

26−

27−module Squeal.PostgreSQL.Expression.Collection

28− ( array

29− , array1

30− , array2

31− , cardinality

32− , index

33− , unnest

34− , row

35− , field

36− ) where

37−

38−import Data.String

39−import Data.Word (Word64)

40−

41−import qualified Generics.SOP as SOP

42−

43−import Squeal.PostgreSQL.Alias

44−import Squeal.PostgreSQL.Expression

45−import Squeal.PostgreSQL.Expression.Set

46−import Squeal.PostgreSQL.List

47−import Squeal.PostgreSQL.Render

48−import Squeal.PostgreSQL.Schema

49−

50−-- $setup

51−-- >>> import Squeal.PostgreSQL

52−

53−-- | >>> printSQL $ array [null_, false, true]

54−-- ARRAY[NULL, FALSE, TRUE]

55−array

56− :: [Expression outer commons grp schemas params from ty]

57− -- ^ array elements

58− -> Expression outer commons grp schemas params from (null ('PGvararray ty))

59−array xs = UnsafeExpression $ "ARRAY" <>

60− bracketed (commaSeparated (renderSQL <$> xs))

61−

62−{- | construct a 1-dimensional fixed length array

63−

64−>>> printSQL $ array1 (null_ :* false *: true)

65−ARRAY[NULL, FALSE, TRUE]

66−

67−>>> :type array1 (null_ :* false *: true)

68−array1 (null_ :* false *: true)

69− :: Expression

70− outer

71− commons

72− grp

73− schemas

74− params

75− from

76− (null ('PGfixarray '[3] ('Null 'PGbool)))

77−-}

78−array1

79− :: (n ~ Length tys, SOP.All ((~) ty) tys)

80− => NP (Expression outer commons grp schemas params from) tys

81− -> Expression outer commons grp schemas params from (null ('PGfixarray '[n] ty))

82−array1 xs = UnsafeExpression $ "ARRAY" <>

83− bracketed (renderCommaSeparated renderSQL xs)

84−

85−{- | construct a 2-dimensional fixed length array

86−

87−>>> printSQL $ array2 ((null_ :* false *: true) *: (false :* null_ *: true))

88−ARRAY[[NULL, FALSE, TRUE], [FALSE, NULL, TRUE]]

89−

90−>>> :type array2 ((null_ :* false *: true) *: (false :* null_ *: true))

91−array2 ((null_ :* false *: true) *: (false :* null_ *: true))

92− :: Expression

93− outer

94− commons

95− grp

96− schemas

97− params

98− from

99− (null ('PGfixarray '[2, 3] ('Null 'PGbool)))

100−-}

101−array2

102− :: ( SOP.All ((~) tys) tyss

103− , SOP.All SOP.SListI tyss

104− , Length tyss ~ n1

105− , SOP.All ((~) ty) tys

106− , Length tys ~ n2 )

107− => NP (NP (Expression outer commons grp schemas params from)) tyss

108− -> Expression outer commons grp schemas params from (null ('PGfixarray '[n1,n2] ty))

109−array2 xss = UnsafeExpression $ "ARRAY" <>

110− bracketed (renderCommaSeparatedConstraint @SOP.SListI (bracketed . renderCommaSeparated renderSQL) xss)

111−

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

113−-- cardinality(ARRAY[NULL, FALSE, TRUE])

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

115−cardinality = unsafeFunction "cardinality"

116−

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

118−-- (ARRAY[NULL, FALSE, TRUE])[2]

119−index

120− :: Word64 -- ^ index

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

122−index n expr = UnsafeExpression $

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

124−

125−-- | Expand an array to a set of rows

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

127−unnest = unsafeSetFunction

128−

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

130−-- (also called a composite value) using values for its member fields.

131−--

132−-- >>> :{

133−-- type Complex = 'PGcomposite

134−-- '[ "real" ::: 'NotNull 'PGfloat8

135−-- , "imaginary" ::: 'NotNull 'PGfloat8 ]

136−-- :}

137−--

138−-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer commons grp schemas params from ('NotNull Complex)

139−-- >>> printSQL i

140−-- ROW(0, 1)

141−row

142− :: SOP.SListI row

143− => NP (Aliased (Expression outer commons grp schemas params from)) row

144− -- ^ zero or more expressions for the row field values

145− -> Expression outer commons grp schemas params from (null ('PGcomposite row))

146−row exprs = UnsafeExpression $ "ROW" <> parenthesized

147− (renderCommaSeparated (\ (expr `As` _) -> renderSQL expr) exprs)

148−

149−-- | >>> :{

150−-- type Complex = 'PGcomposite

151−-- '[ "real" ::: 'NotNull 'PGfloat8

152−-- , "imaginary" ::: 'NotNull 'PGfloat8 ]

153−-- type Schema = '["complex" ::: 'Typedef Complex]

154−-- :}

155−--

156−-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer '[] grp (Public Schema) from params ('NotNull Complex)

157−-- >>> printSQL $ i & field #complex #imaginary

158−-- (ROW(0, 1)::"complex")."imaginary"

159−field

160− :: ( Has sch schemas schema

161− , Has tydef schema ('Typedef ('PGcomposite row))

162− , Has field row ty)

163− => QualifiedAlias sch tydef -- ^ row type

164− -> Alias field -- ^ field name

165− -> Expression outer commons grp schemas params from ('NotNull ('PGcomposite row))

166− -> Expression outer commons grp schemas params from ty

167−field td fld expr = UnsafeExpression $

168− parenthesized (renderSQL expr <> "::" <> renderSQL td)

169− <> "." <> renderSQL fld

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hsdeleted−206

@@ -1,206 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.Comparison

3−Description: Comparison expressions

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Comparison functions and operators

9−-}

10−

11−{-# LANGUAGE

12− OverloadedStrings

13− , RankNTypes

14− , TypeInType

15− , TypeOperators

16−#-}

17−

18−module Squeal.PostgreSQL.Expression.Comparison

19− ( (.==)

20− , (./=)

21− , (.>=)

22− , (.<)

23− , (.<=)

24− , (.>)

25− , greatest

26− , least

27− , BetweenExpr

28− , between

29− , notBetween

30− , betweenSymmetric

31− , notBetweenSymmetric

32− , isDistinctFrom

33− , isNotDistinctFrom

34− , isTrue

35− , isNotTrue

36− , isFalse

37− , isNotFalse

38− , isUnknown

39− , isNotUnknown

40− ) where

41−

42−import Data.ByteString

43−

44−import Squeal.PostgreSQL.Expression

45−import Squeal.PostgreSQL.Expression.Logic

46−import Squeal.PostgreSQL.Render

47−import Squeal.PostgreSQL.Schema

48−

49−-- $setup

50−-- >>> import Squeal.PostgreSQL

51−

52−-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`

53−-- will produce @NULL@s if one of their arguments is @NULL@.

54−--

55−-- >>> printSQL $ true .== null_

56−-- (TRUE = NULL)

57−(.==) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

58−(.==) = unsafeBinaryOp "="

59−infix 4 .==

60−

61−-- | >>> printSQL $ true ./= null_

62−-- (TRUE <> NULL)

63−(./=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

64−(./=) = unsafeBinaryOp "<>"

65−infix 4 ./=

66−

67−-- | >>> printSQL $ true .>= null_

68−-- (TRUE >= NULL)

69−(.>=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

70−(.>=) = unsafeBinaryOp ">="

71−infix 4 .>=

72−

73−-- | >>> printSQL $ true .< null_

74−-- (TRUE < NULL)

75−(.<) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

76−(.<) = unsafeBinaryOp "<"

77−infix 4 .<

78−

79−-- | >>> printSQL $ true .<= null_

80−-- (TRUE <= NULL)

81−(.<=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

82−(.<=) = unsafeBinaryOp "<="

83−infix 4 .<=

84−

85−-- | >>> printSQL $ true .> null_

86−-- (TRUE > NULL)

87−(.>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

88−(.>) = unsafeBinaryOp ">"

89−infix 4 .>

90−

91−-- | >>> let expr = greatest [param @1] currentTimestamp :: Expression outer commons grp schemas '[ 'NotNull 'PGtimestamptz] from ('NotNull 'PGtimestamptz)

92−-- >>> printSQL expr

93−-- GREATEST(($1 :: timestamp with time zone), CURRENT_TIMESTAMP)

94−greatest :: FunctionVar ty ty ty

95−greatest = unsafeFunctionVar "GREATEST"

96−

97−-- | >>> printSQL $ least [null_] currentTimestamp

98−-- LEAST(NULL, CURRENT_TIMESTAMP)

99−least :: FunctionVar ty ty ty

100−least = unsafeFunctionVar "LEAST"

101−

102−{- |

103−A @RankNType@ for comparison expressions like `between`.

104−-}

105−type BetweenExpr

106− = forall outer commons grp schemas params from ty

107− . Expression outer commons grp schemas params from ty

108− -> ( Expression outer commons grp schemas params from ty

109− , Expression outer commons grp schemas params from ty ) -- ^ bounds

110− -> Condition outer commons grp schemas params from

111−

112−unsafeBetweenExpr :: ByteString -> BetweenExpr

113−unsafeBetweenExpr fun a (x,y) = UnsafeExpression $

114− renderSQL a <+> fun <+> renderSQL x <+> "AND" <+> renderSQL y

115−

116−{- | >>> printSQL $ true `between` (null_, false)

117−TRUE BETWEEN NULL AND FALSE

118−-}

119−between :: BetweenExpr

120−between = unsafeBetweenExpr "BETWEEN"

121−

122−{- | >>> printSQL $ true `notBetween` (null_, false)

123−TRUE NOT BETWEEN NULL AND FALSE

124−-}

125−notBetween :: BetweenExpr

126−notBetween = unsafeBetweenExpr "NOT BETWEEN"

127−

128−{- | between, after sorting the comparison values

129−

130−>>> printSQL $ true `betweenSymmetric` (null_, false)

131−TRUE BETWEEN SYMMETRIC NULL AND FALSE

132−-}

133−betweenSymmetric :: BetweenExpr

134−betweenSymmetric = unsafeBetweenExpr "BETWEEN SYMMETRIC"

135−

136−{- | not between, after sorting the comparison values

137−

138−>>> printSQL $ true `notBetweenSymmetric` (null_, false)

139−TRUE NOT BETWEEN SYMMETRIC NULL AND FALSE

140−-}

141−notBetweenSymmetric :: BetweenExpr

142−notBetweenSymmetric = unsafeBetweenExpr "NOT BETWEEN SYMMETRIC"

143−

144−{- | not equal, treating null like an ordinary value

145−

146−>>> printSQL $ true `isDistinctFrom` null_

147−(TRUE IS DISTINCT FROM NULL)

148−-}

149−isDistinctFrom :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

150−isDistinctFrom = unsafeBinaryOp "IS DISTINCT FROM"

151−

152−{- | equal, treating null like an ordinary value

153−

154−>>> printSQL $ true `isNotDistinctFrom` null_

155−(TRUE IS NOT DISTINCT FROM NULL)

156−-}

157−isNotDistinctFrom :: Operator (null0 ty) (null1 ty) ('NotNull 'PGbool)

158−isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"

159−

160−{- | is true

161−

162−>>> printSQL $ true & isTrue

163−(TRUE IS TRUE)

164−-}

165−isTrue :: null0 'PGbool --> null1 'PGbool

166−isTrue = unsafeRightOp "IS TRUE"

167−

168−{- | is false or unknown

169−

170−>>> printSQL $ true & isNotTrue

171−(TRUE IS NOT TRUE)

172−-}

173−isNotTrue :: null0 'PGbool --> null1 'PGbool

174−isNotTrue = unsafeRightOp "IS NOT TRUE"

175−

176−{- | is false

177−

178−>>> printSQL $ true & isFalse

179−(TRUE IS FALSE)

180−-}

181−isFalse :: null0 'PGbool --> null1 'PGbool

182−isFalse = unsafeRightOp "IS FALSE"

183−

184−{- | is true or unknown

185−

186−>>> printSQL $ true & isNotFalse

187−(TRUE IS NOT FALSE)

188−-}

189−isNotFalse :: null0 'PGbool --> null1 'PGbool

190−isNotFalse = unsafeRightOp "IS NOT FALSE"

191−

192−{- | is unknown

193−

194−>>> printSQL $ true & isUnknown

195−(TRUE IS UNKNOWN)

196−-}

197−isUnknown :: null0 'PGbool --> null1 'PGbool

198−isUnknown = unsafeRightOp "IS UNKNOWN"

199−

200−{- | is true or false

201−

202−>>> printSQL $ true & isNotUnknown

203−(TRUE IS NOT UNKNOWN)

204−-}

205−isNotUnknown :: null0 'PGbool --> null1 'PGbool

206−isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hsdeleted−462

@@ -1,462 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.Json

3−Description: Json and Jsonb functions and operators

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Json and Jsonb functions and operators

9−-}

10−

11−{-# LANGUAGE

12− DataKinds

13− , FlexibleContexts

14− , FlexibleInstances

15− , GADTs

16− , OverloadedLabels

17− , OverloadedStrings

18− , PolyKinds

19− , RankNTypes

20− , ScopedTypeVariables

21− , TypeApplications

22− , TypeOperators

23− , UndecidableInstances

24− , UndecidableSuperClasses

25−#-}

26−

27−module Squeal.PostgreSQL.Expression.Json

28− ( -- * Json and Jsonb operators

29− (.->)

30− , (.->>)

31− , (.#>)

32− , (.#>>)

33− -- * Jsonb operators

34− , (.?)

35− , (.?|)

36− , (.?&)

37− , (.-.)

38− , (#-.)

39− -- * Json and Jsonb functions

40− , toJson

41− , toJsonb

42− , arrayToJson

43− , rowToJson

44− , jsonBuildArray

45− , jsonbBuildArray

46− , JsonBuildObject (..)

47− , jsonObject

48− , jsonbObject

49− , jsonZipObject

50− , jsonbZipObject

51− , jsonArrayLength

52− , jsonbArrayLength

53− , jsonTypeof

54− , jsonbTypeof

55− , jsonStripNulls

56− , jsonbStripNulls

57− , jsonbSet

58− , jsonbInsert

59− , jsonbPretty

60− -- * Json and Jsonb set returning functions

61− , jsonEach

62− , jsonbEach

63− , jsonEachText

64− , jsonbEachText

65− , jsonObjectKeys

66− , jsonbObjectKeys

67− , JsonPopulateFunction

68− , jsonPopulateRecord

69− , jsonbPopulateRecord

70− , jsonPopulateRecordSet

71− , jsonbPopulateRecordSet

72− , JsonToRecordFunction

73− , jsonToRecord

74− , jsonbToRecord

75− , jsonToRecordSet

76− , jsonbToRecordSet

77− ) where

78−

79−import Data.ByteString (ByteString)

80−import GHC.TypeLits

81−

82−import Squeal.PostgreSQL.Alias

83−import Squeal.PostgreSQL.Expression

84−import Squeal.PostgreSQL.Expression.Set

85−import Squeal.PostgreSQL.Expression.Type

86−import Squeal.PostgreSQL.List

87−import Squeal.PostgreSQL.Query

88−import Squeal.PostgreSQL.Render

89−import Squeal.PostgreSQL.Schema

90−

91−import qualified Generics.SOP as SOP

92−

93−-- $setup

94−-- >>> import Squeal.PostgreSQL

95−-- >>> import Data.Aeson

96−

97−{-----------------------------------------

98− -- json and jsonb support

99−

100−See https://www.postgresql.org/docs/10/static/functions-json.html -- most

101−comments lifted directly from this page.

102−

103−Table 9.44: json and jsonb operators

104−-----------------------------------------}

105−

106−-- | Get JSON value (object field or array element) at a key.

107−(.->)

108− :: (json `In` PGJsonType, key `In` PGJsonKey)

109− => Operator (null json) (null key) ('Null json)

110−infixl 8 .->

111−(.->) = unsafeBinaryOp "->"

112−

113−-- | Get JSON value (object field or array element) at a key, as text.

114−(.->>)

115− :: (json `In` PGJsonType, key `In` PGJsonKey)

116− => Operator (null json) (null key) ('Null 'PGtext)

117−infixl 8 .->>

118−(.->>) = unsafeBinaryOp "->>"

119−

120−-- | Get JSON value at a specified path.

121−(.#>)

122− :: json `In` PGJsonType

123− => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null json)

124−infixl 8 .#>

125−(.#>) = unsafeBinaryOp "#>"

126−

127−-- | Get JSON value at a specified path as text.

128−(.#>>)

129− :: json `In` PGJsonType

130− => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null 'PGtext)

131−infixl 8 .#>>

132−(.#>>) = unsafeBinaryOp "#>>"

133−

134−-- Additional jsonb operators

135−

136−-- | Does the string exist as a top-level key within the JSON value?

137−(.?) :: Operator (null 'PGjsonb) (null 'PGtext) ('Null 'PGbool)

138−infixl 9 .?

139−(.?) = unsafeBinaryOp "?"

140−

141−-- | Do any of these array strings exist as top-level keys?

142−(.?|) :: Operator

143− (null 'PGjsonb)

144− (null ('PGvararray ('NotNull 'PGtext)))

145− ('Null 'PGbool)

146−infixl 9 .?|

147−(.?|) = unsafeBinaryOp "?|"

148−

149−-- | Do all of these array strings exist as top-level keys?

150−(.?&) :: Operator

151− (null 'PGjsonb)

152− (null ('PGvararray ('NotNull 'PGtext)))

153− ('Null 'PGbool)

154−infixl 9 .?&

155−(.?&) = unsafeBinaryOp "?&"

156−

157−-- | Delete a key or keys from a JSON object, or remove an array element.

158−--

159−-- If the right operand is

160−--

161−-- @ text @: Delete key / value pair or string element from left operand.

162−-- Key / value pairs are matched based on their key value,

163−--

164−-- @ text[] @: Delete multiple key / value pairs or string elements

165−-- from left operand. Key / value pairs are matched based on their key value,

166−--

167−-- @ integer @: Delete the array element with specified index (Negative integers

168−-- count from the end). Throws an error if top level container is not an array.

169−(.-.)

170− :: key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]

171− => Operator (null 'PGjsonb) (null key) (null 'PGjsonb)

172−infixl 6 .-.

173−(.-.) = unsafeBinaryOp "-"

174−

175−-- | Delete the field or element with specified path (for JSON arrays, negative

176−-- integers count from the end)

177−(#-.) :: Operator (null 'PGjsonb) (null ('PGvararray ('NotNull 'PGtext))) (null 'PGjsonb)

178−infixl 6 #-.

179−(#-.) = unsafeBinaryOp "#-"

180−

181−{-----------------------------------------

182−Table 9.45: JSON creation functions

183−-----------------------------------------}

184−

185−-- | Returns the value as json. Arrays and composites are converted

186−-- (recursively) to arrays and objects; otherwise, if there is a cast from the

187−-- type to json, the cast function will be used to perform the conversion;

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

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

190−-- such a fashion that it is a valid json value.

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

192−toJson = unsafeFunction "to_json"

193−

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

195−-- (recursively) to arrays and objects; otherwise, if there is a cast from the

196−-- type to json, the cast function will be used to perform the conversion;

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

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

199−-- such a fashion that it is a valid jsonb value.

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

201−toJsonb = unsafeFunction "to_jsonb"

202−

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

204−-- becomes a JSON array of arrays.

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

206−arrayToJson = unsafeFunction "array_to_json"

207−

208−-- | Returns the row as a JSON object.

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

210−rowToJson = unsafeFunction "row_to_json"

211−

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

213−-- argument list.

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

215−jsonBuildArray = unsafeFunctionN "json_build_array"

216−

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

218−-- variadic argument list.

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

220−jsonbBuildArray = unsafeFunctionN "jsonb_build_array"

221−

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

223−-- argument list. The elements of the argument list must alternate between text

224−-- and values.

225−class SOP.SListI tys => JsonBuildObject tys where

226−

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

228− jsonBuildObject = unsafeFunctionN "json_build_object"

229−

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

231− jsonbBuildObject = unsafeFunctionN "jsonb_build_object"

232−

233−instance JsonBuildObject '[]

234−instance (JsonBuildObject tys, key `In` PGJsonKey)

235− => JsonBuildObject ('NotNull key ': value ': tys)

236−

237−-- | Builds a JSON object out of a text array.

238−-- The array must have two dimensions

239−-- such that each inner array has exactly two elements,

240−-- which are taken as a key/value pair.

241−jsonObject

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

243− --> null 'PGjson

244−jsonObject = unsafeFunction "json_object"

245−

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

247−-- The array must have two dimensions

248−-- such that each inner array has exactly two elements,

249−-- which are taken as a key/value pair.

250−jsonbObject

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

252− --> null 'PGjsonb

253−jsonbObject = unsafeFunction "jsonb_object"

254−

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

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

257−jsonZipObject ::

258− '[ null ('PGvararray ('NotNull 'PGtext))

259− , null ('PGvararray ('NotNull 'PGtext)) ]

260− ---> null 'PGjson

261−jsonZipObject = unsafeFunctionN "json_object"

262−

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

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

265−-- object.

266−jsonbZipObject ::

267− '[ null ('PGvararray ('NotNull 'PGtext))

268− , null ('PGvararray ('NotNull 'PGtext)) ]

269− ---> null 'PGjsonb

270−jsonbZipObject = unsafeFunctionN "jsonb_object"

271−

272−{-----------------------------------------

273−Table 9.46: JSON processing functions

274−-----------------------------------------}

275−

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

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

278−jsonArrayLength = unsafeFunction "json_array_length"

279−

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

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

282−jsonbArrayLength = unsafeFunction "jsonb_array_length"

283−

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

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

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

287−jsonTypeof = unsafeFunction "json_typeof"

288−

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

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

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

292−jsonbTypeof = unsafeFunction "jsonb_typeof"

293−

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

295−-- Other null values are untouched.

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

297−jsonStripNulls = unsafeFunction "json_strip_nulls"

298−

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

300−-- Other null values are untouched.

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

302−jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"

303−

304−-- | @ jsonbSet target path new_value create_missing @

305−--

306−-- Returns target with the section designated by path replaced by @new_value@,

307−-- or with @new_value@ added if create_missing is

308−-- `Squeal.PostgreSQL.Expression.Logic.true` and the

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

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

311−-- arrays.

312−jsonbSet ::

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

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

315−jsonbSet = unsafeFunctionN "jsonbSet"

316−

317−-- | @ jsonbInsert target path new_value insert_after @

318−--

319−-- Returns target with @new_value@ inserted. If target section designated by

320−-- path is in a JSONB array, @new_value@ will be inserted before target or after

321−-- if @insert_after@ is `Squeal.PostgreSQL.Expression.Logic.true`.

322−-- If target section designated by

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

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

325−-- in path count from the end of JSON arrays.

326−jsonbInsert ::

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

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

329−jsonbInsert = unsafeFunctionN "jsonb_insert"

330−

331−-- | Returns its argument as indented JSON text.

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

333−jsonbPretty = unsafeFunction "jsonb_pretty"

334−

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

336−

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

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

339−-}

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

341− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]

342−jsonEach = unsafeSetFunction

343−

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

345−

346−>>> printSQL (select Star (from (jsonbEach (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))

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

348−-}

349−jsonbEach

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

351− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]

352−jsonbEach = unsafeSetFunction

353−

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

355−

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

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

358−-}

359−jsonEachText

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

361− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]

362−jsonEachText = unsafeSetFunction

363−

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

365−

366−>>> printSQL (select Star (from (jsonbEachText (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))

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

368−-}

369−jsonbEachText

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

371− '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]

372−jsonbEachText = unsafeSetFunction

373−

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

375−

376−>>> printSQL (jsonObjectKeys (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))

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

378−-}

379−jsonObjectKeys

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

381− '["json_object_keys" ::: 'NotNull 'PGtext]

382−jsonObjectKeys = unsafeSetFunction

383−

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

385−

386−>>> printSQL (jsonbObjectKeys (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))

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

388−-}

389−jsonbObjectKeys

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

391− '["jsonb_object_keys" ::: 'NotNull 'PGtext]

392−jsonbObjectKeys = unsafeSetFunction

393−

394−-- | Build rows from Json types.

395−type JsonPopulateFunction fun json

396− = forall schemas row outer commons params

397− . json `In` PGJsonType

398− => TypeExpression schemas ('NotNull ('PGcomposite row)) -- ^ row type

399− -> Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)

400− -- ^ json type

401− -> FromClause outer commons schemas params '[fun ::: row]

402−

403−unsafePopulateFunction

404− :: forall fun ty

405− . KnownSymbol fun => Alias fun -> JsonPopulateFunction fun ty

406−unsafePopulateFunction _fun ty expr = UnsafeFromClause $ renderSymbol @fun

407− <> parenthesized ("null::" <> renderSQL ty <> ", " <> renderSQL expr)

408−

409−-- | Expands the JSON expression to a row whose columns match the record

410−-- type defined by the given table.

411−jsonPopulateRecord :: JsonPopulateFunction "json_populate_record" 'PGjson

412−jsonPopulateRecord = unsafePopulateFunction #json_populate_record

413−

414−-- | Expands the binary JSON expression to a row whose columns match the record

415−-- type defined by the given table.

416−jsonbPopulateRecord :: JsonPopulateFunction "jsonb_populate_record" 'PGjsonb

417−jsonbPopulateRecord = unsafePopulateFunction #jsonb_populate_record

418−

419−-- | Expands the outermost array of objects in the given JSON expression to a

420−-- set of rows whose columns match the record type defined by the given table.

421−jsonPopulateRecordSet :: JsonPopulateFunction "json_populate_record_set" 'PGjson

422−jsonPopulateRecordSet = unsafePopulateFunction #json_populate_record_set

423−

424−-- | Expands the outermost array of objects in the given binary JSON expression

425−-- to a set of rows whose columns match the record type defined by the given

426−-- table.

427−jsonbPopulateRecordSet :: JsonPopulateFunction "jsonb_populate_record_set" 'PGjsonb

428−jsonbPopulateRecordSet = unsafePopulateFunction #jsonb_populate_record_set

429−

430−-- | Build rows from Json types.

431−type JsonToRecordFunction json

432− = forall outer commons schemas params tab row

433− . (SOP.SListI row, json `In` PGJsonType)

434− => Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)

435− -- ^ json type

436− -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: row)

437− -- ^ row type

438− -> FromClause outer commons schemas params '[tab ::: row]

439−

440−unsafeRecordFunction :: ByteString -> JsonToRecordFunction json

441−unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $

442− fun <> parenthesized (renderSQL expr) <+> "AS" <+> renderSQL tab

443− <> parenthesized (renderCommaSeparated renderTy types)

444− where

445− renderTy :: Aliased (TypeExpression schemas) ty -> ByteString

446− renderTy (ty `As` alias) = renderSQL alias <+> renderSQL ty

447−

448−-- | Builds an arbitrary record from a JSON object.

449−jsonToRecord :: JsonToRecordFunction 'PGjson

450−jsonToRecord = unsafeRecordFunction "json_to_record"

451−

452−-- | Builds an arbitrary record from a binary JSON object.

453−jsonbToRecord :: JsonToRecordFunction 'PGjsonb

454−jsonbToRecord = unsafeRecordFunction "jsonb_to_record"

455−

456−-- | Builds an arbitrary set of records from a JSON array of objects.

457−jsonToRecordSet :: JsonToRecordFunction 'PGjson

458−jsonToRecordSet = unsafeRecordFunction "json_to_record_set"

459−

460−-- | Builds an arbitrary set of records from a binary JSON array of objects.

461−jsonbToRecordSet :: JsonToRecordFunction 'PGjsonb

462−jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Literal.hsdeleted−87

@@ -1,87 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.Literal

3−Description: Literal expressions

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Literal expressions

9−-}

10−

11−{-# LANGUAGE

12− FlexibleContexts

13− , FlexibleInstances

14− , LambdaCase

15− , OverloadedStrings

16− , RankNTypes

17− , ScopedTypeVariables

18− , TypeApplications

19− , TypeSynonymInstances

20− , UndecidableInstances

21−#-}

22−

23−module Squeal.PostgreSQL.Expression.Literal (Literal (..)) where

24−

25−import ByteString.StrictBuilder (builderBytes)

26−import Data.ByteString.Lazy (toStrict)

27−import Data.Int

28−import Data.String

29−import Data.Text (Text)

30−

31−import qualified Data.Aeson as JSON

32−import qualified Data.Text as Text

33−import qualified Data.Text.Lazy as Lazy (Text)

34−import qualified Data.Text.Lazy as Lazy.Text

35−

36−import Squeal.PostgreSQL.Binary

37−import Squeal.PostgreSQL.Expression

38−import Squeal.PostgreSQL.Expression.Logic

39−import Squeal.PostgreSQL.PG

40−import Squeal.PostgreSQL.Render

41−

42−{- |

43−The `Literal` class allows embedding a Haskell value directly

44−as an `Expression` using `literal`.

45−

46−>>> printSQL (literal 'a')

47−E'a'

48−

49−>>> printSQL (literal (1 :: Double))

50−1.0

51−

52−>>> printSQL (literal (Json [1 :: Double, 2]))

53−('[1.0,2.0]' :: json)

54−

55−>>> printSQL (literal (Enumerated GT))

56−'GT'

57−-}

58−class Literal hask where literal :: hask -> Expr (null (PG hask))

59−instance Literal Bool where

60− literal = \case

61− True -> true

62− False -> false

63−instance JSON.ToJSON hask => Literal (Json hask) where

64− literal = UnsafeExpression . parenthesized . (<> " :: json")

65− . singleQuotedUtf8 . toStrict . JSON.encode . getJson

66−instance JSON.ToJSON hask => Literal (Jsonb hask) where

67− literal = UnsafeExpression . parenthesized . (<> " :: jsonb")

68− . singleQuotedUtf8 . toStrict . JSON.encode . getJsonb

69−instance Literal Char where

70− literal chr = UnsafeExpression $

71− "E\'" <> fromString (escape chr) <> "\'"

72−instance Literal String where literal = fromString

73−instance Literal Int16 where literal = fromIntegral

74−instance Literal Int32 where literal = fromIntegral

75−instance Literal Int64 where literal = fromIntegral

76−instance Literal Float where literal = fromRational . toRational

77−instance Literal Double where literal = fromRational . toRational

78−instance Literal Text where literal = fromString . Text.unpack

79−instance Literal Lazy.Text where literal = fromString . Lazy.Text.unpack

80−instance ToParam (Enumerated enum) (PG (Enumerated enum))

81− => Literal (Enumerated enum) where

82− literal

83− = UnsafeExpression

84− . singleQuotedUtf8

85− . builderBytes

86− . unK

87− . toParam @(Enumerated enum) @(PG (Enumerated enum))

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hsdeleted−105

@@ -1,105 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.Logic

3−Description: Logical expressions

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Logical expressions and operators

9−-}

10−

11−{-# LANGUAGE

12− DataKinds

13− , OverloadedStrings

14− , TypeOperators

15−#-}

16−

17−module Squeal.PostgreSQL.Expression.Logic

18− ( Condition

19− , true

20− , false

21− , not_

22− , (.&&)

23− , (.||)

24− , caseWhenThenElse

25− , ifThenElse

26− ) where

27−

28−import Squeal.PostgreSQL.Expression

29−import Squeal.PostgreSQL.Render

30−import Squeal.PostgreSQL.Schema

31−

32−-- | A `Condition` is an `Expression`, which can evaluate

33−-- to `true`, `false` or `Squeal.PostgreSQL.Null.null_`. This is because SQL uses

34−-- a three valued logic.

35−type Condition outer commons grp schemas params from =

36− Expression outer commons grp schemas params from ('Null 'PGbool)

37−

38−-- | >>> printSQL true

39−-- TRUE

40−true :: Expr (null 'PGbool)

41−true = UnsafeExpression "TRUE"

42−

43−-- | >>> printSQL false

44−-- FALSE

45−false :: Expr (null 'PGbool)

46−false = UnsafeExpression "FALSE"

47−

48−-- | >>> printSQL $ not_ true

49−-- (NOT TRUE)

50−not_ :: null 'PGbool --> null 'PGbool

51−not_ = unsafeLeftOp "NOT"

52−

53−-- | >>> printSQL $ true .&& false

54−-- (TRUE AND FALSE)

55−(.&&) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)

56−infixr 3 .&&

57−(.&&) = unsafeBinaryOp "AND"

58−

59−-- | >>> printSQL $ true .|| false

60−-- (TRUE OR FALSE)

61−(.||) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)

62−infixr 2 .||

63−(.||) = unsafeBinaryOp "OR"

64−

65−-- | >>> :{

66−-- let

67−-- expression :: Expression outer commons grp schemas params from (null 'PGint2)

68−-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3

69−-- in printSQL expression

70−-- :}

71−-- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END

72−caseWhenThenElse

73− :: [ ( Condition outer commons grp schemas params from

74− , Expression outer commons grp schemas params from ty

75− ) ]

76− -- ^ whens and thens

77− -> Expression outer commons grp schemas params from ty

78− -- ^ else

79− -> Expression outer commons grp schemas params from ty

80−caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat

81− [ "CASE"

82− , mconcat

83− [ mconcat

84− [ " WHEN ", renderSQL when_

85− , " THEN ", renderSQL then_

86− ]

87− | (when_,then_) <- whenThens

88− ]

89− , " ELSE ", renderSQL else_

90− , " END"

91− ]

92−

93−-- | >>> :{

94−-- let

95−-- expression :: Expression outer commons grp schemas params from (null 'PGint2)

96−-- expression = ifThenElse true 1 0

97−-- in printSQL expression

98−-- :}

99−-- CASE WHEN TRUE THEN 1 ELSE 0 END

100−ifThenElse

101− :: Condition outer commons grp schemas params from

102− -> Expression outer commons grp schemas params from ty -- ^ then

103− -> Expression outer commons grp schemas params from ty -- ^ else

104− -> Expression outer commons grp schemas params from ty

105−ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hsdeleted−100

@@ -1,100 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.Math

3−Description: Math expressions

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Mathematical functions and operators

9−-}

10−

11−{-# LANGUAGE

12− DataKinds

13− , OverloadedStrings

14− , TypeOperators

15−#-}

16−

17−module Squeal.PostgreSQL.Expression.Math

18− ( atan2_

19− , quot_

20− , rem_

21− , trunc

22− , round_

23− , ceiling_

24− ) where

25−

26−import Squeal.PostgreSQL.Expression

27−import Squeal.PostgreSQL.List

28−import Squeal.PostgreSQL.Schema

29−

30−-- $setup

31−-- >>> import Squeal.PostgreSQL

32−

33−-- | >>> :{

34−-- let

35−-- expression :: Expr (null 'PGfloat4)

36−-- expression = atan2_ (pi *: 2)

37−-- in printSQL expression

38−-- :}

39−-- atan2(pi(), 2)

40−atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float

41−atan2_ = unsafeFunctionN "atan2"

42−

43−

44−-- | integer division, truncates the result

45−--

46−-- >>> :{

47−-- let

48−-- expression :: Expression outer commons grp schemas params from (null 'PGint2)

49−-- expression = 5 `quot_` 2

50−-- in printSQL expression

51−-- :}

52−-- (5 / 2)

53−quot_

54− :: int `In` PGIntegral

55− => Operator (null int) (null int) (null int)

56−quot_ = unsafeBinaryOp "/"

57−

58−-- | remainder upon integer division

59−--

60−-- >>> :{

61−-- let

62−-- expression :: Expression outer commons grp schemas params from (null 'PGint2)

63−-- expression = 5 `rem_` 2

64−-- in printSQL expression

65−-- :}

66−-- (5 % 2)

67−rem_

68− :: int `In` PGIntegral

69− => Operator (null int) (null int) (null int)

70−rem_ = unsafeBinaryOp "%"

71−

72−-- | >>> :{

73−-- let

74−-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)

75−-- expression = trunc pi

76−-- in printSQL expression

77−-- :}

78−-- trunc(pi())

79−trunc :: frac `In` PGFloating => null frac --> null frac

80−trunc = unsafeFunction "trunc"

81−

82−-- | >>> :{

83−-- let

84−-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)

85−-- expression = round_ pi

86−-- in printSQL expression

87−-- :}

88−-- round(pi())

89−round_ :: frac `In` PGFloating => null frac --> null frac

90−round_ = unsafeFunction "round"

91−

92−-- | >>> :{

93−-- let

94−-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)

95−-- expression = ceiling_ pi

96−-- in printSQL expression

97−-- :}

98−-- ceiling(pi())

99−ceiling_ :: frac `In` PGFloating => null frac --> null frac

100−ceiling_ = unsafeFunction "ceiling"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hsdeleted−104

@@ -1,104 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.Null

3−Description: Null

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Null values and null handling functions

9−-}

10−

11−{-# LANGUAGE

12− DataKinds

13− , OverloadedStrings

14− , TypeOperators

15−#-}

16−

17−module Squeal.PostgreSQL.Expression.Null

18− ( null_

19− , notNull

20− , coalesce

21− , fromNull

22− , isNull

23− , isNotNull

24− , matchNull

25− , nullIf

26− ) where

27−

28−import Squeal.PostgreSQL.Expression

29−import Squeal.PostgreSQL.Expression.Logic

30−import Squeal.PostgreSQL.Render

31−import Squeal.PostgreSQL.Schema

32−

33−-- $setup

34−-- >>> import Squeal.PostgreSQL

35−

36−-- | analagous to `Nothing`

37−--

38−-- >>> printSQL null_

39−-- NULL

40−null_ :: Expr ('Null ty)

41−null_ = UnsafeExpression "NULL"

42−

43−-- | analagous to `Just`

44−--

45−-- >>> printSQL $ notNull true

46−-- TRUE

47−notNull :: 'NotNull ty --> 'Null ty

48−notNull = UnsafeExpression . renderSQL

49−

50−-- | return the leftmost value which is not NULL

51−--

52−-- >>> printSQL $ coalesce [null_, true] false

53−-- COALESCE(NULL, TRUE, FALSE)

54−coalesce :: FunctionVar ('Null ty) ('NotNull ty) ('NotNull ty)

55−coalesce nullxs notNullx = UnsafeExpression $

56− "COALESCE" <> parenthesized (commaSeparated

57− ((renderSQL <$> nullxs) <> [renderSQL notNullx]))

58−

59−-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@

60−--

61−-- >>> printSQL $ fromNull true null_

62−-- COALESCE(NULL, TRUE)

63−fromNull

64− :: Expression outer commons grp schemas params from ('NotNull ty)

65− -- ^ what to convert @NULL@ to

66− -> Expression outer commons grp schemas params from ('Null ty)

67− -> Expression outer commons grp schemas params from ('NotNull ty)

68−fromNull notNullx nullx = coalesce [nullx] notNullx

69−

70−-- | >>> printSQL $ null_ & isNull

71−-- NULL IS NULL

72−isNull :: 'Null ty --> null 'PGbool

73−isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"

74−

75−-- | >>> printSQL $ null_ & isNotNull

76−-- NULL IS NOT NULL

77−isNotNull :: 'Null ty --> null 'PGbool

78−isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"

79−

80−-- | analagous to `maybe` using @IS NULL@

81−--

82−-- >>> printSQL $ matchNull true not_ null_

83−-- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END

84−matchNull

85− :: Expression outer commons grp schemas params from (nullty)

86− -- ^ what to convert @NULL@ to

87− -> ( Expression outer commons grp schemas params from ('NotNull ty)

88− -> Expression outer commons grp schemas params from (nullty) )

89− -- ^ function to perform when @NULL@ is absent

90− -> Expression outer commons grp schemas params from ('Null ty)

91− -> Expression outer commons grp schemas params from (nullty)

92−matchNull y f x = ifThenElse (isNull x) y

93− (f (UnsafeExpression (renderSQL x)))

94−

95−{-| right inverse to `fromNull`, if its arguments are equal then

96−`nullIf` gives @NULL@.

97−

98−>>> :set -XTypeApplications -XDataKinds

99−>>> let expr = nullIf (false *: param @1) :: Expression outer commons grp schemas '[ 'NotNull 'PGbool] from ('Null 'PGbool)

100−>>> printSQL expr

101−NULLIF(FALSE, ($1 :: bool))

102−-}

103−nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty

104−nullIf = unsafeFunctionN "NULLIF"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hsdeleted−80

@@ -1,80 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.Parameter

3−Description: Parameters

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Parameters, out-of-line data values

9−-}

10−

11−{-# LANGUAGE

12− AllowAmbiguousTypes

13− , DataKinds

14− , FlexibleContexts

15− , FlexibleInstances

16− , FunctionalDependencies

17− , KindSignatures

18− , MultiParamTypeClasses

19− , OverloadedStrings

20− , RankNTypes

21− , ScopedTypeVariables

22− , TypeApplications

23− , TypeOperators

24− , UndecidableInstances

25−#-}

26−

27−module Squeal.PostgreSQL.Expression.Parameter

28− ( HasParameter (parameter)

29− , param

30− ) where

31−

32−import GHC.TypeLits

33−

34−import Squeal.PostgreSQL.Expression

35−import Squeal.PostgreSQL.Expression.Type

36−import Squeal.PostgreSQL.Render

37−import Squeal.PostgreSQL.Schema

38−

39−-- $setup

40−-- >>> import Squeal.PostgreSQL

41−

42−{- | A `HasParameter` constraint is used to indicate a value that is

43−supplied externally to a SQL statement.

44−`Squeal.PostgreSQL.PQ.manipulateParams`,

45−`Squeal.PostgreSQL.PQ.queryParams` and

46−`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values

47−separately from the SQL command string, in which case `param`s are used to

48−refer to the out-of-line data values.

49−-}

50−class KnownNat n => HasParameter

51− (n :: Nat)

52− (params :: [NullityType])

53− (ty :: NullityType)

54− | n params -> ty where

55− -- | `parameter` takes a `Nat` using type application and a `TypeExpression`.

56− --

57− -- >>> let expr = parameter @1 int4 :: Expression outer '[] grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)

58− -- >>> printSQL expr

59− -- ($1 :: int4)

60− parameter

61− :: TypeExpression schemas ty

62− -> Expression outer commons grp schemas params from ty

63− parameter ty = UnsafeExpression $ parenthesized $

64− "$" <> renderNat @n <+> "::"

65− <+> renderSQL ty

66−instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1

67−instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)

68− => HasParameter n (ty' : params) ty

69−

70−-- | `param` takes a `Nat` using type application and for basic types,

71−-- infers a `TypeExpression`.

72−--

73−-- >>> let expr = param @1 :: Expression outer commons grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)

74−-- >>> printSQL expr

75−-- ($1 :: int4)

76−param

77− :: forall n outer commons schemas params from grp ty

78− . (PGTyped schemas ty, HasParameter n params ty)

79− => Expression outer commons grp schemas params from ty -- ^ param

80−param = parameter @n (pgtype @schemas)

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hsdeleted−230

@@ -1,230 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.Range

3−Description: range types and functions

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Range types and functions

9−-}

10−

11−{-# LANGUAGE

12− AllowAmbiguousTypes

13− , DataKinds

14− , DeriveAnyClass

15− , DeriveGeneric

16− , DeriveFoldable

17− , DerivingStrategies

18− , DeriveTraversable

19− , FlexibleContexts

20− , FlexibleInstances

21− , LambdaCase

22− , MultiParamTypeClasses

23− , OverloadedLabels

24− , OverloadedStrings

25− , PatternSynonyms

26− , RankNTypes

27− , ScopedTypeVariables

28− , TypeApplications

29− , TypeFamilies

30− , TypeOperators

31− , UndecidableInstances

32−#-}

33−

34−module Squeal.PostgreSQL.Expression.Range

35− ( range

36− , Range (..)

37− , (<=..<=), (<..<), (<=..<), (<..<=)

38− , moreThan, atLeast, lessThan, atMost

39− , singleton, whole

40− , Bound (..)

41− , (.<@)

42− , (@>.)

43− , (<<@)

44− , (@>>)

45− , (&<)

46− , (&>)

47− , (-|-)

48− , (@+)

49− , (@*)

50− , (@-)

51− , lowerBound

52− , upperBound

53− , isEmpty

54− , lowerInc

55− , lowerInf

56− , upperInc

57− , upperInf

58− , rangeMerge

59− ) where

60−

61−import BinaryParser

62−import ByteString.StrictBuilder

63−import Data.Bits

64−import qualified GHC.Generics as GHC

65−import qualified Generics.SOP as SOP

66−import qualified PostgreSQL.Binary.Decoding as Decoding

67−

68−import Squeal.PostgreSQL.Binary

69−import Squeal.PostgreSQL.Expression

70−import Squeal.PostgreSQL.Expression.Type hiding (bool)

71−import Squeal.PostgreSQL.PG

72−import Squeal.PostgreSQL.Render

73−import Squeal.PostgreSQL.Schema

74−

75−-- $setup

76−-- >>> import Squeal.PostgreSQL

77−

78−-- | Construct a `range`

79−--

80−-- >>> printSQL $ range tstzrange (atLeast now)

81−-- tstzrange(now(), NULL, '[)')

82−-- >>> printSQL $ range numrange (0 <=..< 2*pi)

83−-- numrange(0, (2 * pi()), '[)')

84−-- >>> printSQL $ range int4range Empty

85−-- ('empty' :: int4range)

86−range

87− :: TypeExpression schemas (null ('PGrange ty))

88− -> Range (Expression outer commons grp schemas params from ('NotNull ty))

89− -> Expression outer commons grp schemas params from (null ('PGrange ty))

90−range ty = \case

91− Empty -> UnsafeExpression $ parenthesized

92− (emp <+> "::" <+> renderSQL ty)

93− NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized

94− (commaSeparated (args l u))

95− where

96− emp = singleQuote <> "empty" <> singleQuote

97− args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote]

98− singleQuote = "\'"

99− arg = \case

100− Infinite -> "NULL"; Closed x -> renderSQL x; Open x -> renderSQL x

101− bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "("

102− ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")"

103−

104−data Bound x = Infinite | Closed x | Open x

105− deriving

106− ( Eq, Ord, Show, Read, GHC.Generic

107− , Functor, Foldable, Traversable )

108−

109−data Range x = Empty | NonEmpty (Bound x) (Bound x)

110− deriving

111− ( Eq, Ord, Show, Read, GHC.Generic

112− , Functor, Foldable, Traversable )

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

114−type instance PG (Range x) = 'PGrange (PG x)

115−instance ToParam x pg => ToParam (Range x) ('PGrange pg) where

116− toParam rng = K $

117− word8 (setFlags rng 0) <>

118− case rng of

119− Empty -> mempty

120− NonEmpty lower upper -> putBound lower <> putBound upper

121− where

122− putBound = \case

123− Infinite -> mempty

124− Closed value -> putValue (unK (toParam @x @pg value))

125− Open value -> putValue (unK (toParam @x @pg value))

126− putValue value = int32BE (fromIntegral (builderLength value)) <> value

127− setFlags = \case

128− Empty -> (`setBit` 0)

129− NonEmpty lower upper ->

130− setLowerFlags lower . setUpperFlags upper

131− setLowerFlags = \case

132− Infinite -> (`setBit` 3)

133− Closed _ -> (`setBit` 1)

134− Open _ -> id

135− setUpperFlags = \case

136− Infinite -> (`setBit` 4)

137− Closed _ -> (`setBit` 2)

138− Open _ -> id

139−instance FromValue pg y => FromValue ('PGrange pg) (Range y) where

140− fromValue = do

141− flag <- byte

142− if testBit flag 0 then return Empty else do

143− lower <-

144− if testBit flag 3

145− then return Infinite

146− else do

147− len <- sized 4 Decoding.int

148− l <- sized len (fromValue @pg)

149− return $ if testBit flag 1 then Closed l else Open l

150− upper <-

151− if testBit flag 4

152− then return Infinite

153− else do

154− len <- sized 4 Decoding.int

155− l <- sized len (fromValue @pg)

156− return $ if testBit flag 2 then Closed l else Open l

157− return $ NonEmpty lower upper

158−

159−(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x

160−infix 4 <=..<=, <..<, <=..<, <..<=

161−x <=..<= y = NonEmpty (Closed x) (Closed y)

162−x <..< y = NonEmpty (Open x) (Open y)

163−x <=..< y = NonEmpty (Closed x) (Open y)

164−x <..<= y = NonEmpty (Open x) (Closed y)

165−

166−moreThan, atLeast, lessThan, atMost :: x -> Range x

167−moreThan x = NonEmpty (Open x) Infinite

168−atLeast x = NonEmpty (Closed x) Infinite

169−lessThan x = NonEmpty Infinite (Open x)

170−atMost x = NonEmpty Infinite (Closed x)

171−

172−singleton :: x -> Range x

173−singleton x = x <=..<= x

174−

175−whole :: Range x

176−whole = NonEmpty Infinite Infinite

177−

178−(.<@) :: Operator ('NotNull ty) (null ('PGrange ty)) ('Null 'PGbool)

179−(.<@) = unsafeBinaryOp "<@"

180−

181−(@>.) :: Operator (null ('PGrange ty)) ('NotNull ty) ('Null 'PGbool)

182−(@>.) = unsafeBinaryOp "<@"

183−

184−(<<@) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)

185−(<<@) = unsafeBinaryOp "<<"

186−

187−(@>>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)

188−(@>>) = unsafeBinaryOp ">>"

189−

190−(&<) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)

191−(&<) = unsafeBinaryOp "&<"

192−

193−(&>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)

194−(&>) = unsafeBinaryOp "&>"

195−

196−(-|-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)

197−(-|-) = unsafeBinaryOp "-|-"

198−

199−(@+) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))

200−(@+) = unsafeBinaryOp "+"

201−

202−(@*) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))

203−(@*) = unsafeBinaryOp "*"

204−

205−(@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))

206−(@-) = unsafeBinaryOp "-"

207−

208−lowerBound :: null ('PGrange ty) --> 'Null ty

209−lowerBound = unsafeFunction "lower"

210−

211−upperBound :: null ('PGrange ty) --> 'Null ty

212−upperBound = unsafeFunction "upper"

213−

214−isEmpty :: null ('PGrange ty) --> 'Null 'PGbool

215−isEmpty = unsafeFunction "isempty"

216−

217−lowerInc :: null ('PGrange ty) --> 'Null 'PGbool

218−lowerInc = unsafeFunction "lower_inc"

219−

220−lowerInf :: null ('PGrange ty) --> 'Null 'PGbool

221−lowerInf = unsafeFunction "lower_inf"

222−

223−upperInc :: null ('PGrange ty) --> 'Null 'PGbool

224−upperInc = unsafeFunction "upper_inc"

225−

226−upperInf :: null ('PGrange ty) --> 'Null 'PGbool

227−upperInf = unsafeFunction "upper_inf"

228−

229−rangeMerge :: '[null ('PGrange ty), null ('PGrange ty)] ---> null ('PGrange ty)

230−rangeMerge = unsafeFunctionN "range_merge"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Set.hsdeleted−139

@@ -1,139 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.Set

3−Description: Set returning functions

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Set returning functions

9−-}

10−

11−{-# LANGUAGE

12− AllowAmbiguousTypes

13− , DataKinds

14− , FlexibleContexts

15− , OverloadedStrings

16− , PolyKinds

17− , RankNTypes

18− , ScopedTypeVariables

19− , TypeApplications

20− , TypeOperators

21−#-}

22−

23−module Squeal.PostgreSQL.Expression.Set

24− ( generateSeries

25− , generateSeriesStep

26− , generateSeriesTimestamp

27− , SetFunction

28− , unsafeSetFunction

29− , SetFunctionDB

30− , setFunction

31− , SetFunctionN

32− , unsafeSetFunctionN

33− , SetFunctionNDB

34− , setFunctionN

35− ) where

36−

37−import GHC.TypeLits

38−

39−import qualified Generics.SOP as SOP

40−

41−import Squeal.PostgreSQL.Alias

42−import Squeal.PostgreSQL.Expression

43−import Squeal.PostgreSQL.List

44−import Squeal.PostgreSQL.Render

45−import Squeal.PostgreSQL.Query

46−import Squeal.PostgreSQL.Schema

47−

48−{- |

49−A @RankNType@ for set returning functions with 1 argument.

50−-}

51−type SetFunction fun ty row

52− = forall outer commons schemas params

53− . Expression outer commons 'Ungrouped schemas params '[] ty

54− -- ^ input

55− -> FromClause outer commons schemas params '[fun ::: row]

56− -- ^ output

57−

58−type SetFunctionDB fun schemas ty row

59− = forall outer commons params

60− . Expression outer commons 'Ungrouped schemas params '[] ty

61− -- ^ input

62− -> FromClause outer commons schemas params '[fun ::: row]

63− -- ^ output

64−

65−-- | Escape hatch for a set returning function with 1 argument.

66−unsafeSetFunction

67− :: forall fun ty row. KnownSymbol fun

68− => SetFunction fun ty row -- ^ set returning function

69−unsafeSetFunction x = UnsafeFromClause $

70− renderSymbol @fun <> parenthesized (renderSQL x)

71−

72−setFunction

73− :: ( Has sch schemas schema

74− , Has fun schema ('Function ('[ty] :=> 'ReturnsTable row)) )

75− => QualifiedAlias sch fun

76− -> SetFunctionDB fun schemas ty row

77−setFunction _ = unsafeSetFunction

78−

79−{- |

80−A @RankNType@ for set returning functions with multiple argument.

81−-}

82−type SetFunctionN fun tys row

83− = forall outer commons schemas params

84− . NP (Expression outer commons 'Ungrouped schemas params '[]) tys

85− -- ^ inputs

86− -> FromClause outer commons schemas params '[fun ::: row]

87− -- ^ output

88−

89−-- | Escape hatch for a set returning function with multiple argument.

90−unsafeSetFunctionN

91− :: forall fun tys row. (SOP.SListI tys, KnownSymbol fun)

92− => SetFunctionN fun tys row -- ^ set returning function

93−unsafeSetFunctionN xs = UnsafeFromClause $

94− renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)

95−

96−type SetFunctionNDB fun schemas tys row

97− = forall outer commons params

98− . NP (Expression outer commons 'Ungrouped schemas params '[]) tys

99− -- ^ inputs

100− -> FromClause outer commons schemas params '[fun ::: row]

101− -- ^ output

102−

103−setFunctionN

104− :: ( Has sch schemas schema

105− , Has fun schema ('Function (tys :=> 'ReturnsTable row))

106− , SOP.SListI tys )

107− => QualifiedAlias sch fun

108− -> SetFunctionNDB fun schemas tys row

109−setFunctionN _ = unsafeSetFunctionN

110−

111−{- | @generateSeries (start *: stop)@

112−

113−Generate a series of values, from @start@ to @stop@ with a step size of one

114−-}

115−generateSeries

116− :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]

117− => SetFunctionN "generate_series" '[ null ty, null ty]

118− '["generate_series" ::: null ty] -- ^ set returning function

119−generateSeries = unsafeSetFunctionN

120−

121−{- | @generateSeries (start :* stop *: step)@

122−

123−Generate a series of values, from @start@ to @stop@ with a step size of @step@

124−-}

125−generateSeriesStep

126− :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]

127− => SetFunctionN "generate_series" '[null ty, null ty, null ty]

128− '["generate_series" ::: null ty] -- ^ set returning function

129−generateSeriesStep = unsafeSetFunctionN

130−

131−{- | @generateSeries (start :* stop *: step)@

132−

133−Generate a series of values, from @start@ to @stop@ with a step size of @step@

134−-}

135−generateSeriesTimestamp

136− :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]

137− => SetFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]

138− '["generate_series" ::: null ty] -- ^ set returning function

139−generateSeriesTimestamp = unsafeSetFunctionN

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hsdeleted−85

@@ -1,85 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.Sort

3−Description: Sort expressions

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Sort expressions

9−-}

10−

11−{-# LANGUAGE

12− DataKinds

13− , GADTs

14− , LambdaCase

15− , OverloadedStrings

16− , StandaloneDeriving

17−#-}

18−

19−module Squeal.PostgreSQL.Expression.Sort

20− ( SortExpression (..)

21− , OrderBy (..)

22− ) where

23−

24−import Squeal.PostgreSQL.Expression

25−import Squeal.PostgreSQL.Render

26−import Squeal.PostgreSQL.Schema

27−

28−-- | `SortExpression`s are used by `orderBy` to optionally sort the results

29−-- of a `Squeal.PostgreSQL.Query.Query`. `Asc` or `Desc`

30−-- set the sort direction of a `NotNull` result

31−-- column to ascending or descending. Ascending order puts smaller values

32−-- first, where "smaller" is defined in terms of the

33−-- `Squeal.PostgreSQL.Expression.Comparison..<` operator. Similarly,

34−-- descending order is determined with the

35−-- `Squeal.PostgreSQL.Expression.Comparison..>` operator. `AscNullsFirst`,

36−-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to

37−-- determine whether nulls appear before or after non-null values in the sort

38−-- ordering of a `Null` result column.

39−data SortExpression outer commons grp schemas params from where

40− Asc

41− :: Expression outer commons grp schemas params from ('NotNull ty)

42− -> SortExpression outer commons grp schemas params from

43− Desc

44− :: Expression outer commons grp schemas params from ('NotNull ty)

45− -> SortExpression outer commons grp schemas params from

46− AscNullsFirst

47− :: Expression outer commons grp schemas params from ('Null ty)

48− -> SortExpression outer commons grp schemas params from

49− AscNullsLast

50− :: Expression outer commons grp schemas params from ('Null ty)

51− -> SortExpression outer commons grp schemas params from

52− DescNullsFirst

53− :: Expression outer commons grp schemas params from ('Null ty)

54− -> SortExpression outer commons grp schemas params from

55− DescNullsLast

56− :: Expression outer commons grp schemas params from ('Null ty)

57− -> SortExpression outer commons grp schemas params from

58−deriving instance Show (SortExpression outer commons grp schemas params from)

59−instance RenderSQL (SortExpression outer commons grp schemas params from) where

60− renderSQL = \case

61− Asc expression -> renderSQL expression <+> "ASC"

62− Desc expression -> renderSQL expression <+> "DESC"

63− AscNullsFirst expression -> renderSQL expression

64− <+> "ASC NULLS FIRST"

65− DescNullsFirst expression -> renderSQL expression

66− <+> "DESC NULLS FIRST"

67− AscNullsLast expression -> renderSQL expression <+> "ASC NULLS LAST"

68− DescNullsLast expression -> renderSQL expression <+> "DESC NULLS LAST"

69−

70−{- |

71−The `orderBy` clause causes the result rows of a `Squeal.PostgreSQL.Query.TableExpression`

72−to be sorted according to the specified `SortExpression`(s).

73−If two rows are equal according to the leftmost expression,

74−they are compared according to the next expression and so on.

75−If they are equal according to all specified expressions,

76−they are returned in an implementation-dependent order.

77−

78−You can also control the order in which rows are processed by window functions

79−using `orderBy` within `Squeal.PostgreSQL.Query.Over`.

80−-}

81−class OrderBy expr where

82− orderBy

83− :: [SortExpression outer commons grp schemas params from]

84− -> expr outer commons grp schemas params from

85− -> expr outer commons grp schemas params from

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hsdeleted−120

@@ -1,120 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.Subquery

3−Description: Subquery expressions

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Subquery expressions

9−-}

10−

11−{-# LANGUAGE

12− DataKinds

13− , OverloadedStrings

14− , RankNTypes

15− , TypeOperators

16−#-}

17−

18−module Squeal.PostgreSQL.Expression.Subquery

19− ( exists

20− , in_

21− , notIn

22− , subAll

23− , subAny

24− ) where

25−

26−import Squeal.PostgreSQL.Alias

27−import Squeal.PostgreSQL.Expression

28−import Squeal.PostgreSQL.Expression.Logic

29−import Squeal.PostgreSQL.List

30−import Squeal.PostgreSQL.Query

31−import Squeal.PostgreSQL.Render

32−import Squeal.PostgreSQL.Schema

33−

34−-- $setup

35−-- >>> import Squeal.PostgreSQL

36−

37−{- |

38−The argument of `exists` is an arbitrary subquery. The subquery is evaluated

39−to determine whether it returns any rows. If it returns at least one row,

40−the result of `exists` is `true`; if the subquery returns no rows,

41−the result of `exists` is `false`.

42−

43−The subquery can refer to variables from the surrounding query,

44−which will act as constants during any one evaluation of the subquery.

45−

46−The subquery will generally only be executed long enough to determine whether

47−at least one row is returned, not all the way to completion.

48−-}

49−exists

50− :: Query (Join outer from) commons schemas params row

51− -> Condition outer commons grp schemas params from

52−exists query = UnsafeExpression $ "EXISTS" <+> parenthesized (renderSQL query)

53−

54−{- |

55−The right-hand side is a parenthesized subquery, which must return

56−exactly one column. The left-hand expression is evaluated and compared to each

57−row of the subquery result using the given `Operator`,

58−which must yield a Boolean result. The result of `subAll` is `true`

59−if all rows yield true (including the case where the subquery returns no rows).

60−The result is `false` if any `false` result is found.

61−The result is `Squeal.PostgreSQL.Expression.Null.null_` if

62− no comparison with a subquery row returns `false`,

63−and at least one comparison returns `Squeal.PostgreSQL.Expression.Null.null_`.

64−

65−>>> printSQL $ subAll true (.==) (values_ (true `as` #foo))

66−(TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo")))

67−-}

68−subAll

69− :: Expression outer commons grp schemas params from ty1 -- ^ expression

70− -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator

71− -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery

72− -> Condition outer commons grp schemas params from

73−subAll expr (?) qry = expr ?

74− (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL qry))

75−

76−{- |

77−The right-hand side is a parenthesized subquery, which must return exactly one column.

78−The left-hand expression is evaluated and compared to each row of the subquery result

79−using the given `Operator`, which must yield a Boolean result. The result of `subAny` is `true`

80−if any `true` result is obtained. The result is `false` if no true result is found

81−(including the case where the subquery returns no rows).

82−

83−>>> printSQL $ subAny "foo" like (values_ ("foobar" `as` #foo))

84−(E'foo' LIKE ANY (SELECT * FROM (VALUES (E'foobar')) AS t ("foo")))

85−-}

86−subAny

87− :: Expression outer commons grp schemas params from ty1 -- ^ expression

88− -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator

89− -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery

90− -> Condition outer commons grp schemas params from

91−subAny expr (?) qry = expr ?

92− (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL qry))

93−

94−{- |

95−The result is `true` if the left-hand expression's result is equal

96−to any of the right-hand expressions.

97−

98−>>> printSQL $ true `in_` [true, false, null_]

99−TRUE IN (TRUE, FALSE, NULL)

100−-}

101−in_

102− :: Expression outer commons grp schemas params from ty -- ^ expression

103− -> [Expression outer commons grp schemas params from ty]

104− -> Condition outer commons grp schemas params from

105−expr `in_` exprs = UnsafeExpression $ renderSQL expr <+> "IN"

106− <+> parenthesized (commaSeparated (renderSQL <$> exprs))

107−

108−{- |

109−The result is `true` if the left-hand expression's result is not equal

110−to any of the right-hand expressions.

111−

112−>>> printSQL $ true `notIn` [false, null_]

113−TRUE NOT IN (FALSE, NULL)

114−-}

115−notIn

116− :: Expression outer commons grp schemas params from ty -- ^ expression

117− -> [Expression outer commons grp schemas params from ty]

118− -> Condition outer commons grp schemas params from

119−expr `notIn` exprs = UnsafeExpression $ renderSQL expr <+> "NOT IN"

120− <+> parenthesized (commaSeparated (renderSQL <$> exprs))

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hsdeleted−64

@@ -1,64 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.Text

3−Description: Text expressions

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−String functions and operators

9−-}

10−

11−{-# LANGUAGE

12− DataKinds

13− , OverloadedStrings

14− , TypeOperators

15−#-}

16−

17−module Squeal.PostgreSQL.Expression.Text

18− ( lower

19− , upper

20− , charLength

21− , like

22− , ilike

23− ) where

24−

25−import Squeal.PostgreSQL.Expression

26−import Squeal.PostgreSQL.Schema

27−

28−-- $setup

29−-- >>> import Squeal.PostgreSQL

30−

31−-- | >>> printSQL $ lower "ARRRGGG"

32−-- lower(E'ARRRGGG')

33−lower :: null 'PGtext --> null 'PGtext

34−lower = unsafeFunction "lower"

35−

36−-- | >>> printSQL $ upper "eeee"

37−-- upper(E'eeee')

38−upper :: null 'PGtext --> null 'PGtext

39−upper = unsafeFunction "upper"

40−

41−-- | >>> printSQL $ charLength "four"

42−-- char_length(E'four')

43−charLength :: null 'PGtext --> null 'PGint4

44−charLength = unsafeFunction "char_length"

45−

46−-- | The `like` expression returns true if the @string@ matches

47−-- the supplied @pattern@. If @pattern@ does not contain percent signs

48−-- or underscores, then the pattern only represents the string itself;

49−-- in that case `like` acts like the equals operator. An underscore (_)

50−-- in pattern stands for (matches) any single character; a percent sign (%)

51−-- matches any sequence of zero or more characters.

52−--

53−-- >>> printSQL $ "abc" `like` "a%"

54−-- (E'abc' LIKE E'a%')

55−like :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)

56−like = unsafeBinaryOp "LIKE"

57−

58−-- | The key word ILIKE can be used instead of LIKE to make the

59−-- match case-insensitive according to the active locale.

60−--

61−-- >>> printSQL $ "abc" `ilike` "a%"

62−-- (E'abc' ILIKE E'a%')

63−ilike :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)

64−ilike = unsafeBinaryOp "ILIKE"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hsdeleted−157

@@ -1,157 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.TextSearch

3−Description: Text search expressions

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Text search functions and operators

9−-}

10−

11−{-# LANGUAGE

12− DataKinds

13− , OverloadedStrings

14− , TypeOperators

15−#-}

16−

17−module Squeal.PostgreSQL.Expression.TextSearch

18− ( (@@)

19− , (.&)

20− , (.|)

21− , (.!)

22− , (<->)

23− , arrayToTSvector

24− , tsvectorLength

25− , numnode

26− , plainToTSquery

27− , phraseToTSquery

28− , websearchToTSquery

29− , queryTree

30− , toTSquery

31− , toTSvector

32− , setWeight

33− , strip

34− , jsonToTSvector

35− , jsonbToTSvector

36− , tsDelete

37− , tsFilter

38− , tsHeadline

39− ) where

40−

41−import Squeal.PostgreSQL.Expression

42−import Squeal.PostgreSQL.List

43−import Squeal.PostgreSQL.Schema

44−

45−-- | `Squeal.PostgreSQL.Expression.Type.tsvector` matches tsquery ?

46−(@@) :: Operator (null 'PGtsvector) (null 'PGtsquery) ('Null 'PGbool)

47−(@@) = unsafeBinaryOp "@@"

48−

49−-- | AND `Squeal.PostgreSQL.Expression.Type.tsquery`s together

50−(.&) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)

51−(.&) = unsafeBinaryOp "&&"

52−

53−-- | OR `Squeal.PostgreSQL.Expression.Type.tsquery`s together

54−(.|) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)

55−(.|) = unsafeBinaryOp "||"

56−

57−-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`

58−(.!) :: null 'PGtsquery --> null 'PGtsquery

59−(.!) = unsafeLeftOp "!!"

60−

61−-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by

62−-- `Squeal.PostgreSQL.Expression.Type.tsquery`

63−(<->) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)

64−(<->) = unsafeBinaryOp "<->"

65−

66−-- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector`

67−arrayToTSvector

68− :: null ('PGvararray ('NotNull 'PGtext))

69− --> null 'PGtsvector

70−arrayToTSvector = unsafeFunction "array_to_tsvector"

71−

72−-- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`

73−tsvectorLength :: null 'PGtsvector --> null 'PGint4

74−tsvectorLength = unsafeFunction "length"

75−

76−-- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`

77−numnode :: null 'PGtsquery --> null 'PGint4

78−numnode = unsafeFunction "numnode"

79−

80−-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation

81−plainToTSquery :: null 'PGtext --> null 'PGtsquery

82−plainToTSquery = unsafeFunction "plainto_tsquery"

83−

84−-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase,

85−-- ignoring punctuation

86−phraseToTSquery :: null 'PGtext --> null 'PGtsquery

87−phraseToTSquery = unsafeFunction "phraseto_tsquery"

88−

89−-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query

90−websearchToTSquery :: null 'PGtext --> null 'PGtsquery

91−websearchToTSquery = unsafeFunction "websearch_to_tsquery"

92−

93−-- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`

94−queryTree :: null 'PGtsquery --> null 'PGtext

95−queryTree = unsafeFunction "query_tree"

96−

97−-- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`

98−toTSquery :: null 'PGtext --> null 'PGtsquery

99−toTSquery = unsafeFunction "to_tsquery"

100−

101−-- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector`

102−toTSvector

103− :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]

104− => null ty --> null 'PGtsvector

105−toTSvector = unsafeFunction "to_tsvector"

106−

107−-- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`

108−setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector

109−setWeight = unsafeFunctionN "set_weight"

110−

111−-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`

112−strip :: null 'PGtsvector --> null 'PGtsvector

113−strip = unsafeFunction "strip"

114−

115−-- | @jsonToTSvector (document *: filter)@

116−-- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,

117−-- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.

118−-- filter is a `Squeal.PostgreSQL.Expression.Type.json` array, that enumerates what kind of elements

119−-- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.

120−-- Possible values for filter are "string" (to include all string values),

121−-- "numeric" (to include all numeric values in the string format),

122−-- "boolean" (to include all Boolean values in the string format "true"/"false"),

123−-- "key" (to include all keys) or "all" (to include all above).

124−-- These values can be combined together to include, e.g. all string and numeric values.

125−jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector

126−jsonToTSvector = unsafeFunctionN "json_to_tsvector"

127−

128−-- | @jsonbToTSvector (document *: filter)@

129−-- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,

130−-- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.

131−-- filter is a `Squeal.PostgreSQL.Expression.Type.jsonb` array, that enumerates what kind of elements

132−-- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.

133−-- Possible values for filter are "string" (to include all string values),

134−-- "numeric" (to include all numeric values in the string format),

135−-- "boolean" (to include all Boolean values in the string format "true"/"false"),

136−-- "key" (to include all keys) or "all" (to include all above).

137−-- These values can be combined together to include, e.g. all string and numeric values.

138−jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector

139−jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"

140−

141−-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`

142−tsDelete ::

143− '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]

144− ---> null 'PGtsvector

145−tsDelete = unsafeFunctionN "ts_delete"

146−

147−-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`

148−tsFilter ::

149− '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]

150− ---> null 'PGtsvector

151−tsFilter = unsafeFunctionN "ts_filter"

152−

153−-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match

154−tsHeadline

155− :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]

156− => '[null document, null 'PGtsquery] ---> null 'PGtext

157−tsHeadline = unsafeFunctionN "ts_headline"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hsdeleted−192

@@ -1,192 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.Time

3−Description: Date/Time expressions

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Date/Time functions and operators

9−-}

10−

11−{-# LANGUAGE

12− DataKinds

13− , DeriveGeneric

14− , FunctionalDependencies

15− , LambdaCase

16− , MultiParamTypeClasses

17− , OverloadedStrings

18− , PolyKinds

19− , RankNTypes

20− , TypeOperators

21−#-}

22−

23−module Squeal.PostgreSQL.Expression.Time

24− ( TimeOp (..)

25− , currentDate

26− , currentTime

27− , currentTimestamp

28− , localTime

29− , localTimestamp

30− , now

31− , makeDate

32− , makeTime

33− , makeTimestamp

34− , makeTimestamptz

35− , interval_

36− , TimeUnit (..)

37− ) where

38−

39−import Data.String

40−

41−import qualified GHC.Generics as GHC

42−import qualified Generics.SOP as SOP

43−

44−import Squeal.PostgreSQL.Expression

45−import Squeal.PostgreSQL.Render

46−import Squeal.PostgreSQL.Schema

47−

48−-- $setup

49−-- >>> import Squeal.PostgreSQL

50−

51−-- | >>> printSQL currentDate

52−-- CURRENT_DATE

53−currentDate :: Expr (null 'PGdate)

54−currentDate = UnsafeExpression "CURRENT_DATE"

55−

56−-- | >>> printSQL currentTime

57−-- CURRENT_TIME

58−currentTime :: Expr (null 'PGtimetz)

59−currentTime = UnsafeExpression "CURRENT_TIME"

60−

61−-- | >>> printSQL currentTimestamp

62−-- CURRENT_TIMESTAMP

63−currentTimestamp :: Expr (null 'PGtimestamptz)

64−currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"

65−

66−-- | >>> printSQL localTime

67−-- LOCALTIME

68−localTime :: Expr (null 'PGtime)

69−localTime = UnsafeExpression "LOCALTIME"

70−

71−-- | >>> printSQL localTimestamp

72−-- LOCALTIMESTAMP

73−localTimestamp :: Expr (null 'PGtimestamp)

74−localTimestamp = UnsafeExpression "LOCALTIMESTAMP"

75−

76−-- | Current date and time (equivalent to `currentTimestamp`)

77−--

78−-- >>> printSQL now

79−-- now()

80−now :: Expr (null 'PGtimestamptz)

81−now = UnsafeExpression "now()"

82−

83−{-|

84−Create date from year, month and day fields

85−

86−>>> printSQL (makeDate (1984 :* 7 *: 3))

87−make_date(1984, 7, 3)

88−-}

89−makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate

90−makeDate = unsafeFunctionN "make_date"

91−

92−{-|

93−Create time from hour, minute and seconds fields

94−

95−>>> printSQL (makeTime (8 :* 15 *: 23.5))

96−make_time(8, 15, 23.5)

97−-}

98−makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime

99−makeTime = unsafeFunctionN "make_time"

100−

101−{-|

102−Create timestamp from year, month, day, hour, minute and seconds fields

103−

104−>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))

105−make_timestamp(2013, 7, 15, 8, 15, 23.5)

106−-}

107−makeTimestamp ::

108− '[ null 'PGint4, null 'PGint4, null 'PGint4

109− , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp

110−makeTimestamp = unsafeFunctionN "make_timestamp"

111−

112−{-|

113−Create timestamp with time zone from

114−year, month, day, hour, minute and seconds fields;

115−the current time zone is used

116−

117−>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))

118−make_timestamptz(2013, 7, 15, 8, 15, 23.5)

119−-}

120−makeTimestamptz ::

121− '[ null 'PGint4, null 'PGint4, null 'PGint4

122− , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz

123−makeTimestamptz = unsafeFunctionN "make_timestamptz"

124−

125−{-|

126−Affine space operations on time types.

127−-}

128−class TimeOp time diff | time -> diff where

129− {-|

130− >>> printSQL (makeDate (1984 :* 7 *: 3) !+ 365)

131− (make_date(1984, 7, 3) + 365)

132− -}

133− (!+) :: Operator (null time) (null diff) (null time)

134− (!+) = unsafeBinaryOp "+"

135− {-|

136− >>> printSQL (365 +! makeDate (1984 :* 7 *: 3))

137− (365 + make_date(1984, 7, 3))

138− -}

139− (+!) :: Operator (null diff) (null time) (null time)

140− (+!) = unsafeBinaryOp "+"

141− {-|

142− >>> printSQL (makeDate (1984 :* 7 *: 3) !- 365)

143− (make_date(1984, 7, 3) - 365)

144− -}

145− (!-) :: Operator (null time) (null diff) (null time)

146− (!-) = unsafeBinaryOp "-"

147− {-|

148− >>> printSQL (makeDate (1984 :* 7 *: 3) !-! currentDate)

149− (make_date(1984, 7, 3) - CURRENT_DATE)

150− -}

151− (!-!) :: Operator (null time) (null time) (null diff)

152− (!-!) = unsafeBinaryOp "-"

153−instance TimeOp 'PGtimestamp 'PGinterval

154−instance TimeOp 'PGtimestamptz 'PGinterval

155−instance TimeOp 'PGtime 'PGinterval

156−instance TimeOp 'PGtimetz 'PGinterval

157−instance TimeOp 'PGinterval 'PGinterval

158−instance TimeOp 'PGdate 'PGint4

159−infixl 6 !+

160−infixl 6 +!

161−infixl 6 !-

162−infixl 6 !-!

163−

164−-- | A `TimeUnit` to use in `interval_` construction.

165−data TimeUnit

166− = Years | Months | Weeks | Days

167− | Hours | Minutes | Seconds

168− | Microseconds | Milliseconds

169− | Decades | Centuries | Millennia

170− deriving (Eq, Ord, Show, Read, Enum, GHC.Generic)

171−instance SOP.Generic TimeUnit

172−instance SOP.HasDatatypeInfo TimeUnit

173−instance RenderSQL TimeUnit where

174− renderSQL = \case

175− Years -> "years"

176− Months -> "months"

177− Weeks -> "weeks"

178− Days -> "days"

179− Hours -> "hours"

180− Minutes -> "minutes"

181− Seconds -> "seconds"

182− Microseconds -> "microseconds"

183− Milliseconds -> "milliseconds"

184− Decades -> "decades"

185− Centuries -> "centuries"

186− Millennia -> "millennia"

187−

188−-- | >>> printSQL $ interval_ 7 Days

189−-- (INTERVAL '7.0 days')

190−interval_ :: Double -> TimeUnit -> Expr (null 'PGinterval)

191−interval_ num unit = UnsafeExpression . parenthesized $ "INTERVAL" <+>

192− "'" <> fromString (show num) <+> renderSQL unit <> "'"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hsdeleted−446

@@ -1,446 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression

3−Description: Type expressions

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Type expressions.

9−-}

10−

11−{-# LANGUAGE

12− AllowAmbiguousTypes

13− , DataKinds

14− , DeriveGeneric

15− , FlexibleContexts

16− , FlexibleInstances

17− , GADTs

18− , GeneralizedNewtypeDeriving

19− , KindSignatures

20− , MultiParamTypeClasses

21− , OverloadedStrings

22− , RankNTypes

23− , ScopedTypeVariables

24− , TypeApplications

25− , TypeOperators

26− , UndecidableInstances

27−#-}

28−

29−module Squeal.PostgreSQL.Expression.Type

30− ( -- * type casting

31− cast

32− , astype

33− , inferredtype

34− -- * type expressions

35− , TypeExpression (..)

36− , typedef

37− , typetable

38− , typeview

39− , bool

40− , int2

41− , smallint

42− , int4

43− , int

44− , integer

45− , int8

46− , bigint

47− , numeric

48− , float4

49− , real

50− , float8

51− , doublePrecision

52− , money

53− , text

54− , char

55− , character

56− , varchar

57− , characterVarying

58− , bytea

59− , timestamp

60− , timestampWithTimeZone

61− , timestamptz

62− , date

63− , time

64− , timeWithTimeZone

65− , timetz

66− , interval

67− , uuid

68− , inet

69− , json

70− , jsonb

71− , vararray

72− , fixarray

73− , tsvector

74− , tsquery

75− , oid

76− , int4range

77− , int8range

78− , numrange

79− , tsrange

80− , tstzrange

81− , daterange

82− -- * column type definitions

83− , ColumnTypeExpression (..)

84− , nullable

85− , notNullable

86− , default_

87− , serial2

88− , smallserial

89− , serial4

90− , serial

91− , serial8

92− , bigserial

93− , hask

94− -- * type inference

95− , PGTyped (..)

96− , PGNullityTyped (..)

97− , FieldTyped (..)

98− ) where

99−

100−import Control.DeepSeq

101−import Data.ByteString

102−import Data.String

103−import GHC.TypeLits

104−

105−import qualified Data.ByteString as ByteString

106−import qualified GHC.Generics as GHC

107−import qualified Generics.SOP as SOP

108−

109−import Squeal.PostgreSQL.Alias

110−import Squeal.PostgreSQL.Expression

111−import Squeal.PostgreSQL.PG

112−import Squeal.PostgreSQL.Render

113−import Squeal.PostgreSQL.Schema

114−

115−-- $setup

116−-- >>> import Squeal.PostgreSQL

117−

118−-- When a `cast` is applied to an `Expression` of a known type, it

119−-- represents a run-time type conversion. The cast will succeed only if a

120−-- suitable type conversion operation has been defined.

121−--

122−-- | >>> printSQL $ true & cast int4

123−-- (TRUE :: int4)

124−cast

125− :: TypeExpression schemas ty1

126− -- ^ type to cast as

127− -> Expression outer commons grp schemas params from ty0

128− -- ^ value to convert

129− -> Expression outer commons grp schemas params from ty1

130−cast ty x = UnsafeExpression $ parenthesized $

131− renderSQL x <+> "::" <+> renderSQL ty

132−

133−-- | A safe version of `cast` which just matches a value with its type.

134−--

135−-- >>> printSQL (1 & astype int)

136−-- (1 :: int)

137−astype

138− :: TypeExpression schemas ty

139− -- ^ type to specify as

140− -> Expression outer commons grp schemas params from ty

141− -- ^ value

142− -> Expression outer commons grp schemas params from ty

143−astype = cast

144−

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

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

147−--

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

149−-- (TRUE :: bool)

150−inferredtype

151− :: PGTyped schemas ty

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

153− -- ^ value

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

155−inferredtype = astype pgtype

156−

157−{-----------------------------------------

158−type expressions

159−-----------------------------------------}

160−

161−-- | `TypeExpression`s are used in `cast`s and

162−-- `Squeal.PostgreSQL.Definition.createTable` commands.

163−newtype TypeExpression (schemas :: SchemasType) (ty :: NullityType)

164− = UnsafeTypeExpression { renderTypeExpression :: ByteString }

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

166−instance RenderSQL (TypeExpression schemas ty) where

167− renderSQL = renderTypeExpression

168−

169−-- | The enum or composite type in a `Typedef` can be expressed by its alias.

170−typedef

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

172− => QualifiedAlias sch td

173− -- ^ type alias

174− -> TypeExpression schemas (null ty)

175−typedef = UnsafeTypeExpression . renderSQL

176−

177−-- | The composite type corresponding to a `Table` definition can be expressed

178−-- by its alias.

179−typetable

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

181− => QualifiedAlias sch tab

182− -- ^ table alias

183− -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))

184−typetable = UnsafeTypeExpression . renderSQL

185−

186−-- | The composite type corresponding to a `View` definition can be expressed

187−-- by its alias.

188−typeview

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

190− => QualifiedAlias sch vw

191− -- ^ view alias

192− -> TypeExpression schemas (null ('PGcomposite view))

193−typeview = UnsafeTypeExpression . renderSQL

194−

195−-- | logical Boolean (true/false)

196−bool :: TypeExpression schemas (null 'PGbool)

197−bool = UnsafeTypeExpression "bool"

198−-- | signed two-byte integer

199−int2, smallint :: TypeExpression schemas (null 'PGint2)

200−int2 = UnsafeTypeExpression "int2"

201−smallint = UnsafeTypeExpression "smallint"

202−-- | signed four-byte integer

203−int4, int, integer :: TypeExpression schemas (null 'PGint4)

204−int4 = UnsafeTypeExpression "int4"

205−int = UnsafeTypeExpression "int"

206−integer = UnsafeTypeExpression "integer"

207−-- | signed eight-byte integer

208−int8, bigint :: TypeExpression schemas (null 'PGint8)

209−int8 = UnsafeTypeExpression "int8"

210−bigint = UnsafeTypeExpression "bigint"

211−-- | arbitrary precision numeric type

212−numeric :: TypeExpression schemas (null 'PGnumeric)

213−numeric = UnsafeTypeExpression "numeric"

214−-- | single precision floating-point number (4 bytes)

215−float4, real :: TypeExpression schemas (null 'PGfloat4)

216−float4 = UnsafeTypeExpression "float4"

217−real = UnsafeTypeExpression "real"

218−-- | double precision floating-point number (8 bytes)

219−float8, doublePrecision :: TypeExpression schemas (null 'PGfloat8)

220−float8 = UnsafeTypeExpression "float8"

221−doublePrecision = UnsafeTypeExpression "double precision"

222−-- | currency amount

223−money :: TypeExpression schema (null 'PGmoney)

224−money = UnsafeTypeExpression "money"

225−-- | variable-length character string

226−text :: TypeExpression schemas (null 'PGtext)

227−text = UnsafeTypeExpression "text"

228−-- | fixed-length character string

229−char, character

230− :: forall n schemas null. (KnownNat n, 1 <= n)

231− => TypeExpression schemas (null ('PGchar n))

232−char = UnsafeTypeExpression $ "char(" <> renderNat @n <> ")"

233−character = UnsafeTypeExpression $ "character(" <> renderNat @n <> ")"

234−-- | variable-length character string

235−varchar, characterVarying

236− :: forall n schemas null. (KnownNat n, 1 <= n)

237− => TypeExpression schemas (null ('PGvarchar n))

238−varchar = UnsafeTypeExpression $ "varchar(" <> renderNat @n <> ")"

239−characterVarying = UnsafeTypeExpression $

240− "character varying(" <> renderNat @n <> ")"

241−-- | binary data ("byte array")

242−bytea :: TypeExpression schemas (null 'PGbytea)

243−bytea = UnsafeTypeExpression "bytea"

244−-- | date and time (no time zone)

245−timestamp :: TypeExpression schemas (null 'PGtimestamp)

246−timestamp = UnsafeTypeExpression "timestamp"

247−-- | date and time, including time zone

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

249−timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

250−timestamptz = UnsafeTypeExpression "timestamptz"

251−-- | calendar date (year, month, day)

252−date :: TypeExpression schemas (null 'PGdate)

253−date = UnsafeTypeExpression "date"

254−-- | time of day (no time zone)

255−time :: TypeExpression schemas (null 'PGtime)

256−time = UnsafeTypeExpression "time"

257−-- | time of day, including time zone

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

259−timeWithTimeZone = UnsafeTypeExpression "time with time zone"

260−timetz = UnsafeTypeExpression "timetz"

261−-- | time span

262−interval :: TypeExpression schemas (null 'PGinterval)

263−interval = UnsafeTypeExpression "interval"

264−-- | universally unique identifier

265−uuid :: TypeExpression schemas (null 'PGuuid)

266−uuid = UnsafeTypeExpression "uuid"

267−-- | IPv4 or IPv6 host address

268−inet :: TypeExpression schemas (null 'PGinet)

269−inet = UnsafeTypeExpression "inet"

270−-- | textual JSON data

271−json :: TypeExpression schemas (null 'PGjson)

272−json = UnsafeTypeExpression "json"

273−-- | binary JSON data, decomposed

274−jsonb :: TypeExpression schemas (null 'PGjsonb)

275−jsonb = UnsafeTypeExpression "jsonb"

276−-- | variable length array

277−vararray

278− :: TypeExpression schemas pg

279− -> TypeExpression schemas (null ('PGvararray pg))

280−vararray ty = UnsafeTypeExpression $ renderSQL ty <> "[]"

281−-- | fixed length array

282−--

283−-- >>> renderSQL (fixarray @'[2] json)

284−-- "json[2]"

285−fixarray

286− :: forall dims schemas null pg. SOP.All KnownNat dims

287− => TypeExpression schemas pg

288− -> TypeExpression schemas (null ('PGfixarray dims pg))

289−fixarray ty = UnsafeTypeExpression $

290− renderSQL ty <> renderDims @dims

291− where

292− renderDims :: forall ns. SOP.All KnownNat ns => ByteString

293− renderDims =

294− ("[" <>)

295− . (<> "]")

296− . ByteString.intercalate "]["

297− . SOP.hcollapse

298− $ SOP.hcmap (SOP.Proxy @KnownNat)

299− (K . fromString . show . natVal)

300− (SOP.hpure SOP.Proxy :: SOP.NP SOP.Proxy ns)

301−-- | text search query

302−tsvector :: TypeExpression schemas (null 'PGtsvector)

303−tsvector = UnsafeTypeExpression "tsvector"

304−-- | text search document

305−tsquery :: TypeExpression schemas (null 'PGtsquery)

306−tsquery = UnsafeTypeExpression "tsquery"

307−-- | Object identifiers (OIDs) are used internally by PostgreSQL

308−-- as primary keys for various system tables.

309−oid :: TypeExpression schemas (null 'PGoid)

310−oid = UnsafeTypeExpression "oid"

311−-- | Range of integer

312−int4range :: TypeExpression schemas (null ('PGrange 'PGint4))

313−int4range = UnsafeTypeExpression "int4range"

314−-- | Range of bigint

315−int8range :: TypeExpression schemas (null ('PGrange 'PGint8))

316−int8range = UnsafeTypeExpression "int8range"

317−-- | Range of numeric

318−numrange :: TypeExpression schemas (null ('PGrange 'PGnumeric))

319−numrange = UnsafeTypeExpression "numrange"

320−-- | Range of timestamp without time zone

321−tsrange :: TypeExpression schemas (null ('PGrange 'PGtimestamp))

322−tsrange = UnsafeTypeExpression "tsrange"

323−-- | Range of timestamp with time zone

324−tstzrange :: TypeExpression schemas (null ('PGrange 'PGtimestamptz))

325−tstzrange = UnsafeTypeExpression "tstzrange"

326−-- | Range of date

327−daterange :: TypeExpression schemas (null ('PGrange 'PGdate))

328−daterange = UnsafeTypeExpression "daterange"

329−

330−-- | `pgtype` is a demoted version of a `PGType`

331−class PGTyped schemas (ty :: NullityType) where

332− pgtype :: TypeExpression schemas ty

333−instance PGTyped schemas (null 'PGbool) where pgtype = bool

334−instance PGTyped schemas (null 'PGint2) where pgtype = int2

335−instance PGTyped schemas (null 'PGint4) where pgtype = int4

336−instance PGTyped schemas (null 'PGint8) where pgtype = int8

337−instance PGTyped schemas (null 'PGnumeric) where pgtype = numeric

338−instance PGTyped schemas (null 'PGfloat4) where pgtype = float4

339−instance PGTyped schemas (null 'PGfloat8) where pgtype = float8

340−instance PGTyped schemas (null 'PGmoney) where pgtype = money

341−instance PGTyped schemas (null 'PGtext) where pgtype = text

342−instance (KnownNat n, 1 <= n)

343− => PGTyped schemas (null ('PGchar n)) where pgtype = char @n

344−instance (KnownNat n, 1 <= n)

345− => PGTyped schemas (null ('PGvarchar n)) where pgtype = varchar @n

346−instance PGTyped schemas (null 'PGbytea) where pgtype = bytea

347−instance PGTyped schemas (null 'PGtimestamp) where pgtype = timestamp

348−instance PGTyped schemas (null 'PGtimestamptz) where pgtype = timestampWithTimeZone

349−instance PGTyped schemas (null 'PGdate) where pgtype = date

350−instance PGTyped schemas (null 'PGtime) where pgtype = time

351−instance PGTyped schemas (null 'PGtimetz) where pgtype = timeWithTimeZone

352−instance PGTyped schemas (null 'PGinterval) where pgtype = interval

353−instance PGTyped schemas (null 'PGuuid) where pgtype = uuid

354−instance PGTyped schemas (null 'PGjson) where pgtype = json

355−instance PGTyped schemas (null 'PGjsonb) where pgtype = jsonb

356−instance PGTyped schemas ty

357− => PGTyped schemas (null ('PGvararray ty)) where

358− pgtype = vararray (pgtype @schemas @ty)

359−instance (SOP.All KnownNat dims, PGTyped schemas ty)

360− => PGTyped schemas (null ('PGfixarray dims ty)) where

361− pgtype = fixarray @dims (pgtype @schemas @ty)

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

363−instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery

364−instance PGTyped schemas (null 'PGoid) where pgtype = oid

365−instance PGTyped schemas (null ('PGrange 'PGint4)) where pgtype = int4range

366−instance PGTyped schemas (null ('PGrange 'PGint8)) where pgtype = int8range

367−instance PGTyped schemas (null ('PGrange 'PGnumeric)) where pgtype = numrange

368−instance PGTyped schemas (null ('PGrange 'PGtimestamp)) where pgtype = tsrange

369−instance PGTyped schemas (null ('PGrange 'PGtimestamptz)) where pgtype = tstzrange

370−instance PGTyped schemas (null ('PGrange 'PGdate)) where pgtype = daterange

371−

372−-- | Lift `PGTyped` to a field

373−class FieldTyped schemas ty where

374− fieldtype :: Aliased (TypeExpression schemas) ty

375−instance (KnownSymbol alias, PGTyped schemas ty)

376− => FieldTyped schemas (alias ::: ty) where

377− fieldtype = pgtype `As` Alias

378−

379−-- | `ColumnTypeExpression`s are used in `createTable` commands.

380−newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)

381− = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }

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

383−instance RenderSQL (ColumnTypeExpression schemas ty) where

384− renderSQL = renderColumnTypeExpression

385−

386−-- | used in `createTable` commands as a column constraint to note that

387−-- @NULL@ may be present in a column

388−nullable

389− :: TypeExpression schemas (nullity ty)

390− -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)

391−nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"

392−

393−-- | used in `createTable` commands as a column constraint to ensure

394−-- @NULL@ is not present in a column

395−notNullable

396− :: TypeExpression schemas (nullity ty)

397− -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)

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

399−

400−-- | used in `createTable` commands as a column constraint to give a default

401−default_

402− :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty

403− -> ColumnTypeExpression schemas ('NoDef :=> ty)

404− -> ColumnTypeExpression schemas ('Def :=> ty)

405−default_ x ty = UnsafeColumnTypeExpression $

406− renderSQL ty <+> "DEFAULT" <+> renderExpression x

407−

408−-- | not a true type, but merely a notational convenience for creating

409−-- unique identifier columns with type `PGint2`

410−serial2, smallserial

411− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)

412−serial2 = UnsafeColumnTypeExpression "serial2"

413−smallserial = UnsafeColumnTypeExpression "smallserial"

414−-- | not a true type, but merely a notational convenience for creating

415−-- unique identifier columns with type `PGint4`

416−serial4, serial

417− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)

418−serial4 = UnsafeColumnTypeExpression "serial4"

419−serial = UnsafeColumnTypeExpression "serial"

420−-- | not a true type, but merely a notational convenience for creating

421−-- unique identifier columns with type `PGint8`

422−serial8, bigserial

423− :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)

424−serial8 = UnsafeColumnTypeExpression "serial8"

425−bigserial = UnsafeColumnTypeExpression "bigserial"

426−

427−-- | Like @PGTyped@ but also accounts for nullity.

428−class PGNullityTyped schemas (nullty :: NullityType) where

429− pgNullityType :: ColumnTypeExpression schemas ('NoDef :=> nullty)

430−

431−instance PGTyped schemas ('Null ty) => PGNullityTyped schemas ('Null ty) where

432− pgNullityType = nullable (pgtype @_ @('Null ty))

433−

434−instance PGTyped schemas ('NotNull ty) => PGNullityTyped schemas ('NotNull ty) where

435− pgNullityType = notNullable (pgtype @_ @('NotNull ty))

436−

437−-- | Allow you to specify pg column types in relation to haskell types.

438−-- >>> printSQL $ hask @(Maybe String)

439−-- text NULL

440−--

441−-- >>> printSQL $ hask @Double

442−-- float8 NOT NULL

443−hask

444− :: forall hask schemas. PGNullityTyped schemas (NullPG hask)

445− => ColumnTypeExpression schemas ('NoDef :=> NullPG hask)

446−hask = pgNullityType

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Window.hsdeleted−284

@@ -1,284 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.Expression.Window

3−Description: Window functions

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Window functions and definitions

9−-}

10−

11−{-# LANGUAGE

12− DataKinds

13− , DeriveGeneric

14− , FlexibleContexts

15− , FlexibleInstances

16− , GADTs

17− , GeneralizedNewtypeDeriving

18− , LambdaCase

19− , MultiParamTypeClasses

20− , OverloadedStrings

21− , RankNTypes

22− , KindSignatures

23−#-}

24−

25−module Squeal.PostgreSQL.Expression.Window

26− ( -- * functions

27− partitionBy

28− , rank

29− , rowNumber

30− , denseRank

31− , percentRank

32− , cumeDist

33− , ntile

34− , lag

35− , lead

36− , firstValue

37− , lastValue

38− , nthValue

39− , unsafeWindowFunction1

40− , unsafeWindowFunctionN

41− -- * types

42− , WindowFunction (..)

43− , WindowDefinition (..)

44− , WinFun0

45− , WinFun1

46− , WinFunN

47− ) where

48−

49−import Control.DeepSeq

50−import Data.ByteString

51−

52−import qualified GHC.Generics as GHC

53−import qualified Generics.SOP as SOP

54−

55−import Squeal.PostgreSQL.Alias

56−import Squeal.PostgreSQL.Expression

57−import Squeal.PostgreSQL.Expression.Aggregate

58−import Squeal.PostgreSQL.Expression.Sort

59−import Squeal.PostgreSQL.List

60−import Squeal.PostgreSQL.Render

61−import Squeal.PostgreSQL.Schema

62−

63−instance Aggregate

64− (Expression outer commons grp schemas params from)

65− (NP (Expression outer commons grp schemas params from))

66− (WindowFunction outer commons grp schemas params from) where

67− countStar = UnsafeWindowFunction "count(*)"

68− count = unsafeWindowFunction1 "count"

69− sum_ = unsafeWindowFunction1 "sum"

70− arrayAgg = unsafeWindowFunction1 "array_agg"

71− jsonAgg = unsafeWindowFunction1 "json_agg"

72− jsonbAgg = unsafeWindowFunction1 "jsonb_agg"

73− bitAnd = unsafeWindowFunction1 "bit_and"

74− bitOr = unsafeWindowFunction1 "bit_or"

75− boolAnd = unsafeWindowFunction1 "bool_and"

76− boolOr = unsafeWindowFunction1 "bool_or"

77− every = unsafeWindowFunction1 "every"

78− max_ = unsafeWindowFunction1 "max"

79− min_ = unsafeWindowFunction1 "min"

80− avg = unsafeWindowFunction1 "avg"

81− corr = unsafeWindowFunctionN "corr"

82− covarPop = unsafeWindowFunctionN "covar_pop"

83− covarSamp = unsafeWindowFunctionN "covar_samp"

84− regrAvgX = unsafeWindowFunctionN "regr_avgx"

85− regrAvgY = unsafeWindowFunctionN "regr_avgy"

86− regrCount = unsafeWindowFunctionN "regr_count"

87− regrIntercept = unsafeWindowFunctionN "regr_intercept"

88− regrR2 = unsafeWindowFunctionN "regr_r2"

89− regrSlope = unsafeWindowFunctionN "regr_slope"

90− regrSxx = unsafeWindowFunctionN "regr_sxx"

91− regrSxy = unsafeWindowFunctionN "regr_sxy"

92− regrSyy = unsafeWindowFunctionN "regr_syy"

93− stddev = unsafeWindowFunction1 "stddev"

94− stddevPop = unsafeWindowFunction1 "stddev_pop"

95− stddevSamp = unsafeWindowFunction1 "stddev_samp"

96− variance = unsafeWindowFunction1 "variance"

97− varPop = unsafeWindowFunction1 "var_pop"

98− varSamp = unsafeWindowFunction1 "var_samp"

99−

100−-- | A `WindowDefinition` is a set of table rows that are somehow related

101−-- to the current row

102−data WindowDefinition outer commons grp schemas params from where

103− WindowDefinition

104− :: SOP.SListI bys

105− => NP (Expression outer commons grp schemas params from) bys

106− -- ^ `partitionBy` clause

107− -> [SortExpression outer commons grp schemas params from]

108− -- ^ `Squeal.PostgreSQL.Expression.Sort.orderBy` clause

109− -> WindowDefinition outer commons grp schemas params from

110−

111−instance OrderBy WindowDefinition where

112− orderBy sortsR (WindowDefinition parts sortsL)

113− = WindowDefinition parts (sortsL ++ sortsR)

114−

115−instance RenderSQL (WindowDefinition outer commons schemas from grp params) where

116− renderSQL (WindowDefinition part ord) =

117− renderPartitionByClause part <> renderOrderByClause ord

118− where

119− renderPartitionByClause = \case

120− Nil -> ""

121− parts -> "PARTITION" <+> "BY" <+> renderCommaSeparated renderExpression parts

122− renderOrderByClause = \case

123− [] -> ""

124− srts -> " ORDER" <+> "BY"

125− <+> commaSeparated (renderSQL <$> srts)

126−

127−{- |

128−The `partitionBy` clause within `Squeal.PostgreSQL.Query.Over` divides the rows into groups,

129−or partitions, that share the same values of the `partitionBy` `Expression`(s).

130−For each row, the window function is computed across the rows that fall into

131−the same partition as the current row.

132−-}

133−partitionBy

134− :: SOP.SListI bys

135− => NP (Expression outer commons grp schemas params from) bys -- ^ partitions

136− -> WindowDefinition outer commons grp schemas params from

137−partitionBy bys = WindowDefinition bys []

138−

139−{- |

140−A window function performs a calculation across a set of table rows

141−that are somehow related to the current row. This is comparable to the type

142−of calculation that can be done with an aggregate function.

143−However, window functions do not cause rows to become grouped into a single

144−output row like non-window aggregate calls would.

145−Instead, the rows retain their separate identities.

146−Behind the scenes, the window function is able to access more than

147−just the current row of the query result.

148−-}

149−newtype WindowFunction

150− (outer :: FromType)

151− (commons :: FromType)

152− (grp :: Grouping)

153− (schemas :: SchemasType)

154− (params :: [NullityType])

155− (from :: FromType)

156− (ty :: NullityType)

157− = UnsafeWindowFunction { renderWindowFunction :: ByteString }

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

159−

160−instance RenderSQL (WindowFunction outer commons grp schemas params from ty) where

161− renderSQL = renderWindowFunction

162−

163−{- |

164−A @RankNType@ for window functions with no arguments.

165−-}

166−type WinFun0 x

167− = forall outer commons grp schemas params from

168− . WindowFunction outer commons grp schemas params from x

169− -- ^ cannot reference aliases

170−

171−{- |

172−A @RankNType@ for window functions with 1 argument.

173−-}

174−type WinFun1 x y

175− = forall outer commons grp schemas params from

176− . Expression outer commons grp schemas params from x

177− -- ^ input

178− -> WindowFunction outer commons grp schemas params from y

179− -- ^ output

180−

181−{- | A @RankNType@ for window functions with a fixed-length

182−list of heterogeneous arguments.

183−Use the `*:` operator to end your argument lists.

184−-}

185−type WinFunN xs y

186− = forall outer commons grp schemas params from

187− . NP (Expression outer commons grp schemas params from) xs

188− -- ^ inputs

189− -> WindowFunction outer commons grp schemas params from y

190− -- ^ output

191−

192−-- | escape hatch for defining window functions

193−unsafeWindowFunction1 :: ByteString -> WinFun1 x y

194−unsafeWindowFunction1 fun x

195− = UnsafeWindowFunction $ fun <> parenthesized (renderSQL x)

196−

197−-- | escape hatch for defining multi-argument window functions

198−unsafeWindowFunctionN :: SOP.SListI xs => ByteString -> WinFunN xs y

199−unsafeWindowFunctionN fun xs = UnsafeWindowFunction $ fun <>

200− parenthesized (renderCommaSeparated renderSQL xs)

201−

202−{- | rank of the current row with gaps; same as `rowNumber` of its first peer

203−

204−>>> printSQL rank

205−rank()

206−-}

207−rank :: WinFun0 ('NotNull 'PGint8)

208−rank = UnsafeWindowFunction "rank()"

209−

210−{- | number of the current row within its partition, counting from 1

211−

212−>>> printSQL rowNumber

213−row_number()

214−-}

215−rowNumber :: WinFun0 ('NotNull 'PGint8)

216−rowNumber = UnsafeWindowFunction "row_number()"

217−

218−{- | rank of the current row without gaps; this function counts peer groups

219−

220−>>> printSQL denseRank

221−dense_rank()

222−-}

223−denseRank :: WinFun0 ('NotNull 'PGint8)

224−denseRank = UnsafeWindowFunction "dense_rank()"

225−

226−{- | relative rank of the current row: (rank - 1) / (total partition rows - 1)

227−

228−>>> printSQL percentRank

229−percent_rank()

230−-}

231−percentRank :: WinFun0 ('NotNull 'PGfloat8)

232−percentRank = UnsafeWindowFunction "percent_rank()"

233−

234−{- | cumulative distribution: (number of partition rows

235−preceding or peer with current row) / total partition rows

236−

237−>>> printSQL cumeDist

238−cume_dist()

239−-}

240−cumeDist :: WinFun0 ('NotNull 'PGfloat8)

241−cumeDist = UnsafeWindowFunction "cume_dist()"

242−

243−{- | integer ranging from 1 to the argument value,

244−dividing the partition as equally as possible

245−

246−>>> printSQL $ ntile 5

247−ntile(5)

248−-}

249−ntile :: WinFun1 ('NotNull 'PGint4) ('NotNull 'PGint4)

250−ntile = unsafeWindowFunction1 "ntile"

251−

252−{- | returns value evaluated at the row that is offset rows before the current

253−row within the partition; if there is no such row, instead return default

254−(which must be of the same type as value). Both offset and default are

255−evaluated with respect to the current row.

256−-}

257−lag :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty

258−lag = unsafeWindowFunctionN "lag"

259−

260−{- | returns value evaluated at the row that is offset rows after the current

261−row within the partition; if there is no such row, instead return default

262−(which must be of the same type as value). Both offset and default are

263−evaluated with respect to the current row.

264−-}

265−lead :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty

266−lead = unsafeWindowFunctionN "lead"

267−

268−{- | returns value evaluated at the row that is the

269−first row of the window frame

270−-}

271−firstValue :: WinFun1 ty ty

272−firstValue = unsafeWindowFunction1 "first_value"

273−

274−{- | returns value evaluated at the row that is the

275−last row of the window frame

276−-}

277−lastValue :: WinFun1 ty ty

278−lastValue = unsafeWindowFunction1 "last_value"

279−

280−{- | returns value evaluated at the row that is the nth

281−row of the window frame (counting from 1); null if no such row

282−-}

283−nthValue :: WinFunN '[null ty, 'NotNull 'PGint4] ('Null ty)

284−nthValue = unsafeWindowFunctionN "nth_value"

squeal-postgresql/src/Squeal/PostgreSQL/List.hsdeleted−112

@@ -1,112 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.List

3−Description: List related types and functions

4−Copyright: (c) Eitan Chatav, 2019

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−Haskell singly-linked lists are very powerful. This module

9−provides functionality for type-level lists, heterogeneous

10−lists and type aligned lists.

11−-}

12−

13−{-# LANGUAGE

14− DataKinds

15− , FlexibleContexts

16− , GADTs

17− , LambdaCase

18− , MultiParamTypeClasses

19− , OverloadedStrings

20− , PolyKinds

21− , QuantifiedConstraints

22− , RankNTypes

23− , ScopedTypeVariables

24− , TypeApplications

25− , TypeFamilies

26− , TypeOperators

27− , UndecidableInstances

28−#-}

29−

30−module Squeal.PostgreSQL.List

31− ( SOP.NP (..)

32− , (*:)

33− , Join

34− , disjoin

35− , Additional (..)

36− , Path (..)

37− , CFunctor (..)

38− , CFoldable (..)

39− , CFree (..)

40− , Elem

41− , In

42− , Length

43− ) where

44−

45−import Control.Category.Free

46−import Data.Function ((&))

47−import Data.Kind

48−import Data.Type.Bool

49−import GHC.TypeLits

50−

51−import Generics.SOP as SOP

52−

53−-- | `Join` is simply promoted `++` and is used in @JOIN@s in

54−-- `Squeal.PostgreSQL.Query.FromClause`s.

55−type family Join xs ys where

56− Join '[] ys = ys

57− Join (x ': xs) ys = x ': Join xs ys

58−

59−-- | `disjoin` is a utility function for splitting an `NP` list into pieces.

60−disjoin

61− :: forall xs ys expr. SListI xs

62− => NP expr (Join xs ys)

63− -> (NP expr xs, NP expr ys)

64−disjoin = case sList @xs of

65− SNil -> \ys -> (Nil, ys)

66− SCons -> \(x :* xsys) ->

67− case disjoin xsys of (xs,ys) -> (x :* xs, ys)

68−

69−-- | The `Additional` class is for appending

70−-- type-level list parameterized constructors such as `NP`,

71−-- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`.

72−class Additional expr where

73− also :: expr ys -> expr xs -> expr (Join xs ys)

74−instance Additional (NP expr) where

75− also ys = \case

76− Nil -> ys

77− x :* xs -> x :* (xs & also ys)

78−

79−-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.

80−(*:) :: f x -> f y -> NP f '[x,y]

81−x *: y = x :* y :* Nil

82−infixl 9 *:

83−

84−-- | @Elem@ is a promoted `Data.List.elem`.

85−type family Elem x xs where

86− Elem x '[] = 'False

87− Elem x (x ': _) = 'True

88− Elem x (_ ': x ': _) = 'True

89− Elem x (_ ': _ ': x ': _) = 'True

90− Elem x (_ ': _ ': _ ': x ': _) = 'True

91− Elem x (_ ': _ ': _ ': _ ': x ': _) = 'True

92− Elem x (_ ': _ ': _ ': _ ': _ ': x ': _) = 'True

93− Elem x (_ ': xs) = Elem x xs

94−

95−-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.

96−type family In x xs :: Constraint where

97− In x xs = If (Elem x xs) (() :: Constraint)

98− (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs))

99−

100−{- | Calculate the `Length` of a type level list

101−

102−>>> :kind! Length '[Char,String,Bool,Double]

103−Length '[Char,String,Bool,Double] :: Nat

104−= 4

105−-}

106−type family Length (xs :: [k]) :: Nat where

107− Length (_ ': _ ': _ ': _ ': _ : xs) = 5 + Length xs

108− Length (_ ': _ ': _ ': _ : xs) = 4 + Length xs

109− Length (_ ': _ ': _ : xs) = 3 + Length xs

110− Length (_ ': _ : xs) = 2 + Length xs

111− Length (_ : xs) = 1 + Length xs

112− Length '[] = 0

squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+357−423

@@ -9,371 +9,316 @@ Squeal data manipulation language.

99-}

1010

1111{-# LANGUAGE

12− DeriveGeneric

12+ DataKinds

13+ , DeriveDataTypeable

14+ , DeriveGeneric

1315 , FlexibleContexts

14− , FlexibleInstances

1516 , GADTs

1617 , GeneralizedNewtypeDeriving

18+ , KindSignatures

1719 , LambdaCase

18− , MultiParamTypeClasses

1920 , OverloadedStrings

20− , PatternSynonyms

21− , QuantifiedConstraints

2221 , RankNTypes

23− , ScopedTypeVariables

24− , TypeApplications

25− , TypeFamilies

22+ , StandaloneDeriving

2623 , TypeInType

2724 , TypeOperators

28− , UndecidableInstances

2925#-}

3026

3127module Squeal.PostgreSQL.Manipulation

3228 ( -- * Manipulation

33− Manipulation_

34− , Manipulation (..)

29+ Manipulation (UnsafeManipulation, renderManipulation)

3530 , queryStatement

31+ , ColumnValue (..)

32+ , ReturningClause (ReturningStar, Returning)

33+ , ConflictClause (OnConflictDoRaise, OnConflictDoNothing, OnConflictDoUpdate)

3634 -- * Insert

37− , insertInto

38− , insertInto_

35+ , insertRows

36+ , insertRow

37+ , insertRows_

38+ , insertRow_

39+ , insertQuery

40+ , insertQuery_

41+ , renderReturningClause

42+ , renderConflictClause

3943 -- * Update

4044 , update

4145 , update_

4246 -- * Delete

4347 , deleteFrom

4448 , deleteFrom_

45− -- * Clauses

46− , Optional (..)

47− , QueryClause (..)

48− , pattern Values_

49− , ReturningClause (..)

50− , pattern Returning_

51− , ConflictClause (..)

52− , ConflictTarget (..)

53− , ConflictAction (..)

54− , UsingClause (..)

49+ -- * With

50+ , with

5551 ) where

5652

5753import Control.DeepSeq

5854import Data.ByteString hiding (foldr)

59−import Data.Kind (Type)

55+import Data.Monoid

6056

57+import qualified Data.ByteString as ByteString

6158import qualified Generics.SOP as SOP

6259import qualified GHC.Generics as GHC

6360

64−import Squeal.PostgreSQL.Alias

6561import Squeal.PostgreSQL.Expression

66−import Squeal.PostgreSQL.Expression.Logic

67−import Squeal.PostgreSQL.List

68−import Squeal.PostgreSQL.PG

6962import Squeal.PostgreSQL.Render

7063import Squeal.PostgreSQL.Query

7164import Squeal.PostgreSQL.Schema

7265

73−-- $setup

74−-- >>> import Squeal.PostgreSQL

75−-- >>> import Data.Int

76−-- >>> import Data.Time

77−

7866{- |

7967A `Manipulation` is a statement which may modify data in the database,

80−but does not alter its schemas. Examples are inserts, updates and deletes.

68+but does not alter the schema. Examples are inserts, updates and deletes.

8169A `Query` is also considered a `Manipulation` even though it does not modify data.

8270

83−The general `Manipulation` type is parameterized by

84−

85−* @commons :: FromType@ - scope for all `common` table expressions,

86−* @schemas :: SchemasType@ - scope for all `table`s and `view`s,

87−* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,

88−* @row :: RowType@ - return type of the `Query`.

89−-}

90−newtype Manipulation

91− (commons :: FromType)

92− (schemas :: SchemasType)

93− (params :: [NullityType])

94− (columns :: RowType)

95− = UnsafeManipulation { renderManipulation :: ByteString }

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

97−instance RenderSQL (Manipulation commons schemas params columns) where

98− renderSQL = renderManipulation

99−instance With Manipulation where

100− with Done manip = manip

101− with ctes manip = UnsafeManipulation $

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

103−

104−{- |

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

106−against which the query is type-checked, an input @parameters@ Haskell `Type`,

107−and an ouput row Haskell `Type`.

108−

109−A top-level `Manipulation_` can be run

110−using `Squeal.PostgreSQL.PQ.manipulateParams`, or if @parameters = ()@

111−using `Squeal.PostgreSQL.PQ.manipulate`.

112−

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

114−may be referenced using positional

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

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

117−

118−>>> :set -XDeriveAnyClass -XDerivingStrategies

119−>>> :{

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

121− deriving stock (GHC.Generic)

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

123−:}

124−

12571simple insert:

12672

127−>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]

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

12973>>> :{

13074let

131− manipulation :: Manipulation_ (Public Schema) () ()

75+ manipulation :: Manipulation

76+ '[ "tab" ::: 'Table ('[] :=>

77+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

78+ , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[] '[]

13279 manipulation =

133− insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))

134−in printSQL manipulation

80+ insertRow_ #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil)

81+in renderManipulation manipulation

13582:}

136−INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)

83+"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT);"

13784

13885parameterized insert:

13986

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

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

14287>>> :{

14388let

144− manipulation :: Manipulation_ (Public Schema) (Int32, Int32) ()

89+ manipulation :: Manipulation

90+ '[ "tab" ::: 'Table ('[] :=>

91+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

92+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]

93+ '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]

14594 manipulation =

146− insertInto_ #tab (Values_ (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2))

147−in printSQL manipulation

95+ insertRow_ #tab

96+ (Set (param @1) `As` #col1 :* Set (param @2) `As` #col2 :* Nil)

97+in renderManipulation manipulation

14898:}

149−INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))

99+"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (($1 :: int4), ($2 :: int4));"

150100

151101returning insert:

152102

153103>>> :{

154104let

155− manipulation :: Manipulation_ (Public Schema) () (Only Int32)

105+ manipulation :: Manipulation

106+ '[ "tab" ::: 'Table ('[] :=>

107+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

108+ , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[]

109+ '["fromOnly" ::: 'NotNull 'PGint4]

156110 manipulation =

157− insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2))

158− OnConflictDoRaise (Returning (#col1 `as` #fromOnly))

159−in printSQL manipulation

111+ insertRow #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil)

112+ OnConflictDoRaise (Returning (#col1 `As` #fromOnly :* Nil))

113+in renderManipulation manipulation

160114:}

161−INSERT INTO "tab" ("col1", "col2") VALUES (2, 3) RETURNING "col1" AS "fromOnly"

115+"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT) RETURNING \"col1\" AS \"fromOnly\";"

162116

163117upsert:

164118

165−>>> type CustomersColumns = '["name" ::: 'NoDef :=> 'NotNull 'PGtext, "email" ::: 'NoDef :=> 'NotNull 'PGtext]

166−>>> type CustomersConstraints = '["uq" ::: 'Unique '["name"]]

167−>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)]

168119>>> :{

169120let

170− manipulation :: Manipulation_ (Public CustomersSchema) () ()

121+ manipulation :: Manipulation

122+ '[ "tab" ::: 'Table ('[] :=>

123+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

124+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]

125+ '[] '[ "sum" ::: 'NotNull 'PGint4]

171126 manipulation =

172− insertInto #customers

173− (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email))

174− (OnConflict (OnConstraint #uq)

175− (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) []))

176− (Returning_ Nil)

177−in printSQL manipulation

127+ insertRows #tab

128+ (Set 2 `As` #col1 :* Set 4 `As` #col2 :* Nil)

129+ [Set 6 `As` #col1 :* Set 8 `As` #col2 :* Nil]

130+ (OnConflictDoUpdate

131+ (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)

132+ [#col1 .== #col2])

133+ (Returning $ (#col1 + #col2) `As` #sum :* Nil)

134+in renderManipulation manipulation

178135:}

179−INSERT INTO "customers" ("name", "email") VALUES (E'John Smith', E'john@smith.com') ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || (E'; ' || "customers"."email"))

136+"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, 4), (6, 8) ON CONFLICT DO UPDATE SET \"col1\" = 2 WHERE (\"col1\" = \"col2\") RETURNING (\"col1\" + \"col2\") AS \"sum\";"

180137

181138query insert:

182139

183140>>> :{

184141let

185− manipulation :: Manipulation_ (Public Schema) () ()

186− manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab))))

187−in printSQL manipulation

142+ manipulation :: Manipulation

143+ '[ "tab" ::: 'Table ('[] :=>

144+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

145+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4

146+ ])

147+ , "other_tab" ::: 'Table ('[] :=>

148+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

149+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4

150+ ])

151+ ] '[] '[]

152+ manipulation =

153+ insertQuery_ #tab

154+ (selectStar (from (table (#other_tab `As` #t))))

155+in renderManipulation manipulation

188156:}

189−INSERT INTO "tab" SELECT * FROM "tab" AS "tab"

157+"INSERT INTO \"tab\" SELECT * FROM \"other_tab\" AS \"t\";"

190158

191159update:

192160

193161>>> :{

194162let

195− manipulation :: Manipulation_ (Public Schema) () ()

196− manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)

197−in printSQL manipulation

198−:}

199−UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")

200−

201−delete:

202−

203−>>> :{

204−let

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

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

207−in printSQL manipulation

208−:}

209−DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING *

210−

211−delete and using clause:

212−

213−>>> :{

214−type Schema3 =

215− '[ "tab" ::: 'Table ('[] :=> Columns)

216− , "other_tab" ::: 'Table ('[] :=> Columns)

217− , "third_tab" ::: 'Table ('[] :=> Columns) ]

218−:}

219−

220−>>> :{

221−let

222− manipulation :: Manipulation_ (Public Schema3) () ()

163+ manipulation :: Manipulation

164+ '[ "tab" ::: 'Table ('[] :=>

165+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

166+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[]

223167 manipulation =

224− deleteFrom #tab (Using (table #other_tab & also (table #third_tab)))

225− ( (#tab ! #col2 .== #other_tab ! #col2)

226− .&& (#tab ! #col2 .== #third_tab ! #col2) )

227− (Returning_ Nil)

228−in printSQL manipulation

168+ update_ #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)

169+ (#col1 ./= #col2)

170+in renderManipulation manipulation

229171:}

230−DELETE FROM "tab" USING "other_tab" AS "other_tab", "third_tab" AS "third_tab" WHERE (("tab"."col2" = "other_tab"."col2") AND ("tab"."col2" = "third_tab"."col2"))

172+"UPDATE \"tab\" SET \"col1\" = 2 WHERE (\"col1\" <> \"col2\");"

231173

232−with manipulation:

174+delete:

233175

234−>>> type ProductsColumns = '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]

235−>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]

236176>>> :{

237177let

238− manipulation :: Manipulation_ (Public ProductsSchema) (Only Day) ()

239− manipulation = with

240− (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del)

241− (insertInto_ #products_deleted (Subquery (select Star (from (common #del)))))

242−in printSQL manipulation

178+ manipulation :: Manipulation

179+ '[ "tab" ::: 'Table ('[] :=>

180+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

181+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[]

182+ '[ "col1" ::: 'NotNull 'PGint4

183+ , "col2" ::: 'NotNull 'PGint4 ]

184+ manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar

185+in renderManipulation manipulation

243186:}

244−WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del"

187+"DELETE FROM \"tab\" WHERE (\"col1\" = \"col2\") RETURNING *;"

245188-}

246−type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type) where

247− Manipulation_ schemas params row = Manipulation '[] schemas (TuplePG params) (RowPG row)

189+newtype Manipulation

190+ (schema :: SchemaType)

191+ (params :: [NullityType])

192+ (columns :: RelationType)

193+ = UnsafeManipulation { renderManipulation :: ByteString }

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

248195

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

250197queryStatement

251− :: Query '[] commons schemas params columns

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

253− -> Manipulation commons schemas params columns

254−queryStatement q = UnsafeManipulation $ renderSQL q

198+ :: Query schema params columns

199+ -> Manipulation schema params columns

200+queryStatement q = UnsafeManipulation $ renderQuery q <> ";"

255201

256202{-----------------------------------------

257203INSERT statements

258204-----------------------------------------}

259205

260−{- |

261−When a table is created, it contains no data. The first thing to do

262−before a database can be of much use is to insert data. Data is

263−conceptually inserted one row at a time. Of course you can also insert

264−more than one row, but there is no way to insert less than one row.

265−Even if you know only some column values, a complete row must be created.

266−-}

267−insertInto

268− :: ( Has sch schemas schema

269− , Has tab schema ('Table table)

270− , columns ~ TableToColumns table

271− , row0 ~ TableToRow table

272− , SOP.SListI columns

273− , SOP.SListI row1 )

274− => QualifiedAlias sch tab

275− -- ^ table

276− -> QueryClause commons schemas params columns

277− -- ^ what to insert

278− -> ConflictClause tab commons schemas params table

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

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

281− -- ^ what to return

282− -> Manipulation commons schemas params row1

283−insertInto tab qry conflict ret = UnsafeManipulation $

284− "INSERT" <+> "INTO" <+> renderSQL tab

285− <+> renderSQL qry

286− <> renderSQL conflict

287− <> renderSQL ret

288−

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

290−insertInto_

291− :: ( Has sch schemas schema

206+-- | Insert multiple rows.

207+--

208+-- When a table is created, it contains no data. The first thing to do

209+-- before a database can be of much use is to insert data. Data is

210+-- conceptually inserted one row at a time. Of course you can also insert

211+-- more than one row, but there is no way to insert less than one row.

212+-- Even if you know only some column values, a complete row must be created.

213+insertRows

214+ :: ( SOP.SListI columns

215+ , SOP.SListI results

292216 , Has tab schema ('Table table)

293− , columns ~ TableToColumns table

294− , row ~ TableToRow table

295− , SOP.SListI columns )

296− => QualifiedAlias sch tab

297− -- ^ table

298− -> QueryClause commons schemas params columns

299− -- ^ what to insert

300− -> Manipulation commons schemas params '[]

301−insertInto_ tab qry =

302− insertInto tab qry OnConflictDoRaise (Returning_ Nil)

303−

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

305−data QueryClause commons schemas params columns where

306− Values

307− :: SOP.SListI columns

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

309− -- ^ row of values

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

311− -- ^ additional rows of values

312− -> QueryClause commons schemas params columns

313− Select

314− :: SOP.SListI columns

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

316− -- ^ row of values

317− -> TableExpression '[] commons grp schemas params from

318− -- ^ from a table expression

319− -> QueryClause commons schemas params columns

320− Subquery

321− :: ColumnsToRow columns ~ row

322− => Query '[] commons schemas params row

323− -- ^ subquery to insert

324− -> QueryClause commons schemas params columns

325−

326−instance RenderSQL (QueryClause commons schemas params columns) where

327− renderSQL = \case

328− Values row0 rows ->

329− parenthesized (renderCommaSeparated renderSQLPart row0)

330− <+> "VALUES"

331− <+> commaSeparated

332− ( parenthesized

333− . renderCommaSeparated renderValuePart <$> row0 : rows )

334− Select row0 tab ->

335− parenthesized (renderCommaSeparatedMaybe renderSQLPartMaybe row0)

336− <+> "SELECT"

337− <+> renderCommaSeparatedMaybe renderValuePartMaybe row0

338− <+> renderSQL tab

339− Subquery qry -> renderQuery qry

217+ , columns ~ TableToColumns table )

218+ => Alias tab -- ^ table to insert into

219+ -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert

220+ -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert

221+ -> ConflictClause columns params

222+ -- ^ what to do in case of constraint conflict

223+ -> ReturningClause columns params results -- ^ results to return

224+ -> Manipulation schema params results

225+insertRows tab row rows conflict returning = UnsafeManipulation $

226+ "INSERT" <+> "INTO" <+> renderAlias tab

227+ <+> parenthesized (renderCommaSeparated renderAliasPart row)

228+ <+> "VALUES"

229+ <+> commaSeparated

230+ ( parenthesized

231+ . renderCommaSeparated renderColumnValuePart <$> row:rows )

232+ <> renderConflictClause conflict

233+ <> renderReturningClause returning

340234 where

341− renderSQLPartMaybe, renderValuePartMaybe

342− :: Aliased (Optional (Expression '[] commons grp schemas params from)) column

343− -> Maybe ByteString

344− renderSQLPartMaybe = \case

345− Default `As` _ -> Nothing

346− Set _ `As` name -> Just $ renderSQL name

347− renderValuePartMaybe = \case

348− Default `As` _ -> Nothing

349− Set value `As` _ -> Just $ renderExpression value

350− renderSQLPart, renderValuePart

351− :: Aliased (Optional (Expression '[] commons grp schemas params from)) column

352− -> ByteString

353− renderSQLPart (_ `As` name) = renderSQL name

354− renderValuePart (value `As` _) = renderSQL value

355−

356−-- | `Values_` describes a single `NP` list of `Aliased` `Optional` `Expression`s

357−-- whose `ColumnsType` must match the tables'.

358−pattern Values_

359− :: SOP.SListI columns

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

361− -- ^ row of values

362− -> QueryClause commons schemas params columns

363−pattern Values_ vals = Values vals []

364−

365−-- | `Optional` is either `Default` or a value, parameterized by an appropriate

366−-- `ColumnConstraint`.

367−data Optional expr ty where

368− -- | Use the `Default` value for a column.

369− Default :: Optional expr ('Def :=> ty)

370− -- | `Set` a value for a column.

371− Set :: expr ty -> Optional expr (def :=> ty)

372−

373−instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where

374− renderSQL = \case

375− Default -> "DEFAULT"

376− Set expr -> renderSQL expr

235+ renderAliasPart, renderColumnValuePart

236+ :: Aliased (ColumnValue '[] params) ty -> ByteString

237+ renderAliasPart (_ `As` name) = renderAlias name

238+ renderColumnValuePart (value `As` _) = case value of

239+ Default -> "DEFAULT"

240+ Set expression -> renderExpression expression

241+

242+-- | Insert a single row.

243+insertRow

244+ :: ( SOP.SListI columns

245+ , SOP.SListI results

246+ , Has tab schema ('Table table)

247+ , columns ~ TableToColumns table )

248+ => Alias tab -- ^ table to insert into

249+ -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert

250+ -> ConflictClause columns params

251+ -- ^ what to do in case of constraint conflict

252+ -> ReturningClause columns params results -- ^ results to return

253+ -> Manipulation schema params results

254+insertRow tab row = insertRows tab row []

255+

256+-- | Insert multiple rows returning `Nil` and raising an error on conflicts.

257+insertRows_

258+ :: ( SOP.SListI columns

259+ , Has tab schema ('Table table)

260+ , columns ~ TableToColumns table )

261+ => Alias tab -- ^ table to insert into

262+ -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert

263+ -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert

264+ -> Manipulation schema params '[]

265+insertRows_ tab row rows =

266+ insertRows tab row rows OnConflictDoRaise (Returning Nil)

267+

268+-- | Insert a single row returning `Nil` and raising an error on conflicts.

269+insertRow_

270+ :: ( SOP.SListI columns

271+ , Has tab schema ('Table table)

272+ , columns ~ TableToColumns table )

273+ => Alias tab -- ^ table to insert into

274+ -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert

275+ -> Manipulation schema params '[]

276+insertRow_ tab row = insertRow tab row OnConflictDoRaise (Returning Nil)

277+

278+-- | Insert a `Query`.

279+insertQuery

280+ :: ( SOP.SListI columns

281+ , SOP.SListI results

282+ , Has tab schema ('Table table)

283+ , columns ~ TableToColumns table )

284+ => Alias tab -- ^ table to insert into

285+ -> Query schema params (ColumnsToRelation columns)

286+ -> ConflictClause columns params

287+ -- ^ what to do in case of constraint conflict

288+ -> ReturningClause columns params results -- ^ results to return

289+ -> Manipulation schema params results

290+insertQuery tab query conflict returning = UnsafeManipulation $

291+ "INSERT" <+> "INTO" <+> renderAlias tab

292+ <+> renderQuery query

293+ <> renderConflictClause conflict

294+ <> renderReturningClause returning

295+

296+-- | Insert a `Query` returning `Nil` and raising an error on conflicts.

297+insertQuery_

298+ :: ( SOP.SListI columns

299+ , Has tab schema ('Table table)

300+ , columns ~ TableToColumns table )

301+ => Alias tab -- ^ table to insert into

302+ -> Query schema params (ColumnsToRelation columns)

303+ -> Manipulation schema params '[]

304+insertQuery_ tab query =

305+ insertQuery tab query OnConflictDoRaise (Returning Nil)

306+

307+-- | `ColumnValue`s are values to insert or update in a row

308+-- `Same` updates with the same value.

309+-- `Default` inserts or updates with the @DEFAULT@ value

310+-- `Set` a value to be an `Expression`, relative to the given

311+-- row for an update, and closed for an insert.

312+data ColumnValue

313+ (columns :: RelationType)

314+ (params :: [NullityType])

315+ (ty :: ColumnType)

316+ where

317+ Same :: ColumnValue (column ': columns) params ty

318+ Default :: ColumnValue columns params ('Def :=> ty)

319+ Set

320+ :: (forall table. Expression '[table ::: columns] 'Ungrouped params ty)

321+ -> ColumnValue columns params (constraint :=> ty)

377322

378323-- | A `ReturningClause` computes and return value(s) based

379324-- on each row actually inserted, updated or deleted. This is primarily

@@ -381,100 +326,71 @@ instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where

381326-- serial sequence number. However, any expression using the table's columns

382327-- is allowed. Only rows that were successfully inserted or updated or

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

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

385−-- the row will not be returned. `Returning` `Star` will return all columns

386−-- in the row. Use `Returning` `Nil` in the common case where no return

329+-- but not updated because an `OnConflictDoUpdate` condition was not satisfied,

330+-- the row will not be returned. `ReturningStar` will return all columns

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

387332-- values are desired.

388−newtype ReturningClause commons schemas params from row =

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

390−

391−instance RenderSQL (ReturningClause commons schemas params from row) where

392− renderSQL = \case

393− Returning (List Nil) -> ""

394− Returning selection -> " RETURNING" <+> renderSQL selection

395−

396−-- | `Returning` a `List`

397−pattern Returning_

398− :: SOP.SListI row

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

400− -- ^ row of values

401− -> ReturningClause commons schemas params from row

402−pattern Returning_ list = Returning (List list)

333+data ReturningClause

334+ (columns :: ColumnsType)

335+ (params :: [NullityType])

336+ (results :: RelationType)

337+ where

338+ ReturningStar

339+ :: results ~ ColumnsToRelation columns

340+ => ReturningClause columns params results

341+ Returning

342+ :: rel ~ ColumnsToRelation columns

343+ => NP (Aliased (Expression '[table ::: rel] 'Ungrouped params)) results

344+ -> ReturningClause columns params results

345+

346+-- | Render a `ReturningClause`.

347+renderReturningClause

348+ :: SOP.SListI results

349+ => ReturningClause params columns results

350+ -> ByteString

351+renderReturningClause = \case

352+ ReturningStar -> " RETURNING *;"

353+ Returning Nil -> ";"

354+ Returning results -> " RETURNING"

355+ <+> renderCommaSeparated (renderAliasedAs renderExpression) results <> ";"

403356

404357-- | A `ConflictClause` specifies an action to perform upon a constraint

405358-- violation. `OnConflictDoRaise` will raise an error.

406−-- `OnConflict` `DoNothing` simply avoids inserting a row.

407−-- `OnConflict` `DoUpdate` updates the existing row that conflicts with the row

359+-- `OnConflictDoNothing` simply avoids inserting a row.

360+-- `OnConflictDoUpdate` updates the existing row that conflicts with the row

408361-- proposed for insertion.

409−data ConflictClause tab commons schemas params table where

410− OnConflictDoRaise :: ConflictClause tab commons schemas params table

411− OnConflict

412− :: ConflictTarget constraints

413− -- ^ conflict target

414− -> ConflictAction tab commons schemas params columns

415− -- ^ conflict action

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

362+data ConflictClause (columns :: ColumnsType) params where

363+ OnConflictDoRaise :: ConflictClause columns params

364+ OnConflictDoNothing :: ConflictClause columns params

365+ OnConflictDoUpdate

366+ :: NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns

367+ -> [Condition '[table ::: ColumnsToRelation columns] 'Ungrouped params]

368+ -> ConflictClause columns params

417369

418370-- | Render a `ConflictClause`.

419−instance SOP.SListI (TableToColumns table)

420− => RenderSQL (ConflictClause tab commons schemas params table) where

421− renderSQL = \case

422− OnConflictDoRaise -> ""

423− OnConflict target action -> " ON CONFLICT"

424− <+> renderSQL target <+> renderSQL action

425−

426−{- |

427−`ConflictAction` specifies an alternative `OnConflict` action.

428−It can be either `DoNothing`, or a `DoUpdate` clause specifying

429−the exact details of the `update` action to be performed in case of a conflict.

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

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

432−for insertion using the special @#excluded@ table.

433−`OnConflict` `DoNothing` simply avoids inserting a row as its alternative action.

434−`OnConflict` `DoUpdate` updates the existing row that conflicts

435−with the row proposed for insertion as its alternative action.

436−-}

437−data ConflictAction tab commons schemas params columns where

438− DoNothing :: ConflictAction tab commons schemas params columns

439− DoUpdate

440− :: ( row ~ ColumnsToRow columns

441− , SOP.SListI columns

442− , columns ~ (col0 ': cols)

443− , SOP.All (HasIn columns) subcolumns

444− , AllUnique subcolumns )

445− => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]))) subcolumns

446− -> [Condition '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]]

447− -- ^ WHERE `Condition`s

448− -> ConflictAction tab commons schemas params columns

449−

450−instance RenderSQL (ConflictAction tab commons schemas params columns) where

451− renderSQL = \case

452− DoNothing -> "DO NOTHING"

453− DoUpdate updates whs'

454− -> "DO UPDATE SET"

455− <+> renderCommaSeparated renderUpdate updates

456− <> case whs' of

457− [] -> ""

458− wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)

459−

460−renderUpdate

461− :: (forall x. RenderSQL (expr x))

462− => Aliased (Optional expr) ty

371+renderConflictClause

372+ :: SOP.SListI columns

373+ => ConflictClause columns params

463374 -> ByteString

464−renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr

465−

466−-- | A `ConflictTarget` specifies the constraint violation that triggers a

467−-- `ConflictAction`.

468−data ConflictTarget constraints where

469− OnConstraint

470− :: Has con constraints constraint

471− => Alias con

472− -> ConflictTarget constraints

473−

474−-- | Render a `ConflictTarget`

475−instance RenderSQL (ConflictTarget constraints) where

476− renderSQL (OnConstraint con) =

477− "ON" <+> "CONSTRAINT" <+> renderSQL con

375+renderConflictClause = \case

376+ OnConflictDoRaise -> ""

377+ OnConflictDoNothing -> " ON CONFLICT DO NOTHING"

378+ OnConflictDoUpdate updates whs'

379+ -> " ON CONFLICT DO UPDATE SET"

380+ <+> renderCommaSeparatedMaybe renderUpdate updates

381+ <> case whs' of

382+ [] -> ""

383+ wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)

384+ where

385+ renderUpdate

386+ :: Aliased (ColumnValue columns params) column

387+ -> Maybe ByteString

388+ renderUpdate = \case

389+ Same `As` _ -> Nothing

390+ Default `As` column -> Just $

391+ renderAlias column <+> "=" <+> "DEFAULT"

392+ Set expression `As` column -> Just $

393+ renderAlias column <+> "=" <+> renderExpression expression

478394

479395{-----------------------------------------

480396UPDATE statements

@@ -484,95 +400,113 @@ UPDATE statements

484400-- in all rows that satisfy the condition.

485401update

486402 :: ( SOP.SListI columns

487− , SOP.SListI row1

488− , Has sch schemas schema

403+ , SOP.SListI results

489404 , Has tab schema ('Table table)

490− , row0 ~ TableToRow table

491− , columns ~ TableToColumns table

492− , SOP.All (HasIn columns) subcolumns

493− , AllUnique subcolumns )

494− => QualifiedAlias sch tab -- ^ table to update

495− -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row0]))) subcolumns

405+ , columns ~ TableToColumns table )

406+ => Alias tab -- ^ table to update

407+ -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns

496408 -- ^ modified values to replace old values

497− -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]

409+ -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params

498410 -- ^ condition under which to perform update on a row

499− -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return

500− -> Manipulation commons schemas params row1

411+ -> ReturningClause columns params results -- ^ results to return

412+ -> Manipulation schema params results

501413update tab columns wh returning = UnsafeManipulation $

502414 "UPDATE"

503− <+> renderSQL tab

415+ <+> renderAlias tab

504416 <+> "SET"

505− <+> renderCommaSeparated renderUpdate columns

506− <+> "WHERE" <+> renderSQL wh

507− <> renderSQL returning

417+ <+> renderCommaSeparatedMaybe renderUpdate columns

418+ <+> "WHERE" <+> renderExpression wh

419+ <> renderReturningClause returning

420+ where

421+ renderUpdate

422+ :: Aliased (ColumnValue columns params) column

423+ -> Maybe ByteString

424+ renderUpdate = \case

425+ Same `As` _ -> Nothing

426+ Default `As` column -> Just $

427+ renderAlias column <+> "=" <+> "DEFAULT"

428+ Set expression `As` column -> Just $

429+ renderAlias column <+> "=" <+> renderExpression expression

508430

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

510432update_

511433 :: ( SOP.SListI columns

512− , Has sch schemas schema

513434 , Has tab schema ('Table table)

514− , row ~ TableToRow table

515− , columns ~ TableToColumns table

516− , SOP.All (HasIn columns) subcolumns

517− , AllUnique subcolumns )

518− => QualifiedAlias sch tab -- ^ table to update

519− -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row]))) subcolumns

435+ , columns ~ TableToColumns table )

436+ => Alias tab -- ^ table to update

437+ -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns

520438 -- ^ modified values to replace old values

521− -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]

439+ -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params

522440 -- ^ condition under which to perform update on a row

523− -> Manipulation commons schemas params '[]

524−update_ tab columns wh = update tab columns wh (Returning_ Nil)

441+ -> Manipulation schema params '[]

442+update_ tab columns wh = update tab columns wh (Returning Nil)

525443

526444{-----------------------------------------

527445DELETE statements

528446-----------------------------------------}

529447

530−-- | Specify additional tables with `Using`

531−-- an `also` list of table expressions, allowing columns

532−-- from other tables to appear in the WHERE condition.

533−-- This is similar to the list of tables that can be specified

534−-- in the FROM Clause of a SELECT statement;

535−-- for example, an alias for the table name can be specified.

536−-- Do not repeat the target table in the `Using` list,

537−-- unless you wish to set up a self-join.

538−-- `NoUsing` if no additional tables are to be used.

539−data UsingClause commons schemas params from where

540− NoUsing :: UsingClause commons schemas params '[]

541− Using

542− :: FromClause '[] commons schemas params from

543− -- ^ what to use

544− -> UsingClause commons schemas params from

545−

546−-- | Delete rows from a table.

448+-- | Delete rows of a table.

547449deleteFrom

548− :: ( SOP.SListI row1

549− , Has sch schemas schema

450+ :: ( SOP.SListI results

550451 , Has tab schema ('Table table)

551− , row0 ~ TableToRow table

552452 , columns ~ TableToColumns table )

553− => QualifiedAlias sch tab -- ^ table to delete from

554− -> UsingClause commons schemas params from

555− -> Condition '[] commons 'Ungrouped schemas params (tab ::: row0 ': from)

453+ => Alias tab -- ^ table to delete from

454+ -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params

556455 -- ^ condition under which to delete a row

557− -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return

558− -> Manipulation commons schemas params row1

559−deleteFrom tab using wh returning = UnsafeManipulation $

560− "DELETE FROM"

561− <+> renderSQL tab

562− <> case using of

563− NoUsing -> ""

564− Using tables -> " USING" <+> renderSQL tables

565− <+> "WHERE" <+> renderSQL wh

566− <> renderSQL returning

456+ -> ReturningClause columns params results -- ^ results to return

457+ -> Manipulation schema params results

458+deleteFrom tab wh returning = UnsafeManipulation $

459+ "DELETE FROM" <+> renderAlias tab

460+ <+> "WHERE" <+> renderExpression wh

461+ <> renderReturningClause returning

567462

568463-- | Delete rows returning `Nil`.

569464deleteFrom_

570− :: ( Has sch schemas schema

571− , Has tab schema ('Table table)

572− , row ~ TableToRow table

465+ :: ( Has tab schema ('Table table)

573466 , columns ~ TableToColumns table )

574− => QualifiedAlias sch tab -- ^ table to delete from

575− -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]

467+ => Alias tab -- ^ table to delete from

468+ -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params

576469 -- ^ condition under which to delete a row

577− -> Manipulation commons schemas params '[]

578−deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil)

470+ -> Manipulation schema params '[]

471+deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil)

472+

473+{-----------------------------------------

474+WITH statements

475+-----------------------------------------}

476+

477+-- | `with` provides a way to write auxiliary statements for use in a larger statement.

478+-- These statements, which are often referred to as Common Table Expressions or CTEs,

479+-- can be thought of as defining temporary tables that exist just for one statement.

480+--

481+-- >>> type ProductsTable = '[] :=> '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]

482+--

483+-- >>> :{

484+-- let

485+-- manipulation :: Manipulation '["products" ::: 'Table ProductsTable, "products_deleted" ::: 'Table ProductsTable] '[ 'NotNull 'PGdate] '[]

486+-- manipulation = with

487+-- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rows :* Nil)

488+-- (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rows `As` #t)))))

489+-- in renderManipulation manipulation

490+-- :}

491+-- "WITH \"deleted_rows\" AS (DELETE FROM \"products\" WHERE (\"date\" < ($1 :: date)) RETURNING *) INSERT INTO \"products_deleted\" SELECT * FROM \"deleted_rows\" AS \"t\";"

492+with

493+ :: SOP.SListI commons

494+ => NP (Aliased (Manipulation schema params)) commons

495+ -- ^ common table expressions

496+ -> Manipulation (With commons schema) params results

497+ -> Manipulation schema params results

498+with commons manipulation = UnsafeManipulation $

499+ "WITH" <+> renderCommaSeparated renderCommon commons

500+ <+> renderManipulation manipulation

501+ where

502+ renderCommon

503+ :: Aliased (Manipulation schema params) common

504+ -> ByteString

505+ renderCommon (common `As` alias) =

506+ renderAlias alias <+> "AS" <+>

507+ let

508+ str = renderManipulation common

509+ len = ByteString.length str

510+ str' = ByteString.take (len - 1) str -- remove ';'

511+ in

512+ parenthesized str'

squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+219−349

@@ -8,13 +8,8 @@ Stability: experimental

88This module defines a `Migration` type to safely

99change the schema of your database over time. Let's see an example!

1010

11−First turn on some extensions.

12−

1311>>> :set -XDataKinds -XOverloadedLabels

1412>>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators

15−

16−Next, let's define our `TableType`s.

17−

1813>>> :{

1914type UsersTable =

2015 '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

@@ -25,7 +20,7 @@ type UsersTable =

2520

2621>>> :{

2722type EmailsTable =

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

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

2924 , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]

3025 ] :=>

3126 '[ "id" ::: 'Def :=> 'NotNull 'PGint4

@@ -34,293 +29,250 @@ type EmailsTable =

3429 ]

3530:}

3631

37−Now we can define some `Migration`s to make our tables.

38−

3932>>> :{

4033let

41− makeUsers :: Migration Definition (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]]

34+ makeUsers :: Migration IO '[] '["users" ::: 'Table UsersTable]

4235 makeUsers = Migration

4336 { name = "make users table"

44− , up = createTable #users

45− ( serial `as` #id :*

46− notNullable text `as` #name )

47− ( primaryKey #id `as` #pk_users )

48− , down = dropTable #users

37+ , up = void . define $

38+ createTable #users

39+ ( serial `As` #id :*

40+ (text & notNull) `As` #name :* Nil )

41+ ( primaryKey #id `As` #pk_users :* Nil )

42+ , down = void . define $ dropTable #users

4943 }

5044:}

5145

5246>>> :{

5347let

54− makeEmails :: Migration Definition '["public" ::: '["users" ::: 'Table UsersTable]]

55− '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]]

48+ makeEmails :: Migration IO '["users" ::: 'Table UsersTable]

49+ '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]

5650 makeEmails = Migration

5751 { name = "make emails table"

58− , up = createTable #emails

59− ( serial `as` #id :*

60− notNullable int `as` #user_id :*

61− nullable text `as` #email )

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

52+ , up = void . define $

53+ createTable #emails

54+ ( serial `As` #id :*

55+ (int & notNull) `As` #user_id :*

56+ (text & null') `As` #email :* Nil )

57+ ( primaryKey #id `As` #pk_emails :*

6358 foreignKey #user_id #users #id

64− OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

65− , down = dropTable #emails

59+ OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )

60+ , down = void . define $ dropTable #emails

6661 }

6762:}

6863

69−Now that we have a couple migrations we can chain them together into a `Path`.

64+Now that we have a couple migrations we can chain them together.

7065

7166>>> let migrations = makeUsers :>> makeEmails :>> Done

7267

73−Now run the migrations.

68+>>> :{

69+let

70+ numMigrations

71+ :: Has "schema_migrations" schema ('Table MigrationsTable)

72+ => PQ schema schema IO ()

73+ numMigrations = do

74+ result <- runQuery (selectStar (from (table (#schema_migrations `As` #m))))

75+ num <- ntuples result

76+ liftBase $ print num

77+:}

7478

75−>>> import Control.Monad.IO.Class

7679>>> :{

7780withConnection "host=localhost port=5432 dbname=exampledb" $

7881 manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")

7982 -- suppress notices

80− & pqThen (liftIO (putStrLn "Migrate"))

8183 & pqThen (migrateUp migrations)

82− & pqThen (liftIO (putStrLn "Rollback"))

84+ & pqThen numMigrations

8385 & pqThen (migrateDown migrations)

86+ & pqThen numMigrations

8487:}

85−Migrate

86−Rollback

87−

88−We can also create a simple executable using `defaultMain`.

89−

90−>>> let main = defaultMain "host=localhost port=5432 dbname=exampledb" migrations

91−

92−>>> withArgs [] main

93−Invalid command: "". Use:

94−migrate to run all available migrations

95−rollback to rollback all available migrations

96−status to display migrations run and migrations left to run

97−

98−>>> withArgs ["status"] main

99−Migrations already run:

100− None

101−Migrations left to run:

102− - make users table

103− - make emails table

104−

105−>>> withArgs ["migrate"] main

106−Migrations already run:

107− - make users table

108− - make emails table

109−Migrations left to run:

110− None

111−

112−>>> withArgs ["rollback"] main

113−Migrations already run:

114− None

115−Migrations left to run:

116− - make users table

117− - make emails table

118−

119−In addition to enabling `Migration`s using pure SQL `Definition`s for

120−the `up` and `down` instructions, you can also perform impure `IO` actions

121−by using a `Migration`s over the `Terminally` `PQ` `IO` category.

88+Row 2

89+Row 0

12290-}

12391

12492{-# LANGUAGE

125− DataKinds

126− , DeriveGeneric

127− , FlexibleContexts

128− , FlexibleInstances

93+ ScopedTypeVariables

94+ , OverloadedStrings

95+ , DataKinds

12996 , GADTs

13097 , LambdaCase

131− , OverloadedLabels

132− , OverloadedStrings

13398 , PolyKinds

134− , QuantifiedConstraints

135− , RankNTypes

99+ , OverloadedLabels

136100 , TypeApplications

101+ , FlexibleContexts

137102 , TypeOperators

138103#-}

139104

140105module Squeal.PostgreSQL.Migration

141106 ( -- * Migration

142107 Migration (..)

143− , Migratory (..)

144− , Terminally (..)

145− , terminally

146− , pureMigration

108+ , migrateUp

109+ , migrateDown

110+ -- * Aligned lists

111+ , AlignedList (..)

112+ , single

113+ -- * Migration table

147114 , MigrationsTable

148− , defaultMain

115+ , createMigrations

116+ , insertMigration

117+ , deleteMigration

118+ , selectMigration

149119 ) where

150120

151121import Control.Category

152122import Control.Monad

153−import Data.ByteString (ByteString)

154−import Data.Foldable (traverse_)

123+import Control.Monad.Base

124+import Control.Monad.Trans.Control

125+import Data.Monoid

126+import Generics.SOP (K(..))

155127import Data.Function ((&))

156−import Data.List ((\\))

157128import Data.Text (Text)

158−import Data.Time (UTCTime)

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

160−import System.Environment

161−import UnliftIO (MonadIO (..))

129+import Prelude hiding (id, (.))

162130

163−import qualified Data.Text.IO as Text (putStrLn)

164−import qualified Generics.SOP as SOP

165−import qualified GHC.Generics as GHC

131+import Squeal.PostgreSQL

166132

167−import Squeal.PostgreSQL.Alias

168−import Squeal.PostgreSQL.Binary

169−import Squeal.PostgreSQL.Definition

170−import Squeal.PostgreSQL.Definition.Table

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

172−import Squeal.PostgreSQL.Expression.Comparison

173−import Squeal.PostgreSQL.Expression.Parameter

174−import Squeal.PostgreSQL.Expression.Time

175−import Squeal.PostgreSQL.Expression.Type

176−import Squeal.PostgreSQL.List

177−import Squeal.PostgreSQL.Manipulation

178−import Squeal.PostgreSQL.PQ

179−import Squeal.PostgreSQL.Query

180−import Squeal.PostgreSQL.Schema

181−import Squeal.PostgreSQL.Transaction

182−

183−-- | A `Migration` is a named "isomorphism" over a given category.

184−-- It should contain an inverse pair of `up` and `down`

185−-- instructions and a unique `name`.

186−data Migration p schemas0 schemas1 = Migration

133+-- | A `Migration` should contain an inverse pair of

134+-- `up` and `down` instructions and a unique `name`.

135+data Migration io schema0 schema1 = Migration

187136 { name :: Text -- ^ The `name` of a `Migration`.

188137 -- Each `name` in a `Migration` should be unique.

189− , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.

190− , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.

191− } deriving (GHC.Generic)

192−

193−{- |

194−A `Migratory` @p@ is a `Category` for which one can execute or rewind

195−a `Path` of `Migration`s over @p@. This includes the category of pure

196−SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.

197−-}

198−class Category p => Migratory p where

199−

200− {- |

201− Run a `Path` of `Migration`s.

202− Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.

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

204− if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.

205− -}

206− migrateUp

207− :: Path (Migration p) schemas0 schemas1

208− -> PQ schemas0 schemas1 IO ()

209−

210− {- |

211− Rewind a `Path` of `Migration`s.

212− Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.

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

214− if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.

215− -}

216− migrateDown

217− :: Path (Migration p) schemas0 schemas1

218− -> PQ schemas1 schemas0 IO ()

219−

220−instance Migratory Definition where

221− migrateUp = migrateUp . cmap pureMigration

222− migrateDown = migrateDown . cmap pureMigration

223−

224−{- | `Terminally` turns an indexed monad transformer and the monad it transforms

225−into a category by restricting the return type to @()@ and permuting the type variables.

226−This is similar to how applying a monad to @()@ yields a monoid.

227−Since a `Terminally` action has a trivial return value, the only reason

228−to run one is for the side effects, in particular database and other IO effects.

229−-}

230−newtype Terminally trans monad x0 x1 = Terminally

231− { runTerminally :: trans x0 x1 monad () }

232− deriving GHC.Generic

233−

234−instance

235− ( IndexedMonadTransPQ trans

236− , Monad monad

237− , forall x0 x1. x0 ~ x1 => Monad (trans x0 x1 monad) )

238− => Category (Terminally trans monad) where

239− id = Terminally (return ())

240− Terminally g . Terminally f = Terminally $ pqThen g f

241−

242−-- | `terminally` ignores the output of a computation, returning @()@ and

243−-- wrapping it up into a `Terminally`. You can lift an action in the base monad

244−-- by using @terminally . lift@.

245−terminally

246− :: Functor (trans x0 x1 monad)

247− => trans x0 x1 monad ignore

248− -> Terminally trans monad x0 x1

249−terminally = Terminally . void

250−

251−-- | A `pureMigration` turns a `Migration` involving only pure SQL

252−-- `Definition`s into a `Migration` that may be combined with arbitrary `IO`.

253−pureMigration

254− :: Migration Definition schemas0 schemas1

255− -> Migration (Terminally PQ IO) schemas0 schemas1

256−pureMigration migration = Migration

257− { name = name migration

258− , up = terminally . define $ up migration

259− , down = terminally . define $ down migration

138+ , up :: PQ schema0 schema1 io () -- ^ The `up` instruction of a `Migration`.

139+ , down :: PQ schema1 schema0 io () -- ^ The `down` instruction of a `Migration`.

260140 }

261141

262−instance Migratory (Terminally PQ IO) where

263−

264− migrateUp migration = unsafePQ . transactionally_ $ do

265− define createMigrations

266− upMigrations migration

267−

268− where

269−

270− upMigrations

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

272− -> PQ MigrationsSchemas MigrationsSchemas IO ()

273− upMigrations = \case

274− Done -> return ()

275− step :>> steps -> upMigration step >> upMigrations steps

276−

277− upMigration

278− :: Migration (Terminally PQ IO) schemas0 schemas1

279− -> PQ MigrationsSchemas MigrationsSchemas IO ()

280− upMigration step = do

281− executed <- queryExecuted step

282− unless (executed == 1) $ do

283− unsafePQ . runTerminally $ up step

284− manipulateParams_ insertMigration (Only (name step))

285−

286− queryExecuted

287− :: Migration (Terminally PQ IO) schemas0 schemas1

288− -> PQ MigrationsSchemas MigrationsSchemas IO Row

289− queryExecuted step = do

290− result <- runQueryParams selectMigration (Only (name step))

291− ntuples result

292−

293− migrateDown migrations = unsafePQ . transactionally_ $ do

294− define createMigrations

295− downMigrations migrations

296−

297− where

298−

299− downMigrations

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

301− -> PQ MigrationsSchemas MigrationsSchemas IO ()

302− downMigrations = \case

303− Done -> return ()

304− step :>> steps -> downMigrations steps >> downMigration step

305−

306− downMigration

307− :: Migration (Terminally PQ IO) schemas0 schemas1

308− -> PQ MigrationsSchemas MigrationsSchemas IO ()

309− downMigration step = do

310− executed <- queryExecuted step

311− unless (executed == 0) $ do

312− unsafePQ . runTerminally $ down step

313− manipulateParams_ deleteMigration (Only (name step))

142+-- | An `AlignedList` is a type-aligned list or free category.

143+data AlignedList p x0 x1 where

144+ Done :: AlignedList p x x

145+ (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2

146+infixr 7 :>>

147+instance Category (AlignedList p) where

148+ id = Done

149+ (.) list = \case

150+ Done -> list

151+ step :>> steps -> step :>> (steps >>> list)

152+

153+-- | A `single` step.

154+single :: p x0 x1 -> AlignedList p x0 x1

155+single step = step :>> Done

156+

157+-- | Run `Migration`s by creating the `MigrationsTable`

158+-- if it does not exist and then in a transaction, for each each `Migration`

159+-- query to see if the `Migration` is executed. If not, then

160+-- execute the `Migration` and insert its row in the `MigrationsTable`.

161+migrateUp

162+ :: MonadBaseControl IO io

163+ => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run

164+ -> PQ

165+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

166+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

167+ io ()

168+migrateUp migration =

169+ define createMigrations

170+ & pqBind okResult

171+ & pqThen (transactionallySchema_ (upMigrations migration))

172+ where

314173

315− queryExecuted

316− :: Migration (Terminally PQ IO) schemas0 schemas1

317− -> PQ MigrationsSchemas MigrationsSchemas IO Row

318− queryExecuted step = do

319− result <- runQueryParams selectMigration (Only (name step))

320− ntuples result

174+ upMigrations

175+ :: MonadBaseControl IO io

176+ => AlignedList (Migration io) schema0 schema1

177+ -> PQ

178+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

179+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

180+ io ()

181+ upMigrations = \case

182+ Done -> return ()

183+ step :>> steps -> upMigration step & pqThen (upMigrations steps)

184+

185+ upMigration

186+ :: MonadBase IO io

187+ => Migration io schema0 schema1 -> PQ

188+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

189+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

190+ io ()

191+ upMigration step =

192+ queryExecuted step

193+ & pqBind (\ executed ->

194+ if executed == 1 -- up step has already been executed

195+ then PQ (\ _ -> return (K ())) -- unsafely switch schemas

196+ else

197+ pqEmbed (up step) -- safely switch schemas

198+ & pqThen (manipulateParams insertMigration (Only (name step)))

199+ -- insert execution record

200+ & pqBind okResult)

201+

202+ queryExecuted

203+ :: MonadBase IO io

204+ => Migration io schema0 schema1 -> PQ

205+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

206+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

207+ io Row

208+ queryExecuted step = do

209+ result <- runQueryParams selectMigration (Only (name step))

210+ okResult result

211+ ntuples result

212+

213+-- | Rewind `Migration`s by creating the `MigrationsTable`

214+-- if it does not exist and then in a transaction, for each each `Migration`

215+-- query to see if the `Migration` is executed. If it is, then

216+-- rewind the `Migration` and delete its row in the `MigrationsTable`.

217+migrateDown

218+ :: MonadBaseControl IO io

219+ => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind

220+ -> PQ

221+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

222+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

223+ io ()

224+migrateDown migrations =

225+ define createMigrations

226+ & pqBind okResult

227+ & pqThen (transactionallySchema_ (downMigrations migrations))

228+ where

321229

322−unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x

323−unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK

230+ downMigrations

231+ :: MonadBaseControl IO io

232+ => AlignedList (Migration io) schema0 schema1 -> PQ

233+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

234+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

235+ io ()

236+ downMigrations = \case

237+ Done -> return ()

238+ step :>> steps -> downMigrations steps & pqThen (downMigration step)

239+

240+ downMigration

241+ :: MonadBase IO io

242+ => Migration io schema0 schema1 -> PQ

243+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

244+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

245+ io ()

246+ downMigration step =

247+ queryExecuted step

248+ & pqBind (\ executed ->

249+ if executed == 0 -- up step has not been executed

250+ then PQ (\ _ -> return (K ())) -- unsafely switch schemas

251+ else

252+ pqEmbed (down step) -- safely switch schemas

253+ & pqThen (manipulateParams deleteMigration (Only (name step)))

254+ -- delete execution record

255+ & pqBind okResult)

256+

257+ queryExecuted

258+ :: MonadBase IO io

259+ => Migration io schema0 schema1 -> PQ

260+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

261+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

262+ io Row

263+ queryExecuted step = do

264+ result <- runQueryParams selectMigration (Only (name step))

265+ okResult result

266+ ntuples result

267+

268+okResult :: MonadBase IO io => K Result results -> PQ schema schema io ()

269+okResult result = do

270+ status <- resultStatus result

271+ when (not (status `elem` [CommandOk, TuplesOk])) $ do

272+ errorMessageMaybe <- resultErrorMessage result

273+ case errorMessageMaybe of

274+ Nothing -> error "migrateDown: unknown error"

275+ Just msg -> error ("migrationDown: " <> show msg)

324276

325277-- | The `TableType` for a Squeal migration.

326278type MigrationsTable =

@@ -329,120 +281,38 @@ type MigrationsTable =

329281 , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz

330282 ]

331283

332−data MigrationRow =

333− MigrationRow { migrationName :: Text

334− , migrationTime :: UTCTime }

335− deriving (GHC.Generic, Show)

336−

337−instance SOP.Generic MigrationRow

338−instance SOP.HasDatatypeInfo MigrationRow

339−

340−type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable]

341−type MigrationsSchemas = Public MigrationsSchema

342−

343284-- | Creates a `MigrationsTable` if it does not already exist.

344−createMigrations :: Definition MigrationsSchemas MigrationsSchemas

285+createMigrations

286+ :: Has "schema_migrations" schema ('Table MigrationsTable)

287+ => Definition schema schema

345288createMigrations =

346289 createTableIfNotExists #schema_migrations

347− ( (text & notNullable) `as` #name :*

348− (timestampWithTimeZone & notNullable & default_ currentTimestamp)

349− `as` #executed_at )

350− ( unique #name `as` #migrations_unique_name )

351−

352−-- | Inserts a `Migration` into the `MigrationsTable`, returning

353−-- the time at which it was inserted.

354−insertMigration :: Manipulation_ MigrationsSchemas (Only Text) ()

355−insertMigration = insertInto_ #schema_migrations

356− (Values_ (Set (param @1) `as` #name :* Default `as` #executed_at))

357−

358−-- | Deletes a `Migration` from the `MigrationsTable`, returning

359−-- the time at which it was inserted.

360−deleteMigration :: Manipulation_ MigrationsSchemas (Only Text) ()

290+ ( (text & notNull) `As` #name :*

291+ (timestampWithTimeZone & notNull & default_ currentTimestamp)

292+ `As` #executed_at :* Nil )

293+ ( unique (#name :* Nil) `As` #migrations_unique_name :* Nil )

294+

295+-- | Inserts a `Migration` into the `MigrationsTable`

296+insertMigration

297+ :: Has "schema_migrations" schema ('Table MigrationsTable)

298+ => Manipulation schema '[ 'NotNull 'PGtext] '[]

299+insertMigration = insertRow_ #schema_migrations

300+ ( Set (param @1) `As` #name :*

301+ Default `As` #executed_at :* Nil )

302+

303+-- | Deletes a `Migration` from the `MigrationsTable`

304+deleteMigration

305+ :: Has "schema_migrations" schema ('Table MigrationsTable)

306+ => Manipulation schema '[ 'NotNull 'PGtext ] '[]

361307deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)

362308

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

364−-- the time at which it was inserted.

310+-- the time at which it was executed.

365311selectMigration

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

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

368− $ from (table (#schema_migrations))

369− & where_ (#name .== param @1)

370−

371−selectMigrations :: Query_ MigrationsSchemas () MigrationRow

372−selectMigrations = select_

373− (#name `as` #migrationName :* #executed_at `as` #migrationTime)

374− (from (table #schema_migrations))

375−

376−data MigrateCommand

377− = MigrateStatus

378− | MigrateUp

379− | MigrateDown deriving (GHC.Generic, Show)

380−

381−{- | `defaultMain` creates a simple executable

382−from a connection string and a list of `Migration`s. -}

383−defaultMain

384− :: Migratory p

385− => ByteString

386− -- ^ connection string

387− -> Path (Migration p) db0 db1

388− -- ^ migrations

389− -> IO ()

390−defaultMain connectTo migrations = do

391− command <- readCommandFromArgs

392− maybe (pure ()) performCommand command

393−

394− where

395−

396− performCommand :: MigrateCommand -> IO ()

397− performCommand = \case

398− MigrateStatus -> withConnection connectTo $

399− suppressNotices >> migrateStatus

400− MigrateUp -> withConnection connectTo $

401− suppressNotices & pqThen (migrateUp migrations) & pqThen migrateStatus

402− MigrateDown -> withConnection connectTo $

403− suppressNotices & pqThen (migrateDown migrations) & pqThen migrateStatus

404−

405− migrateStatus :: PQ schema schema IO ()

406− migrateStatus = unsafePQ $ do

407− runNames <- getRunMigrationNames

408− let names = ctoList name migrations

409− unrunNames = names \\ runNames

410− liftIO $ displayRunned runNames >> displayUnrunned unrunNames

411−

412− suppressNotices :: PQ schema schema IO ()

413− suppressNotices = manipulate_ $

414− UnsafeManipulation "SET client_min_messages TO WARNING;"

415−

416− readCommandFromArgs :: IO (Maybe MigrateCommand)

417− readCommandFromArgs = getArgs >>= \case

418− ["migrate"] -> pure . Just $ MigrateUp

419− ["rollback"] -> pure . Just $ MigrateDown

420− ["status"] -> pure . Just $ MigrateStatus

421− args -> displayUsage args >> pure Nothing

422−

423− displayUsage :: [String] -> IO ()

424− displayUsage args = do

425− putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:"

426− putStrLn "migrate to run all available migrations"

427− putStrLn "rollback to rollback all available migrations"

428− putStrLn "status to display migrations run and migrations left to run"

429−

430− getRunMigrationNames :: (MonadIO m) => PQ db0 db0 m [Text]

431− getRunMigrationNames =

432− fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery selectMigrations)) >>= getRows)

433−

434− displayListOfNames :: [Text] -> IO ()

435− displayListOfNames [] = Text.putStrLn " None"

436− displayListOfNames xs =

437− let singleName n = Text.putStrLn $ " - " <> n

438− in traverse_ singleName xs

439−

440− displayUnrunned :: [Text] -> IO ()

441− displayUnrunned unrunned =

442− Text.putStrLn "Migrations left to run:"

443− >> displayListOfNames unrunned

444−

445− displayRunned :: [Text] -> IO ()

446− displayRunned runned =

447− Text.putStrLn "Migrations already run:"

448− >> displayListOfNames runned

312+ :: Has "schema_migrations" schema ('Table MigrationsTable)

313+ => Query schema '[ 'NotNull 'PGtext ]

314+ '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]

315+selectMigration = select

316+ (#executed_at `As` #executed_at :* Nil)

317+ ( from (table (#schema_migrations `As` #m))

318+ & where_ (#name .== param @1))

squeal-postgresql/src/Squeal/PostgreSQL/PG.hsdeleted−388

@@ -1,388 +0,0 @@

1−{-|

2−Module: Squeal.PostgreSQL.PG

3−Description: Embedding of Haskell types into Postgres's type system

4−Copyright: (c) Eitan Chatav, 2010

5−Maintainer: eitan@morphism.tech

6−Stability: experimental

7−

8−`Squeal.PostgreSQL.PG` provides type families for turning Haskell

9−`Type`s into corresponding Postgres types.

10−-}

11−{-# LANGUAGE

12− AllowAmbiguousTypes

13− , DeriveAnyClass

14− , DeriveFoldable

15− , DeriveFunctor

16− , DeriveGeneric

17− , DeriveTraversable

18− , DerivingStrategies

19− , DefaultSignatures

20− , FlexibleContexts

21− , FlexibleInstances

22− , FunctionalDependencies

23− , GADTs

24− , LambdaCase

25− , MultiParamTypeClasses

26− , OverloadedStrings

27− , ScopedTypeVariables

28− , TypeApplications

29− , TypeFamilies

30− , TypeInType

31− , TypeOperators

32− , UndecidableInstances

33− , UndecidableSuperClasses

34−#-}

35−

36−module Squeal.PostgreSQL.PG

37− ( -- * PG embeddings

38− PG

39− , NullPG

40− , TuplePG

41− , RowPG

42− -- * Storage newtypes

43− , Money (..)

44− , Json (..)

45− , Jsonb (..)

46− , Composite (..)

47− , Enumerated (..)

48− , VarArray (..)

49− , FixArray (..)

50− , LibPQ.Oid (..)

51− -- * Type families

52− , LabelsPG

53− , DimPG

54− , FixPG

55− , TupleOf

56− , TupleCodeOf

57− , RowOf

58− , ConstructorsOf

59− , ConstructorNameOf

60− , ConstructorNamesOf

61− ) where

62−

63−import Data.Aeson (Value)

64−import Data.Kind (Type)

65−import Data.Int (Int16, Int32, Int64)

66−import Data.Scientific (Scientific)

67−import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)

68−import Data.Vector (Vector)

69−import Data.UUID.Types (UUID)

70−import GHC.TypeLits

71−import Network.IP.Addr (NetAddr, IP)

72−

73−import qualified Data.ByteString.Lazy as Lazy (ByteString)

74−import qualified Data.ByteString as Strict (ByteString)

75−import qualified Data.Text.Lazy as Lazy (Text)

76−import qualified Data.Text as Strict (Text)

77−import qualified Database.PostgreSQL.LibPQ as LibPQ

78−import qualified GHC.Generics as GHC

79−import qualified Generics.SOP as SOP

80−import qualified Generics.SOP.Record as SOP

81−import qualified Generics.SOP.Type.Metadata as Type

82−

83−import Squeal.PostgreSQL.Alias

84−import Squeal.PostgreSQL.Schema

85−

86−-- $setup

87−-- >>> import Squeal.PostgreSQL

88−-- >>> import Data.Text (Text)

89−

90−{- | The `PG` type family embeds a subset of Haskell types

91−as Postgres types. As an open type family, `PG` is extensible.

92−

93−>>> :kind! PG LocalTime

94−PG LocalTime :: PGType

95−= 'PGtimestamp

96−

97−>>> newtype MyDouble = My Double

98−>>> :set -XTypeFamilies

99−>>> type instance PG MyDouble = 'PGfloat8

100−-}

101−type family PG (hask :: Type) :: PGType

102−-- | `PGbool`

103−type instance PG Bool = 'PGbool

104−-- | `PGint2`

105−type instance PG Int16 = 'PGint2

106−-- | `PGint4`

107−type instance PG Int32 = 'PGint4

108−-- | `PGint8`

109−type instance PG Int64 = 'PGint8

110−-- | `PGint2`

111−type instance PG LibPQ.Oid = 'PGoid

112−-- | `PGnumeric`

113−type instance PG Scientific = 'PGnumeric

114−-- | `PGfloat4`

115−type instance PG Float = 'PGfloat4

116−-- | `PGfloat8`

117−type instance PG Double = 'PGfloat8

118−-- | `PGchar` @1@

119−type instance PG Char = 'PGchar 1

120−-- | `PGtext`

121−type instance PG Strict.Text = 'PGtext

122−-- | `PGtext`

123−type instance PG Lazy.Text = 'PGtext

124−-- | `PGtext`

125−type instance PG String = 'PGtext

126−-- | `PGbytea`

127−type instance PG Strict.ByteString = 'PGbytea

128−-- | `PGbytea`

129−type instance PG Lazy.ByteString = 'PGbytea

130−-- | `PGtimestamp`

131−type instance PG LocalTime = 'PGtimestamp

132−-- | `PGtimestamptz`

133−type instance PG UTCTime = 'PGtimestamptz

134−-- | `PGdate`

135−type instance PG Day = 'PGdate

136−-- | `PGtime`

137−type instance PG TimeOfDay = 'PGtime

138−-- | `PGtimetz`

139−type instance PG (TimeOfDay, TimeZone) = 'PGtimetz

140−-- | `PGinterval`

141−type instance PG DiffTime = 'PGinterval

142−-- | `PGuuid`

143−type instance PG UUID = 'PGuuid

144−-- | `PGinet`

145−type instance PG (NetAddr IP) = 'PGinet

146−-- | `PGjson`

147−type instance PG Value = 'PGjson

148−

149−{-| The `LabelsPG` type family calculates the constructors of a

150−Haskell enum type.

151−

152−>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic

153−>>> instance SOP.Generic Schwarma

154−>>> instance SOP.HasDatatypeInfo Schwarma

155−>>> :kind! LabelsPG Schwarma

156−LabelsPG Schwarma :: [Type.ConstructorName]

157−= '["Beef", "Lamb", "Chicken"]

158−-}

159−type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where

160− LabelsPG hask =

161− ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask))

162−

163−{- |

164−`RowPG` turns a Haskell `Type` into a `RowType`.

165−

166−`RowPG` may be applied to normal Haskell record types provided they

167−have `SOP.Generic` and `SOP.HasDatatypeInfo` instances;

168−

169−>>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic

170−>>> instance SOP.Generic Person

171−>>> instance SOP.HasDatatypeInfo Person

172−>>> :kind! RowPG Person

173−RowPG Person :: [(Symbol, NullityType)]

174−= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]

175−-}

176−type family RowPG (hask :: Type) :: RowType where

177− RowPG hask = RowOf (SOP.RecordCodeOf hask)

178−

179−-- | `RowOf` applies `NullPG` to the fields of a list.

180−type family RowOf (record :: [(Symbol, Type)]) :: RowType where

181− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': col4 ::: ty4 ': record) =

182− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': col4 ::: NullPG ty4 ': RowOf record

183− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': record) =

184− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': RowOf record

185− RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': record) =

186− col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': RowOf record

187− RowOf (col ::: ty ': col1 ::: ty1 ': record) =

188− col ::: NullPG ty ': col1::: NullPG ty1 ': RowOf record

189− RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record

190− RowOf '[] = '[]

191−

192−{- | `NullPG` turns a Haskell type into a `NullityType`.

193−

194−>>> :kind! NullPG Double

195−NullPG Double :: NullityType

196−= 'NotNull 'PGfloat8

197−>>> :kind! NullPG (Maybe Double)

198−NullPG (Maybe Double) :: NullityType

199−= 'Null 'PGfloat8

200−-}

201−type family NullPG (hask :: Type) :: NullityType where

202− NullPG (Maybe hask) = 'Null (PG hask)

203− NullPG hask = 'NotNull (PG hask)

204−

205−{- | `TuplePG` turns a Haskell tuple type (including record types) into

206−the corresponding list of `NullityType`s.

207−

208−>>> :kind! TuplePG (Double, Maybe Char)

209−TuplePG (Double, Maybe Char) :: [NullityType]

210−= '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)]

211−-}

212−type family TuplePG (hask :: Type) :: [NullityType] where

213− TuplePG hask = TupleOf (TupleCodeOf hask (SOP.Code hask))

214−

215−-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.

216−type family TupleOf (tuple :: [Type]) :: [NullityType] where

217− TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': hask5 ': tuple) =

218− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': NullPG hask5 ': TupleOf tuple

219− TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': tuple) =

220− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': TupleOf tuple

221− TupleOf (hask ': hask1 ': hask2 ': hask3 ': tuple) =

222− NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': TupleOf tuple

223− TupleOf (hask ': hask1 ': hask2 ': tuple) =

224− NullPG hask ': NullPG hask1 ': NullPG hask2 ': TupleOf tuple

225− TupleOf (hask ': hask1 ': tuple) = NullPG hask ': NullPG hask1 ': TupleOf tuple

226− TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple

227− TupleOf '[] = '[]

228−

229−-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`

230−-- and if it's a simple product returns it, otherwise giving a `TypeError`.

231−type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where

232− TupleCodeOf hask '[tuple] = tuple

233− TupleCodeOf hask '[] =

234− TypeError

235− ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."

236− ':$$: 'Text "It is a void type with no constructors."

237− )

238− TupleCodeOf hask (_ ': _ ': _) =

239− TypeError

240− ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."

241− ':$$: 'Text "It is a sum type with more than one constructor."

242− )

243−

244−-- | Calculates constructors of a datatype.

245−type family ConstructorsOf (datatype :: Type.DatatypeInfo)

246− :: [Type.ConstructorInfo] where

247− ConstructorsOf ('Type.ADT _module _datatype constructors) =

248− constructors

249− ConstructorsOf ('Type.Newtype _module _datatype constructor) =

250− '[constructor]

251−

252−-- | Calculates the name of a nullary constructor, otherwise

253−-- generates a type error.

254−type family ConstructorNameOf (constructor :: Type.ConstructorInfo)

255− :: Type.ConstructorName where

256− ConstructorNameOf ('Type.Constructor name) = name

257− ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError

258− ('Text "ConstructorNameOf error: non-nullary constructor "

259− ':<>: 'Text name)

260− ConstructorNameOf ('Type.Record name _fields) = TypeError

261− ('Text "ConstructorNameOf error: non-nullary constructor "

262− ':<>: 'Text name)

263−

264−-- | Calculate the names of nullary constructors.

265−type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])

266− :: [Type.ConstructorName] where

267− ConstructorNamesOf '[] = '[]

268− ConstructorNamesOf (constructor ': constructors) =

269− ConstructorNameOf constructor ': ConstructorNamesOf constructors

270−

271−-- | `DimPG` turns Haskell nested homogeneous tuples into a list of lengths.

272−type family DimPG (hask :: Type) :: [Nat] where

273− DimPG (x,x) = 2 ': DimPG x

274− DimPG (x,x,x) = 3 ': DimPG x

275− DimPG (x,x,x,x) = 4 ': DimPG x

276− DimPG (x,x,x,x,x) = 5 ': DimPG x

277− DimPG (x,x,x,x,x,x) = 6 ': DimPG x

278− DimPG (x,x,x,x,x,x,x) = 7 ': DimPG x

279− DimPG (x,x,x,x,x,x,x,x) = 8 ': DimPG x

280− DimPG (x,x,x,x,x,x,x,x,x) = 9 ': DimPG x

281− DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x

282− DimPG x = '[]

283−

284−-- | `FixPG` extracts `NullPG` of the base type of nested homogeneous tuples.

285−type family FixPG (hask :: Type) :: NullityType where

286− FixPG (x,x) = FixPG x

287− FixPG (x,x,x) = FixPG x

288− FixPG (x,x,x,x) = FixPG x

289− FixPG (x,x,x,x,x) = FixPG x

290− FixPG (x,x,x,x,x,x) = FixPG x

291− FixPG (x,x,x,x,x,x,x) = FixPG x

292− FixPG (x,x,x,x,x,x,x,x) = FixPG x

293− FixPG (x,x,x,x,x,x,x,x,x) = FixPG x

294− FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x

295− FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x

296− FixPG x = NullPG x

297−

298−{- | The `Money` newtype stores a monetary value in terms

299−of the number of cents, i.e. @$2,000.20@ would be expressed as

300−@Money { cents = 200020 }@.

301−

302−>>> import Control.Monad (void)

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

304−>>> import Squeal.PostgreSQL

305−>>> :{

306−let

307− roundTrip :: Query_ (Public '[]) (Only Money) (Only Money)

308− roundTrip = values_ $ parameter @1 money `as` #fromOnly

309−:}

310−

311−>>> let input = Only (Money 20020)

312−

313−>>> :{

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

315− result <- runQueryParams roundTrip input

316− Just output <- firstRow result

317− liftIO . print $ input == output

318−:}

319−True

320−-}

321−newtype Money = Money { cents :: Int64 }

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

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

324−-- | `PGmoney`

325−type instance PG Money = 'PGmoney

326−

327−{- | The `Json` newtype is an indication that the Haskell

328−type it's applied to should be stored as a `PGjson`.

329−-}

330−newtype Json hask = Json {getJson :: hask}

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

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

333−-- | `PGjson`

334−type instance PG (Json hask) = 'PGjson

335−

336−{- | The `Jsonb` newtype is an indication that the Haskell

337−type it's applied to should be stored as a `PGjsonb`.

338−-}

339−newtype Jsonb hask = Jsonb {getJsonb :: hask}

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

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

342−-- | `PGjsonb`

343−type instance PG (Jsonb hask) = 'PGjsonb

344−

345−{- | The `Composite` newtype is an indication that the Haskell

346−type it's applied to should be stored as a `PGcomposite`.

347−-}

348−newtype Composite record = Composite {getComposite :: record}

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

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

351−-- | `PGcomposite` @(@`RowPG` @hask)@

352−type instance PG (Composite hask) = 'PGcomposite (RowPG hask)

353−

354−{- | The `Enumerated` newtype is an indication that the Haskell

355−type it's applied to should be stored as a `PGenum`.

356−-}

357−newtype Enumerated enum = Enumerated {getEnumerated :: enum}

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

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

360−-- | `PGenum` @(@`LabelsPG` @hask)@

361−type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)

362−

363−{- | The `VarArray` newtype is an indication that the Haskell

364−type it's applied to should be stored as a `PGvararray`.

365−

366−>>> :kind! PG (VarArray (Vector Double))

367−PG (VarArray (Vector Double)) :: PGType

368−= 'PGvararray ('NotNull 'PGfloat8)

369−-}

370−newtype VarArray arr = VarArray {getVarArray :: arr}

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

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

373−-- | `PGvararray` @(@`NullPG` @hask)@

374−type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)

375−type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask)

376−

377−{- | The `FixArray` newtype is an indication that the Haskell

378−type it's applied to should be stored as a `PGfixarray`.

379−

380−>>> :kind! PG (FixArray ((Double, Double), (Double, Double)))

381−PG (FixArray ((Double, Double), (Double, Double))) :: PGType

382−= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)

383−-}

384−newtype FixArray arr = FixArray {getFixArray :: arr}

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

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

387−-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@

388−type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)

squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+217−314

@@ -6,12 +6,12 @@ Maintainer: eitan@morphism.tech

66Stability: experimental

88This module is where Squeal commands actually get executed by

9−`Database.PostgreSQL.LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing

9+`LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing

1010a `Definition` and `MonadPQ` for executing a `Manipulation` or `Query`,

1111and a `PQ` type with instances for them.

1212

1313Using Squeal in your application will come down to defining

14−the @schemas@ of your database and including @PQ schemas schemas@ in your

14+the @schema@ of your database and including @PQ schema schema@ in your

1515application's monad transformer stack, giving it an instance of `MonadPQ`.

1616

1717This module also provides functions for retrieving rows from the `LibPQ.Result`

@@ -20,11 +20,15 @@ of executing Squeal commands.

2020

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

2222{-# LANGUAGE

23− DefaultSignatures

23+ DataKinds

24+ , DefaultSignatures

2425 , FunctionalDependencies

26+ , PolyKinds

27+ , DeriveFunctor

2528 , FlexibleContexts

2629 , FlexibleInstances

27− , InstanceSigs

30+ , MagicHash

31+ , MultiParamTypeClasses

2832 , OverloadedStrings

2933 , RankNTypes

3034 , ScopedTypeVariables

@@ -49,7 +53,9 @@ module Squeal.PostgreSQL.PQ

4953 , evalPQ

5054 , IndexedMonadTransPQ (..)

5155 , MonadPQ (..)

52− -- * Results

56+ , PQRun

57+ , pqliftWith

58+ -- * Result

5359 , LibPQ.Result

5460 , LibPQ.Row

5561 , ntuples

@@ -61,33 +67,22 @@ module Squeal.PostgreSQL.PQ

6167 , LibPQ.ExecStatus (..)

6268 , resultStatus

6369 , resultErrorMessage

64− , resultErrorCode

65− -- * Exceptions

66− , SquealException (..)

67− , PQState (..)

68− , okResult

69− , catchSqueal

70− , handleSqueal

71− , trySqueal

7270 ) where

7371

74−import Control.Exception (Exception, throw)

72+import Control.Exception.Lifted

73+import Control.Monad.Base

7574import Control.Monad.Except

7675import Control.Monad.Morph

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

76+import Control.Monad.Trans.Control

7877import Data.ByteString (ByteString)

7978import Data.Foldable

8079import Data.Function ((&))

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

8280import Data.Kind

83−import Data.Text (pack, Text)

81+import Data.Monoid

8482import Data.Traversable

8583import Generics.SOP

86−import PostgreSQL.Binary.Encoding (encodingBytes)

8784

88−import qualified Control.Monad.Fail as Fail

8985import qualified Database.PostgreSQL.LibPQ as LibPQ

90−import qualified PostgreSQL.Binary.Encoding as Encoding

9186

9287import Squeal.PostgreSQL.Binary

9388import Squeal.PostgreSQL.Definition

@@ -100,6 +95,7 @@ import Control.Monad.Trans.Identity

10095import Control.Monad.Trans.Reader

10196import Control.Monad.Trans.Maybe

10297import Control.Monad.Trans.Cont

98+import Control.Monad.Trans.List

10399

104100import qualified Control.Monad.Trans.State.Lazy as Lazy

105101import qualified Control.Monad.Trans.State.Strict as Strict

@@ -108,9 +104,6 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict

108104import qualified Control.Monad.Trans.RWS.Lazy as Lazy

109105import qualified Control.Monad.Trans.RWS.Strict as Strict

110106

111−-- $setup

112−-- >>> import Squeal.PostgreSQL

113−

114107{- | Makes a new connection to the database server.

115108

116109This function opens a new database connection using the parameters taken

@@ -137,22 +130,22 @@ Note that, for now, squeal doesn't offer any protection from connecting

137130with the wrong schema!

138131-}

139132connectdb

140− :: forall schemas io

141− . MonadIO io

133+ :: forall schema io

134+ . MonadBase IO io

142135 => ByteString -- ^ conninfo

143− -> io (K LibPQ.Connection schemas)

144−connectdb = fmap K . liftIO . LibPQ.connectdb

136+ -> io (K LibPQ.Connection schema)

137+connectdb = fmap K . liftBase . LibPQ.connectdb

145138

146139-- | Closes the connection to the server.

147−finish :: MonadIO io => K LibPQ.Connection schemas -> io ()

148−finish = liftIO . LibPQ.finish . unK

140+finish :: MonadBase IO io => K LibPQ.Connection schema -> io ()

141+finish = liftBase . LibPQ.finish . unK

149142

150143-- | Do `connectdb` and `finish` before and after a computation.

151144withConnection

152− :: forall schemas0 schemas1 io x

153− . MonadUnliftIO io

145+ :: forall schema0 schema1 io x

146+ . MonadBaseControl IO io

154147 => ByteString

155− -> PQ schemas0 schemas1 io x

148+ -> PQ schema0 schema1 io x

156149 -> io x

157150withConnection connString action = do

158151 K x <- bracket (connectdb connString) finish (unPQ action)

@@ -160,47 +153,47 @@ withConnection connString action = do

160153

161154-- | Safely `lowerConnection` to a smaller schema.

162155lowerConnection

163− :: K LibPQ.Connection (schema ': schemas)

164− -> K LibPQ.Connection schemas

156+ :: K LibPQ.Connection (table ': schema)

157+ -> K LibPQ.Connection schema

165158lowerConnection (K conn) = K conn

166159

167160-- | We keep track of the schema via an Atkey indexed state monad transformer,

168161-- `PQ`.

169162newtype PQ

170− (schemas0 :: SchemasType)

171− (schemas1 :: SchemasType)

163+ (schema0 :: SchemaType)

164+ (schema1 :: SchemaType)

172165 (m :: Type -> Type)

173166 (x :: Type) =

174− PQ { unPQ :: K LibPQ.Connection schemas0 -> m (K x schemas1) }

167+ PQ { unPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }

175168

176−instance Monad m => Functor (PQ schemas0 schemas1 m) where

169+instance Monad m => Functor (PQ schema0 schema1 m) where

177170 fmap f (PQ pq) = PQ $ \ conn -> do

178171 K x <- pq conn

179172 return $ K (f x)

180173

181−-- | Run a `PQ` and keep the result and the `LibPQ.Connection`.

174+-- | Run a `PQ` and keep the result and the `Connection`.

182175runPQ

183176 :: Functor m

184− => PQ schemas0 schemas1 m x

185− -> K LibPQ.Connection schemas0

186− -> m (x, K LibPQ.Connection schemas1)

177+ => PQ schema0 schema1 m x

178+ -> K LibPQ.Connection schema0

179+ -> m (x, K LibPQ.Connection schema1)

187180runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn

188181 -- K x <- pq conn

189182 -- return (x, K (unK conn))

190183

191−-- | Execute a `PQ` and discard the result but keep the `LibPQ.Connection`.

184+-- | Execute a `PQ` and discard the result but keep the `Connection`.

192185execPQ

193186 :: Functor m

194− => PQ schemas0 schemas1 m x

195− -> K LibPQ.Connection schemas0

196− -> m (K LibPQ.Connection schemas1)

187+ => PQ schema0 schema1 m x

188+ -> K LibPQ.Connection schema0

189+ -> m (K LibPQ.Connection schema1)

197190execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn

198191

199−-- | Evaluate a `PQ` and discard the `LibPQ.Connection` but keep the result.

192+-- | Evaluate a `PQ` and discard the `Connection` but keep the result.

200193evalPQ

201194 :: Functor m

202− => PQ schemas0 schemas1 m x

203− -> K LibPQ.Connection schemas0

195+ => PQ schema0 schema1 m x

196+ -> K LibPQ.Connection schema0

204197 -> m x

205198evalPQ (PQ pq) conn = unK <$> pq conn

206199

@@ -208,56 +201,60 @@ evalPQ (PQ pq) conn = unK <$> pq conn

208201-- [enriched category](https://ncatlab.org/nlab/show/enriched+category).

209202-- An indexed monad transformer transforms a `Monad` into an indexed monad.

210203-- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that

211−-- support running `Definition`s using `define`.

204+-- support running `Definition`s using `define` and embedding a computation

205+-- in a larger schema using `pqEmbed`.

212206class IndexedMonadTransPQ pq where

213207

214208 -- | indexed analog of `<*>`

215209 pqAp

216210 :: Monad m

217− => pq schemas0 schemas1 m (x -> y)

218− -> pq schemas1 schemas2 m x

219− -> pq schemas0 schemas2 m y

211+ => pq schema0 schema1 m (x -> y)

212+ -> pq schema1 schema2 m x

213+ -> pq schema0 schema2 m y

220214

221215 -- | indexed analog of `join`

222216 pqJoin

223217 :: Monad m

224− => pq schemas0 schemas1 m (pq schemas1 schemas2 m y)

225− -> pq schemas0 schemas2 m y

218+ => pq schema0 schema1 m (pq schema1 schema2 m y)

219+ -> pq schema0 schema2 m y

226220 pqJoin pq = pq & pqBind id

227221

228222 -- | indexed analog of `=<<`

229223 pqBind

230224 :: Monad m

231− => (x -> pq schemas1 schemas2 m y)

232− -> pq schemas0 schemas1 m x

233− -> pq schemas0 schemas2 m y

225+ => (x -> pq schema1 schema2 m y)

226+ -> pq schema0 schema1 m x

227+ -> pq schema0 schema2 m y

234228

235229 -- | indexed analog of flipped `>>`

236230 pqThen

237231 :: Monad m

238− => pq schemas1 schemas2 m y

239− -> pq schemas0 schemas1 m x

240− -> pq schemas0 schemas2 m y

232+ => pq schema1 schema2 m y

233+ -> pq schema0 schema1 m x

234+ -> pq schema0 schema2 m y

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

242236

243237 -- | indexed analog of `<=<`

244238 pqAndThen

245239 :: Monad m

246− => (y -> pq schemas1 schemas2 m z)

247− -> (x -> pq schemas0 schemas1 m y)

248− -> x -> pq schemas0 schemas2 m z

240+ => (y -> pq schema1 schema2 m z)

241+ -> (x -> pq schema0 schema1 m y)

242+ -> x -> pq schema0 schema2 m z

249243 pqAndThen g f x = pqBind g (f x)

250244

251− -- | Run a `Definition` with `LibPQ.exec`.

252− --

253− -- It should be functorial in effect.

245+ -- | Safely embed a computation in a larger schema.

246+ pqEmbed

247+ :: Monad m

248+ => pq schema0 schema1 m x

249+ -> pq (table ': schema0) (table : schema1) m x

250+

251+ -- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law

254252 --

255− -- @define id = return ()@

256− -- @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@

253+ -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@

257254 define

258− :: MonadIO io

259− => Definition schemas0 schemas1

260− -> pq schemas0 schemas1 io ()

255+ :: MonadBase IO io

256+ => Definition schema0 schema1

257+ -> pq schema0 schema1 io (K LibPQ.Result '[])

261258

262259instance IndexedMonadTransPQ PQ where

263260

@@ -270,26 +267,26 @@ instance IndexedMonadTransPQ PQ where

270267 K x' <- x conn

271268 unPQ (f x') (K (unK conn))

272269

270+ pqEmbed (PQ pq) = PQ $ \ (K conn) -> do

271+ K x <- pq (K conn)

272+ return $ K x

273+

273274 define (UnsafeDefinition q) = PQ $ \ (K conn) -> do

274− resultMaybe <- liftIO $ LibPQ.exec conn q

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

275276 case resultMaybe of

276− Nothing -> throw $ ResultException

277+ Nothing -> error

277278 "define: LibPQ.exec returned no results"

278− Just result -> K <$> okResult_ result

279+ Just result -> return $ K (K result)

279280

280−{- | `MonadPQ` is an @mtl@ style constraint, similar to

281−`Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` to

281+{- | `MonadPQ` is an `mtl` style constraint, similar to

282+`Control.Monad.State.Class.MonadState`, for using `LibPQ` to

282283

283284* `manipulateParams` runs a `Manipulation` with params from a type

284285 with a `ToParams` constraint. It calls `LibPQ.execParams` and

285286 doesn't afraid of anything.

286287

287−* `manipulateParams_` is like `manipulateParams` for a returning-free statement.

288−

289288* `manipulate` is like `manipulateParams` for a parameter-free statement.

290289

291−* `manipulate_` is like `manipulate` for a returning-free statement.

292−

293290* `runQueryParams` is like `manipulateParams` for query statements.

294291

295292* `runQuery` is like `runQueryParams` for a parameter-free statement.

@@ -303,11 +300,11 @@ instance IndexedMonadTransPQ PQ where

303300* `forPrepared` is a flipped `traversePrepared`

304301

305302* `traversePrepared_` is like `traversePrepared` but works on `Foldable`

306− containers for a returning-free statement.

303+ containers and returns unit.

307304

308305* `forPrepared_` is a flipped `traversePrepared_`.

309306

310−* `liftPQ` lets you lift actions from `Database.PostgreSQL.LibPQ` that require a connection

307+* `liftPQ` lets you lift actions from `LibPQ` that require a connection

311308 into your monad.

312309

313310To define an instance, you can minimally define only `manipulateParams`,

@@ -315,398 +312,304 @@ To define an instance, you can minimally define only `manipulateParams`,

315312a default instance.

316313

317314-}

318−class Monad pq => MonadPQ schemas pq | pq -> schemas where

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

319316 manipulateParams

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

321− => Manipulation '[] schemas params ys

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

317+ :: ToParams x params

318+ => Manipulation schema params ys

319+ -- ^ `insertRows`, `update` or `deleteFrom`

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

324321 default manipulateParams

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

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

327− => Manipulation '[] schemas params ys

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

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

323+ => ToParams x params

324+ => Manipulation schema params ys

325+ -- ^ `insertRows`, `update` or `deleteFrom`

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

330327 manipulateParams manipulation params = lift $

331328 manipulateParams manipulation params

332329

333− manipulateParams_

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

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

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

337− -> x -> pq ()

338− manipulateParams_ q x = void $ manipulateParams q x

339−

340− manipulate :: Manipulation '[] schemas '[] ys -> pq (K LibPQ.Result ys)

330+ manipulate :: Manipulation schema '[] ys -> pq (K LibPQ.Result ys)

341331 manipulate statement = manipulateParams statement ()

342332

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

344− manipulate_ = void . manipulate

345−

346333 runQueryParams

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

348− => Query '[] '[] schemas params ys

334+ :: ToParams x params

335+ => Query schema params ys

349336 -- ^ `select` and friends

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

351338 runQueryParams = manipulateParams . queryStatement

352339

353340 runQuery

354− :: Query '[] '[] schemas '[] ys

341+ :: Query schema '[] ys

355342 -- ^ `select` and friends

356343 -> pq (K LibPQ.Result ys)

357344 runQuery q = runQueryParams q ()

358345

359346 traversePrepared

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

361− => Manipulation '[] schemas params ys

362− -- ^ `insertInto`, `update`, or `deleteFrom`, and friends

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

348+ => Manipulation schema params ys

349+ -- ^ `insertRows`, `update`, or `deleteFrom`, and friends

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

364351 default traversePrepared

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

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

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

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

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

354+ => Manipulation schema params ys -> list x -> pq (list (K LibPQ.Result ys))

368355 traversePrepared manipulation params = lift $

369356 traversePrepared manipulation params

370357

371358 forPrepared

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

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

373360 => list x

374− -> Manipulation '[] schemas params ys

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

361+ -> Manipulation schema params ys

362+ -- ^ `insertRows`, `update` or `deleteFrom`

376363 -> pq (list (K LibPQ.Result ys))

377364 forPrepared = flip traversePrepared

378365

379366 traversePrepared_

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

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

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

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

368+ => Manipulation schema params '[]

369+ -- ^ `insertRows`, `update` or `deleteFrom`

383370 -> list x -> pq ()

384371 default traversePrepared_

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

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

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

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

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

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

374+ => Manipulation schema params '[]

375+ -- ^ `insertRows`, `update` or `deleteFrom`

389376 -> list x -> pq ()

390377 traversePrepared_ manipulation params = lift $

391378 traversePrepared_ manipulation params

392379

393380 forPrepared_

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

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

395382 => list x

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

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

383+ -> Manipulation schema params '[]

384+ -- ^ `insertRows`, `update` or `deleteFrom`

398385 -> pq ()

399386 forPrepared_ = flip traversePrepared_

400387

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

402389 default liftPQ

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

390+ :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

404391 => (LibPQ.Connection -> IO a) -> pq a

405392 liftPQ = lift . liftPQ

406393

407−instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)

408− => MonadPQ schemas (PQ schemas0 schemas1 io) where

394+instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)

395+ => MonadPQ schema (PQ schema0 schema1 io) where

409396

410397 manipulateParams

411− (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =

398+ (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =

412399 PQ $ \ (K conn) -> do

413400 let

414− paramSet

415− :: forall param. OidOfParam param

416− => K (Maybe Encoding.Encoding) param

417− -> K (Maybe (LibPQ.Oid, ByteString, LibPQ.Format)) param

418− paramSet (K maybeEncoding) = K $

419− maybeEncoding <&> \encoding ->

420− (oidOfParam @param, encodingBytes encoding, LibPQ.Binary)

421− params'

422− = hcollapse

423− . hcmap (Proxy @OidOfParam) paramSet

424− $ toParams @x @ps params

425− q' = q <> ";"

426− resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary

401+ toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)

402+ params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))

403+ resultMaybe <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary

427404 case resultMaybe of

428− Nothing -> throw $ ResultException

405+ Nothing -> error

429406 "manipulateParams: LibPQ.execParams returned no results"

430− Just result -> do

431− okResult_ result

432− return $ K (K result)

407+ Just result -> return $ K (K result)

433408

434409 traversePrepared

435− (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =

436− PQ $ \ (K conn) -> liftIO $ do

437− let

438− temp = "temporary_statement"

439− paramOid :: forall p. OidOfParam p => K LibPQ.Oid p

440− paramOid = K (oidOfParam @p)

441− paramOids :: NP (K LibPQ.Oid) xs

442− paramOids = hcpure (Proxy @OidOfParam) paramOid

443− paramOids' :: [LibPQ.Oid]

444− paramOids' = hcollapse paramOids

445− prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')

410+ (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

411+ PQ $ \ (K conn) -> liftBase $ do

412+ let temp = "temporary_statement"

413+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing

446414 case prepResultMaybe of

447− Nothing -> throw $ ResultException

415+ Nothing -> error

448416 "traversePrepared: LibPQ.prepare returned no results"

449− Just prepResult -> okResult_ prepResult

417+ Just prepResult -> do

418+ status <- LibPQ.resultStatus prepResult

419+ unless (status == LibPQ.CommandOk) . error $

420+ "traversePrepared: LibPQ.prepare status " <> show status

450421 results <- for list $ \ params -> do

451422 let

452− toParam' encoding = (encodingBytes encoding, LibPQ.Binary)

423+ toParam' bytes = (bytes,LibPQ.Binary)

453424 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

454425 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary

455426 case resultMaybe of

456− Nothing -> throw $ ResultException

427+ Nothing -> error

457428 "traversePrepared: LibPQ.execParams returned no results"

458− Just result -> do

459− okResult_ result

460− return $ K result

429+ Just result -> return $ K result

461430 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

462431 case deallocResultMaybe of

463− Nothing -> throw $ ResultException

432+ Nothing -> error

464433 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

465− Just deallocResult -> okResult_ deallocResult

434+ Just deallocResult -> do

435+ status <- LibPQ.resultStatus deallocResult

436+ unless (status == LibPQ.CommandOk) . error $

437+ "traversePrepared: DEALLOCATE status " <> show status

466438 return (K results)

467439

468440 traversePrepared_

469− (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =

470− PQ $ \ (K conn) -> liftIO $ do

471− let

472− temp = "temporary_statement"

473− paramOid :: forall p. OidOfParam p => K LibPQ.Oid p

474− paramOid = K (oidOfParam @p)

475− paramOids :: NP (K LibPQ.Oid) xs

476− paramOids = hcpure (Proxy @OidOfParam) paramOid

477− paramOids' :: [LibPQ.Oid]

478− paramOids' = hcollapse paramOids

479− prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')

441+ (UnsafeManipulation q :: Manipulation schema xs '[]) (list :: list x) =

442+ PQ $ \ (K conn) -> liftBase $ do

443+ let temp = "temporary_statement"

444+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing

480445 case prepResultMaybe of

481− Nothing -> throw $ ResultException

446+ Nothing -> error

482447 "traversePrepared_: LibPQ.prepare returned no results"

483− Just prepResult -> okResult_ prepResult

448+ Just prepResult -> do

449+ status <- LibPQ.resultStatus prepResult

450+ unless (status == LibPQ.CommandOk) . error $

451+ "traversePrepared: LibPQ.prepare status " <> show status

484452 for_ list $ \ params -> do

485453 let

486− toParam' encoding = (encodingBytes encoding, LibPQ.Binary)

454+ toParam' bytes = (bytes,LibPQ.Binary)

487455 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

488456 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary

489457 case resultMaybe of

490− Nothing -> throw $ ResultException

458+ Nothing -> error

491459 "traversePrepared_: LibPQ.execParams returned no results"

492− Just result -> okResult_ result

460+ Just _result -> return ()

493461 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

494462 case deallocResultMaybe of

495− Nothing -> throw $ ResultException

463+ Nothing -> error

496464 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

497− Just deallocResult -> okResult_ deallocResult

465+ Just deallocResult -> do

466+ status <- LibPQ.resultStatus deallocResult

467+ unless (status == LibPQ.CommandOk) . error $

468+ "traversePrepared: DEALLOCATE status " <> show status

498469 return (K ())

499470

500471 liftPQ pq = PQ $ \ (K conn) -> do

501− y <- liftIO $ pq conn

472+ y <- liftBase $ pq conn

502473 return (K y)

503474

504−instance MonadPQ schemas m => MonadPQ schemas (IdentityT m)

505−instance MonadPQ schemas m => MonadPQ schemas (ReaderT r m)

506−instance MonadPQ schemas m => MonadPQ schemas (Strict.StateT s m)

507−instance MonadPQ schemas m => MonadPQ schemas (Lazy.StateT s m)

508−instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.WriterT w m)

509−instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.WriterT w m)

510−instance MonadPQ schemas m => MonadPQ schemas (MaybeT m)

511−instance MonadPQ schemas m => MonadPQ schemas (ExceptT e m)

512−instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.RWST r w s m)

513−instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.RWST r w s m)

514−instance MonadPQ schemas m => MonadPQ schemas (ContT r m)

515−

516−instance (Monad m, schemas0 ~ schemas1)

517− => Applicative (PQ schemas0 schemas1 m) where

475+instance MonadPQ schema m => MonadPQ schema (IdentityT m)

476+instance MonadPQ schema m => MonadPQ schema (ReaderT r m)

477+instance MonadPQ schema m => MonadPQ schema (Strict.StateT s m)

478+instance MonadPQ schema m => MonadPQ schema (Lazy.StateT s m)

479+instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Strict.WriterT w m)

480+instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Lazy.WriterT w m)

481+instance MonadPQ schema m => MonadPQ schema (MaybeT m)

482+instance MonadPQ schema m => MonadPQ schema (ExceptT e m)

483+instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Strict.RWST r w s m)

484+instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Lazy.RWST r w s m)

485+instance MonadPQ schema m => MonadPQ schema (ContT r m)

486+instance MonadPQ schema m => MonadPQ schema (ListT m)

487+

488+instance (Monad m, schema0 ~ schema1)

489+ => Applicative (PQ schema0 schema1 m) where

518490 pure x = PQ $ \ _conn -> pure (K x)

519491 (<*>) = pqAp

520492

521−instance (Monad m, schemas0 ~ schemas1)

522− => Monad (PQ schemas0 schemas1 m) where

493+instance (Monad m, schema0 ~ schema1)

494+ => Monad (PQ schema0 schema1 m) where

523495 return = pure

524496 (>>=) = flip pqBind

525497

526−instance (Monad m, schemas0 ~ schemas1)

527− => Fail.MonadFail (PQ schemas0 schemas1 m) where

528− fail = Fail.fail

529−

530−instance schemas0 ~ schemas1 => MFunctor (PQ schemas0 schemas1) where

498+instance schema0 ~ schema1 => MFunctor (PQ schema0 schema1) where

531499 hoist f (PQ pq) = PQ (f . pq)

532500

533−instance schemas0 ~ schemas1 => MonadTrans (PQ schemas0 schemas1) where

501+instance schema0 ~ schema1 => MonadTrans (PQ schema0 schema1) where

534502 lift m = PQ $ \ _conn -> do

535503 x <- m

536504 return (K x)

537505

538−instance schemas0 ~ schemas1 => MMonad (PQ schemas0 schemas1) where

506+instance schema0 ~ schema1 => MMonad (PQ schema0 schema1) where

539507 embed f (PQ pq) = PQ $ \ conn -> do

540508 evalPQ (f (pq conn)) conn

541509

542−instance (MonadIO m, schema0 ~ schema1)

543− => MonadIO (PQ schema0 schema1 m) where

544− liftIO = lift . liftIO

510+instance (MonadBase b m, schema0 ~ schema1)

511+ => MonadBase b (PQ schema0 schema1 m) where

512+ liftBase = lift . liftBase

545513

546−instance (MonadUnliftIO m, schemas0 ~ schemas1)

547− => MonadUnliftIO (PQ schemas0 schemas1 m) where

548− withRunInIO

549− :: ((forall a . PQ schemas0 schema1 m a -> IO a) -> IO b)

550− -> PQ schemas0 schema1 m b

551− withRunInIO inner = PQ $ \conn ->

552− withRunInIO $ \(run :: (forall x . m x -> IO x)) ->

553− K <$> inner (\pq -> run $ unK <$> unPQ pq conn)

514+-- | A snapshot of the state of a `PQ` computation.

515+type PQRun schema =

516+ forall m x. Monad m => PQ schema schema m x -> m (K x schema)

517+

518+-- | Helper function in defining `MonadBaseControl` instance for `PQ`.

519+pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a

520+pqliftWith f = PQ $ \ conn ->

521+ fmap K (f $ \ pq -> unPQ pq conn)

522+

523+instance (MonadBaseControl b m, schema0 ~ schema1)

524+ => MonadBaseControl b (PQ schema0 schema1 m) where

525+ type StM (PQ schema0 schema1 m) x = StM m (K x schema0)

526+ liftBaseWith f =

527+ pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run

528+ restoreM = PQ . const . restoreM

554529

555530-- | Get a row corresponding to a given row number from a `LibPQ.Result`,

556531-- throwing an exception if the row number is out of bounds.

557532getRow

558− :: (FromRow columns y, MonadIO io)

533+ :: (FromRow columns y, MonadBase IO io)

559534 => LibPQ.Row

560535 -- ^ row number

561536 -> K LibPQ.Result columns

562537 -- ^ result

563538 -> io y

564−getRow r (K result :: K LibPQ.Result columns) = liftIO $ do

539+getRow r (K result :: K LibPQ.Result columns) = liftBase $ do

565540 numRows <- LibPQ.ntuples result

566− when (numRows < r) $ throw $ ResultException $

567− "getRow: expected at least " <> pack (show r) <> "rows but only saw "

568− <> pack (show numRows)

541+ when (numRows < r) $ error $

542+ "getRow: expected at least " <> show r <> "rows but only saw "

543+ <> show numRows

569544 let len = fromIntegral (lengthSList (Proxy @columns))

570545 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

571546 case fromList row' of

572− Nothing -> throw $ ResultException "getRow: found unexpected length"

573− Just row -> case fromRow @columns row of

574− Left parseError -> throw $ ParseException $ "getRow: " <> parseError

575− Right y -> return y

547+ Nothing -> error "getRow: found unexpected length"

548+ Just row -> return $ fromRow @columns row

576549

577550-- | Intended to be used for unfolding in streaming libraries, `nextRow`

578551-- takes a total number of rows (which can be found with `ntuples`)

579552-- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`,

580553-- otherwise returning the row along with the next row number.

581554nextRow

582− :: (FromRow columns y, MonadIO io)

555+ :: (FromRow columns y, MonadBase IO io)

583556 => LibPQ.Row -- ^ total number of rows

584557 -> K LibPQ.Result columns -- ^ result

585558 -> LibPQ.Row -- ^ row number

586559 -> io (Maybe (LibPQ.Row,y))

587560nextRow total (K result :: K LibPQ.Result columns) r

588− = liftIO $ if r >= total then return Nothing else do

561+ = liftBase $ if r >= total then return Nothing else do

589562 let len = fromIntegral (lengthSList (Proxy @columns))

590563 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

591564 case fromList row' of

592− Nothing -> throw $ ResultException "nextRow: found unexpected length"

593− Just row -> case fromRow @columns row of

594− Left parseError -> throw $ ParseException $ "nextRow: " <> parseError

595− Right y -> return $ Just (r+1, y)

565+ Nothing -> error "nextRow: found unexpected length"

566+ Just row -> return $ Just (r+1, fromRow @columns row)

596567

597568-- | Get all rows from a `LibPQ.Result`.

598569getRows

599− :: (FromRow columns y, MonadIO io)

570+ :: (FromRow columns y, MonadBase IO io)

600571 => K LibPQ.Result columns -- ^ result

601572 -> io [y]

602−getRows (K result :: K LibPQ.Result columns) = liftIO $ do

573+getRows (K result :: K LibPQ.Result columns) = liftBase $ do

603574 let len = fromIntegral (lengthSList (Proxy @columns))

604575 numRows <- LibPQ.ntuples result

605576 for [0 .. numRows - 1] $ \ r -> do

606577 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

607578 case fromList row' of

608− Nothing -> throw $ ResultException "getRows: found unexpected length"

609− Just row -> case fromRow @columns row of

610− Left parseError -> throw $ ParseException $ "getRows: " <> parseError

611− Right y -> return y

579+ Nothing -> error "getRows: found unexpected length"

580+ Just row -> return $ fromRow @columns row

612581

613582-- | Get the first row if possible from a `LibPQ.Result`.

614583firstRow

615− :: (FromRow columns y, MonadIO io)

584+ :: (FromRow columns y, MonadBase IO io)

616585 => K LibPQ.Result columns -- ^ result

617586 -> io (Maybe y)

618−firstRow (K result :: K LibPQ.Result columns) = liftIO $ do

587+firstRow (K result :: K LibPQ.Result columns) = liftBase $ do

619588 numRows <- LibPQ.ntuples result

620589 if numRows <= 0 then return Nothing else do

621590 let len = fromIntegral (lengthSList (Proxy @columns))

622591 row' <- traverse (LibPQ.getvalue result 0) [0 .. len - 1]

623592 case fromList row' of

624− Nothing -> throw $ ResultException "firstRow: found unexpected length"

625− Just row -> case fromRow @columns row of

626− Left parseError -> throw $ ParseException $ "firstRow: " <> parseError

627− Right y -> return $ Just y

593+ Nothing -> error "firstRow: found unexpected length"

594+ Just row -> return . Just $ fromRow @columns row

628595

629596-- | Lifts actions on results from @LibPQ@.

630597liftResult

631− :: MonadIO io

598+ :: MonadBase IO io

632599 => (LibPQ.Result -> IO x)

633600 -> K LibPQ.Result results -> io x

634−liftResult f (K result) = liftIO $ f result

601+liftResult f (K result) = liftBase $ f result

635602

636603-- | Returns the number of rows (tuples) in the query result.

637−ntuples :: MonadIO io => K LibPQ.Result columns -> io LibPQ.Row

604+ntuples :: MonadBase IO io => K LibPQ.Result columns -> io LibPQ.Row

638605ntuples = liftResult LibPQ.ntuples

639606

640607-- | Returns the result status of the command.

641−resultStatus :: MonadIO io => K LibPQ.Result results -> io LibPQ.ExecStatus

608+resultStatus :: MonadBase IO io => K LibPQ.Result results -> io LibPQ.ExecStatus

642609resultStatus = liftResult LibPQ.resultStatus

643610

644611-- | Returns the error message most recently generated by an operation

645612-- on the connection.

646613resultErrorMessage

647− :: MonadIO io => K LibPQ.Result results -> io (Maybe ByteString)

614+ :: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)

648615resultErrorMessage = liftResult LibPQ.resultErrorMessage

649−

650−-- | Returns the error code most recently generated by an operation

651−-- on the connection.

652−--

653−-- https://www.postgresql.org/docs/current/static/errcodes-appendix.html

654−resultErrorCode

655− :: MonadIO io

656− => K LibPQ.Result results

657− -> io (Maybe ByteString)

658−resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)

659−

660−-- | the state of LibPQ

661−data PQState = PQState

662− { sqlExecStatus :: LibPQ.ExecStatus

663− , sqlStateCode :: Maybe ByteString

664− -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html

665− , sqlErrorMessage :: Maybe ByteString

666− } deriving (Eq, Show)

667−

668−-- | `Exception`s that can be thrown by Squeal.

669−data SquealException

670− = PQException PQState

671− | ResultException Text

672− | ParseException Text

673− deriving (Eq, Show)

674−instance Exception SquealException

675−

676−okResult_ :: MonadIO io => LibPQ.Result -> io ()

677−okResult_ result = liftIO $ do

678− status <- LibPQ.resultStatus result

679− case status of

680− LibPQ.CommandOk -> return ()

681− LibPQ.TuplesOk -> return ()

682− _ -> do

683− stateCode <- LibPQ.resultErrorField result LibPQ.DiagSqlstate

684− msg <- LibPQ.resultErrorMessage result

685− throw . PQException $ PQState status stateCode msg

686−

687−-- | Check if a `LibPQ.Result`'s status is either `LibPQ.CommandOk`

688−-- or `LibPQ.TuplesOk` otherwise `throw` a `PQException`.

689−okResult :: MonadIO io => K LibPQ.Result row -> io ()

690−okResult = okResult_ . unK

691−

692−-- | Catch `SquealException`s.

693−catchSqueal

694− :: MonadUnliftIO io

695− => io a

696− -> (SquealException -> io a) -- ^ handler

697− -> io a

698−catchSqueal = catch

699−

700−-- | Handle `SquealException`s.

701−handleSqueal

702− :: MonadUnliftIO io

703− => (SquealException -> io a) -- ^ handler

704− -> io a -> io a

705−handleSqueal = handle

706−

707−-- | `Either` return a `SquealException` or a result.

708−trySqueal

709− :: MonadUnliftIO io

710− => io a

711− -> io (Either SquealException a)

712−trySqueal = try

squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+81−70

@@ -1,40 +1,18 @@

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

34− DeriveFunctor

12+ DataKinds

13+ , DeriveFunctor

3514 , FlexibleContexts

3615 , FlexibleInstances

37− , InstanceSigs

3816 , MultiParamTypeClasses

3917 , RankNTypes

4018 , ScopedTypeVariables

@@ -45,24 +23,34 @@ a

4523

4624module Squeal.PostgreSQL.Pool

4725 ( -- * Pools

48− Pool

26+ PoolPQ (..)

4927 , createConnectionPool

50− , usingConnectionPool

51− , destroyConnectionPool

28+ , Pool

29+ , destroyAllResources

30+ , PoolPQRun

31+ , poolpqliftWith

5232 ) where

5333

34+import Control.Monad.Base

35+import Control.Monad.Trans

36+import Control.Monad.Trans.Control

5437import Data.ByteString

38+import Data.Pool

5539import Data.Time

56−import Generics.SOP (K(..), unK)

57−import UnliftIO (MonadUnliftIO (..))

58−import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)

40+import Generics.SOP (K(..))

5941

6042import Squeal.PostgreSQL.PQ

43+import Squeal.PostgreSQL.Schema

44+

45+-- | `PoolPQ` @schema@ should be a drop-in replacement for `PQ` @schema schema@.

46+newtype PoolPQ (schema :: SchemaType) m x =

47+ PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x }

48+ deriving Functor

6149

6250-- | Create a striped pool of connections.

6351-- 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.

6452createConnectionPool

65− :: MonadUnliftIO io

53+ :: MonadBase IO io

6654 => ByteString

6755 -- ^ The passed string can be empty to use all default parameters, or it can

6856 -- contain one or more parameter settings separated by whitespace.

@@ -78,45 +66,68 @@ createConnectionPool

7866 -> Int

7967 -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1.

8068 -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.

81− -> io (Pool (K Connection schemas))

82−createConnectionPool conninfo stripes idle maxResrc =

69+ -> io (Pool (K Connection schema))

70+createConnectionPool conninfo stripes idle maxResrc = liftBase $

8371 createPool (connectdb conninfo) finish stripes idle maxResrc

8472

85−{-|

86−Temporarily take a connection from a `Pool`, perform an action with it,

87−and return it to the pool afterwards.

73+-- | `Applicative` instance for `PoolPQ`.

74+instance Monad m => Applicative (PoolPQ schema m) where

75+ pure x = PoolPQ $ \ _ -> pure x

76+ PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do

77+ f' <- f pool

78+ x' <- x pool

79+ return $ f' x'

8880

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

81+-- | `Monad` instance for `PoolPQ`.

82+instance Monad m => Monad (PoolPQ schema m) where

83+ return = pure

84+ PoolPQ x >>= f = PoolPQ $ \ pool -> do

85+ x' <- x pool

86+ runPoolPQ (f x') pool

10187

102−{- |

103−Destroy all connections in all stripes in the pool.

104−Note that this will ignore any exceptions in the destroy function.

88+-- | `MonadTrans` instance for `PoolPQ`.

89+instance MonadTrans (PoolPQ schema) where

90+ lift m = PoolPQ $ \ _pool -> m

10591

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.

92+-- | `MonadBase` instance for `PoolPQ`.

93+instance MonadBase b m => MonadBase b (PoolPQ schema m) where

94+ liftBase = lift . liftBase

11295

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

96+-- | `MonadPQ` instance for `PoolPQ`.

97+instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where

98+ manipulateParams manipulation params = PoolPQ $ \ pool -> do

99+ withResource pool $ \ conn -> do

100+ (K result :: K (K Result ys) schema) <- flip unPQ conn $

101+ manipulateParams manipulation params

102+ return result

103+ traversePrepared manipulation params = PoolPQ $ \ pool ->

104+ withResource pool $ \ conn -> do

105+ (K result :: K (list (K Result ys)) schema) <- flip unPQ conn $

106+ traversePrepared manipulation params

107+ return result

108+ traversePrepared_ manipulation params = PoolPQ $ \ pool -> do

109+ withResource pool $ \ conn -> do

110+ (_ :: K () schema) <- flip unPQ conn $

111+ traversePrepared_ manipulation params

112+ return ()

113+ liftPQ m = PoolPQ $ \ pool ->

114+ withResource pool $ \ conn -> do

115+ (K result :: K result schema) <- flip unPQ conn $

116+ liftPQ m

117+ return result

118+

119+-- | A snapshot of the state of a `PoolPQ` computation.

120+type PoolPQRun schema =

121+ forall m x. Monad m => PoolPQ schema m x -> m x

122+

123+-- | Helper function in defining `MonadBaseControl` instance for `PoolPQ`.

124+poolpqliftWith :: Functor m => (PoolPQRun schema -> m a) -> PoolPQ schema m a

125+poolpqliftWith f = PoolPQ $ \ pool ->

126+ (f $ \ pq -> runPoolPQ pq pool)

127+

128+-- | `MonadBaseControl` instance for `PoolPQ`.

129+instance MonadBaseControl b m => MonadBaseControl b (PoolPQ schema m) where

130+ type StM (PoolPQ schema m) x = StM m x

131+ liftBaseWith f =

132+ poolpqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run

133+ restoreM = PoolPQ . const . restoreM

squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+445−722

@@ -1,7 +1,7 @@

11{-|

22Module: Squeal.PostgreSQL.Query

33Description: Squeal queries

4−Copyright: (c) Eitan Chatav, 2019

4+Copyright: (c) Eitan Chatav, 2017

55Maintainer: eitan@morphism.tech

66Stability: experimental

@@ -9,81 +9,76 @@ Squeal queries.

99-}

1010

1111{-# LANGUAGE

12− ConstraintKinds

12+ DataKinds

13+ , DeriveDataTypeable

1314 , DeriveGeneric

1415 , FlexibleContexts

1516 , FlexibleInstances

1617 , GADTs

1718 , GeneralizedNewtypeDeriving

19+ , KindSignatures

1820 , LambdaCase

1921 , MultiParamTypeClasses

20− , OverloadedLabels

2122 , OverloadedStrings

22− , QuantifiedConstraints

2323 , ScopedTypeVariables

2424 , StandaloneDeriving

2525 , TypeApplications

26− , TypeFamilies

2726 , TypeInType

2827 , TypeOperators

29− , RankNTypes

3028 , UndecidableInstances

31− #-}

29+#-}

3230

3331module Squeal.PostgreSQL.Query

3432 ( -- * Queries

35− Query_

36− , Query (..)

37− -- ** Select

38− , select

39− , select_

40− , selectDistinct

41− , selectDistinct_

42− , selectDistinctOn

43− , selectDistinctOn_

44− , Selection (..)

45− -- ** Values

46− , values

47− , values_

48− -- ** Set Operations

33+ Query (UnsafeQuery, renderQuery)

4934 , union

5035 , unionAll

5136 , intersect

5237 , intersectAll

5338 , except

5439 , exceptAll

55− -- ** With

56− , With (..)

57− , CommonTableExpression (..)

58− , withRecursive

40+ -- * Select

41+ , select

42+ , selectDistinct

43+ , selectStar

44+ , selectDistinctStar

45+ , selectDotStar

46+ , selectDistinctDotStar

5947 -- * Table Expressions

6048 , TableExpression (..)

49+ , renderTableExpression

6150 , from

6251 , where_

63− , groupBy

52+ , group

6453 , having

54+ , orderBy

6555 , limit

6656 , offset

67− -- * From Clauses

57+ -- * From

6858 , FromClause (..)

6959 , table

7060 , subquery

7161 , view

72− , common

7362 , crossJoin

7463 , innerJoin

7564 , leftOuterJoin

7665 , rightOuterJoin

7766 , fullOuterJoin

7867 -- * Grouping

79− , By (..)

80− , GroupByClause (..)

81− , HavingClause (..)

68+ , By (By, By2)

69+ , renderBy

70+ , GroupByClause (NoGroups, Group)

71+ , renderGroupByClause

72+ , HavingClause (NoHaving, Having)

73+ , renderHavingClause

74+ -- * Sorting

75+ , SortExpression (..)

76+ , renderSortExpression

8277 ) where

8378

8479import Control.DeepSeq

8580import Data.ByteString (ByteString)

86−import Data.Kind (Type)

81+import Data.Monoid hiding (All)

8782import Data.String

8883import Data.Word

8984import Generics.SOP hiding (from)

@@ -91,577 +86,352 @@ import GHC.TypeLits

9186

9287import qualified GHC.Generics as GHC

9388

94−import Squeal.PostgreSQL.Alias

9589import Squeal.PostgreSQL.Expression

96−import Squeal.PostgreSQL.Expression.Logic

97−import Squeal.PostgreSQL.Expression.Sort

98−import Squeal.PostgreSQL.Expression.Window

99−import Squeal.PostgreSQL.List

100−import Squeal.PostgreSQL.PG

10190import Squeal.PostgreSQL.Render

10291import Squeal.PostgreSQL.Schema

10392

104−-- $setup

105−-- >>> import Squeal.PostgreSQL

106−-- >>> import Data.Int (Int32, Int64)

107−-- >>> import Data.Monoid (Sum (..))

108−-- >>> import Data.Text (Text)

109−-- >>> import qualified Generics.SOP as SOP

110−

11193{- |

112−The process of retrieving or the command to retrieve data from

113−a database is called a `Query`.

114−

115−The general `Query` type is parameterized by

116−

117−* @outer :: FromType@ - outer scope for a correlated subquery,

118−* @commons :: FromType@ - scope for all `common` table expressions,

119−* @schemas :: SchemasType@ - scope for all `table`s and `view`s,

120−* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,

121−* @row :: RowType@ - return type of the `Query`.

122−-}

123−newtype Query

124− (outer :: FromType)

125− (commons :: FromType)

126− (schemas :: SchemasType)

127− (params :: [NullityType])

128− (row :: RowType)

129− = UnsafeQuery { renderQuery :: ByteString }

130− deriving (GHC.Generic,Show,Eq,Ord,NFData)

131−instance RenderSQL (Query outer commons schemas params row) where renderSQL = renderQuery

132−

133−{- |

134−The top level `Query_` type is parameterized by a @schemas@ `SchemasType`,

135−against which the query is type-checked, an input @parameters@ Haskell `Type`,

136−and an ouput row Haskell `Type`.

137−

138−A top-level query can be run

139−using `Squeal.PostgreSQL.PQ.runQueryParams`, or if @parameters = ()@

140−using `Squeal.PostgreSQL.PQ.runQuery`.

141−

142−Generally, @parameters@ will be a Haskell tuple or record whose entries

143−may be referenced using positional

144−`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a

145−Haskell record, whose entries will be targeted using overloaded labels.

146−

147−Let's see some examples of queries.

148−

149−>>> :set -XDeriveAnyClass -XDerivingStrategies

150−>>> :{

151−data Row a b = Row { col1 :: a, col2 :: b }

152− deriving stock (GHC.Generic)

153− deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)

154−:}

94+The process of retrieving or the command to retrieve data from a database

95+is called a `Query`. The `select`, `selectStar`, `selectDotStar`,

96+`selectDistinct`, `selectDistinctStar` and `selectDistinctDotStar` commands

97+are used to specify queries.

15598

15699simple query:

157100

158−>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]

159−>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]

160101>>> :{

161102let

162− query :: Query_ (Public Schema) () (Row Int32 Int32)

163− query = select Star (from (table #tab))

164−in printSQL query

103+ query :: Query

104+ '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

105+ '[]

106+ '["col" ::: 'Null 'PGint4]

107+ query = selectStar (from (table (#tab `As` #t)))

108+in renderQuery query

165109:}

166−SELECT * FROM "tab" AS "tab"

110+"SELECT * FROM \"tab\" AS \"t\""

167111

168112restricted query:

169113

170114>>> :{

171115let

172− query :: Query_ (Public Schema) () (Row Int32 Int32)

173− query =

174− select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2)

175− ( from (table #tab)

116+ query :: Query

117+ '[ "tab" ::: 'Table ('[] :=>

118+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

119+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]

120+ '[]

121+ '[ "sum" ::: 'NotNull 'PGint4

122+ , "col1" ::: 'NotNull 'PGint4 ]

123+ query =

124+ select

125+ ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)

126+ ( from (table (#tab `As` #t))

176127 & where_ (#col1 .> #col2)

177128 & where_ (#col2 .> 0) )

178−in printSQL query

129+in renderQuery query

179130:}

180−SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))

131+"SELECT (\"col1\" + \"col2\") AS \"sum\", \"col1\" AS \"col1\" FROM \"tab\" AS \"t\" WHERE ((\"col1\" > \"col2\") AND (\"col2\" > 0))"

181132

182133subquery:

183134

184135>>> :{

185136let

186− query :: Query_ (Public Schema) () (Row Int32 Int32)

187− query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))

188−in printSQL query

137+ query :: Query

138+ '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

139+ '[]

140+ '["col" ::: 'Null 'PGint4]

141+ query =

142+ selectStar

143+ (from (subquery (selectStar (from (table (#tab `As` #t))) `As` #sub)))

144+in renderQuery query

189145:}

190−SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub"

146+"SELECT * FROM (SELECT * FROM \"tab\" AS \"t\") AS \"sub\""

191147

192148limits and offsets:

193149

194150>>> :{

195151let

196− query :: Query_ (Public Schema) () (Row Int32 Int32)

197− query = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)

198−in printSQL query

152+ query :: Query

153+ '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

154+ '[]

155+ '["col" ::: 'Null 'PGint4]

156+ query = selectStar

157+ (from (table (#tab `As` #t)) & limit 100 & offset 2 & limit 50 & offset 2)

158+in renderQuery query

199159:}

200−SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4

160+"SELECT * FROM \"tab\" AS \"t\" LIMIT 50 OFFSET 4"

201161

202162parameterized query:

203163

204164>>> :{

205165let

206− query :: Query_ (Public Schema) (Only Int32) (Row Int32 Int32)

207− query = select Star (from (table #tab) & where_ (#col1 .> param @1))

208−in printSQL query

166+ query :: Query

167+ '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8])]

168+ '[ 'NotNull 'PGfloat8]

169+ '["col" ::: 'NotNull 'PGfloat8]

170+ query = selectStar

171+ (from (table (#tab `As` #t)) & where_ (#col .> param @1))

172+in renderQuery query

209173:}

210−SELECT * FROM "tab" AS "tab" WHERE ("col1" > ($1 :: int4))

174+"SELECT * FROM \"tab\" AS \"t\" WHERE (\"col\" > ($1 :: float8))"

211175

212176aggregation query:

213177

214178>>> :{

215179let

216− query :: Query_ (Public Schema) () (Row Int64 Int32)

180+ query :: Query

181+ '[ "tab" ::: 'Table ('[] :=>

182+ '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

183+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]

184+ '[]

185+ '[ "sum" ::: 'NotNull 'PGint4

186+ , "col1" ::: 'NotNull 'PGint4 ]

217187 query =

218− select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2)

219− ( from (table (#tab `as` #table1))

220− & groupBy #col1

221− & having (sum_ (Distinct #col2) .> 1) )

222−in printSQL query

188+ select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil)

189+ ( from (table (#tab `As` #table1))

190+ & group (By #col1 :* Nil)

191+ & having (#col1 + sum_ #col2 .> 1) )

192+in renderQuery query

223193:}

224−SELECT COALESCE(sum(ALL "col2"), 0) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > 1)

194+"SELECT sum(\"col2\") AS \"sum\", \"col1\" AS \"col1\" FROM \"tab\" AS \"table1\" GROUP BY \"col1\" HAVING ((\"col1\" + sum(\"col2\")) > 1)"

225195

226196sorted query:

227197

228198>>> :{

229199let

230− query :: Query_ (Public Schema) () (Row Int32 Int32)

231− query = select Star (from (table #tab) & orderBy [#col1 & Asc])

232−in printSQL query

200+ query :: Query

201+ '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

202+ '[]

203+ '["col" ::: 'Null 'PGint4]

204+ query = selectStar

205+ (from (table (#tab `As` #t)) & orderBy [#col & AscNullsFirst])

206+in renderQuery query

233207:}

234−SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC

208+"SELECT * FROM \"tab\" AS \"t\" ORDER BY \"col\" ASC NULLS FIRST"

235209

236210joins:

237211

238−>>> :{

239−type OrdersColumns =

240− '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

241− , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4

242− , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4

243− , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4 ]

244−:}

245−

246−>>> :{

247−type OrdersConstraints =

248− '["pk_orders" ::: PrimaryKey '["id"]

249− ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]

250− ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"] ]

251−:}

252−

253−>>> type NamesColumns = '["id" ::: 'NoDef :=> 'NotNull 'PGint4, "name" ::: 'NoDef :=> 'NotNull 'PGtext]

254−>>> type CustomersConstraints = '["pk_customers" ::: PrimaryKey '["id"]]

255−>>> type ShippersConstraints = '["pk_shippers" ::: PrimaryKey '["id"]]

256−>>> :{

257−type OrdersSchema =

258− '[ "orders" ::: 'Table (OrdersConstraints :=> OrdersColumns)

259− , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns)

260− , "shippers" ::: 'Table (ShippersConstraints :=> NamesColumns) ]

261−:}

262−

263−>>> :{

264−data Order = Order

265− { price :: Float

266− , customerName :: Text

267− , shipperName :: Text

268− } deriving GHC.Generic

269−instance SOP.Generic Order

270−instance SOP.HasDatatypeInfo Order

271−:}

272−

212+>>> :set -XFlexibleContexts

273213>>> :{

274214let

275− query :: Query_ (Public OrdersSchema) () Order

276− query = select_

277− ( #o ! #price `as` #price :*

278− #c ! #name `as` #customerName :*

279− #s ! #name `as` #shipperName )

280− ( from (table (#orders `as` #o)

281− & innerJoin (table (#customers `as` #c))

215+ query :: Query

216+ '[ "orders" ::: 'Table (

217+ '["pk_orders" ::: PrimaryKey '["id"]

218+ ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]

219+ ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"]] :=>

220+ '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

221+ , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4

222+ , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4

223+ , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4

224+ ])

225+ , "customers" ::: 'Table (

226+ '["pk_customers" ::: PrimaryKey '["id"]] :=>

227+ '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

228+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext

229+ ])

230+ , "shippers" ::: 'Table (

231+ '["pk_shippers" ::: PrimaryKey '["id"]] :=>

232+ '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

233+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext

234+ ])

235+ ]

236+ '[]

237+ '[ "order_price" ::: 'NotNull 'PGfloat4

238+ , "customer_name" ::: 'NotNull 'PGtext

239+ , "shipper_name" ::: 'NotNull 'PGtext

240+ ]

241+ query = select

242+ ( #o ! #price `As` #order_price :*

243+ #c ! #name `As` #customer_name :*

244+ #s ! #name `As` #shipper_name :* Nil )

245+ ( from (table (#orders `As` #o)

246+ & innerJoin (table (#customers `As` #c))

282247 (#o ! #customer_id .== #c ! #id)

283− & innerJoin (table (#shippers `as` #s))

248+ & innerJoin (table (#shippers `As` #s))

284249 (#o ! #shipper_id .== #s ! #id)) )

285−in printSQL query

250+in renderQuery query

286251:}

287−SELECT "o"."price" AS "price", "c"."name" AS "customerName", "s"."name" AS "shipperName" FROM "orders" AS "o" INNER JOIN "customers" AS "c" ON ("o"."customer_id" = "c"."id") INNER JOIN "shippers" AS "s" ON ("o"."shipper_id" = "s"."id")

252+"SELECT \"o\".\"price\" AS \"order_price\", \"c\".\"name\" AS \"customer_name\", \"s\".\"name\" AS \"shipper_name\" FROM \"orders\" AS \"o\" INNER JOIN \"customers\" AS \"c\" ON (\"o\".\"customer_id\" = \"c\".\"id\") INNER JOIN \"shippers\" AS \"s\" ON (\"o\".\"shipper_id\" = \"s\".\"id\")"

288253

289254self-join:

290255

291256>>> :{

292257let

293− query :: Query_ (Public Schema) () (Row Int32 Int32)

294− query = select

295− (#t1 & DotStar)

296− (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))

297−in printSQL query

258+ query :: Query

259+ '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

260+ '[]

261+ '["col" ::: 'Null 'PGint4]

262+ query = selectDotStar #t1

263+ (from (table (#tab `As` #t1) & crossJoin (table (#tab `As` #t2))))

264+in renderQuery query

298265:}

299−SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2"

300−

301−value queries:

302−

303−>>> :{

304−let

305− query :: Query_ schemas () (Row String Bool)

306− query = values

307− ("true" `as` #col1 :* true `as` #col2)

308− ["false" `as` #col1 :* false `as` #col2]

309−in printSQL query

310−:}

311−SELECT * FROM (VALUES (E'true', TRUE), (E'false', FALSE)) AS t ("col1", "col2")

266+"SELECT \"t1\".* FROM \"tab\" AS \"t1\" CROSS JOIN \"tab\" AS \"t2\""

312267

313268set operations:

314269

315270>>> :{

316271let

317− query :: Query_ (Public Schema) () (Row Int32 Int32)

318− query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))

319−in printSQL query

320−:}

321−(SELECT * FROM "tab" AS "tab") UNION ALL (SELECT * FROM "tab" AS "tab")

322−

323−with queries:

324−

325−>>> :{

326−let

327− query :: Query_ (Public Schema) () (Row Int32 Int32)

328− query = with (

329− select Star (from (table #tab)) `as` #cte1 :>>

330− select Star (from (common #cte1)) `as` #cte2

331− ) (select Star (from (common #cte2)))

332−in printSQL query

333−:}

334−WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2"

335−

336−window function queries

337−

338−>>> :{

339−let

340− query :: Query_ (Public Schema) () (Row Int32 Int64)

341− query = select

342− (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))

343− (from (table #tab))

344−in printSQL query

345−:}

346−SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "col2" FROM "tab" AS "tab"

347−

348−correlated subqueries

349−

350−>>> :{

351−let

352− query :: Query_ (Public Schema) () (Only Int32)

272+ query :: Query

273+ '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

274+ '[]

275+ '["col" ::: 'Null 'PGint4]

353276 query =

354− select (#col1 `as` #fromOnly) (from (table (#tab `as` #t1))

355− & where_ (exists (

356− select Star (from (table (#tab `as` #t2))

357− & where_ (#t2 ! #col2 .== #t1 ! #col1)))))

358−in printSQL query

277+ selectStar (from (table (#tab `As` #t)))

278+ `unionAll`

279+ selectStar (from (table (#tab `As` #t)))

280+in renderQuery query

359281:}

360−SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))

361−

282+"(SELECT * FROM \"tab\" AS \"t\") UNION ALL (SELECT * FROM \"tab\" AS \"t\")"

362283-}

363−type family Query_

364− (schemas :: SchemasType)

365− (parameters :: Type)

366− (row :: Type) where

367− Query_ schemas params row =

368− Query '[] '[] schemas (TuplePG params) (RowPG row)

284+newtype Query

285+ (schema :: SchemaType)

286+ (params :: [NullityType])

287+ (columns :: RelationType)

288+ = UnsafeQuery { renderQuery :: ByteString }

289+ deriving (GHC.Generic,Show,Eq,Ord,NFData)

369290

370291-- | The results of two queries can be combined using the set operation

371−-- `union`. Duplicate rows are eliminated.

292+-- `union`. Duplicate rows are eliminated.

372293union

373− :: Query outer commons schemas params columns

374− -> Query outer commons schemas params columns

375− -> Query outer commons schemas params columns

294+ :: Query schema params columns

295+ -> Query schema params columns

296+ -> Query schema params columns

376297q1 `union` q2 = UnsafeQuery $

377− parenthesized (renderSQL q1)

298+ parenthesized (renderQuery q1)

378299 <+> "UNION"

379− <+> parenthesized (renderSQL q2)

300+ <+> parenthesized (renderQuery q2)

380301

381302-- | The results of two queries can be combined using the set operation

382303-- `unionAll`, the disjoint union. Duplicate rows are retained.

383304unionAll

384− :: Query outer commons schemas params columns

385− -> Query outer commons schemas params columns

386− -> Query outer commons schemas params columns

305+ :: Query schema params columns

306+ -> Query schema params columns

307+ -> Query schema params columns

387308q1 `unionAll` q2 = UnsafeQuery $

388− parenthesized (renderSQL q1)

309+ parenthesized (renderQuery q1)

389310 <+> "UNION" <+> "ALL"

390− <+> parenthesized (renderSQL q2)

311+ <+> parenthesized (renderQuery q2)

391312

392313-- | The results of two queries can be combined using the set operation

393314-- `intersect`, the intersection. Duplicate rows are eliminated.

394315intersect

395− :: Query outer commons schemas params columns

396− -> Query outer commons schemas params columns

397− -> Query outer commons schemas params columns

316+ :: Query schema params columns

317+ -> Query schema params columns

318+ -> Query schema params columns

398319q1 `intersect` q2 = UnsafeQuery $

399− parenthesized (renderSQL q1)

320+ parenthesized (renderQuery q1)

400321 <+> "INTERSECT"

401− <+> parenthesized (renderSQL q2)

322+ <+> parenthesized (renderQuery q2)

402323

403324-- | The results of two queries can be combined using the set operation

404325-- `intersectAll`, the intersection. Duplicate rows are retained.

405326intersectAll

406− :: Query outer commons schemas params columns

407− -> Query outer commons schemas params columns

408− -> Query outer commons schemas params columns

327+ :: Query schema params columns

328+ -> Query schema params columns

329+ -> Query schema params columns

409330q1 `intersectAll` q2 = UnsafeQuery $

410− parenthesized (renderSQL q1)

331+ parenthesized (renderQuery q1)

411332 <+> "INTERSECT" <+> "ALL"

412− <+> parenthesized (renderSQL q2)

333+ <+> parenthesized (renderQuery q2)

413334

414335-- | The results of two queries can be combined using the set operation

415336-- `except`, the set difference. Duplicate rows are eliminated.

416337except

417− :: Query outer commons schemas params columns

418− -> Query outer commons schemas params columns

419− -> Query outer commons schemas params columns

338+ :: Query schema params columns

339+ -> Query schema params columns

340+ -> Query schema params columns

420341q1 `except` q2 = UnsafeQuery $

421− parenthesized (renderSQL q1)

342+ parenthesized (renderQuery q1)

422343 <+> "EXCEPT"

423− <+> parenthesized (renderSQL q2)

344+ <+> parenthesized (renderQuery q2)

424345

425346-- | The results of two queries can be combined using the set operation

426347-- `exceptAll`, the set difference. Duplicate rows are retained.

427348exceptAll

428− :: Query outer commons schemas params columns

429− -> Query outer commons schemas params columns

430− -> Query outer commons schemas params columns

349+ :: Query schema params columns

350+ -> Query schema params columns

351+ -> Query schema params columns

431352q1 `exceptAll` q2 = UnsafeQuery $

432− parenthesized (renderSQL q1)

353+ parenthesized (renderQuery q1)

433354 <+> "EXCEPT" <+> "ALL"

434− <+> parenthesized (renderSQL q2)

355+ <+> parenthesized (renderQuery q2)

435356

436357{-----------------------------------------

437358SELECT queries

438359-----------------------------------------}

439360

440−{- | The simplest kinds of `Selection` are `Star` and `DotStar` which

441−emits all columns that a `TableExpression` produces. A select `List`

442−is a list of `Expression`s. A `Selection` could be a list of

443−`WindowFunction`s `Over` `WindowDefinition`. `Additional` `Selection`s can

444−be selected with `Also`.

445−-}

446−data Selection outer commons grp schemas params from row where

447− Star

448− :: HasUnique tab from row

449− => Selection outer commons 'Ungrouped schemas params from row

450− -- ^ `HasUnique` table in the `FromClause`

451− DotStar

452− :: Has tab from row

453− => Alias tab

454− -- ^ `Has` table with `Alias`

455− -> Selection outer commons 'Ungrouped schemas params from row

456− List

457− :: SListI row

458− => NP (Aliased (Expression outer commons grp schemas params from)) row

459− -- ^ `NP` list of `Aliased` `Expression`s

460− -> Selection outer commons grp schemas params from row

461− Over

462− :: SListI row

463− => NP (Aliased (WindowFunction outer commons grp schemas params from)) row

464− -- ^ `NP` list of `Aliased` `WindowFunction`s

465− -> WindowDefinition outer commons grp schemas params from

466− -> Selection outer commons grp schemas params from row

467− Also

468− :: Selection outer commons grp schemas params from right

469− -- ^ `Additional` `Selection`

470− -> Selection outer commons grp schemas params from left

471− -> Selection outer commons grp schemas params from (Join left right)

472−instance Additional (Selection outer commons grp schemas params from) where

473− also = Also

474−instance (KnownSymbol col, row ~ '[col ::: ty])

475− => Aliasable col

476− (Expression outer commons grp schemas params from ty)

477− (Selection outer commons grp schemas params from row) where

478− expr `as` col = List (expr `as` col)

479−instance (Has tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty])

480− => IsQualified tab col

481− (Selection outer commons 'Ungrouped schemas params from row1) where

482− tab ! col = tab ! col `as` col

483−instance

484− ( Has tab (Join outer from) row0

485− , Has col row0 ty

486− , row1 ~ '[col ::: ty]

487− , GroupedBy tab col bys )

488− => IsQualified tab col

489− (Selection outer commons ('Grouped bys) schemas params from row1) where

490− tab ! col = tab ! col `as` col

491−instance (HasUnique tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty])

492− => IsLabel col

493− (Selection outer commons 'Ungrouped schemas params from row1) where

494− fromLabel = fromLabel @col `as` Alias

495−instance

496− ( HasUnique tab (Join outer from) row0

497− , Has col row0 ty

498− , row1 ~ '[col ::: ty]

499− , GroupedBy tab col bys )

500− => IsLabel col

501− (Selection outer commons ('Grouped bys) schemas params from row1) where

502− fromLabel = fromLabel @col `as` Alias

503−

504−instance RenderSQL (Selection outer commons grp schemas params from row) where

505− renderSQL = \case

506− List list -> renderCommaSeparated (renderAliased renderSQL) list

507− Star -> "*"

508− DotStar tab -> renderSQL tab <> ".*"

509− Also right left -> renderSQL left <> ", " <> renderSQL right

510− Over winFns winDef ->

511− let

512− renderOver

513− :: Aliased (WindowFunction outer commons grp schemas params from) field

514− -> ByteString

515− renderOver (winFn `As` col) = renderSQL winFn

516− <+> "OVER" <+> parenthesized (renderSQL winDef)

517− <+> "AS" <+> renderSQL col

518− in

519− renderCommaSeparated renderOver winFns

520−

521−instance IsString

522− (Selection outer commons grp schemas params from '["fromOnly" ::: 'NotNull 'PGtext]) where

523− fromString str = fromString str `as` Alias

524−

525361-- | the `TableExpression` in the `select` command constructs an intermediate

526362-- virtual table by possibly combining tables, views, eliminating rows,

527363-- grouping, etc. This table is finally passed on to processing by

528−-- the select list. The `Selection` determines which columns of

364+-- the select list. The select list determines which columns of

529365-- the intermediate table are actually output.

530366select

531− :: (SListI row, row ~ (x ': xs))

532− => Selection outer commons grp schemas params from row

533− -- ^ selection

534− -> TableExpression outer commons grp schemas params from

535− -- ^ intermediate virtual table

536− -> Query outer commons schemas params row

537−select selection tabexpr = UnsafeQuery $

538− "SELECT"

539− <+> renderSQL selection

540− <+> renderSQL tabexpr

541−

542−-- | Like `select` but takes an `NP` list of `Expression`s instead

543−-- of a general `Selection`.

544−select_

545− :: (SListI row, row ~ (x ': xs))

546− => NP (Aliased (Expression outer commons grp schemas params from)) row

367+ :: SListI columns

368+ => NP (Aliased (Expression relations grouping params)) (column ': columns)

547369 -- ^ select list

548− -> TableExpression outer commons grp schemas params from

370+ -> TableExpression schema params relations grouping

549371 -- ^ intermediate virtual table

550− -> Query outer commons schemas params row

551−select_ = select . List

372+ -> Query schema params (column ': columns)

373+select list rels = UnsafeQuery $

374+ "SELECT"

375+ <+> renderCommaSeparated (renderAliasedAs renderExpression) list

376+ <+> renderTableExpression rels

552377

553378-- | After the select list has been processed, the result table can

554379-- be subject to the elimination of duplicate rows using `selectDistinct`.

555380selectDistinct

556− :: (SListI columns, columns ~ (col ': cols))

557− => Selection outer commons grp schemas params from columns

558− -- ^ selection

559− -> TableExpression outer commons grp schemas params from

381+ :: SListI columns

382+ => NP (Aliased (Expression relations 'Ungrouped params)) (column ': columns)

383+ -- ^ select list

384+ -> TableExpression schema params relations 'Ungrouped

560385 -- ^ intermediate virtual table

561− -> Query outer commons schemas params columns

562−selectDistinct selection tabexpr = UnsafeQuery $

386+ -> Query schema params (column ': columns)

387+selectDistinct list rels = UnsafeQuery $

563388 "SELECT DISTINCT"

564− <+> renderSQL selection

565− <+> renderSQL tabexpr

566−

567−-- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead

568−-- of a general `Selection`.

569−selectDistinct_

570− :: (SListI columns, columns ~ (col ': cols))

571− => NP (Aliased (Expression outer commons grp schemas params from)) columns

572− -- ^ select list

573− -> TableExpression outer commons grp schemas params from

389+ <+> renderCommaSeparated (renderAliasedAs renderExpression) list

390+ <+> renderTableExpression rels

391+

392+-- | The simplest kind of query is `selectStar` which emits all columns

393+-- that the table expression produces.

394+selectStar

395+ :: HasUnique relation relations columns

396+ => TableExpression schema params relations 'Ungrouped

574397 -- ^ intermediate virtual table

575− -> Query outer commons schemas params columns

576−selectDistinct_ = selectDistinct . List

577−

578−{-|

579−`selectDistinctOn` keeps only the first row of each set of rows where

580−the given expressions evaluate to equal. The DISTINCT ON expressions are

581−interpreted using the same rules as for ORDER BY. ORDER BY is used to

582−ensure that the desired row appears first.

583−

584−The DISTINCT ON expression(s) must match the leftmost ORDER BY expression(s).

585−The ORDER BY clause will normally contain additional expression(s) that

586−determine the desired precedence of rows within each DISTINCT ON group.

587−

588−In order to guarantee they match and reduce redundancy, this function

589−will prepend the The DISTINCT ON expressions to the ORDER BY clause.

590−-}

591−selectDistinctOn

592− :: (SListI columns, columns ~ (col ': cols))

593− => [SortExpression outer commons grp schemas params from]

594− -- ^ DISTINCT ON expression(s) and prepended to ORDER BY clause

595− -> Selection outer commons grp schemas params from columns

596− -- ^ selection

597− -> TableExpression outer commons grp schemas params from

398+ -> Query schema params columns

399+selectStar rels = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression rels

400+

401+-- | A `selectDistinctStar` emits all columns that the table expression

402+-- produces and eliminates duplicate rows.

403+selectDistinctStar

404+ :: HasUnique relation relations columns

405+ => TableExpression schema params relations 'Ungrouped

406+ -- ^ intermediate virtual table

407+ -> Query schema params columns

408+selectDistinctStar rels = UnsafeQuery $

409+ "SELECT DISTINCT" <+> "*" <+> renderTableExpression rels

410+

411+-- | When working with multiple tables, it can also be useful to ask

412+-- for all the columns of a particular table, using `selectDotStar`.

413+selectDotStar

414+ :: Has relation relations columns

415+ => Alias relation

416+ -- ^ particular virtual subtable

417+ -> TableExpression schema params relations 'Ungrouped

598418 -- ^ 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

419+ -> Query schema params columns

420+selectDotStar rel relations = UnsafeQuery $

421+ "SELECT" <+> renderAlias rel <> ".*" <+> renderTableExpression relations

422+

423+-- | A `selectDistinctDotStar` asks for all the columns of a particular table,

424+-- and eliminates duplicate rows.

425+selectDistinctDotStar

426+ :: Has relation relations columns

427+ => Alias relation

428+ -- ^ particular virtual table

429+ -> TableExpression schema params relations 'Ungrouped

623430 -- ^ intermediate virtual table

624− -> Query outer commons schemas params columns

625−selectDistinctOn_ distincts = selectDistinctOn distincts . List

626−

627−-- | `values` computes a row value or set of row values

628−-- specified by value expressions. It is most commonly used

629−-- to generate a “constant table” within a larger command,

630−-- but it can be used on its own.

631−--

632−-- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]

633−-- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query outer commons schemas '[] Row

634−-- >>> printSQL query

635−-- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b")

636−values

637− :: SListI cols

638− => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols

639− -> [NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols]

640− -- ^ When more than one row is specified, all the rows must

641− -- must have the same number of elements

642− -> Query outer commons schemas params cols

643−values rw rws = UnsafeQuery $ "SELECT * FROM"

644− <+> parenthesized (

645− "VALUES"

646− <+> commaSeparated

647− ( parenthesized

648− . renderCommaSeparated renderValuePart <$> rw:rws )

649− ) <+> "AS t"

650− <+> parenthesized (renderCommaSeparated renderAliasPart rw)

651− where

652− renderAliasPart, renderValuePart

653− :: Aliased (Expression outer commons 'Ungrouped schemas params '[] ) ty -> ByteString

654− renderAliasPart (_ `As` name) = renderSQL name

655− renderValuePart (value `As` _) = renderSQL value

656−

657−-- | `values_` computes a row value or set of row values

658−-- specified by value expressions.

659−values_

660− :: SListI cols

661− => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols

662− -- ^ one row of values

663− -> Query outer commons schemas params cols

664−values_ rw = values rw []

431+ -> Query schema params columns

432+selectDistinctDotStar rel relations = UnsafeQuery $

433+ "SELECT DISTINCT" <+> renderAlias rel <> ".*"

434+ <+> renderTableExpression relations

665435

666436{-----------------------------------------

667437Table Expressions

@@ -674,17 +444,15 @@ Table Expressions

674444-- to a table on disk, a so-called base table, but more complex expressions

675445-- can be used to modify or combine base tables in various ways.

676446data TableExpression

677− (outer :: FromType)

678− (commons :: FromType)

679− (grp :: Grouping)

680− (schemas :: SchemasType)

447+ (schema :: SchemaType)

681448 (params :: [NullityType])

682− (from :: FromType)

449+ (relations :: RelationsType)

450+ (grouping :: Grouping)

683451 = TableExpression

684− { fromClause :: FromClause outer commons schemas params from

452+ { fromClause :: FromClause schema params relations

685453 -- ^ A table reference that can be a table name, or a derived table such

686454 -- as a subquery, a @JOIN@ construct, or complex combinations of these.

687− , whereClause :: [Condition outer commons 'Ungrouped schemas params from]

455+ , whereClause :: [Condition relations 'Ungrouped params]

688456 -- ^ optional search coditions, combined with `.&&`. After the processing

689457 -- of the `fromClause` is done, each row of the derived virtual table

690458 -- is checked against the search condition. If the result of the

@@ -693,20 +461,20 @@ data TableExpression

693461 -- at least one column of the table generated in the `fromClause`;

694462 -- this is not required, but otherwise the WHERE clause will

695463 -- be fairly useless.

696− , groupByClause :: GroupByClause grp from

464+ , groupByClause :: GroupByClause relations grouping

697465 -- ^ The `groupByClause` is used to group together those rows in a table

698466 -- that have the same values in all the columns listed. The order in which

699467 -- the columns are listed does not matter. The effect is to combine each

700468 -- set of rows having common values into one group row that represents all

701469 -- rows in the group. This is done to eliminate redundancy in the output

702470 -- and/or compute aggregates that apply to these groups.

703− , havingClause :: HavingClause outer commons grp schemas params from

471+ , havingClause :: HavingClause relations grouping params

704472 -- ^ If a table has been grouped using `groupBy`, but only certain groups

705473 -- are of interest, the `havingClause` can be used, much like a

706474 -- `whereClause`, to eliminate groups from the result. Expressions in the

707475 -- `havingClause` can refer both to grouped expressions and to ungrouped

708476 -- expressions (which necessarily involve an aggregate function).

709− , orderByClause :: [SortExpression outer commons grp schemas params from]

477+ , orderByClause :: [SortExpression relations grouping params]

710478 -- ^ The `orderByClause` is for optional sorting. When more than one

711479 -- `SortExpression` is specified, the later (right) values are used to sort

712480 -- rows that are equal according to the earlier (left) values.

@@ -716,69 +484,72 @@ data TableExpression

716484 -- will be returned (but possibly fewer, if the query itself yields

717485 -- fewer rows).

718486 , offsetClause :: [Word64]

719− -- ^ The `offsetClause` is combined with `Prelude.+` to give an offset count

487+ -- ^ The `offsetClause` is combined with `+` to give an offset count

720488 -- if nonempty. The offset count says to skip that many rows before

721489 -- beginning to return rows. The rows are skipped before the limit count

722490 -- is applied.

723− } deriving (GHC.Generic)

491+ }

724492

725493-- | Render a `TableExpression`

726−instance RenderSQL (TableExpression outer commons grp schemas params from) where

727− renderSQL

728− (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat

729− [ "FROM ", renderSQL frm'

730− , renderWheres whs'

731− , renderSQL grps'

732− , renderSQL hvs'

733− , renderOrderByClause srts'

734− , renderLimits lims'

735− , renderOffsets offs' ]

736− where

737− renderWheres = \case

738− [] -> ""

739− wh:[] -> " WHERE" <+> renderSQL wh

740− wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)

741− renderOrderByClause = \case

742− [] -> ""

743− srts -> " ORDER BY"

744− <+> commaSeparated (renderSQL <$> srts)

745− renderLimits = \case

746− [] -> ""

747− lims -> " LIMIT" <+> fromString (show (minimum lims))

748− renderOffsets = \case

749− [] -> ""

750− offs -> " OFFSET" <+> fromString (show (sum offs))

494+renderTableExpression

495+ :: TableExpression schema params relations grouping

496+ -> ByteString

497+renderTableExpression

498+ (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat

499+ [ "FROM ", renderFromClause frm'

500+ , renderWheres whs'

501+ , renderGroupByClause grps'

502+ , renderHavingClause hvs'

503+ , renderOrderByClause srts'

504+ , renderLimits lims'

505+ , renderOffsets offs'

506+ ]

507+ where

508+ renderWheres = \case

509+ [] -> ""

510+ wh:[] -> " WHERE" <+> renderExpression wh

511+ wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)

512+ renderOrderByClause = \case

513+ [] -> ""

514+ srts -> " ORDER BY"

515+ <+> commaSeparated (renderSortExpression <$> srts)

516+ renderLimits = \case

517+ [] -> ""

518+ lims -> " LIMIT" <+> fromString (show (minimum lims))

519+ renderOffsets = \case

520+ [] -> ""

521+ offs -> " OFFSET" <+> fromString (show (sum offs))

751522

752523-- | A `from` generates a `TableExpression` from a table reference that can be

753524-- a table name, or a derived table such as a subquery, a JOIN construct,

754525-- or complex combinations of these. A `from` may be transformed by `where_`,

755−-- `groupBy`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator

526+-- `group`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator

756527-- to match the left-to-right sequencing of their placement in SQL.

757528from

758− :: FromClause outer commons schemas params from -- ^ table reference

759− -> TableExpression outer commons 'Ungrouped schemas params from

760−from tab = TableExpression tab [] noGroups NoHaving [] [] []

529+ :: FromClause schema params relations -- ^ table reference

530+ -> TableExpression schema params relations 'Ungrouped

531+from rels = TableExpression rels [] NoGroups NoHaving [] [] []

761532

762533-- | A `where_` is an endomorphism of `TableExpression`s which adds a

763534-- search condition to the `whereClause`.

764535where_

765− :: Condition outer commons 'Ungrouped schemas params from -- ^ filtering condition

766− -> TableExpression outer commons grp schemas params from

767− -> TableExpression outer commons grp schemas params from

536+ :: Condition relations 'Ungrouped params -- ^ filtering condition

537+ -> TableExpression schema params relations grouping

538+ -> TableExpression schema params relations grouping

768539where_ wh rels = rels {whereClause = wh : whereClause rels}

769540

770−-- | A `groupBy` is a transformation of `TableExpression`s which switches

771−-- its `Grouping` from `Ungrouped` to `Grouped`. Use @groupBy Nil@ to perform

541+-- | A `group` is a transformation of `TableExpression`s which switches

542+-- its `Grouping` from `Ungrouped` to `Grouped`. Use @group Nil@ to perform

772543-- a "grand total" aggregation query.

773−groupBy

544+group

774545 :: SListI bys

775− => NP (By from) bys -- ^ grouped columns

776− -> TableExpression outer commons 'Ungrouped schemas params from

777− -> TableExpression outer commons ('Grouped bys) schemas params from

778−groupBy bys rels = TableExpression

546+ => NP (By relations) bys -- ^ grouped columns

547+ -> TableExpression schema params relations 'Ungrouped

548+ -> TableExpression schema params relations ('Grouped bys)

549+group bys rels = TableExpression

779550 { fromClause = fromClause rels

780551 , whereClause = whereClause rels

781− , groupByClause = group bys

552+ , groupByClause = Group bys

782553 , havingClause = Having []

783554 , orderByClause = []

784555 , limitClause = limitClause rels

@@ -788,29 +559,34 @@ groupBy bys rels = TableExpression

788559-- | A `having` is an endomorphism of `TableExpression`s which adds a

789560-- search condition to the `havingClause`.

790561having

791− :: Condition outer commons ('Grouped bys) schemas params from -- ^ having condition

792− -> TableExpression outer commons ('Grouped bys) schemas params from

793− -> TableExpression outer commons ('Grouped bys) schemas params from

562+ :: Condition relations ('Grouped bys) params -- ^ having condition

563+ -> TableExpression schema params relations ('Grouped bys)

564+ -> TableExpression schema params relations ('Grouped bys)

794565having hv rels = rels

795566 { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) }

796567

797−instance OrderBy TableExpression where

798− orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}

568+-- | An `orderBy` is an endomorphism of `TableExpression`s which appends an

569+-- ordering to the right of the `orderByClause`.

570+orderBy

571+ :: [SortExpression relations grouping params] -- ^ sort expressions

572+ -> TableExpression schema params relations grouping

573+ -> TableExpression schema params relations grouping

574+orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}

799575

800576-- | A `limit` is an endomorphism of `TableExpression`s which adds to the

801577-- `limitClause`.

802578limit

803579 :: Word64 -- ^ limit parameter

804− -> TableExpression outer commons grp schemas params from

805− -> TableExpression outer commons grp schemas params from

580+ -> TableExpression schema params relations grouping

581+ -> TableExpression schema params relations grouping

806582limit lim rels = rels {limitClause = lim : limitClause rels}

807583

808584-- | An `offset` is an endomorphism of `TableExpression`s which adds to the

809585-- `offsetClause`.

810586offset

811587 :: Word64 -- ^ offset parameter

812− -> TableExpression outer commons grp schemas params from

813− -> TableExpression outer commons grp schemas params from

588+ -> TableExpression schema params relations grouping

589+ -> TableExpression schema params relations grouping

814590offset off rels = rels {offsetClause = off : offsetClause rels}

815591

816592{-----------------------------------------

@@ -821,76 +597,57 @@ FROM clauses

821597A `FromClause` can be a table name, or a derived table such

822598as a subquery, a @JOIN@ construct, or complex combinations of these.

823599-}

824−newtype FromClause outer commons schemas params from

600+newtype FromClause schema params relations

825601 = UnsafeFromClause { renderFromClause :: ByteString }

826602 deriving (GHC.Generic,Show,Eq,Ord,NFData)

827−instance RenderSQL (FromClause outer commons schemas params from) where

828− renderSQL = renderFromClause

829603

830−-- | A real `table` is a table from the database.

604+-- | A real `table` is a table from the schema.

831605table

832− :: (Has sch schemas schema, Has tab schema ('Table table))

833− => Aliased (QualifiedAlias sch) (alias ::: tab)

834− -> FromClause outer commons schemas params '[alias ::: TableToRow table]

835−table (tab `As` alias) = UnsafeFromClause $

836− renderSQL tab <+> "AS" <+> renderSQL alias

606+ :: Aliased (Table schema) table

607+ -> FromClause schema params '[table]

608+table = UnsafeFromClause . renderAliasedAs renderTable

837609

838610-- | `subquery` derives a table from a `Query`.

839611subquery

840− :: Aliased (Query outer commons schemas params) query

841− -> FromClause outer commons schemas params '[query]

842−subquery = UnsafeFromClause . renderAliased (parenthesized . renderSQL)

612+ :: Aliased (Query schema params) table

613+ -> FromClause schema params '[table]

614+subquery = UnsafeFromClause . renderAliasedAs (parenthesized . renderQuery)

843615

844616-- | `view` derives a table from a `View`.

845617view

846− :: (Has sch schemas schema, Has vw schema ('View view))

847− => Aliased (QualifiedAlias sch) (alias ::: vw)

848− -> FromClause outer commons schemas params '[alias ::: view]

849−view (vw `As` alias) = UnsafeFromClause $

850− renderSQL vw <+> "AS" <+> renderSQL alias

851−

852−-- | `common` derives a table from a common table expression.

853−common

854− :: Has cte commons common

855− => Aliased Alias (alias ::: cte)

856− -> FromClause outer commons schemas params '[alias ::: common]

857−common (cte `As` alias) = UnsafeFromClause $

858− renderSQL cte <+> "AS" <+> renderSQL alias

859−

860−instance Additional (FromClause outer commons schemas params) where

861− also right left = UnsafeFromClause $

862− renderSQL left <> ", " <> renderSQL right

863−

864−{- |

865−@left & crossJoin right@. For every possible combination of rows from

866−@left@ and @right@ (i.e., a Cartesian product), the joined table will contain

867−a row consisting of all columns in @left@ followed by all columns in @right@.

868−If the tables have @n@ and @m@ rows respectively, the joined table will

869−have @n * m@ rows.

618+ :: Aliased (View schema) table

619+ -> FromClause schema params '[table]

620+view = UnsafeFromClause . renderAliasedAs renderView

621+

622+{- | @left & crossJoin right@. For every possible combination of rows from

623+ @left@ and @right@ (i.e., a Cartesian product), the joined table will contain

624+ a row consisting of all columns in @left@ followed by all columns in @right@.

625+ If the tables have @n@ and @m@ rows respectively, the joined table will

626+ have @n * m@ rows.

870627-}

871628crossJoin

872− :: FromClause outer commons schemas params right

629+ :: FromClause schema params right

873630 -- ^ right

874− -> FromClause outer commons schemas params left

631+ -> FromClause schema params left

875632 -- ^ left

876− -> FromClause outer commons schemas params (Join left right)

633+ -> FromClause schema params (Join left right)

877634crossJoin right left = UnsafeFromClause $

878− renderSQL left <+> "CROSS JOIN" <+> renderSQL right

635+ renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right

879636

880637{- | @left & innerJoin right on@. The joined table is filtered by

881638the @on@ condition.

882639-}

883640innerJoin

884− :: FromClause outer commons schemas params right

641+ :: FromClause schema params right

885642 -- ^ right

886− -> Condition outer commons 'Ungrouped schemas params (Join left right)

643+ -> Condition (Join left right) 'Ungrouped params

887644 -- ^ @on@ condition

888− -> FromClause outer commons schemas params left

645+ -> FromClause schema params left

889646 -- ^ left

890− -> FromClause outer commons schemas params (Join left right)

647+ -> FromClause schema params (Join left right)

891648innerJoin right on left = UnsafeFromClause $

892− renderSQL left <+> "INNER JOIN" <+> renderSQL right

893− <+> "ON" <+> renderSQL on

649+ renderFromClause left <+> "INNER JOIN" <+> renderFromClause right

650+ <+> "ON" <+> renderExpression on

894651

895652{- | @left & leftOuterJoin right on@. First, an inner join is performed.

896653 Then, for each row in @left@ that does not satisfy the @on@ condition with

@@ -898,16 +655,16 @@ innerJoin right on left = UnsafeFromClause $

898655 Thus, the joined table always has at least one row for each row in @left@.

899656-}

900657leftOuterJoin

901− :: FromClause outer commons schemas params right

658+ :: FromClause schema params right

902659 -- ^ right

903− -> Condition outer commons 'Ungrouped schemas params (Join left right)

660+ -> Condition (Join left right) 'Ungrouped params

904661 -- ^ @on@ condition

905− -> FromClause outer commons schemas params left

662+ -> FromClause schema params left

906663 -- ^ left

907− -> FromClause outer commons schemas params (Join left (NullifyFrom right))

664+ -> FromClause schema params (Join left (NullifyRelations right))

908665leftOuterJoin right on left = UnsafeFromClause $

909− renderSQL left <+> "LEFT OUTER JOIN" <+> renderSQL right

910− <+> "ON" <+> renderSQL on

666+ renderFromClause left <+> "LEFT OUTER JOIN" <+> renderFromClause right

667+ <+> "ON" <+> renderExpression on

911668

912669{- | @left & rightOuterJoin right on@. First, an inner join is performed.

913670 Then, for each row in @right@ that does not satisfy the @on@ condition with

@@ -916,16 +673,16 @@ leftOuterJoin right on left = UnsafeFromClause $

916673 have a row for each row in @right@.

917674-}

918675rightOuterJoin

919− :: FromClause outer commons schemas params right

676+ :: FromClause schema params right

920677 -- ^ right

921− -> Condition outer commons 'Ungrouped schemas params (Join left right)

678+ -> Condition (Join left right) 'Ungrouped params

922679 -- ^ @on@ condition

923− -> FromClause outer commons schemas params left

680+ -> FromClause schema params left

924681 -- ^ left

925− -> FromClause outer commons schemas params (Join (NullifyFrom left) right)

682+ -> FromClause schema params (Join (NullifyRelations left) right)

926683rightOuterJoin right on left = UnsafeFromClause $

927− renderSQL left <+> "RIGHT OUTER JOIN" <+> renderSQL right

928− <+> "ON" <+> renderSQL on

684+ renderFromClause left <+> "RIGHT OUTER JOIN" <+> renderFromClause right

685+ <+> "ON" <+> renderExpression on

929686

930687{- | @left & fullOuterJoin right on@. First, an inner join is performed.

931688 Then, for each row in @left@ that does not satisfy the @on@ condition with

@@ -935,56 +692,47 @@ rightOuterJoin right on left = UnsafeFromClause $

935692 is added.

936693-}

937694fullOuterJoin

938− :: FromClause outer commons schemas params right

695+ :: FromClause schema params right

939696 -- ^ right

940− -> Condition outer commons 'Ungrouped schemas params (Join left right)

697+ -> Condition (Join left right) 'Ungrouped params

941698 -- ^ @on@ condition

942− -> FromClause outer commons schemas params left

699+ -> FromClause schema params left

943700 -- ^ left

944− -> FromClause outer commons schemas params

945− (Join (NullifyFrom left) (NullifyFrom right))

701+ -> FromClause schema params

702+ (Join (NullifyRelations left) (NullifyRelations right))

946703fullOuterJoin right on left = UnsafeFromClause $

947− renderSQL left <+> "FULL OUTER JOIN" <+> renderSQL right

948− <+> "ON" <+> renderSQL on

704+ renderFromClause left <+> "FULL OUTER JOIN" <+> renderFromClause right

705+ <+> "ON" <+> renderExpression on

949706

950707{-----------------------------------------

951708Grouping

952709-----------------------------------------}

953710

954−-- | `By`s are used in `groupBy` to reference a list of columns which are then

711+-- | `By`s are used in `group` to reference a list of columns which are then

955712-- used to group together those rows in a table that have the same values

956713-- in all the columns listed. @By \#col@ will reference an unambiguous

957714-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table

958715-- qualified column @tab.col@.

959716data By

960− (from :: FromType)

717+ (relations :: RelationsType)

961718 (by :: (Symbol,Symbol)) where

962− By1

963− :: (HasUnique table from columns, Has column columns ty)

719+ By

720+ :: (HasUnique relation relations columns, Has column columns ty)

964721 => Alias column

965− -> By from '(table, column)

722+ -> By relations '(relation, column)

966723 By2

967− :: (Has table from columns, Has column columns ty)

968− => Alias table

969− -> Alias column

970− -> By from '(table, column)

971−deriving instance Show (By from by)

972−deriving instance Eq (By from by)

973−deriving instance Ord (By from by)

974−instance RenderSQL (By from by) where

975− renderSQL = \case

976− By1 column -> renderSQL column

977− By2 rel column -> renderSQL rel <> "." <> renderSQL column

978−

979−instance (HasUnique rel rels cols, Has col cols ty, by ~ '(rel, col))

980− => IsLabel col (By rels by) where fromLabel = By1 fromLabel

981−instance (HasUnique rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])

982− => IsLabel col (NP (By rels) bys) where fromLabel = By1 fromLabel :* Nil

983−instance (Has rel rels cols, Has col cols ty, by ~ '(rel, col))

984− => IsQualified rel col (By rels by) where (!) = By2

985−instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])

986− => IsQualified rel col (NP (By rels) bys) where

987− rel ! col = By2 rel col :* Nil

724+ :: (Has relation relations columns, Has column columns ty)

725+ => (Alias relation, Alias column)

726+ -> By relations '(relation, column)

727+deriving instance Show (By relations by)

728+deriving instance Eq (By relations by)

729+deriving instance Ord (By relations by)

730+

731+-- | Renders a `By`.

732+renderBy :: By relations by -> ByteString

733+renderBy = \case

734+ By column -> renderAlias column

735+ By2 (rel, column) -> renderAlias rel <> "." <> renderAlias column

988736

989737-- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.

990738-- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`.

@@ -992,107 +740,82 @@ instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])

992740-- done on @NoGroups@ while all output `Expression`s must be aggregated

993741-- in @Group Nil@. In general, all output `Expression`s in the

994742-- complement of @bys@ must be aggregated in @Group bys@.

995−newtype GroupByClause grp from = UnsafeGroupByClause

996− { renderGroupByClause :: ByteString }

997− deriving (GHC.Generic,Show,Eq,Ord,NFData)

998−instance RenderSQL (GroupByClause grp from) where

999− renderSQL = renderGroupByClause

1000−noGroups :: GroupByClause 'Ungrouped from

1001−noGroups = UnsafeGroupByClause ""

1002−group

1003− :: SListI bys

1004− => NP (By from) bys

1005− -> GroupByClause ('Grouped bys) from

1006−group bys = UnsafeGroupByClause $ case bys of

1007− Nil -> ""

1008− bys' -> " GROUP BY" <+> renderCommaSeparated renderSQL bys'

743+data GroupByClause relations grouping where

744+ NoGroups :: GroupByClause relations 'Ungrouped

745+ Group

746+ :: SListI bys

747+ => NP (By relations) bys

748+ -> GroupByClause relations ('Grouped bys)

749+

750+-- | Renders a `GroupByClause`.

751+renderGroupByClause :: GroupByClause relations grouping -> ByteString

752+renderGroupByClause = \case

753+ NoGroups -> ""

754+ Group Nil -> ""

755+ Group bys -> " GROUP BY" <+> renderCommaSeparated renderBy bys

1009756

1010757-- | A `HavingClause` is used to eliminate groups that are not of interest.

1011758-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`

1012759-- `TableExpression` must use `Having` whose conditions are combined with

1013760-- `.&&`.

1014−data HavingClause outer commons grp schemas params from where

1015− NoHaving :: HavingClause outer commons 'Ungrouped schemas params from

761+data HavingClause relations grouping params where

762+ NoHaving :: HavingClause relations 'Ungrouped params

1016763 Having

1017− :: [Condition outer commons ('Grouped bys) schemas params from]

1018− -> HavingClause outer commons ('Grouped bys) schemas params from

1019−deriving instance Show (HavingClause outer commons grp schemas params from)

1020−deriving instance Eq (HavingClause outer commons grp schemas params from)

1021−deriving instance Ord (HavingClause outer commons grp schemas params from)

764+ :: [Condition relations ('Grouped bys) params]

765+ -> HavingClause relations ('Grouped bys) params

766+deriving instance Show (HavingClause relations grouping params)

767+deriving instance Eq (HavingClause relations grouping params)

768+deriving instance Ord (HavingClause relations grouping params)

1022769

1023770-- | Render a `HavingClause`.

1024−instance RenderSQL (HavingClause outer commons grp schemas params from) where

1025− renderSQL = \case

1026− NoHaving -> ""

1027− Having [] -> ""

1028− Having conditions ->

1029− " HAVING" <+> commaSeparated (renderSQL <$> conditions)

1030−

1031−-- | A `CommonTableExpression` is an auxiliary statement in a `with` clause.

1032−data CommonTableExpression statement

1033− (schemas :: SchemasType)

1034− (params :: [NullityType])

1035− (commons0 :: FromType)

1036− (commons1 :: FromType) where

1037− CommonTableExpression

1038− :: Aliased (statement commons schemas params) (cte ::: common)

1039− -> CommonTableExpression statement schemas params commons (cte ::: common ': commons)

1040−instance

1041− ( KnownSymbol cte

1042− , commons1 ~ (cte ::: common ': commons)

1043− ) => Aliasable cte

1044− (statement commons schemas params common)

1045− (CommonTableExpression statement schemas params commons commons1) where

1046− statement `as` cte = CommonTableExpression (statement `as` cte)

1047−instance

1048− ( KnownSymbol cte

1049− , commons1 ~ (cte ::: common ': commons)

1050− ) => Aliasable cte

1051− (statement commons schemas params common)

1052− (Path (CommonTableExpression statement schemas params) commons commons1) where

1053− statement `as` cte = csingleton (statement `as` cte)

1054−

1055−instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL

1056− (CommonTableExpression statement schemas params commons0 commons1) where

1057− renderSQL (CommonTableExpression (statement `As` cte)) =

1058− renderSQL cte <+> "AS" <+> parenthesized (renderSQL statement)

1059−

1060−-- | `with` provides a way to write auxiliary statements for use in a larger query.

1061−-- These statements, referred to as `CommonTableExpression`s, can be thought of as

1062−-- defining temporary tables that exist just for one query.

1063−class With statement where

1064− with

1065− :: Path (CommonTableExpression statement schemas params) commons0 commons1

1066− -- ^ common table expressions

1067− -> statement commons1 schemas params row

1068− -- ^ larger query

1069− -> statement commons0 schemas params row

1070−instance With (Query outer) where

1071− with Done query = query

1072− with ctes query = UnsafeQuery $

1073− "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL query

771+renderHavingClause :: HavingClause relations grouping params -> ByteString

772+renderHavingClause = \case

773+ NoHaving -> ""

774+ Having [] -> ""

775+ Having conditions ->

776+ " HAVING" <+> commaSeparated (renderExpression <$> conditions)

1074777

1075−{- |

1076−>>> import Data.Monoid (Sum (..))

1077−>>> import Data.Int (Int64)

1078−>>> :{

1079− let

1080− query :: Query_ schema () (Sum Int64)

1081− query = withRecursive

1082− ( values_ ((1 & astype int) `as` #n)

1083− `unionAll`

1084− select_ ((#n + 1) `as` #n)

1085− (from (common #t) & where_ (#n .< 100)) `as` #t )

1086− ( select_ (fromNull 0 (sum_ (All #n)) `as` #getSum) (from (common #t) & groupBy Nil))

1087− in printSQL query

1088−:}

1089−WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES ((1 :: int))) AS t ("n")) UNION ALL (SELECT ("n" + 1) AS "n" FROM "t" AS "t" WHERE ("n" < 100))) SELECT COALESCE(sum(ALL "n"), 0) AS "getSum" FROM "t" AS "t"

1090−-}

1091−withRecursive

1092− :: Aliased (Query outer (recursive ': commons) schemas params) recursive

1093− -> Query outer (recursive ': commons) schemas params row

1094− -> Query outer commons schemas params row

1095−withRecursive (recursive `As` cte) query = UnsafeQuery $

1096− "WITH RECURSIVE" <+> renderSQL cte

1097− <+> "AS" <+> parenthesized (renderSQL recursive)

1098− <+> renderSQL query

778+{-----------------------------------------

779+Sorting

780+-----------------------------------------}

781+

782+-- | `SortExpression`s are used by `sortBy` to optionally sort the results

783+-- of a `Query`. `Asc` or `Desc` set the sort direction of a `NotNull` result

784+-- column to ascending or descending. Ascending order puts smaller values

785+-- first, where "smaller" is defined in terms of the `.<` operator. Similarly,

786+-- descending order is determined with the `.>` operator. `AscNullsFirst`,

787+-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to

788+-- determine whether nulls appear before or after non-null values in the sort

789+-- ordering of a `Null` result column.

790+data SortExpression relations grouping params where

791+ Asc

792+ :: Expression relations grouping params ('NotNull ty)

793+ -> SortExpression relations grouping params

794+ Desc

795+ :: Expression relations grouping params ('NotNull ty)

796+ -> SortExpression relations grouping params

797+ AscNullsFirst

798+ :: Expression relations grouping params ('Null ty)

799+ -> SortExpression relations grouping params

800+ AscNullsLast

801+ :: Expression relations grouping params ('Null ty)

802+ -> SortExpression relations grouping params

803+ DescNullsFirst

804+ :: Expression relations grouping params ('Null ty)

805+ -> SortExpression relations grouping params

806+ DescNullsLast

807+ :: Expression relations grouping params ('Null ty)

808+ -> SortExpression relations grouping params

809+deriving instance Show (SortExpression relations grouping params)

810+

811+-- | Render a `SortExpression`.

812+renderSortExpression :: SortExpression relations grouping params -> ByteString

813+renderSortExpression = \case

814+ Asc expression -> renderExpression expression <+> "ASC"

815+ Desc expression -> renderExpression expression <+> "DESC"

816+ AscNullsFirst expression -> renderExpression expression

817+ <+> "ASC NULLS FIRST"

818+ DescNullsFirst expression -> renderExpression expression

819+ <+> "DESC NULLS FIRST"

820+ AscNullsLast expression -> renderExpression expression <+> "ASC NULLS LAST"

821+ DescNullsLast expression -> renderExpression expression <+> "DESC NULLS LAST"

squeal-postgresql/src/Squeal/PostgreSQL/Render.hs+6−71

@@ -9,11 +9,7 @@ Rendering helper functions.

99-}

1010

1111{-# LANGUAGE

12− AllowAmbiguousTypes

13− , ConstraintKinds

14− , FlexibleContexts

15− , LambdaCase

16− , MagicHash

12+ MagicHash

1713 , OverloadedStrings

1814 , PolyKinds

1915 , RankNTypes

@@ -23,48 +19,30 @@ Rendering helper functions.

2319

2420module Squeal.PostgreSQL.Render

2521 ( -- * Render

26− RenderSQL (..)

27− , printSQL

28− , escape

29− , parenthesized

30− , bracketed

22+ parenthesized

3123 , (<+>)

3224 , commaSeparated

3325 , doubleQuoted

34− , singleQuotedText

35− , singleQuotedUtf8

3626 , renderCommaSeparated

37− , renderCommaSeparatedConstraint

3827 , renderCommaSeparatedMaybe

3928 , renderNat

40− , renderSymbol

4129 ) where

4230

43−import Control.Monad.IO.Class (MonadIO (..))

4431import Data.ByteString (ByteString)

45−import Data.Maybe (catMaybes)

32+import Data.Maybe

4633import Data.Monoid ((<>))

47−import Data.Text (Text)

4834import Generics.SOP

4935import GHC.Exts

50−import GHC.TypeLits hiding (Text)

36+import GHC.TypeLits

5137

52−import qualified Data.Text as Text

53−import qualified Data.Text.Encoding as Text

5438import qualified Data.ByteString as ByteString

55−import qualified Data.ByteString.Char8 as Char8

5639

5740-- | Parenthesize a `ByteString`.

5841parenthesized :: ByteString -> ByteString

5942parenthesized str = "(" <> str <> ")"

6043

61−-- | Square bracket a `ByteString`

62−bracketed :: ByteString -> ByteString

63−bracketed str = "[" <> str <> "]"

64−

6544-- | Concatenate two `ByteString`s with a space between.

6645(<+>) :: ByteString -> ByteString -> ByteString

67−infixr 7 <+>

6846str1 <+> str2 = str1 <> " " <> str2

6947

7048-- | Comma separate a list of `ByteString`s.

@@ -75,15 +53,6 @@ commaSeparated = ByteString.intercalate ", "

7553doubleQuoted :: ByteString -> ByteString

7654doubleQuoted str = "\"" <> str <> "\""

7755

78−-- | Add single quotes around a `Text` and escape single quotes within it.

79−singleQuotedText :: Text -> ByteString

80−singleQuotedText str =

81− "'" <> Text.encodeUtf8 (Text.replace "'" "''" str) <> "'"

82−

83−-- | Add single quotes around a `ByteString` and escape single quotes within it.

84−singleQuotedUtf8 :: ByteString -> ByteString

85−singleQuotedUtf8 = singleQuotedText . Text.decodeUtf8

86−

8756-- | Comma separate the renderings of a heterogeneous list.

8857renderCommaSeparated

8958 :: SListI xs

@@ -94,16 +63,6 @@ renderCommaSeparated render

9463 . hcollapse

9564 . hmap (K . render)

9665

97−-- | Comma separate the renderings of a heterogeneous list.

98−renderCommaSeparatedConstraint

99− :: forall c xs expression. (All c xs, SListI xs)

100− => (forall x. c x => expression x -> ByteString)

101− -> NP expression xs -> ByteString

102−renderCommaSeparatedConstraint render

103− = commaSeparated

104− . hcollapse

105− . hcmap (Proxy @c) (K . render)

106−

10766-- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping

10867-- `Nothing`s.

10968renderCommaSeparatedMaybe

@@ -117,29 +76,5 @@ renderCommaSeparatedMaybe render

11776 . hmap (K . render)

11877

11978-- | Render a promoted `Nat`.

120−renderNat :: forall n. KnownNat n => ByteString

121−renderNat = fromString (show (natVal' (proxy# :: Proxy# n)))

122−

123−-- | Render a promoted `Symbol`.

124−renderSymbol :: forall s. KnownSymbol s => ByteString

125−renderSymbol = fromString (symbolVal' (proxy# :: Proxy# s))

126−

127−-- | A class for rendering SQL

128−class RenderSQL sql where renderSQL :: sql -> ByteString

129−

130−-- | Print SQL.

131−printSQL :: (RenderSQL sql, MonadIO io) => sql -> io ()

132−printSQL = liftIO . Char8.putStrLn . renderSQL

133−

134−-- | `escape` a character to prevent injection

135−escape :: Char -> String

136−escape = \case

137− '\NUL' -> "\\0"

138− '\'' -> "''"

139− '"' -> "\\\""

140− '\b' -> "\\b"

141− '\n' -> "\\n"

142− '\r' -> "\\r"

143− '\t' -> "\\t"

144− '\\' -> "\\\\"

145− c -> [c]

79+renderNat :: KnownNat n => proxy n -> ByteString

80+renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))

squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+397−342

@@ -1,32 +1,33 @@

11{-|

22Module: Squeal.PostgreSQL.Schema

33Description: Embedding of PostgreSQL type and alias system

4−Copyright: (c) Eitan Chatav, 2019

4+Copyright: (c) Eitan Chatav, 2017

55Maintainer: eitan@morphism.tech

66Stability: experimental

8−`Squeal.PostgreSQL.Schema` provides a type-level DSL for kinds of Postgres types,

9−tables, schema, constraints, aliases, enumerated labels, and groupings.

10−It also defines useful type families to operate on these. Finally,

11−it defines an embedding of Haskell types into Postgres types.

8+A type-level DSL for kinds of PostgreSQL types, constraints, and aliases.

129-}

10+

1311{-# LANGUAGE

1412 AllowAmbiguousTypes

1513 , ConstraintKinds

14+ , DataKinds

1615 , DeriveAnyClass

16+ , DeriveDataTypeable

1717 , DeriveGeneric

1818 , FlexibleContexts

1919 , FlexibleInstances

2020 , FunctionalDependencies

2121 , GADTs

22− , LambdaCase

22+ , MagicHash

23+ , MultiParamTypeClasses

2324 , OverloadedStrings

24− , QuantifiedConstraints

25+ , PolyKinds

2526 , RankNTypes

2627 , ScopedTypeVariables

2728 , StandaloneDeriving

2829 , TypeApplications

29− , TypeFamilyDependencies

30+ , TypeFamilies

3031 , TypeInType

3132 , TypeOperators

3233 , UndecidableInstances

@@ -34,85 +35,97 @@ it defines an embedding of Haskell types into Postgres types.

3435#-}

3536

3637module Squeal.PostgreSQL.Schema

37− ( -- * Postgres Types

38+ ( -- * Types

3839 PGType (..)

40+ , HasOid (..)

3941 , NullityType (..)

40− , RowType

41− , FromType

42− -- * Schema Types

4342 , ColumnType

4443 , ColumnsType

44+ , RelationType

45+ , NilRelation

46+ , RelationsType

4547 , TableType

46− , SchemumType (..)

47− , IndexType (..)

48− , FunctionType

49− , OperatorType (..)

50− , ReturnsType (..)

51− , SchemaType

52− , SchemasType

53− , Public

48+ , TablesType

49+ , NilTables

50+ -- * Grouping

51+ , Grouping (..)

52+ , GroupedBy

5453 -- * Constraints

5554 , (:=>)

5655 , ColumnConstraint (..)

5756 , TableConstraint (..)

5857 , TableConstraints

58+ , NilTableConstraints

5959 , Uniquely

60− -- * Enumerated Labels

61− , IsPGlabel (..)

62− , PGlabel (..)

63− -- * Data Definitions

60+ -- * Aliases

61+ , (:::)

62+ , Alias (Alias)

63+ , renderAlias

64+ , renderAliases

65+ , Aliased (As)

66+ , renderAliasedAs

67+ , AliasesOf

68+ , Has

69+ , HasUnique

70+ , HasAll

71+ , IsLabel (..)

72+ , IsQualified (..)

73+ -- * Type Families

74+ , Join

6475 , Create

65− , CreateIfNotExists

66− , CreateOrReplace

6776 , Drop

68− , DropSchemum

69− , DropIfExists

70− , DropSchemumIfExists

7177 , Alter

72− , AlterIfExists

7378 , Rename

74− , RenameIfExists

75− , ConstraintInvolves

76− , DropIfConstraintsInvolve

77− , IsNotElem

78− , AllUnique

79− -- * Type Classifications

79+ , Elem

80+ , In

8081 , PGNum

8182 , PGIntegral

8283 , PGFloating

8384 , PGTypeOf

84− , PGJsonType

85− , PGJsonKey

85+ , SameTypes

8686 , SamePGType

8787 , AllNotNull

8888 , NotAllNull

89− -- * Nullifications

9089 , NullifyType

91− , NullifyRow

92− , NullifyFrom

93− -- * Table Conversions

90+ , NullifyRelation

91+ , NullifyRelations

92+ , ColumnsToRelation

93+ , RelationToColumns

9494 , TableToColumns

95− , ColumnsToRow

96− , TableToRow

95+ , TablesToRelations

96+ , RelationsToTables

97+ , ConstraintInvolves

98+ , DropIfConstraintsInvolve

99+ -- * Generics

100+ , SameField

101+ , SameFields

102+ , SameLabel

103+ , SameLabels

104+ -- * Schema

105+ , SchemumType (..)

106+ , SchemaType

107+ , With

97108 ) where

98109

99−import Control.Category

100−import Data.Kind

110+import Control.DeepSeq

111+import Data.ByteString

101112import Data.Monoid hiding (All)

113+import Data.String

114+import Data.Word

102115import Data.Type.Bool

103−import Generics.SOP

116+import GHC.Exts

117+import GHC.OverloadedLabels

104118import GHC.TypeLits

105−import Prelude hiding (id, (.))

106119

107−import Squeal.PostgreSQL.Alias

108−import Squeal.PostgreSQL.List

109−import Squeal.PostgreSQL.Render

120+import qualified GHC.Generics as GHC

121+import qualified Generics.SOP as SOP

122+import qualified Generics.SOP.Type.Metadata as Type

110123

111−-- $setup

112−-- >>> import Squeal.PostgreSQL

124+import Squeal.PostgreSQL.Render

113125

114126-- | `PGType` is the promoted datakind of PostgreSQL types.

115127--

128+-- >>> import Squeal.PostgreSQL.Schema

116129-- >>> :kind 'PGbool

117130-- 'PGbool :: PGType

118131data PGType

@@ -123,7 +136,6 @@ data PGType

123136 | PGnumeric -- ^ arbitrary precision numeric type

124137 | PGfloat4 -- ^ single precision floating-point number (4 bytes)

125138 | PGfloat8 -- ^ double precision floating-point number (8 bytes)

126− | PGmoney -- ^ currency amount

127139 | PGchar Nat -- ^ fixed-length character string

128140 | PGvarchar Nat -- ^ variable-length character string

129141 | PGtext -- ^ variable-length character string

@@ -138,16 +150,40 @@ data PGType

138150 | PGinet -- ^ IPv4 or IPv6 host address

139151 | PGjson -- ^ textual JSON data

140152 | PGjsonb -- ^ binary JSON data, decomposed

141− | PGvararray NullityType -- ^ variable length array

142− | PGfixarray [Nat] NullityType -- ^ fixed length array

143− | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.

144− | PGcomposite RowType -- ^ a composite type represents the structure of a row or record; it is essentially just a list of field names and their data types.

145− | PGtsvector -- ^ A tsvector value is a sorted list of distinct lexemes, which are words that have been normalized to merge different variants of the same word.

146− | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for.

147− | PGoid -- Object identifiers (OIDs) are used internally by PostgreSQL as primary keys for various system tables.

148− | PGrange PGType -- ^ Range types are data types representing a range of values of some element type (called the range's subtype).

153+ | PGvararray PGType -- ^ variable length array

154+ | PGfixarray Nat PGType -- ^ fixed length array

155+ | PGenum [Symbol]

156+ | PGcomposite [(Symbol, PGType)]

149157 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types

150158

159+-- | The object identifier of a `PGType`.

160+--

161+-- >>> :set -XTypeApplications

162+-- >>> oid @'PGbool

163+-- 16

164+class HasOid (ty :: PGType) where oid :: Word32

165+instance HasOid 'PGbool where oid = 16

166+instance HasOid 'PGint2 where oid = 21

167+instance HasOid 'PGint4 where oid = 23

168+instance HasOid 'PGint8 where oid = 20

169+instance HasOid 'PGnumeric where oid = 1700

170+instance HasOid 'PGfloat4 where oid = 700

171+instance HasOid 'PGfloat8 where oid = 701

172+instance HasOid ('PGchar n) where oid = 18

173+instance HasOid ('PGvarchar n) where oid = 1043

174+instance HasOid 'PGtext where oid = 25

175+instance HasOid 'PGbytea where oid = 17

176+instance HasOid 'PGtimestamp where oid = 1114

177+instance HasOid 'PGtimestamptz where oid = 1184

178+instance HasOid 'PGdate where oid = 1082

179+instance HasOid 'PGtime where oid = 1083

180+instance HasOid 'PGtimetz where oid = 1266

181+instance HasOid 'PGinterval where oid = 1186

182+instance HasOid 'PGuuid where oid = 2950

183+instance HasOid 'PGinet where oid = 869

184+instance HasOid 'PGjson where oid = 114

185+instance HasOid 'PGjsonb where oid = 3802

186+

151187-- | `NullityType` encodes the potential presence or definite absence of a

152188-- @NULL@ allowing operations which are sensitive to such to be well typed.

153189--

@@ -166,6 +202,14 @@ data NullityType

166202type (:=>) constraint ty = '(constraint,ty)

167203infixr 7 :=>

168204

205+-- | The alias operator `:::` is like a promoted version of `As`,

206+-- a type level pair between

207+-- an alias and some type, like a column alias and either a `ColumnType` or

208+-- `NullityType` or a table alias and either a `TableType` or a `RelationType`

209+-- or a constraint alias and a `TableConstraint`.

210+type (:::) (alias :: Symbol) ty = '(alias,ty)

211+infixr 6 :::

212+

169213-- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates.

170214-- A column can be assigned a default value.

171215-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also

@@ -207,14 +251,11 @@ data TableConstraint

207251 | PrimaryKey [Symbol]

208252 | ForeignKey [Symbol] Symbol [Symbol]

209253

210−{- | A `TableConstraints` is a row of `TableConstraint`s.

211−

212−>>> :{

213−type family UsersConstraints :: TableConstraints where

214− UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]

215−:}

216−-}

254+-- | A `TableConstraints` is a row of `TableConstraint`s.

217255type TableConstraints = [(Symbol,TableConstraint)]

256+-- | A monokinded empty `TableConstraints`.

257+type family NilTableConstraints :: TableConstraints where

258+ NilTableConstraints = '[]

218259

219260-- | A `ForeignKey` must reference columns that either are

220261-- a `PrimaryKey` or form a `Unique` constraint.

@@ -238,65 +279,227 @@ type family Uniquely

238279-- :}

239280type TableType = (TableConstraints,ColumnsType)

240281

241−{- | A `RowType` is a row of `NullityType`. They correspond to Haskell

242−record types by means of `Squeal.PostgreSQL.Binary.RowPG` and are used in many places.

243−

244−>>> :{

245−type family PersonRow :: RowType where

246− PersonRow =

247− '[ "name" ::: 'NotNull 'PGtext

248− , "age" ::: 'NotNull 'PGint4

249− , "dateOfBirth" ::: 'Null 'PGdate

250− ]

251−:}

252−-}

253−type RowType = [(Symbol,NullityType)]

282+-- | `TablesType` is a row of `TableType`s, thought of as a union.

283+--

284+-- >>> :{

285+-- type family Schema :: TablesType where

286+-- Schema =

287+-- '[ "users" :::

288+-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

289+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4

290+-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext

291+-- , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2)

292+-- ]

293+-- , "emails" :::

294+-- '[ "pk_emails" ::: 'PrimaryKey '["id"]

295+-- , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]

296+-- ] :=>

297+-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4

298+-- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4

299+-- , "email" ::: 'NoDef :=> 'Null 'PGtext

300+-- ]

301+-- ]

302+-- :}

303+type TablesType = [(Symbol,TableType)]

304+-- | A monokinded empty `TablesType`.

305+type family NilTables :: TablesType where NilTables = '[]

254306

255−{- | `FromType` is a row of `RowType`s. It can be thought of as

256−a product, or horizontal gluing and is used in `Squeal.PostgreSQL.Query.FromClause`s

257−and `Squeal.PostgreSQL.Query.TableExpression`s.

258−-}

259−type FromType = [(Symbol,RowType)]

260−

261−-- | `ColumnsToRow` removes column constraints.

262−type family ColumnsToRow (columns :: ColumnsType) :: RowType where

263− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': column5 ::: _ :=> ty5 ': columns) =

264− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': ColumnsToRow columns

265− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': columns) =

266− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': ColumnsToRow columns

267− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': columns) =

268− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': ColumnsToRow columns

269− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': columns) =

270− column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': ColumnsToRow columns

271− ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': columns) =

272− column ::: ty ': column1 ::: ty1 ': ColumnsToRow columns

273− ColumnsToRow (column ::: _ :=> ty ': columns) =

274− column ::: ty ': ColumnsToRow columns

275− ColumnsToRow '[] = '[]

307+-- | `RelationType` is a row of `NullityType`

308+--

309+-- >>> :{

310+-- type family PersonRelation :: RelationType where

311+-- PersonRelation =

312+-- '[ "name" ::: 'NotNull 'PGtext

313+-- , "age" ::: 'NotNull 'PGint4

314+-- , "dateOfBirth" ::: 'Null 'PGdate

315+-- ]

316+-- :}

317+type RelationType = [(Symbol,NullityType)]

318+-- | A monokinded empty `RelationType`.

319+type family NilRelation :: RelationType where NilRelation = '[]

276320

277−-- | `TableToColumns` removes table constraints.

278−type family TableToColumns (table :: TableType) :: ColumnsType where

279− TableToColumns (constraints :=> columns) = columns

321+-- | `RelationsType` is a row of `RelationType`s, thought of as a product.

322+type RelationsType = [(Symbol,RelationType)]

280323

281−-- | Convert a table to a row type.

282−type family TableToRow (table :: TableType) :: RowType where

283− TableToRow tab = ColumnsToRow (TableToColumns tab)

324+-- | `ColumnsToRelation` removes column constraints.

325+type family ColumnsToRelation (columns :: ColumnsType) :: RelationType where

326+ ColumnsToRelation '[] = '[]

327+ ColumnsToRelation (column ::: constraint :=> ty ': columns) =

328+ column ::: ty ': ColumnsToRelation columns

284329

285−-- | Numeric Postgres types.

286−type PGNum =

287− '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]

330+-- | `RelationToColumns` adds `'NoDef` column constraints.

331+type family RelationToColumns (relation :: RelationType) :: ColumnsType where

332+ RelationToColumns '[] = '[]

333+ RelationToColumns (column ::: ty ': columns) =

334+ column ::: 'NoDef :=> ty ': RelationToColumns columns

288335

289−-- | Floating Postgres types.

290−type PGFloating = '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]

336+-- | `TableToColumns` removes table constraints.

337+type family TableToColumns (table :: TableType) :: ColumnsType where

338+ TableToColumns (constraints :=> columns) = columns

291339

292−-- | Integral Postgres types.

293−type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8]

340+-- | `TablesToRelations` removes both table and column constraints.

341+type family TablesToRelations (tables :: TablesType) :: RelationsType where

342+ TablesToRelations '[] = '[]

343+ TablesToRelations (alias ::: constraint :=> columns ': tables) =

344+ alias ::: ColumnsToRelation columns ': TablesToRelations tables

345+

346+-- | `RelationsToTables` adds both trivial table and column constraints.

347+type family RelationsToTables (tables :: RelationsType) :: TablesType where

348+ RelationsToTables '[] = '[]

349+ RelationsToTables (alias ::: columns ': relations) =

350+ alias ::: '[] :=> RelationToColumns columns ': RelationsToTables relations

351+

352+-- | `Grouping` is an auxiliary namespace, created by

353+-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used

354+-- for typesafe aggregation

355+data Grouping

356+ = Ungrouped -- ^ no aggregation permitted

357+ | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped

358+

359+{- | A `GroupedBy` constraint indicates that a table qualified column is

360+a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,

361+may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.

362+-}

363+class (KnownSymbol relation, KnownSymbol column)

364+ => GroupedBy relation column bys where

365+instance {-# OVERLAPPING #-} (KnownSymbol relation, KnownSymbol column)

366+ => GroupedBy relation column ('(table,column) ': bys)

367+instance {-# OVERLAPPABLE #-}

368+ ( KnownSymbol relation

369+ , KnownSymbol column

370+ , GroupedBy relation column bys

371+ ) => GroupedBy relation column (tabcol ': bys)

372+

373+-- | `Alias`es are proxies for a type level string or `Symbol`

374+-- and have an `IsLabel` instance so that with @-XOverloadedLabels@

375+--

376+-- >>> :set -XOverloadedLabels

377+-- >>> #foobar :: Alias "foobar"

378+-- Alias

379+data Alias (alias :: Symbol) = Alias

380+ deriving (Eq,GHC.Generic,Ord,Show,NFData)

381+instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where

382+ fromLabel = Alias

383+instance aliases ~ '[alias] => IsLabel alias (SOP.NP Alias aliases) where

384+ fromLabel = fromLabel SOP.:* SOP.Nil

385+

386+-- | >>> renderAlias #jimbob

387+-- "\"jimbob\""

388+renderAlias :: KnownSymbol alias => Alias alias -> ByteString

389+renderAlias = doubleQuoted . fromString . symbolVal

390+

391+-- | >>> import Generics.SOP (NP(..))

392+-- >>> renderAliases (#jimbob :* #kandi :* Nil)

393+-- ["\"jimbob\"","\"kandi\""]

394+renderAliases

395+ :: SOP.All KnownSymbol aliases => SOP.NP Alias aliases -> [ByteString]

396+renderAliases = SOP.hcollapse

397+ . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderAlias)

398+

399+-- | The `As` operator is used to name an expression. `As` is like a demoted

400+-- version of `:::`.

401+--

402+-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)

403+-- As (Just "hello") Alias

404+data Aliased expression aliased where

405+ As

406+ :: KnownSymbol alias

407+ => expression ty

408+ -> Alias alias

409+ -> Aliased expression (alias ::: ty)

410+deriving instance Show (expression ty)

411+ => Show (Aliased expression (alias ::: ty))

412+deriving instance Eq (expression ty)

413+ => Eq (Aliased expression (alias ::: ty))

414+deriving instance Ord (expression ty)

415+ => Ord (Aliased expression (alias ::: ty))

416+

417+-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")

418+-- >>> renderAliasedAs renderMaybe (Just (3::Int) `As` #an_int)

419+-- "Just AS \"an_int\""

420+renderAliasedAs

421+ :: (forall ty. expression ty -> ByteString)

422+ -> Aliased expression aliased

423+ -> ByteString

424+renderAliasedAs render (expression `As` alias) =

425+ render expression <> " AS " <> renderAlias alias

426+

427+-- | `AliasesOf` retains the AliasesOf in a row.

428+type family AliasesOf aliaseds where

429+ AliasesOf '[] = '[]

430+ AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys

431+

432+-- | @HasUnique alias fields field@ is a constraint that proves that

433+-- @fields@ is a singleton of @alias ::: field@.

434+type HasUnique alias fields field = fields ~ '[alias ::: field]

435+

436+-- | @Has alias fields field@ is a constraint that proves that

437+-- @fields@ has a field of @alias ::: field@.

438+class KnownSymbol alias =>

439+ Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)

440+ | alias fields -> field where

441+instance {-# OVERLAPPING #-} KnownSymbol alias

442+ => Has alias (alias ::: field ': fields) field

443+instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)

444+ => Has alias (field' ': fields) field

445+

446+class

447+ ( SOP.All KnownSymbol aliases

448+ ) => HasAll

449+ (aliases :: [Symbol])

450+ (fields :: [(Symbol,kind)])

451+ (subfields :: [(Symbol,kind)])

452+ | aliases fields -> subfields where

453+instance {-# OVERLAPPING #-} HasAll '[] fields '[]

454+instance {-# OVERLAPPABLE #-}

455+ (Has alias fields field, HasAll aliases fields subfields)

456+ => HasAll (alias ': aliases) fields (alias ::: field ': subfields)

457+

458+-- | Analagous to `IsLabel`, the constraint

459+-- `IsQualified` defines `!` for a column alias qualified

460+-- by a table alias.

461+class IsQualified table column expression where

462+ (!) :: Alias table -> Alias column -> expression

463+ infixl 9 !

464+instance IsQualified table column (Alias table, Alias column) where (!) = (,)

465+

466+-- | @Elem@ is a promoted `Data.List.elem`.

467+type family Elem x xs where

468+ Elem x '[] = 'False

469+ Elem x (x ': xs) = 'True

470+ Elem x (_ ': xs) = Elem x xs

471+

472+-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.

473+type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True

474+

475+-- | `PGNum` is a constraint on `PGType` whose

476+-- `Squeal.PostgreSQL.Expression.Expression`s have a `Num` constraint.

477+type PGNum ty =

478+ In ty '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]

479+

480+-- | `PGFloating` is a constraint on `PGType` whose

481+-- `Squeal.PostgreSQL.Expression.Expression`s

482+-- have `Fractional` and `Floating` constraints.

483+type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]

484+

485+-- | `PGIntegral` is a constraint on `PGType` whose

486+-- `Squeal.PostgreSQL.Expression.Expression`s

487+-- have `Squeal.PostgreSQL.Expression.div_` and

488+-- `Squeal.PostgreSQL.Expression.mod_` functions.

489+type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]

294490

295491-- | `PGTypeOf` forgets about @NULL@ and any column constraints.

296492type family PGTypeOf (ty :: NullityType) :: PGType where

297493 PGTypeOf (nullity pg) = pg

298494

299−-- | Equality constraint on the underlying `PGType` of two columns.

495+-- | `SameTypes` is a constraint that proves two `ColumnsType`s have the same

496+-- length and the same `ColumnType`s.

497+type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType)

498+ :: Constraint where

499+ SameTypes '[] '[] = ()

500+ SameTypes (column0 ::: def0 :=> ty0 ': columns0) (column1 ::: def1 :=> ty1 ': columns1)

501+ = (ty0 ~ ty1, SameTypes columns0 columns1)

502+

300503class SamePGType

301504 (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where

302505instance ty0 ~ ty1 => SamePGType

@@ -305,63 +508,39 @@ instance ty0 ~ ty1 => SamePGType

305508

306509-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.

307510type 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

314511 AllNotNull '[] = ()

512+ AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns

315513

316514-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some

317515-- @NOT NULL@.

318516type family NotAllNull (columns :: ColumnsType) :: Constraint where

319− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()

320− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()

321− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()

322− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()

323− NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()

324− NotAllNull (_ ::: _ :=> 'NotNull _ ': _) = ()

325− NotAllNull (_ ::: _ :=> 'Null _ ': columns) = NotAllNull columns

326−

327−-- | `NullifyType` is an idempotent that nullifies a `NullityType`.

517+ NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()

518+ NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns

519+

520+-- | `NullifyType` is an idempotent that nullifies a `ColumnType`.

328521type family NullifyType (ty :: NullityType) :: NullityType where

329522 NullifyType ('Null ty) = 'Null ty

330523 NullifyType ('NotNull ty) = 'Null ty

331524

332−-- | `NullifyRow` is an idempotent that nullifies a `RowType`.

333−type family NullifyRow (columns :: RowType) :: RowType where

334− NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': columns) =

335− column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': column4 ::: NullifyType ty4 ': column5 ::: NullifyType ty5 ': NullifyRow columns

336− NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': columns) =

337− column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': column4 ::: NullifyType ty4 ': NullifyRow columns

338− NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': columns) =

339− column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': NullifyRow columns

340− NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': columns) =

341− column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': NullifyRow columns

342− NullifyRow (column ::: ty ': column1 ::: ty1 ': columns) =

343− column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': NullifyRow columns

344− NullifyRow (column ::: ty ': columns) =

345− column ::: NullifyType ty ': NullifyRow columns

346− NullifyRow '[] = '[]

347−

348−-- | `NullifyFrom` is an idempotent that nullifies a `FromType`

525+-- | `NullifyRelation` is an idempotent that nullifies a `ColumnsType`.

526+type family NullifyRelation (columns :: RelationType) :: RelationType where

527+ NullifyRelation '[] = '[]

528+ NullifyRelation (column ::: ty ': columns) =

529+ column ::: NullifyType ty ': NullifyRelation columns

530+

531+-- | `NullifyRelations` is an idempotent that nullifies a `RelationsType`

349532-- used to nullify the left or right hand side of an outer join

350533-- in a `Squeal.PostgreSQL.Query.FromClause`.

351−type family NullifyFrom (tables :: FromType) :: FromType where

352− NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': table5 ::: columns5 ': tables) =

353− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': table4 ::: NullifyRow columns5 ': table5 ::: NullifyRow columns4 ': NullifyFrom tables

354− NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': tables) =

355− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': table4 ::: NullifyRow columns4 ': NullifyFrom tables

356− NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': tables) =

357− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': NullifyFrom tables

358− NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': tables) =

359− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': NullifyFrom tables

360− NullifyFrom (table ::: columns ': table1 ::: columns1 ': tables) =

361− table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': NullifyFrom tables

362− NullifyFrom (table ::: columns ': tables) =

363− table ::: NullifyRow columns ': NullifyFrom tables

364− NullifyFrom '[] = '[]

534+type family NullifyRelations (tables :: RelationsType) :: RelationsType where

535+ NullifyRelations '[] = '[]

536+ NullifyRelations (table ::: columns ': tables) =

537+ table ::: NullifyRelation columns ': NullifyRelations tables

538+

539+-- | `Join` is simply promoted `++` and is used in @JOIN@s in

540+-- `Squeal.PostgreSQL.Query.FromClause`s.

541+type family Join xs ys where

542+ Join '[] ys = ys

543+ Join (x ': xs) ys = x ': Join xs ys

365544

366545-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in

367546-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@

@@ -371,100 +550,74 @@ type family Create alias x xs where

371550 Create alias x (alias ::: y ': xs) = TypeError

372551 ('Text "Create: alias "

373552 ':<>: 'ShowType alias

374− ':<>: 'Text "already exists")

553+ ':<>: 'Text "already in use")

375554 Create alias y (x ': xs) = x ': Create alias y xs

376555

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−

394556-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@

395557-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements

396558-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.

397559type 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

560+ Drop alias ((alias ::: x) ': xs) = xs

403561 Drop alias (x ': xs) = x ': Drop alias xs

404562

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−

437563-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@

438−-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable`

564+-- with the type `x` and is used in `Squeal.PostgreSQL.Definition.alterTable`

439565-- and `Squeal.PostgreSQL.Definition.alterColumn`.

440566type family Alter alias x xs where

441− Alter alias x '[] = TypeError

442− ('Text "Alter: alias "

443− ':<>: 'ShowType alias

444− ':<>: 'Text " does not exist" )

445567 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs

446568 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs

447569

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

570+-- type family AddConstraint constraint ty where

571+-- AddConstraint constraint (constraints :=> ty)

572+-- = AsSet (constraint ': constraints) :=> ty

573+

574+-- type family DeleteFromList (e :: elem) (list :: [elem]) where

575+-- DeleteFromList elem '[] = '[]

576+-- DeleteFromList elem (x ': xs) =

577+-- If (Cmp elem x == 'EQ) xs (x ': DeleteFromList elem xs)

578+

579+-- type family DropConstraint constraint ty where

580+-- DropConstraint constraint (constraints :=> ty)

581+-- = (AsSet (DeleteFromList constraint constraints)) :=> ty

452582

453583-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@

454584-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and

455585-- `Squeal.PostgreSQL.Definition.renameColumn`.

456586type family Rename alias0 alias1 xs where

457− Rename alias0 alias1 '[] = TypeError

458− ('Text "Rename: alias "

459− ':<>: 'ShowType alias0

460− ':<>: 'Text " does not exist" )

461587 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs

462588 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs

463589

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

590+-- | A `SameField` constraint is an equality constraint on a

591+-- `Generics.SOP.Type.Metadata.FieldInfo` and the column alias in a `:::` pair.

592+class SameField

593+ (fieldInfo :: Type.FieldInfo) (fieldty :: (Symbol,NullityType)) where

594+instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty)

595+

596+-- | A `SameFields` constraint proves that a

597+-- `Generics.SOP.Type.Metadata.DatatypeInfo` of a record type has the same

598+-- field names as the column AliasesOf of a `ColumnsType`.

599+type family SameFields

600+ (datatypeInfo :: Type.DatatypeInfo) (columns :: [(Symbol,ty)])

601+ :: Constraint where

602+ SameFields

603+ ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields])

604+ columns

605+ = SOP.AllZip SameField fields columns

606+ SameFields

607+ ('Type.Newtype _module _datatype ('Type.Record _constructor fields))

608+ columns

609+ = SOP.AllZip SameField fields columns

610+

611+class SameLabel

612+ (constrInfo :: Type.ConstructorInfo) (label :: Symbol) where

613+instance name ~ label => SameLabel ('Type.Constructor name) label

614+

615+type family SameLabels

616+ (datatypeInfo :: Type.DatatypeInfo) (labels :: [Symbol])

617+ :: Constraint where

618+ SameLabels

619+ ('Type.ADT _module _datatype constructors) labels

620+ = SOP.AllZip SameLabel constructors labels

468621

469622-- | Check if a `TableConstraint` involves a column

470623type family ConstraintInvolves column constraint where

@@ -482,115 +635,17 @@ type family DropIfConstraintsInvolve column constraints where

482635 (DropIfConstraintsInvolve column constraints)

483636 (alias ::: constraint ': DropIfConstraintsInvolve column constraints)

484637

485−-- | A `SchemumType` is a user-defined type, either a `Table`,

486−-- `View` or `Typedef`.

487638data SchemumType

488639 = Table TableType

489− | View RowType

640+ | View RelationType

490641 | Typedef PGType

491− | Index IndexType

492− | Function FunctionType

493− | Operator OperatorType

494− | UnsafeSchemum Symbol

495−

496−type FunctionType = ([NullityType], ReturnsType)

497−

498−data IndexType

499− = Btree

500− | Hash

501− | Gist

502− | Spgist

503− | Gin

504− | Brin

505−

506−data ReturnsType

507− = Returns NullityType

508− | ReturnsTable RowType

509−

510−data OperatorType

511− = BinaryOp NullityType NullityType NullityType

512− | LeftOp NullityType NullityType

513− | RightOp NullityType NullityType

514−

515−{- | The schema of a database consists of a list of aliased,

516−user-defined `SchemumType`s.

517−

518−>>> :{

519−type family Schema :: SchemaType where

520− Schema =

521− '[ "users" ::: 'Table (

522− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

523− '[ "id" ::: 'Def :=> 'NotNull 'PGint4

524− , "name" ::: 'NoDef :=> 'NotNull 'PGtext

525− ])

526− , "emails" ::: 'Table (

527− '[ "pk_emails" ::: 'PrimaryKey '["id"]

528− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]

529− ] :=>

530− '[ "id" ::: 'Def :=> 'NotNull 'PGint4

531− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4

532− , "email" ::: 'NoDef :=> 'Null 'PGtext

533− ])

534− ]

535−:}

536−-}

537−type SchemaType = [(Symbol,SchemumType)]

538642

539−{- |

540−A database contains one or more named schemas, which in turn contain tables.

541−The same object name can be used in different schemas without conflict;

542−for example, both schema1 and myschema can contain tables named mytable.

543−Unlike databases, schemas are not rigidly separated:

544−a user can access objects in any of the schemas in the database they are connected to,

545−if they have privileges to do so.

546−

547−There are several reasons why one might want to use schemas:

643+type SchemaType = [(Symbol,SchemumType)]

548644

549− * To allow many users to use one database without interfering with each other.

550− * To organize database objects into logical groups to make them more manageable.

551− * Third-party applications can be put into separate schemas

552− so they do not collide with the names of other objects.

553−-}

554−type SchemasType = [(Symbol,SchemaType)]

555−

556−-- | A type family to use for a single schema database.

557−type family Public (schema :: SchemaType) :: SchemasType

558− where Public schema = '["public" ::: schema]

559−

560−-- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas

561−-- the overloaded label, `fromLabel` is used for column references,

562−-- `label`s are used for enum terms. A `label` is called with

563−-- type application like `label @"beef"`.

564−class IsPGlabel (label :: Symbol) expr where label :: expr

565−instance label ~ label1

566− => IsPGlabel label (PGlabel label1) where label = PGlabel

567−instance labels ~ '[label]

568− => IsPGlabel label (NP PGlabel labels) where label = PGlabel :* Nil

569−-- | A `PGlabel` unit type with an `IsPGlabel` instance

570−data PGlabel (label :: Symbol) = PGlabel

571−instance KnownSymbol label => RenderSQL (PGlabel label) where

572− renderSQL _ = "\'" <> renderSymbol @label <> "\'"

573−instance All KnownSymbol labels => RenderSQL (NP PGlabel labels) where

574− renderSQL

575− = commaSeparated

576− . hcollapse

577− . hcmap (Proxy @KnownSymbol) (K . renderSQL)

578−

579−-- | Is a type a valid JSON key?

580−type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]

581−

582−-- | Is a type a valid JSON type?

583−type PGJsonType = '[ 'PGjson, 'PGjsonb ]

584−

585−-- | Utility class for `AllUnique` to provide nicer error messages.

586−class IsNotElem x isElem where

587−instance IsNotElem x 'False where

588−instance (TypeError ( 'Text "Cannot assign to "

589− ':<>: 'ShowType alias

590− ':<>: 'Text " more than once"))

591− => IsNotElem '(alias, a) 'True where

592−

593−-- | No elem of @xs@ appears more than once, in the context of assignment.

594−class AllUnique (xs :: [(Symbol, a)]) where

595−instance AllUnique '[] where

596−instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where

645+type family With

646+ (relations :: RelationsType)

647+ (schema :: SchemaType)

648+ :: SchemaType where

649+ With '[] schema = schema

650+ With (alias ::: rel ': rels) schema =

651+ alias ::: 'View rel ': With rels schema

squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+82−102

@@ -1,7 +1,7 @@

11{-|

22Module: Squeal.PostgreSQL.Transaction

33Description: Squeal transaction control language

4−Copyright: (c) Eitan Chatav, 2019

4+Copyright: (c) Eitan Chatav, 2017

55Maintainer: eitan@morphism.tech

66Stability: experimental

@@ -10,9 +10,14 @@ Squeal transaction control language.

1010

1111{-# LANGUAGE

1212 DataKinds

13+ , EmptyCase

1314 , FlexibleContexts

15+ , FlexibleInstances

1416 , LambdaCase

1517 , OverloadedStrings

18+ , MultiParamTypeClasses

19+ , ScopedTypeVariables

20+ , TypeFamilies

1621 , TypeInType

1722#-}

1823

@@ -20,114 +25,89 @@ module Squeal.PostgreSQL.Transaction

2025 ( -- * Transaction

2126 transactionally

2227 , transactionally_

23− , transactionallyRetry

24− , ephemerally

25− , ephemerally_

2628 , begin

2729 , commit

2830 , rollback

31+ , transactionallySchema

32+ , transactionallySchema_

2933 -- * Transaction Mode

3034 , TransactionMode (..)

3135 , defaultMode

3236 , longRunningMode

3337 , IsolationLevel (..)

38+ , renderIsolationLevel

3439 , AccessMode (..)

40+ , renderAccessMode

3541 , DeferrableMode (..)

42+ , renderDeferrableMode

3643 ) where

3744

38−import UnliftIO

45+import Control.Exception.Lifted

46+import Control.Monad.Base

47+import Control.Monad.Trans.Control

48+import Data.ByteString

49+import Data.Monoid

50+import Generics.SOP

51+

52+import qualified Database.PostgreSQL.LibPQ as LibPQ

3953

4054import Squeal.PostgreSQL.Manipulation

4155import Squeal.PostgreSQL.Render

4256import Squeal.PostgreSQL.PQ

57+import Squeal.PostgreSQL.Schema

4358

44−{- | Run a computation `transactionally`;

45−first `begin`,

46−then run the computation,

47−`onException` `rollback` and rethrow the exception,

48−otherwise `commit` and `return` the result.

49−-}

59+-- | Run a schema invariant computation `transactionally`.

5060transactionally

51− :: (MonadUnliftIO tx, MonadPQ schemas tx)

61+ :: (MonadBaseControl IO tx, MonadPQ schema tx)

5262 => TransactionMode

5363 -> tx x -- ^ run inside a transaction

5464 -> tx x

5565transactionally mode tx = mask $ \restore -> do

56− manipulate_ $ begin mode

57− result <- restore tx `onException` (manipulate_ rollback)

58− manipulate_ commit

66+ _ <- begin mode

67+ result <- restore tx `onException` rollback

68+ _ <- commit

5969 return result

6070

61−-- | Run a computation `transactionally_`, in `defaultMode`.

71+-- | Run a schema invariant computation `transactionally_` in `defaultMode`.

6272transactionally_

63− :: (MonadUnliftIO tx, MonadPQ schemas tx)

73+ :: (MonadBaseControl IO tx, MonadPQ schema tx)

6474 => tx x -- ^ run inside a transaction

6575 -> tx x

6676transactionally_ = transactionally defaultMode

6777

68−{- |

69−`transactionallyRetry` a computation;

70−

71−* first `begin`,

72−* then `try` the computation,

73− - if it raises a serialization failure then `rollback` and restart the transaction,

74− - if it raises any other exception then `rollback` and rethrow the exception,

75− - otherwise `commit` and `return` the result.

76−-}

77−transactionallyRetry

78− :: (MonadUnliftIO tx, MonadPQ schemas tx)

79− => TransactionMode

80− -> tx x -- ^ run inside a transaction

81− -> tx x

82−transactionallyRetry mode tx = mask $ \restore ->

83− loop . try $ do

84− x <- restore tx

85− manipulate_ commit

86− return x

87− where

88− loop attempt = do

89− manipulate_ $ begin mode

90− attempt >>= \case

91− Left (PQException (PQState _ (Just "40001") _)) -> do

92− manipulate_ rollback

93− loop attempt

94− Left err -> do

95− manipulate_ rollback

96− throwIO err

97− Right x -> return x

98−

99−{- | Run a computation `ephemerally`;

100−Like `transactionally` but always `rollback`, useful in testing.

101−-}

102−ephemerally

103− :: (MonadUnliftIO tx, MonadPQ schemas tx)

104− => TransactionMode

105− -> tx x -- ^ run inside an ephemeral transaction

106− -> tx x

107−ephemerally mode tx = mask $ \restore -> do

108− manipulate_ $ begin mode

109− result <- restore tx `onException` (manipulate_ rollback)

110− manipulate_ rollback

111− return result

112−

113−{- | Run a computation `ephemerally` in `defaultMode`. -}

114−ephemerally_

115− :: (MonadUnliftIO tx, MonadPQ schemas tx)

116− => tx x -- ^ run inside an ephemeral transaction

117− -> tx x

118−ephemerally_ = ephemerally defaultMode

119−

12078-- | @BEGIN@ a transaction.

121−begin :: TransactionMode -> Manipulation_ schemas () ()

122−begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode

79+begin :: MonadPQ schema tx => TransactionMode -> tx (K Result NilRelation)

80+begin mode = manipulate . UnsafeManipulation $

81+ "BEGIN" <+> renderTransactionMode mode <> ";"

12382

124−-- | @COMMIT@ a transaction.

125−commit :: Manipulation_ schemas () ()

126−commit = UnsafeManipulation "COMMIT"

83+-- | @COMMIT@ a schema invariant transaction.

84+commit :: MonadPQ schema tx => tx (K Result NilRelation)

85+commit = manipulate $ UnsafeManipulation "COMMIT;"

12786

128−-- | @ROLLBACK@ a transaction.

129−rollback :: Manipulation_ schemas () ()

130−rollback = UnsafeManipulation "ROLLBACK"

87+-- | @ROLLBACK@ a schema invariant transaction.

88+rollback :: MonadPQ schema tx => tx (K Result NilRelation)

89+rollback = manipulate $ UnsafeManipulation "ROLLBACK;"

90+

91+-- | Run a schema changing computation `transactionallySchema`.

92+transactionallySchema

93+ :: MonadBaseControl IO io

94+ => TransactionMode

95+ -> PQ schema0 schema1 io x

96+ -> PQ schema0 schema1 io x

97+transactionallySchema mode u = PQ $ \ conn -> mask $ \ restore -> do

98+ _ <- liftBase . LibPQ.exec (unK conn) $

99+ "BEGIN" <+> renderTransactionMode mode <> ";"

100+ x <- restore (unPQ u conn)

101+ `onException` (liftBase (LibPQ.exec (unK conn) "ROLLBACK"))

102+ _ <- liftBase $ LibPQ.exec (unK conn) "COMMIT"

103+ return x

104+

105+-- | Run a schema changing computation `transactionallySchema_` in `DefaultMode`.

106+transactionallySchema_

107+ :: MonadBaseControl IO io

108+ => PQ schema0 schema1 io x

109+ -> PQ schema0 schema1 io x

110+transactionallySchema_ = transactionallySchema defaultMode

131111

132112-- | The available transaction characteristics are the transaction `IsolationLevel`,

133113-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.

@@ -140,7 +120,7 @@ data TransactionMode = TransactionMode

140120-- | `TransactionMode` with a `Serializable` `IsolationLevel`,

141121-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.

142122defaultMode :: TransactionMode

143−defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable

123+defaultMode = TransactionMode Serializable ReadWrite NotDeferrable

144124

145125-- | `TransactionMode` with a `Serializable` `IsolationLevel`,

146126-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.

@@ -149,12 +129,12 @@ longRunningMode :: TransactionMode

149129longRunningMode = TransactionMode Serializable ReadOnly Deferrable

150130

151131-- | Render a `TransactionMode`.

152−instance RenderSQL TransactionMode where

153− renderSQL mode =

154− "ISOLATION LEVEL"

155− <+> renderSQL (isolationLevel mode)

156− <+> renderSQL (accessMode mode)

157− <+> renderSQL (deferrableMode mode)

132+renderTransactionMode :: TransactionMode -> ByteString

133+renderTransactionMode mode =

134+ "ISOLATION LEVEL"

135+ <+> renderIsolationLevel (isolationLevel mode)

136+ <+> renderAccessMode (accessMode mode)

137+ <+> renderDeferrableMode (deferrableMode mode)

158138

159139-- | The SQL standard defines four levels of transaction isolation.

160140-- The most strict is `Serializable`, which is defined by the standard in a paragraph

@@ -185,32 +165,32 @@ data IsolationLevel

185165 = Serializable

186166 -- ^ Dirty read is not possible.

187167 -- Nonrepeatable read is not possible.

188− -- Phantom read is not possible.

168+ -- Phantom read is not possible.

189169 -- Serialization anomaly is not possible.

190170 | RepeatableRead

191171 -- ^ Dirty read is not possible.

192172 -- Nonrepeatable read is not possible.

193− -- Phantom read is not possible.

173+ -- Phantom read is not possible.

194174 -- Serialization anomaly is possible.

195175 | ReadCommitted

196176 -- ^ Dirty read is not possible.

197177 -- Nonrepeatable read is possible.

198− -- Phantom read is possible.

178+ -- Phantom read is possible.

199179 -- Serialization anomaly is possible.

200180 | ReadUncommitted

201181 -- ^ Dirty read is not possible.

202182 -- Nonrepeatable read is possible.

203− -- Phantom read is possible.

183+ -- Phantom read is possible.

204184 -- Serialization anomaly is possible.

205185 deriving (Show, Eq)

206186

207187-- | Render an `IsolationLevel`.

208−instance RenderSQL IsolationLevel where

209− renderSQL = \case

210− Serializable -> "SERIALIZABLE"

211− ReadCommitted -> "READ COMMITTED"

212− ReadUncommitted -> "READ UNCOMMITTED"

213− RepeatableRead -> "REPEATABLE READ"

188+renderIsolationLevel :: IsolationLevel -> ByteString

189+renderIsolationLevel = \case

190+ Serializable -> "SERIALIZABLE"

191+ ReadCommitted -> "READ COMMITTED"

192+ ReadUncommitted -> "READ UNCOMMITTED"

193+ RepeatableRead -> "REPEATABLE READ"

214194

215195-- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`.

216196-- `ReadWrite` is the default. When a transaction is `ReadOnly`,

@@ -227,10 +207,10 @@ data AccessMode

227207 deriving (Show, Eq)

228208

229209-- | Render an `AccessMode`.

230−instance RenderSQL AccessMode where

231− renderSQL = \case

232− ReadWrite -> "READ WRITE"

233− ReadOnly -> "READ ONLY"

210+renderAccessMode :: AccessMode -> ByteString

211+renderAccessMode = \case

212+ ReadWrite -> "READ WRITE"

213+ ReadOnly -> "READ ONLY"

234214

235215-- | The `Deferrable` transaction property has no effect

236216-- unless the transaction is also `Serializable` and `ReadOnly`.

@@ -246,7 +226,7 @@ data DeferrableMode

246226 deriving (Show, Eq)

247227

248228-- | Render a `DeferrableMode`.

249−instance RenderSQL DeferrableMode where

250− renderSQL = \case

251− Deferrable -> "DEFERRABLE"

252− NotDeferrable -> "NOT DEFERRABLE"

229+renderDeferrableMode :: DeferrableMode -> ByteString

230+renderDeferrableMode = \case

231+ Deferrable -> "DEFERRABLE"

232+ NotDeferrable -> "NOT DEFERRABLE"

squeal-postgresql/test/Doc.hsdeleted−6

@@ -1,6 +0,0 @@

1−module Main (main) where

2−

3−import Test.DocTest

4−

5−main :: IO ()

6−main = doctest [ "-isrc", "src" ]

squeal-postgresql/test/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-presentation-raveline.mddeleted−794

@@ -1,794 +0,0 @@

1−# Squeal

2−

3−_A bridge between SQL and Haskell_

4−

5−by [@Raveline](https://github.com/raveline)

6−

7−---

8−

9−# Rationale

10−

11−Using `postgresql-simple` you have a typical "Trial, error, despair" workflow:

12−

13−- Write query manually or semi-automatically

14−

15−- Write haskell code using the query

16−

17−- Pray that the query syntax is correct

18−

19−- Pray that it returns what you want

20−

21−- Realize the inefficiency of prayer when it comes to SQL

22−

23−- Iterate till it works

24−

25−---

26−

27−![Can't take this anymore](http://gif.eraveline.eu/static/img/0x16e.gif)

28−

29−---

30−

31−# Use your best friend: GHC

32−

33−Squeal provides several eDSL to make your SQL typesafe:

34−

35−- Type level eDSL to express schema;

36−

37−- Value level eDSL to manipulate schema (plus migration, yeehaw !);

38−

39−- Type level eDSL to express queries;

40−

41−- Value level eDSL to perform queries

42−

43−However, it's not an ORM. There's no caching, lazy loading - you retain control over your memory. Also, joins - and mostly aggregation after joins - have to be handled manually.

44−

45−---

46−

47−# Part I. Schema & migration

48−

49−---

50−

51−# The Schema

52−

53−- The schema will be used to validate _everything_: migration, queries, etc.

54−

55−- A schema is mostly a collection of tables.

56−

57−- In this presentation, we will create a very basic database modeling a parliament. We will store _members of parliament_ and _parliamentary groups_.

58−

59−- A simple Schema to represent a Parliament could be:

60−

61−```haskell

62−type Schema = '[ "mp" ::: 'Table MemberOfParliament

63− , "groupp" ::: 'Table ParliamentGroup ]

64−```

65−

66−---

67−

68−> _note_ We need the `DataKinds` extension to be able to express heterogenous lists containing

69−> specific types like this one.

70−

71−> You can perfectly call your table "group" and not "groupp" even though it is a

72−> keyword in SQL - Squeal queries will be properly escaped.

73−

74−---

75−

76−# A small example

77−

78−```haskell

79−type ParliamentaryGroup =

80− '[ "pk_groupp" ::: 'PrimaryKey '["groupp_id"]]

81− :=>

82− '[ "groupp_id" ::: 'NoDef :=> 'NotNull 'PGuuid

83− , "name" ::: 'NoDef :=> 'NotNull 'PGtext

84− ]

85−```

86−

87−- That's a whole simple table defined in one go.

88−

89−- `:::` lets us define a column or a constraint.

90−

91−- `:=>` associates the constraints to the column.

92−

93−- Let's split constraints and column to study the syntax a bit more.

94−

95−---

96−

97−> _note_ We are using `:::` and `:=>` to quickly express associations when writing

98−> our schema. We need the `TypeOperators` extension.]

99−

100−---

101−

102−![What does this means ?!](http://gif.eraveline.eu/static/img/0x27e.gif)

103−

104−---

105−

106−# Defining a table

107−

108−```haskell

109−type MemberOfParliament =

110− '[ "pk_mp" ::: 'PrimaryKey '["mp_id"]

111− , "fk_mp_groupp" ::: 'ForeignKey '["mp_group"] "groupp" '["groupp_id"]

112− ] :=> MpCols

113−```

114−

115−- A table is a collection of constraints associated to a collection of columns.

116−

117−- We defined a table named "mp".

118−

119−- It has a constraint named "pk_mp", defining its primary key on column "mp_id".

120−

121−- It has a constraint named "fk_mp_groupp" defining a foreign key on column "mg_group", connected to the column "groupp_id" of table "groupp".

122−

123−- These constraints will be associated to the columns defined in `MpCols`.

124−

125−---

126−

127−# Defining columns

128−

129−```haskell

130−type MpCols =

131− '[ "mp_id" ::: 'NoDef :=> 'NotNull 'PGuuid

132− , "first_name" ::: 'NoDef :=> 'NotNull 'PGtext

133− , "last_name" ::: 'NoDef :=> 'NotNull 'PGtext

134− ]

135−```

136−

137−- A listing of column associate, for each element:

138−

139− * a name;

140−

141− * the mention of an eventual default value;

142−

143− * the nullability;

144−

145− * the type (obviously).

146−

147−---

148−

149−> _note_ GHC is already helping. If I named the "mp_id" column differently,

150−> GHC would yell because I promised a primary key constraint on a column named `mp_id`, so there must be one.]

151−

152−---

153−

154−# Implementating the schema

155−

156−- We will carry this schema type pretty much everywhere.

157−

158−- But before we play with this schema, we need to implement it.

159−

160−---

161−

162−```haskell

163−setup :: Definition '[] Schema

164−setup =

165− createTable #groupp

166− ( notNullable uuid `as` #groupp_id

167− :* notNullable text `as` #name)

168− ( primaryKey #groupp_id `as` #pk_groupp )

169− >>> createTable #mp

170− ( notNullable uuid `as` #mp_id

171− :* notNullable text `as` #first_name

172− :* notNullable text `as` #last_name

173− :* notNullable text `as` #mp_group)

174− ( primaryKey #mp_id `as` #pk_mp

175− :* foreignKey #mp_group #groupp #groupp_id

176− OnDeleteCascade OnUpdateCascade

177− `as` #fk_mp_groupp)

178−```

179−

180−---

181−

182−# Damn, that's verbose

183−

184−- Yes. But you need verbosity to get type safety.

185−

186−- On the plus side, it's fairly straightforward.

187−

188−- You use `:*` to compose the element of the heterogenous list of columns.

189−

190−- You use `>>>` to compose table creation.

191−

192−> _note_ The compiler will catch any mistype between Schema and

193−> definition; wrong nullability, wrong type, wrong name, etc.

194−

195−---

196−

197−> _note_ You'll also need `OverloadedLabels`, for naming stuff.

198−> This is mostly to avoid having to write manual proxies all

199−> the time and for convenience.

200−

201−---

202−

203−# Setting up the schema

204−

205−- Squeal comes with a very good migration manager, handling _upgrades_ AND

206−_downgrades_.

207−

208−- A migration is a simple type:

209−

210−```haskell

211−Migration io schema0 schema1

212−```

213−

214−- The first parameter is a BaseMonad (typically, IO).

215−

216−- The second parameter is "the current schema of your DB".

217−

218−- The last one is "what you will migrate to".

219−

220−- The `Definition` type used to define upgrade and downgrade functions use the

221− same logic (from one schema to the other).

222−

223−---

224−

225−# Defining our first migration

226−

227−- We have the setup bit, we need the teardown:

228−

229−```haskell

230−tearDown :: Definition Schema '[]

231−tearDown = dropTable #mp >>> dropTable #groupp

232−```

233−

234−> _note_ GHC will also detect the _proper_ order of what you typed in

235−> downgrade and upgrade should there be any conflict (with foreign keys).

236−

237−```haskell

238−initDB :: Migration IO '[] Schema

239−initDB =

240− Migration { name = "Schema creation"

241− , up = void $ define setup

242− , down = void $ define tearDown }

243−```

244−

245−---

246−

247−# Simple migrator example

248−

249−```haskell

250−main :: IO ()

251−main = do

252− printSQL setup

253− void $ withConnection connectionString $

254− migrateUp $ single initDB

255−```

256−

257−- We print the migration query; you can do this for all queries generated through Squeal.

258−

259−- We use `migrateUp` to perform the migration.

260−

261−- You can run several migration at the same time, to run only one use `single`.

262−

263−---

264−

265−![That was easy](http://gif.eraveline.eu/static/img/0x47f.gif)

266−

267−---

268−

269−# Part II. Insertions

270−

271−---

272−

273−# Manipulations & Queries

274−

275−Besides the specific case of migration, you will mostly perform:

276−

277−- `Manipulation` : inserting, updating and deleting data.

278−

279−- `Query` : fetching data.

280−

281−- Both types are parametric over the same things:

282−

283− * A schema

284−

285− * Input parameters

286−

287− * Output

288−

289−- Simplified, they look like this:

290−

291−```haskell

292−Manipulation schema params columns

293−

294−Query schema params columns

295−```

296−

297−

298−---

299−

300−# Our Haskell model

301−

302−```haskell

303−type Parliament = [Group]

304−

305−data Group =

306− Group { name :: Text

307− , members :: [MemberOfParliament] }

308−

309−data MemberOfParliament =

310− MemberOfParliament { firstName :: Text

311− , lastName :: Text }

312−```

313−

314−> _note_ We didn't use anything from Squeal.

315−> The model can be entirely separated from the persistence layer.

316−

317−---

318−

319−# Inserting a Parliamentary Group

320−

321−- A group is very simple: it's a uuid and a name. Let's define our params:

322−

323−```haskell

324−type GroupInsertionParams = '[ 'NotNull 'PGuuid

325− , 'NotNull 'PGtext ]

326−```

327−

328−- Params are not named, but they are indexed. You just need nullability and type.

329−

330−---

331−

332−```haskell

333−groupInsertion :: Manipulation Schema GroupInsertionParams '[]

334−groupInsertion =

335− insertRow_ #groupp ( Set (param @1) `as` #groupp_id

336− :* Set (param @2) `as` #name )

337−```

338−

339−---

340−

341−- `TypeApplication` lets us use the index of parameters (counting from 1).

342−

343−- Once again: all this is checked by the compiler. Wrong name, wrong type... you'll get a compile error.

344−

345−- `insertRow_` is a simplified version of `insertRow`. `insertRow` lets you express a `RETURNING` clause and the expected behaviour in case of conflict.

346−

347−---

348−

349−_Inserting a Member of Parliament_

350−# Doing an INSERT INTO ... SELECT

351−

352−- We could create a naive query that takes MP uuid, first name, last name and group uuid...

353−

354−---

355−

356−- But that's boring. So let's use the `INSERT INTO ... SELECT`.

357−

358−---

359−

360−- We will build a query that will return as constants our MP's uuid, first name and last name...

361−

362−---

363−

364−- ... and fetch the uuid of a group given the name of the group.

365−

366−---

367−

368−- There's a `insertQuery` utility function for that. All we have to do is write the `select` !

369−

370−```haskell

371−mpInsertion :: Manipulation Schema MpParams '[]

372−mpInsertion =

373− insertQuery_ #mp selectGroup -- we just have to write selectGroup !

374−```

375−

376−---

377−

378−_Inserting a Member of Parliament_

379−# The query type

380−

381−- A query looks just like a `Manipulation`:

382−

383−```haskell

384−Query schema params returns

385−```

386−

387−- Returns use a special syntax, that demands names, nullability and types:

388−

389−```haskell

390−type ExampleReturnType = '[ "some_column" ::: 'NotNull 'PGuuid

391− , "other_column" ::: 'Null 'PGtext ]

392−```

393−

394−- It is not the same as the column definition we used in the schema. That one also expects that you specify, for each column, an eventual default:

395−

396−```haskell

397−type ExampleSchemaCols =

398− '[ "some_column" ::: 'NoDef :=> 'NotNull 'PGuuid

399− , "other_column" ::: 'NoDef :=> 'Null 'PGtext ]

400−```

401−

402−---

403−

404−_Inserting a Member of Parliament_

405−# Don't rewrite column definitions

406−

407−- We want our return type to be "all columns from table MP expressed as return type".

408−

409−- But we cannot reuse our neat `MpCols` alias, since the type do not match as we've just seen.

410−

411−- Hopefully, there's a neat Type Family that will let you convert any table you defined to the type of the equivalent row: `TableToRow`.

412−

413−- We finally have the signature for our SELECT query.

414−

415−```haskell

416−selectGroup :: Query Schema MpParams (TableToRow MemberOfParliament)

417−```

418−

419−---

420−

421−_Inserting a Member of Parliament_

422−# Our final Select query

423−

424−- Our intermediate query looks like this:

425−

426−```haskell

427−selectGroup =

428− select

429− ( param @1 `as` #mp_id

430− :* param @2 `as` #first_name

431− :* param @3 `as` #last_name

432− :* #groupp ! #groupp_id `as` #mp_group

433− )

434− ( from (table #groupp)

435− & where_ ( #groupp ! #name .== param @4 )

436− )

437−```

438−

439−- The first three columns are constant defined through our params;

440−

441−- ... we alias the column name using `as`...

442−

443−- ... and when we need the result from the table we use the `#table ! #column` syntax.

444−

445−- We'll go back to the "from" block later.

446−

447−---

448−

449−# Dealing with the connection context

450−

451−- Queries are runned in a connection context:

452−

453− * When dealing with a single-connection context, use the type `PQ`.

454−

455− * When dealing with a pool of connection, use the type `PoolPQ`.

456−

457−- Or get rid of the context and use `mtl` style, with the typeclass `MonadPQ`.

458−

459−- We'll use that to demonstrate how to actually run our queries.

460−

461−---

462−

463−# Inserting a whole group

464−

465−```haskell

466−insertGroup :: (MonadPQ Schema m, MonadBaseControl IO m) => Group -> m ()

467−insertGroup g@(Group name _) = do

468− uuid' <- liftBase nextRandom

469− void $ manipulateParams groupInsertion (uuid', name)

470− insertMps g

471−```

472−

473−- Remember that we defined a group as a name and a list of MPs.

474−

475−- We are in `MonadBaseControl`, so we cannot use `liftIO`, we need `liftBase`.

476−

477−- To perform a simple insertion, use `manipulateParams`. It takes into parameter

478−instances of `ToParam`, but you will typically use tuples or Generic-SOP.

479−

480−---

481−

482−# Inserting a bunch of MPs

483−

484−```haskell

485−insertMps :: (MonadPQ Schema m, MonadBaseControl IO m) => Group -> m ()

486−insertMps (Group groupName mps) =

487− let tuplify Mp{..} = (, firstName, lastName, groupName) <$> nextRandom

488− params = traverse tuplify mps

489− in void $ liftBase params >>= traversePrepared mpInsertion

490−```

491−

492−- This time, we want to do a `preparedStatement`. We'll use `traversePrepare`

493−which behaves like `manipulateParams`, but expect a list of `ToParam`

494−instances.

495−

496−- We build our tuple manually again, mostly because we want to generate UUID on

497−the fly and we don't want to have them in our model.

498−

499−---

500−

501−# Inserting a whole parliament

502−

503−```haskell

504−insertParliament ::

505− (MonadPQ Schema m, MonadBaseControl IO m) => Parliament -> m ()

506−insertParliament = traverse_ insertGroup

507−```

508−

509−- That's simple enough !

510−

511−- If we want to be a bit safer, though, we can wrap this call in a

512−`transactionally_` function, which will put all that in a transaction.

513−

514−---

515−

516−![Very simple](https://media1.tenor.com/images/0188c63209aced59f1583e1ca94e509e/tenor.gif?itemid=3550689)

517−

518−

519−---

520−

521−# Part III. Selects

522−

523−---

524−

525−# Composable queries

526−

527−- Building basic queries is easy, and is well documented.

528−

529−- However, the real interest of a tool like Squeal is in DRYness, and the documentation is still lacking in "how-to" related to composability.

530−

531−- I'll build an example showing how column selections and from clause can be factorized.

532−

533−- We want to write two queries:

534−

535− * One to get all members of a specific group.

536−

537− * One to get all the parliament.

538−

539−---

540−

541−# Decomposing a `Query`

542−

543−- A query typically stars with `select` (variants are available).

544−

545−- It then takes:

546−

547− * A heterogenous list of fields with a scary signature;

548−

549− * A virtual table (the from clause and filter clauses), called a `TableExpression`.

550−

551−- And return fields. Ours will look like this:

552−

553−```haskell

554−type GroupRowResult =

555− '[ "groupName" ::: 'NotNull 'PGtext

556− , "firstName" ::: 'NotNull 'PGtext

557− , "lastName" ::: 'NotNull 'PGtext ]

558−```

559−

560−---

561−

562−# The Table Expression

563−

564−- It necessarily contains a `fromClause` (table, view or subquery, plus optional joins).

565−

566−- You can add where, groups, "HAVING" clause, order, etc.

567−

568−- `from` creates a basic `TableExpression` that you extend through various function to add clauses.

569−

570−- For our queries, we will share a common `FromClause`.

571−

572−---

573−

574−# The From Clause

575−

576−```

577−FromClause schema params from

578−```

579−

580−- We need Schema, input parameters and a `FromType` giving the available fields of the expression.

581−

582−- In our case, we'll join the table `mp` and the table `groupp`, meaning the `from` will be all fields of these tables.

583−

584−- We can use `TableToRow` to be more DRY:

585−

586−```haskell

587−type BaseParliamentSelection =

588− '[ "g" ::: TableToRow GroupCols

589− , "m" ::: TableToRow MpCols ]

590−```

591−

592−> _note_ We've also put everything with table aliases: "g" and "m".

593−

594−---

595−

596−# Writing our from clause

597−

598−```haskell

599−baseParliamentTables ::

600− FromClause Schema (param :: [NullityType]) BaseParliamentSelection

601−baseParliamentTables =

602− table

603− (#groupp `as` #g)

604− & innerJoin

605− (table (#mp `as` #m))

606− (#m ! #mp_group .== #g ! #groupp_id)

607−```

608−

609−- When picking "from" something, you need to specify the type with a function: `table` for a table, `view` for a view, etc.

610−

611−- All joins are available. `innerJoin` is the most basic one. It takes the joined table and the joining condition.

612−

613−- We have to specifiy the type of `param` (current limitation of the lib), even though _any_ params will be compatible with this, so we can plug `where` clauses depending on params should we need to !

614−

615−---

616−

617−# Typing the common selection

618−

619−- Both our querie will need the same fields. This has to be factorized too.

620−

621−- The scary signature of selection fields:

622−

623−```haskell

624−NP (Aliased (Expression schema from grouping params)) cols

625−```

626−

627−- `NP` is for heterogenous lists ("n-ary product").

628−

629−- `from` is the virtual table type, so our `BaseParliamentSelection`.

630−

631−- `grouping` is there to make a distinction between aggregated / unaggregated queries.

632−

633−- And finally, cols is the return type.

634−

635−---

636−

637−# Our common selection

638−

639−```haskell

640−groupSelection ::

641− NP (Aliased (Expression Schema BaseParliamentSelection 'Ungrouped param))

642− GroupRowResult

643−groupSelection =

644− #g ! #name `as` #groupName

645− :* #m ! #first_name `as` #firstName

646− :* #m ! #last_name `as` #lastName

647−```

648−

649−- I hope you like big signatures.

650−

651−- But it's what let GHC checks that all alias and columns are available.

652−

653−- And that you're returning what you really intend to return.

654−

655−---

656−

657−# Putting it all together

658−

659−```haskell

660−selectParliament :: Query Schema '[] GroupRowResult

661−selectParliament =

662− select groupSelection (from baseParliamentTables)

663−```

664−

665−```haskell

666−selectGroupMembers :: Query Schema '[ 'NotNull 'PGtext] GroupRowResult

667−selectGroupMembers =

668− select groupSelection

669− (from baseParliamentTables

670− & where_ (#g ! #name .== param @1))

671−```

672−

673−- That is fairly DRY. And _entirely typesafe_.

674−

675−---

676−

677−# Actually fetching the data

678−

679−- We'll build an intermediary datatype representing our rows.

680−

681−- We'll make it match our row.

682−

683−- And we'll add generic-SOP so that we can build them from query results.

684−

685−```haskell

686−type GroupRowResult =

687− '[ "groupName" ::: 'NotNull 'PGtext

688− , "firstName" ::: 'NotNull 'PGtext

689− , "lastName" ::: 'NotNull 'PGtext ]

690−```

691−

692−```haskell

693−data GroupRow =

694− GroupRow { groupName :: Text

695− , firstName :: Text

696− , lastName :: Text }

697− deriving (Generic)

698−

699−instance SOP.Generic GroupRow

700−instance SOP.HasDatatypeInfo GroupRow

701−```

702−

703−---

704−

705−# Aggregate result logic

706−

707−- We will get tabular, SQL data.

708−

709−- Our results will be `[GroupRow]`.

710−

711−- We'll build `Groups` from this:

712−

713−```haskell

714−buildGroup :: NE.NonEmpty GroupRow -> Group

715−buildGroup grs =

716− let buildMP (GroupRow _ f l) = Mp f l

717− name = groupName . NE.head $ grs

718− members = NE.toList (buildMP <$> grs)

719− in Group{..}

720−

721−rowToGroups :: [GroupRow] -> [Group]

722−rowToGroups =

723− let grouped = fmap NE.fromList . L.groupBy ((==) `on` groupName)

724− in fmap buildGroup . grouped

725−```

726−

727−---

728−

729−# Finally calling our queries

730−

731−- Query with params will use `runQueryParams`.

732−

733−- Query without params will use `runQuery`.

734−

735−- Result is inside a `MonadPQ` and of type `K` from generic-sop.

736−

737−- You get your actual result using `getRows`. Exemple:

738−

739−```haskell

740−getParliament :: (MonadPQ Schema m, MonadBaseControl IO m) => m [Group]

741−getParliament = do

742− res <- runQuery selectParliament

743− rows <- getRows res

744− pure $ rowToGroups rows

745−```

746−

747−- In real life of course you'll write:

748−

749−```haskell

750−getParliament =

751− rowToGroups <$> (runQuery selectParliament >>= getRows)

752−```

753−

754−---

755−

756−# Our query with params

757−

758−```haskell

759−getGroupMembers ::

760− (MonadPQ Schema m, MonadBaseControl IO m) => Text -> m (Maybe Group)

761−getGroupMembers =

762− listToMaybe . rowToGroups <$>

763− (runQueryParams selectGroupMembers (Only t) >>= getRows)

764−```

765−

766−- And that's it.

767−

768−---

769−

770−![Eazy](https://media.tenor.com/images/8fc7c4077efe11b4a3a3b9ae4e643e87/tenor.gif)

771−

772−---

773−

774−# Conclusion

775−

776−---

777−

778−# Pros & Cons

779−

780−- Not everything is included: some cool stuff like array_agg and window functions are not available yet.

781−

782−- But development is _very_ active. `IN` clauses were missing but were added in the 4.0 released recently.

783−

784−- It's bleeding edge. You need latest LTS to be comfortable and psql >= 9.5.

785−

786−- It's Postgres-only but I would say that's a feature. Multi-DB tools are even more complex.

787−

788−- The author & maintainer is <3.

789−

790−- Typesafe. 'nuff said.

791−

792−---

793−

794−# Thank you !

stack.yaml+1−6

@@ -1,8 +1,3 @@

1−resolver: nightly-2019-07-14

1+resolver: lts-11.1

22packages:

33- squeal-postgresql

4−

5−extra-deps:

6−- unliftio-pool-0.2.1.0

7−- github: morphismtech/free-categories

8− commit: c0e555fbefb5c21619e532264c4dfeac556d0630