60488bd · squeal · git.iko.soy

git.iko.soy/squeal

Merge pull request #33 from morphismtech/0.3

0.3

commit60488bd6a40c6e544d289941529358191d8edf7d authorEitan Chatav <eitan.chatav@gmail.com> dateTue 26 Jun 2018, 11:41 (8 years ago) parenta15c7b6 b3ccfb0

18 files changed+2557−1391

compare with dev

unifiedsplit

.circleci/config.yml+1−1

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

22jobs:

33 build:

44 docker:

5− - image: haskell:latest

5+ - image: haskell:8.2.2

66 - image: circleci/postgres:latest

77 environment:

88 POSTGRES_DB: exampledb

README.md+77−66

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

4444* linear, invertible migrations

4545* connection pools

4646* transactions

47+* views

48+* composite and enumerated types

4749

4850## installation

4951

@@ -62,24 +64,25 @@ Let's see an example!

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

6365features.

6466

65−```haskell

67+```Haskell

6668>>> :set -XDataKinds -XDeriveGeneric -XOverloadedLabels

6769>>> :set -XOverloadedStrings -XTypeApplications -XTypeOperators

6870```

6971

7072We'll need some imports.

7173

72−```haskell

74+```Haskell

7375>>> import Control.Monad (void)

7476>>> import Control.Monad.Base (liftBase)

7577>>> import Data.Int (Int32)

7678>>> import Data.Text (Text)

7779>>> import Squeal.PostgreSQL

80+>>> import Squeal.PostgreSQL.Render

7881```

7982

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

8184

82−```haskell

85+```Haskell

8386>>> import qualified Generics.SOP as SOP

8487>>> import qualified GHC.Generics as GHC

8588```

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

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

8891we use `DataKinds` and `TypeOperators`.

8992

90−```haskell

93+```Haskell

9194>>> :{

9295type 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− ]

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

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

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

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

100+ ])

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

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

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

104+ ] :=>

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

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

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

108+ ])

109+ ]

107110:}

108111```

109112

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

113+Notice the use of type operators.

114+

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

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

117+operator.

118+

119+`:=>` is used to pair `TableConstraints` with a `ColumnsType`,

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

114−yielding a `ColumnType`.

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

115122

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

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

124+Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`

125+has two type parameters, corresponding to the schema

126+before being run and the schema after. We can compose definitions using `>>>`.

127+Here and in the rest of our commands we make use of overloaded

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

122129

123−```haskell

130+```Haskell

124131>>> :{

125132let

126133 setup :: Definition '[] Schema

127134 setup =

128− createTable #users

129− ( serial `As` #id :*

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

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

132− createTable #emails

133− ( serial `As` #id :*

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

135− text `As` #email :* Nil )

136− ( primaryKey (Column #id :* Nil) `As` #pk_emails :*

137− foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)

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

135+ createTable #users

136+ ( serial `As` #id :*

137+ (text & notNullable) `As` #name :* Nil )

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

139+ createTable #emails

140+ ( serial `As` #id :*

141+ (int & notNullable) `As` #user_id :*

142+ (text & nullable) `As` #email :* Nil )

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

144+ foreignKey #user_id #users #id

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

139146:}

140147```

141148

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

149+We can easily see the generated SQL is unsurprising looking.

143150

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

151+```Haskell

152+>>> printSQL setup

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

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

147155```

148156

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

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

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

159+primary and foreign keys, making them somewhat complex. Our `teardown`

152160`Definition` is simpler.

153161

154−```haskell

162+```Haskell

155163>>> :{

156164let

157165 teardown :: Definition Schema '[]

158166 teardown = dropTable #emails >>> dropTable #users

159167:}

160−>>> renderDefinition teardown

161−"DROP TABLE emails; DROP TABLE users;"

168+

169+>>> printSQL teardown

170+DROP TABLE "emails";

171+DROP TABLE "users";

162172```

163173

164174Next, 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

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

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

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

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

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

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

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

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

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

174183of our inserts.

175184

176−```haskell

185+```Haskell

177186>>> :{

178187let

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

@@ -181,6 +190,7 @@ let

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

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

183192:}

193+

184194>>> :{

185195let

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

@@ -190,10 +200,11 @@ let

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

191201 OnConflictDoNothing (Returning Nil)

192202:}

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

203+

204+>>> printSQL insertUser

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

206+>>> printSQL insertEmail

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

197208```

198209

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

@@ -201,7 +212,7 @@ interested in the ids here, just the usernames and email addresses. We

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

202213`Manipulation` with the same kind of type parameters.

203214

204−```haskell

215+```Haskell

205216>>> :{

206217let

207218 getUsers :: Query Schema '[]

@@ -213,8 +224,9 @@ let

213224 & innerJoin (table (#emails `As` #e))

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

215226:}

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

227+

228+>>> printSQL getUsers

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

218230```

219231

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

@@ -223,7 +235,7 @@ for users. We give the type `Generics.SOP.Generic` and

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

224236`User` type match the column names of `getUsers`.

225237

226−```haskell

238+```Haskell

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

228240>>> instance SOP.Generic User

229241>>> instance SOP.HasDatatypeInfo User

@@ -231,7 +243,7 @@ we receive when we run `getUsers`. Notice that the record fields of the

231243

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

233245

234−```haskell

246+```Haskell

235247>>> :{

236248let

237249 users :: [User]

@@ -251,7 +263,7 @@ the changing schema information through by using the indexed `PQ` monad

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

252264`MonadPQ` functionality.

253265

254−```haskell

266+```Haskell

255267>>> :{

256268let

257269 session :: PQ Schema Schema IO ()

@@ -262,12 +274,11 @@ let

262274 usersResult <- runQuery getUsers

263275 usersRows <- getRows usersResult

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

277+in

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

279+ define setup

280+ & pqThen session

281+ & pqThen (define teardown)

271282:}

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

273284```

RELEASE NOTES.md+240

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

11## RELEASE NOTES

3+### Version 0.3 - June 26, 2018

5+Version 0.3 of Squeal adds views as well as composite and enumerated types to Squeal.

6+To support these features, a new kind `SchemumType` was added.

8+```Haskell

9+data SchemumType

10+ = Table TableType

11+ | View RelationType

12+ | Typedef PGType

13+```

14+

15+As a consequence, you will have to update your schema definitions like so:

16+

17+```Haskell

18+-- Squeal 0.2

19+type Schema =

20+ '[ "users" :::

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

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

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

24+ ]

25+ ]

26+

27+-- Squeal 0.3

28+type Schema =

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

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

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

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

33+ ])

34+ ]

35+```

36+

37+**Views**

38+

39+You can now create, drop, and query views.

40+

41+```Haskell

42+>>> :{

43+type ABC =

44+ ('[] :: TableConstraints) :=>

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

46+ , "b" ::: 'NoDef :=> 'Null 'PGint4

47+ , "c" ::: 'NoDef :=> 'Null 'PGint4

48+ ]

49+type BC =

50+ '[ "b" ::: 'Null 'PGint4

51+ , "c" ::: 'Null 'PGint4

52+ ]

53+:}

54+

55+>>> :{

56+let

57+ definition :: Definition '["abc" ::: 'Table ABC ] '["abc" ::: 'Table ABC, "bc" ::: 'View BC]

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

59+in printSQL definition

60+:}

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

62+

63+>>> :{

64+let

65+ definition :: Definition '["abc" ::: 'Table ABC, "bc" ::: 'View BC] '["abc" ::: 'Table ABC]

66+ definition = dropView #bc

67+in printSQL definition

68+:}

69+DROP VIEW "bc";

70+

71+>>> :{

72+let

73+ query :: Query '["abc" ::: 'Table ABC, "bc" ::: 'View BC] '[] BC

74+ query = selectStar (from (view #bc))

75+in printSQL query

76+:}

77+SELECT * FROM "bc" AS "bc"

78+```

79+

80+**Enumerated Types**

81+

82+PostgreSQL has a powerful type system. It even allows for user defined types.

83+For instance, you can define enumerated types which are data types that comprise

84+a static, ordered set of values. They are equivalent to Haskell algebraic data

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

86+or a set of status values for a piece of data.

87+

88+Enumerated types are created using the `createTypeEnum` command, for example:

89+

90+```Haskell

91+>>> :{

92+let

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

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

95+:}

96+>>> printSQL definition

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

98+```

99+

100+Enumerated types can also be generated from a Haskell algbraic data type with nullary constructors, for example:

101+

102+```Haskell

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

104+>>> instance SOP.Generic Schwarma

105+>>> instance SOP.HasDatatypeInfo Schwarma

106+

107+>>> :kind! EnumFrom Schwarma

108+EnumFrom Schwarma :: PGType

109+= 'PGenum '["Beef", "Lamb", "Chicken"]

110+

111+>>> :{

112+let

113+ definition :: Definition '[] '["schwarma" ::: 'Typedef (EnumFrom Schwarma)]

114+ definition = createTypeEnumFrom @Schwarma #schwarma

115+:}

116+>>> printSQL definition

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

118+```

119+

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

121+of the `IsPGlabel` typeclass.

122+

123+```Haskell

124+>>> :{

125+let

126+ expression :: Expression sch rels grp params ('NotNull (EnumFrom Schwarma))

127+ expression = label @"Chicken"

128+in printSQL expression

129+:}

130+'Chicken'

131+```

132+

133+**Composite Types**

134+

135+In addition to enum types, you can define composite types.

136+A composite type represents the structure of a row or record;

137+it is essentially just a list of field names and their data types.

138+

139+

140+`createTypeComposite` creates a composite type. The composite type is

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

142+

143+```Haskell

144+>>> :{

145+let

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

147+ definition = createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil)

148+:}

149+>>> printSQL definition

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

151+```

152+

153+Composite types are almost equivalent to Haskell record types.

154+However, because of the potential presence of `NULL`

155+all the record fields must be `Maybe`s of basic types.

156+Composite types can be generated from a Haskell record type, for example:

157+

158+```Haskell

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

160+>>> instance SOP.Generic Complex

161+>>> instance SOP.HasDatatypeInfo Complex

162+

163+>>> :kind! CompositeFrom Complex

164+CompositeFrom Complex :: PGType

165+= 'PGcomposite '['("real", 'PGfloat8), '("imaginary", 'PGfloat8)]

166+

167+>>> :{

168+let

169+ definition :: Definition '[] '["complex" ::: 'Typedef (CompositeFrom Complex)]

170+ definition = createTypeCompositeFrom @Complex #complex

171+in printSQL definition

172+:}

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

174+```

175+

176+A row constructor is an expression that builds a row value

177+(also called a composite value) using values for its member fields.

178+

179+```Haskell

180+>>> :{

181+let

182+ i :: Expression '[] '[] 'Ungrouped '[] ('NotNull (CompositeFrom Complex))

183+ i = row (0 `As` #real :* 1 `As` #imaginary :* Nil)

184+:}

185+>>> printSQL i

186+ROW(0, 1)

187+```

188+

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

190+

191+```Haskell

192+>>> :{

193+let

194+ expr :: Expression '[] '[] 'Ungrouped '[] ('Null 'PGfloat8)

195+ expr = i & #imaginary

196+in printSQL expr

197+:}

198+(ROW(0, 1)).imaginary

199+```

200+

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

202+And they can be dropped.

203+

204+```Haskell

205+>>> :{

206+let

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

208+ definition = dropType #mood

209+:}

210+>>> printSQL definition

211+DROP TYPE "mood";

212+```

213+

214+**Additional Changes**

215+

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

217+This makes it possible to clean up some unfortunately messy Squeal 0.2 definitions.

218+

219+```Haskell

220+-- Squeal 0.2

221+>>> unique (Column #a :* Column #b :* Nil)

222+

223+-- Squeal 0.3

224+>>> unique (#a :* #b :* Nil)

225+```

226+

227+Squeal 0.3 also adds `IsLabel` instances for `Aliased` expressions and tables as well as

228+heterogeneous lists, allowing for some more economy of code.

229+

230+```Haskell

231+-- Squeal 0.2 (or 0.3)

232+>>> select (#a `As` #a :* Nil) (from (table (#t `As` #t)))

233+

234+-- Squeal 0.3

235+>>> select #a (from (table #t))

236+```

237+

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

239+

240+The above changes required major and minor changes to Squeal DSL functions.

241+Please consult the documentation.

242+

3243### Version 0.2.1 - April 7, 2018

4244

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

squeal-postgresql/exe/Example.hs+11−11

@@ -25,36 +25,36 @@ import qualified Generics.SOP as SOP

2525import qualified GHC.Generics as GHC

2626

2727type Schema =

28− '[ "users" :::

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

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

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

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

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

33− ]

34− , "emails" :::

33+ ])

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

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

3636 , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]

3737 ] :=>

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

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

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

41− ]

41+ ])

4242 ]

4343

4444setup :: Definition '[] Schema

4545setup =

4646 createTable #users

4747 ( serial `As` #id :*

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

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

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

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

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

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

5151 >>>

5252 createTable #emails

5353 ( serial `As` #id :*

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

55− text `As` #email :* Nil )

56− ( primaryKey (Column #id :* Nil) `As` #pk_emails :*

57− foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)

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

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

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

57+ foreignKey #user_id #users #id

5858 OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )

5959

6060teardown :: Definition Schema '[]

squeal-postgresql/squeal-postgresql.cabal+6−4

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

11name: squeal-postgresql

2−version: 0.2.1.0

2+version: 0.3.0.0

33synopsis: Squeal PostgreSQL Library

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

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

@@ -34,11 +34,13 @@ library

3434 Squeal.PostgreSQL.Schema

3535 Squeal.PostgreSQL.Transaction

3636 default-language: Haskell2010

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

37+ ghc-options: -Wall -Werror

3838 build-depends:

3939 aeson >= 1.2.4.0

4040 , base >= 4.10.1.0 && < 5.0

41+ , binary-parser >= 0.5.5

4142 , bytestring >= 0.10.8.2

43+ , bytestring-strict-builder >= 0.4.5

4244 , deepseq >= 1.4.3.0

4345 , generics-sop >= 0.3.2.0

4446 , lifted-base >= 0.2.3.12

@@ -61,7 +63,7 @@ test-suite squeal-postgresql-doctest

6163 default-language: Haskell2010

6264 type: exitcode-stdio-1.0

6365 hs-source-dirs: test

64− ghc-options: -Wall

66+ ghc-options: -Wall -Werror

6567 main-is: DocTest.hs

6668 build-depends:

6769 base >= 4.10.0.0

@@ -70,7 +72,7 @@ test-suite squeal-postgresql-doctest

7072executable squeal-postgresql-example

7173 default-language: Haskell2010

7274 hs-source-dirs: exe

73− ghc-options: -Wall

75+ ghc-options: -Wall -Werror

7476 main-is: Example.hs

7577 build-depends:

7678 base >= 4.10.0.0 && < 5.0

squeal-postgresql/src/Squeal/PostgreSQL.hs+207−202

@@ -1,206 +1,211 @@

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

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

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

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

38−-- ]

39−-- , "emails" :::

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 (Column #id :* Nil) `As` #pk_users :* Nil ) >>>

71−-- createTable #emails

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

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

74−-- text `As` #email :* Nil )

75−-- ( primaryKey (Column #id :* Nil) `As` #pk_emails :*

76−-- foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)

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

1+{-|

2+Module: Squeal.PostgreSQL

3+Description: Squeel export module

4+Copyright: (c) Eitan Chatav, 2017

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

2037

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

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

16+

17+We'll need some imports.

18+

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

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

21+>>> import Data.Int (Int32)

22+>>> import Data.Text (Text)

23+>>> import Squeal.PostgreSQL

24+>>> import Squeal.PostgreSQL.Render

25+

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

27+

28+>>> import qualified Generics.SOP as SOP

29+>>> import qualified GHC.Generics as GHC

30+

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

32+we use @DataKinds@ and @TypeOperators@.

33+

34+>>> :{

35+type Schema =

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

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

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

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

40+ ])

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

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

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

44+ ] :=>

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

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

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

48+ ])

49+ ]

50+:}

51+

52+Notice the use of type operators.

53+

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

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

56+operator.

57+

58+`:=>` is used to pair `TableConstraints` with a `ColumnsType`,

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

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

61+

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

63+Squeal, a `Definition` like `createTable`, `alterTable` or `dropTable`

64+has two type parameters, corresponding to the schema

65+before being run and the schema after. We can compose definitions using `>>>`.

66+Here and in the rest of our commands we make use of overloaded

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

68+

69+>>> :{

70+let

71+ setup :: Definition '[] Schema

72+ setup =

73+ createTable #users

74+ ( serial `As` #id :*

75+ (text & notNullable) `As` #name :* Nil )

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

77+ createTable #emails

78+ ( serial `As` #id :*

79+ (int & notNullable) `As` #user_id :*

80+ (text & nullable) `As` #email :* Nil )

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

82+ foreignKey #user_id #users #id

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

84+:}

85+

86+We can easily see the generated SQL is unsurprising looking.

87+

88+>>> printSQL setup

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

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

91+

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

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

94+primary and foreign keys, making them somewhat complex. Our @teardown@

95+`Definition` is simpler.

96+

97+>>> :{

98+let

99+ teardown :: Definition Schema '[]

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

101+:}

102+

103+>>> printSQL teardown

104+DROP TABLE "emails";

105+DROP TABLE "users";

106+

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

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

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

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

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

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

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

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

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

116+of our inserts.

117+

118+>>> :{

119+let

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

121+ insertUser = insertRow #users

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

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

124+:}

125+

126+>>> :{

127+let

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

129+ insertEmail = insertRow #emails

130+ ( Default `As` #id :*

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

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

133+ OnConflictDoNothing (Returning Nil)

134+:}

135+

136+>>> printSQL insertUser

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

138+>>> printSQL insertEmail

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

140+

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

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

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

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

145+

146+>>> :{

147+let

148+ getUsers :: Query Schema '[]

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

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

151+ getUsers = select

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

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

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

155+ (#u ! #id .== #e ! #user_id)) )

156+:}

157+

158+>>> printSQL getUsers

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

160+

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

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

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

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

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

166+

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

168+>>> instance SOP.Generic User

169+>>> instance SOP.HasDatatypeInfo User

170+

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

172+

173+>>> :{

174+let

175+ users :: [User]

176+ users =

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

178+ , User "Bob" Nothing

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

180+ ]

181+:}

182+

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

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

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

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

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

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

189+`MonadPQ` functionality.

190+

191+>>> :{

192+let

193+ session :: PQ Schema Schema IO ()

194+ session = do

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

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

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

198+ usersResult <- runQuery getUsers

199+ usersRows <- getRows usersResult

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

201+in

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

203+ define setup

204+ & pqThen session

205+ & pqThen (define teardown)

206+:}

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

208+-}

204209module Squeal.PostgreSQL

205210 ( module Squeal.PostgreSQL.Binary

206211 , module Squeal.PostgreSQL.Definition

squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+271−13

@@ -5,13 +5,131 @@ Copyright: (c) Eitan Chatav, 2017

55Maintainer: eitan@morphism.tech

66Stability: experimental

8−Binary encoding and decoding between Haskell and PostgreSQL types.

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

10+Instances are governed by the `Generic` and `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+>>> import Data.Int (Int16)

15+>>> import Data.Text (Text)

16+

17+>>> data Row = Row { col1 :: Int16, col2 :: Text } deriving (Eq, GHC.Generic)

18+>>> instance Generic Row

19+>>> instance HasDatatypeInfo Row

20+

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

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

23+>>> import Squeal.PostgreSQL

24+

25+>>> :{

26+let

27+ query :: Query '[]

28+ '[ 'NotNull 'PGint2, 'NotNull 'PGtext]

29+ '["col1" ::: 'NotNull 'PGint2, "col2" ::: 'NotNull 'PGtext]

30+ query = values_ (param @1 `As` #col1 :* param @2 `As` #col2 :* Nil)

31+:}

32+

33+>>> :{

34+let

35+ roundtrip :: IO ()

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

37+ result <- runQueryParams query (2 :: Int16, "hi" :: Text)

38+ Just row <- firstRow result

39+ liftBase . print $ row == Row 2 "hi"

40+:}

41+

42+>>> roundtrip

43+True

44+

45+In addition to being able to encode and decode basic Haskell types like `Int16` and `Text`,

46+Squeal permits you to encode and decode Haskell types which are equivalent to

47+Postgres enumerated and composite types.

48+

49+Enumerated (enum) types are data types that comprise a static, ordered set of values.

50+They are equivalent to Haskell algebraic data types whose constructors are nullary.

51+An example of an enum type might be the days of the week,

52+or a set of status values for a piece of data.

53+

54+>>> data Schwarma = Beef | Lamb | Chicken deriving (Show, GHC.Generic)

55+>>> instance Generic Schwarma

56+>>> instance HasDatatypeInfo Schwarma

57+

58+A composite type represents the structure of a row or record;

59+it is essentially just a list of field names and their data types. They are almost

60+equivalent to Haskell record types. However, because of the potential presence of @NULL@

61+all the record fields must be `Maybe`s of basic types.

62+

63+>>> data Person = Person {name :: Maybe Text, age :: Maybe Int32} deriving (Show, GHC.Generic)

64+>>> instance Generic Person

65+>>> instance HasDatatypeInfo Person

66+

67+We can create the equivalent Postgres types directly from their Haskell types.

68+

69+>>> :{

70+type Schema =

71+ '[ "schwarma" ::: 'Typedef (EnumFrom Schwarma)

72+ , "person" ::: 'Typedef (CompositeFrom Person)

73+ ]

74+:}

75+

76+>>> :{

77+let

78+ setup :: Definition '[] Schema

79+ setup =

80+ createTypeEnumFrom @Schwarma #schwarma >>>

81+ createTypeCompositeFrom @Person #person

82+:}

83+

84+Then we can perform roundtrip queries;

85+

86+>>> :{

87+let

88+ querySchwarma :: Query Schema

89+ '[ 'NotNull (EnumFrom Schwarma)]

90+ '["fromOnly" ::: 'NotNull (EnumFrom Schwarma)]

91+ querySchwarma = values_ (parameter @1 #schwarma `As` #fromOnly :* Nil)

92+:}

93+

94+>>> :{

95+let

96+ queryPerson :: Query Schema

97+ '[ 'NotNull (CompositeFrom Person)]

98+ '["fromOnly" ::: 'NotNull (CompositeFrom Person)]

99+ queryPerson = values_ (parameter @1 #person `As` #fromOnly :* Nil)

100+:}

101+

102+And finally drop the types.

103+

104+>>> :{

105+let

106+ teardown :: Definition Schema '[]

107+ teardown = dropType #schwarma >>> dropType #person

108+:}

109+

110+Now let's run it.

111+

112+>>> :{

113+let

114+ session = do

115+ result1 <- runQueryParams querySchwarma (Only Chicken)

116+ Just (Only schwarma) <- firstRow result1

117+ liftBase $ print (schwarma :: Schwarma)

118+ result2 <- runQueryParams queryPerson (Only (Person (Just "Faisal") (Just 24)))

119+ Just (Only person) <- firstRow result2

120+ liftBase $ print (person :: Person)

121+in

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

123+ define setup

124+ & pqThen session

125+ & pqThen (define teardown)

126+:}

127+Chicken

128+Person {name = Just "Faisal", age = Just 24}

9129-}

10130

11131{-# LANGUAGE

12− ConstraintKinds

13− , DataKinds

14− , DefaultSignatures

132+ AllowAmbiguousTypes

15133 , DeriveFoldable

16134 , DeriveFunctor

17135 , DeriveGeneric

@@ -20,11 +138,9 @@ Binary encoding and decoding between Haskell and PostgreSQL types.

20138 , FlexibleInstances

21139 , GADTs

22140 , LambdaCase

23− , KindSignatures

24141 , MultiParamTypeClasses

25142 , ScopedTypeVariables

26143 , TypeApplications

27− , TypeFamilies

28144 , TypeInType

29145 , TypeOperators

30146 , UndecidableInstances

@@ -43,9 +159,12 @@ module Squeal.PostgreSQL.Binary

43159 , Only (..)

44160 ) where

45161

162+import BinaryParser

163+import ByteString.StrictBuilder

46164import Data.Aeson hiding (Null)

47165import Data.Int

48166import Data.Kind

167+import Data.Monoid hiding (All)

49168import Data.Scientific

50169import Data.Time

51170import Data.UUID.Types

@@ -56,7 +175,7 @@ import GHC.TypeLits

56175import Network.IP.Addr

57176

58177import qualified Data.ByteString.Lazy as Lazy

59−import qualified Data.ByteString as Strict hiding (unpack)

178+import qualified Data.ByteString as Strict hiding (pack, unpack)

60179import qualified Data.Text.Lazy as Lazy

61180import qualified Data.Text as Strict

62181import qualified Data.Vector as Vector

@@ -119,9 +238,83 @@ instance (HasOid pg, ToParam x pg)

119238 => ToParam (Vector (Maybe x)) ('PGvararray pg) where

120239 toParam = K . Encoding.nullableArray_vector

121240 (oid @pg) (unK . toParam @x @pg)

241+instance

242+ ( IsEnumType x

243+ , HasDatatypeInfo x

244+ , LabelsFrom x ~ labels

245+ ) => ToParam x ('PGenum labels) where

246+ toParam =

247+ let

248+ gshowConstructor :: NP ConstructorInfo xss -> SOP I xss -> String

249+ gshowConstructor Nil _ = ""

250+ gshowConstructor (constructor :* _) (SOP (Z _)) =

251+ constructorName constructor

252+ gshowConstructor (_ :* constructors) (SOP (S xs)) =

253+ gshowConstructor constructors (SOP xs)

254+ in

255+ K . Encoding.text_strict

256+ . Strict.pack

257+ . gshowConstructor (constructorInfo (datatypeInfo (Proxy @x)))

258+ . from

259+instance

260+ ( SListI fields

261+ , MapMaybes xs

262+ , IsProductType x (Maybes xs)

263+ , AllZip ToAliasedParam xs fields

264+ , FieldNamesFrom x ~ AliasesOf fields

265+ , All HasAliasedOid fields

266+ ) => ToParam x ('PGcomposite fields) where

267+ toParam =

268+ let

269+

270+ encoders = htrans (Proxy @ToAliasedParam) toAliasedParam

271+

272+ composite

273+ :: All HasAliasedOid row

274+ => NP (K (Maybe Encoding.Encoding)) row

275+ -> K Encoding.Encoding ('PGcomposite row)

276+ composite fields = K $

277+ -- <number of fields: 4 bytes>

278+ -- [for each field]

279+ -- <OID of field's type: sizeof(Oid) bytes>

280+ -- [if value is NULL]

281+ -- <-1: 4 bytes>

282+ -- [else]

283+ -- <length of value: 4 bytes>

284+ -- <value: <length> bytes>

285+ -- [end if]

286+ -- [end for]

287+ int32BE (fromIntegral (lengthSList (Proxy @xs))) <>

288+ let

289+ each

290+ :: HasAliasedOid field

291+ => K (Maybe Encoding.Encoding) field

292+ -> Encoding.Encoding

293+ each (K field :: K (Maybe Encoding.Encoding) field) =

294+ word32BE (aliasedOid @field)

295+ <> case field of

296+ Nothing -> int64BE (-1)

297+ Just value ->

298+ int32BE (fromIntegral (builderLength value))

299+ <> value

300+ in

301+ hcfoldMap (Proxy @HasAliasedOid) each fields

302+

303+ in

304+ composite . encoders . unMaybes . unZ . unSOP . from

122305

123−-- | A `ToColumnParam` constraint lifts the `ToParam` encoding

124−-- of a `Type` to a `ColumnType`, encoding `Maybe`s to `Null`s. You should

306+class HasAliasedOid (field :: (Symbol, PGType)) where aliasedOid :: Word32

307+instance HasOid ty => HasAliasedOid (alias ::: ty) where aliasedOid = oid @ty

308+

309+class ToAliasedParam (x :: Type) (field :: (Symbol, PGType)) where

310+ toAliasedParam :: Maybe x -> K (Maybe Encoding.Encoding) field

311+instance ToParam x ty => ToAliasedParam x (alias ::: ty) where

312+ toAliasedParam = \case

313+ Nothing -> K Nothing

314+ Just x -> K . Just . unK $ toParam @x @ty x

315+

316+-- | A `ToColumnParam` constraint lifts the `ToParam` encoding

317+-- of a `Type` to a `NullityType`, encoding `Maybe`s to `Null`s. You should

125318-- not define instances of `ToColumnParam`, just use the provided instances.

126319class ToColumnParam (x :: Type) (ty :: NullityType) where

127320 -- | >>> toColumnParam @Int16 @('NotNull 'PGint2) 0

@@ -201,9 +394,74 @@ instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where

201394 fromValue _ = Decoding.array

202395 (Decoding.dimensionArray Vector.replicateM

203396 (Decoding.nullableValueArray (fromValue (Proxy @pg))))

397+instance

398+ ( IsEnumType y

399+ , HasDatatypeInfo y

400+ , LabelsFrom y ~ labels

401+ ) => FromValue ('PGenum labels) y where

402+ fromValue _ =

403+ let

404+ greadConstructor

405+ :: All ((~) '[]) xss

406+ => NP ConstructorInfo xss

407+ -> String

408+ -> Maybe (SOP I xss)

409+ greadConstructor Nil _ = Nothing

410+ greadConstructor (constructor :* constructors) name =

411+ if name == constructorName constructor

412+ then Just (SOP (Z Nil))

413+ else SOP . S . unSOP <$> greadConstructor constructors name

414+ in

415+ Decoding.enum

416+ $ fmap to

417+ . greadConstructor (constructorInfo (datatypeInfo (Proxy @y)))

418+ . Strict.unpack

419+

420+instance

421+ ( SListI fields

422+ , MapMaybes ys

423+ , IsProductType y (Maybes ys)

424+ , AllZip FromAliasedValue fields ys

425+ , FieldNamesFrom y ~ AliasesOf fields

426+ ) => FromValue ('PGcomposite fields) y where

427+ fromValue =

428+ let

429+ decoders

430+ :: forall pgs zs proxy

431+ . AllZip FromAliasedValue pgs zs

432+ => proxy ('PGcomposite pgs)

433+ -> NP Decoding.Value zs

434+ decoders _ = htrans (Proxy @FromAliasedValue) fromAliasedValue

435+ (hpure Proxy :: NP Proxy pgs)

436+

437+ composite fields = do

438+ -- <number of fields: 4 bytes>

439+ -- [for each field]

440+ -- <OID of field's type: sizeof(Oid) bytes>

441+ -- [if value is NULL]

442+ -- <-1: 4 bytes>

443+ -- [else]

444+ -- <length of value: 4 bytes>

445+ -- <value: <length> bytes>

446+ -- [end if]

447+ -- [end for]

448+ unitOfSize 4

449+ let

450+ each field = do

451+ unitOfSize 4

452+ len <- sized 4 Decoding.int

453+ if len == -1 then return Nothing else Just <$> sized len field

454+ htraverse' each fields

455+

456+ in fmap (to . SOP . Z . maybes) . composite . decoders

457+

458+class FromAliasedValue (pg :: (Symbol,PGType)) (y :: Type) where

459+ fromAliasedValue :: proxy pg -> Decoding.Value y

460+instance FromValue pg y => FromAliasedValue (alias ::: pg) y where

461+ fromAliasedValue _ = fromValue (Proxy @pg)

204462

205463-- | A `FromColumnValue` constraint lifts the `FromValue` parser

206−-- to a decoding of a @(Symbol, ColumnType)@ to a `Type`,

464+-- to a decoding of a @(Symbol, NullityType)@ to a `Type`,

207465-- decoding `Null`s to `Maybe`s. You should not define instances for

208466-- `FromColumnValue`, just use the provided instances.

209467class FromColumnValue (colty :: (Symbol,NullityType)) (y :: Type) where

@@ -220,10 +478,10 @@ instance FromValue pg y

220478 => FromColumnValue (column ::: ('NotNull pg)) y where

221479 fromColumnValue = \case

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

223− K (Just bytes) ->

481+ K (Just bs) ->

224482 let

225483 errOrValue =

226− Decoding.valueParser (fromValue @pg @y Proxy) bytes

484+ Decoding.valueParser (fromValue @pg @y Proxy) bs

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

228486 in

229487 either err id errOrValue

@@ -257,7 +515,7 @@ instance

257515 ( SListI results

258516 , IsProductType y ys

259517 , AllZip FromColumnValue results ys

260− , SameFields (DatatypeInfoOf y) results

518+ , FieldNamesFrom y ~ AliasesOf results

261519 ) => FromRow results y where

262520 fromRow

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

squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+569−277

@@ -9,35 +9,33 @@ Squeal data definition language.

99-}

1010

1111{-# LANGUAGE

12− ConstraintKinds

13− , DataKinds

14− , DeriveDataTypeable

12+ AllowAmbiguousTypes

13+ , ConstraintKinds

1514 , DeriveGeneric

1615 , FlexibleContexts

1716 , FlexibleInstances

1817 , GADTs

1918 , GeneralizedNewtypeDeriving

20− , KindSignatures

2119 , LambdaCase

2220 , MultiParamTypeClasses

2321 , OverloadedStrings

2422 , RankNTypes

2523 , ScopedTypeVariables

26− , StandaloneDeriving

2724 , TypeApplications

2825 , TypeInType

2926 , TypeOperators

27+ , UndecidableSuperClasses

3028#-}

3129

3230module Squeal.PostgreSQL.Definition

33− ( -- * Definition

31+ ( -- * Definition

3432 Definition (UnsafeDefinition, renderDefinition)

3533 , (>>>)

36− -- * Create

34+ -- * Tables

35+ -- ** Create

3736 , createTable

3837 , createTableIfNotExists

3938 , TableConstraintExpression (..)

40− , Column (..)

4139 , check

4240 , unique

4341 , primaryKey

@@ -47,9 +45,9 @@ module Squeal.PostgreSQL.Definition

4745 , renderOnDeleteClause

4846 , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)

4947 , renderOnUpdateClause

50− -- * Drop

48+ -- ** Drop

5149 , dropTable

52− -- * Alter

50+ -- ** Alter

5351 , alterTable

5452 , alterTableRename

5553 , AlterTable (UnsafeAlterTable, renderAlterTable)

@@ -65,6 +63,26 @@ module Squeal.PostgreSQL.Definition

6563 , setNotNull

6664 , dropNotNull

6765 , alterType

66+ -- * Views

67+ , createView

68+ , dropView

69+ -- * Types

70+ , createTypeEnum

71+ , createTypeEnumFrom

72+ , createTypeComposite

73+ , createTypeCompositeFrom

74+ , dropType

75+ -- * Columns

76+ , ColumnTypeExpression (..)

77+ , nullable

78+ , notNullable

79+ , default_

80+ , serial2

81+ , smallserial

82+ , serial4

83+ , serial

84+ , serial8

85+ , bigserial

6886 ) where

6987

7088import Control.Category

@@ -78,6 +96,7 @@ import qualified Generics.SOP as SOP

7896import qualified GHC.Generics as GHC

7997

8098import Squeal.PostgreSQL.Expression

99+import Squeal.PostgreSQL.Query

81100import Squeal.PostgreSQL.Render

82101import Squeal.PostgreSQL.Schema

83102

@@ -89,67 +108,76 @@ statements

89108-- database, like a `createTable`, `dropTable`, or `alterTable` command.

90109-- `Definition`s may be composed using the `>>>` operator.

91110newtype Definition

92− (schema0 :: TablesType)

93− (schema1 :: TablesType)

111+ (schema0 :: SchemaType)

112+ (schema1 :: SchemaType)

94113 = UnsafeDefinition { renderDefinition :: ByteString }

95114 deriving (GHC.Generic,Show,Eq,Ord,NFData)

96115

116+instance RenderSQL (Definition schema0 schema1) where

117+ renderSQL = renderDefinition

118+

97119instance Category Definition where

98120 id = UnsafeDefinition ";"

99121 ddl1 . ddl0 = UnsafeDefinition $

100− renderDefinition ddl0 <+> renderDefinition ddl1

122+ renderDefinition ddl0 <> "\n" <> renderDefinition ddl1

101123

102124{-----------------------------------------

103125CREATE statements

104126-----------------------------------------}

105127

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

107−--

108−-- >>> :set -XOverloadedLabels

109−-- >>> :{

110−-- renderDefinition $

111−-- createTable #tab (int `As` #a :* real `As` #b :* Nil) Nil

112−-- :}

113−-- "CREATE TABLE \"tab\" (\"a\" int, \"b\" real);"

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

129+

130+>>> :set -XOverloadedLabels

131+>>> :{

132+printSQL $

133+ createTable #tab ((int & nullable) `As` #a :* (real & nullable) `As` #b :* Nil) Nil

134+:}

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

136+-}

114137createTable

115138 :: ( KnownSymbol table

116139 , columns ~ (col ': cols)

117140 , SOP.SListI columns

118− , SOP.SListI constraints )

141+ , SOP.SListI constraints

142+ , schema1 ~ Create table ('Table (constraints :=> columns)) schema0 )

119143 => Alias table -- ^ the name of the table to add

120− -> NP (Aliased TypeExpression) columns

144+ -> NP (Aliased (ColumnTypeExpression schema0)) columns

121145 -- ^ the names and datatype of each column

122− -> NP (Aliased (TableConstraintExpression schema columns)) constraints

146+ -> NP (Aliased (TableConstraintExpression schema1 table)) constraints

123147 -- ^ constraints that must hold for the table

124− -> Definition schema (Create table (constraints :=> columns) schema)

125−createTable table columns constraints = UnsafeDefinition $

126− "CREATE TABLE" <+> renderCreation table columns constraints

127−

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

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

130−-- `createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in the `Category` `Definition`.

131−--

132−-- >>> :set -XOverloadedLabels -XTypeApplications

133−-- >>> type Table = '[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGfloat4]

134−-- >>> type Schema = '["tab" ::: Table]

135−-- >>> :{

136−-- renderDefinition

137−-- (createTableIfNotExists #tab (int `As` #a :* real `As` #b :* Nil) Nil :: Definition Schema Schema)

138−-- :}

139−-- "CREATE TABLE IF NOT EXISTS \"tab\" (\"a\" int, \"b\" real);"

148+ -> Definition schema0 schema1

149+createTable tab columns constraints = UnsafeDefinition $

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

151+

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

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

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

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

156+

157+>>> :set -XOverloadedLabels -XTypeApplications

158+>>> type Table = '[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGfloat4]

159+>>> type Schema = '["tab" ::: 'Table Table]

160+>>> :{

161+let

162+ setup :: Definition Schema Schema

163+ setup = createTableIfNotExists #tab ((int & nullable) `As` #a :* (real & nullable) `As` #b :* Nil) Nil

164+in printSQL setup

165+:}

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

167+-}

140168createTableIfNotExists

141− :: ( Has table schema (constraints :=> columns)

169+ :: ( Has table schema ('Table (constraints :=> columns))

142170 , SOP.SListI columns

143171 , SOP.SListI constraints )

144172 => Alias table -- ^ the name of the table to add

145− -> NP (Aliased TypeExpression) columns

173+ -> NP (Aliased (ColumnTypeExpression schema)) columns

146174 -- ^ the names and datatype of each column

147− -> NP (Aliased (TableConstraintExpression schema columns)) constraints

175+ -> NP (Aliased (TableConstraintExpression schema table)) constraints

148176 -- ^ constraints that must hold for the table

149177 -> Definition schema schema

150−createTableIfNotExists table columns constraints = UnsafeDefinition $

178+createTableIfNotExists tab columns constraints = UnsafeDefinition $

151179 "CREATE TABLE IF NOT EXISTS"

152− <+> renderCreation table columns constraints

180+ <+> renderCreation tab columns constraints

153181

154182-- helper function for `createTable` and `createTableIfNotExists`

155183renderCreation

@@ -157,12 +185,12 @@ renderCreation

157185 , SOP.SListI columns

158186 , SOP.SListI constraints )

159187 => Alias table -- ^ the name of the table to add

160− -> NP (Aliased TypeExpression) columns

188+ -> NP (Aliased (ColumnTypeExpression schema0)) columns

161189 -- ^ the names and datatype of each column

162− -> NP (Aliased (TableConstraintExpression schema columns)) constraints

190+ -> NP (Aliased (TableConstraintExpression schema1 table)) constraints

163191 -- ^ constraints that must hold for the table

164192 -> ByteString

165−renderCreation table columns constraints = renderAlias table

193+renderCreation tab columns constraints = renderAlias tab

166194 <+> parenthesized

167195 ( renderCommaSeparated renderColumnDef columns

168196 <> ( case constraints of

@@ -171,9 +199,9 @@ renderCreation table columns constraints = renderAlias table

171199 renderCommaSeparated renderConstraint constraints ) )

172200 <> ";"

173201 where

174− renderColumnDef :: Aliased TypeExpression x -> ByteString

202+ renderColumnDef :: Aliased (ColumnTypeExpression schema) x -> ByteString

175203 renderColumnDef (ty `As` column) =

176− renderAlias column <+> renderTypeExpression ty

204+ renderAlias column <+> renderColumnTypeExpression ty

177205 renderConstraint

178206 :: Aliased (TableConstraintExpression schema columns) constraint

179207 -> ByteString

@@ -193,156 +221,226 @@ renderCreation table columns constraints = renderAlias table

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

194222-- even if the value came from the default value definition.

195223newtype TableConstraintExpression

196− (schema :: TablesType)

197− (columns :: ColumnsType)

224+ (schema :: SchemaType)

225+ (table :: Symbol)

198226 (tableConstraint :: TableConstraint)

199227 = UnsafeTableConstraintExpression

200228 { renderTableConstraintExpression :: ByteString }

201229 deriving (GHC.Generic,Show,Eq,Ord,NFData)

202230

203−-- | @Column columns column@ is a witness that `column` is in `columns`.

204−data Column

205− (columns :: ColumnsType)

206− (column :: (Symbol,ColumnType))

207− where

208− Column

209− :: Has column columns ty

210− => Alias column

211− -> Column columns (column ::: ty)

212−

213−-- | Render a `Column`.

214−renderColumn :: Column columns column -> ByteString

215−renderColumn (Column column) = renderAlias column

216−

217−-- | A `check` constraint is the most generic `TableConstraint` type.

218−-- It allows you to specify that the value in a certain column must satisfy

219−-- a Boolean (truth-value) expression.

220−--

221−-- >>> :{

222−-- renderDefinition $

223−-- createTable #tab

224−-- ( (int & notNull) `As` #a :*

225−-- (int & notNull) `As` #b :* Nil )

226−-- ( check (Column #a :* Column #b :* Nil) (#a .> #b) `As` #inequality :* Nil )

227−-- :}

228−-- "CREATE TABLE \"tab\" (\"a\" int NOT NULL, \"b\" int NOT NULL, CONSTRAINT \"inequality\" CHECK ((\"a\" > \"b\")));"

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

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

233+a Boolean (truth-value) expression.

234+

235+>>> :{

236+type Schema = '[

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

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

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

240+ ])]

241+:}

242+

243+>>> :{

244+let

245+ definition :: Definition '[] Schema

246+ definition = createTable #tab

247+ ( (int & notNullable) `As` #a :*

248+ (int & notNullable) `As` #b :* Nil )

249+ ( check (#a :* #b :* Nil) (#a .> #b) `As` #inequality :* Nil )

250+:}

251+

252+>>> printSQL definition

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

254+-}

229255check

230− :: NP (Column columns) subcolumns

231− -> Condition '[table ::: ColumnsToRelation subcolumns] 'Ungrouped '[]

232− -- ^ condition to check

233− -> TableConstraintExpression schema columns ('Check (AliasesOf subcolumns))

256+ :: ( Has alias schema ('Table table)

257+ , HasAll aliases (TableToRelation table) subcolumns )

258+ => NP Alias aliases

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

260+ -> (forall tab. Condition schema '[tab ::: subcolumns] 'Ungrouped '[])

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

262+ -> TableConstraintExpression schema alias ('Check aliases)

234263check _cols condition = UnsafeTableConstraintExpression $

235264 "CHECK" <+> parenthesized (renderExpression condition)

236265

237−-- | A `unique` constraint ensure that the data contained in a column,

238−-- or a group of columns, is unique among all the rows in the table.

239−--

240−-- >>> :{

241−-- renderDefinition $

242−-- createTable #tab

243−-- ( int `As` #a :*

244−-- int `As` #b :* Nil )

245−-- ( unique (Column #a :* Column #b :* Nil) `As` #uq_a_b :* Nil )

246−-- :}

247−-- "CREATE TABLE \"tab\" (\"a\" int, \"b\" int, CONSTRAINT \"uq_a_b\" UNIQUE (\"a\", \"b\"));"

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

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

268+

269+>>> :{

270+type Schema = '[

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

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

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

274+ ])]

275+:}

276+

277+>>> :{

278+let

279+ definition :: Definition '[] Schema

280+ definition = createTable #tab

281+ ( (int & nullable) `As` #a :*

282+ (int & nullable) `As` #b :* Nil )

283+ ( unique (#a :* #b :* Nil) `As` #uq_a_b :* Nil )

284+:}

285+

286+>>> printSQL definition

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

288+-}

248289unique

249− :: SOP.SListI subcolumns

250− => NP (Column columns) subcolumns

251− -- ^ unique column or group of columns

252− -> TableConstraintExpression schema columns ('Unique (AliasesOf subcolumns))

290+ :: ( Has alias schema ('Table table)

291+ , HasAll aliases (TableToRelation table) subcolumns )

292+ => NP Alias aliases

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

294+ -> TableConstraintExpression schema alias ('Unique aliases)

253295unique columns = UnsafeTableConstraintExpression $

254− "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)

255−

256−-- | A `primaryKey` constraint indicates that a column, or group of columns,

257−-- can be used as a unique identifier for rows in the table.

258−-- This requires that the values be both unique and not null.

259−--

260−-- >>> :{

261−-- renderDefinition $

262−-- createTable #tab

263−-- ( serial `As` #id :*

264−-- (text & notNull) `As` #name :* Nil )

265−-- ( primaryKey (Column #id :* Nil) `As` #pk_id :* Nil )

266−-- :}

267−-- "CREATE TABLE \"tab\" (\"id\" serial, \"name\" text NOT NULL, CONSTRAINT \"pk_id\" PRIMARY KEY (\"id\"));"

296+ "UNIQUE" <+> parenthesized (commaSeparated (renderAliases columns))

297+

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

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

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

301+

302+>>> :{

303+type Schema = '[

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

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

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

307+ ])]

308+:}

309+

310+>>> :{

311+let

312+ definition :: Definition '[] Schema

313+ definition = createTable #tab

314+ ( serial `As` #id :*

315+ (text & notNullable) `As` #name :* Nil )

316+ ( primaryKey #id `As` #pk_id :* Nil )

317+:}

318+

319+>>> printSQL definition

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

321+-}

268322primaryKey

269− :: (SOP.SListI subcolumns, AllNotNull subcolumns)

270− => NP (Column columns) subcolumns

271− -- ^ identifying column or group of columns

272− -> TableConstraintExpression schema columns ('PrimaryKey (AliasesOf subcolumns))

323+ :: ( Has alias schema ('Table table)

324+ , HasAll aliases (TableToColumns table) subcolumns

325+ , AllNotNull subcolumns )

326+ => NP Alias aliases

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

328+ -> TableConstraintExpression schema alias ('PrimaryKey aliases)

273329primaryKey columns = UnsafeTableConstraintExpression $

274− "PRIMARY KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)

275−

276−-- | A `foreignKey` specifies that the values in a column

277−-- (or a group of columns) must match the values appearing in some row of

278−-- another table. We say this maintains the referential integrity

279−-- between two related tables.

280−--

281−-- >>> :{

282−-- type Schema =

283−-- '[ "users" :::

284−-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

285−-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4

286−-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext

287−-- ]

288−-- , "emails" :::

289−-- '[ "pk_emails" ::: 'PrimaryKey '["id"]

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

291−-- ] :=>

292−-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4

293−-- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4

294−-- , "email" ::: 'NoDef :=> 'Null 'PGtext

295−-- ]

296−-- ]

297−-- :}

298−--

299−-- >>> :{

300−-- let

301−-- setup :: Definition '[] Schema

302−-- setup =

303−-- createTable #users

304−-- ( serial `As` #id :*

305−-- (text & notNull) `As` #name :* Nil )

306−-- ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil ) >>>

307−-- createTable #emails

308−-- ( serial `As` #id :*

309−-- (int & notNull) `As` #user_id :*

310−-- text `As` #email :* Nil )

311−-- ( primaryKey (Column #id :* Nil) `As` #pk_emails :*

312−-- foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)

313−-- OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )

314−-- in renderDefinition setup

315−-- :}

316−-- "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);"

330+ "PRIMARY KEY" <+> parenthesized (commaSeparated (renderAliases columns))

331+

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

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

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

335+between two related tables.

336+

337+>>> :{

338+type Schema =

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

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

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

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

343+ ])

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

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

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

347+ ] :=>

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

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

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

351+ ])

352+ ]

353+:}

354+

355+>>> :{

356+let

357+ setup :: Definition '[] Schema

358+ setup =

359+ createTable #users

360+ ( serial `As` #id :*

361+ (text & notNullable) `As` #name :* Nil )

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

363+ createTable #emails

364+ ( serial `As` #id :*

365+ (int & notNullable) `As` #user_id :*

366+ (text & nullable) `As` #email :* Nil )

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

368+ foreignKey #user_id #users #id

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

370+in printSQL setup

371+:}

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

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

374+

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

376+

377+>>> :{

378+type Schema =

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

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

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

382+ ] :=>

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

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

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

386+ ])

387+ ]

388+:}

389+

390+>>> :{

391+let

392+ setup :: Definition '[] Schema

393+ setup =

394+ createTable #employees

395+ ( serial `As` #id :*

396+ (text & notNullable) `As` #name :*

397+ (integer & nullable) `As` #employer_id :* Nil )

398+ ( primaryKey #id `As` #employees_pk :*

399+ foreignKey #employer_id #employees #id

400+ OnDeleteCascade OnUpdateCascade `As` #employees_employer_fk :* Nil )

401+in printSQL setup

402+:}

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

404+-}

317405foreignKey

318− :: ForeignKeyed schema table reftable subcolumns refsubcolumns

319− => NP (Column columns) subcolumns

406+ :: (ForeignKeyed schema child parent

407+ table reftable

408+ columns refcolumns

409+ constraints cols

410+ reftys tys )

411+ => NP Alias columns

320412 -- ^ column or columns in the table

321− -> Alias table

413+ -> Alias parent

322414 -- ^ reference table

323− -> NP (Column (TableToColumns reftable)) refsubcolumns

415+ -> NP Alias refcolumns

324416 -- ^ reference column or columns in the reference table

325417 -> OnDeleteClause

326418 -- ^ what to do when reference is deleted

327419 -> OnUpdateClause

328420 -- ^ what to do when reference is updated

329− -> TableConstraintExpression schema columns

330− ('ForeignKey (AliasesOf subcolumns) table (AliasesOf refsubcolumns))

331−foreignKey columns reftable refcolumns onDelete onUpdate =

332− UnsafeTableConstraintExpression $

333− "FOREIGN KEY" <+> parenthesized (renderCommaSeparated renderColumn columns)

334− <+> "REFERENCES" <+> renderAlias reftable

335− <+> parenthesized (renderCommaSeparated renderColumn refcolumns)

336− <+> renderOnDeleteClause onDelete

337− <+> renderOnUpdateClause onUpdate

338−

339−-- | A type synonym for constraints on a table with a foreign key.

340−type ForeignKeyed schema table reftable subcolumns refsubcolumns

341− = ( Has table schema reftable

342− , SameTypes subcolumns refsubcolumns

343− , AllNotNull subcolumns

344− , SOP.SListI subcolumns

345− , SOP.SListI refsubcolumns )

421+ -> TableConstraintExpression schema child

422+ ('ForeignKey columns parent refcolumns)

423+foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $

424+ "FOREIGN KEY" <+> parenthesized (commaSeparated (renderAliases keys))

425+ <+> "REFERENCES" <+> renderAlias parent

426+ <+> parenthesized (commaSeparated (renderAliases refs))

427+ <+> renderOnDeleteClause ondel

428+ <+> renderOnUpdateClause onupd

429+

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

431+type ForeignKeyed schema

432+ child parent

433+ table reftable

434+ columns refcolumns

435+ constraints cols

436+ reftys tys =

437+ ( Has child schema ('Table table)

438+ , Has parent schema ('Table reftable)

439+ , HasAll columns (TableToColumns table) tys

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

441+ , HasAll refcolumns cols reftys

442+ , SOP.AllZip SamePGType tys reftys

443+ , Uniquely refcolumns constraints )

346444

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

348446data OnDeleteClause

@@ -389,13 +487,19 @@ DROP statements

389487

390488-- | `dropTable` removes a table from the schema.

391489--

392−-- >>> renderDefinition $ dropTable #muh_table

393−-- "DROP TABLE \"muh_table\";"

490+-- >>> :{

491+-- let

492+-- definition :: Definition '["muh_table" ::: 'Table t] '[]

493+-- definition = dropTable #muh_table

494+-- :}

495+--

496+-- >>> printSQL definition

497+-- DROP TABLE "muh_table";

394498dropTable

395− :: KnownSymbol table

499+ :: Has table schema ('Table t)

396500 => Alias table -- ^ table to remove

397501 -> Definition schema (Drop table schema)

398−dropTable table = UnsafeDefinition $ "DROP TABLE" <+> renderAlias table <> ";"

502+dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderAlias tab <> ";"

399503

400504{-----------------------------------------

401505ALTER statements

@@ -403,20 +507,20 @@ ALTER statements

403507

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

405509alterTable

406− :: Has tab schema table0

407− => Alias tab -- ^ table to alter

408− -> AlterTable schema table0 table1 -- ^ alteration to perform

409− -> Definition schema (Alter tab schema table1)

410−alterTable table alteration = UnsafeDefinition $

510+ :: KnownSymbol alias

511+ => Alias alias -- ^ table to alter

512+ -> AlterTable alias table schema -- ^ alteration to perform

513+ -> Definition schema (Alter alias ('Table table) schema)

514+alterTable tab alteration = UnsafeDefinition $

411515 "ALTER TABLE"

412− <+> renderAlias table

516+ <+> renderAlias tab

413517 <+> renderAlterTable alteration

414518 <> ";"

415519

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

417521--

418−-- >>> renderDefinition $ alterTableRename #foo #bar

419−-- "ALTER TABLE \"foo\" RENAME TO \"bar\";"

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

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

420524alterTableRename

421525 :: (KnownSymbol table0, KnownSymbol table1)

422526 => Alias table0 -- ^ table to rename

@@ -429,9 +533,9 @@ alterTableRename table0 table1 = UnsafeDefinition $

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

430534-- of a table.

431535newtype AlterTable

432− (schema :: TablesType)

433− (table0 :: TableType)

434− (table1 :: TableType) =

536+ (alias :: Symbol)

537+ (table :: TableType)

538+ (schema :: SchemaType) =

435539 UnsafeAlterTable {renderAlterTable :: ByteString}

436540 deriving (GHC.Generic,Show,Eq,Ord,NFData)

437541

@@ -440,19 +544,21 @@ newtype AlterTable

440544-- >>> :{

441545-- let

442546-- definition :: Definition

443−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]

444−-- '["tab" ::: '["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]

445−-- definition = alterTable #tab (addConstraint #positive (check (Column #col :* Nil) (#col .> 0)))

446−-- in renderDefinition definition

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

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

549+-- definition = alterTable #tab (addConstraint #positive (check (#col :* Nil) (#col .> 0)))

550+-- in printSQL definition

447551-- :}

448−-- "ALTER TABLE \"tab\" ADD CONSTRAINT \"positive\" CHECK ((\"col\" > 0));"

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

449553addConstraint

450− :: KnownSymbol alias

554+ :: ( KnownSymbol alias

555+ , Has tab schema ('Table table0)

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

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

451558 => Alias alias

452− -> TableConstraintExpression schema columns constraint

559+ -> TableConstraintExpression schema tab constraint

453560 -- ^ constraint to add

454− -> AlterTable schema (constraints :=> columns)

455− (Create alias constraint constraints :=> columns)

561+ -> AlterTable tab table1 schema

456562addConstraint alias constraint = UnsafeAlterTable $

457563 "ADD" <+> "CONSTRAINT" <+> renderAlias alias

458564 <+> renderTableConstraintExpression constraint

@@ -462,19 +568,20 @@ addConstraint alias constraint = UnsafeAlterTable $

462568-- >>> :{

463569-- let

464570-- definition :: Definition

465−-- '["tab" ::: '["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]

466−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]

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

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

467573-- definition = alterTable #tab (dropConstraint #positive)

468−-- in renderDefinition definition

574+-- in printSQL definition

469575-- :}

470−-- "ALTER TABLE \"tab\" DROP CONSTRAINT \"positive\";"

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

471577dropConstraint

472− :: KnownSymbol constraint

578+ :: ( KnownSymbol constraint

579+ , Has tab schema ('Table table0)

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

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

473582 => Alias constraint

474583 -- ^ constraint to drop

475− -> AlterTable schema

476− (constraints :=> columns)

477− (Drop constraint constraints :=> columns)

584+ -> AlterTable tab table1 schema

478585dropConstraint constraint = UnsafeAlterTable $

479586 "DROP" <+> "CONSTRAINT" <+> renderAlias constraint

480587

@@ -486,34 +593,36 @@ class AddColumn ty where

486593 -- >>> :{

487594 -- let

488595 -- definition :: Definition

489− -- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]]

490− -- '["tab" ::: '[] :=>

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

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

491598 -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

492− -- , "col2" ::: 'Def :=> 'Null 'PGtext ]]

493− -- definition = alterTable #tab (addColumn #col2 (text & default_ "foo"))

494− -- in renderDefinition definition

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

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

601+ -- in printSQL definition

495602 -- :}

496− -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text DEFAULT E'foo';"

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

497604 --

498605 -- >>> :{

499606 -- let

500607 -- definition :: Definition

501− -- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]]

502− -- '["tab" ::: '[] :=>

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

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

503610 -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

504− -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ]]

505− -- definition = alterTable #tab (addColumn #col2 text)

506− -- in renderDefinition definition

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

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

613+ -- in printSQL definition

507614 -- :}

508− -- "ALTER TABLE \"tab\" ADD COLUMN \"col2\" text;"

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

509616 addColumn

510− :: KnownSymbol column

617+ :: ( KnownSymbol column

618+ , Has tab schema ('Table table0)

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

620+ , table1 ~ (constraints :=> Create column ty columns) )

511621 => Alias column -- ^ column to add

512− -> TypeExpression ty -- ^ type of the new column

513− -> AlterTable schema (constraints :=> columns)

514− (constraints :=> Create column ty columns)

622+ -> ColumnTypeExpression schema ty -- ^ type of the new column

623+ -> AlterTable tab table1 schema

515624 addColumn column ty = UnsafeAlterTable $

516− "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty

625+ "ADD COLUMN" <+> renderAlias column <+> renderColumnTypeExpression ty

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

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

519628

@@ -525,20 +634,21 @@ instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)

525634-- >>> :{

526635-- let

527636-- definition :: Definition

528−-- '["tab" ::: '[] :=>

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

529638-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

530−-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ]]

531−-- '["tab" ::: '[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4]]

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

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

532641-- definition = alterTable #tab (dropColumn #col2)

533−-- in renderDefinition definition

642+-- in printSQL definition

534643-- :}

535−-- "ALTER TABLE \"tab\" DROP COLUMN \"col2\";"

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

536645dropColumn

537− :: KnownSymbol column

646+ :: ( KnownSymbol column

647+ , Has tab schema ('Table table0)

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

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

538650 => Alias column -- ^ column to remove

539− -> AlterTable schema

540− (constraints :=> columns)

541− (DropIfConstraintsInvolve column constraints :=> Drop column columns)

651+ -> AlterTable tab table1 schema

542652dropColumn column = UnsafeAlterTable $

543653 "DROP COLUMN" <+> renderAlias column

544654

@@ -547,33 +657,39 @@ dropColumn column = UnsafeAlterTable $

547657-- >>> :{

548658-- let

549659-- definition :: Definition

550−-- '["tab" ::: '[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4]]

551−-- '["tab" ::: '[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4]]

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

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

552662-- definition = alterTable #tab (renameColumn #foo #bar)

553−-- in renderDefinition definition

663+-- in printSQL definition

554664-- :}

555−-- "ALTER TABLE \"tab\" RENAME COLUMN \"foo\" TO \"bar\";"

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

556666renameColumn

557− :: (KnownSymbol column0, KnownSymbol column1)

667+ :: ( KnownSymbol column0

668+ , KnownSymbol column1

669+ , Has tab schema ('Table table0)

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

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

558672 => Alias column0 -- ^ column to rename

559673 -> Alias column1 -- ^ what to rename the column

560− -> AlterTable schema (constraints :=> columns)

561− (constraints :=> Rename column0 column1 columns)

674+ -> AlterTable tab table1 schema

562675renameColumn column0 column1 = UnsafeAlterTable $

563676 "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1

564677

565678-- | An `alterColumn` alters a single column.

566679alterColumn

567− :: (KnownSymbol column, Has column columns ty0)

680+ :: ( KnownSymbol column

681+ , Has tab schema ('Table table0)

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

683+ , Has column columns ty0

684+ , tables1 ~ (constraints :=> Alter column ty1 columns))

568685 => Alias column -- ^ column to alter

569− -> AlterColumn ty0 ty1 -- ^ alteration to perform

570− -> AlterTable schema (constraints :=> columns)

571− (constraints :=> Alter column columns ty1)

686+ -> AlterColumn schema ty0 ty1 -- ^ alteration to perform

687+ -> AlterTable tab table1 schema

572688alterColumn column alteration = UnsafeAlterTable $

573689 "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration

574690

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

576−newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) =

692+newtype AlterColumn (schema :: SchemaType) (ty0 :: ColumnType) (ty1 :: ColumnType) =

577693 UnsafeAlterColumn {renderAlterColumn :: ByteString}

578694 deriving (GHC.Generic,Show,Eq,Ord,NFData)

579695

@@ -584,15 +700,15 @@ newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) =

584700-- >>> :{

585701-- let

586702-- definition :: Definition

587−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]

588−-- '["tab" ::: '[] :=> '["col" ::: 'Def :=> 'Null 'PGint4]]

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

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

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

590−-- in renderDefinition definition

706+-- in printSQL definition

591707-- :}

592−-- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" SET DEFAULT 5;"

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

593709setDefault

594− :: Expression '[] 'Ungrouped '[] ty -- ^ default value to set

595− -> AlterColumn (constraint :=> ty) ('Def :=> ty)

710+ :: Expression schema '[] 'Ungrouped '[] ty -- ^ default value to set

711+ -> AlterColumn schema (constraint :=> ty) ('Def :=> ty)

596712setDefault expression = UnsafeAlterColumn $

597713 "SET DEFAULT" <+> renderExpression expression

598714

@@ -601,13 +717,13 @@ setDefault expression = UnsafeAlterColumn $

601717-- >>> :{

602718-- let

603719-- definition :: Definition

604−-- '["tab" ::: '[] :=> '["col" ::: 'Def :=> 'Null 'PGint4]]

605−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]

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

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

606722-- definition = alterTable #tab (alterColumn #col dropDefault)

607−-- in renderDefinition definition

723+-- in printSQL definition

608724-- :}

609−-- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" DROP DEFAULT;"

610−dropDefault :: AlterColumn ('Def :=> ty) ('NoDef :=> ty)

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

726+dropDefault :: AlterColumn schema ('Def :=> ty) ('NoDef :=> ty)

611727dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"

612728

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

@@ -617,14 +733,14 @@ dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"

617733-- >>> :{

618734-- let

619735-- definition :: Definition

620−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]

621−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]

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

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

622738-- definition = alterTable #tab (alterColumn #col setNotNull)

623−-- in renderDefinition definition

739+-- in printSQL definition

624740-- :}

625−-- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" SET NOT NULL;"

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

626742setNotNull

627− :: AlterColumn (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)

743+ :: AlterColumn schema (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)

628744setNotNull = UnsafeAlterColumn $ "SET NOT NULL"

629745

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

@@ -632,14 +748,14 @@ setNotNull = UnsafeAlterColumn $ "SET NOT NULL"

632748-- >>> :{

633749-- let

634750-- definition :: Definition

635−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]

636−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]

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

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

637753-- definition = alterTable #tab (alterColumn #col dropNotNull)

638−-- in renderDefinition definition

754+-- in printSQL definition

639755-- :}

640−-- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" DROP NOT NULL;"

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

641757dropNotNull

642− :: AlterColumn (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)

758+ :: AlterColumn schema (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)

643759dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"

644760

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

@@ -649,12 +765,188 @@ dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"

649765-- >>> :{

650766-- let

651767-- definition :: Definition

652−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4]]

653−-- '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric]]

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

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

654770-- definition =

655−-- alterTable #tab (alterColumn #col (alterType (numeric & notNull)))

656−-- in renderDefinition definition

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

772+-- in printSQL definition

657773-- :}

658−-- "ALTER TABLE \"tab\" ALTER COLUMN \"col\" TYPE numeric NOT NULL;"

659−alterType :: TypeExpression ty -> AlterColumn ty0 ty

660−alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderTypeExpression ty

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

775+alterType :: ColumnTypeExpression schema ty -> AlterColumn schema ty0 ty

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

777+

778+-- | Create a view.

779+--

780+-- >>> :{

781+-- let

782+-- definition :: Definition

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

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

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

786+-- definition =

787+-- createView #bc (select (#b :* #c :* Nil) (from (table #abc)))

788+-- in printSQL definition

789+-- :}

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

791+createView

792+ :: KnownSymbol view

793+ => Alias view -- ^ the name of the view to add

794+ -> Query schema '[] relation

795+ -- ^ query

796+ -> Definition schema (Create view ('View relation) schema)

797+createView alias query = UnsafeDefinition $

798+ "CREATE" <+> "VIEW" <+> renderAlias alias <+> "AS"

799+ <+> renderQuery query <> ";"

800+

801+-- | Drop a view.

802+--

803+-- >>> :{

804+-- let

805+-- definition :: Definition

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

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

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

809+-- definition = dropView #bc

810+-- in printSQL definition

811+-- :}

812+-- DROP VIEW "bc";

813+dropView

814+ :: Has view schema ('View v)

815+ => Alias view -- ^ view to remove

816+ -> Definition schema (Drop view schema)

817+dropView v = UnsafeDefinition $ "DROP VIEW" <+> renderAlias v <> ";"

818+

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

820+--

821+-- >>> printSQL $ createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil)

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

823+createTypeEnum

824+ :: (KnownSymbol enum, SOP.All KnownSymbol labels)

825+ => Alias enum

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

827+ -> NP PGlabel labels

828+ -- ^ labels of the enumerated type

829+ -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema)

830+createTypeEnum enum labels = UnsafeDefinition $

831+ "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+> "ENUM" <+>

832+ parenthesized (commaSeparated (renderLabels labels)) <> ";"

833+

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

835+--

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

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

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

839+-- >>> printSQL $ createTypeEnumFrom @Schwarma #schwarma

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

841+createTypeEnumFrom

842+ :: forall hask enum schema.

843+ ( SOP.Generic hask

844+ , SOP.All KnownSymbol (LabelsFrom hask)

845+ , KnownSymbol enum

846+ )

847+ => Alias enum

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

849+ -> Definition schema (Create enum ('Typedef (EnumFrom hask)) schema)

850+createTypeEnumFrom enum = createTypeEnum enum

851+ (SOP.hpure label :: NP PGlabel (LabelsFrom hask))

852+

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

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

855+--

856+-- >>> printSQL $ createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil)

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

858+createTypeComposite

859+ :: (KnownSymbol ty, SOP.SListI fields)

860+ => Alias ty

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

862+ -> NP (Aliased (TypeExpression schema)) fields

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

864+ -> Definition schema (Create ty ('Typedef ('PGcomposite fields)) schema)

865+createTypeComposite ty fields = UnsafeDefinition $

866+ "CREATE" <+> "TYPE" <+> renderAlias ty <+> "AS" <+> parenthesized

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

868+ where

869+ renderField :: Aliased (TypeExpression schema) x -> ByteString

870+ renderField (typ `As` field) =

871+ renderAlias field <+> renderTypeExpression typ

872+

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

874+--

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

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

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

878+-- >>> printSQL $ createTypeCompositeFrom @Complex #complex

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

880+createTypeCompositeFrom

881+ :: forall hask ty schema.

882+ ( ZipAliased (FieldNamesFrom hask) (FieldTypesFrom hask)

883+ , SOP.All (PGTyped schema) (FieldTypesFrom hask)

884+ , KnownSymbol ty

885+ )

886+ => Alias ty

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

888+ -> Definition schema (Create ty ( 'Typedef (CompositeFrom hask)) schema)

889+createTypeCompositeFrom ty = createTypeComposite ty $ zipAs

890+ (SOP.hpure Alias :: NP Alias (FieldNamesFrom hask))

891+ (SOP.hcpure (SOP.Proxy :: SOP.Proxy (PGTyped schema)) pgtype

892+ :: NP (TypeExpression schema) (FieldTypesFrom hask))

893+

894+-- | Drop a type.

895+--

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

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

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

899+-- >>> printSQL (dropType #schwarma :: Definition '["schwarma" ::: 'Typedef (EnumFrom Schwarma)] '[])

900+-- DROP TYPE "schwarma";

901+dropType

902+ :: Has tydef schema ('Typedef ty)

903+ => Alias tydef

904+ -- ^ name of the user defined type

905+ -> Definition schema (Drop tydef schema)

906+dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderAlias tydef <> ";"

907+

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

909+newtype ColumnTypeExpression (schema :: SchemaType) (ty :: ColumnType)

910+ = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }

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

912+

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

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

915+nullable

916+ :: TypeExpression schema ty

917+ -> ColumnTypeExpression schema ('NoDef :=> 'Null ty)

918+nullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL"

919+

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

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

922+notNullable

923+ :: TypeExpression schema ty

924+ -> ColumnTypeExpression schema (def :=> 'NotNull ty)

925+notNullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL"

926+

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

928+default_

929+ :: Expression schema '[] 'Ungrouped '[] ty

930+ -> ColumnTypeExpression schema ('NoDef :=> ty)

931+ -> ColumnTypeExpression schema ('Def :=> ty)

932+default_ x ty = UnsafeColumnTypeExpression $

933+ renderColumnTypeExpression ty <+> "DEFAULT" <+> renderExpression x

934+

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

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

937+serial2, smallserial

938+ :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint2)

939+serial2 = UnsafeColumnTypeExpression "serial2"

940+smallserial = UnsafeColumnTypeExpression "smallserial"

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

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

943+serial4, serial

944+ :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint4)

945+serial4 = UnsafeColumnTypeExpression "serial4"

946+serial = UnsafeColumnTypeExpression "serial"

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

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

949+serial8, bigserial

950+ :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint8)

951+serial8 = UnsafeColumnTypeExpression "serial8"

952+bigserial = UnsafeColumnTypeExpression "bigserial"

squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+482−436

@@ -11,21 +11,15 @@ Squeal expressions are the atoms used to build statements.

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

1212{-# LANGUAGE

1313 AllowAmbiguousTypes

14− , DataKinds

1514 , DeriveGeneric

16− , DeriveDataTypeable

1715 , FlexibleContexts

1816 , FlexibleInstances

1917 , FunctionalDependencies

20− , GADTs

2118 , GeneralizedNewtypeDeriving

2219 , LambdaCase

2320 , MagicHash

2421 , OverloadedStrings

25− , PolyKinds

26− , RankNTypes

2722 , ScopedTypeVariables

28− , StandaloneDeriving

2923 , TypeApplications

3024 , TypeFamilies

3125 , TypeInType

@@ -33,21 +27,23 @@ Squeal expressions are the atoms used to build statements.

3327 , UndecidableInstances

3428#-}

3529

36−module Squeal.PostgreSQL.Expression

30+module Squeal.PostgreSQL.Expression

3731 ( -- * Expression

3832 Expression (UnsafeExpression, renderExpression)

39− , HasParameter (param)

33+ , HasParameter (parameter)

34+ , param

4035 -- ** Null

4136 , null_

42− , unNull

37+ , notNull

4338 , coalesce

4439 , fromNull

4540 , isNull

46− , isn'tNull

41+ , isNotNull

4742 , matchNull

4843 , nullIf

49− -- ** Arrays

44+ -- ** Collections

5045 , array

46+ , row

5147 -- ** Functions

5248 , unsafeBinaryOp

5349 , unsafeUnaryOp

@@ -97,8 +93,6 @@ module Squeal.PostgreSQL.Expression

9793 , count, countDistinct

9894 , every, everyDistinct

9995 , max_, maxDistinct, min_, minDistinct

100− -- * Tables

101− , Table (UnsafeTable, renderTable)

10296 -- * Types

10397 , TypeExpression (UnsafeTypeExpression, renderTypeExpression)

10498 , PGTyped (pgtype)

@@ -115,12 +109,6 @@ module Squeal.PostgreSQL.Expression

115109 , real

116110 , float8

117111 , doublePrecision

118− , serial2

119− , smallserial

120− , serial4

121− , serial

122− , serial8

123− , bigserial

124112 , text

125113 , char

126114 , character

@@ -139,8 +127,6 @@ module Squeal.PostgreSQL.Expression

139127 , jsonb

140128 , vararray

141129 , fixarray

142− , notNull

143− , default_

144130 -- * Re-export

145131 , (&)

146132 , NP ((:*), Nil)

@@ -150,7 +136,7 @@ import Control.Category

150136import Control.DeepSeq

151137import Data.ByteString (ByteString)

152138import Data.Function ((&))

153−import Data.Monoid hiding (All)

139+import Data.Semigroup

154140import Data.Ratio

155141import Data.String

156142import Generics.SOP hiding (from)

@@ -178,6 +164,7 @@ values from primitive expression using arithmetic, logical,

178164and other operations.

179165-}

180166newtype Expression

167+ (schema :: SchemaType)

181168 (relations :: RelationsType)

182169 (grouping :: Grouping)

183170 (params :: [NullityType])

@@ -185,6 +172,9 @@ newtype Expression

185172 = UnsafeExpression { renderExpression :: ByteString }

186173 deriving (GHC.Generic,Show,Eq,Ord,NFData)

187174

175+instance RenderSQL (Expression schema relations grouping params ty) where

176+ renderSQL = renderExpression

177+

188178{- | A `HasParameter` constraint is used to indicate a value that is

189179supplied externally to a SQL statement.

190180`Squeal.PostgreSQL.PQ.manipulateParams`,

@@ -193,203 +183,302 @@ supplied externally to a SQL statement.

193183separately from the SQL command string, in which case `param`s are used to

194184refer to the out-of-line data values.

195185-}

196−class (PGTyped (PGTypeOf ty), KnownNat n) => HasParameter

186+class KnownNat n => HasParameter

197187 (n :: Nat)

188+ (schema :: SchemaType)

198189 (params :: [NullityType])

199190 (ty :: NullityType)

200191 | n params -> ty where

201− param :: Expression relations grouping params ty

202− param = UnsafeExpression $ parenthesized $

192+ -- | `parameter` takes a `Nat` using type application and a `TypeExpression`.

193+ --

194+ -- >>> let expr = parameter @1 int4 :: Expression sch rels grp '[ 'Null 'PGint4] ('Null 'PGint4)

195+ -- >>> printSQL expr

196+ -- ($1 :: int4)

197+ parameter

198+ :: TypeExpression schema (PGTypeOf ty)

199+ -> Expression schema relations grouping params ty

200+ parameter ty = UnsafeExpression $ parenthesized $

203201 "$" <> renderNat (Proxy @n) <+> "::"

204− <+> renderTypeExpression (pgtype @(PGTypeOf ty))

205−instance {-# OVERLAPPING #-} PGTyped (PGTypeOf ty1)

206− => HasParameter 1 (ty1:tys) ty1

207−instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)

208− => HasParameter n (ty' : params) ty

202+ <+> renderTypeExpression ty

203+instance {-# OVERLAPPING #-} HasParameter 1 schema (ty1:tys) ty1

204+instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) schema params ty)

205+ => HasParameter n schema (ty' : params) ty

206+

207+-- | `param` takes a `Nat` using type application and for basic types,

208+-- infers a `TypeExpression`.

209+--

210+-- >>> let expr = param @1 :: Expression sch rels grp '[ 'Null 'PGint4] ('Null 'PGint4)

211+-- >>> printSQL expr

212+-- ($1 :: int4)

213+param

214+ :: forall n schema params relations grouping ty

215+ . (PGTyped schema (PGTypeOf ty), HasParameter n schema params ty)

216+ => Expression schema relations grouping params ty -- ^ param

217+param = parameter @n pgtype

209218

210219instance (HasUnique relation relations columns, Has column columns ty)

211− => IsLabel column (Expression relations 'Ungrouped params ty) where

220+ => IsLabel column (Expression schema relations 'Ungrouped params ty) where

212221 fromLabel = UnsafeExpression $ renderAlias (Alias @column)

222+instance (HasUnique relation relations columns, Has column columns ty)

223+ => IsLabel column

224+ (Aliased (Expression schema relations 'Ungrouped params) (column ::: ty)) where

225+ fromLabel = fromLabel @column `As` Alias @column

226+instance (HasUnique relation relations columns, Has column columns ty)

227+ => IsLabel column

228+ (NP (Aliased (Expression schema relations 'Ungrouped params)) '[column ::: ty]) where

229+ fromLabel = fromLabel @column :* Nil

213230

214231instance (Has relation relations columns, Has column columns ty)

215− => IsQualified relation column (Expression relations 'Ungrouped params ty) where

232+ => IsQualified relation column (Expression schema relations 'Ungrouped params ty) where

216233 relation ! column = UnsafeExpression $

217234 renderAlias relation <> "." <> renderAlias column

218−

235+instance (Has relation relations columns, Has column columns ty)

236+ => IsQualified relation column

237+ (Aliased (Expression schema relations 'Ungrouped params) (column ::: ty)) where

238+ relation ! column = relation ! column `As` column

239+instance (Has relation relations columns, Has column columns ty)

240+ => IsQualified relation column

241+ (NP (Aliased (Expression schema relations 'Ungrouped params)) '[column ::: ty]) where

242+ relation ! column = relation ! column :* Nil

243+

219244instance

220245 ( HasUnique relation relations columns

221246 , Has column columns ty

222247 , GroupedBy relation column bys

223248 ) => IsLabel column

224− (Expression relations ('Grouped bys) params ty) where

249+ (Expression schema relations ('Grouped bys) params ty) where

225250 fromLabel = UnsafeExpression $ renderAlias (Alias @column)

226−

251+instance

252+ ( HasUnique relation relations columns

253+ , Has column columns ty

254+ , GroupedBy relation column bys

255+ ) => IsLabel column

256+ ( Aliased (Expression schema relations ('Grouped bys) params)

257+ (column ::: ty) ) where

258+ fromLabel = fromLabel @column `As` Alias @column

259+instance

260+ ( HasUnique relation relations columns

261+ , Has column columns ty

262+ , GroupedBy relation column bys

263+ ) => IsLabel column

264+ ( NP (Aliased (Expression schema relations ('Grouped bys) params))

265+ '[column ::: ty] ) where

266+ fromLabel = fromLabel @column :* Nil

267+

227268instance

228269 ( Has relation relations columns

229270 , Has column columns ty

230271 , GroupedBy relation column bys

231272 ) => IsQualified relation column

232− (Expression relations ('Grouped bys) params ty) where

273+ (Expression schema relations ('Grouped bys) params ty) where

233274 relation ! column = UnsafeExpression $

234275 renderAlias relation <> "." <> renderAlias column

276+instance

277+ ( Has relation relations columns

278+ , Has column columns ty

279+ , GroupedBy relation column bys

280+ ) => IsQualified relation column

281+ (Aliased (Expression schema relations ('Grouped bys) params)

282+ (column ::: ty)) where

283+ relation ! column = relation ! column `As` column

284+instance

285+ ( Has relation relations columns

286+ , Has column columns ty

287+ , GroupedBy relation column bys

288+ ) => IsQualified relation column

289+ ( NP (Aliased (Expression schema relations ('Grouped bys) params))

290+ '[column ::: ty]) where

291+ relation ! column = relation ! column :* Nil

235292

236293-- | analagous to `Nothing`

237294--

238−-- >>> renderExpression $ null_

239−-- "NULL"

240−null_ :: Expression relations grouping params ('Null ty)

295+-- >>> printSQL null_

296+-- NULL

297+null_ :: Expression schema rels grouping params ('Null ty)

241298null_ = UnsafeExpression "NULL"

242299

243300-- | analagous to `Just`

244301--

245−-- >>> renderExpression $ unNull true

246−-- "TRUE"

247−unNull

248− :: Expression relations grouping params ('NotNull ty)

249− -- ^ not @NULL@

250− -> Expression relations grouping params ('Null ty)

251−unNull = UnsafeExpression . renderExpression

302+-- >>> printSQL $ notNull true

303+-- TRUE

304+notNull

305+ :: Expression schema rels grouping params ('NotNull ty)

306+ -> Expression schema rels grouping params ('Null ty)

307+notNull = UnsafeExpression . renderExpression

252308

253309-- | return the leftmost value which is not NULL

254310--

255−-- >>> renderExpression $ coalesce [null_, unNull true] false

256−-- "COALESCE(NULL, TRUE, FALSE)"

311+-- >>> printSQL $ coalesce [null_, notNull true] false

312+-- COALESCE(NULL, TRUE, FALSE)

257313coalesce

258− :: [Expression relations grouping params ('Null ty)]

314+ :: [Expression schema relations grouping params ('Null ty)]

259315 -- ^ @NULL@s may be present

260− -> Expression relations grouping params ('NotNull ty)

316+ -> Expression schema relations grouping params ('NotNull ty)

261317 -- ^ @NULL@ is absent

262− -> Expression relations grouping params ('NotNull ty)

318+ -> Expression schema relations grouping params ('NotNull ty)

263319coalesce nullxs notNullx = UnsafeExpression $

264320 "COALESCE" <> parenthesized (commaSeparated

265321 ((renderExpression <$> nullxs) <> [renderExpression notNullx]))

266322

267323-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@

268324--

269−-- >>> renderExpression $ fromNull true null_

270−-- "COALESCE(NULL, TRUE)"

325+-- >>> printSQL $ fromNull true null_

326+-- COALESCE(NULL, TRUE)

271327fromNull

272− :: Expression relations grouping params ('NotNull ty)

328+ :: Expression schema relations grouping params ('NotNull ty)

273329 -- ^ what to convert @NULL@ to

274− -> Expression relations grouping params ('Null ty)

275− -> Expression relations grouping params ('NotNull ty)

330+ -> Expression schema relations grouping params ('Null ty)

331+ -> Expression schema relations grouping params ('NotNull ty)

276332fromNull notNullx nullx = coalesce [nullx] notNullx

277333

278−-- | >>> renderExpression $ null_ & isNull

279−-- "NULL IS NULL"

334+-- | >>> printSQL $ null_ & isNull

335+-- NULL IS NULL

280336isNull

281− :: Expression relations grouping params ('Null ty)

337+ :: Expression schema relations grouping params ('Null ty)

282338 -- ^ possibly @NULL@

283− -> Condition relations grouping params

339+ -> Condition schema relations grouping params

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

285341

286−-- | >>> renderExpression $ null_ & isn'tNull

287−-- "NULL IS NOT NULL"

288−isn'tNull

289− :: Expression relations grouping params ('Null ty)

342+-- | >>> printSQL $ null_ & isNotNull

343+-- NULL IS NOT NULL

344+isNotNull

345+ :: Expression schema relations grouping params ('Null ty)

290346 -- ^ possibly @NULL@

291− -> Condition relations grouping params

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

347+ -> Condition schema relations grouping params

348+isNotNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL"

293349

294350-- | analagous to `maybe` using @IS NULL@

295351--

296−-- >>> renderExpression $ matchNull true not_ null_

297−-- "CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END"

352+-- >>> printSQL $ matchNull true not_ null_

353+-- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END

298354matchNull

299− :: Expression relations grouping params (nullty)

355+ :: Expression schema relations grouping params (nullty)

300356 -- ^ what to convert @NULL@ to

301− -> ( Expression relations grouping params ('NotNull ty)

302− -> Expression relations grouping params (nullty) )

357+ -> ( Expression schema relations grouping params ('NotNull ty)

358+ -> Expression schema relations grouping params (nullty) )

303359 -- ^ function to perform when @NULL@ is absent

304− -> Expression relations grouping params ('Null ty)

305− -> Expression relations grouping params (nullty)

360+ -> Expression schema relations grouping params ('Null ty)

361+ -> Expression schema relations grouping params (nullty)

306362matchNull y f x = ifThenElse (isNull x) y

307363 (f (UnsafeExpression (renderExpression x)))

308364

309−-- | right inverse to `fromNull`, if its arguments are equal then

310−-- `nullIf` gives @NULL@.

311−--

312−-- >>> :set -XTypeApplications -XDataKinds

313−-- >>> renderExpression @_ @_ @'[_] $ fromNull false (nullIf false (param @1))

314−-- "COALESCE(NULL IF (FALSE, ($1 :: bool)), FALSE)"

365+{-| right inverse to `fromNull`, if its arguments are equal then

366+`nullIf` gives @NULL@.

367+

368+>>> :set -XTypeApplications -XDataKinds

369+>>> let expr = nullIf false (param @1) :: Expression schema rels grp '[ 'NotNull 'PGbool] ('Null 'PGbool)

370+>>> printSQL expr

371+NULL IF (FALSE, ($1 :: bool))

372+-}

315373nullIf

316− :: Expression relations grouping params ('NotNull ty)

374+ :: Expression schema relations grouping params ('NotNull ty)

317375 -- ^ @NULL@ is absent

318− -> Expression relations grouping params ('NotNull ty)

376+ -> Expression schema relations grouping params ('NotNull ty)

319377 -- ^ @NULL@ is absent

320− -> Expression relations grouping params ('Null ty)

378+ -> Expression schema relations grouping params ('Null ty)

321379nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized

322380 (renderExpression x <> ", " <> renderExpression y)

323381

324−-- | >>> renderExpression $ array [null_, unNull false, unNull true]

325−-- "ARRAY[NULL, FALSE, TRUE]"

382+-- | >>> printSQL $ array [null_, notNull false, notNull true]

383+-- ARRAY[NULL, FALSE, TRUE]

326384array

327− :: [Expression relations grouping params ('Null ty)]

385+ :: [Expression schema relations grouping params ('Null ty)]

328386 -- ^ array elements

329− -> Expression relations grouping params (nullity ('PGvararray ty))

387+ -> Expression schema relations grouping params (nullity ('PGvararray ty))

330388array xs = UnsafeExpression $

331389 "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]"

332390

391+instance (KnownSymbol label, label `In` labels) => IsPGlabel label

392+ (Expression schema relations grouping params (nullity ('PGenum labels))) where

393+ label = UnsafeExpression $ renderLabel (PGlabel @label)

394+

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

396+-- (also called a composite value) using values for its member fields.

397+--

398+-- >>> type Complex = PGcomposite '["real" ::: 'PGfloat8, "imaginary" ::: 'PGfloat8]

399+-- >>> let i = row (0 `As` #real :* 1 `As` #imaginary :* Nil) :: Expression '[] '[] 'Ungrouped '[] ('NotNull Complex)

400+-- >>> printSQL i

401+-- ROW(0, 1)

402+row

403+ :: SListI (Nulls fields)

404+ => NP (Aliased (Expression schema relations grouping params)) (Nulls fields)

405+ -- ^ zero or more expressions for the row field values

406+ -> Expression schema relations grouping params (nullity ('PGcomposite fields))

407+row exprs = UnsafeExpression $ "ROW" <> parenthesized

408+ (renderCommaSeparated (\ (expr `As` _) -> renderExpression expr) exprs)

409+

410+instance Has field fields ty => IsLabel field

411+ ( Expression schema relation grouping params (nullity ('PGcomposite fields))

412+ -> Expression schema relation grouping params ('Null ty) ) where

413+ fromLabel expr = UnsafeExpression $

414+ parenthesized (renderExpression expr) <> "." <>

415+ fromString (symbolVal (Proxy @field))

416+

417+instance Semigroup

418+ (Expression schema relations grouping params (nullity ('PGvararray ty))) where

419+ (<>) = unsafeBinaryOp "||"

420+

333421instance Monoid

334− (Expression relations grouping params (nullity ('PGvararray ty))) where

422+ (Expression schema relations grouping params (nullity ('PGvararray ty))) where

335423 mempty = array []

336− mappend = unsafeBinaryOp "||"

424+ mappend = (<>)

337425

338−-- | >>> renderExpression @_ @_ @'[_] $ greatest currentTimestamp [param @1]

339−-- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))"

426+-- | >>> let expr = greatest currentTimestamp [param @1] :: Expression sch rels grp '[ 'NotNull 'PGtimestamptz] ('NotNull 'PGtimestamptz)

427+-- >>> printSQL expr

428+-- GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))

340429greatest

341− :: Expression relations grouping params (nullty)

430+ :: Expression schema relations grouping params (nullty)

342431 -- ^ needs at least 1 argument

343− -> [Expression relations grouping params (nullty)]

432+ -> [Expression schema relations grouping params (nullty)]

344433 -- ^ or more

345− -> Expression relations grouping params (nullty)

434+ -> Expression schema relations grouping params (nullty)

346435greatest x xs = UnsafeExpression $ "GREATEST("

347436 <> commaSeparated (renderExpression <$> (x:xs)) <> ")"

348437

349−-- | >>> renderExpression $ least currentTimestamp [null_]

350−-- "LEAST(CURRENT_TIMESTAMP, NULL)"

438+-- | >>> printSQL $ least currentTimestamp [null_]

439+-- LEAST(CURRENT_TIMESTAMP, NULL)

351440least

352− :: Expression relations grouping params (nullty)

441+ :: Expression schema relations grouping params (nullty)

353442 -- ^ needs at least 1 argument

354− -> [Expression relations grouping params (nullty)]

443+ -> [Expression schema relations grouping params (nullty)]

355444 -- ^ or more

356− -> Expression relations grouping params (nullty)

445+ -> Expression schema relations grouping params (nullty)

357446least x xs = UnsafeExpression $ "LEAST("

358447 <> commaSeparated (renderExpression <$> (x:xs)) <> ")"

359448

360−-- | >>> renderExpression $ unsafeBinaryOp "OR" true false

361−-- "(TRUE OR FALSE)"

449+-- | >>> printSQL $ unsafeBinaryOp "OR" true false

450+-- (TRUE OR FALSE)

362451unsafeBinaryOp

363452 :: ByteString

364453 -- ^ operator

365− -> Expression relations grouping params (ty0)

366− -> Expression relations grouping params (ty1)

367− -> Expression relations grouping params (ty2)

454+ -> Expression schema relations grouping params (ty0)

455+ -> Expression schema relations grouping params (ty1)

456+ -> Expression schema relations grouping params (ty2)

368457unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $

369458 renderExpression x <+> op <+> renderExpression y

370459

371−-- | >>> renderExpression $ unsafeUnaryOp "NOT" true

372−-- "(NOT TRUE)"

460+-- | >>> printSQL $ unsafeUnaryOp "NOT" true

461+-- (NOT TRUE)

373462unsafeUnaryOp

374463 :: ByteString

375464 -- ^ operator

376− -> Expression relations grouping params (ty0)

377− -> Expression relations grouping params (ty1)

465+ -> Expression schema relations grouping params (ty0)

466+ -> Expression schema relations grouping params (ty1)

378467unsafeUnaryOp op x = UnsafeExpression $ parenthesized $

379468 op <+> renderExpression x

380469

381−-- | >>> renderExpression $ unsafeFunction "f" true

382−-- "f(TRUE)"

470+-- | >>> printSQL $ unsafeFunction "f" true

471+-- f(TRUE)

383472unsafeFunction

384473 :: ByteString

385474 -- ^ function

386− -> Expression relations grouping params (xty)

387− -> Expression relations grouping params (yty)

475+ -> Expression schema relations grouping params (xty)

476+ -> Expression schema relations grouping params (yty)

388477unsafeFunction fun x = UnsafeExpression $

389478 fun <> parenthesized (renderExpression x)

390479

391480instance PGNum ty

392− => Num (Expression relations grouping params (nullity ty)) where

481+ => Num (Expression schema relations grouping params (nullity ty)) where

393482 (+) = unsafeBinaryOp "+"

394483 (-) = unsafeBinaryOp "-"

395484 (*) = unsafeBinaryOp "*"

@@ -401,12 +490,12 @@ instance PGNum ty

401490 . show

402491

403492instance (PGNum ty, PGFloating ty) => Fractional

404− (Expression relations grouping params (nullity ty)) where

493+ (Expression schema relations grouping params (nullity ty)) where

405494 (/) = unsafeBinaryOp "/"

406495 fromRational x = fromInteger (numerator x) / fromInteger (denominator x)

407496

408497instance (PGNum ty, PGFloating ty) => Floating

409− (Expression relations grouping params (nullity ty)) where

498+ (Expression schema relations grouping params (nullity ty)) where

410499 pi = UnsafeExpression "pi()"

411500 exp = unsafeFunction "exp"

412501 log = unsafeFunction "ln"

@@ -429,18 +518,18 @@ instance (PGNum ty, PGFloating ty) => Floating

429518

430519-- | >>> :{

431520-- let

432−-- expression :: Expression relations grouping params (nullity 'PGfloat4)

521+-- expression :: Expression schema relations grouping params (nullity 'PGfloat4)

433522-- expression = atan2_ pi 2

434−-- in renderExpression expression

523+-- in printSQL expression

435524-- :}

436−-- "atan2(pi(), 2)"

525+-- atan2(pi(), 2)

437526atan2_

438527 :: PGFloating float

439− => Expression relations grouping params (nullity float)

528+ => Expression schema relations grouping params (nullity float)

440529 -- ^ numerator

441− -> Expression relations grouping params (nullity float)

530+ -> Expression schema relations grouping params (nullity float)

442531 -- ^ denominator

443− -> Expression relations grouping params (nullity float)

532+ -> Expression schema relations grouping params (nullity float)

444533atan2_ y x = UnsafeExpression $

445534 "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"

446535

@@ -448,14 +537,14 @@ atan2_ y x = UnsafeExpression $

448537-- represents a run-time type conversion. The cast will succeed only if a

449538-- suitable type conversion operation has been defined.

450539--

451−-- | >>> renderExpression $ true & cast int4

452−-- "(TRUE :: int4)"

540+-- | >>> printSQL $ true & cast int4

541+-- (TRUE :: int4)

453542cast

454− :: TypeExpression ('NoDef :=> 'Null ty1)

543+ :: TypeExpression schema ty1

455544 -- ^ type to cast as

456− -> Expression relations grouping params (nullity ty0)

545+ -> Expression schema relations grouping params (nullity ty0)

457546 -- ^ value to convert

458− -> Expression relations grouping params (nullity ty1)

547+ -> Expression schema relations grouping params (nullity ty1)

459548cast ty x = UnsafeExpression $ parenthesized $

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

461550

@@ -463,135 +552,135 @@ cast ty x = UnsafeExpression $ parenthesized $

463552--

464553-- >>> :{

465554-- let

466−-- expression :: Expression relations grouping params (nullity 'PGint2)

555+-- expression :: Expression schema relations grouping params (nullity 'PGint2)

467556-- expression = 5 `quot_` 2

468−-- in renderExpression expression

557+-- in printSQL expression

469558-- :}

470−-- "(5 / 2)"

559+-- (5 / 2)

471560quot_

472561 :: PGIntegral int

473− => Expression relations grouping params (nullity int)

562+ => Expression schema relations grouping params (nullity int)

474563 -- ^ numerator

475− -> Expression relations grouping params (nullity int)

564+ -> Expression schema relations grouping params (nullity int)

476565 -- ^ denominator

477− -> Expression relations grouping params (nullity int)

566+ -> Expression schema relations grouping params (nullity int)

478567quot_ = unsafeBinaryOp "/"

479568

480569-- | remainder upon integer division

481570--

482571-- >>> :{

483572-- let

484−-- expression :: Expression relations grouping params (nullity 'PGint2)

573+-- expression :: Expression schema relations grouping params (nullity 'PGint2)

485574-- expression = 5 `rem_` 2

486−-- in renderExpression expression

575+-- in printSQL expression

487576-- :}

488−-- "(5 % 2)"

577+-- (5 % 2)

489578rem_

490579 :: PGIntegral int

491− => Expression relations grouping params (nullity int)

580+ => Expression schema relations grouping params (nullity int)

492581 -- ^ numerator

493− -> Expression relations grouping params (nullity int)

582+ -> Expression schema relations grouping params (nullity int)

494583 -- ^ denominator

495− -> Expression relations grouping params (nullity int)

584+ -> Expression schema relations grouping params (nullity int)

496585rem_ = unsafeBinaryOp "%"

497586

498587-- | >>> :{

499588-- let

500−-- expression :: Expression relations grouping params (nullity 'PGfloat4)

589+-- expression :: Expression schema relations grouping params (nullity 'PGfloat4)

501590-- expression = trunc pi

502−-- in renderExpression expression

591+-- in printSQL expression

503592-- :}

504−-- "trunc(pi())"

593+-- trunc(pi())

505594trunc

506595 :: PGFloating frac

507− => Expression relations grouping params (nullity frac)

596+ => Expression schema relations grouping params (nullity frac)

508597 -- ^ fractional number

509− -> Expression relations grouping params (nullity frac)

598+ -> Expression schema relations grouping params (nullity frac)

510599trunc = unsafeFunction "trunc"

511600

512601-- | >>> :{

513602-- let

514−-- expression :: Expression relations grouping params (nullity 'PGfloat4)

603+-- expression :: Expression schema relations grouping params (nullity 'PGfloat4)

515604-- expression = round_ pi

516−-- in renderExpression expression

605+-- in printSQL expression

517606-- :}

518−-- "round(pi())"

607+-- round(pi())

519608round_

520609 :: PGFloating frac

521− => Expression relations grouping params (nullity frac)

610+ => Expression schema relations grouping params (nullity frac)

522611 -- ^ fractional number

523− -> Expression relations grouping params (nullity frac)

612+ -> Expression schema relations grouping params (nullity frac)

524613round_ = unsafeFunction "round"

525614

526615-- | >>> :{

527616-- let

528−-- expression :: Expression relations grouping params (nullity 'PGfloat4)

617+-- expression :: Expression schema relations grouping params (nullity 'PGfloat4)

529618-- expression = ceiling_ pi

530−-- in renderExpression expression

619+-- in printSQL expression

531620-- :}

532−-- "ceiling(pi())"

621+-- ceiling(pi())

533622ceiling_

534623 :: PGFloating frac

535− => Expression relations grouping params (nullity frac)

624+ => Expression schema relations grouping params (nullity frac)

536625 -- ^ fractional number

537− -> Expression relations grouping params (nullity frac)

626+ -> Expression schema relations grouping params (nullity frac)

538627ceiling_ = unsafeFunction "ceiling"

539628

540629-- | A `Condition` is a boolean valued `Expression`. While SQL allows

541630-- conditions to have @NULL@, Squeal instead chooses to disallow @NULL@,

542631-- forcing one to handle the case of @NULL@ explicitly to produce

543632-- a `Condition`.

544−type Condition relations grouping params =

545− Expression relations grouping params ('NotNull 'PGbool)

633+type Condition schema relations grouping params =

634+ Expression schema relations grouping params ('NotNull 'PGbool)

546635

547−-- | >>> renderExpression true

548−-- "TRUE"

549−true :: Condition relations grouping params

636+-- | >>> printSQL true

637+-- TRUE

638+true :: Condition schema relations grouping params

550639true = UnsafeExpression "TRUE"

551640

552−-- | >>> renderExpression false

553−-- "FALSE"

554−false :: Condition relations grouping params

641+-- | >>> printSQL false

642+-- FALSE

643+false :: Condition schema relations grouping params

555644false = UnsafeExpression "FALSE"

556645

557−-- | >>> renderExpression $ not_ true

558−-- "(NOT TRUE)"

646+-- | >>> printSQL $ not_ true

647+-- (NOT TRUE)

559648not_

560− :: Condition relations grouping params

561− -> Condition relations grouping params

649+ :: Condition schema relations grouping params

650+ -> Condition schema relations grouping params

562651not_ = unsafeUnaryOp "NOT"

563652

564−-- | >>> renderExpression $ true .&& false

565−-- "(TRUE AND FALSE)"

653+-- | >>> printSQL $ true .&& false

654+-- (TRUE AND FALSE)

566655(.&&)

567− :: Condition relations grouping params

568− -> Condition relations grouping params

569− -> Condition relations grouping params

656+ :: Condition schema relations grouping params

657+ -> Condition schema relations grouping params

658+ -> Condition schema relations grouping params

570659(.&&) = unsafeBinaryOp "AND"

571660

572−-- | >>> renderExpression $ true .|| false

573−-- "(TRUE OR FALSE)"

661+-- | >>> printSQL $ true .|| false

662+-- (TRUE OR FALSE)

574663(.||)

575− :: Condition relations grouping params

576− -> Condition relations grouping params

577− -> Condition relations grouping params

664+ :: Condition schema relations grouping params

665+ -> Condition schema relations grouping params

666+ -> Condition schema relations grouping params

578667(.||) = unsafeBinaryOp "OR"

579668

580669-- | >>> :{

581670-- let

582−-- expression :: Expression relations grouping params (nullity 'PGint2)

671+-- expression :: Expression schema relations grouping params (nullity 'PGint2)

583672-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3

584−-- in renderExpression expression

673+-- in printSQL expression

585674-- :}

586−-- "CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END"

675+-- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END

587676caseWhenThenElse

588− :: [ ( Condition relations grouping params

589− , Expression relations grouping params (ty)

677+ :: [ ( Condition schema relations grouping params

678+ , Expression schema relations grouping params (ty)

590679 ) ]

591680 -- ^ whens and thens

592− -> Expression relations grouping params (ty)

681+ -> Expression schema relations grouping params (ty)

593682 -- ^ else

594− -> Expression relations grouping params (ty)

683+ -> Expression schema relations grouping params (ty)

595684caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat

596685 [ "CASE"

597686 , mconcat

@@ -607,103 +696,103 @@ caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat

607696

608697-- | >>> :{

609698-- let

610−-- expression :: Expression relations grouping params (nullity 'PGint2)

699+-- expression :: Expression schema relations grouping params (nullity 'PGint2)

611700-- expression = ifThenElse true 1 0

612−-- in renderExpression expression

701+-- in printSQL expression

613702-- :}

614−-- "CASE WHEN TRUE THEN 1 ELSE 0 END"

703+-- CASE WHEN TRUE THEN 1 ELSE 0 END

615704ifThenElse

616− :: Condition relations grouping params

617− -> Expression relations grouping params (ty) -- ^ then

618− -> Expression relations grouping params (ty) -- ^ else

619− -> Expression relations grouping params (ty)

705+ :: Condition schema relations grouping params

706+ -> Expression schema relations grouping params (ty) -- ^ then

707+ -> Expression schema relations grouping params (ty) -- ^ else

708+ -> Expression schema relations grouping params (ty)

620709ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_

621710

622711-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`

623712-- will produce @NULL@s if one of their arguments is @NULL@.

624713--

625−-- >>> renderExpression $ unNull true .== null_

626−-- "(TRUE = NULL)"

714+-- >>> printSQL $ notNull true .== null_

715+-- (TRUE = NULL)

627716(.==)

628− :: Expression relations grouping params (nullity ty) -- ^ lhs

629− -> Expression relations grouping params (nullity ty) -- ^ rhs

630− -> Expression relations grouping params (nullity 'PGbool)

717+ :: Expression schema relations grouping params (nullity ty) -- ^ lhs

718+ -> Expression schema relations grouping params (nullity ty) -- ^ rhs

719+ -> Expression schema relations grouping params (nullity 'PGbool)

631720(.==) = unsafeBinaryOp "="

632721infix 4 .==

633722

634−-- | >>> renderExpression $ unNull true ./= null_

635−-- "(TRUE <> NULL)"

723+-- | >>> printSQL $ notNull true ./= null_

724+-- (TRUE <> NULL)

636725(./=)

637− :: Expression relations grouping params (nullity ty) -- ^ lhs

638− -> Expression relations grouping params (nullity ty) -- ^ rhs

639− -> Expression relations grouping params (nullity 'PGbool)

726+ :: Expression schema relations grouping params (nullity ty) -- ^ lhs

727+ -> Expression schema relations grouping params (nullity ty) -- ^ rhs

728+ -> Expression schema relations grouping params (nullity 'PGbool)

640729(./=) = unsafeBinaryOp "<>"

641730infix 4 ./=

642731

643−-- | >>> renderExpression $ unNull true .>= null_

644−-- "(TRUE >= NULL)"

732+-- | >>> printSQL $ notNull true .>= null_

733+-- (TRUE >= NULL)

645734(.>=)

646− :: Expression relations grouping params (nullity ty) -- ^ lhs

647− -> Expression relations grouping params (nullity ty) -- ^ rhs

648− -> Expression relations grouping params (nullity 'PGbool)

735+ :: Expression schema relations grouping params (nullity ty) -- ^ lhs

736+ -> Expression schema relations grouping params (nullity ty) -- ^ rhs

737+ -> Expression schema relations grouping params (nullity 'PGbool)

649738(.>=) = unsafeBinaryOp ">="

650739infix 4 .>=

651740

652−-- | >>> renderExpression $ unNull true .< null_

653−-- "(TRUE < NULL)"

741+-- | >>> printSQL $ notNull true .< null_

742+-- (TRUE < NULL)

654743(.<)

655− :: Expression relations grouping params (nullity ty) -- ^ lhs

656− -> Expression relations grouping params (nullity ty) -- ^ rhs

657− -> Expression relations grouping params (nullity 'PGbool)

744+ :: Expression schema relations grouping params (nullity ty) -- ^ lhs

745+ -> Expression schema relations grouping params (nullity ty) -- ^ rhs

746+ -> Expression schema relations grouping params (nullity 'PGbool)

658747(.<) = unsafeBinaryOp "<"

659748infix 4 .<

660749

661−-- | >>> renderExpression $ unNull true .<= null_

662−-- "(TRUE <= NULL)"

750+-- | >>> printSQL $ notNull true .<= null_

751+-- (TRUE <= NULL)

663752(.<=)

664− :: Expression relations grouping params (nullity ty) -- ^ lhs

665− -> Expression relations grouping params (nullity ty) -- ^ rhs

666− -> Expression relations grouping params (nullity 'PGbool)

753+ :: Expression schema relations grouping params (nullity ty) -- ^ lhs

754+ -> Expression schema relations grouping params (nullity ty) -- ^ rhs

755+ -> Expression schema relations grouping params (nullity 'PGbool)

667756(.<=) = unsafeBinaryOp "<="

668757infix 4 .<=

669758

670−-- | >>> renderExpression $ unNull true .> null_

671−-- "(TRUE > NULL)"

759+-- | >>> printSQL $ notNull true .> null_

760+-- (TRUE > NULL)

672761(.>)

673− :: Expression relations grouping params (nullity ty) -- ^ lhs

674− -> Expression relations grouping params (nullity ty) -- ^ rhs

675− -> Expression relations grouping params (nullity 'PGbool)

762+ :: Expression schema relations grouping params (nullity ty) -- ^ lhs

763+ -> Expression schema relations grouping params (nullity ty) -- ^ rhs

764+ -> Expression schema relations grouping params (nullity 'PGbool)

676765(.>) = unsafeBinaryOp ">"

677766infix 4 .>

678767

679−-- | >>> renderExpression currentDate

680−-- "CURRENT_DATE"

768+-- | >>> printSQL currentDate

769+-- CURRENT_DATE

681770currentDate

682− :: Expression relations grouping params (nullity 'PGdate)

771+ :: Expression schema relations grouping params (nullity 'PGdate)

683772currentDate = UnsafeExpression "CURRENT_DATE"

684773

685−-- | >>> renderExpression currentTime

686−-- "CURRENT_TIME"

774+-- | >>> printSQL currentTime

775+-- CURRENT_TIME

687776currentTime

688− :: Expression relations grouping params (nullity 'PGtimetz)

777+ :: Expression schema relations grouping params (nullity 'PGtimetz)

689778currentTime = UnsafeExpression "CURRENT_TIME"

690779

691−-- | >>> renderExpression currentTimestamp

692−-- "CURRENT_TIMESTAMP"

780+-- | >>> printSQL currentTimestamp

781+-- CURRENT_TIMESTAMP

693782currentTimestamp

694− :: Expression relations grouping params (nullity 'PGtimestamptz)

783+ :: Expression schema relations grouping params (nullity 'PGtimestamptz)

695784currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"

696785

697−-- | >>> renderExpression localTime

698−-- "LOCALTIME"

786+-- | >>> printSQL localTime

787+-- LOCALTIME

699788localTime

700− :: Expression relations grouping params (nullity 'PGtime)

789+ :: Expression schema relations grouping params (nullity 'PGtime)

701790localTime = UnsafeExpression "LOCALTIME"

702791

703−-- | >>> renderExpression localTimestamp

704−-- "LOCALTIMESTAMP"

792+-- | >>> printSQL localTimestamp

793+-- LOCALTIMESTAMP

705794localTimestamp

706− :: Expression relations grouping params (nullity 'PGtimestamp)

795+ :: Expression schema relations grouping params (nullity 'PGtimestamp)

707796localTimestamp = UnsafeExpression "LOCALTIMESTAMP"

708797

709798{-----------------------------------------

@@ -711,7 +800,7 @@ text

711800-----------------------------------------}

712801

713802instance IsString

714− (Expression relations grouping params (nullity 'PGtext)) where

803+ (Expression schema relations grouping params (nullity 'PGtext)) where

715804 fromString str = UnsafeExpression $

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

717806 where

@@ -726,33 +815,37 @@ instance IsString

726815 '\\' -> "\\\\"

727816 c -> [c]

728817

818+instance Semigroup

819+ (Expression schema relations grouping params (nullity 'PGtext)) where

820+ (<>) = unsafeBinaryOp "||"

821+

729822instance Monoid

730− (Expression relations grouping params (nullity 'PGtext)) where

823+ (Expression schema relations grouping params (nullity 'PGtext)) where

731824 mempty = fromString ""

732− mappend = unsafeBinaryOp "||"

825+ mappend = (<>)

733826

734−-- | >>> renderExpression $ lower "ARRRGGG"

735−-- "lower(E'ARRRGGG')"

827+-- | >>> printSQL $ lower "ARRRGGG"

828+-- lower(E'ARRRGGG')

736829lower

737− :: Expression relations grouping params (nullity 'PGtext)

830+ :: Expression schema relations grouping params (nullity 'PGtext)

738831 -- ^ string to lower case

739− -> Expression relations grouping params (nullity 'PGtext)

832+ -> Expression schema relations grouping params (nullity 'PGtext)

740833lower = unsafeFunction "lower"

741834

742−-- | >>> renderExpression $ upper "eeee"

743−-- "upper(E'eeee')"

835+-- | >>> printSQL $ upper "eeee"

836+-- upper(E'eeee')

744837upper

745− :: Expression relations grouping params (nullity 'PGtext)

838+ :: Expression schema relations grouping params (nullity 'PGtext)

746839 -- ^ string to upper case

747− -> Expression relations grouping params (nullity 'PGtext)

840+ -> Expression schema relations grouping params (nullity 'PGtext)

748841upper = unsafeFunction "upper"

749842

750−-- | >>> renderExpression $ charLength "four"

751−-- "char_length(E'four')"

843+-- | >>> printSQL $ charLength "four"

844+-- char_length(E'four')

752845charLength

753− :: Expression relations grouping params (nullity 'PGtext)

846+ :: Expression schema relations grouping params (nullity 'PGtext)

754847 -- ^ string to measure

755− -> Expression relations grouping params (nullity 'PGint4)

848+ -> Expression schema relations grouping params (nullity 'PGint4)

756849charLength = unsafeFunction "char_length"

757850

758851-- | The `like` expression returns true if the @string@ matches

@@ -762,14 +855,14 @@ charLength = unsafeFunction "char_length"

762855-- in pattern stands for (matches) any single character; a percent sign (%)

763856-- matches any sequence of zero or more characters.

764857--

765−-- >>> renderExpression $ "abc" `like` "a%"

766−-- "(E'abc' LIKE E'a%')"

858+-- >>> printSQL $ "abc" `like` "a%"

859+-- (E'abc' LIKE E'a%')

767860like

768− :: Expression relations grouping params (nullity 'PGtext)

861+ :: Expression schema relations grouping params (nullity 'PGtext)

769862 -- ^ string

770− -> Expression relations grouping params (nullity 'PGtext)

863+ -> Expression schema relations grouping params (nullity 'PGtext)

771864 -- ^ pattern

772− -> Expression relations grouping params (nullity 'PGbool)

865+ -> Expression schema relations grouping params (nullity 'PGbool)

773866like = unsafeBinaryOp "LIKE"

774867

775868{-----------------------------------------

@@ -779,54 +872,54 @@ aggregation

779872-- | escape hatch to define aggregate functions

780873unsafeAggregate

781874 :: ByteString -- ^ aggregate function

782− -> Expression relations 'Ungrouped params (xty)

783− -> Expression relations ('Grouped bys) params (yty)

875+ -> Expression schema relations 'Ungrouped params (xty)

876+ -> Expression schema relations ('Grouped bys) params (yty)

784877unsafeAggregate fun x = UnsafeExpression $ mconcat

785878 [fun, "(", renderExpression x, ")"]

786879

787880-- | escape hatch to define aggregate functions over distinct values

788881unsafeAggregateDistinct

789882 :: ByteString -- ^ aggregate function

790− -> Expression relations 'Ungrouped params (xty)

791− -> Expression relations ('Grouped bys) params (yty)

883+ -> Expression schema relations 'Ungrouped params (xty)

884+ -> Expression schema relations ('Grouped bys) params (yty)

792885unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat

793886 [fun, "(DISTINCT ", renderExpression x, ")"]

794887

795888-- | >>> :{

796889-- let

797−-- expression :: Expression '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric)

890+-- expression :: Expression schema '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric)

798891-- expression = sum_ #col

799−-- in renderExpression expression

892+-- in printSQL expression

800893-- :}

801−-- "sum(\"col\")"

894+-- sum("col")

802895sum_

803896 :: PGNum ty

804− => Expression relations 'Ungrouped params (nullity ty)

897+ => Expression schema relations 'Ungrouped params (nullity ty)

805898 -- ^ what to sum

806− -> Expression relations ('Grouped bys) params (nullity ty)

899+ -> Expression schema relations ('Grouped bys) params (nullity ty)

807900sum_ = unsafeAggregate "sum"

808901

809902-- | >>> :{

810903-- let

811−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric)

904+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric)

812905-- expression = sumDistinct #col

813−-- in renderExpression expression

906+-- in printSQL expression

814907-- :}

815−-- "sum(DISTINCT \"col\")"

908+-- sum(DISTINCT "col")

816909sumDistinct

817910 :: PGNum ty

818− => Expression relations 'Ungrouped params (nullity ty)

911+ => Expression schema relations 'Ungrouped params (nullity ty)

819912 -- ^ what to sum

820− -> Expression relations ('Grouped bys) params (nullity ty)

913+ -> Expression schema relations ('Grouped bys) params (nullity ty)

821914sumDistinct = unsafeAggregateDistinct "sum"

822915

823916-- | A constraint for `PGType`s that you can take averages of and the resulting

824917-- `PGType`.

825918class PGAvg ty avg | ty -> avg where

826919 avg, avgDistinct

827− :: Expression relations 'Ungrouped params (nullity ty)

920+ :: Expression schema relations 'Ungrouped params (nullity ty)

828921 -- ^ what to average

829− -> Expression relations ('Grouped bys) params (nullity avg)

922+ -> Expression schema relations ('Grouped bys) params (nullity avg)

830923 avg = unsafeAggregate "avg"

831924 avgDistinct = unsafeAggregateDistinct "avg"

832925instance PGAvg 'PGint2 'PGnumeric

@@ -839,312 +932,281 @@ instance PGAvg 'PGinterval 'PGinterval

839932

840933-- | >>> :{

841934-- let

842−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

935+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

843936-- expression = bitAnd #col

844−-- in renderExpression expression

937+-- in printSQL expression

845938-- :}

846−-- "bit_and(\"col\")"

939+-- bit_and("col")

847940bitAnd

848941 :: PGIntegral int

849− => Expression relations 'Ungrouped params (nullity int)

942+ => Expression schema relations 'Ungrouped params (nullity int)

850943 -- ^ what to aggregate

851− -> Expression relations ('Grouped bys) params (nullity int)

944+ -> Expression schema relations ('Grouped bys) params (nullity int)

852945bitAnd = unsafeAggregate "bit_and"

853946

854947-- | >>> :{

855948-- let

856−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

949+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

857950-- expression = bitOr #col

858−-- in renderExpression expression

951+-- in printSQL expression

859952-- :}

860−-- "bit_or(\"col\")"

953+-- bit_or("col")

861954bitOr

862955 :: PGIntegral int

863− => Expression relations 'Ungrouped params (nullity int)

956+ => Expression schema relations 'Ungrouped params (nullity int)

864957 -- ^ what to aggregate

865− -> Expression relations ('Grouped bys) params (nullity int)

958+ -> Expression schema relations ('Grouped bys) params (nullity int)

866959bitOr = unsafeAggregate "bit_or"

867960

868961-- | >>> :{

869962-- let

870−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

963+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

871964-- expression = bitAndDistinct #col

872−-- in renderExpression expression

965+-- in printSQL expression

873966-- :}

874−-- "bit_and(DISTINCT \"col\")"

967+-- bit_and(DISTINCT "col")

875968bitAndDistinct

876969 :: PGIntegral int

877− => Expression relations 'Ungrouped params (nullity int)

970+ => Expression schema relations 'Ungrouped params (nullity int)

878971 -- ^ what to aggregate

879− -> Expression relations ('Grouped bys) params (nullity int)

972+ -> Expression schema relations ('Grouped bys) params (nullity int)

880973bitAndDistinct = unsafeAggregateDistinct "bit_and"

881974

882975-- | >>> :{

883976-- let

884−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

977+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

885978-- expression = bitOrDistinct #col

886−-- in renderExpression expression

979+-- in printSQL expression

887980-- :}

888−-- "bit_or(DISTINCT \"col\")"

981+-- bit_or(DISTINCT "col")

889982bitOrDistinct

890983 :: PGIntegral int

891− => Expression relations 'Ungrouped params (nullity int)

984+ => Expression schema relations 'Ungrouped params (nullity int)

892985 -- ^ what to aggregate

893− -> Expression relations ('Grouped bys) params (nullity int)

986+ -> Expression schema relations ('Grouped bys) params (nullity int)

894987bitOrDistinct = unsafeAggregateDistinct "bit_or"

895988

896989-- | >>> :{

897990-- let

898−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

991+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

899992-- expression = boolAnd #col

900−-- in renderExpression expression

993+-- in printSQL expression

901994-- :}

902−-- "bool_and(\"col\")"

995+-- bool_and("col")

903996boolAnd

904− :: Expression relations 'Ungrouped params (nullity 'PGbool)

997+ :: Expression schema relations 'Ungrouped params (nullity 'PGbool)

905998 -- ^ what to aggregate

906− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

999+ -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)

9071000boolAnd = unsafeAggregate "bool_and"

9081001

9091002-- | >>> :{

9101003-- let

911−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

1004+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

9121005-- expression = boolOr #col

913−-- in renderExpression expression

1006+-- in printSQL expression

9141007-- :}

915−-- "bool_or(\"col\")"

1008+-- bool_or("col")

9161009boolOr

917− :: Expression relations 'Ungrouped params (nullity 'PGbool)

1010+ :: Expression schema relations 'Ungrouped params (nullity 'PGbool)

9181011 -- ^ what to aggregate

919− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

1012+ -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)

9201013boolOr = unsafeAggregate "bool_or"

9211014

9221015-- | >>> :{

9231016-- let

924−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

1017+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

9251018-- expression = boolAndDistinct #col

926−-- in renderExpression expression

1019+-- in printSQL expression

9271020-- :}

928−-- "bool_and(DISTINCT \"col\")"

1021+-- bool_and(DISTINCT "col")

9291022boolAndDistinct

930− :: Expression relations 'Ungrouped params (nullity 'PGbool)

1023+ :: Expression schema relations 'Ungrouped params (nullity 'PGbool)

9311024 -- ^ what to aggregate

932− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

1025+ -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)

9331026boolAndDistinct = unsafeAggregateDistinct "bool_and"

9341027

9351028-- | >>> :{

9361029-- let

937−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

1030+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

9381031-- expression = boolOrDistinct #col

939−-- in renderExpression expression

1032+-- in printSQL expression

9401033-- :}

941−-- "bool_or(DISTINCT \"col\")"

1034+-- bool_or(DISTINCT "col")

9421035boolOrDistinct

943− :: Expression relations 'Ungrouped params (nullity 'PGbool)

1036+ :: Expression schema relations 'Ungrouped params (nullity 'PGbool)

9441037 -- ^ what to aggregate

945− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

1038+ -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)

9461039boolOrDistinct = unsafeAggregateDistinct "bool_or"

9471040

9481041-- | A special aggregation that does not require an input

9491042--

950−-- >>> renderExpression countStar

951−-- "count(*)"

1043+-- >>> printSQL countStar

1044+-- count(*)

9521045countStar

953− :: Expression relations ('Grouped bys) params ('NotNull 'PGint8)

1046+ :: Expression schema relations ('Grouped bys) params ('NotNull 'PGint8)

9541047countStar = UnsafeExpression $ "count(*)"

9551048

9561049-- | >>> :{

9571050-- let

958−-- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)

1051+-- expression :: Expression schema '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)

9591052-- expression = count #col

960−-- in renderExpression expression

1053+-- in printSQL expression

9611054-- :}

962−-- "count(\"col\")"

1055+-- count("col")

9631056count

964− :: Expression relations 'Ungrouped params ty

1057+ :: Expression schema relations 'Ungrouped params ty

9651058 -- ^ what to count

966− -> Expression relations ('Grouped bys) params ('NotNull 'PGint8)

1059+ -> Expression schema relations ('Grouped bys) params ('NotNull 'PGint8)

9671060count = unsafeAggregate "count"

9681061

9691062-- | >>> :{

9701063-- let

971−-- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)

1064+-- expression :: Expression schema '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)

9721065-- expression = countDistinct #col

973−-- in renderExpression expression

1066+-- in printSQL expression

9741067-- :}

975−-- "count(DISTINCT \"col\")"

1068+-- count(DISTINCT "col")

9761069countDistinct

977− :: Expression relations 'Ungrouped params ty

1070+ :: Expression schema relations 'Ungrouped params ty

9781071 -- ^ what to count

979− -> Expression relations ('Grouped bys) params ('NotNull 'PGint8)

1072+ -> Expression schema relations ('Grouped bys) params ('NotNull 'PGint8)

9801073countDistinct = unsafeAggregateDistinct "count"

9811074

9821075-- | synonym for `boolAnd`

9831076--

9841077-- >>> :{

9851078-- let

986−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

1079+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

9871080-- expression = every #col

988−-- in renderExpression expression

1081+-- in printSQL expression

9891082-- :}

990−-- "every(\"col\")"

1083+-- every("col")

9911084every

992− :: Expression relations 'Ungrouped params (nullity 'PGbool)

1085+ :: Expression schema relations 'Ungrouped params (nullity 'PGbool)

9931086 -- ^ what to aggregate

994− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

1087+ -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)

9951088every = unsafeAggregate "every"

9961089

9971090-- | synonym for `boolAndDistinct`

9981091--

9991092-- >>> :{

10001093-- let

1001−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

1094+-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

10021095-- expression = everyDistinct #col

1003−-- in renderExpression expression

1096+-- in printSQL expression

10041097-- :}

1005−-- "every(DISTINCT \"col\")"

1098+-- every(DISTINCT "col")

10061099everyDistinct

1007− :: Expression relations 'Ungrouped params (nullity 'PGbool)

1100+ :: Expression schema relations 'Ungrouped params (nullity 'PGbool)

10081101 -- ^ what to aggregate

1009− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

1102+ -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)

10101103everyDistinct = unsafeAggregateDistinct "every"

10111104

10121105-- | minimum and maximum aggregation

10131106max_, min_, maxDistinct, minDistinct

1014− :: Expression relations 'Ungrouped params (nullity ty)

1107+ :: Expression schema relations 'Ungrouped params (nullity ty)

10151108 -- ^ what to aggregate

1016− -> Expression relations ('Grouped bys) params (nullity ty)

1109+ -> Expression schema relations ('Grouped bys) params (nullity ty)

10171110max_ = unsafeAggregate "max"

10181111min_ = unsafeAggregate "min"

10191112maxDistinct = unsafeAggregateDistinct "max"

10201113minDistinct = unsafeAggregateDistinct "min"

10211114

1022−{-----------------------------------------

1023−tables

1024−-----------------------------------------}

1025−

1026−-- | A `Table` from a table expression is a way

1027−-- to call a table reference by its alias.

1028−newtype Table

1029− (schema :: TablesType)

1030− (columns :: RelationType)

1031− = UnsafeTable { renderTable :: ByteString }

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

1033−instance

1034− ( Has alias schema table

1035− , relation ~ ColumnsToRelation (TableToColumns table)

1036− ) => IsLabel alias (Table schema relation) where

1037− fromLabel = UnsafeTable $ renderAlias (Alias @alias)

1038−

10391115{-----------------------------------------

10401116type expressions

10411117-----------------------------------------}

10421118

10431119-- | `TypeExpression`s are used in `cast`s and `createTable` commands.

1044−newtype TypeExpression (ty :: ColumnType)

1120+newtype TypeExpression (schema :: SchemaType) (ty :: PGType)

10451121 = UnsafeTypeExpression { renderTypeExpression :: ByteString }

10461122 deriving (GHC.Generic,Show,Eq,Ord,NFData)

10471123

1124+instance (Has alias schema ('Typedef ty))

1125+ => IsLabel alias (TypeExpression schema ty) where

1126+ fromLabel = UnsafeTypeExpression (renderAlias (fromLabel @alias))

1127+

10481128-- | logical Boolean (true/false)

1049−bool :: TypeExpression ('NoDef :=> 'Null 'PGbool)

1129+bool :: TypeExpression schema 'PGbool

10501130bool = UnsafeTypeExpression "bool"

10511131-- | signed two-byte integer

1052−int2, smallint :: TypeExpression ('NoDef :=> 'Null 'PGint2)

1132+int2, smallint :: TypeExpression schema 'PGint2

10531133int2 = UnsafeTypeExpression "int2"

10541134smallint = UnsafeTypeExpression "smallint"

10551135-- | signed four-byte integer

1056−int4, int, integer :: TypeExpression ('NoDef :=> 'Null 'PGint4)

1136+int4, int, integer :: TypeExpression schema 'PGint4

10571137int4 = UnsafeTypeExpression "int4"

10581138int = UnsafeTypeExpression "int"

10591139integer = UnsafeTypeExpression "integer"

10601140-- | signed eight-byte integer

1061−int8, bigint :: TypeExpression ('NoDef :=> 'Null 'PGint8)

1141+int8, bigint :: TypeExpression schema 'PGint8

10621142int8 = UnsafeTypeExpression "int8"

10631143bigint = UnsafeTypeExpression "bigint"

10641144-- | arbitrary precision numeric type

1065−numeric :: TypeExpression ('NoDef :=> 'Null 'PGnumeric)

1145+numeric :: TypeExpression schema 'PGnumeric

10661146numeric = UnsafeTypeExpression "numeric"

10671147-- | single precision floating-point number (4 bytes)

1068−float4, real :: TypeExpression ('NoDef :=> 'Null 'PGfloat4)

1148+float4, real :: TypeExpression schema 'PGfloat4

10691149float4 = UnsafeTypeExpression "float4"

10701150real = UnsafeTypeExpression "real"

10711151-- | double precision floating-point number (8 bytes)

1072−float8, doublePrecision :: TypeExpression ('NoDef :=> 'Null 'PGfloat8)

1152+float8, doublePrecision :: TypeExpression schema 'PGfloat8

10731153float8 = UnsafeTypeExpression "float8"

10741154doublePrecision = UnsafeTypeExpression "double precision"

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

1076−-- unique identifier columns with type `'PGint2`

1077−serial2, smallserial

1078− :: TypeExpression ('Def :=> 'NotNull 'PGint2)

1079−serial2 = UnsafeTypeExpression "serial2"

1080−smallserial = UnsafeTypeExpression "smallserial"

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

1082−-- unique identifier columns with type `'PGint4`

1083−serial4, serial

1084− :: TypeExpression ('Def :=> 'NotNull 'PGint4)

1085−serial4 = UnsafeTypeExpression "serial4"

1086−serial = UnsafeTypeExpression "serial"

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

1088−-- unique identifier columns with type `'PGint8`

1089−serial8, bigserial

1090− :: TypeExpression ('Def :=> 'NotNull 'PGint8)

1091−serial8 = UnsafeTypeExpression "serial8"

1092−bigserial = UnsafeTypeExpression "bigserial"

10931155-- | variable-length character string

1094−text :: TypeExpression ('NoDef :=> 'Null 'PGtext)

1156+text :: TypeExpression schema 'PGtext

10951157text = UnsafeTypeExpression "text"

10961158-- | fixed-length character string

10971159char, character

10981160 :: (KnownNat n, 1 <= n)

10991161 => proxy n

1100− -> TypeExpression ('NoDef :=> 'Null ('PGchar n))

1162+ -> TypeExpression schema ('PGchar n)

11011163char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"

11021164character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"

11031165-- | variable-length character string

11041166varchar, characterVarying

11051167 :: (KnownNat n, 1 <= n)

11061168 => proxy n

1107− -> TypeExpression ('NoDef :=> 'Null ('PGvarchar n))

1169+ -> TypeExpression schema ('PGvarchar n)

11081170varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"

11091171characterVarying p = UnsafeTypeExpression $

11101172 "character varying(" <> renderNat p <> ")"

11111173-- | binary data ("byte array")

1112−bytea :: TypeExpression ('NoDef :=> 'Null 'PGbytea)

1174+bytea :: TypeExpression schema 'PGbytea

11131175bytea = UnsafeTypeExpression "bytea"

11141176-- | date and time (no time zone)

1115−timestamp :: TypeExpression ('NoDef :=> 'Null 'PGtimestamp)

1177+timestamp :: TypeExpression schema 'PGtimestamp

11161178timestamp = UnsafeTypeExpression "timestamp"

11171179-- | date and time, including time zone

1118−timestampWithTimeZone :: TypeExpression ('NoDef :=> 'Null 'PGtimestamptz)

1180+timestampWithTimeZone :: TypeExpression schema 'PGtimestamptz

11191181timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

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

1121−date :: TypeExpression ('NoDef :=> 'Null 'PGdate)

1183+date :: TypeExpression schema 'PGdate

11221184date = UnsafeTypeExpression "date"

11231185-- | time of day (no time zone)

1124−time :: TypeExpression ('NoDef :=> 'Null 'PGtime)

1186+time :: TypeExpression schema 'PGtime

11251187time = UnsafeTypeExpression "time"

11261188-- | time of day, including time zone

1127−timeWithTimeZone :: TypeExpression ('NoDef :=> 'Null 'PGtimetz)

1189+timeWithTimeZone :: TypeExpression schema 'PGtimetz

11281190timeWithTimeZone = UnsafeTypeExpression "time with time zone"

11291191-- | time span

1130−interval :: TypeExpression ('NoDef :=> 'Null 'PGinterval)

1192+interval :: TypeExpression schema 'PGinterval

11311193interval = UnsafeTypeExpression "interval"

11321194-- | universally unique identifier

1133−uuid :: TypeExpression ('NoDef :=> 'Null 'PGuuid)

1195+uuid :: TypeExpression schema 'PGuuid

11341196uuid = UnsafeTypeExpression "uuid"

11351197-- | IPv4 or IPv6 host address

1136−inet :: TypeExpression ('NoDef :=> 'Null 'PGinet)

1198+inet :: TypeExpression schema 'PGinet

11371199inet = UnsafeTypeExpression "inet"

11381200-- | textual JSON data

1139−json :: TypeExpression ('NoDef :=> 'Null 'PGjson)

1201+json :: TypeExpression schema 'PGjson

11401202json = UnsafeTypeExpression "json"

11411203-- | binary JSON data, decomposed

1142−jsonb :: TypeExpression ('NoDef :=> 'Null 'PGjsonb)

1204+jsonb :: TypeExpression schema 'PGjsonb

11431205jsonb = UnsafeTypeExpression "jsonb"

11441206-- | variable length array

11451207vararray

1146− :: TypeExpression ('NoDef :=> 'Null pg)

1147− -> TypeExpression ('NoDef :=> 'Null ('PGvararray pg))

1208+ :: TypeExpression schema pg

1209+ -> TypeExpression schema ('PGvararray pg)

11481210vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"

11491211-- | fixed length array

11501212--

@@ -1153,52 +1215,36 @@ vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"

11531215fixarray

11541216 :: KnownNat n

11551217 => proxy n

1156− -> TypeExpression ('NoDef :=> 'Null pg)

1157− -> TypeExpression ('NoDef :=> 'Null ('PGfixarray n pg))

1218+ -> TypeExpression schema pg

1219+ -> TypeExpression schema ('PGfixarray n pg)

11581220fixarray p ty = UnsafeTypeExpression $

11591221 renderTypeExpression ty <> "[" <> renderNat p <> "]"

11601222

1161−-- | used in `createTable` commands as a column constraint to ensure

1162−-- @NULL@ is not present

1163−notNull

1164− :: TypeExpression (def :=> 'Null ty)

1165− -> TypeExpression (def :=> 'NotNull ty)

1166−notNull ty = UnsafeTypeExpression $ renderTypeExpression ty <+> "NOT NULL"

1167−

1168−-- | used in `createTable` commands as a column constraint to give a default

1169−default_

1170− :: Expression '[] 'Ungrouped '[] ty

1171− -> TypeExpression ('NoDef :=> ty)

1172− -> TypeExpression ('Def :=> ty)

1173−default_ x ty = UnsafeTypeExpression $

1174− renderTypeExpression ty <+> "DEFAULT" <+> renderExpression x

1175−

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

1177−class PGTyped (ty :: PGType) where

1178− pgtype :: TypeExpression ('NoDef :=> 'Null ty)

1179−instance PGTyped 'PGbool where pgtype = bool

1180−instance PGTyped 'PGint2 where pgtype = int2

1181−instance PGTyped 'PGint4 where pgtype = int4

1182−instance PGTyped 'PGint8 where pgtype = int8

1183−instance PGTyped 'PGnumeric where pgtype = numeric

1184−instance PGTyped 'PGfloat4 where pgtype = float4

1185−instance PGTyped 'PGfloat8 where pgtype = float8

1186−instance PGTyped 'PGtext where pgtype = text

1224+class PGTyped schema (ty :: PGType) where pgtype :: TypeExpression schema ty

1225+instance PGTyped schema 'PGbool where pgtype = bool

1226+instance PGTyped schema 'PGint2 where pgtype = int2

1227+instance PGTyped schema 'PGint4 where pgtype = int4

1228+instance PGTyped schema 'PGint8 where pgtype = int8

1229+instance PGTyped schema 'PGnumeric where pgtype = numeric

1230+instance PGTyped schema 'PGfloat4 where pgtype = float4

1231+instance PGTyped schema 'PGfloat8 where pgtype = float8

1232+instance PGTyped schema 'PGtext where pgtype = text

11871233instance (KnownNat n, 1 <= n)

1188− => PGTyped ('PGchar n) where pgtype = char (Proxy @n)

1234+ => PGTyped schema ('PGchar n) where pgtype = char (Proxy @n)

11891235instance (KnownNat n, 1 <= n)

1190− => PGTyped ('PGvarchar n) where pgtype = varchar (Proxy @n)

1191−instance PGTyped 'PGbytea where pgtype = bytea

1192−instance PGTyped 'PGtimestamp where pgtype = timestamp

1193−instance PGTyped 'PGtimestamptz where pgtype = timestampWithTimeZone

1194−instance PGTyped 'PGdate where pgtype = date

1195−instance PGTyped 'PGtime where pgtype = time

1196−instance PGTyped 'PGtimetz where pgtype = timeWithTimeZone

1197−instance PGTyped 'PGinterval where pgtype = interval

1198−instance PGTyped 'PGuuid where pgtype = uuid

1199−instance PGTyped 'PGjson where pgtype = json

1200−instance PGTyped 'PGjsonb where pgtype = jsonb

1201−instance PGTyped ty => PGTyped ('PGvararray ty) where

1202− pgtype = vararray (pgtype @ty)

1203−instance (KnownNat n, PGTyped ty) => PGTyped ('PGfixarray n ty) where

1204− pgtype = fixarray (Proxy @n) (pgtype @ty)

1236+ => PGTyped schema ('PGvarchar n) where pgtype = varchar (Proxy @n)

1237+instance PGTyped schema 'PGbytea where pgtype = bytea

1238+instance PGTyped schema 'PGtimestamp where pgtype = timestamp

1239+instance PGTyped schema 'PGtimestamptz where pgtype = timestampWithTimeZone

1240+instance PGTyped schema 'PGdate where pgtype = date

1241+instance PGTyped schema 'PGtime where pgtype = time

1242+instance PGTyped schema 'PGtimetz where pgtype = timeWithTimeZone

1243+instance PGTyped schema 'PGinterval where pgtype = interval

1244+instance PGTyped schema 'PGuuid where pgtype = uuid

1245+instance PGTyped schema 'PGjson where pgtype = json

1246+instance PGTyped schema 'PGjsonb where pgtype = jsonb

1247+instance PGTyped schema ty => PGTyped schema ('PGvararray ty) where

1248+ pgtype = vararray (pgtype @schema @ty)

1249+instance (KnownNat n, PGTyped schema ty) => PGTyped schema ('PGfixarray n ty) where

1250+ pgtype = fixarray (Proxy @n) (pgtype @schema @ty)

squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+107−112

@@ -9,17 +9,13 @@ Squeal data manipulation language.

99-}

1010

1111{-# LANGUAGE

12− DataKinds

13− , DeriveDataTypeable

14− , DeriveGeneric

12+ DeriveGeneric

1513 , FlexibleContexts

1614 , GADTs

1715 , GeneralizedNewtypeDeriving

18− , KindSignatures

1916 , LambdaCase

2017 , OverloadedStrings

2118 , RankNTypes

22− , StandaloneDeriving

2319 , TypeInType

2420 , TypeOperators

2521#-}

@@ -54,7 +50,6 @@ import Control.DeepSeq

5450import Data.ByteString hiding (foldr)

5551import Data.Monoid

5652

57−import qualified Data.ByteString as ByteString

5853import qualified Generics.SOP as SOP

5954import qualified GHC.Generics as GHC

6055

@@ -73,55 +68,55 @@ simple insert:

7368>>> :{

7469let

7570 manipulation :: Manipulation

76− '[ "tab" ::: '[] :=>

71+ '[ "tab" ::: 'Table ('[] :=>

7772 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

78− , "col2" ::: 'Def :=> 'NotNull 'PGint4 ]] '[] '[]

73+ , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[] '[]

7974 manipulation =

8075 insertRow_ #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil)

81−in renderManipulation manipulation

76+in printSQL manipulation

8277:}

83−"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT);"

78+INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)

8479

8580parameterized insert:

8681

8782>>> :{

8883let

8984 manipulation :: Manipulation

90− '[ "tab" ::: '[] :=>

85+ '[ "tab" ::: 'Table ('[] :=>

9186 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

92− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]

87+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]

9388 '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]

9489 manipulation =

9590 insertRow_ #tab

9691 (Set (param @1) `As` #col1 :* Set (param @2) `As` #col2 :* Nil)

97−in renderManipulation manipulation

92+in printSQL manipulation

9893:}

99−"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (($1 :: int4), ($2 :: int4));"

94+INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))

10095

10196returning insert:

10297

10398>>> :{

10499let

105100 manipulation :: Manipulation

106− '[ "tab" ::: '[] :=>

101+ '[ "tab" ::: 'Table ('[] :=>

107102 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

108− , "col2" ::: 'Def :=> 'NotNull 'PGint4 ]] '[]

103+ , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[]

109104 '["fromOnly" ::: 'NotNull 'PGint4]

110105 manipulation =

111106 insertRow #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil)

112107 OnConflictDoRaise (Returning (#col1 `As` #fromOnly :* Nil))

113−in renderManipulation manipulation

108+in printSQL manipulation

114109:}

115−"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT) RETURNING \"col1\" AS \"fromOnly\";"

110+INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT) RETURNING "col1" AS "fromOnly"

116111

117112upsert:

118113

119114>>> :{

120115let

121116 manipulation :: Manipulation

122− '[ "tab" ::: '[] :=>

117+ '[ "tab" ::: 'Table ('[] :=>

123118 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

124− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]

119+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]

125120 '[] '[ "sum" ::: 'NotNull 'PGint4]

126121 manipulation =

127122 insertRows #tab

@@ -131,73 +126,76 @@ let

131126 (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)

132127 [#col1 .== #col2])

133128 (Returning $ (#col1 + #col2) `As` #sum :* Nil)

134−in renderManipulation manipulation

129+in printSQL manipulation

135130:}

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\";"

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

137132

138133query insert:

139134

140135>>> :{

141136let

142137 manipulation :: Manipulation

143− '[ "tab" ::: '[] :=>

138+ '[ "tab" ::: 'Table ('[] :=>

144139 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

145140 , "col2" ::: 'NoDef :=> 'NotNull 'PGint4

146− ]

147− , "other_tab" ::: '[] :=>

141+ ])

142+ , "other_tab" ::: 'Table ('[] :=>

148143 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

149144 , "col2" ::: 'NoDef :=> 'NotNull 'PGint4

150− ]

145+ ])

151146 ] '[] '[]

152− manipulation =

147+ manipulation =

153148 insertQuery_ #tab

154149 (selectStar (from (table (#other_tab `As` #t))))

155−in renderManipulation manipulation

150+in printSQL manipulation

156151:}

157−"INSERT INTO \"tab\" SELECT * FROM \"other_tab\" AS \"t\";"

152+INSERT INTO "tab" SELECT * FROM "other_tab" AS "t"

158153

159154update:

160155

161156>>> :{

162157let

163158 manipulation :: Manipulation

164− '[ "tab" ::: '[] :=>

159+ '[ "tab" ::: 'Table ('[] :=>

165160 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

166− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[] '[]

161+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[]

167162 manipulation =

168163 update_ #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)

169164 (#col1 ./= #col2)

170−in renderManipulation manipulation

165+in printSQL manipulation

171166:}

172−"UPDATE \"tab\" SET \"col1\" = 2 WHERE (\"col1\" <> \"col2\");"

167+UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")

173168

174169delete:

175170

176171>>> :{

177172let

178173 manipulation :: Manipulation

179− '[ "tab" ::: '[] :=>

174+ '[ "tab" ::: 'Table ('[] :=>

180175 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

181− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[]

176+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[]

182177 '[ "col1" ::: 'NotNull 'PGint4

183178 , "col2" ::: 'NotNull 'PGint4 ]

184179 manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar

185−in renderManipulation manipulation

180+in printSQL manipulation

186181:}

187−"DELETE FROM \"tab\" WHERE (\"col1\" = \"col2\") RETURNING *;"

182+DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING *

188183-}

189184newtype Manipulation

190− (schema :: TablesType)

185+ (schema :: SchemaType)

191186 (params :: [NullityType])

192187 (columns :: RelationType)

193188 = UnsafeManipulation { renderManipulation :: ByteString }

194189 deriving (GHC.Generic,Show,Eq,Ord,NFData)

195190

191+instance RenderSQL (Manipulation schema params columns) where

192+ renderSQL = renderManipulation

193+

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

197195queryStatement

198196 :: Query schema params columns

199197 -> Manipulation schema params columns

200−queryStatement q = UnsafeManipulation $ renderQuery q <> ";"

198+queryStatement q = UnsafeManipulation $ renderQuery q

201199

202200{-----------------------------------------

203201INSERT statements

@@ -213,27 +211,27 @@ INSERT statements

213211insertRows

214212 :: ( SOP.SListI columns

215213 , SOP.SListI results

216− , Has tab schema table

214+ , Has tab schema ('Table table)

217215 , columns ~ TableToColumns table )

218216 => 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

217+ -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert

218+ -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert

219+ -> ConflictClause schema columns params

222220 -- ^ what to do in case of constraint conflict

223− -> ReturningClause columns params results -- ^ results to return

221+ -> ReturningClause schema columns params results -- ^ results to return

224222 -> Manipulation schema params results

225−insertRows tab row rows conflict returning = UnsafeManipulation $

223+insertRows tab rw rws conflict returning = UnsafeManipulation $

226224 "INSERT" <+> "INTO" <+> renderAlias tab

227− <+> parenthesized (renderCommaSeparated renderAliasPart row)

225+ <+> parenthesized (renderCommaSeparated renderAliasPart rw)

228226 <+> "VALUES"

229227 <+> commaSeparated

230228 ( parenthesized

231− . renderCommaSeparated renderColumnValuePart <$> row:rows )

229+ . renderCommaSeparated renderColumnValuePart <$> rw:rws )

232230 <> renderConflictClause conflict

233231 <> renderReturningClause returning

234232 where

235233 renderAliasPart, renderColumnValuePart

236− :: Aliased (ColumnValue '[] params) ty -> ByteString

234+ :: Aliased (ColumnValue schema '[] params) ty -> ByteString

237235 renderAliasPart (_ `As` name) = renderAlias name

238236 renderColumnValuePart (value `As` _) = case value of

239237 Default -> "DEFAULT"

@@ -243,49 +241,49 @@ insertRows tab row rows conflict returning = UnsafeManipulation $

243241insertRow

244242 :: ( SOP.SListI columns

245243 , SOP.SListI results

246− , Has tab schema table

244+ , Has tab schema ('Table table)

247245 , columns ~ TableToColumns table )

248246 => Alias tab -- ^ table to insert into

249− -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert

250− -> ConflictClause columns params

247+ -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert

248+ -> ConflictClause schema columns params

251249 -- ^ what to do in case of constraint conflict

252− -> ReturningClause columns params results -- ^ results to return

250+ -> ReturningClause schema columns params results -- ^ results to return

253251 -> Manipulation schema params results

254−insertRow tab row = insertRows tab row []

252+insertRow tab rw = insertRows tab rw []

255253

256254-- | Insert multiple rows returning `Nil` and raising an error on conflicts.

257255insertRows_

258256 :: ( SOP.SListI columns

259− , Has tab schema table

257+ , Has tab schema ('Table table)

260258 , columns ~ TableToColumns table )

261259 => 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

260+ -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert

261+ -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert

264262 -> Manipulation schema params '[]

265−insertRows_ tab row rows =

266− insertRows tab row rows OnConflictDoRaise (Returning Nil)

263+insertRows_ tab rw rws =

264+ insertRows tab rw rws OnConflictDoRaise (Returning Nil)

267265

268266-- | Insert a single row returning `Nil` and raising an error on conflicts.

269267insertRow_

270268 :: ( SOP.SListI columns

271− , Has tab schema table

269+ , Has tab schema ('Table table)

272270 , columns ~ TableToColumns table )

273271 => Alias tab -- ^ table to insert into

274− -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert

272+ -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert

275273 -> Manipulation schema params '[]

276−insertRow_ tab row = insertRow tab row OnConflictDoRaise (Returning Nil)

274+insertRow_ tab rw = insertRow tab rw OnConflictDoRaise (Returning Nil)

277275

278276-- | Insert a `Query`.

279277insertQuery

280278 :: ( SOP.SListI columns

281279 , SOP.SListI results

282− , Has tab schema table

280+ , Has tab schema ('Table table)

283281 , columns ~ TableToColumns table )

284282 => Alias tab -- ^ table to insert into

285283 -> Query schema params (ColumnsToRelation columns)

286− -> ConflictClause columns params

284+ -> ConflictClause schema columns params

287285 -- ^ what to do in case of constraint conflict

288− -> ReturningClause columns params results -- ^ results to return

286+ -> ReturningClause schema columns params results -- ^ results to return

289287 -> Manipulation schema params results

290288insertQuery tab query conflict returning = UnsafeManipulation $

291289 "INSERT" <+> "INTO" <+> renderAlias tab

@@ -296,7 +294,7 @@ insertQuery tab query conflict returning = UnsafeManipulation $

296294-- | Insert a `Query` returning `Nil` and raising an error on conflicts.

297295insertQuery_

298296 :: ( SOP.SListI columns

299− , Has tab schema table

297+ , Has tab schema ('Table table)

300298 , columns ~ TableToColumns table )

301299 => Alias tab -- ^ table to insert into

302300 -> Query schema params (ColumnsToRelation columns)

@@ -304,21 +302,22 @@ insertQuery_

304302insertQuery_ tab query =

305303 insertQuery tab query OnConflictDoRaise (Returning Nil)

306304

307−-- | `ColumnValue`s are values to insert or update in a row

305+-- | `ColumnValue`s are values to insert or update in a row.

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

307+-- `Default` inserts or updates with the @DEFAULT@ value.

308+-- `Set` sets a value to be an `Expression`, which can refer to

309+-- existing value in the row for an update.

312310data ColumnValue

311+ (schema :: SchemaType)

313312 (columns :: RelationType)

314313 (params :: [NullityType])

315314 (ty :: ColumnType)

316315 where

317− Same :: ColumnValue (column ': columns) params ty

318− Default :: ColumnValue columns params ('Def :=> ty)

316+ Same :: ColumnValue schema (column ': columns) params ty

317+ Default :: ColumnValue schema columns params ('Def :=> ty)

319318 Set

320− :: (forall table. Expression '[table ::: columns] 'Ungrouped params ty)

321− -> ColumnValue columns params (constraint :=> ty)

319+ :: (forall table. Expression schema '[table ::: columns] 'Ungrouped params ty)

320+ -> ColumnValue schema columns params (constraint :=> ty)

322321

323322-- | A `ReturningClause` computes and return value(s) based

324323-- on each row actually inserted, updated or deleted. This is primarily

@@ -331,46 +330,47 @@ data ColumnValue

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

332331-- values are desired.

333332data ReturningClause

333+ (schema :: SchemaType)

334334 (columns :: ColumnsType)

335335 (params :: [NullityType])

336336 (results :: RelationType)

337337 where

338338 ReturningStar

339339 :: results ~ ColumnsToRelation columns

340− => ReturningClause columns params results

340+ => ReturningClause schema columns params results

341341 Returning

342342 :: rel ~ ColumnsToRelation columns

343− => NP (Aliased (Expression '[table ::: rel] 'Ungrouped params)) results

344− -> ReturningClause columns params results

343+ => NP (Aliased (Expression schema '[table ::: rel] 'Ungrouped params)) results

344+ -> ReturningClause schema columns params results

345345

346346-- | Render a `ReturningClause`.

347347renderReturningClause

348348 :: SOP.SListI results

349− => ReturningClause params columns results

349+ => ReturningClause schema params columns results

350350 -> ByteString

351351renderReturningClause = \case

352− ReturningStar -> " RETURNING *;"

353− Returning Nil -> ";"

352+ ReturningStar -> " RETURNING *"

353+ Returning Nil -> ""

354354 Returning results -> " RETURNING"

355− <+> renderCommaSeparated (renderAliasedAs renderExpression) results <> ";"

355+ <+> renderCommaSeparated (renderAliasedAs renderExpression) results

356356

357357-- | A `ConflictClause` specifies an action to perform upon a constraint

358358-- violation. `OnConflictDoRaise` will raise an error.

359359-- `OnConflictDoNothing` simply avoids inserting a row.

360360-- `OnConflictDoUpdate` updates the existing row that conflicts with the row

361361-- proposed for insertion.

362−data ConflictClause (columns :: ColumnsType) params where

363− OnConflictDoRaise :: ConflictClause columns params

364− OnConflictDoNothing :: ConflictClause columns params

362+data ConflictClause (schema :: SchemaType) (columns :: ColumnsType) params where

363+ OnConflictDoRaise :: ConflictClause schema columns params

364+ OnConflictDoNothing :: ConflictClause schema columns params

365365 OnConflictDoUpdate

366− :: NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns

367− -> [Condition '[table ::: ColumnsToRelation columns] 'Ungrouped params]

368− -> ConflictClause columns params

366+ :: NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns

367+ -> [Condition schema '[table ::: ColumnsToRelation columns] 'Ungrouped params]

368+ -> ConflictClause schema columns params

369369

370370-- | Render a `ConflictClause`.

371371renderConflictClause

372372 :: SOP.SListI columns

373− => ConflictClause columns params

373+ => ConflictClause schema columns params

374374 -> ByteString

375375renderConflictClause = \case

376376 OnConflictDoRaise -> ""

@@ -383,7 +383,7 @@ renderConflictClause = \case

383383 wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)

384384 where

385385 renderUpdate

386− :: Aliased (ColumnValue columns params) column

386+ :: Aliased (ColumnValue schema columns params) column

387387 -> Maybe ByteString

388388 renderUpdate = \case

389389 Same `As` _ -> Nothing

@@ -401,14 +401,14 @@ UPDATE statements

401401update

402402 :: ( SOP.SListI columns

403403 , SOP.SListI results

404− , Has tab schema table

404+ , Has tab schema ('Table table)

405405 , columns ~ TableToColumns table )

406406 => Alias tab -- ^ table to update

407− -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns

407+ -> NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns

408408 -- ^ modified values to replace old values

409− -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params

409+ -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params

410410 -- ^ condition under which to perform update on a row

411− -> ReturningClause columns params results -- ^ results to return

411+ -> ReturningClause schema columns params results -- ^ results to return

412412 -> Manipulation schema params results

413413update tab columns wh returning = UnsafeManipulation $

414414 "UPDATE"

@@ -419,7 +419,7 @@ update tab columns wh returning = UnsafeManipulation $

419419 <> renderReturningClause returning

420420 where

421421 renderUpdate

422− :: Aliased (ColumnValue columns params) column

422+ :: Aliased (ColumnValue schema columns params) column

423423 -> Maybe ByteString

424424 renderUpdate = \case

425425 Same `As` _ -> Nothing

@@ -431,12 +431,12 @@ update tab columns wh returning = UnsafeManipulation $

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

432432update_

433433 :: ( SOP.SListI columns

434− , Has tab schema table

434+ , Has tab schema ('Table table)

435435 , columns ~ TableToColumns table )

436436 => Alias tab -- ^ table to update

437− -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns

437+ -> NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns

438438 -- ^ modified values to replace old values

439− -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params

439+ -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params

440440 -- ^ condition under which to perform update on a row

441441 -> Manipulation schema params '[]

442442update_ tab columns wh = update tab columns wh (Returning Nil)

@@ -448,12 +448,12 @@ DELETE statements

448448-- | Delete rows of a table.

449449deleteFrom

450450 :: ( SOP.SListI results

451− , Has tab schema table

451+ , Has tab schema ('Table table)

452452 , columns ~ TableToColumns table )

453453 => Alias tab -- ^ table to delete from

454− -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params

454+ -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params

455455 -- ^ condition under which to delete a row

456− -> ReturningClause columns params results -- ^ results to return

456+ -> ReturningClause schema columns params results -- ^ results to return

457457 -> Manipulation schema params results

458458deleteFrom tab wh returning = UnsafeManipulation $

459459 "DELETE FROM" <+> renderAlias tab

@@ -462,10 +462,10 @@ deleteFrom tab wh returning = UnsafeManipulation $

462462

463463-- | Delete rows returning `Nil`.

464464deleteFrom_

465− :: ( Has tab schema table

465+ :: ( Has tab schema ('Table table)

466466 , columns ~ TableToColumns table )

467467 => Alias tab -- ^ table to delete from

468− -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params

468+ -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params

469469 -- ^ condition under which to delete a row

470470 -> Manipulation schema params '[]

471471deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil)

@@ -482,18 +482,18 @@ WITH statements

482482--

483483-- >>> :{

484484-- let

485−-- manipulation :: Manipulation '["products" ::: ProductsTable, "products_deleted" ::: ProductsTable] '[ 'NotNull 'PGdate] '[]

485+-- manipulation :: Manipulation '["products" ::: 'Table ProductsTable, "products_deleted" ::: 'Table ProductsTable] '[ 'NotNull 'PGdate] '[]

486486-- manipulation = with

487487-- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rows :* Nil)

488−-- (insertQuery_ #products_deleted (selectStar (from (table (#deleted_rows `As` #t)))))

489−-- in renderManipulation manipulation

488+-- (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rows `As` #t)))))

489+-- in printSQL manipulation

490490-- :}

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

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

492492with

493493 :: SOP.SListI commons

494494 => NP (Aliased (Manipulation schema params)) commons

495495 -- ^ common table expressions

496− -> Manipulation (Join (RelationsToTables commons) schema) params results

496+ -> Manipulation (With commons schema) params results

497497 -> Manipulation schema params results

498498with commons manipulation = UnsafeManipulation $

499499 "WITH" <+> renderCommaSeparated renderCommon commons

@@ -504,9 +504,4 @@ with commons manipulation = UnsafeManipulation $

504504 -> ByteString

505505 renderCommon (common `As` alias) =

506506 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'

507+ parenthesized (renderManipulation common)

squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+34−36

@@ -31,31 +31,31 @@ type EmailsTable =

3131

3232>>> :{

3333let

34− makeUsers :: Migration IO '[] '["users" ::: UsersTable]

34+ makeUsers :: Migration IO '[] '["users" ::: 'Table UsersTable]

3535 makeUsers = Migration

3636 { name = "make users table"

3737 , up = void . define $

3838 createTable #users

3939 ( serial `As` #id :*

40− (text & notNull) `As` #name :* Nil )

41− ( primaryKey (Column #id :* Nil) `As` #pk_users :* Nil )

40+ (text & notNullable) `As` #name :* Nil )

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

4242 , down = void . define $ dropTable #users

4343 }

4444:}

4545

4646>>> :{

4747let

48− makeEmails :: Migration IO '["users" ::: UsersTable]

49− '["users" ::: UsersTable, "emails" ::: EmailsTable]

48+ makeEmails :: Migration IO '["users" ::: 'Table UsersTable]

49+ '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]

5050 makeEmails = Migration

5151 { name = "make emails table"

5252 , up = void . define $

5353 createTable #emails

5454 ( serial `As` #id :*

55− (int & notNull) `As` #user_id :*

56− text `As` #email :* Nil )

57− ( primaryKey (Column #id :* Nil) `As` #pk_emails :*

58− foreignKey (Column #user_id :* Nil) #users (Column #id :* Nil)

55+ (int & notNullable) `As` #user_id :*

56+ (text & nullable) `As` #email :* Nil )

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

58+ foreignKey #user_id #users #id

5959 OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )

6060 , down = void . define $ dropTable #emails

6161 }

@@ -68,7 +68,7 @@ Now that we have a couple migrations we can chain them together.

6868>>> :{

6969let

7070 numMigrations

71− :: Has "schema_migrations" schema MigrationsTable

71+ :: Has "schema_migrations" schema ('Table MigrationsTable)

7272 => PQ schema schema IO ()

7373 numMigrations = do

7474 result <- runQuery (selectStar (from (table (#schema_migrations `As` #m))))

@@ -90,9 +90,7 @@ Row 0

9090-}

9191

9292{-# LANGUAGE

93− ScopedTypeVariables

94− , OverloadedStrings

95− , DataKinds

93+ DataKinds

9694 , GADTs

9795 , LambdaCase

9896 , PolyKinds

@@ -162,8 +160,8 @@ migrateUp

162160 :: MonadBaseControl IO io

163161 => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run

164162 -> PQ

165− ("schema_migrations" ::: MigrationsTable ': schema0)

166− ("schema_migrations" ::: MigrationsTable ': schema1)

163+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

164+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

167165 io ()

168166migrateUp migration =

169167 define createMigrations

@@ -175,8 +173,8 @@ migrateUp migration =

175173 :: MonadBaseControl IO io

176174 => AlignedList (Migration io) schema0 schema1

177175 -> PQ

178− ("schema_migrations" ::: MigrationsTable ': schema0)

179− ("schema_migrations" ::: MigrationsTable ': schema1)

176+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

177+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

180178 io ()

181179 upMigrations = \case

182180 Done -> return ()

@@ -185,8 +183,8 @@ migrateUp migration =

185183 upMigration

186184 :: MonadBase IO io

187185 => Migration io schema0 schema1 -> PQ

188− ("schema_migrations" ::: MigrationsTable ': schema0)

189− ("schema_migrations" ::: MigrationsTable ': schema1)

186+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

187+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

190188 io ()

191189 upMigration step =

192190 queryExecuted step

@@ -202,8 +200,8 @@ migrateUp migration =

202200 queryExecuted

203201 :: MonadBase IO io

204202 => Migration io schema0 schema1 -> PQ

205− ("schema_migrations" ::: MigrationsTable ': schema0)

206− ("schema_migrations" ::: MigrationsTable ': schema0)

203+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

204+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

207205 io Row

208206 queryExecuted step = do

209207 result <- runQueryParams selectMigration (Only (name step))

@@ -218,8 +216,8 @@ migrateDown

218216 :: MonadBaseControl IO io

219217 => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind

220218 -> PQ

221− ("schema_migrations" ::: MigrationsTable ': schema1)

222− ("schema_migrations" ::: MigrationsTable ': schema0)

219+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

220+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

223221 io ()

224222migrateDown migrations =

225223 define createMigrations

@@ -230,8 +228,8 @@ migrateDown migrations =

230228 downMigrations

231229 :: MonadBaseControl IO io

232230 => AlignedList (Migration io) schema0 schema1 -> PQ

233− ("schema_migrations" ::: MigrationsTable ': schema1)

234− ("schema_migrations" ::: MigrationsTable ': schema0)

231+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

232+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

235233 io ()

236234 downMigrations = \case

237235 Done -> return ()

@@ -240,8 +238,8 @@ migrateDown migrations =

240238 downMigration

241239 :: MonadBase IO io

242240 => Migration io schema0 schema1 -> PQ

243− ("schema_migrations" ::: MigrationsTable ': schema1)

244− ("schema_migrations" ::: MigrationsTable ': schema0)

241+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

242+ ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

245243 io ()

246244 downMigration step =

247245 queryExecuted step

@@ -257,8 +255,8 @@ migrateDown migrations =

257255 queryExecuted

258256 :: MonadBase IO io

259257 => Migration io schema0 schema1 -> PQ

260− ("schema_migrations" ::: MigrationsTable ': schema1)

261− ("schema_migrations" ::: MigrationsTable ': schema1)

258+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

259+ ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

262260 io Row

263261 queryExecuted step = do

264262 result <- runQueryParams selectMigration (Only (name step))

@@ -283,18 +281,18 @@ type MigrationsTable =

283281

284282-- | Creates a `MigrationsTable` if it does not already exist.

285283createMigrations

286− :: Has "schema_migrations" schema MigrationsTable

284+ :: Has "schema_migrations" schema ('Table MigrationsTable)

287285 => Definition schema schema

288286createMigrations =

289287 createTableIfNotExists #schema_migrations

290− ( (text & notNull) `As` #name :*

291− (timestampWithTimeZone & notNull & default_ currentTimestamp)

288+ ( (text & notNullable) `As` #name :*

289+ (timestampWithTimeZone & notNullable & default_ currentTimestamp)

292290 `As` #executed_at :* Nil )

293− ( unique (Column #name :* Nil) `As` #migrations_unique_name :* Nil )

291+ ( unique (#name :* Nil) `As` #migrations_unique_name :* Nil )

294292

295293-- | Inserts a `Migration` into the `MigrationsTable`

296294insertMigration

297− :: Has "schema_migrations" schema MigrationsTable

295+ :: Has "schema_migrations" schema ('Table MigrationsTable)

298296 => Manipulation schema '[ 'NotNull 'PGtext] '[]

299297insertMigration = insertRow_ #schema_migrations

300298 ( Set (param @1) `As` #name :*

@@ -302,14 +300,14 @@ insertMigration = insertRow_ #schema_migrations

302300

303301-- | Deletes a `Migration` from the `MigrationsTable`

304302deleteMigration

305− :: Has "schema_migrations" schema MigrationsTable

303+ :: Has "schema_migrations" schema ('Table MigrationsTable)

306304 => Manipulation schema '[ 'NotNull 'PGtext ] '[]

307305deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)

308306

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

310308-- the time at which it was executed.

311309selectMigration

312− :: Has "schema_migrations" schema MigrationsTable

310+ :: Has "schema_migrations" schema ('Table MigrationsTable)

313311 => Query schema '[ 'NotNull 'PGtext ]

314312 '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]

315313selectMigration = select

squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+17−15

@@ -20,15 +20,10 @@ of executing Squeal commands.

2020

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

2222{-# LANGUAGE

23− DataKinds

24− , DefaultSignatures

23+ DefaultSignatures

2524 , FunctionalDependencies

26− , PolyKinds

27− , DeriveFunctor

2825 , FlexibleContexts

2926 , FlexibleInstances

30− , MagicHash

31− , MultiParamTypeClasses

3227 , OverloadedStrings

3328 , RankNTypes

3429 , ScopedTypeVariables

@@ -160,8 +155,8 @@ lowerConnection (K conn) = K conn

160155-- | We keep track of the schema via an Atkey indexed state monad transformer,

161156-- `PQ`.

162157newtype PQ

163− (schema0 :: TablesType)

164− (schema1 :: TablesType)

158+ (schema0 :: SchemaType)

159+ (schema1 :: SchemaType)

165160 (m :: Type -> Type)

166161 (x :: Type) =

167162 PQ { unPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }

@@ -171,7 +166,7 @@ instance Monad m => Functor (PQ schema0 schema1 m) where

171166 K x <- pq conn

172167 return $ K (f x)

173168

174−-- | Run a `PQ` and keep the result and the `Connection`.

169+-- | Run a `PQ` and keep the result and the `Connection`.

175170runPQ

176171 :: Functor m

177172 => PQ schema0 schema1 m x

@@ -181,7 +176,7 @@ runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn

181176 -- K x <- pq conn

182177 -- return (x, K (unK conn))

183178

184−-- | Execute a `PQ` and discard the result but keep the `Connection`.

179+-- | Execute a `PQ` and discard the result but keep the `Connection`.

185180execPQ

186181 :: Functor m

187182 => PQ schema0 schema1 m x

@@ -217,6 +212,7 @@ class IndexedMonadTransPQ pq where

217212 :: Monad m

218213 => pq schema0 schema1 m (pq schema1 schema2 m y)

219214 -> pq schema0 schema2 m y

215+ pqJoin pq = pq & pqBind id

220216

221217 -- | indexed analog of `=<<`

222218 pqBind

@@ -231,6 +227,15 @@ class IndexedMonadTransPQ pq where

231227 => pq schema1 schema2 m y

232228 -> pq schema0 schema1 m x

233229 -> pq schema0 schema2 m y

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

231+

232+ -- | indexed analog of `<=<`

233+ pqAndThen

234+ :: Monad m

235+ => (y -> pq schema1 schema2 m z)

236+ -> (x -> pq schema0 schema1 m y)

237+ -> x -> pq schema0 schema2 m z

238+ pqAndThen g f x = pqBind g (f x)

234239

235240 -- | Safely embed a computation in a larger schema.

236241 pqEmbed

@@ -253,14 +258,10 @@ instance IndexedMonadTransPQ PQ where

253258 K x' <- x (K (unK conn))

254259 return $ K (f' x')

255260

256− pqJoin pq = pq & pqBind id

257−

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

259262 K x' <- x conn

260263 unPQ (f x') (K (unK conn))

261264

262− pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)

263−

264265 pqEmbed (PQ pq) = PQ $ \ (K conn) -> do

265266 K x <- pq (K conn)

266267 return $ K x

@@ -394,7 +395,8 @@ instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)

394395 let

395396 toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)

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

397− resultMaybe <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary

398+ q' = q <> ";"

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

398400 case resultMaybe of

399401 Nothing -> error

400402 "manipulateParams: LibPQ.execParams returned no results"

squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+3−4

@@ -9,8 +9,7 @@ A `MonadPQ` for pooled connections.

99-}

1010

1111{-# LANGUAGE

12− DataKinds

13− , DeriveFunctor

12+ DeriveFunctor

1413 , FlexibleContexts

1514 , FlexibleInstances

1615 , MultiParamTypeClasses

@@ -43,7 +42,7 @@ import Squeal.PostgreSQL.PQ

4342import Squeal.PostgreSQL.Schema

4443

4544-- | `PoolPQ` @schema@ should be a drop-in replacement for `PQ` @schema schema@.

46−newtype PoolPQ (schema :: TablesType) m x =

45+newtype PoolPQ (schema :: SchemaType) m x =

4746 PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x }

4847 deriving Functor

4948

@@ -110,7 +109,7 @@ instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where

110109 (_ :: K () schema) <- flip unPQ conn $

111110 traversePrepared_ manipulation params

112111 return ()

113− liftPQ m = PoolPQ $ \ pool ->

112+ liftPQ m = PoolPQ $ \ pool ->

114113 withResource pool $ \ conn -> do

115114 (K result :: K result schema) <- flip unPQ conn $

116115 liftPQ m

squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+148−103

@@ -9,23 +9,15 @@ Squeal queries.

99-}

1010

1111{-# LANGUAGE

12− DataKinds

13− , DeriveDataTypeable

14− , DeriveGeneric

12+ DeriveGeneric

1513 , FlexibleContexts

16− , FlexibleInstances

1714 , GADTs

1815 , GeneralizedNewtypeDeriving

19− , KindSignatures

2016 , LambdaCase

21− , MultiParamTypeClasses

2217 , OverloadedStrings

23− , ScopedTypeVariables

2418 , StandaloneDeriving

25− , TypeApplications

2619 , TypeInType

2720 , TypeOperators

28− , UndecidableInstances

2921#-}

3022

3123module Squeal.PostgreSQL.Query

@@ -44,6 +36,8 @@ module Squeal.PostgreSQL.Query

4436 , selectDistinctStar

4537 , selectDotStar

4638 , selectDistinctDotStar

39+ , values

40+ , values_

4741 -- * Table Expressions

4842 , TableExpression (..)

4943 , renderTableExpression

@@ -58,6 +52,7 @@ module Squeal.PostgreSQL.Query

5852 , FromClause (..)

5953 , table

6054 , subquery

55+ , view

6156 , crossJoin

6257 , innerJoin

6358 , leftOuterJoin

@@ -100,111 +95,111 @@ simple query:

10095>>> :{

10196let

10297 query :: Query

103− '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]

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

10499 '[]

105100 '["col" ::: 'Null 'PGint4]

106− query = selectStar (from (table (#tab `As` #t)))

107−in renderQuery query

101+ query = selectStar (from (table #tab))

102+in printSQL query

108103:}

109−"SELECT * FROM \"tab\" AS \"t\""

104+SELECT * FROM "tab" AS "tab"

110105

111106restricted query:

112107

113108>>> :{

114109let

115110 query :: Query

116− '[ "tab" ::: '[] :=>

111+ '[ "tab" ::: 'Table ('[] :=>

117112 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

118− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]

113+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]

119114 '[]

120115 '[ "sum" ::: 'NotNull 'PGint4

121116 , "col1" ::: 'NotNull 'PGint4 ]

122− query =

117+ query =

123118 select

124− ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)

125− ( from (table (#tab `As` #t))

119+ ((#col1 + #col2) `As` #sum :* #col1 :* Nil)

120+ ( from (table #tab)

126121 & where_ (#col1 .> #col2)

127122 & where_ (#col2 .> 0) )

128−in renderQuery query

123+in printSQL query

129124:}

130−"SELECT (\"col1\" + \"col2\") AS \"sum\", \"col1\" AS \"col1\" FROM \"tab\" AS \"t\" WHERE ((\"col1\" > \"col2\") AND (\"col2\" > 0))"

125+SELECT ("col1" + "col2") AS "sum", "col1" AS "col1" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))

131126

132127subquery:

133128

134129>>> :{

135130let

136131 query :: Query

137− '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]

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

138133 '[]

139134 '["col" ::: 'Null 'PGint4]

140135 query =

141136 selectStar

142− (from (subquery (selectStar (from (table (#tab `As` #t))) `As` #sub)))

143−in renderQuery query

137+ (from (subquery (selectStar (from (table #tab)) `As` #sub)))

138+in printSQL query

144139:}

145−"SELECT * FROM (SELECT * FROM \"tab\" AS \"t\") AS \"sub\""

140+SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub"

146141

147142limits and offsets:

148143

149144>>> :{

150145let

151146 query :: Query

152− '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]

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

153148 '[]

154149 '["col" ::: 'Null 'PGint4]

155150 query = selectStar

156− (from (table (#tab `As` #t)) & limit 100 & offset 2 & limit 50 & offset 2)

157−in renderQuery query

151+ (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)

152+in printSQL query

158153:}

159−"SELECT * FROM \"tab\" AS \"t\" LIMIT 50 OFFSET 4"

154+SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4

160155

161156parameterized query:

162157

163158>>> :{

164159let

165160 query :: Query

166− '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8]]

161+ '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8])]

167162 '[ 'NotNull 'PGfloat8]

168163 '["col" ::: 'NotNull 'PGfloat8]

169164 query = selectStar

170− (from (table (#tab `As` #t)) & where_ (#col .> param @1))

171−in renderQuery query

165+ (from (table #tab) & where_ (#col .> param @1))

166+in printSQL query

172167:}

173−"SELECT * FROM \"tab\" AS \"t\" WHERE (\"col\" > ($1 :: float8))"

168+SELECT * FROM "tab" AS "tab" WHERE ("col" > ($1 :: float8))

174169

175170aggregation query:

176171

177172>>> :{

178173let

179174 query :: Query

180− '[ "tab" ::: '[] :=>

175+ '[ "tab" ::: 'Table ('[] :=>

181176 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

182− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]

177+ , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]

183178 '[]

184179 '[ "sum" ::: 'NotNull 'PGint4

185180 , "col1" ::: 'NotNull 'PGint4 ]

186181 query =

187− select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil)

182+ select (sum_ #col2 `As` #sum :* #col1 :* Nil)

188183 ( from (table (#tab `As` #table1))

189− & group (By #col1 :* Nil)

184+ & group (By #col1 :* Nil)

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

191−in renderQuery query

186+in printSQL query

192187:}

193−"SELECT sum(\"col2\") AS \"sum\", \"col1\" AS \"col1\" FROM \"tab\" AS \"table1\" GROUP BY \"col1\" HAVING ((\"col1\" + sum(\"col2\")) > 1)"

188+SELECT sum("col2") AS "sum", "col1" AS "col1" FROM "tab" AS "table1" GROUP BY "col1" HAVING (("col1" + sum("col2")) > 1)

194189

195190sorted query:

196191

197192>>> :{

198193let

199194 query :: Query

200− '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]

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

201196 '[]

202197 '["col" ::: 'Null 'PGint4]

203198 query = selectStar

204− (from (table (#tab `As` #t)) & orderBy [#col & AscNullsFirst])

205−in renderQuery query

199+ (from (table #tab) & orderBy [#col & AscNullsFirst])

200+in printSQL query

206201:}

207−"SELECT * FROM \"tab\" AS \"t\" ORDER BY \"col\" ASC NULLS FIRST"

202+SELECT * FROM "tab" AS "tab" ORDER BY "col" ASC NULLS FIRST

208203

209204joins:

210205

@@ -212,7 +207,7 @@ joins:

212207>>> :{

213208let

214209 query :: Query

215− '[ "orders" :::

210+ '[ "orders" ::: 'Table (

216211 '["pk_orders" ::: PrimaryKey '["id"]

217212 ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]

218213 ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"]] :=>

@@ -220,17 +215,17 @@ let

220215 , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4

221216 , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4

222217 , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4

223− ]

224− , "customers" :::

218+ ])

219+ , "customers" ::: 'Table (

225220 '["pk_customers" ::: PrimaryKey '["id"]] :=>

226221 '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

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

228− ]

229− , "shippers" :::

223+ ])

224+ , "shippers" ::: 'Table (

230225 '["pk_shippers" ::: PrimaryKey '["id"]] :=>

231226 '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

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

233− ]

228+ ])

234229 ]

235230 '[]

236231 '[ "order_price" ::: 'NotNull 'PGfloat4

@@ -246,49 +241,50 @@ let

246241 (#o ! #customer_id .== #c ! #id)

247242 & innerJoin (table (#shippers `As` #s))

248243 (#o ! #shipper_id .== #s ! #id)) )

249−in renderQuery query

244+in printSQL query

250245:}

251−"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\")"

246+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")

252247

253248self-join:

254249

255250>>> :{

256251let

257252 query :: Query

258− '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]

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

259254 '[]

260255 '["col" ::: 'Null 'PGint4]

261256 query = selectDotStar #t1

262257 (from (table (#tab `As` #t1) & crossJoin (table (#tab `As` #t2))))

263−in renderQuery query

258+in printSQL query

264259:}

265−"SELECT \"t1\".* FROM \"tab\" AS \"t1\" CROSS JOIN \"tab\" AS \"t2\""

260+SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2"

266261

267262set operations:

268263

269264>>> :{

270265let

271266 query :: Query

272− '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4]]

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

273268 '[]

274269 '["col" ::: 'Null 'PGint4]

275270 query =

276− selectStar (from (table (#tab `As` #t)))

271+ selectStar (from (table #tab))

277272 `unionAll`

278− selectStar (from (table (#tab `As` #t)))

279−in renderQuery query

273+ selectStar (from (table #tab))

274+in printSQL query

280275:}

281−"(SELECT * FROM \"tab\" AS \"t\") UNION ALL (SELECT * FROM \"tab\" AS \"t\")"

276+(SELECT * FROM "tab" AS "tab") UNION ALL (SELECT * FROM "tab" AS "tab")

282277-}

283278newtype Query

284− (schema :: TablesType)

279+ (schema :: SchemaType)

285280 (params :: [NullityType])

286281 (columns :: RelationType)

287282 = UnsafeQuery { renderQuery :: ByteString }

288283 deriving (GHC.Generic,Show,Eq,Ord,NFData)

284+instance RenderSQL (Query schema params columns) where renderSQL = renderQuery

289285

290286-- | The results of two queries can be combined using the set operation

291−-- `union`. Duplicate rows are eliminated.

287+-- `union`. Duplicate rows are eliminated.

292288union

293289 :: Query schema params columns

294290 -> Query schema params columns

@@ -364,7 +360,7 @@ SELECT queries

364360-- the intermediate table are actually output.

365361select

366362 :: SListI columns

367− => NP (Aliased (Expression relations grouping params)) (column ': columns)

363+ => NP (Aliased (Expression schema relations grouping params)) (column ': columns)

368364 -- ^ select list

369365 -> TableExpression schema params relations grouping

370366 -- ^ intermediate virtual table

@@ -378,7 +374,7 @@ select list rels = UnsafeQuery $

378374-- be subject to the elimination of duplicate rows using `selectDistinct`.

379375selectDistinct

380376 :: SListI columns

381− => NP (Aliased (Expression relations 'Ungrouped params)) (column ': columns)

377+ => NP (Aliased (Expression schema relations 'Ungrouped params)) (column ': columns)

382378 -- ^ select list

383379 -> TableExpression schema params relations 'Ungrouped

384380 -- ^ intermediate virtual table

@@ -419,7 +415,7 @@ selectDotStar

419415selectDotStar rel relations = UnsafeQuery $

420416 "SELECT" <+> renderAlias rel <> ".*" <+> renderTableExpression relations

421417

422−-- | A `selectDistinctDotStar` asks for all the columns of a particular table,

418+-- | A `selectDistinctDotStar` asks for all the columns of a particular table,

423419-- and eliminates duplicate rows.

424420selectDistinctDotStar

425421 :: Has relation relations columns

@@ -432,6 +428,45 @@ selectDistinctDotStar rel relations = UnsafeQuery $

432428 "SELECT DISTINCT" <+> renderAlias rel <> ".*"

433429 <+> renderTableExpression relations

434430

431+-- | `values` computes a row value or set of row values

432+-- specified by value expressions. It is most commonly used

433+-- to generate a “constant table” within a larger command,

434+-- but it can be used on its own.

435+--

436+-- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]

437+-- >>> let query = values (1 `As` #a :* "one" `As` #b :* Nil) [] :: Query '[] '[] Row

438+-- >>> printSQL query

439+-- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b")

440+values

441+ :: SListI cols

442+ => NP (Aliased (Expression schema '[] 'Ungrouped params)) cols

443+ -> [NP (Aliased (Expression schema '[] 'Ungrouped params)) cols]

444+ -- ^ When more than one row is specified, all the rows must

445+ -- must have the same number of elements

446+ -> Query schema params cols

447+values rw rws = UnsafeQuery $ "SELECT * FROM"

448+ <+> parenthesized (

449+ "VALUES"

450+ <+> commaSeparated

451+ ( parenthesized

452+ . renderCommaSeparated renderValuePart <$> rw:rws )

453+ ) <+> "AS t"

454+ <+> parenthesized (renderCommaSeparated renderAliasPart rw)

455+ where

456+ renderAliasPart, renderValuePart

457+ :: Aliased (Expression schema '[] 'Ungrouped params) ty -> ByteString

458+ renderAliasPart (_ `As` name) = renderAlias name

459+ renderValuePart (value `As` _) = renderExpression value

460+

461+-- | `values_` computes a row value or set of row values

462+-- specified by value expressions.

463+values_

464+ :: SListI cols

465+ => NP (Aliased (Expression schema '[] 'Ungrouped params)) cols

466+ -- ^ one row of values

467+ -> Query schema params cols

468+values_ rw = values rw []

469+

435470{-----------------------------------------

436471Table Expressions

437472-----------------------------------------}

@@ -443,7 +478,7 @@ Table Expressions

443478-- to a table on disk, a so-called base table, but more complex expressions

444479-- can be used to modify or combine base tables in various ways.

445480data TableExpression

446− (schema :: TablesType)

481+ (schema :: SchemaType)

447482 (params :: [NullityType])

448483 (relations :: RelationsType)

449484 (grouping :: Grouping)

@@ -451,7 +486,7 @@ data TableExpression

451486 { fromClause :: FromClause schema params relations

452487 -- ^ A table reference that can be a table name, or a derived table such

453488 -- as a subquery, a @JOIN@ construct, or complex combinations of these.

454− , whereClause :: [Condition relations 'Ungrouped params]

489+ , whereClause :: [Condition schema relations 'Ungrouped params]

455490 -- ^ optional search coditions, combined with `.&&`. After the processing

456491 -- of the `fromClause` is done, each row of the derived virtual table

457492 -- is checked against the search condition. If the result of the

@@ -467,13 +502,13 @@ data TableExpression

467502 -- set of rows having common values into one group row that represents all

468503 -- rows in the group. This is done to eliminate redundancy in the output

469504 -- and/or compute aggregates that apply to these groups.

470− , havingClause :: HavingClause relations grouping params

505+ , havingClause :: HavingClause schema relations grouping params

471506 -- ^ If a table has been grouped using `groupBy`, but only certain groups

472507 -- are of interest, the `havingClause` can be used, much like a

473508 -- `whereClause`, to eliminate groups from the result. Expressions in the

474509 -- `havingClause` can refer both to grouped expressions and to ungrouped

475510 -- expressions (which necessarily involve an aggregate function).

476− , orderByClause :: [SortExpression relations grouping params]

511+ , orderByClause :: [SortExpression schema relations grouping params]

477512 -- ^ The `orderByClause` is for optional sorting. When more than one

478513 -- `SortExpression` is specified, the later (right) values are used to sort

479514 -- rows that are equal according to the earlier (left) values.

@@ -532,7 +567,7 @@ from rels = TableExpression rels [] NoGroups NoHaving [] [] []

532567-- | A `where_` is an endomorphism of `TableExpression`s which adds a

533568-- search condition to the `whereClause`.

534569where_

535− :: Condition relations 'Ungrouped params -- ^ filtering condition

570+ :: Condition schema relations 'Ungrouped params -- ^ filtering condition

536571 -> TableExpression schema params relations grouping

537572 -> TableExpression schema params relations grouping

538573where_ wh rels = rels {whereClause = wh : whereClause rels}

@@ -543,7 +578,7 @@ where_ wh rels = rels {whereClause = wh : whereClause rels}

543578group

544579 :: SListI bys

545580 => NP (By relations) bys -- ^ grouped columns

546− -> TableExpression schema params relations 'Ungrouped

581+ -> TableExpression schema params relations 'Ungrouped

547582 -> TableExpression schema params relations ('Grouped bys)

548583group bys rels = TableExpression

549584 { fromClause = fromClause rels

@@ -558,7 +593,7 @@ group bys rels = TableExpression

558593-- | A `having` is an endomorphism of `TableExpression`s which adds a

559594-- search condition to the `havingClause`.

560595having

561− :: Condition relations ('Grouped bys) params -- ^ having condition

596+ :: Condition schema relations ('Grouped bys) params -- ^ having condition

562597 -> TableExpression schema params relations ('Grouped bys)

563598 -> TableExpression schema params relations ('Grouped bys)

564599having hv rels = rels

@@ -567,7 +602,7 @@ having hv rels = rels

567602-- | An `orderBy` is an endomorphism of `TableExpression`s which appends an

568603-- ordering to the right of the `orderByClause`.

569604orderBy

570− :: [SortExpression relations grouping params] -- ^ sort expressions

605+ :: [SortExpression schema relations grouping params] -- ^ sort expressions

571606 -> TableExpression schema params relations grouping

572607 -> TableExpression schema params relations grouping

573608orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}

@@ -602,16 +637,26 @@ newtype FromClause schema params relations

602637

603638-- | A real `table` is a table from the schema.

604639table

605− :: Aliased (Table schema) table

606− -> FromClause schema params '[table]

607−table = UnsafeFromClause . renderAliasedAs renderTable

640+ :: Has tab schema ('Table table)

641+ => Aliased Alias (alias ::: tab)

642+ -> FromClause schema params '[alias ::: TableToRelation table]

643+table (tab `As` alias) = UnsafeFromClause $

644+ renderAlias tab <+> "AS" <+> renderAlias alias

608645

609646-- | `subquery` derives a table from a `Query`.

610647subquery

611− :: Aliased (Query schema params) table

612− -> FromClause schema params '[table]

648+ :: Aliased (Query schema params) rel

649+ -> FromClause schema params '[rel]

613650subquery = UnsafeFromClause . renderAliasedAs (parenthesized . renderQuery)

614651

652+-- | `view` derives a table from a `View`.

653+view

654+ :: Has view schema ('View rel)

655+ => Aliased Alias (alias ::: view)

656+ -> FromClause schema params '[alias ::: rel]

657+view (vw `As` alias) = UnsafeFromClause $

658+ renderAlias vw <+> "AS" <+> renderAlias alias

659+

615660{- | @left & crossJoin right@. For every possible combination of rows from

616661 @left@ and @right@ (i.e., a Cartesian product), the joined table will contain

617662 a row consisting of all columns in @left@ followed by all columns in @right@.

@@ -633,7 +678,7 @@ the @on@ condition.

633678innerJoin

634679 :: FromClause schema params right

635680 -- ^ right

636− -> Condition (Join left right) 'Ungrouped params

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

637682 -- ^ @on@ condition

638683 -> FromClause schema params left

639684 -- ^ left

@@ -650,7 +695,7 @@ innerJoin right on left = UnsafeFromClause $

650695leftOuterJoin

651696 :: FromClause schema params right

652697 -- ^ right

653− -> Condition (Join left right) 'Ungrouped params

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

654699 -- ^ @on@ condition

655700 -> FromClause schema params left

656701 -- ^ left

@@ -668,7 +713,7 @@ leftOuterJoin right on left = UnsafeFromClause $

668713rightOuterJoin

669714 :: FromClause schema params right

670715 -- ^ right

671− -> Condition (Join left right) 'Ungrouped params

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

672717 -- ^ @on@ condition

673718 -> FromClause schema params left

674719 -- ^ left

@@ -687,7 +732,7 @@ rightOuterJoin right on left = UnsafeFromClause $

687732fullOuterJoin

688733 :: FromClause schema params right

689734 -- ^ right

690− -> Condition (Join left right) 'Ungrouped params

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

691736 -- ^ @on@ condition

692737 -> FromClause schema params left

693738 -- ^ left

@@ -751,17 +796,17 @@ renderGroupByClause = \case

751796-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`

752797-- `TableExpression` must use `Having` whose conditions are combined with

753798-- `.&&`.

754−data HavingClause relations grouping params where

755− NoHaving :: HavingClause relations 'Ungrouped params

799+data HavingClause schema relations grouping params where

800+ NoHaving :: HavingClause schema relations 'Ungrouped params

756801 Having

757− :: [Condition relations ('Grouped bys) params]

758− -> HavingClause relations ('Grouped bys) params

759−deriving instance Show (HavingClause relations grouping params)

760−deriving instance Eq (HavingClause relations grouping params)

761−deriving instance Ord (HavingClause relations grouping params)

802+ :: [Condition schema relations ('Grouped bys) params]

803+ -> HavingClause schema relations ('Grouped bys) params

804+deriving instance Show (HavingClause schema relations grouping params)

805+deriving instance Eq (HavingClause schema relations grouping params)

806+deriving instance Ord (HavingClause schema relations grouping params)

762807

763808-- | Render a `HavingClause`.

764−renderHavingClause :: HavingClause relations grouping params -> ByteString

809+renderHavingClause :: HavingClause schema relations grouping params -> ByteString

765810renderHavingClause = \case

766811 NoHaving -> ""

767812 Having [] -> ""

@@ -780,29 +825,29 @@ Sorting

780825-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to

781826-- determine whether nulls appear before or after non-null values in the sort

782827-- ordering of a `Null` result column.

783−data SortExpression relations grouping params where

828+data SortExpression schema relations grouping params where

784829 Asc

785− :: Expression relations grouping params ('NotNull ty)

786− -> SortExpression relations grouping params

830+ :: Expression schema relations grouping params ('NotNull ty)

831+ -> SortExpression schema relations grouping params

787832 Desc

788− :: Expression relations grouping params ('NotNull ty)

789− -> SortExpression relations grouping params

833+ :: Expression schema relations grouping params ('NotNull ty)

834+ -> SortExpression schema relations grouping params

790835 AscNullsFirst

791− :: Expression relations grouping params ('Null ty)

792− -> SortExpression relations grouping params

836+ :: Expression schema relations grouping params ('Null ty)

837+ -> SortExpression schema relations grouping params

793838 AscNullsLast

794− :: Expression relations grouping params ('Null ty)

795− -> SortExpression relations grouping params

839+ :: Expression schema relations grouping params ('Null ty)

840+ -> SortExpression schema relations grouping params

796841 DescNullsFirst

797− :: Expression relations grouping params ('Null ty)

798− -> SortExpression relations grouping params

842+ :: Expression schema relations grouping params ('Null ty)

843+ -> SortExpression schema relations grouping params

799844 DescNullsLast

800− :: Expression relations grouping params ('Null ty)

801− -> SortExpression relations grouping params

802−deriving instance Show (SortExpression relations grouping params)

845+ :: Expression schema relations grouping params ('Null ty)

846+ -> SortExpression schema relations grouping params

847+deriving instance Show (SortExpression schema relations grouping params)

803848

804849-- | Render a `SortExpression`.

805−renderSortExpression :: SortExpression relations grouping params -> ByteString

850+renderSortExpression :: SortExpression schema relations grouping params -> ByteString

806851renderSortExpression = \case

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

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

squeal-postgresql/src/Squeal/PostgreSQL/Render.hs+14−2

@@ -9,12 +9,12 @@ Rendering helper functions.

99-}

1010

1111{-# LANGUAGE

12− MagicHash

12+ FlexibleContexts

13+ , MagicHash

1314 , OverloadedStrings

1415 , PolyKinds

1516 , RankNTypes

1617 , ScopedTypeVariables

17− , TypeApplications

1818#-}

1919

2020module Squeal.PostgreSQL.Render

@@ -26,8 +26,11 @@ module Squeal.PostgreSQL.Render

2626 , renderCommaSeparated

2727 , renderCommaSeparatedMaybe

2828 , renderNat

29+ , RenderSQL (..)

30+ , printSQL

2931 ) where

3032

33+import Control.Monad.Base

3134import Data.ByteString (ByteString)

3235import Data.Maybe

3336import Data.Monoid ((<>))

@@ -36,6 +39,7 @@ import GHC.Exts

3639import GHC.TypeLits

3740

3841import qualified Data.ByteString as ByteString

42+import qualified Data.ByteString.Char8 as Char8

3943

4044-- | Parenthesize a `ByteString`.

4145parenthesized :: ByteString -> ByteString

@@ -78,3 +82,11 @@ renderCommaSeparatedMaybe render

7882-- | Render a promoted `Nat`.

7983renderNat :: KnownNat n => proxy n -> ByteString

8084renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))

85+

86+-- | A class for rendering SQL

87+class RenderSQL sql where

88+ renderSQL :: sql -> ByteString

89+

90+-- | Print SQL.

91+printSQL :: (RenderSQL sql, MonadBase IO io) => sql -> io ()

92+printSQL = liftBase . Char8.putStrLn . renderSQL

squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+364−96

55Maintainer: eitan@morphism.tech

66Stability: experimental

8−A type-level DSL for kinds of PostgreSQL types, constraints, and aliases.

8+This module 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.

912-}

1013

1114{-# LANGUAGE

1215 AllowAmbiguousTypes

1316 , ConstraintKinds

14− , DataKinds

1517 , DeriveAnyClass

16− , DeriveDataTypeable

1718 , DeriveGeneric

1819 , FlexibleContexts

1920 , FlexibleInstances

2021 , FunctionalDependencies

2122 , GADTs

22− , MagicHash

23− , MultiParamTypeClasses

2423 , OverloadedStrings

25− , PolyKinds

2624 , RankNTypes

2725 , ScopedTypeVariables

2826 , StandaloneDeriving

2927 , TypeApplications

30− , TypeFamilies

28+ , TypeFamilyDependencies

3129 , TypeInType

3230 , TypeOperators

3331 , UndecidableInstances

32+ , UndecidableSuperClasses

3433#-}

3534

3635module Squeal.PostgreSQL.Schema

@@ -39,35 +38,47 @@ module Squeal.PostgreSQL.Schema

3938 , HasOid (..)

4039 , NullityType (..)

4140 , ColumnType

41+ -- * Tables

4242 , ColumnsType

4343 , RelationType

4444 , NilRelation

4545 , RelationsType

4646 , TableType

47− , TablesType

48− , NilTables

49− -- * Grouping

50− , Grouping (..)

51− , GroupedBy

47+ -- * Schema

48+ , SchemumType (..)

49+ , SchemaType

5250 -- * Constraints

5351 , (:=>)

5452 , ColumnConstraint (..)

5553 , TableConstraint (..)

5654 , TableConstraints

5755 , NilTableConstraints

56+ , Uniquely

5857 -- * Aliases

5958 , (:::)

6059 , Alias (Alias)

6160 , renderAlias

61+ , renderAliases

6262 , Aliased (As)

6363 , renderAliasedAs

6464 , AliasesOf

65+ , ZipAliased (..)

6566 , Has

6667 , HasUnique

68+ , HasAll

6769 , IsLabel (..)

6870 , IsQualified (..)

71+ -- * Enumerated Labels

72+ , IsPGlabel (..)

73+ , PGlabel (..)

74+ , renderLabel

75+ , renderLabels

76+ -- * Grouping

77+ , Grouping (..)

78+ , GroupedBy

6979 -- * Type Families

7080 , Join

81+ , With

7182 , Create

7283 , Drop

7384 , Alter

@@ -79,35 +90,58 @@ module Squeal.PostgreSQL.Schema

7990 , PGFloating

8091 , PGTypeOf

8192 , SameTypes

93+ , SamePGType

8294 , AllNotNull

8395 , NotAllNull

8496 , NullifyType

8597 , NullifyRelation

8698 , NullifyRelations

8799 , ColumnsToRelation

88− , RelationToColumns

89100 , TableToColumns

90− , TablesToRelations

91− , RelationsToTables

101+ , TableToRelation

92102 , ConstraintInvolves

93103 , DropIfConstraintsInvolve

94− -- * Generics

95− , SameField

96− , SameFields

104+ -- * Embedding

105+ , PG

106+ , EnumFrom

107+ , LabelsFrom

108+ , CompositeFrom

109+ , FieldNamesFrom

110+ , FieldTypesFrom

111+ , ConstructorsOf

112+ , ConstructorNameOf

113+ , ConstructorNamesOf

114+ , FieldsOf

115+ , FieldNameOf

116+ , FieldNamesOf

117+ , FieldTypeOf

118+ , FieldTypesOf

119+ , RecordCodeOf

120+ , MapMaybes (..)

121+ , Nulls

97122 ) where

98123

99124import Control.DeepSeq

100−import Data.ByteString

101−import Data.Monoid

125+import Data.Aeson (Value)

126+import Data.ByteString (ByteString)

127+import Data.Int (Int16, Int32, Int64)

128+import Data.Kind

129+import Data.Monoid hiding (All)

130+import Data.Scientific (Scientific)

102131import Data.String

103−import Data.Word

132+import Data.Text (Text)

133+import Data.Time

134+import Data.Word (Word16, Word32, Word64)

104135import Data.Type.Bool

105−import Generics.SOP (AllZip)

106−import GHC.Generics (Generic)

107−import GHC.Exts

136+import Data.UUID.Types (UUID)

137+import Generics.SOP

108138import GHC.OverloadedLabels

109139import GHC.TypeLits

140+import Network.IP.Addr

110141

142+import qualified Data.ByteString.Lazy as Lazy

143+import qualified Data.Text.Lazy as Lazy

144+import qualified GHC.Generics as GHC

111145import qualified Generics.SOP.Type.Metadata as Type

112146

113147import Squeal.PostgreSQL.Render

@@ -141,6 +175,8 @@ data PGType

141175 | PGjsonb -- ^ binary JSON data, decomposed

142176 | PGvararray PGType -- ^ variable length array

143177 | PGfixarray Nat PGType -- ^ fixed length array

178+ | PGenum [Symbol]

179+ | PGcomposite [(Symbol, PGType)]

144180 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types

145181

146182-- | The object identifier of a `PGType`.

@@ -190,10 +226,7 @@ type (:=>) constraint ty = '(constraint,ty)

190226infixr 7 :=>

191227

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

193−-- a type level pair between

194−-- an alias and some type, like a column alias and either a `ColumnType` or

195−-- `NullityType` or a table alias and either a `TableType` or a `RelationType`

196−-- or a constraint alias and a `TableConstraint`.

229+-- a type level pair between an alias and some type.

197230type (:::) (alias :: Symbol) ty = '(alias,ty)

198231infixr 6 :::

199232

@@ -244,6 +277,15 @@ type TableConstraints = [(Symbol,TableConstraint)]

244277type family NilTableConstraints :: TableConstraints where

245278 NilTableConstraints = '[]

246279

280+-- | A `ForeignKey` must reference columns that either are

281+-- a `PrimaryKey` or form a `Unique` constraint.

282+type family Uniquely

283+ (key :: [Symbol])

284+ (constraints :: TableConstraints) :: Constraint where

285+ Uniquely key (uq ::: 'Unique key ': constraints) = ()

286+ Uniquely key (pk ::: 'PrimaryKey key ': constraints) = ()

287+ Uniquely key (_ ': constraints) = Uniquely key constraints

288+

247289-- | `TableType` encodes a row of constraints on a table as well as the types

248290-- of its columns.

249291--

@@ -257,31 +299,6 @@ type family NilTableConstraints :: TableConstraints where

257299-- :}

258300type TableType = (TableConstraints,ColumnsType)

259301

260−-- | `TablesType` is a row of `TableType`s, thought of as a union.

261−--

262−-- >>> :{

263−-- type family Schema :: TablesType where

264−-- Schema =

265−-- '[ "users" :::

266−-- '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

267−-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4

268−-- , "name" ::: 'NoDef :=> 'NotNull 'PGtext

269−-- , "vec" ::: 'NoDef :=> 'NotNull ('PGvararray 'PGint2)

270−-- ]

271−-- , "emails" :::

272−-- '[ "pk_emails" ::: 'PrimaryKey '["id"]

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

274−-- ] :=>

275−-- '[ "id" ::: 'Def :=> 'NotNull 'PGint4

276−-- , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4

277−-- , "email" ::: 'NoDef :=> 'Null 'PGtext

278−-- ]

279−-- ]

280−-- :}

281−type TablesType = [(Symbol,TableType)]

282−-- | A monokinded empty `TablesType`.

283−type family NilTables :: TablesType where NilTables = '[]

284−

285302-- | `RelationType` is a row of `NullityType`

286303--

287304-- >>> :{

@@ -305,27 +322,13 @@ type family ColumnsToRelation (columns :: ColumnsType) :: RelationType where

305322 ColumnsToRelation (column ::: constraint :=> ty ': columns) =

306323 column ::: ty ': ColumnsToRelation columns

307324

308−-- | `RelationToColumns` adds `'NoDef` column constraints.

309−type family RelationToColumns (relation :: RelationType) :: ColumnsType where

310− RelationToColumns '[] = '[]

311− RelationToColumns (column ::: ty ': columns) =

312− column ::: 'NoDef :=> ty ': RelationToColumns columns

313−

314325-- | `TableToColumns` removes table constraints.

315326type family TableToColumns (table :: TableType) :: ColumnsType where

316327 TableToColumns (constraints :=> columns) = columns

317328

318−-- | `TablesToRelations` removes both table and column constraints.

319−type family TablesToRelations (tables :: TablesType) :: RelationsType where

320− TablesToRelations '[] = '[]

321− TablesToRelations (alias ::: constraint :=> columns ': tables) =

322− alias ::: ColumnsToRelation columns ': TablesToRelations tables

323−

324−-- | `RelationsToTables` adds both trivial table and column constraints.

325−type family RelationsToTables (tables :: RelationsType) :: TablesType where

326− RelationsToTables '[] = '[]

327− RelationsToTables (alias ::: columns ': relations) =

328− alias ::: '[] :=> RelationToColumns columns ': RelationsToTables relations

329+-- | Convert a table to a relation.

330+type family TableToRelation (table :: TableType) :: RelationType where

331+ TableToRelation tab = ColumnsToRelation (TableToColumns tab)

329332

330333-- | `Grouping` is an auxiliary namespace, created by

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

@@ -355,15 +358,26 @@ instance {-# OVERLAPPABLE #-}

355358-- >>> #foobar :: Alias "foobar"

356359-- Alias

357360data Alias (alias :: Symbol) = Alias

358− deriving (Eq,Generic,Ord,Show,NFData)

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

359362instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where

360363 fromLabel = Alias

364+instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where

365+ fromLabel = fromLabel :* Nil

366+instance KnownSymbol alias => RenderSQL (Alias alias) where renderSQL = renderAlias

361367

362368-- | >>> renderAlias #jimbob

363369-- "\"jimbob\""

364370renderAlias :: KnownSymbol alias => Alias alias -> ByteString

365371renderAlias = doubleQuoted . fromString . symbolVal

366372

373+-- | >>> import Generics.SOP (NP(..))

374+-- >>> renderAliases (#jimbob :* #kandi :* Nil)

375+-- ["\"jimbob\"","\"kandi\""]

376+renderAliases

377+ :: All KnownSymbol aliases => NP Alias aliases -> [ByteString]

378+renderAliases = hcollapse

379+ . hcmap (Proxy @KnownSymbol) (K . renderAlias)

380+

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

368382-- version of `:::`.

369383--

@@ -381,6 +395,9 @@ deriving instance Eq (expression ty)

381395 => Eq (Aliased expression (alias ::: ty))

382396deriving instance Ord (expression ty)

383397 => Ord (Aliased expression (alias ::: ty))

398+instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)

399+ => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where

400+ fromLabel = fromLabel @alias2 `As` fromLabel @alias1

384401

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

386403-- >>> renderAliasedAs renderMaybe (Just (3::Int) `As` #an_int)

@@ -397,12 +414,43 @@ type family AliasesOf aliaseds where

397414 AliasesOf '[] = '[]

398415 AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys

399416

417+-- | The `ZipAliased` class provides a type family for zipping

418+-- `Symbol` lists together with arbitrary lists of the same size,

419+-- with an associated type family `ZipAs`, together with

420+-- a method `zipAs` for zipping heterogeneous lists of `Alias`es

421+-- together with a heterogeneous list of expressions into

422+-- a heterogeneous list of `Aliased` expressions.

423+class

424+ ( SListI (ZipAs ns xs)

425+ , All KnownSymbol ns

426+ ) => ZipAliased ns xs where

427+

428+ type family ZipAs

429+ (ns :: [Symbol]) (xs :: [k]) = (zs :: [(Symbol,k)]) | zs -> ns xs

430+

431+ zipAs

432+ :: NP Alias ns

433+ -> NP expr xs

434+ -> NP (Aliased expr) (ZipAs ns xs)

435+

436+instance ZipAliased '[] '[] where

437+ type ZipAs '[] '[] = '[]

438+ zipAs Nil Nil = Nil

439+

440+instance

441+ ( KnownSymbol n

442+ , ZipAliased ns xs

443+ ) => ZipAliased (n ': ns) (x ': xs) where

444+ type ZipAs (n ': ns) (x ': xs) = '(n,x) ': ZipAs ns xs

445+ zipAs (n :* ns) (x :* xs) = x `As` n :* zipAs ns xs

446+

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

401448-- @fields@ is a singleton of @alias ::: field@.

402449type HasUnique alias fields field = fields ~ '[alias ::: field]

403450

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

405−-- @fields@ has a field of @alias ::: field@.

452+-- @fields@ has a field of @alias ::: field@, inferring @field@

453+-- from @alias@ and @fields@.

406454class KnownSymbol alias =>

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

408456 | alias fields -> field where

@@ -411,6 +459,20 @@ instance {-# OVERLAPPING #-} KnownSymbol alias

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

412460 => Has alias (field' ': fields) field

413461

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

463+-- a list of @subfields@.

464+class

465+ ( All KnownSymbol aliases

466+ ) => HasAll

467+ (aliases :: [Symbol])

468+ (fields :: [(Symbol,kind)])

469+ (subfields :: [(Symbol,kind)])

470+ | aliases fields -> subfields where

471+instance {-# OVERLAPPING #-} HasAll '[] fields '[]

472+instance {-# OVERLAPPABLE #-}

473+ (Has alias fields field, HasAll aliases fields subfields)

474+ => HasAll (alias ': aliases) fields (alias ::: field ': subfields)

475+

414476-- | Analagous to `IsLabel`, the constraint

415477-- `IsQualified` defines `!` for a column alias qualified

416478-- by a table alias.

@@ -456,6 +518,13 @@ type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType)

456518 SameTypes (column0 ::: def0 :=> ty0 ': columns0) (column1 ::: def1 :=> ty1 ': columns1)

457519 = (ty0 ~ ty1, SameTypes columns0 columns1)

458520

521+-- | Equality constraint on the underlying `PGType` of two columns.

522+class SamePGType

523+ (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where

524+instance ty0 ~ ty1 => SamePGType

525+ (alias0 ::: def0 :=> nullity0 ty0)

526+ (alias1 ::: def1 :=> nullity1 ty1)

527+

459528-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.

460529type family AllNotNull (columns :: ColumnsType) :: Constraint where

461530 AllNotNull '[] = ()

@@ -497,6 +566,10 @@ type family Join xs ys where

497566-- `Squeal.PostgreSQL.Definition.addColumn`.

498567type family Create alias x xs where

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

569+ Create alias x (alias ::: y ': xs) = TypeError

570+ ('Text "Create: alias "

571+ ':<>: 'ShowType alias

572+ ':<>: 'Text "already in use")

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

501574

502575-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@

@@ -506,12 +579,12 @@ type family Drop alias xs where

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

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

508581

509−-- | @Alter alias xs x@ replaces the type associated with an @alias@ in @xs@

582+-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@

510583-- with the type `x` and is used in `Squeal.PostgreSQL.Definition.alterTable`

511584-- and `Squeal.PostgreSQL.Definition.alterColumn`.

512−type family Alter alias xs x where

513− Alter alias ((alias ::: x0) ': xs) x1 = (alias ::: x1) ': xs

514− Alter alias (x0 ': xs) x1 = x0 ': Alter alias xs x1

585+type family Alter alias x xs where

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

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

515588

516589-- type family AddConstraint constraint ty where

517590-- AddConstraint constraint (constraints :=> ty)

@@ -533,26 +606,25 @@ type family Rename alias0 alias1 xs where

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

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

535608

536−-- | A `SameField` constraint is an equality constraint on a

537−-- `Generics.SOP.Type.Metadata.FieldInfo` and the column alias in a `:::` pair.

538−class SameField

539− (fieldInfo :: Type.FieldInfo) (fieldty :: (Symbol,NullityType)) where

540−instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty)

541−

542−-- | A `SameFields` constraint proves that a

543−-- `Generics.SOP.Type.Metadata.DatatypeInfo` of a record type has the same

544−-- field names as the column AliasesOf of a `ColumnsType`.

545−type family SameFields

546− (datatypeInfo :: Type.DatatypeInfo) (columns :: RelationType)

547− :: Constraint where

548− SameFields

549− ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields])

550− columns

551− = AllZip SameField fields columns

552− SameFields

553− ('Type.Newtype _module _datatype ('Type.Record _constructor fields))

554− columns

555− = AllZip SameField fields columns

609+-- | `MapMaybes` is used in the binary instances of composite types.

610+class MapMaybes xs where

611+ type family Maybes (xs :: [Type]) = (mxs :: [Type]) | mxs -> xs

612+ maybes :: NP Maybe xs -> NP I (Maybes xs)

613+ unMaybes :: NP I (Maybes xs) -> NP Maybe xs

614+instance MapMaybes '[] where

615+ type Maybes '[] = '[]

616+ maybes Nil = Nil

617+ unMaybes Nil = Nil

618+instance MapMaybes xs => MapMaybes (x ': xs) where

619+ type Maybes (x ': xs) = Maybe x ': Maybes xs

620+ maybes (x :* xs) = I x :* maybes xs

621+ unMaybes (I mx :* xs) = mx :* unMaybes xs

622+

623+-- | `Nulls` is used to construct a `Squeal.Postgresql.Expression.row`

624+-- of a composite type.

625+type family Nulls tys where

626+ Nulls '[] = '[]

627+ Nulls (field ::: ty ': tys) = field ::: 'Null ty ': Nulls tys

556628

557629-- | Check if a `TableConstraint` involves a column

558630type family ConstraintInvolves column constraint where

@@ -569,3 +641,199 @@ type family DropIfConstraintsInvolve column constraints where

569641 = If (ConstraintInvolves column constraint)

570642 (DropIfConstraintsInvolve column constraints)

571643 (alias ::: constraint ': DropIfConstraintsInvolve column constraints)

644+

645+-- | A `SchemumType` is a user-defined type, either a `Table`,

646+-- `View` or `Typedef`.

647+data SchemumType

648+ = Table TableType

649+ | View RelationType

650+ | Typedef PGType

651+

652+-- | The schema of a database consists of a list of aliased,

653+-- user-defined `SchemumType`s.

654+type SchemaType = [(Symbol,SchemumType)]

655+

656+-- | Used in `Squeal.Postgresql.Manipulation.with`.

657+type family With

658+ (relations :: RelationsType)

659+ (schema :: SchemaType)

660+ :: SchemaType where

661+ With '[] schema = schema

662+ With (alias ::: rel ': rels) schema =

663+ alias ::: 'View rel ': With rels schema

664+

665+-- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas

666+-- the overloaded label, `fromLabel` is used for column references,

667+-- `label`s are used for enum terms. A `label` is called with

668+-- type application like `label @"beef"`.

669+class IsPGlabel (label :: Symbol) expr where label :: expr

670+instance label ~ label'

671+ => IsPGlabel label (PGlabel label') where label = PGlabel

672+-- | A `PGlabel` unit type with an `IsPGlabel` instance

673+data PGlabel (label :: Symbol) = PGlabel

674+-- | Renders a label

675+renderLabel :: KnownSymbol label => proxy label -> ByteString

676+renderLabel (_ :: proxy label) =

677+ "\'" <> fromString (symbolVal (Proxy @label)) <> "\'"

678+-- | Renders a list of labels

679+renderLabels

680+ :: All KnownSymbol labels => NP PGlabel labels -> [ByteString]

681+renderLabels = hcollapse

682+ . hcmap (Proxy @KnownSymbol) (K . renderLabel)

683+

684+-- | The `PG` type family embeds a subset of Haskell types

685+-- as Postgres basic types.

686+--

687+-- >>> :kind! PG LocalTime

688+-- PG LocalTime :: PGType

689+-- = 'PGtimestamp

690+type family PG (hask :: Type) :: PGType where

691+ PG Bool = 'PGbool

692+ PG Int16 = 'PGint2

693+ PG Int32 = 'PGint4

694+ PG Int64 = 'PGint8

695+ PG Word16 = 'PGint2

696+ PG Word32 = 'PGint4

697+ PG Word64 = 'PGint8

698+ PG Scientific = 'PGnumeric

699+ PG Float = 'PGfloat4

700+ PG Double = 'PGfloat8

701+ PG Char = 'PGchar 1

702+ PG Text = 'PGtext

703+ PG Lazy.Text = 'PGtext

704+ PG ByteString = 'PGbytea

705+ PG Lazy.ByteString = 'PGbytea

706+ PG LocalTime = 'PGtimestamp

707+ PG UTCTime = 'PGtimestamptz

708+ PG Day = 'PGdate

709+ PG TimeOfDay = 'PGtime

710+ PG (TimeOfDay, TimeZone) = 'PGtimetz

711+ PG DiffTime = 'PGinterval

712+ PG UUID = 'PGuuid

713+ PG (NetAddr IP) = 'PGinet

714+ PG Value = 'PGjson

715+ PG ty = TypeError

716+ ('Text "There is no Postgres basic type for " ':<>: 'ShowType ty)

717+

718+-- | The `EnumFrom` type family embeds Haskell enum types, ADTs with

719+-- nullary constructors, as Postgres enum types

720+--

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

722+-- >>> instance Generic Schwarma

723+-- >>> instance HasDatatypeInfo Schwarma

724+-- >>> :kind! EnumFrom Schwarma

725+-- EnumFrom Schwarma :: PGType

726+-- = 'PGenum '["Beef", "Lamb", "Chicken"]

727+type family EnumFrom (hask :: Type) :: PGType where

728+ EnumFrom hask = 'PGenum (LabelsFrom hask)

729+

730+-- | The `LabelsFrom` type family calculates the constructors of a

731+-- Haskell enum type.

732+--

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

734+-- >>> instance Generic Schwarma

735+-- >>> instance HasDatatypeInfo Schwarma

736+-- >>> :kind! LabelsFrom Schwarma

737+-- LabelsFrom Schwarma :: [Type.ConstructorName]

738+-- = '["Beef", "Lamb", "Chicken"]

739+type family LabelsFrom (hask :: Type) :: [Type.ConstructorName] where

740+ LabelsFrom hask =

741+ ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask))

742+

743+-- | The `CompositeFrom` type family embeds Haskell record types as

744+-- Postgres composite types, as long as the record fields

745+-- are `Maybe`s of Haskell types that can be embedded as basic types

746+-- with the `PG` type family.

747+--

748+-- >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic

749+-- >>> instance Generic Row

750+-- >>> instance HasDatatypeInfo Row

751+-- >>> :kind! CompositeFrom Row

752+-- CompositeFrom Row :: PGType

753+-- = 'PGcomposite '['("a", 'PGint2), '("b", 'PGtimestamp)]

754+type family CompositeFrom (hask :: Type) :: PGType where

755+ CompositeFrom hask =

756+ 'PGcomposite (ZipAs (FieldNamesFrom hask) (FieldTypesFrom hask))

757+

758+-- | >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic

759+-- >>> instance Generic Row

760+-- >>> instance HasDatatypeInfo Row

761+-- >>> :kind! FieldNamesFrom Row

762+-- FieldNamesFrom Row :: [Type.FieldName]

763+-- = '["a", "b"]

764+type family FieldNamesFrom (hask :: Type) :: [Type.FieldName] where

765+ FieldNamesFrom hask = FieldNamesOf (FieldsOf (DatatypeInfoOf hask))

766+

767+-- | >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic

768+-- >>> instance Generic Row

769+-- >>> instance HasDatatypeInfo Row

770+-- >>> :kind! FieldTypesFrom Row

771+-- FieldTypesFrom Row :: [PGType]

772+-- = '['PGint2, 'PGtimestamp]

773+type family FieldTypesFrom (hask :: Type) :: [PGType] where

774+ FieldTypesFrom hask = FieldTypesOf (RecordCodeOf hask (Code hask))

775+

776+-- | Calculates constructors of a datatype.

777+type family ConstructorsOf (datatype :: Type.DatatypeInfo)

778+ :: [Type.ConstructorInfo] where

779+ ConstructorsOf ('Type.ADT _module _datatype constructors) =

780+ constructors

781+ ConstructorsOf ('Type.Newtype _module _datatype constructor) =

782+ '[constructor]

783+

784+-- | Calculates the name of a nullary constructor, otherwise

785+-- generates a type error.

786+type family ConstructorNameOf (constructors :: Type.ConstructorInfo)

787+ :: Type.ConstructorName where

788+ ConstructorNameOf ('Type.Constructor name) = name

789+ ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError

790+ ('Text "ConstructorNameOf error: non-nullary constructor "

791+ ':<>: 'Text name)

792+ ConstructorNameOf ('Type.Record name _fields) = TypeError

793+ ('Text "ConstructorNameOf error: non-nullary constructor "

794+ ':<>: 'Text name)

795+

796+-- | Calculate the names of nullary constructors.

797+type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])

798+ :: [Type.ConstructorName] where

799+ ConstructorNamesOf '[] = '[]

800+ ConstructorNamesOf (constructor ': constructors) =

801+ ConstructorNameOf constructor ': ConstructorNamesOf constructors

802+

803+-- | Calculate the fields of a datatype.

804+type family FieldsOf (datatype :: Type.DatatypeInfo)

805+ :: [Type.FieldInfo] where

806+ FieldsOf ('Type.ADT _module _datatype '[ 'Type.Record _name fields]) =

807+ fields

808+ FieldsOf ('Type.Newtype _module _datatype ('Type.Record _name fields)) =

809+ fields

810+

811+-- | Calculate the name of a field.

812+type family FieldNameOf (field :: Type.FieldInfo) :: Type.FieldName where

813+ FieldNameOf ('Type.FieldInfo name) = name

814+

815+-- | Calculate the names of fields.

816+type family FieldNamesOf (fields :: [Type.FieldInfo])

817+ :: [Type.FieldName] where

818+ FieldNamesOf '[] = '[]

819+ FieldNamesOf (field ': fields) = FieldNameOf field ': FieldNamesOf fields

820+

821+-- | >>> :kind! FieldTypeOf (Maybe Int16)

822+-- FieldTypeOf (Maybe Int16) :: PGType

823+-- = 'PGint2

824+type family FieldTypeOf (maybe :: Type) where

825+ FieldTypeOf (Maybe hask) = PG hask

826+ FieldTypeOf ty = TypeError

827+ ('Text "FieldTypeOf error: non-Maybe type " ':<>: 'ShowType ty)

828+

829+-- | Calculate the types of fields.

830+type family FieldTypesOf (fields :: [Type]) where

831+ FieldTypesOf '[] = '[]

832+ FieldTypesOf (field ': fields) = FieldTypeOf field ': FieldTypesOf fields

833+

834+-- | Inspect the code of an algebraic datatype and ensure it's a product,

835+-- otherwise generate a type error

836+type family RecordCodeOf (hask :: Type) (code ::[[Type]]) :: [Type] where

837+ RecordCodeOf _hask '[tys] = tys

838+ RecordCodeOf hask _tys = TypeError

839+ ('Text "RecordCodeOf error: non-Record type " ':<>: 'ShowType hask)

squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+5−12

@@ -9,16 +9,9 @@ Squeal transaction control language.

99-}

1010

1111{-# LANGUAGE

12− DataKinds

13− , EmptyCase

14− , FlexibleContexts

15− , FlexibleInstances

12+ FlexibleContexts

1613 , LambdaCase

1714 , OverloadedStrings

18− , MultiParamTypeClasses

19− , ScopedTypeVariables

20− , TypeFamilies

21− , TypeInType

2215#-}

2316

2417module Squeal.PostgreSQL.Transaction

@@ -165,22 +158,22 @@ data IsolationLevel

165158 = Serializable

166159 -- ^ Dirty read is not possible.

167160 -- Nonrepeatable read is not possible.

168− -- Phantom read is not possible.

161+ -- Phantom read is not possible.

169162 -- Serialization anomaly is not possible.

170163 | RepeatableRead

171164 -- ^ Dirty read is not possible.

172165 -- Nonrepeatable read is not possible.

173− -- Phantom read is not possible.

166+ -- Phantom read is not possible.

174167 -- Serialization anomaly is possible.

175168 | ReadCommitted

176169 -- ^ Dirty read is not possible.

177170 -- Nonrepeatable read is possible.

178− -- Phantom read is possible.

171+ -- Phantom read is possible.

179172 -- Serialization anomaly is possible.

180173 | ReadUncommitted

181174 -- ^ Dirty read is not possible.

182175 -- Nonrepeatable read is possible.

183− -- Phantom read is possible.

176+ -- Phantom read is possible.

184177 -- Serialization anomaly is possible.

185178 deriving (Show, Eq)

186179

stack.yaml+1−1

@@ -1,3 +1,3 @@

1−resolver: lts-11.1

1+resolver: lts-11.15

22packages:

33- squeal-postgresql