1e229ac...dev · squeal

git.iko.soy/squeal

52 files changed+11834−4516

since splitsnapshots

unifiedsplit

.circleci/config.yml+3−2

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

22jobs:

33 build:

44 docker:

5− - image: haskell:latest

5+ - image: haskell:8.6.5

66 - image: circleci/postgres:latest

77 environment:

8+ POSTGRES_USER: root

89 POSTGRES_DB: exampledb

910 steps:

1011 - checkout

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

1314 - dependency-cache

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

1516 - run: stack upgrade && stack update

16− - run: stack build

17+ - run: stack build --fast

1718 - run: stack test

1819 - run: stack haddock

1920 - save_cache:

README.md+126−119

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

4444* linear, invertible migrations

4545* connection pools

4646* transactions

47+* views

48+* array, composite and enumerated types

49+* json functions and operations

50+* multischema support

51+* correlated subqueries

52+* window functions

53+* text search

4754

4855## installation

4956

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

5158

5259## testing

5360

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

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

5562

5663`stack test`

5764

65+## contributing

66+

67+We welcome contributors.

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

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

70+

5871## usage

5972

6073Let's see an example!

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

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

6376features.

6477

65−```haskell

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

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

78+```Haskell

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

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

6881```

6982

7083We'll need some imports.

7184

72−```haskell

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

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

85+```Haskell

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

7587>>> import Data.Int (Int32)

7688>>> import Data.Text (Text)

7789>>> import Squeal.PostgreSQL

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

7991

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

8193

82−```haskell

94+```Haskell

8395>>> import qualified Generics.SOP as SOP

8496>>> import qualified GHC.Generics as GHC

8597```

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

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

88100we use `DataKinds` and `TypeOperators`.

89101

90−```haskell

102+```Haskell

91103>>> :{

104+type UsersColumns =

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

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

107+type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]

108+type EmailsColumns =

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

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

111+ , "email" ::: 'NoDef :=> 'Null 'PGtext ]

112+type EmailsConstraints =

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

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

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

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

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

118+type Schemas = Public Schema

107119:}

108120```

109121

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

122+Notice the use of type operators.

123+

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

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

126+operator.

127+

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

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

114−yielding a `ColumnType`.

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

115131

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

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

134+has two type parameters, corresponding to the schema

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

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

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

122138

123−```haskell

139+```Haskell

124140>>> :{

125141let

126− setup :: Definition '[] Schema

127− setup =

128− createTable #users

129− ( serial `As` #id :*

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

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

132− createTable #emails

133− ( serial `As` #id :*

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

135− (text & nullable) `As` #email :* Nil )

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

137− foreignKey #user_id #users #id

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

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

143+ setup =

144+ createTable #users

145+ ( serial `as` #id :*

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

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

148+ createTable #emails

149+ ( serial `as` #id :*

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

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

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

153+ foreignKey #user_id #users #id

154+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

139155:}

140156```

141157

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

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

143159

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

160+```Haskell

161+>>> printSQL setup

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

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

147164```

148165

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

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

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

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

152169`Definition` is simpler.

153170

154−```haskell

171+```Haskell

155172>>> :{

156173let

157− teardown :: Definition Schema '[]

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

158175 teardown = dropTable #emails >>> dropTable #users

159176:}

160−>>> renderDefinition teardown

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

177+

178+>>> printSQL teardown

179+DROP TABLE "emails";

180+DROP TABLE "users";

181+```

182+

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

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

185+

186+```Haskell

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

188+>>> instance SOP.Generic User

189+>>> instance SOP.HasDatatypeInfo User

162190```

163191

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

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

166−or `deleteFrom` command and

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

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

192+Next, we'll write `Manipulation_`s to insert `User`s into our two tables.

193+A `Manipulation_` like `insertInto`, `update` or `deleteFrom`

194+has three type parameters, the schemas it refers to, input parameters

195+and an output row. When

169196we 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

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

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

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

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

174−of our inserts.

200+the emails table. We can do this in a single `Manipulation_` by using a

201+`with` statement.

175202

176−```haskell

203+```Haskell

177204>>> :{

178205let

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

180− insertUser = insertRow #users

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

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

206+ insertUser :: Manipulation_ Schemas User ()

207+ insertUser = with (u `as` #u) e

208+ where

209+ u = insertInto #users

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

211+ OnConflictDoRaise (Returning_ (#id :* param @2 `as` #email))

212+ e = insertInto_ #emails $ Select

213+ (Default `as` #id :* Set (#u ! #id) `as` #user_id :* Set (#u ! #email) `as` #email)

214+ (from (common #u))

183215:}

184−>>> :{

185−let

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

187− insertEmail = insertRow #emails

188− ( Default `As` #id :*

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

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

191− OnConflictDoNothing (Returning Nil)

192−:}

193−>>> renderManipulation insertUser

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

195−>>> renderManipulation insertEmail

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

216+

217+>>> printSQL insertUser

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

197219```

198220

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

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

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

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

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

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

224+`Manipulation_` with the same kind of type parameters.

203225

204−```haskell

226+```Haskell

205227>>> :{

206228let

207− getUsers :: Query Schema '[]

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

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

210− getUsers = select

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

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

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

229+ getUsers :: Query_ Schemas () User

230+ getUsers = select_

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

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

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

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

215235:}

216−>>> renderQuery getUsers

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

218−```

219−

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

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

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

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

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

225236

226−```haskell

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

228−>>> instance SOP.Generic User

229−>>> instance SOP.HasDatatypeInfo User

237+>>> printSQL getUsers

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

230239```

231240

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

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

233242

234−```haskell

243+```Haskell

235244>>> :{

236245let

237246 users :: [User]

238− users =

247+ users =

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

240249 , User "Bob" Nothing

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

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

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

252261`MonadPQ` functionality.

253262

254−```haskell

263+```Haskell

255264>>> :{

256265let

257− session :: PQ Schema Schema IO ()

266+ session :: PQ Schemas Schemas IO ()

258267 session = do

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

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

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

268+ _ <- traversePrepared_ insertUser users

262269 usersResult <- runQuery getUsers

263270 usersRows <- getRows usersResult

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

265−:}

266−>>> :{

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

268− define setup

269− & pqThen session

270− & pqThen (define teardown)

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

272+in

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

274+ define setup

275+ & pqThen session

276+ & pqThen (define teardown)

271277:}

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

279+-}

273280```

RELEASE NOTES.md+1077

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

11## RELEASE NOTES

3+### Version 0.5

5+Version 0.5 makes a number of large changes and additions to Squeal.

6+I want to thank folks who contributed issues and pull requests;

7+Raveline, rimmington, ilyakooo0, chshersh, reygoch, and more.

9+**Multi-schema support**

10+

11+Previous versions of Squeal only supported definitions in the "public"

12+schema. Squeal 0.5 adds support for multiple schemas with the new kind

13+

14+```Haskell

15+type SchemasType = [(Symbol,SchemaType)]

16+```

17+

18+In order to upgrade your queries, manipulations and definitions from

19+Squeal 0.4, you will have to apply the `Public` type family, which indicates

20+that your only schema is the "public" schema.

21+

22+```Haskell

23+-- Squeal 0.4

24+setup :: Definition '[] Schema

25+

26+-- Squeal 0.5

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

28+```

29+

30+You can create non-public schemas using `createSchema` and inversely

31+remove them using `dropSchema`. There is also an idempotent

32+`createSchemaIfNotExists`.

33+

34+In order to handle aliases which may refer to non-public schemas, Squeal 0.5

35+introduces `QualifiedAlias`es. A `QualifiedAlias` can be referred to using

36+the `(!)` operator from the `IsQualified` typeclass; but if you want to refer

37+to an alias from the "public" schema, you can continue to use a single

38+overloaded label, no need to write `#public ! #tab`, just write `#tab`.

39+

40+**Top-level statements**

41+

42+As a consequence of multi-schema support, common table expressions that

43+a `Query` or `Manipulation` may refer to had to be broken into a new parameter.

44+Additionally, `Query` gained another new parameter for its outer scope which

45+will be discussed in the next section.

46+

47+To simplify type signatures that you have to write for top-level queries

48+and manipulations, Squeal 0.5 introduces the `Query_` and `Manipulation_`

49+type families.

50+

51+```

52+type family Query_

53+ (schemas :: SchemasType)

54+ (parameters :: Type)

55+ (row :: Type) where

56+ Query_ schemas params row =

57+ Query '[] '[] schemas (TuplePG params) (RowPG row)

58+```

59+

60+As you see, a top-level `Query_` has no outer scope and no common

61+table expressions in scope, they are empty `'[]`. Moreover,

62+its parameters and row parameters are now `Type`s, which are

63+converted to corresponding Postgres types using the `TuplePG`

64+and `RowPG` type families. This means you can write the type signatures

65+for your top-level statements using the Haskell types that you

66+intend to input and retrieve when running the statements. Similar

67+to `Query_`, there is a `Manipulation_` type, the only difference

68+being that a general `Manipulation` doesn't have an outer scope,

69+only a scope for common table expressions.

70+

71+**Subquery expressions**

72+

73+Previous versions of Squeal offered subquery expression support

74+but there were issues. The common use case of using the `IN` operator

75+from SQL was overly complex. There was a proliferation of subquery

76+functions to handle different comparison operators, each with two versions

77+for comparing `ALL` or `ANY` of the query rows. And, most confoundedly,

78+there was no way to support the `EXISTS` subquery because the "outer scope"

79+for a query was not available.

80+

81+Squeal adds an outer scope to the `Query` type.

82+

83+```Haskell

84+newtype Query

85+ (outer :: FromType)

86+ (commons :: FromType)

87+ (schemas :: SchemasType)

88+ (params :: [NullityType])

89+ (row :: RowType)

90+ = UnsafeQuery { renderQuery :: ByteString }

91+```

92+

93+This enables a well-typed `exists` function.

94+

95+```Haskell

96+exists

97+ :: Query (Join outer from) commons schemas params row

98+ -> Condition outer commons grp schemas params from

99+```

100+

101+The `in_` and `notIn` functions were simplified to handle the most

102+common use case of comparing to a list of values.

103+

104+```Haskell

105+in_

106+ :: Expression outer commons grp schemas params from ty -- ^ expression

107+ -> [Expression outer commons grp schemas params from ty]

108+ -> Condition outer commons grp schemas params from

109+```

110+

111+Finally, general subquery comparisons were abstracted to work with

112+any comparison operators, using the `Operator` type which will be discussed in

113+the next section.

114+

115+```Haskell

116+subAll

117+ :: Expression outer commons grp schemas params from ty1

118+ -> Operator ty1 ty2 ('Null 'PGbool)

119+ -> Query (Join outer from) commons schemas params '[col ::: ty2]

120+ -> Condition outer commons grp schemas params from

121+

122+subAny

123+ :: Expression outer commons grp schemas params from ty1

124+ -> Operator ty1 ty2 ('Null 'PGbool)

125+ -> Query (Join outer from) commons schemas params '[col ::: ty2]

126+ -> Condition outer commons grp schemas params from

127+```

128+

129+**Expression RankNTypes**

130+

131+Squeal 0.5 introduces RankNType type synonyms for common expression patterns.

132+The simplest example is the `Expr` type, a type for "closed" expressions

133+that cannot reference any aliases or parameters.

134+

135+```Haskell

136+type Expr x

137+ = forall outer commons grp schemas params from

138+ . Expression outer commons grp schemas params from x

139+```

140+

141+There is also a function type `(-->)`, which is a subtype of the usual Haskell function

142+type `(->)`.

143+

144+```Haskell

145+type (-->) x y

146+ = forall outer commons grp schemas params from

147+ . Expression outer commons grp schemas params from x

148+ -> Expression outer commons grp schemas params from y

149+```

150+

151+We saw in the subquery section that there is an `Operator` type.

152+

153+```Haskell

154+type Operator x1 x2 y

155+ = forall outer commons grp schemas params from

156+ . Expression outer commons grp schemas params from x1

157+ -> Expression outer commons grp schemas params from x2

158+ -> Expression outer commons grp schemas params from y

159+```

160+

161+There are also types `FunctionN` and `FunctionVar` for n-ary functions

162+and variadic functions.

163+

164+```

165+type FunctionN xs y

166+ = forall outer commons grp schemas params from

167+ . NP (Expression outer commons grp schemas params from) xs

168+ -> Expression outer commons grp schemas params from y

169+```

170+

171+An n-ary function takes an `NP` list of `Expression`s as its argument.

172+Squeal 0.5 adds a helpful operator `(*:)`, to help scrap your `Nil`s.

173+You can construct an `NP` list now by using the operator `(:*)`,

174+until your last element, using `(*:)` there. For instance, the function

175+`atan2_` takes two arguments, `atan2_ (pi *: 2)`.

176+

177+**Selections**

178+

179+Previously, Squeal provided a couple versions of `SELECT` depending

180+on whether you wanted to select all columns of a unique table

181+in the from clause, i.e. `*`, all columns of a particular table

182+in the from clause, i.e. `.*`, or a list of columns from the from clause.

183+

184+Squeal 0.5 refactors this pattern into a `Selection` GADT type, allowing

185+for abstraction and combinations that were not possible before.

186+

187+```Haskell

188+data Selection outer commons grp schemas params from row where

189+ Star

190+ :: HasUnique tab from row

191+ => Selection outer commons 'Ungrouped schemas params from row

192+ DotStar

193+ :: Has tab from row

194+ => Alias tab

195+ -> Selection outer commons 'Ungrouped schemas params from row

196+ List

197+ :: SListI row

198+ => NP (Aliased (Expression outer commons grp schemas params from)) row

199+ -> Selection outer commons grp schemas params from row

200+ Over

201+ :: SListI row

202+ => NP (Aliased (WindowFunction outer commons grp schemas params from)) row

203+ -> WindowDefinition outer commons grp schemas params from

204+ -> Selection outer commons grp schemas params from row

205+ Also

206+ :: Selection outer commons grp schemas params from right

207+ -> Selection outer commons grp schemas params from left

208+ -> Selection outer commons grp schemas params from (Join left right)

209+```

210+

211+In addition to the `Star`, `DotStar` and `List` constructors, there is an

212+`Also` constructor combinator, which enables users to combine `Selection`s.

213+Additionally, there is an `Over` constructor that is used to enable

214+window functions, described in the next section.

215+

216+To upgrade from Squeal 0.4, you will replace `selectStar` with `select Star`,

217+replace `selectDotStar #tab` with `select (DotStar #tab)`. The `List`

218+selection is such a common use case that there is a function `select_` which

219+automatically applies it, so to upgrade from Squeal 0.4, replace `select`

220+with `select_`. There are also independent `selectDistinct` and `selectDistinct_`

221+functions to filter out duplicate rows.

222+

223+**Query clauses**

224+

225+Previously, Squeal provided a couple versions of `INSERT` depending

226+on whether you wanted to insert `VALUES` or a query.

227+

228+Squeal 0.5 refactors this pattern into a `QueryClause` GADT.

229+

230+```

231+-- Squeal 0.4

232+insertRow_ #tab (Set 2 `as` #col1 :* Default `as` #col2)

233+insertQuery_ #tab (selectStar (from (table #other_tab)))

234+

235+-- Squeal 0.5

236+insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))

237+insertInto_ #tab (Subquery (select Star (from (table #other_tab))))

238+```

239+

240+**Window functions and aggregation**

241+

242+Previous versions of Squeal provided no support for window functions.

243+Squeal 0.5 adds support for window functions. We saw `Over` in the

244+previous section.

245+

246+```Haskell

247+Over

248+ :: SListI row

249+ => NP (Aliased (WindowFunction outer commons grp schemas params from)) row

250+ -> WindowDefinition outer commons grp schemas params from

251+ -> Selection outer commons grp schemas params from row

252+```

253+

254+`Over` combines window functions with window definitions. A `WindowDefinition`

255+is constructed using the `partitionBy` function, optionally with an `orderBy`

256+clause. For example,

257+

258+```Haskell

259+query :: Query_ (Public Schema) () (Row Int32 Int32)

260+query = select

261+ (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))

262+ (from (table #tab))

263+```

264+

265+Here the `rank` function is a `WindowFunction`

266+

267+```Haskell

268+rank :: WinFun0 ('NotNull 'PGint8)

269+rank = UnsafeWindowFunction "rank()"

270+```

271+

272+`WinFun0` is a RankNType, like `Expr` was, used for no argument window functions.

273+Similarly, there are also `WinFun1` and `WinFunN` types for

274+window functions and n-ary window functions.

275+

276+In order to use the same syntax for certain window functions and aggregate functions,

277+a new typeclass `Aggregate` was introduced. So for instance, `sum_` can be

278+either a `Distinction` `Expression` or a `WindowFunction`, used either with

279+a `groupBy` or with a `partitionBy` in the appropriate way.

280+

281+```

282+data Distinction (expr :: kind -> Type) (ty :: kind)

283+ = All (expr ty)

284+ | Distinct (expr ty)

285+```

286+

287+Aggregate functions can be run over all rows or only over distinct rows,

288+while window functions bear no such distinction.

289+

290+**Migrations**

291+

292+Thanks to [https://github.com/Raveline](Raveline) Squeal 0.5 introduces

293+a function `defaultMain` to easily create a command line program to

294+run or rewind your migrations.

295+

296+Previously, Squeal's migrations were impure, allowing in addition to

297+running `Definition`s to run arbitrary `IO` operations, such as inserting

298+data into the database or printing out status messages. In order to

299+provide compatibility with other migration systems, Squeal 0.5 introduces

300+pure migrations, that is migrations that are only `Definition`s.

301+

302+```Haskell

303+data Migration p schemas0 schemas1 = Migration

304+ { name :: Text -- ^ The `name` of a `Migration`.

305+ -- Each `name` in a `Migration` should be unique.

306+ , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.

307+ , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.

308+ } deriving (GHC.Generic)

309+```

310+

311+A pure migration is a `Migration Definition`, a pair of inverse

312+`Definition`s with a unique name. To recover impure migrations, Squeal 0.5

313+introduces the `Terminally` type.

314+

315+```Haskell

316+newtype Terminally trans monad x0 x1 = Terminally

317+ { runTerminally :: trans x0 x1 monad () }

318+```

319+

320+`Terminally` applies the indexed monad transformer and the monad it transforms

321+to the unit type `()`, thereby turning an indexed monad into a `Category`. An

322+impure migration is a `Migration (Terminally PQ IO)`. You can always cast

323+a pure migration into an impure migration with the functor, `pureMigration`.

324+

325+```Haskell

326+pureMigration

327+ :: Migration Definition schemas0 schemas1

328+ -> Migration (Terminally PQ IO) schemas0 schemas1

329+```

330+

331+To run either pure or impure migrations, Squeal 0.5 introduces

332+a typeclass, `Migratory`.

333+

334+```

335+class Category p => Migratory p where

336+

337+ migrateUp

338+ :: AlignedList (Migration p) schemas0 schemas1

339+ -> PQ schemas0 schemas1 IO ()

340+

341+ migrateDown

342+ :: AlignedList (Migration p) schemas0 schemas1

343+ -> PQ schemas1 schemas0 IO ()

344+```

345+

346+The signatures of `migrateUp` and `migrateDown` have been changed

347+to make them easier to compose with other `PQ` actions.

348+

349+**Transactions**

350+

351+You can now run transactions `ephemerally`, guaranteed to roll back,

352+but return the result or throw the exception that the transaction

353+would have generated. This is useful for testing. You can also

354+`transactionallyRetry` computations, retrying the transaction if

355+a [serialization failure](https://www.postgresql.org/docs/11/transaction-iso.html#XACT-REPEATABLE-READ) occurs.

356+

357+**Types**

358+

359+Squeal now supports money via a `Money` Haskell `Type` and a `'PGmoney`

360+`PGType`. Squeal 0.5 also adds support for creating domain types

361+with `createDomain`.

362+

363+**Time**

364+

365+Squeal 0.5 adds support for new functions; `now`, `makeDate`, `makeTime`,

366+, `makeTimestamp`, and `makeTimestamptz`, a function `interval_` for

367+constructing time intervals out multiples of `TimeUnit`s, and a new

368+`TimeOp` class, defining affine space operators for time types and their

369+differences.

370+

371+**Literals**

372+

373+Squeal allows you to include Haskell values in your statements using

374+out of line `parameter`s, but often you want to include them inline,

375+as a SQL `literal`. Squeal 0.5 enables this using the `Literal` class.

376+

377+**Set returning functions**

378+

379+Squeal 0.5 adds support for set returning functions such as `unnest`,

380+with the `RankNType` `SetOfFunction`, which can be used as as a `FromClause`.

381+

382+**Text search**

383+

384+Squeal 0.5 adds extensive support for text search types, functions and operators.

385+

386+**Much more**

387+

388+Lots more changes went into and under the hood of the new version.

389+The `Expression` module was split into coherent submodules since it

390+had grown to immense proportions. New modules `Alias`, `PG` and `List`

391+were added to relieve some of the burden that the `Schema` module

392+had been carrying. Rendering has been better unified with a new

393+`RenderSQL` typeclass. Type level list concatenation with the `Additional`

394+typeclass has been added. `Manipulation`s `update` and `delete`

395+were upgraded, so you can leave out fields you don't want to update and

396+use `USING` clauses in deletes. Upserts which were previously broken

397+now work. The `IO` typeclass hierarchy was changed from `MonadBase`

398+and `MonadBaseControl` to `MonadIO` and `MonadUnliftIO`. A new

399+`withRecursive` `Manipulation` was added. `SquealException`s were

400+refactored and a `trySqueal` function added. Arrays were refactored.

401+And there was probably more I've forgotten.

402+

403+### Version 0.4

404+

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

406+support for multidimensional arrays, improves support

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

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

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

410+

411+**Types**

412+

413+Squeal 0.4 renames some kinds to aid intuition:

414+

415+```Haskell

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

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

418+```

419+

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

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

422+a `RowType`.

423+

424+```Haskell

425+data PGType

426+ = ..

427+ | PGvararray NullityType

428+ | PGfixarray Nat NullityType

429+ | PGcomposite RowType

430+```

431+

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

433+

434+```Haskell

435+data PGType = PGbool | ..

436+data NullityType = Null PGType | NotNull PGType

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

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

439+```

440+

441+In another sense, we can embed Haskell types

442+into Postgres types by providing type families:

443+

444+```Haskell

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

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

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

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

449+```

450+

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

452+

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

454+associates some Haskell types to their obvious corresponding Postgres

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

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

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

458+users can make their own type instances.

459+

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

461+thing for Haskell with `Maybe`s:

462+

463+```Haskell

464+type family NullPG hask where

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

466+ NullPG hask = 'NotNull (PG hask)

467+```

468+

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

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

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

472+

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

474+

475+```Haskell

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

477+>>> instance SOP.Generic Person

478+>>> instance SOP.HasDatatypeInfo Person

479+>>> :kind! TuplePG Person

480+TuplePG Person :: [NullityType]

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

482+>>> :kind! RowPG Person

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

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

485+```

486+

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

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

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

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

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

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

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

494+

495+For instance:

496+

497+```Haskell

498+>>> :{

499+let

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

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

502+:}

503+```

504+

505+**Arrays**

506+

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

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

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

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

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

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

513+

514+```Haskell

515+>>> :{

516+data Row = Row

517+ { col1 :: Vector Int16

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

519+ , col3 :: ((Int16,Int16),(Int16,Int16),(Int16,Int16))

520+ } deriving (Eq, GHC.Generic)

521+:}

522+

523+>>> instance Generic Row

524+>>> instance HasDatatypeInfo Row

525+```

526+

527+Define a simple round trip query.

528+

529+```Haskell

530+>>> :{

531+let

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

533+ roundTrip = values_ $

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

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

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

537+:}

538+

539+>>> :set -XOverloadedLists

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

541+>>> :{

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

543+ result <- runQueryParams roundTrip input

544+ Just output <- firstRow result

545+ liftBase . print $ input == output

546+:}

547+True

548+```

549+

550+**Containers**

551+

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

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

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

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

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

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

558+

559+```Haskell

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

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

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

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

564+```

565+

566+Let's see an example:

567+

568+```Haskell

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

570+>>> instance SOP.Generic Schwarma

571+>>> instance SOP.HasDatatypeInfo Schwarma

572+>>>

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

574+>>> instance SOP.Generic Person

575+>>> instance SOP.HasDatatypeInfo Person

576+>>> instance Aeson.FromJSON Person

577+>>> instance Aeson.ToJSON Person

578+```

579+

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

581+

582+```Haskell

583+>>> :{

584+type Schema =

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

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

587+ ]

588+:}

589+

590+>>> :{

591+let

592+ setup :: Definition '[] Schema

593+ setup =

594+ createTypeEnumFrom @Schwarma #schwarma >>>

595+ createTypeCompositeFrom @Person #person

596+:}

597+```

598+

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

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

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

602+

603+```Haskell

604+>>> :{

605+data Row = Row

606+ { schwarma :: Enumerated Schwarma

607+ , person1 :: Composite Person

608+ , person2 :: Json Person

609+ } deriving (Eq, GHC.Generic)

610+:}

611+

612+>>> instance Generic Row

613+>>> instance HasDatatypeInfo Row

614+>>> :{

615+let

616+ input = Row

617+ (Enumerated Chicken)

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

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

620+:}

621+```

622+

623+Once again, define a round trip query.

624+

625+```Haskell

626+>>> :{

627+let

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

629+ roundTrip = values_ $

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

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

632+ parameter @3 json `as` #person2

633+:}

634+```

635+

636+Finally, we can drop our type definitions.

637+

638+```Haskell

639+>>> :{

640+let

641+ teardown :: Definition Schema '[]

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

643+:}

644+```

645+

646+Now let's run it.

647+

648+```Haskell

649+>>> :{

650+let

651+ session = do

652+ result <- runQueryParams roundTrip input

653+ Just output <- firstRow result

654+ liftBase . print $ input == output

655+in

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

657+ define setup

658+ & pqThen session

659+ & pqThen (define teardown)

660+:}

661+True

662+```

663+

664+**With**

665+

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

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

668+

669+```Haskell

670+with

671+ :: SOP.SListI commons

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

673+ -- ^ common table expressions

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

675+ -> Manipulation schema params results

676+```

677+

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

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

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

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

682+

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

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

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

686+

687+```Haskell

688+data CommonTableExpression statement params schema0 schema1 where

689+ CommonTableExpression

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

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

692+```

693+

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

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

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

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

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

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

700+

701+```Haskell

702+class With statement where

703+ with

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

705+ -> statement schema1 params row

706+ -> statement schema0 params row

707+```

708+

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

710+

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

712+

713+```Haskell

714+>>> :{

715+let

716+ query :: Query

717+ '[ "t1" ::: 'View

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

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

720+ '[]

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

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

723+ query = with (

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

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

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

727+in printSQL query

728+:}

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

730+

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

732+

733+>>> :{

734+let

735+ manipulation :: Manipulation

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

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

738+ ] '[ 'NotNull 'PGdate] '[]

739+ manipulation = with

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

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

742+in printSQL manipulation

743+:}

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

745+```

746+

747+**Three Valued Logic**

748+

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

750+of `true` and `false`.

751+

752+```Haskell

753+-- Squeal 0.3

754+type Condition schema from grouping params =

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

756+```

757+

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

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

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

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

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

763+

764+```Haskell

765+-- Squeal 0.4

766+type Condition schema from grouping params =

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

768+```

769+

770+**Subquery Expressions**

771+

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

773+

774+**Row Types**

775+

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

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

778+`typedef`.

779+

780+**Runtime Exceptions**

781+

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

783+encountered and handler functions.

784+

785+```Haskell

786+data SquealException

787+ = PQException

788+ { sqlExecStatus :: LibPQ.ExecStatus

789+ , sqlStateCode :: Maybe ByteString

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

791+ , sqlErrorMessage :: Maybe ByteString

792+ }

793+ | ResultException Text

794+ | ParseException Text

795+ deriving (Eq, Show)

796+instance Exception SquealException

797+

798+catchSqueal

799+ :: MonadBaseControl IO io

800+ => io a

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

802+ -> io a

803+

804+handleSqueal

805+ :: MonadBaseControl IO io

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

807+ -> io a -> io a

808+```

809+

810+**Additional Changes**

811+

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

813+and array expressions.

814+

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

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

817+

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

819+Please consult the documentation.

820+

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

822+

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

824+more than 50 new functions.

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

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

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

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

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

830+

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

832+

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

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

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

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

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

838+Please consult the documentation.

839+

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

841+

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

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

844+

845+```Haskell

846+data SchemumType

847+ = Table TableType

848+ | View RelationType

849+ | Typedef PGType

850+```

851+

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

853+

854+```Haskell

855+-- Squeal 0.2

856+type Schema =

857+ '[ "users" :::

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

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

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

861+ ]

862+ ]

863+

864+-- Squeal 0.3

865+type Schema =

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

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

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

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

870+ ])

871+ ]

872+```

873+

874+**Views**

875+

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

877+

878+```Haskell

879+>>> :{

880+type ABC =

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

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

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

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

885+ ]

886+type BC =

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

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

889+ ]

890+:}

891+

892+>>> :{

893+let

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

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

896+in printSQL definition

897+:}

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

899+

900+>>> :{

901+let

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

903+ definition = dropView #bc

904+in printSQL definition

905+:}

906+DROP VIEW "bc";

907+

908+>>> :{

909+let

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

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

912+in printSQL query

913+:}

914+SELECT * FROM "bc" AS "bc"

915+```

916+

917+**Enumerated Types**

918+

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

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

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

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

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

924+

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

926+

927+```Haskell

928+>>> :{

929+let

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

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

932+:}

933+>>> printSQL definition

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

935+```

936+

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

938+

939+```Haskell

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

941+>>> instance SOP.Generic Schwarma

942+>>> instance SOP.HasDatatypeInfo Schwarma

943+

944+>>> :kind! EnumFrom Schwarma

945+EnumFrom Schwarma :: PGType

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

947+

948+>>> :{

949+let

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

951+ definition = createTypeEnumFrom @Schwarma #schwarma

952+:}

953+>>> printSQL definition

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

955+```

956+

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

958+of the `IsPGlabel` typeclass.

959+

960+```Haskell

961+>>> :{

962+let

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

964+ expression = label @"Chicken"

965+in printSQL expression

966+:}

967+'Chicken'

968+```

969+

970+**Composite Types**

971+

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

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

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

975+

976+

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

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

979+

980+```Haskell

981+>>> :{

982+let

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

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

985+:}

986+>>> printSQL definition

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

988+```

989+

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

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

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

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

994+

995+```Haskell

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

997+>>> instance SOP.Generic Complex

998+>>> instance SOP.HasDatatypeInfo Complex

999+

1000+>>> :kind! CompositeFrom Complex

1001+CompositeFrom Complex :: PGType

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

1003+

1004+>>> :{

1005+let

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

1007+ definition = createTypeCompositeFrom @Complex #complex

1008+in printSQL definition

1009+:}

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

1011+```

1012+

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

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

1015+

1016+```Haskell

1017+>>> :{

1018+let

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

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

1021+:}

1022+>>> printSQL i

1023+ROW(0, 1)

1024+```

1025+

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

1027+

1028+```Haskell

1029+>>> :{

1030+let

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

1032+ expr = i & #imaginary

1033+in printSQL expr

1034+:}

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

1036+```

1037+

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

1039+And they can be dropped.

1040+

1041+```Haskell

1042+>>> :{

1043+let

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

1045+ definition = dropType #mood

1046+:}

1047+>>> printSQL definition

1048+DROP TYPE "mood";

1049+```

1050+

1051+**Additional Changes**

1052+

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

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

1055+

1056+```Haskell

1057+-- Squeal 0.2

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

1059+

1060+-- Squeal 0.3

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

1062+```

1063+

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

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

1066+

1067+```Haskell

1068+-- Squeal 0.2 (or 0.3)

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

1070+

1071+-- Squeal 0.3

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

1073+```

1074+

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

1076+

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

1078+Please consult the documentation.

1079+

31080### Version 0.2.1 - April 7, 2018

41081

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

scrap-your-nils.mdnew file+60

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

1+## Scrap your Nils

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

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

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

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

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

8+Squeal makes heavy use of this type.

10+```Haskell

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

12+>>> :i NP

13+type role NP representational nominal

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

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

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

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

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

19+```

20+

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

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

23+

24+```Haskell

25+>>> :set -XDataKinds

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

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

28+>>> example

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

30+```

31+

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

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

34+of the aliases themselves at the type level.

35+

36+```Haskell

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

38+>>> import GHC.TypeLits

39+>>> import GHC.OverloadedLabels

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

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

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

43+```

44+

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

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

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

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

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

50+the last label as a list.

51+

52+```Haskell

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

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

55+```

56+

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

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

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

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

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

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

1111

1212module Main (main, main2) where

1313

14−import Control.Monad (void)

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

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

1615import Data.Int (Int16, Int32)

1716import Data.Monoid ((<>))

1817import Data.Text (Text)

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

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

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

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

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

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

3332 ])

3433 , "emails" ::: 'Table (

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

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

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

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

4140 ])

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

4242 ]

4343

44−setup :: Definition '[] Schema

45−setup =

44+type Schemas = Public Schema

45+

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

47+setup =

4648 createTable #users

47− ( serial `As` #id :*

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

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

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

49+ ( serial `as` #id :*

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

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

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

5153 >>>

5254 createTable #emails

53− ( serial `As` #id :*

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

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

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

55+ ( serial `as` #id :*

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

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

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

5759 foreignKey #user_id #users #id

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

59−

60−teardown :: Definition Schema '[]

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

62−

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

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

65−insertUser = insertRows #users

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

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

68−

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

70−insertEmail = insertRows #emails

71− ( Default `As` #id :*

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

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

74− OnConflictDoNothing (Returning Nil)

75−

76−getUsers :: Query Schema '[]

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

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

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

80−getUsers = select

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

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

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

60+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

61+ >>>

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

63+

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

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

66+

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

68+insertUser = insertInto #users

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

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

71+

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

73+insertEmail = insertInto_ #emails

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

75+

76+getUsers :: Query_ Schemas () User

77+getUsers = select_

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

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

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

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

8582

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

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

8784 deriving (Show, GHC.Generic)

8885instance SOP.Generic User

8986instance SOP.HasDatatypeInfo User

9087

9188users :: [User]

92−users =

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

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

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

89+users =

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

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

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

9693 ]

9794

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

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

9996session = do

100− liftBase $ Char8.putStrLn "manipulating"

97+ liftIO $ Char8.putStrLn "manipulating"

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

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

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

104− liftBase $ Char8.putStrLn "querying"

101+ liftIO $ Char8.putStrLn "querying"

105102 usersResult <- runQuery getUsers

106103 usersRows <- getRows usersResult

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

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

108105

109106main :: IO ()

110107main = do

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

122119

123120main2 :: IO ()

124121main2 =

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

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

126123 define setup

127124 & pqThen session

128125 & pqThen (define teardown)

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

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

11name: squeal-postgresql

2−version: 0.3.0.0

2+version: 0.5.1.0

33synopsis: Squeal PostgreSQL Library

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

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

@@ -22,54 +22,116 @@ library

2222 hs-source-dirs: src

2323 exposed-modules:

2424 Squeal.PostgreSQL

25+ Squeal.PostgreSQL.Alias

2526 Squeal.PostgreSQL.Binary

2627 Squeal.PostgreSQL.Definition

28+ Squeal.PostgreSQL.Definition.Function

29+ Squeal.PostgreSQL.Definition.Index

30+ Squeal.PostgreSQL.Definition.Table

31+ Squeal.PostgreSQL.Definition.Table.Constraint

32+ Squeal.PostgreSQL.Definition.Type

33+ Squeal.PostgreSQL.Definition.Schema

34+ Squeal.PostgreSQL.Definition.View

2735 Squeal.PostgreSQL.Expression

36+ Squeal.PostgreSQL.Expression.Aggregate

37+ Squeal.PostgreSQL.Expression.Collection

38+ Squeal.PostgreSQL.Expression.Comparison

39+ Squeal.PostgreSQL.Expression.Json

40+ Squeal.PostgreSQL.Expression.Literal

41+ Squeal.PostgreSQL.Expression.Logic

42+ Squeal.PostgreSQL.Expression.Math

43+ Squeal.PostgreSQL.Expression.Null

44+ Squeal.PostgreSQL.Expression.Parameter

45+ Squeal.PostgreSQL.Expression.Range

46+ Squeal.PostgreSQL.Expression.Set

47+ Squeal.PostgreSQL.Expression.Sort

48+ Squeal.PostgreSQL.Expression.Subquery

49+ Squeal.PostgreSQL.Expression.Text

50+ Squeal.PostgreSQL.Expression.TextSearch

51+ Squeal.PostgreSQL.Expression.Time

52+ Squeal.PostgreSQL.Expression.Type

53+ Squeal.PostgreSQL.Expression.Window

54+ Squeal.PostgreSQL.List

2855 Squeal.PostgreSQL.Manipulation

2956 Squeal.PostgreSQL.Migration

3057 Squeal.PostgreSQL.Pool

58+ Squeal.PostgreSQL.PG

3159 Squeal.PostgreSQL.PQ

3260 Squeal.PostgreSQL.Render

3361 Squeal.PostgreSQL.Query

3462 Squeal.PostgreSQL.Schema

3563 Squeal.PostgreSQL.Transaction

3664 default-language: Haskell2010

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

65+ ghc-options: -Wall

3866 build-depends:

3967 aeson >= 1.2.4.0

40− , base >= 4.10.1.0 && < 5.0

68+ , base >= 4.11.1.0 && < 5.0

4169 , binary-parser >= 0.5.5

42− , bytestring-strict-builder >= 0.4.5

4370 , bytestring >= 0.10.8.2

71+ , bytestring-strict-builder >= 0.4.5

4472 , deepseq >= 1.4.3.0

45− , generics-sop >= 0.3.2.0

46− , lifted-base >= 0.2.3.12

73+ , free-categories >= 0.1.0.0

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

4775 , mmorph >= 1.1.1

48− , monad-control >= 1.0.2.3

4976 , mtl >= 2.2.2

5077 , network-ip >= 0.3.0.2

5178 , postgresql-binary >= 0.12.1

5279 , postgresql-libpq >= 0.9.4.1

80+ , records-sop >= 0.1.0.0

5381 , resource-pool >= 0.2.3.2

5482 , scientific >= 0.3.5.3

5583 , text >= 1.2.3.0

5684 , time >= 1.8.0.2

5785 , transformers >= 0.5.2.0

58− , transformers-base >= 0.4.4

86+ , unliftio >= 0.2.10

87+ , unliftio-pool >= 0.2.1.0

5988 , uuid-types >= 1.0.3

6089 , vector >= 0.12.0.1

6190

62−test-suite squeal-postgresql-doctest

91+test-suite doctest

6392 default-language: Haskell2010

6493 type: exitcode-stdio-1.0

6594 hs-source-dirs: test

6695 ghc-options: -Wall

67− main-is: DocTest.hs

96+ main-is: Doc.hs

6897 build-depends:

6998 base >= 4.10.0.0

7099 , doctest >= 0.11.4

100+ , squeal-postgresql

101+

102+test-suite properties

103+ default-language: Haskell2010

104+ type: exitcode-stdio-1.0

105+ hs-source-dirs: test

106+ ghc-options: -Wall

107+ main-is: Property.hs

108+ build-depends:

109+ base >= 4.10.0.0

110+ , bytestring >= 0.10.8.2

111+ , hedgehog >= 1.0

112+ , mtl >= 2.2.2

113+ , scientific >= 0.3.5.3

114+ , squeal-postgresql

115+ , time >= 1.8.0.2

116+

117+test-suite spec

118+ default-language: Haskell2010

119+ type: exitcode-stdio-1.0

120+ hs-source-dirs: test

121+ ghc-options: -Wall

122+ main-is: Spec.hs

123+ build-depends:

124+ base >= 4.10.0.0

125+ , async >= 2.2.2

126+ , bytestring >= 0.10.8.2

127+ , generics-sop >= 0.3.1.0

128+ , hspec >= 2.4.8

129+ , mtl >= 2.2.2

130+ , squeal-postgresql

131+ , text >= 1.2.2.2

132+ , vector >= 0.12.0.1

71133

72−executable squeal-postgresql-example

134+executable example

73135 default-language: Haskell2010

74136 hs-source-dirs: exe

75137 ghc-options: -Wall

@@ -82,5 +144,4 @@ executable squeal-postgresql-example

82144 , squeal-postgresql

83145 , text >= 1.2.2.2

84146 , transformers >= 0.5.2.0

85− , transformers-base >= 0.4.4

86147 , vector >= 0.12.0.1

squeal-postgresql/src/Squeal/PostgreSQL.hs+131−124

@@ -1,7 +1,7 @@

11{-|

22Module: Squeal.PostgreSQL

3−Description: Squeel export module

4−Copyright: (c) Eitan Chatav, 2017

3+Description: Squeal export module

4+Copyright: (c) Eitan Chatav, 2019

55Maintainer: eitan@morphism.tech

66Stability: experimental

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

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

1212features.

1313

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

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

16−

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

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

16+

1717We'll need some imports.

1818

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

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

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

2120>>> import Data.Int (Int32)

2221>>> import Data.Text (Text)

2322>>> import Squeal.PostgreSQL

24−>>> import qualified Data.ByteString.Char8 as Char8 (putStrLn)

2523

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

2725

@@ -32,145 +30,136 @@ The first step is to define the schema of our database. This is where

3230we use @DataKinds@ and @TypeOperators@.

3331

3432>>> :{

33+type UsersColumns =

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

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

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

37+type EmailsColumns =

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

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

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

41+type EmailsConstraints =

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

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

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

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

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

47+type Schemas = Public Schema

5048:}

5149

52−Notice the use of type operators. `:::` is used

53−to pair an alias `Symbol` with either a `TableType` or a `ColumnType`.

54−`:=>` is used to pair a `TableConstraint`s with a `ColumnsType`,

50+Notice the use of type operators.

51+

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

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

54+operator.

55+

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

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

56−yielding a `ColumnType`.

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

5759

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

59−Squeal, a `Definition` is a `createTable`, `alterTable` or `dropTable`

60−command and has two type parameters, corresponding to the schema

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

62+has two type parameters, corresponding to the schema

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

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

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

6466

6567>>> :{

6668let

67− setup :: Definition '[] Schema

68− setup =

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

70+ setup =

6971 createTable #users

70− ( serial `As` #id :*

71− (text & notNullable) `As` #name :* Nil )

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

72+ ( serial `as` #id :*

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

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

7375 createTable #emails

74− ( serial `As` #id :*

75− (int & notNullable) `As` #user_id :*

76− (text & nullable) `As` #email :* Nil )

77− ( primaryKey #id `As` #pk_emails :*

76+ ( serial `as` #id :*

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

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

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

7880 foreignKey #user_id #users #id

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

81+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

8082:}

8183

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

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

8385

84−>>> Char8.putStrLn $ renderDefinition setup

86+>>> printSQL setup

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

8688CREATE 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);

8789

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

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

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

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

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

9193`Definition` is simpler.

9294

9395>>> :{

9496let

95− teardown :: Definition Schema '[]

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

9698 teardown = dropTable #emails >>> dropTable #users

9799:}

98100

99−>>> Char8.putStrLn $ renderDefinition teardown

101+>>> printSQL teardown

100102DROP TABLE "emails";

101103DROP TABLE "users";

102104

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

104−A `Manipulation` is an `insertRow` (or other inserts), `update`

105−or `deleteFrom` command and

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

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

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

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

107+

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

109+>>> instance SOP.Generic User

110+>>> instance SOP.HasDatatypeInfo User

111+

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

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

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

115+and an output row. When

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

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

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

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

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

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

113−of our inserts.

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

121+`with` statement.

114122

115123>>> :{

116124let

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

118− insertUser = insertRow #users

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

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

125+ insertUser :: Manipulation_ Schemas User ()

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

127+ where

128+ u = insertInto #users

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

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

131+ e = insertInto_ #emails $ Select

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

133+ (from (common #u))

121134:}

122135

123−>>> :{

124−let

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

126− insertEmail = insertRow #emails

127− ( Default `As` #id :*

128− Set (param @1) `As` #user_id :*

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

130− OnConflictDoNothing (Returning Nil)

131−:}

132−

133−>>> Char8.putStrLn $ renderManipulation insertUser

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

135−>>> Char8.putStrLn $ renderManipulation insertEmail

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

136+>>> printSQL insertUser

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

137138

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

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

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

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

141−`Manipulation` with the same kind of type parameters.

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

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

142143

143144>>> :{

144145let

145− getUsers :: Query Schema '[]

146− '[ "userName" ::: 'NotNull 'PGtext

147− , "userEmail" ::: 'Null 'PGtext ]

148− getUsers = select

149− (#u ! #name `As` #userName :* #e ! #email `As` #userEmail :* Nil)

150− ( from (table (#users `As` #u)

151− & innerJoin (table (#emails `As` #e))

146+ getUsers :: Query_ Schemas () User

147+ getUsers = select_

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

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

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

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

153152:}

154153

155−>>> Char8.putStrLn $ renderQuery getUsers

154+>>> printSQL getUsers

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

157156

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

159−for users. We give the type `Generics.SOP.Generic` and

160−`Generics.SOP.HasDatatypeInfo` instances so that we can decode the rows

161−we receive when we run @getUsers@. Notice that the record fields of the

162−@User@ type match the column names of @getUsers@.

163−

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

165−>>> instance SOP.Generic User

166−>>> instance SOP.HasDatatypeInfo User

167−

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

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

169158

170159>>> :{

171160let

172161 users :: [User]

173− users =

162+ users =

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

175164 , User "Bob" Nothing

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

@@ -187,40 +176,58 @@ transformer and when the schema doesn't change we can use `Monad` and

187176

188177>>> :{

189178let

190− session :: PQ Schema Schema IO ()

179+ session :: PQ Schemas Schemas IO ()

191180 session = do

192− idResults <- traversePrepared insertUser (Only . userName <$> users)

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

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

181+ _ <- traversePrepared_ insertUser users

195182 usersResult <- runQuery getUsers

196183 usersRows <- getRows usersResult

197− liftBase $ print (usersRows :: [User])

198−:}

199−

200−>>> :{

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

202− define setup

203− & pqThen session

204− & pqThen (define teardown)

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

185+in

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

187+ define setup

188+ & pqThen session

189+ & pqThen (define teardown)

205190:}

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

207192-}

208−module Squeal.PostgreSQL

209− ( module Squeal.PostgreSQL.Binary

210− , module Squeal.PostgreSQL.Definition

211− , module Squeal.PostgreSQL.Expression

212− , module Squeal.PostgreSQL.Manipulation

213− , module Squeal.PostgreSQL.PQ

214− , module Squeal.PostgreSQL.Query

215− , module Squeal.PostgreSQL.Schema

216− , module Squeal.PostgreSQL.Transaction

217− ) where

218−

219−import Squeal.PostgreSQL.Binary

220−import Squeal.PostgreSQL.Definition

221−import Squeal.PostgreSQL.Expression

222−import Squeal.PostgreSQL.Manipulation

223−import Squeal.PostgreSQL.PQ

224−import Squeal.PostgreSQL.Query

225−import Squeal.PostgreSQL.Schema

226−import Squeal.PostgreSQL.Transaction

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

194+

195+import Squeal.PostgreSQL.Alias as X

196+import Squeal.PostgreSQL.Binary as X

197+import Squeal.PostgreSQL.Definition as X

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

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

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

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

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

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

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

205+import Squeal.PostgreSQL.Expression as X

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

224+import Squeal.PostgreSQL.List as X

225+import Squeal.PostgreSQL.Manipulation as X

226+import Squeal.PostgreSQL.Migration as X

227+import Squeal.PostgreSQL.PG as X

228+import Squeal.PostgreSQL.Pool as X

229+import Squeal.PostgreSQL.PQ as X

230+import Squeal.PostgreSQL.Query as X

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

232+import Squeal.PostgreSQL.Schema as X

233+import Squeal.PostgreSQL.Transaction as X

squeal-postgresql/src/Squeal/PostgreSQL/Alias.hsnew file+249

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

1+{-|

2+Module: Squeal.PostgreSQL.Alias

3+Description: Aliases

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

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

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

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

11+-}

12+

13+{-# LANGUAGE

14+ AllowAmbiguousTypes

15+ , ConstraintKinds

16+ , DeriveAnyClass

17+ , DeriveGeneric

18+ , FlexibleContexts

19+ , FlexibleInstances

20+ , FunctionalDependencies

21+ , GADTs

22+ , LambdaCase

23+ , OverloadedStrings

24+ , QuantifiedConstraints

25+ , RankNTypes

26+ , ScopedTypeVariables

27+ , StandaloneDeriving

28+ , TypeApplications

29+ , TypeFamilyDependencies

30+ , TypeInType

31+ , TypeOperators

32+ , UndecidableInstances

33+ , UndecidableSuperClasses

34+#-}

35+

36+module Squeal.PostgreSQL.Alias

37+ ( (:::)

38+ , Alias (..)

39+ , IsLabel (..)

40+ , Aliased (As)

41+ , Aliasable (as)

42+ , renderAliased

43+ , Has

44+ , HasUnique

45+ , HasAll

46+ , HasIn

47+ , QualifiedAlias (..)

48+ , IsQualified (..)

49+ -- * Grouping

50+ , Grouping (..)

51+ , GroupedBy

52+ ) where

53+

54+import Control.DeepSeq

55+import Data.ByteString (ByteString)

56+import Data.String (fromString)

57+import GHC.OverloadedLabels

58+import GHC.TypeLits

59+

60+import qualified Generics.SOP as SOP

61+import qualified GHC.Generics as GHC

62+

63+import Squeal.PostgreSQL.List

64+import Squeal.PostgreSQL.Render

65+

66+-- $setup

67+-- >>> import Squeal.PostgreSQL

68+

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

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

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

72+infixr 6 :::

73+

74+

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

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

77+-- for typesafe aggregation

78+data Grouping

79+ = Ungrouped -- ^ no aggregation permitted

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

81+

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

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

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

85+-}

86+class (KnownSymbol table, KnownSymbol column)

87+ => GroupedBy table column bys where

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

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

90+instance {-# OVERLAPPABLE #-}

91+ ( KnownSymbol table

92+ , KnownSymbol column

93+ , GroupedBy table column bys

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

95+

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

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

98+--

99+-- >>> :set -XOverloadedLabels

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

101+-- Alias

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

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

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

105+ fromLabel = Alias

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

107+ fromLabel = fromLabel SOP.:* Nil

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

109+-- "jimbob"

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

111+ renderSQL = doubleQuoted . fromString . symbolVal

112+

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

114+-- "jimbob", "kandi"

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

116+ renderSQL

117+ = commaSeparated

118+ . SOP.hcollapse

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

120+

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

122+-- version of `:::`.

123+--

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

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

126+data Aliased expression aliased where

127+ As

128+ :: KnownSymbol alias

129+ => expression ty

130+ -> Alias alias

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

132+deriving instance Show (expression ty)

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

134+deriving instance Eq (expression ty)

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

136+deriving instance Ord (expression ty)

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

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

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

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

141+

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

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

144+class KnownSymbol alias => Aliasable alias expression aliased

145+ | aliased -> expression

146+ , aliased -> alias

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

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

149+ (expression ty)

150+ (Aliased expression aliased)

151+ where

152+ as = As

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

154+ (expression ty)

155+ (NP (Aliased expression) tys)

156+ where

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

158+

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

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

161+-- "Just AS \"an_int\""

162+renderAliased

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

164+ -> Aliased expression aliased

165+ -> ByteString

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

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

168+

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

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

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

172+

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

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

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

176+class KnownSymbol alias =>

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

178+ | alias fields -> field where

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

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

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

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

183+

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

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

186+choose which subfields to update.

187+-}

188+class HasIn fields field where

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

190+

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

192+-- a list of @subfields@.

193+class

194+ ( SOP.All KnownSymbol aliases

195+ ) => HasAll

196+ (aliases :: [Symbol])

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

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

199+ | aliases fields -> subfields where

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

201+instance {-# OVERLAPPABLE #-}

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

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

204+

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

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

207+-- by a table alias.

208+class IsQualified table column expression where

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

210+ infixl 9 !

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

212+

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

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

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

216+a qualifier of @public@ is provided.

217+

218+>>> :{

219+let

220+ alias1 :: QualifiedAlias "sch" "tab"

221+ alias1 = #sch ! #tab

222+ alias2 :: QualifiedAlias "public" "vw"

223+ alias2 = #vw

224+in printSQL alias1 >> printSQL alias2

225+:}

226+"sch"."tab"

227+"vw"

228+-}

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

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

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

232+ _!_ = QualifiedAlias

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

234+ fromLabel = QualifiedAlias

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

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

237+ _!_ = QualifiedAlias `As` Alias

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

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

240+ fromLabel = QualifiedAlias `As` Alias

241+

242+instance (KnownSymbol q, KnownSymbol a)

243+ => RenderSQL (QualifiedAlias q a) where

244+ renderSQL _ =

245+ let

246+ qualifier = renderSQL (Alias @q)

247+ alias = renderSQL (Alias @a)

248+ in

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

squeal-postgresql/src/Squeal/PostgreSQL/Binary.hs+586−227

@@ -5,81 +5,177 @@ 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.

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

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

12+to encode Haskell values into statement parameters.

1113

12−Let's see an example of a round trip, inserting a row containing an value of enumerated type

13−and a value of composite type by encoding Haskell values into Postgres binary format

14−and then decoding them back into Haskell.

15−

16−>>> import Control.Monad

17−>>> import Control.Monad.Base

18−>>> import Data.Text

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

1915

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

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

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

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

2020>>> import Squeal.PostgreSQL

21−>>> import qualified Squeal.PostgreSQL as SQL

2221

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

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

23+round trip query.

24+

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

26+>>> instance Generic Row

27+>>> instance HasDatatypeInfo Row

28+>>> :{

29+let

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

31+ roundTrip = values_ $

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

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

34+ parameter @3 bool `as` #col3

35+:}

36+

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

38+the input and output should be equal.

39+

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

41+>>> :{

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

43+ result <- runQueryParams roundTrip input

44+ Just output <- firstRow result

45+ liftIO . print $ input == output

46+:}

47+True

48+

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

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

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

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

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

54+create multi-dimensional fixed length arrays.

55+

56+>>> :{

57+data Row = Row

58+ { col1 :: VarArray (Vector Int16)

59+ , col2 :: FixArray (Maybe Int16,Maybe Int16)

60+ , col3 :: FixArray ((Int16,Int16),(Int16,Int16),(Int16,Int16))

61+ } deriving (Eq, GHC.Generic)

62+:}

63+

64+>>> instance Generic Row

65+>>> instance HasDatatypeInfo Row

66+

67+Once again, we define a simple round trip query.

68+

69+>>> :{

70+let

71+ roundTrip :: Query_ (Public '[]) Row Row

72+ roundTrip = values_ $

73+ parameter @1 (int2 & vararray) `as` #col1 :*

74+ parameter @2 (int2 & fixarray @'[2]) `as` #col2 :*

75+ parameter @3 (int2 & fixarray @'[3,2]) `as` #col3

76+:}

77+

78+>>> :set -XOverloadedLists

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

80+>>> :{

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

82+ result <- runQueryParams roundTrip input

83+ Just output <- firstRow result

84+ liftIO . print $ input == output

85+:}

86+True

87+

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

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

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

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

92+

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

2494>>> instance Generic Schwarma

2595>>> instance HasDatatypeInfo Schwarma

2696

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

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

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

99+

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

28101>>> instance Generic Person

29102>>> instance HasDatatypeInfo Person

103+>>> instance Aeson.FromJSON Person

104+>>> instance Aeson.ToJSON Person

105+

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

30107

31−>>> :set -XTypeFamilies -XTypeInType -XUndecidableInstances

32108>>> :{

33−type family Schema :: SchemaType where

34− Schema =

35− '[ "schwarma" ::: 'Typedef (EnumWith Schwarma)

36− , "person" ::: 'Typedef (CompositeWith Person)

37− , "tab" ::: 'Table ('[] :=>

38− '[ "col1" ::: 'NoDef :=> 'NotNull (EnumWith Schwarma)

39− , "col2" ::: 'NoDef :=> 'NotNull (CompositeWith Person)

40− ])

41− ]

109+type Schema =

110+ '[ "schwarma" ::: 'Typedef (PG (Enumerated Schwarma))

111+ , "person" ::: 'Typedef (PG (Composite Person))

112+ ]

42113:}

43114

44115>>> :{

45116let

46− setup :: Definition '[] Schema

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

47118 setup =

48− createTypeEnumWith @Schwarma #schwarma >>>

49− createTypeCompositeWith @Person #person >>>

50− createTable #tab (

51− notNullable #schwarma `As` #col1 :*

52− notNullable #person `As` #col2 :* Nil

53− ) Nil

54− teardown :: Definition Schema '[]

55− teardown = dropTable #tab >>> dropType #schwarma >>> dropType #person

56− manip :: Manipulation Schema '[ 'NotNull (EnumWith Schwarma), 'NotNull (CompositeWith Person)] '[]

57− manip =

58− insertRow_ #tab (

59− Set (parameter @1 #schwarma) `As` #col1 :*

60− Set (parameter @2 #person) `As` #col2 :* Nil)

61− qry1 :: Query Schema '[] '["fromOnly" ::: 'NotNull (EnumWith Schwarma)]

62− qry1 = select (#col1 `As` #fromOnly :* Nil) (SQL.from (table #tab))

63− qry2 :: Query Schema '[] '["fromOnly" ::: 'NotNull (CompositeWith Person)]

64− qry2 = select (#col2 `As` #fromOnly :* Nil) (SQL.from (table #tab))

65− session = do

66− manipulateParams manip (Chicken, Person (Just "Faisal") (Just 24))

67− result1 <- runQuery qry1

68− Just (Only schwarma) <- firstRow result1

69− liftBase $ print (schwarma :: Schwarma)

70− result2 <- runQuery qry2

71− Just (Only person) <- firstRow result2

72− liftBase $ print (person :: Person)

119+ createTypeEnumFrom @Schwarma #schwarma >>>

120+ createTypeCompositeFrom @Person #person

121+:}

122+

123+Let's demonstrate how to associate our Haskell types @Schwarma@ and @Person@

124+with enumerated, composite or json types in Postgres. First create a Haskell

125+@Row@ type using the `Enumerated`, `Composite` and `Json` newtypes as fields.

126+

127+>>> :{

128+data Row = Row

129+ { schwarma :: Enumerated Schwarma

130+ , person1 :: Composite Person

131+ , person2 :: Json Person

132+ } deriving (Eq, GHC.Generic)

133+:}

134+

135+>>> instance Generic Row

136+>>> instance HasDatatypeInfo Row

137+>>> :{

138+let

139+ input = Row

140+ (Enumerated Chicken)

141+ (Composite (Person "Faisal" 24))

142+ (Json (Person "Ahmad" 48))

73143:}

74144

145+Once again, define a round trip query.

146+

75147>>> :{

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

77− define setup

78− & pqThen session

79− & pqThen (define teardown)

148+let

149+ roundTrip :: Query_ (Public Schema) Row Row

150+ roundTrip = values_ $

151+ parameter @1 (typedef #schwarma) `as` #schwarma :*

152+ parameter @2 (typedef #person) `as` #person1 :*

153+ parameter @3 json `as` #person2

80154:}

81−Chicken

82−Person {name = Just "Faisal", age = Just 24}

155+

156+Finally, we can drop our type definitions.

157+

158+>>> :{

159+let

160+ teardown :: Definition (Public Schema) (Public '[])

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

162+:}

163+

164+Now let's run it.

165+

166+>>> :{

167+let

168+ session = do

169+ result <- runQueryParams roundTrip input

170+ Just output <- firstRow result

171+ liftIO . print $ input == output

172+in

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

174+ define setup

175+ & pqThen session

176+ & pqThen (define teardown)

177+:}

178+True

83179-}

84180

85181{-# LANGUAGE

@@ -88,55 +184,76 @@ Person {name = Just "Faisal", age = Just 24}

88184 , DeriveFunctor

89185 , DeriveGeneric

90186 , DeriveTraversable

187+ , DefaultSignatures

91188 , FlexibleContexts

92189 , FlexibleInstances

190+ , FunctionalDependencies

93191 , GADTs

94192 , LambdaCase

193+ , OverloadedStrings

95194 , MultiParamTypeClasses

96195 , ScopedTypeVariables

97196 , TypeApplications

197+ , TypeFamilies

98198 , TypeInType

99199 , TypeOperators

100200 , UndecidableInstances

201+ , UndecidableSuperClasses

101202#-}

102203

103204module Squeal.PostgreSQL.Binary

104205 ( -- * Encoding

105206 ToParam (..)

106− , ToColumnParam (..)

107207 , ToParams (..)

208+ , ToNullityParam (..)

209+ , ToField (..)

210+ , ToFixArray (..)

108211 -- * Decoding

109212 , FromValue (..)

110− , FromColumnValue (..)

111213 , FromRow (..)

214+ , FromField (..)

215+ , FromFixArray (..)

112216 -- * Only

113217 , Only (..)

218+ -- * Oid

219+ , OidOf (..)

220+ , OidOfParam (..)

221+ , OidOfField (..)

114222 ) where

115223

116224import BinaryParser

117−import ByteString.StrictBuilder

118−import Data.Aeson hiding (Null)

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

226+import Control.Arrow (left)

227+import Control.Monad

119228import Data.Int

120229import Data.Kind

121−import Data.Monoid hiding (All)

122230import Data.Scientific

123231import Data.Time

124232import Data.UUID.Types

125233import Data.Vector (Vector)

126234import Data.Word

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

127236import Generics.SOP

237+import Generics.SOP.Record

128238import GHC.TypeLits

129239import Network.IP.Addr

130240

131−import qualified Data.ByteString.Lazy as Lazy

132−import qualified Data.ByteString as Strict hiding (pack, unpack)

133−import qualified Data.Text.Lazy as Lazy

134−import qualified Data.Text as Strict

241+import qualified Data.Aeson as Aeson

242+import qualified Data.ByteString.Lazy as Lazy (ByteString)

243+import qualified Data.ByteString.Lazy as Lazy.ByteString

244+import qualified Data.ByteString as Strict (ByteString)

245+import qualified Data.Text.Lazy as Lazy (Text)

246+import qualified Data.Text as Strict (Text)

247+import qualified Data.Text as Strict.Text

135248import qualified Data.Vector as Vector

249+import qualified Database.PostgreSQL.LibPQ as LibPQ

136250import qualified GHC.Generics as GHC

137251import qualified PostgreSQL.Binary.Decoding as Decoding

138252import qualified PostgreSQL.Binary.Encoding as Encoding

139253

254+import Squeal.PostgreSQL.Alias

255+import Squeal.PostgreSQL.List

256+import Squeal.PostgreSQL.PG

140257import Squeal.PostgreSQL.Schema

141258

142259-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into

@@ -160,19 +277,20 @@ class ToParam (x :: Type) (pg :: PGType) where

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

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

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

163−instance ToParam Word16 'PGint2 where toParam = K . Encoding.int2_word16

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

165−instance ToParam Word32 'PGint4 where toParam = K . Encoding.int4_word32

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

167−instance ToParam Word64 'PGint8 where toParam = K . Encoding.int8_word64

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

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

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

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

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

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

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

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

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

175291instance ToParam Lazy.Text 'PGtext where toParam = K . Encoding.text_lazy

292+instance ToParam String 'PGtext where

293+ toParam = K . Encoding.text_strict . Strict.Text.pack

176294instance ToParam Strict.ByteString 'PGbytea where

177295 toParam = K . Encoding.bytea_strict

178296instance ToParam Lazy.ByteString 'PGbytea where

@@ -186,17 +304,40 @@ instance ToParam LocalTime 'PGtimestamp where

186304instance ToParam UTCTime 'PGtimestamptz where

187305 toParam = K . Encoding.timestamptz_int

188306instance ToParam DiffTime 'PGinterval where toParam = K . Encoding.interval_int

189−instance ToParam Value 'PGjson where toParam = K . Encoding.json_ast

190−instance ToParam Value 'PGjsonb where toParam = K . Encoding.jsonb_ast

191−instance (HasOid pg, ToParam x pg)

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

193− toParam = K . Encoding.nullableArray_vector

194− (oid @pg) (unK . toParam @x @pg)

307+instance ToParam Aeson.Value 'PGjson where toParam = K . Encoding.json_ast

308+instance ToParam Aeson.Value 'PGjsonb where toParam = K . Encoding.jsonb_ast

309+instance Aeson.ToJSON x => ToParam (Json x) 'PGjson where

310+ toParam = K . Encoding.json_bytes

311+ . Lazy.ByteString.toStrict . Aeson.encode . getJson

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

313+ toParam = K . Encoding.jsonb_bytes

314+ . Lazy.ByteString.toStrict . Aeson.encode . getJsonb

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

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

317+ toParam = K

318+ . Encoding.array_foldable

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

320+ . getVarArray

321+instance (ToParam x pg, OidOf pg)

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

323+ toParam = K

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

325+ . getVarArray

326+instance (ToParam x pg, OidOf pg)

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

328+ toParam = K

329+ . Encoding.nullableArray_vector

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

331+ . getVarArray

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

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

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

335+ . unK . unK . toFixArray @x @dims @ty . getFixArray

195336instance

196337 ( IsEnumType x

197338 , HasDatatypeInfo x

198− , LabelsWith x ~ labels

199− ) => ToParam x ('PGenum labels) where

339+ , LabelsPG x ~ labels

340+ ) => ToParam (Enumerated x) ('PGenum labels) where

200341 toParam =

201342 let

202343 gshowConstructor :: NP ConstructorInfo xss -> SOP I xss -> String

@@ -207,24 +348,23 @@ instance

207348 gshowConstructor constructors (SOP xs)

208349 in

209350 K . Encoding.text_strict

210− . Strict.pack

351+ . Strict.Text.pack

211352 . gshowConstructor (constructorInfo (datatypeInfo (Proxy @x)))

212353 . from

354+ . getEnumerated

213355instance

214356 ( SListI fields

215− , MapMaybes xs

216− , IsProductType x (Maybes xs)

217− , AllZip ToAliasedParam xs fields

218− , FieldNamesWith x ~ AliasesOf fields

219− , All HasAliasedOid fields

220− ) => ToParam x ('PGcomposite fields) where

357+ , IsRecord x xs

358+ , AllZip ToField xs fields

359+ , All OidOfField fields

360+ ) => ToParam (Composite x) ('PGcomposite fields) where

221361 toParam =

222362 let

223363

224− encoders = htrans (Proxy @ToAliasedParam) toAliasedParam

364+ encoders = htrans (Proxy @ToField) toField

225365

226366 composite

227− :: All HasAliasedOid row

367+ :: All OidOfField row

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

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

230370 composite fields = K $

@@ -241,53 +381,179 @@ instance

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

242382 let

243383 each

244− :: HasAliasedOid field

384+ :: OidOfField field

245385 => K (Maybe Encoding.Encoding) field

246386 -> Encoding.Encoding

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

248− word32BE (aliasedOid @field)

388+ word32BE (getOid (oidOfField @field))

249389 <> case field of

250390 Nothing -> int64BE (-1)

251391 Just value ->

252392 int32BE (fromIntegral (builderLength value))

253393 <> value

254394 in

255− hcfoldMap (Proxy @HasAliasedOid) each fields

395+ hcfoldMap (Proxy @OidOfField) each fields

256396

257397 in

258− composite . encoders . unMaybes . unZ . unSOP . from

259−

260−class HasAliasedOid (field :: (Symbol, PGType)) where aliasedOid :: Word32

261−instance HasOid ty => HasAliasedOid (alias ::: ty) where aliasedOid = oid @ty

262−

263−class ToAliasedParam (x :: Type) (field :: (Symbol, PGType)) where

264− toAliasedParam :: Maybe x -> K (Maybe Encoding.Encoding) field

265−instance ToParam x ty => ToAliasedParam x (alias ::: ty) where

266− toAliasedParam = \case

267− Nothing -> K Nothing

268− Just x -> K . Just . unK $ toParam @x @ty x

269−

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

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

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

273−class ToColumnParam (x :: Type) (ty :: NullityType) where

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

275− -- K (Just "\NUL\NUL")

276− --

277− -- >>> toColumnParam @(Maybe Int16) @('Null 'PGint2) (Just 0)

278− -- K (Just "\NUL\NUL")

279− --

280− -- >>> toColumnParam @(Maybe Int16) @('Null 'PGint2) Nothing

281− -- K Nothing

282− toColumnParam :: x -> K (Maybe Strict.ByteString) ty

283−instance ToParam x pg => ToColumnParam x ('NotNull pg) where

284− toColumnParam = K . Just . Encoding.encodingBytes . unK . toParam @x @pg

285−instance ToParam x pg => ToColumnParam (Maybe x) ('Null pg) where

286− toColumnParam = K . fmap (Encoding.encodingBytes . unK . toParam @x @pg)

398+ composite . encoders . toRecord . getComposite

399+

400+-- | The object identifier of a `PGType`.

401+--

402+-- >>> :set -XTypeApplications

403+-- >>> oidOf @'PGbool

404+-- Oid 16

405+class OidOf (ty :: PGType) where oidOf :: LibPQ.Oid

406+instance OidOf 'PGbool where oidOf = LibPQ.Oid 16

407+instance OidOf ('PGfixarray ns (null 'PGbool)) where oidOf = LibPQ.Oid 1000

408+instance OidOf ('PGvararray (null 'PGbool)) where oidOf = LibPQ.Oid 1000

409+instance OidOf 'PGint2 where oidOf = LibPQ.Oid 21

410+instance OidOf ('PGfixarray ns (null 'PGint2)) where oidOf = LibPQ.Oid 1005

411+instance OidOf ('PGvararray (null 'PGint2)) where oidOf = LibPQ.Oid 1005

412+instance OidOf 'PGint4 where oidOf = LibPQ.Oid 23

413+instance OidOf ('PGfixarray ns (null 'PGint4)) where oidOf = LibPQ.Oid 1007

414+instance OidOf ('PGvararray (null 'PGint4)) where oidOf = LibPQ.Oid 1007

415+instance OidOf 'PGint8 where oidOf = LibPQ.Oid 20

416+instance OidOf ('PGfixarray ns (null 'PGint8)) where oidOf = LibPQ.Oid 1016

417+instance OidOf ('PGvararray (null 'PGint8)) where oidOf = LibPQ.Oid 1016

418+instance OidOf 'PGnumeric where oidOf = LibPQ.Oid 1700

419+instance OidOf ('PGfixarray ns (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231

420+instance OidOf ('PGvararray (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231

421+instance OidOf 'PGfloat4 where oidOf = LibPQ.Oid 700

422+instance OidOf ('PGfixarray ns (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021

423+instance OidOf ('PGvararray (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021

424+instance OidOf 'PGfloat8 where oidOf = LibPQ.Oid 701

425+instance OidOf ('PGfixarray ns (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022

426+instance OidOf ('PGvararray (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022

427+instance OidOf 'PGmoney where oidOf = LibPQ.Oid 790

428+instance OidOf ('PGfixarray ns (null 'PGmoney)) where oidOf = LibPQ.Oid 791

429+instance OidOf ('PGvararray (null 'PGmoney)) where oidOf = LibPQ.Oid 791

430+instance OidOf ('PGchar n) where oidOf = LibPQ.Oid 18

431+instance OidOf ('PGfixarray ns (null ('PGchar n))) where oidOf = LibPQ.Oid 1002

432+instance OidOf ('PGvararray (null ('PGchar n))) where oidOf = LibPQ.Oid 1002

433+instance OidOf ('PGvarchar n) where oidOf = LibPQ.Oid 1043

434+instance OidOf ('PGfixarray ns (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015

435+instance OidOf ('PGvararray (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015

436+instance OidOf 'PGtext where oidOf = LibPQ.Oid 25

437+instance OidOf ('PGfixarray ns (null 'PGtext)) where oidOf = LibPQ.Oid 1009

438+instance OidOf ('PGvararray (null 'PGtext)) where oidOf = LibPQ.Oid 1009

439+instance OidOf 'PGbytea where oidOf = LibPQ.Oid 17

440+instance OidOf ('PGfixarray ns (null 'PGbytea)) where oidOf = LibPQ.Oid 1001

441+instance OidOf ('PGvararray (null 'PGbytea)) where oidOf = LibPQ.Oid 1001

442+instance OidOf 'PGtimestamp where oidOf = LibPQ.Oid 1114

443+instance OidOf ('PGfixarray ns (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115

444+instance OidOf ('PGvararray (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115

445+instance OidOf 'PGtimestamptz where oidOf = LibPQ.Oid 1184

446+instance OidOf ('PGfixarray ns (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185

447+instance OidOf ('PGvararray (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185

448+instance OidOf 'PGdate where oidOf = LibPQ.Oid 1082

449+instance OidOf ('PGfixarray ns (null 'PGdate)) where oidOf = LibPQ.Oid 1182

450+instance OidOf ('PGvararray (null 'PGdate)) where oidOf = LibPQ.Oid 1182

451+instance OidOf 'PGtime where oidOf = LibPQ.Oid 1083

452+instance OidOf ('PGfixarray ns (null 'PGtime)) where oidOf = LibPQ.Oid 1183

453+instance OidOf ('PGvararray (null 'PGtime)) where oidOf = LibPQ.Oid 1183

454+instance OidOf 'PGtimetz where oidOf = LibPQ.Oid 1266

455+instance OidOf ('PGfixarray ns (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270

456+instance OidOf ('PGvararray (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270

457+instance OidOf 'PGinterval where oidOf = LibPQ.Oid 1186

458+instance OidOf ('PGfixarray ns (null 'PGinterval)) where oidOf = LibPQ.Oid 1187

459+instance OidOf ('PGvararray (null 'PGinterval)) where oidOf = LibPQ.Oid 1187

460+instance OidOf 'PGuuid where oidOf = LibPQ.Oid 2950

461+instance OidOf ('PGfixarray ns (null 'PGuuid)) where oidOf = LibPQ.Oid 2951

462+instance OidOf ('PGvararray (null 'PGuuid)) where oidOf = LibPQ.Oid 2951

463+instance OidOf 'PGinet where oidOf = LibPQ.Oid 869

464+instance OidOf ('PGfixarray ns (null 'PGinet)) where oidOf = LibPQ.Oid 1041

465+instance OidOf ('PGvararray (null 'PGinet)) where oidOf = LibPQ.Oid 1041

466+instance OidOf 'PGjson where oidOf = LibPQ.Oid 114

467+instance OidOf ('PGfixarray ns (null 'PGjson)) where oidOf = LibPQ.Oid 199

468+instance OidOf ('PGvararray (null 'PGjson)) where oidOf = LibPQ.Oid 199

469+instance OidOf 'PGjsonb where oidOf = LibPQ.Oid 3802

470+instance OidOf ('PGfixarray ns (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807

471+instance OidOf ('PGvararray (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807

472+instance OidOf 'PGtsvector where oidOf = LibPQ.Oid 3614

473+instance OidOf ('PGfixarray ns (null 'PGtsvector)) where oidOf = LibPQ.Oid 3643

474+instance OidOf ('PGvararray (null 'PGtsvector)) where oidOf = LibPQ.Oid 3643

475+instance OidOf 'PGtsquery where oidOf = LibPQ.Oid 3615

476+instance OidOf ('PGfixarray ns (null 'PGtsquery)) where oidOf = LibPQ.Oid 3645

477+instance OidOf ('PGvararray (null 'PGtsquery)) where oidOf = LibPQ.Oid 3645

478+instance OidOf 'PGoid where oidOf = LibPQ.Oid 26

479+instance OidOf ('PGfixarray ns (null 'PGoid)) where oidOf = LibPQ.Oid 1028

480+instance OidOf ('PGvararray (null 'PGoid)) where oidOf = LibPQ.Oid 1028

481+instance OidOf ('PGrange 'PGint4) where oidOf = LibPQ.Oid 3904

482+instance OidOf ('PGfixarray ns (null ('PGrange 'PGint4))) where oidOf = LibPQ.Oid 3905

483+instance OidOf ('PGvararray (null ('PGrange 'PGint4))) where oidOf = LibPQ.Oid 3905

484+instance OidOf ('PGrange 'PGint8) where oidOf = LibPQ.Oid 3926

485+instance OidOf ('PGfixarray ns (null ('PGrange 'PGint8))) where oidOf = LibPQ.Oid 3927

486+instance OidOf ('PGvararray (null ('PGrange 'PGint8))) where oidOf = LibPQ.Oid 3927

487+instance OidOf ('PGrange 'PGnumeric) where oidOf = LibPQ.Oid 3906

488+instance OidOf ('PGfixarray ns (null ('PGrange 'PGnumeric))) where oidOf = LibPQ.Oid 3907

489+instance OidOf ('PGvararray (null ('PGrange 'PGnumeric))) where oidOf = LibPQ.Oid 3907

490+instance OidOf ('PGrange 'PGtimestamp) where oidOf = LibPQ.Oid 3908

491+instance OidOf ('PGfixarray ns (null ('PGrange 'PGtimestamp))) where oidOf = LibPQ.Oid 3909

492+instance OidOf ('PGvararray (null ('PGrange 'PGtimestamp))) where oidOf = LibPQ.Oid 3909

493+instance OidOf ('PGrange 'PGtimestamptz) where oidOf = LibPQ.Oid 3910

494+instance OidOf ('PGfixarray ns (null ('PGrange 'PGtimestamptz))) where oidOf = LibPQ.Oid 3911

495+instance OidOf ('PGvararray (null ('PGrange 'PGtimestamptz))) where oidOf = LibPQ.Oid 3911

496+instance OidOf ('PGrange 'PGdate) where oidOf = LibPQ.Oid 3912

497+instance OidOf ('PGfixarray ns (null ('PGrange 'PGdate))) where oidOf = LibPQ.Oid 3913

498+instance OidOf ('PGvararray (null ('PGrange 'PGdate))) where oidOf = LibPQ.Oid 3913

499+instance {-# OVERLAPPABLE #-} OidOf ('PGrange ty) where oidOf = LibPQ.invalidOid

500+instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGrange ty))) where oidOf = LibPQ.invalidOid

501+instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGrange ty))) where oidOf = LibPQ.invalidOid

502+instance {-# OVERLAPPABLE #-} OidOf ('PGcomposite row) where oidOf = LibPQ.invalidOid

503+instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGcomposite row))) where oidOf = LibPQ.invalidOid

504+instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGcomposite row))) where oidOf = LibPQ.invalidOid

505+instance {-# OVERLAPPABLE #-} OidOf ('PGenum labels) where oidOf = LibPQ.invalidOid

506+instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGenum labels))) where oidOf = LibPQ.invalidOid

507+instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGenum labels))) where oidOf = LibPQ.invalidOid

508+

509+class OidOfParam (ty :: NullityType) where oidOfParam :: Oid

510+instance OidOf ty => OidOfParam (null ty) where oidOfParam = oidOf @ty

511+

512+-- | Lifts a `OidOf` constraint to a field.

513+class OidOfField (field :: (Symbol, NullityType)) where

514+ oidOfField :: Oid

515+instance OidOf ty => OidOfField (alias ::: nullity ty) where

516+ oidOfField = oidOf @ty

517+

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

519+-- into the binary format of a PostgreSQL `NullityType`.

520+class ToNullityParam (x :: Type) (ty :: NullityType) where

521+ toNullityParam :: x -> K (Maybe Encoding.Encoding) ty

522+instance ToParam x pg => ToNullityParam x ('NotNull pg) where

523+ toNullityParam = K . Just . unK . toParam @x @pg

524+instance ToParam x pg => ToNullityParam (Maybe x) ('Null pg) where

525+ toNullityParam = K . fmap (unK . toParam @x @pg)

526+

527+-- | A `ToField` constraint lifts the `ToParam` parser

528+-- to an encoding of a @(Symbol, Type)@ to a @(Symbol, NullityType)@,

529+-- encoding `Null`s to `Maybe`s. You should not define instances for

530+-- `FromField`, just use the provided instances.

531+class ToField (x :: (Symbol, Type)) (field :: (Symbol, NullityType)) where

532+ toField :: P x -> K (Maybe Encoding.Encoding) field

533+instance ToNullityParam x ty => ToField (alias ::: x) (alias ::: ty) where

534+ toField (P x) = K . unK $ toNullityParam @x @ty x

535+

536+-- | A `ToFixArray` constraint gives an encoding of a Haskell `Type`

537+-- into the binary format of a PostgreSQL fixed-length array.

538+-- You should not define instances for

539+-- `ToFixArray`, just use the provided instances.

540+class ToFixArray (x :: Type) (dims :: [Nat]) (array :: NullityType) where

541+ toFixArray :: x -> K (K Encoding.Array dims) array

542+instance ToNullityParam x ty => ToFixArray x '[] ty where

543+ toFixArray = K . K . maybe Encoding.nullArray Encoding.encodingArray . unK

544+ . toNullityParam @x @ty

545+instance

546+ ( IsProductType product xs

547+ , Length xs ~ dim

548+ , All ((~) x) xs

549+ , ToFixArray x dims ty )

550+ => ToFixArray product (dim ': dims) ty where

551+ toFixArray = K . K . Encoding.dimensionArray foldlN

552+ (unK . unK . toFixArray @x @dims @ty) . unZ . unSOP . from

287553

288554-- | A `ToParams` constraint generically sequences the encodings of `Type`s

289555-- of the fields of a tuple or record to a row of `ColumnType`s. You should

290−-- not define instances of `ToParams`. Instead define `Generic` instances

556+-- not define instances of `ToParams`. Instead define `SOP.Generic` instances

291557-- which in turn provide `ToParams` instances.

292558class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where

293559 -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2]

@@ -299,61 +565,98 @@ class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where

299565 -- >>> instance Generic Tuple

300566 -- >>> toParams @Tuple @Params (Tuple False (Just 0))

301567 -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil

302− toParams :: x -> NP (K (Maybe Strict.ByteString)) tys

303−instance (SListI tys, IsProductType x xs, AllZip ToColumnParam xs tys)

568+ toParams :: x -> NP (K (Maybe Encoding.Encoding)) tys

569+instance (SListI tys, IsProductType x xs, AllZip ToNullityParam xs tys)

304570 => ToParams x tys where

305571 toParams

306− = htrans (Proxy @ToColumnParam) (toColumnParam . unI)

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

307573 . unZ . unSOP . from

308574

309575-- | A `FromValue` constraint gives a parser from the binary format of

310576-- a PostgreSQL `PGType` into a Haskell `Type`.

311577class FromValue (pg :: PGType) (y :: Type) where

312578 -- | >>> newtype Id = Id { getId :: Int16 } deriving Show

313− -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue

314− fromValue :: proxy pg -> Decoding.Value y

315−instance FromValue 'PGbool Bool where fromValue _ = Decoding.bool

316−instance FromValue 'PGint2 Int16 where fromValue _ = Decoding.int

317−instance FromValue 'PGint4 Int32 where fromValue _ = Decoding.int

318−instance FromValue 'PGint8 Int64 where fromValue _ = Decoding.int

319−instance FromValue 'PGfloat4 Float where fromValue _ = Decoding.float4

320−instance FromValue 'PGfloat8 Double where fromValue _ = Decoding.float8

321−instance FromValue 'PGnumeric Scientific where fromValue _ = Decoding.numeric

322−instance FromValue 'PGuuid UUID where fromValue _ = Decoding.uuid

323−instance FromValue 'PGinet (NetAddr IP) where fromValue _ = Decoding.inet

324−instance FromValue ('PGchar 1) Char where fromValue _ = Decoding.char

325−instance FromValue 'PGtext Strict.Text where fromValue _ = Decoding.text_strict

326−instance FromValue 'PGtext Lazy.Text where fromValue _ = Decoding.text_lazy

579+ -- >>> instance FromValue 'PGint2 Id where fromValue = Id <$> fromValue @'PGint2

580+ fromValue :: Decoding.Value y

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

582+instance FromValue 'PGint2 Int16 where fromValue = Decoding.int

583+instance FromValue 'PGint4 Int32 where fromValue = Decoding.int

584+instance FromValue 'PGint8 Int64 where fromValue = Decoding.int

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

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

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

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

589+instance FromValue 'PGmoney Money where fromValue = Money <$> Decoding.int

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

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

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

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

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

595+instance FromValue 'PGtext String where

596+ fromValue = Strict.Text.unpack <$> Decoding.text_strict

327597instance FromValue 'PGbytea Strict.ByteString where

328− fromValue _ = Decoding.bytea_strict

598+ fromValue = Decoding.bytea_strict

329599instance FromValue 'PGbytea Lazy.ByteString where

330− fromValue _ = Decoding.bytea_lazy

331−instance FromValue 'PGdate Day where fromValue _ = Decoding.date

332−instance FromValue 'PGtime TimeOfDay where fromValue _ = Decoding.time_int

600+ fromValue = Decoding.bytea_lazy

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

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

333603instance FromValue 'PGtimetz (TimeOfDay, TimeZone) where

334− fromValue _ = Decoding.timetz_int

604+ fromValue = Decoding.timetz_int

335605instance FromValue 'PGtimestamp LocalTime where

336− fromValue _ = Decoding.timestamp_int

606+ fromValue = Decoding.timestamp_int

337607instance FromValue 'PGtimestamptz UTCTime where

338− fromValue _ = Decoding.timestamptz_int

608+ fromValue = Decoding.timestamptz_int

339609instance FromValue 'PGinterval DiffTime where

340− fromValue _ = Decoding.interval_int

341−instance FromValue 'PGjson Value where fromValue _ = Decoding.json_ast

342−instance FromValue 'PGjsonb Value where fromValue _ = Decoding.jsonb_ast

343−instance FromValue pg y => FromValue ('PGvararray pg) (Vector (Maybe y)) where

344− fromValue _ = Decoding.array

345− (Decoding.dimensionArray Vector.replicateM

346− (Decoding.nullableValueArray (fromValue (Proxy @pg))))

347−instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where

348− fromValue _ = Decoding.array

349− (Decoding.dimensionArray Vector.replicateM

350− (Decoding.nullableValueArray (fromValue (Proxy @pg))))

610+ fromValue = Decoding.interval_int

611+instance FromValue 'PGjson Aeson.Value where fromValue = Decoding.json_ast

612+instance FromValue 'PGjsonb Aeson.Value where fromValue = Decoding.jsonb_ast

613+instance Aeson.FromJSON x => FromValue 'PGjson (Json x) where

614+ fromValue = Json <$>

615+ Decoding.json_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)

616+instance Aeson.FromJSON x => FromValue 'PGjsonb (Jsonb x) where

617+ fromValue = Jsonb <$>

618+ Decoding.jsonb_bytes (left Strict.Text.pack . Aeson.eitherDecodeStrict)

619+instance FromValue pg y

620+ => FromValue ('PGvararray ('NotNull pg)) (VarArray (Vector y)) where

621+ fromValue =

622+ let

623+ rep n x = VarArray <$> Vector.replicateM n x

624+ in

625+ Decoding.array $ Decoding.dimensionArray rep

626+ (fromFixArray @'[] @('NotNull pg))

627+instance FromValue pg y

628+ => FromValue ('PGvararray ('Null pg)) (VarArray (Vector (Maybe y))) where

629+ fromValue =

630+ let

631+ rep n x = VarArray <$> Vector.replicateM n x

632+ in

633+ Decoding.array $ Decoding.dimensionArray rep

634+ (fromFixArray @'[] @('Null pg))

635+instance FromValue pg y

636+ => FromValue ('PGvararray ('NotNull pg)) (VarArray [y]) where

637+ fromValue =

638+ let

639+ rep n x = VarArray <$> replicateM n x

640+ in

641+ Decoding.array $ Decoding.dimensionArray rep

642+ (fromFixArray @'[] @('NotNull pg))

643+instance FromValue pg y

644+ => FromValue ('PGvararray ('Null pg)) (VarArray [Maybe y]) where

645+ fromValue =

646+ let

647+ rep n x = VarArray <$> replicateM n x

648+ in

649+ Decoding.array $ Decoding.dimensionArray rep

650+ (fromFixArray @'[] @('Null pg))

651+instance FromFixArray dims ty y

652+ => FromValue ('PGfixarray dims ty) (FixArray y) where

653+ fromValue = FixArray <$> Decoding.array (fromFixArray @dims @ty @y)

351654instance

352655 ( IsEnumType y

353656 , HasDatatypeInfo y

354− , LabelsWith y ~ labels

355− ) => FromValue ('PGenum labels) y where

356− fromValue _ =

657+ , LabelsPG y ~ labels

658+ ) => FromValue ('PGenum labels) (Enumerated y) where

659+ fromValue =

357660 let

358661 greadConstructor

359662 :: All ((~) '[]) xss

@@ -366,29 +669,16 @@ instance

366669 then Just (SOP (Z Nil))

367670 else SOP . S . unSOP <$> greadConstructor constructors name

368671 in

369− Decoding.enum

672+ fmap Enumerated

673+ . Decoding.enum

370674 $ fmap to

371675 . greadConstructor (constructorInfo (datatypeInfo (Proxy @y)))

372− . Strict.unpack

373−

676+ . Strict.Text.unpack

374677instance

375− ( SListI fields

376− , MapMaybes ys

377− , IsProductType y (Maybes ys)

378− , AllZip FromAliasedValue fields ys

379− , FieldNamesWith y ~ AliasesOf fields

380− ) => FromValue ('PGcomposite fields) y where

678+ ( FromRow fields y

679+ ) => FromValue ('PGcomposite fields) (Composite y) where

381680 fromValue =

382681 let

383− decoders

384− :: forall pgs zs proxy

385− . AllZip FromAliasedValue pgs zs

386− => proxy ('PGcomposite pgs)

387− -> NP Decoding.Value zs

388− decoders _ = htrans (Proxy @FromAliasedValue) fromAliasedValue

389− (hpure Proxy :: NP Proxy pgs)

390−

391− composite fields = do

392682 -- <number of fields: 4 bytes>

393683 -- [for each field]

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

@@ -399,80 +689,133 @@ instance

399689 -- <value: <length> bytes>

400690 -- [end if]

401691 -- [end for]

692+ composite = Decoding.valueParser $ do

402693 unitOfSize 4

403− let

404− each field = do

405− unitOfSize 4

406− len <- sized 4 Decoding.int

407− if len == -1 then return Nothing else Just <$> sized len field

408− htraverse' each fields

409−

410− in fmap (to . SOP . Z . maybes) . composite . decoders

411−

412−class FromAliasedValue (pg :: (Symbol,PGType)) (y :: Type) where

413− fromAliasedValue :: proxy pg -> Decoding.Value y

414−instance FromValue pg y => FromAliasedValue (alias ::: pg) y where

415− fromAliasedValue _ = fromValue (Proxy @pg)

694+ hsequence' $ hpure $ Comp $ do

695+ unitOfSize 4

696+ len <- sized 4 Decoding.int

697+ if len == -1

698+ then return (K Nothing)

699+ else K . Just <$> bytesOfSize len

700+ in

701+ fmap Composite (Decoding.fn (fromRow @fields <=< composite))

416702

417−-- | A `FromColumnValue` constraint lifts the `FromValue` parser

703+-- | A `FromField` constraint lifts the `FromValue` parser

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

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

420−-- `FromColumnValue`, just use the provided instances.

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

422− -- | >>> :set -XTypeOperators -XOverloadedStrings

423− -- >>> newtype Id = Id { getId :: Int16 } deriving Show

424− -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue

425− -- >>> fromColumnValue @("col" ::: 'NotNull 'PGint2) @Id (K (Just "\NUL\SOH"))

426− -- Id {getId = 1}

427− --

428− -- >>> fromColumnValue @("col" ::: 'Null 'PGint2) @(Maybe Id) (K (Just "\NUL\SOH"))

429− -- Just (Id {getId = 1})

430− fromColumnValue :: K (Maybe Strict.ByteString) colty -> y

706+-- `FromField`, just use the provided instances.

707+class FromField (pg :: (Symbol, NullityType)) (y :: (Symbol, Type)) where

708+ fromField

709+ :: K (Maybe Strict.ByteString) pg

710+ -> (Either Strict.Text :.: P) y

431711instance FromValue pg y

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

433− fromColumnValue = \case

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

435− K (Just bs) ->

436− let

437− errOrValue =

438− Decoding.valueParser (fromValue @pg @y Proxy) bs

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

440− in

441− either err id errOrValue

712+ => FromField (column ::: ('NotNull pg)) (column ::: y) where

713+ fromField = Comp . \case

714+ K Nothing -> Left "fromField: saw NULL when expecting NOT NULL"

715+ K (Just bytestring) -> P <$>

716+ Decoding.valueParser (fromValue @pg) bytestring

442717instance FromValue pg y

443− => FromColumnValue (column ::: ('Null pg)) (Maybe y) where

444− fromColumnValue (K nullOrBytes)

445− = either err id

446− . Decoding.valueParser (fromValue @pg @y Proxy)

447− <$> nullOrBytes

448− where

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

718+ => FromField (column ::: 'Null pg) (column ::: Maybe y) where

719+ fromField = Comp . \case

720+ K Nothing -> Right $ P Nothing

721+ K (Just bytestring) -> P . Just <$>

722+ Decoding.valueParser (fromValue @pg) bytestring

723+

724+-- | A `FromFixArray` constraint gives a decoding to a Haskell `Type`

725+-- from the binary format of a PostgreSQL fixed-length array.

726+-- You should not define instances for

727+-- `FromFixArray`, just use the provided instances.

728+class FromFixArray (dims :: [Nat]) (ty :: NullityType) (y :: Type) where

729+ fromFixArray :: Decoding.Array y

730+instance FromValue pg y => FromFixArray '[] ('NotNull pg) y where

731+ fromFixArray = Decoding.valueArray (fromValue @pg @y)

732+instance FromValue pg y => FromFixArray '[] ('Null pg) (Maybe y) where

733+ fromFixArray = Decoding.nullableValueArray (fromValue @pg @y)

734+instance

735+ ( IsProductType product ys

736+ , Length ys ~ dim

737+ , All ((~) y) ys

738+ , FromFixArray dims ty y )

739+ => FromFixArray (dim ': dims) ty product where

740+ fromFixArray =

741+ let

742+ rep _ = fmap (to . SOP . Z) . replicateMN

743+ in

744+ Decoding.dimensionArray rep (fromFixArray @dims @ty @y)

450745

451746-- | A `FromRow` constraint generically sequences the parsings of the columns

452−-- of a `RelationType` into the fields of a record `Type` provided they have

747+-- of a `RowType` into the fields of a record `Type` provided they have

453748-- the same field names. You should not define instances of `FromRow`.

454−-- Instead define `Generic` and `HasDatatypeInfo` instances which in turn

749+-- Instead define `SOP.Generic` and `SOP.HasDatatypeInfo` instances which in turn

455750-- provide `FromRow` instances.

456−class SListI results => FromRow (results :: RelationType) y where

751+class SListI result => FromRow (result :: RowType) y where

457752 -- | >>> :set -XOverloadedStrings

458753 -- >>> import Data.Text

459754 -- >>> newtype UserId = UserId { getUserId :: Int16 } deriving Show

460− -- >>> instance FromValue 'PGint2 UserId where fromValue = fmap UserId . fromValue

755+ -- >>> instance FromValue 'PGint2 UserId where fromValue = UserId <$> fromValue @'PGint2

461756 -- >>> data UserRow = UserRow { userId :: UserId, userName :: Maybe Text } deriving (Show, GHC.Generic)

462757 -- >>> instance Generic UserRow

463758 -- >>> instance HasDatatypeInfo UserRow

464759 -- >>> type User = '["userId" ::: 'NotNull 'PGint2, "userName" ::: 'Null 'PGtext]

465760 -- >>> fromRow @User @UserRow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)

466− -- UserRow {userId = UserId {getUserId = 1}, userName = Just "bloodninja"}

467− fromRow :: NP (K (Maybe Strict.ByteString)) results -> y

761+ -- Right (UserRow {userId = UserId {getUserId = 1}, userName = Just "bloodninja"})

762+ fromRow :: NP (K (Maybe Strict.ByteString)) result -> Either Strict.Text y

468763instance

469− ( SListI results

470− , IsProductType y ys

471− , AllZip FromColumnValue results ys

472− , FieldNamesWith y ~ AliasesOf results

473− ) => FromRow results y where

764+ ( SListI result

765+ , IsRecord y ys

766+ , AllZip FromField result ys

767+ ) => FromRow result y where

474768 fromRow

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

769+ = fmap fromRecord

770+ . hsequence'

771+ . htrans (Proxy @FromField) fromField

772+------------------------------------------------------

773+-- P records

774+------------------------------------------------------

775+-- instance (FromField (col ::: pg) (col ::: hask))

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

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

778+-- instance

779+-- ( row ~ Join row1 row2

780+-- , FromRow row1 hask1

781+-- , FromRow row2 hask2

782+-- , SListI row

783+-- ) => FromRow row (hask1, hask2) where

784+-- fromRow row = case disjoin @row1 @row2 row of

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

786+-- instance

787+-- ( row ~ Join row1 row23

788+-- , FromRow row1 hask1

789+-- , FromRow row23 (hask2, hask3)

790+-- , SListI row

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

792+-- fromRow row = case disjoin @row1 @row23 row of

793+-- (row1, row23) -> do

794+-- hask1 <- fromRow row1

795+-- (hask2, hask3) <- fromRow row23

796+-- return (hask1, hask2, hask3)

797+-- instance

798+-- ( row ~ Join row1 row234

799+-- , FromRow row1 hask1

800+-- , FromRow row234 (hask2, hask3, hask4)

801+-- , SListI row

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

803+-- fromRow row = case disjoin @row1 @row234 row of

804+-- (row1, row234) -> do

805+-- hask1 <- fromRow row1

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

807+-- return (hask1, hask2, hask3, hask4)

808+-- instance

809+-- ( row ~ Join row1 row2345

810+-- , FromRow row1 hask1

811+-- , FromRow row2345 (hask2, hask3, hask4, hask5)

812+-- , SListI row

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

814+-- fromRow row = case disjoin @row1 @row2345 row of

815+-- (row1, row2345) -> do

816+-- hask1 <- fromRow row1

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

818+-- return (hask1, hask2, hask3, hask4, hask5)

476819

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

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

@@ -482,8 +825,24 @@ instance

482825-- K (Just "foo") :* Nil

483826--

484827-- >>> fromRow @'["fromOnly" ::: 'Null 'PGtext] @(Only (Maybe Text)) (K (Just "bar") :* Nil)

485−-- Only {fromOnly = Just "bar"}

828+-- Right (Only {fromOnly = Just "bar"})

486829newtype Only x = Only { fromOnly :: x }

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

488831instance Generic (Only x)

489832instance HasDatatypeInfo (Only x)

833+

834+foldlN

835+ :: All ((~) x) xs

836+ => (z -> x -> z) -> z -> NP I xs -> z

837+foldlN f z = \case

838+ Nil -> z

839+ I x :* xs -> let z' = f z x in seq z' $ foldlN f z' xs

840+

841+replicateMN

842+ :: forall x xs m. (All ((~) x) xs, Monad m, SListI xs)

843+ => m x -> m (NP I xs)

844+replicateMN mx = hsequence' $

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

846+

847+getOid :: LibPQ.Oid -> Word32

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

squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+25−889

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

1111{-# LANGUAGE

1212 AllowAmbiguousTypes

1313 , ConstraintKinds

14+ , DeriveAnyClass

1415 , DeriveGeneric

16+ , DerivingStrategies

1517 , FlexibleContexts

1618 , FlexibleInstances

1719 , GADTs

18− , GeneralizedNewtypeDeriving

1920 , LambdaCase

2021 , MultiParamTypeClasses

22+ , OverloadedLabels

2123 , OverloadedStrings

2224 , RankNTypes

2325 , ScopedTypeVariables

@@ -25,922 +27,56 @@ Squeal data definition language.

2527 , TypeInType

2628 , TypeOperators

2729 , UndecidableSuperClasses

30+ , UndecidableInstances

2831#-}

2932

3033module Squeal.PostgreSQL.Definition

3134 ( -- * Definition

32− Definition (UnsafeDefinition, renderDefinition)

35+ Definition (..)

3336 , (>>>)

34− -- * Tables

35− -- ** Create

36− , createTable

37− , createTableIfNotExists

38− , TableConstraintExpression (..)

39− , check

40− , unique

41− , primaryKey

42− , foreignKey

43− , ForeignKeyed

44− , OnDeleteClause (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade)

45− , renderOnDeleteClause

46− , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)

47− , renderOnUpdateClause

48− -- ** Drop

49− , dropTable

50− -- ** Alter

51− , alterTable

52− , alterTableRename

53− , AlterTable (UnsafeAlterTable, renderAlterTable)

54− , addConstraint

55− , dropConstraint

56− , AddColumn (addColumn)

57− , dropColumn

58− , renameColumn

59− , alterColumn

60− , AlterColumn (UnsafeAlterColumn, renderAlterColumn)

61− , setDefault

62− , dropDefault

63− , setNotNull

64− , dropNotNull

65− , alterType

66− -- * Views

67− , createView

68− , dropView

69− -- * Types

70− , createTypeEnum

71− , createTypeEnumWith

72− , createTypeComposite

73− , createTypeCompositeWith

74− , dropType

75− -- * Columns

76− , ColumnTypeExpression (..)

77− , nullable

78− , notNullable

79− , default_

80− , serial2

81− , smallserial

82− , serial4

83− , serial

84− , serial8

85− , bigserial

37+ , manipDefinition

8638 ) where

8739

8840import Control.Category

8941import Control.DeepSeq

9042import Data.ByteString

9143import Data.Monoid

92−import GHC.TypeLits

9344import Prelude hiding ((.), id)

9445

95−import qualified Generics.SOP as SOP

9646import qualified GHC.Generics as GHC

9747

98−import Squeal.PostgreSQL.Expression

99−import Squeal.PostgreSQL.Query

48+import Squeal.PostgreSQL.Manipulation

10049import Squeal.PostgreSQL.Render

10150import Squeal.PostgreSQL.Schema

10251

52+-- $setup

53+-- >>> import Squeal.PostgreSQL

54+

10355{-----------------------------------------

10456statements

10557-----------------------------------------}

10658

107−-- | A `Definition` is a statement that changes the schema of the

59+-- | A `Definition` is a statement that changes the schemas of the

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

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

11062newtype Definition

111− (schema0 :: SchemaType)

112− (schema1 :: SchemaType)

63+ (schemas0 :: SchemasType)

64+ (schemas1 :: SchemasType)

11365 = UnsafeDefinition { renderDefinition :: ByteString }

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

11567

68+instance RenderSQL (Definition schemas0 schemas1) where

69+ renderSQL = renderDefinition

70+

11671instance Category Definition where

11772 id = UnsafeDefinition ";"

11873 ddl1 . ddl0 = UnsafeDefinition $

119− renderDefinition ddl0 <> "\n" <> renderDefinition ddl1

120−

121−{-----------------------------------------

122−CREATE statements

123−-----------------------------------------}

124−

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

126−

127−>>> :set -XOverloadedLabels

128−>>> :{

129−Data.ByteString.Char8.putStrLn . renderDefinition $

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

131−:}

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

133−-}

134−createTable

135− :: ( KnownSymbol table

136− , columns ~ (col ': cols)

137− , SOP.SListI columns

138− , SOP.SListI constraints

139− , schema1 ~ Create table ('Table (constraints :=> columns)) schema0 )

140− => Alias table -- ^ the name of the table to add

141− -> NP (Aliased (ColumnTypeExpression schema0)) columns

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

143− -> NP (Aliased (TableConstraintExpression schema1 table)) constraints

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

145− -> Definition schema0 schema1

146−createTable tab columns constraints = UnsafeDefinition $

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

148−

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

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

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

152−

153−>>> :set -XOverloadedLabels -XTypeApplications

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

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

156−>>> :{

157−Data.ByteString.Char8.putStrLn $ renderDefinition

158− (createTableIfNotExists #tab ((int & nullable) `As` #a :* (real & nullable) `As` #b :* Nil) Nil :: Definition Schema Schema)

159−:}

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

161−-}

162−createTableIfNotExists

163− :: ( Has table schema ('Table (constraints :=> columns))

164− , SOP.SListI columns

165− , SOP.SListI constraints )

166− => Alias table -- ^ the name of the table to add

167− -> NP (Aliased (ColumnTypeExpression schema)) columns

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

169− -> NP (Aliased (TableConstraintExpression schema table)) constraints

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

171− -> Definition schema schema

172−createTableIfNotExists tab columns constraints = UnsafeDefinition $

173− "CREATE TABLE IF NOT EXISTS"

174− <+> renderCreation tab columns constraints

175−

176−-- helper function for `createTable` and `createTableIfNotExists`

177−renderCreation

178− :: ( KnownSymbol table

179− , SOP.SListI columns

180− , SOP.SListI constraints )

181− => Alias table -- ^ the name of the table to add

182− -> NP (Aliased (ColumnTypeExpression schema0)) columns

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

184− -> NP (Aliased (TableConstraintExpression schema1 table)) constraints

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

186− -> ByteString

187−renderCreation tab columns constraints = renderAlias tab

188− <+> parenthesized

189− ( renderCommaSeparated renderColumnDef columns

190− <> ( case constraints of

191− Nil -> ""

192− _ -> ", " <>

193− renderCommaSeparated renderConstraint constraints ) )

194− <> ";"

195− where

196− renderColumnDef :: Aliased (ColumnTypeExpression schema) x -> ByteString

197− renderColumnDef (ty `As` column) =

198− renderAlias column <+> renderColumnTypeExpression ty

199− renderConstraint

200− :: Aliased (TableConstraintExpression schema columns) constraint

201− -> ByteString

202− renderConstraint (constraint `As` alias) =

203− "CONSTRAINT" <+> renderAlias alias <+> renderTableConstraintExpression constraint

204−

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

206−-- table. For many applications, however, the constraint they provide is

207−-- too coarse. For example, a column containing a product price should

208−-- probably only accept positive values. But there is no standard data type

209−-- that accepts only positive numbers. Another issue is that you might want

210−-- to constrain column data with respect to other columns or rows.

211−-- For example, in a table containing product information,

212−-- there should be only one row for each product number.

213−-- `TableConstraint`s give you as much control over the data in your tables

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

215−-- violate a constraint, an error is raised. This applies

216−-- even if the value came from the default value definition.

217−newtype TableConstraintExpression

218− (schema :: SchemaType)

219− (table :: Symbol)

220− (tableConstraint :: TableConstraint)

221− = UnsafeTableConstraintExpression

222− { renderTableConstraintExpression :: ByteString }

223− deriving (GHC.Generic,Show,Eq,Ord,NFData)

224−

225−{-| A `check` constraint is the most generic `TableConstraint` type.

226−It allows you to specify that the value in a certain column must satisfy

227−a Boolean (truth-value) expression.

228−

229−>>> :{

230−type Schema = '[

231− "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[

232− "a" ::: 'NoDef :=> 'NotNull 'PGint4,

233− "b" ::: 'NoDef :=> 'NotNull 'PGint4

234− ])]

235−:}

236−

237−>>> :{

238−let

239− definition :: Definition '[] Schema

240− definition = createTable #tab

241− ( (int & notNullable) `As` #a :*

242− (int & notNullable) `As` #b :* Nil )

243− ( check (#a :* #b :* Nil) (#a .> #b) `As` #inequality :* Nil )

244−:}

245−

246−>>> Data.ByteString.Char8.putStrLn $ renderDefinition definition

247−CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));

248−-}

249−check

250− :: ( Has alias schema ('Table table)

251− , HasAll aliases (TableToRelation table) subcolumns )

252− => NP Alias aliases

253− -- ^ specify the subcolumns which are getting checked

254− -> (forall tab. Condition schema '[tab ::: subcolumns] 'Ungrouped '[])

255− -- ^ a closed `Condition` on those subcolumns

256− -> TableConstraintExpression schema alias ('Check aliases)

257−check _cols condition = UnsafeTableConstraintExpression $

258− "CHECK" <+> parenthesized (renderExpression condition)

259−

260−{-| A `unique` constraint ensure that the data contained in a column,

261−or a group of columns, is unique among all the rows in the table.

262−

263−>>> :{

264−type Schema = '[

265− "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[

266− "a" ::: 'NoDef :=> 'Null 'PGint4,

267− "b" ::: 'NoDef :=> 'Null 'PGint4

268− ])]

269−:}

270−

271−>>> :{

272−let

273− definition :: Definition '[] Schema

274− definition = createTable #tab

275− ( (int & nullable) `As` #a :*

276− (int & nullable) `As` #b :* Nil )

277− ( unique (#a :* #b :* Nil) `As` #uq_a_b :* Nil )

278−:}

279−

280−>>> Data.ByteString.Char8.putStrLn $ renderDefinition definition

281−CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));

282−-}

283−unique

284− :: ( Has alias schema ('Table table)

285− , HasAll aliases (TableToRelation table) subcolumns )

286− => NP Alias aliases

287− -- ^ specify subcolumns which together are unique for each row

288− -> TableConstraintExpression schema alias ('Unique aliases)

289−unique columns = UnsafeTableConstraintExpression $

290− "UNIQUE" <+> parenthesized (commaSeparated (renderAliases columns))

291−

292−{-| A `primaryKey` constraint indicates that a column, or group of columns,

293−can be used as a unique identifier for rows in the table.

294−This requires that the values be both unique and not null.

295−

296−>>> :{

297−type Schema = '[

298− "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[

299− "id" ::: 'Def :=> 'NotNull 'PGint4,

300− "name" ::: 'NoDef :=> 'NotNull 'PGtext

301− ])]

302−:}

303−

304−>>> :{

305−let

306− definition :: Definition '[] Schema

307− definition = createTable #tab

308− ( serial `As` #id :*

309− (text & notNullable) `As` #name :* Nil )

310− ( primaryKey #id `As` #pk_id :* Nil )

311−:}

312−

313−>>> Data.ByteString.Char8.putStrLn $ renderDefinition definition

314−CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));

315−-}

316−primaryKey

317− :: ( Has alias schema ('Table table)

318− , HasAll aliases (TableToColumns table) subcolumns

319− , AllNotNull subcolumns )

320− => NP Alias aliases

321− -- ^ specify the subcolumns which together form a primary key.

322− -> TableConstraintExpression schema alias ('PrimaryKey aliases)

323−primaryKey columns = UnsafeTableConstraintExpression $

324− "PRIMARY KEY" <+> parenthesized (commaSeparated (renderAliases columns))

325−

326−{-| A `foreignKey` specifies that the values in a column

327−(or a group of columns) must match the values appearing in some row of

328−another table. We say this maintains the referential integrity

329−between two related tables.

330−

331−>>> :{

332−type Schema =

333− '[ "users" ::: 'Table (

334− '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

335− '[ "id" ::: 'Def :=> 'NotNull 'PGint4

336− , "name" ::: 'NoDef :=> 'NotNull 'PGtext

337− ])

338− , "emails" ::: 'Table (

339− '[ "pk_emails" ::: 'PrimaryKey '["id"]

340− , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]

341− ] :=>

342− '[ "id" ::: 'Def :=> 'NotNull 'PGint4

343− , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4

344− , "email" ::: 'NoDef :=> 'Null 'PGtext

345− ])

346− ]

347−:}

348−

349−>>> :{

350−let

351− setup :: Definition '[] Schema

352− setup =

353− createTable #users

354− ( serial `As` #id :*

355− (text & notNullable) `As` #name :* Nil )

356− ( primaryKey #id `As` #pk_users :* Nil ) >>>

357− createTable #emails

358− ( serial `As` #id :*

359− (int & notNullable) `As` #user_id :*

360− (text & nullable) `As` #email :* Nil )

361− ( primaryKey #id `As` #pk_emails :*

362− foreignKey #user_id #users #id

363− OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )

364−in Data.ByteString.Char8.putStrLn $ renderDefinition setup

365−:}

366−CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));

367−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);

368−

369−A `foreignKey` can even be a table self-reference.

370−

371−>>> :{

372−type Schema =

373− '[ "employees" ::: 'Table (

374− '[ "employees_pk" ::: 'PrimaryKey '["id"]

375− , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]

376− ] :=>

377− '[ "id" ::: 'Def :=> 'NotNull 'PGint4

378− , "name" ::: 'NoDef :=> 'NotNull 'PGtext

379− , "employer_id" ::: 'NoDef :=> 'Null 'PGint4

380− ])

381− ]

382−:}

383−

384−>>> :{

385−let

386− setup :: Definition '[] Schema

387− setup =

388− createTable #employees

389− ( serial `As` #id :*

390− (text & notNullable) `As` #name :*

391− (integer & nullable) `As` #employer_id :* Nil )

392− ( primaryKey #id `As` #employees_pk :*

393− foreignKey #employer_id #employees #id

394− OnDeleteCascade OnUpdateCascade `As` #employees_employer_fk :* Nil )

395−in Data.ByteString.Char8.putStrLn $ renderDefinition setup

396−:}

397−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);

398−-}

399−foreignKey

400− :: (ForeignKeyed schema child parent

401− table reftable

402− columns refcolumns

403− constraints cols

404− reftys tys )

405− => NP Alias columns

406− -- ^ column or columns in the table

407− -> Alias parent

408− -- ^ reference table

409− -> NP Alias refcolumns

410− -- ^ reference column or columns in the reference table

411− -> OnDeleteClause

412− -- ^ what to do when reference is deleted

413− -> OnUpdateClause

414− -- ^ what to do when reference is updated

415− -> TableConstraintExpression schema child

416− ('ForeignKey columns parent refcolumns)

417−foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $

418− "FOREIGN KEY" <+> parenthesized (commaSeparated (renderAliases keys))

419− <+> "REFERENCES" <+> renderAlias parent

420− <+> parenthesized (commaSeparated (renderAliases refs))

421− <+> renderOnDeleteClause ondel

422− <+> renderOnUpdateClause onupd

423−

424−-- | A constraint synonym between types involved in a foreign key constraint.

425−type ForeignKeyed schema

426− child parent

427− table reftable

428− columns refcolumns

429− constraints cols

430− reftys tys =

431− ( Has child schema ('Table table)

432− , Has parent schema ('Table reftable)

433− , HasAll columns (TableToColumns table) tys

434− , reftable ~ (constraints :=> cols)

435− , HasAll refcolumns cols reftys

436− , SOP.AllZip SamePGType tys reftys

437− , Uniquely refcolumns constraints )

438−

439−-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.

440−data OnDeleteClause

441− = OnDeleteNoAction

442− -- ^ if any referencing rows still exist when the constraint is checked,

443− -- an error is raised

444− | OnDeleteRestrict -- ^ prevents deletion of a referenced row

445− | OnDeleteCascade

446− -- ^ specifies that when a referenced row is deleted,

447− -- row(s) referencing it should be automatically deleted as well

448− deriving (GHC.Generic,Show,Eq,Ord)

449−instance NFData OnDeleteClause

450−

451−-- | Render `OnDeleteClause`.

452−renderOnDeleteClause :: OnDeleteClause -> ByteString

453−renderOnDeleteClause = \case

454− OnDeleteNoAction -> "ON DELETE NO ACTION"

455− OnDeleteRestrict -> "ON DELETE RESTRICT"

456− OnDeleteCascade -> "ON DELETE CASCADE"

457−

458−-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked

459−-- when a referenced column is changed (updated).

460−data OnUpdateClause

461− = OnUpdateNoAction

462− -- ^ if any referencing rows has not changed when the constraint is checked,

463− -- an error is raised

464− | OnUpdateRestrict -- ^ prevents update of a referenced row

465− | OnUpdateCascade

466− -- ^ the updated values of the referenced column(s) should be copied

467− -- into the referencing row(s)

468− deriving (GHC.Generic,Show,Eq,Ord)

469−instance NFData OnUpdateClause

470−

471−-- | Render `OnUpdateClause`.

472−renderOnUpdateClause :: OnUpdateClause -> ByteString

473−renderOnUpdateClause = \case

474− OnUpdateNoAction -> "ON UPDATE NO ACTION"

475− OnUpdateRestrict -> "ON UPDATE RESTRICT"

476− OnUpdateCascade -> "ON UPDATE CASCADE"

477−

478−{-----------------------------------------

479−DROP statements

480−-----------------------------------------}

481−

482−-- | `dropTable` removes a table from the schema.

483−--

484−-- >>> :{

485−-- let

486−-- definition :: Definition '["muh_table" ::: 'Table t] '[]

487−-- definition = dropTable #muh_table

488−-- :}

489−--

490−-- >>> Data.ByteString.Char8.putStrLn $ renderDefinition definition

491−-- DROP TABLE "muh_table";

492−dropTable

493− :: Has table schema ('Table t)

494− => Alias table -- ^ table to remove

495− -> Definition schema (Drop table schema)

496−dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderAlias tab <> ";"

497−

498−{-----------------------------------------

499−ALTER statements

500−-----------------------------------------}

501−

502−-- | `alterTable` changes the definition of a table from the schema.

503−alterTable

504− :: KnownSymbol alias

505− => Alias alias -- ^ table to alter

506− -> AlterTable alias table schema -- ^ alteration to perform

507− -> Definition schema (Alter alias ('Table table) schema)

508−alterTable tab alteration = UnsafeDefinition $

509− "ALTER TABLE"

510− <+> renderAlias tab

511− <+> renderAlterTable alteration

512− <> ";"

513−

514−-- | `alterTableRename` changes the name of a table from the schema.

515−--

516−-- >>> Data.ByteString.Char8.putStrLn $ renderDefinition $ alterTableRename #foo #bar

517−-- ALTER TABLE "foo" RENAME TO "bar";

518−alterTableRename

519− :: (KnownSymbol table0, KnownSymbol table1)

520− => Alias table0 -- ^ table to rename

521− -> Alias table1 -- ^ what to rename it

522− -> Definition schema (Rename table0 table1 schema)

523−alterTableRename table0 table1 = UnsafeDefinition $

524− "ALTER TABLE" <+> renderAlias table0

525− <+> "RENAME TO" <+> renderAlias table1 <> ";"

526−

527−-- | An `AlterTable` describes the alteration to perform on the columns

528−-- of a table.

529−newtype AlterTable

530− (alias :: Symbol)

531− (table :: TableType)

532− (schema :: SchemaType) =

533− UnsafeAlterTable {renderAlterTable :: ByteString}

534− deriving (GHC.Generic,Show,Eq,Ord,NFData)

535−

536−-- | An `addConstraint` adds a table constraint.

537−--

538−-- >>> :{

539−-- let

540−-- definition :: Definition

541−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]

542−-- '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]

543−-- definition = alterTable #tab (addConstraint #positive (check (#col :* Nil) (#col .> 0)))

544−-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition

545−-- :}

546−-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));

547−addConstraint

548− :: ( KnownSymbol alias

549− , Has tab schema ('Table table0)

550− , table0 ~ (constraints :=> columns)

551− , table1 ~ (Create alias constraint constraints :=> columns) )

552− => Alias alias

553− -> TableConstraintExpression schema tab constraint

554− -- ^ constraint to add

555− -> AlterTable tab table1 schema

556−addConstraint alias constraint = UnsafeAlterTable $

557− "ADD" <+> "CONSTRAINT" <+> renderAlias alias

558− <+> renderTableConstraintExpression constraint

559−

560−-- | A `dropConstraint` drops a table constraint.

561−--

562−-- >>> :{

563−-- let

564−-- definition :: Definition

565−-- '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]

566−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]

567−-- definition = alterTable #tab (dropConstraint #positive)

568−-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition

569−-- :}

570−-- ALTER TABLE "tab" DROP CONSTRAINT "positive";

571−dropConstraint

572− :: ( KnownSymbol constraint

573− , Has tab schema ('Table table0)

574− , table0 ~ (constraints :=> columns)

575− , table1 ~ (Drop constraint constraints :=> columns) )

576− => Alias constraint

577− -- ^ constraint to drop

578− -> AlterTable tab table1 schema

579−dropConstraint constraint = UnsafeAlterTable $

580− "DROP" <+> "CONSTRAINT" <+> renderAlias constraint

581−

582−-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.

583−class AddColumn ty where

584− -- | `addColumn` adds a new column, initially filled with whatever

585− -- default value is given or with @NULL@.

586− --

587− -- >>> :{

588− -- let

589− -- definition :: Definition

590− -- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]

591− -- '["tab" ::: 'Table ('[] :=>

592− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

593− -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]

594− -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))

595− -- in Data.ByteString.Char8.putStrLn $ renderDefinition definition

596− -- :}

597− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';

598− --

599− -- >>> :{

600− -- let

601− -- definition :: Definition

602− -- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]

603− -- '["tab" ::: 'Table ('[] :=>

604− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

605− -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]

606− -- definition = alterTable #tab (addColumn #col2 (text & nullable))

607− -- in Data.ByteString.Char8.putStrLn $ renderDefinition definition

608− -- :}

609− -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;

610− addColumn

611− :: ( KnownSymbol column

612− , Has tab schema ('Table table0)

613− , table0 ~ (constraints :=> columns)

614− , table1 ~ (constraints :=> Create column ty columns) )

615− => Alias column -- ^ column to add

616− -> ColumnTypeExpression schema ty -- ^ type of the new column

617− -> AlterTable tab table1 schema

618− addColumn column ty = UnsafeAlterTable $

619− "ADD COLUMN" <+> renderAlias column <+> renderColumnTypeExpression ty

620−instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)

621−instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)

622−

623−-- | A `dropColumn` removes a column. Whatever data was in the column

624−-- disappears. Table constraints involving the column are dropped, too.

625−-- However, if the column is referenced by a foreign key constraint of

626−-- another table, PostgreSQL will not silently drop that constraint.

627−--

628−-- >>> :{

629−-- let

630−-- definition :: Definition

631−-- '["tab" ::: 'Table ('[] :=>

632−-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

633−-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]

634−-- '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]

635−-- definition = alterTable #tab (dropColumn #col2)

636−-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition

637−-- :}

638−-- ALTER TABLE "tab" DROP COLUMN "col2";

639−dropColumn

640− :: ( KnownSymbol column

641− , Has tab schema ('Table table0)

642− , table0 ~ (constraints :=> columns)

643− , table1 ~ (constraints :=> Drop column columns) )

644− => Alias column -- ^ column to remove

645− -> AlterTable tab table1 schema

646−dropColumn column = UnsafeAlterTable $

647− "DROP COLUMN" <+> renderAlias column

648−

649−-- | A `renameColumn` renames a column.

650−--

651−-- >>> :{

652−-- let

653−-- definition :: Definition

654−-- '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]

655−-- '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]

656−-- definition = alterTable #tab (renameColumn #foo #bar)

657−-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition

658−-- :}

659−-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";

660−renameColumn

661− :: ( KnownSymbol column0

662− , KnownSymbol column1

663− , Has tab schema ('Table table0)

664− , table0 ~ (constraints :=> columns)

665− , table1 ~ (constraints :=> Rename column0 column1 columns) )

666− => Alias column0 -- ^ column to rename

667− -> Alias column1 -- ^ what to rename the column

668− -> AlterTable tab table1 schema

669−renameColumn column0 column1 = UnsafeAlterTable $

670− "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1

671−

672−-- | An `alterColumn` alters a single column.

673−alterColumn

674− :: ( KnownSymbol column

675− , Has tab schema ('Table table0)

676− , table0 ~ (constraints :=> columns)

677− , Has column columns ty0

678− , tables1 ~ (constraints :=> Alter column ty1 columns))

679− => Alias column -- ^ column to alter

680− -> AlterColumn schema ty0 ty1 -- ^ alteration to perform

681− -> AlterTable tab table1 schema

682−alterColumn column alteration = UnsafeAlterTable $

683− "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration

684−

685−-- | An `AlterColumn` describes the alteration to perform on a single column.

686−newtype AlterColumn (schema :: SchemaType) (ty0 :: ColumnType) (ty1 :: ColumnType) =

687− UnsafeAlterColumn {renderAlterColumn :: ByteString}

688− deriving (GHC.Generic,Show,Eq,Ord,NFData)

689−

690−-- | A `setDefault` sets a new default for a column. Note that this doesn't

691−-- affect any existing rows in the table, it just changes the default for

692−-- future insert and update commands.

693−--

694−-- >>> :{

695−-- let

696−-- definition :: Definition

697−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

698−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]

699−-- definition = alterTable #tab (alterColumn #col (setDefault 5))

700−-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition

701−-- :}

702−-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;

703−setDefault

704− :: Expression schema '[] 'Ungrouped '[] ty -- ^ default value to set

705− -> AlterColumn schema (constraint :=> ty) ('Def :=> ty)

706−setDefault expression = UnsafeAlterColumn $

707− "SET DEFAULT" <+> renderExpression expression

708−

709−-- | A `dropDefault` removes any default value for a column.

710−--

711−-- >>> :{

712−-- let

713−-- definition :: Definition

714−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]

715−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

716−-- definition = alterTable #tab (alterColumn #col dropDefault)

717−-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition

718−-- :}

719−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;

720−dropDefault :: AlterColumn schema ('Def :=> ty) ('NoDef :=> ty)

721−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"

722−

723−-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.

724−-- The constraint will be checked immediately, so the table data must satisfy

725−-- the constraint before it can be added.

726−--

727−-- >>> :{

728−-- let

729−-- definition :: Definition

730−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

731−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]

732−-- definition = alterTable #tab (alterColumn #col setNotNull)

733−-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition

734−-- :}

735−-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;

736−setNotNull

737− :: AlterColumn schema (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)

738−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"

739−

740−-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.

741−--

742−-- >>> :{

743−-- let

744−-- definition :: Definition

745−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]

746−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

747−-- definition = alterTable #tab (alterColumn #col dropNotNull)

748−-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition

749−-- :}

750−-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;

751−dropNotNull

752− :: AlterColumn schema (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)

753−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"

754−

755−-- | An `alterType` converts a column to a different data type.

756−-- This will succeed only if each existing entry in the column can be

757−-- converted to the new type by an implicit cast.

758−--

759−-- >>> :{

760−-- let

761−-- definition :: Definition

762−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]

763−-- '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]

764−-- definition =

765−-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))

766−-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition

767−-- :}

768−-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;

769−alterType :: ColumnTypeExpression schema ty -> AlterColumn schema ty0 ty

770−alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty

771−

772−-- | Create a view.

773−--

774−-- >>> :{

775−-- let

776−-- definition :: Definition

777−-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]

778−-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])

779−-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]

780−-- definition =

781−-- createView #bc (select (#b :* #c :* Nil) (from (table #abc)))

782−-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition

783−-- :}

784−-- CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";

785−createView

786− :: KnownSymbol view

787− => Alias view -- ^ the name of the table to add

788− -> Query schema '[] relation

789− -- ^ query

790− -> Definition schema (Create view ('View relation) schema)

791−createView alias query = UnsafeDefinition $

792− "CREATE" <+> "VIEW" <+> renderAlias alias <+> "AS"

793− <+> renderQuery query <> ";"

794−

795−-- | Drop a view.

796−--

797−-- >>> :{

798−-- let

799−-- definition :: Definition

800−-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])

801−-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]

802−-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]

803−-- definition = dropView #bc

804−-- in Data.ByteString.Char8.putStrLn $ renderDefinition definition

805−-- :}

806−-- DROP VIEW "bc";

807−dropView

808− :: Has view schema ('View v)

809− => Alias view -- ^ view to remove

810− -> Definition schema (Drop view schema)

811−dropView v = UnsafeDefinition $ "DROP VIEW" <+> renderAlias v <> ";"

812−

813−-- | Enumerated types are created using the `createTypeEnum` command, for example

814−--

815−-- >>> Data.ByteString.Char8.putStrLn $ renderDefinition $ createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy" :* Nil)

816−-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');

817−createTypeEnum

818− :: (KnownSymbol enum, SOP.All KnownSymbol labels)

819− => Alias enum

820− -- ^ name of the user defined enumerated type

821− -> NP PGlabel labels

822− -- ^ labels of the enumerated type

823− -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema)

824−createTypeEnum enum labels = UnsafeDefinition $

825− "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+> "ENUM" <+>

826− parenthesized (commaSeparated (renderLabels labels)) <> ";"

827−

828−-- | Enumerated types can also be generated from a Haskell type, for example

829−--

830−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic

831−-- >>> instance SOP.Generic Schwarma

832−-- >>> instance SOP.HasDatatypeInfo Schwarma

833−-- >>> Data.ByteString.Char8.putStrLn $ renderDefinition $ createTypeEnumWith @Schwarma #schwarma

834−-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');

835−createTypeEnumWith

836− :: forall hask enum schema.

837− ( SOP.Generic hask

838− , SOP.All KnownSymbol (LabelsWith hask)

839− , KnownSymbol enum

840− )

841− => Alias enum

842− -- ^ name of the user defined enumerated type

843− -> Definition schema (Create enum ('Typedef (EnumWith hask)) schema)

844−createTypeEnumWith enum = createTypeEnum enum

845− (SOP.hpure label :: NP PGlabel (LabelsWith hask))

846−

847−-- | `createTypeComposite` creates a composite type. The composite type is

848−-- specified by a list of attribute names and data types.

849−--

850−-- >>> Data.ByteString.Char8.putStrLn $ renderDefinition $ createTypeComposite #complex (float8 `As` #real :* float8 `As` #imaginary :* Nil)

851−-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);

852−createTypeComposite

853− :: (KnownSymbol ty, SOP.SListI fields)

854− => Alias ty

855− -- ^ name of the user defined composite type

856− -> NP (Aliased (TypeExpression schema)) fields

857− -- ^ list of attribute names and data types

858− -> Definition schema (Create ty ('Typedef ('PGcomposite fields)) schema)

859−createTypeComposite ty fields = UnsafeDefinition $

860− "CREATE" <+> "TYPE" <+> renderAlias ty <+> "AS" <+> parenthesized

861− (renderCommaSeparated renderField fields) <> ";"

862− where

863− renderField :: Aliased (TypeExpression schema) x -> ByteString

864− renderField (typ `As` field) =

865− renderAlias field <+> renderTypeExpression typ

866−

867−-- | Composite types can also be generated from a Haskell type, for example

868−--

869−-- >>> data Complex = Complex {real :: Maybe Double, imaginary :: Maybe Double} deriving GHC.Generic

870−-- >>> instance SOP.Generic Complex

871−-- >>> instance SOP.HasDatatypeInfo Complex

872−-- >>> Data.ByteString.Char8.putStrLn $ renderDefinition $ createTypeCompositeWith @Complex #complex

873−-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);

874−createTypeCompositeWith

875− :: forall hask ty schema.

876− ( ZipAliased (FieldNamesWith hask) (FieldTypesWith hask)

877− , SOP.All (PGTyped schema) (FieldTypesWith hask)

878− , KnownSymbol ty

879− )

880− => Alias ty

881− -- ^ name of the user defined composite type

882− -> Definition schema (Create ty ( 'Typedef (CompositeWith hask)) schema)

883−createTypeCompositeWith ty = createTypeComposite ty $ zipAs

884− (SOP.hpure Alias :: NP Alias (FieldNamesWith hask))

885− (SOP.hcpure (SOP.Proxy :: SOP.Proxy (PGTyped schema)) pgtype

886− :: NP (TypeExpression schema) (FieldTypesWith hask))

887−

888−-- | Drop a type.

889−--

890−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic

891−-- >>> instance SOP.Generic Schwarma

892−-- >>> instance SOP.HasDatatypeInfo Schwarma

893−-- >>> Data.ByteString.Char8.putStrLn $ renderDefinition (dropType #schwarma :: Definition '["schwarma" ::: 'Typedef (EnumWith Schwarma)] '[])

894−-- DROP TYPE "schwarma";

895−dropType

896− :: Has tydef schema ('Typedef ty)

897− => Alias tydef

898− -- ^ name of the user defined type

899− -> Definition schema (Drop tydef schema)

900−dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderAlias tydef <> ";"

901−

902−-- | `ColumnTypeExpression`s are used in `createTable` commands.

903−newtype ColumnTypeExpression (schema :: SchemaType) (ty :: ColumnType)

904− = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }

905− deriving (GHC.Generic,Show,Eq,Ord,NFData)

906−

907−-- | used in `createTable` commands as a column constraint to note that

908−-- @NULL@ may be present in a column

909−nullable

910− :: TypeExpression schema ty

911− -> ColumnTypeExpression schema ('NoDef :=> 'Null ty)

912−nullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL"

913−

914−-- | used in `createTable` commands as a column constraint to ensure

915−-- @NULL@ is not present in a column

916−notNullable

917− :: TypeExpression schema ty

918− -> ColumnTypeExpression schema (def :=> 'NotNull ty)

919−notNullable ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL"

920−

921−-- | used in `createTable` commands as a column constraint to give a default

922−default_

923− :: Expression schema '[] 'Ungrouped '[] ty

924− -> ColumnTypeExpression schema ('NoDef :=> ty)

925− -> ColumnTypeExpression schema ('Def :=> ty)

926−default_ x ty = UnsafeColumnTypeExpression $

927− renderColumnTypeExpression ty <+> "DEFAULT" <+> renderExpression x

928−

929−-- | not a true type, but merely a notational convenience for creating

930−-- unique identifier columns with type `'PGint2`

931−serial2, smallserial

932− :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint2)

933−serial2 = UnsafeColumnTypeExpression "serial2"

934−smallserial = UnsafeColumnTypeExpression "smallserial"

935−-- | not a true type, but merely a notational convenience for creating

936−-- unique identifier columns with type `'PGint4`

937−serial4, serial

938− :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint4)

939−serial4 = UnsafeColumnTypeExpression "serial4"

940−serial = UnsafeColumnTypeExpression "serial"

941−-- | not a true type, but merely a notational convenience for creating

942−-- unique identifier columns with type `'PGint8`

943−serial8, bigserial

944− :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint8)

945−serial8 = UnsafeColumnTypeExpression "serial8"

946−bigserial = UnsafeColumnTypeExpression "bigserial"

74+ renderSQL ddl0 <> "\n" <> renderSQL ddl1

75+

76+-- | A `Manipulation` without input or output can be run as a statement

77+-- along with other `Definition`s, by embedding it using `manipDefinition`.

78+manipDefinition

79+ :: Manipulation '[] schemas '[] '[]

80+ -- ^ no input or output

81+ -> Definition schemas schemas

82+manipDefinition = UnsafeDefinition . (<> ";") . renderSQL

squeal-postgresql/src/Squeal/PostgreSQL/Definition/Function.hsnew file+238

@@ -0,0 +1,238 @@

1+{-|

2+Module: Squeal.PostgreSQL.Definition.Function

3+Description: Create and drop function and operator definitions

4+Copyright: (c) Eitan Chatav, 2017

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Create and drop function and operator definitions.

9+-}

10+

11+{-# LANGUAGE

12+ AllowAmbiguousTypes

13+ , ConstraintKinds

14+ , DeriveAnyClass

15+ , DeriveGeneric

16+ , DerivingStrategies

17+ , FlexibleContexts

18+ , FlexibleInstances

19+ , GADTs

20+ , LambdaCase

21+ , MultiParamTypeClasses

22+ , OverloadedLabels

23+ , OverloadedStrings

24+ , RankNTypes

25+ , ScopedTypeVariables

26+ , TypeApplications

27+ , TypeInType

28+ , TypeOperators

29+ , UndecidableSuperClasses

30+#-}

31+

32+module Squeal.PostgreSQL.Definition.Function

33+ ( createFunction

34+ , createOrReplaceFunction

35+ , createSetFunction

36+ , createOrReplaceSetFunction

37+ , createBinaryOp

38+ , createLeftOp

39+ , createRightOp

40+ , dropFunction

41+ , dropFunctionIfExists

42+ , dropOperator

43+ , dropOperatorIfExists

44+ , FunctionDefinition(..)

45+ , languageSqlExpr

46+ , languageSqlQuery

47+ ) where

48+

49+import Control.DeepSeq

50+import Data.ByteString

51+import GHC.TypeLits

52+

53+import qualified Generics.SOP as SOP

54+import qualified GHC.Generics as GHC

55+

56+import Squeal.PostgreSQL.Alias

57+import Squeal.PostgreSQL.Definition

58+import Squeal.PostgreSQL.Expression

59+import Squeal.PostgreSQL.Expression.Type

60+import Squeal.PostgreSQL.List

61+import Squeal.PostgreSQL.Query

62+import Squeal.PostgreSQL.Render

63+import Squeal.PostgreSQL.Schema

64+

65+-- $setup

66+-- >>> import Squeal.PostgreSQL

67+

68+createFunction

69+ :: ( Has sch schemas schema

70+ , KnownSymbol fun

71+ , SOP.SListI args )

72+ => QualifiedAlias sch fun

73+ -> NP (TypeExpression schemas) args

74+ -> TypeExpression schemas ret

75+ -> FunctionDefinition schemas args ('Returns ret)

76+ -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'Returns ret)) schema) schemas)

77+createFunction fun args ret fundef = UnsafeDefinition $

78+ "CREATE" <+> "FUNCTION" <+> renderSQL fun

79+ <+> parenthesized (renderCommaSeparated renderSQL args)

80+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"

81+

82+createOrReplaceFunction

83+ :: ( Has sch schemas schema

84+ , KnownSymbol fun

85+ , SOP.SListI args )

86+ => QualifiedAlias sch fun

87+ -> NP (TypeExpression schemas) args

88+ -> TypeExpression schemas ret

89+ -> FunctionDefinition schemas args ('Returns ret)

90+ -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'Returns ret)) schema) schemas)

91+createOrReplaceFunction fun args ret fundef = UnsafeDefinition $

92+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun

93+ <+> parenthesized (renderCommaSeparated renderSQL args)

94+ <+> "RETURNS" <+> renderSQL ret <+> renderSQL fundef <> ";"

95+

96+languageSqlExpr

97+ :: Expression '[] '[] 'Ungrouped schemas args '[] ret

98+ -> FunctionDefinition schemas args ('Returns ret)

99+languageSqlExpr expr = UnsafeFunctionDefinition $

100+ "language sql as"

101+ <+> "$$" <+> renderSQL (values_ (expr `as` #ret)) <+> "$$"

102+

103+languageSqlQuery

104+ :: Query '[] '[] schemas args rets

105+ -> FunctionDefinition schemas args ('ReturnsTable rets)

106+languageSqlQuery qry = UnsafeFunctionDefinition $

107+ "language sql as" <+> "$$" <+> renderSQL qry <+> "$$"

108+

109+createSetFunction

110+ :: ( Has sch schemas schema

111+ , KnownSymbol fun

112+ , SOP.SListI args

113+ , SOP.SListI rets )

114+ => QualifiedAlias sch fun

115+ -> NP (TypeExpression schemas) args

116+ -> NP (Aliased (TypeExpression schemas)) rets

117+ -> FunctionDefinition schemas args ('ReturnsTable rets)

118+ -> Definition schemas (Alter sch (Create fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)

119+createSetFunction fun args rets fundef = UnsafeDefinition $

120+ "CREATE" <+> "FUNCTION" <+> renderSQL fun

121+ <+> parenthesized (renderCommaSeparated renderSQL args)

122+ <+> "RETURNS" <+> "TABLE"

123+ <+> parenthesized (renderCommaSeparated renderRet rets)

124+ <+> renderSQL fundef <> ";"

125+ where

126+ renderRet :: Aliased (TypeExpression s) r -> ByteString

127+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty

128+

129+createOrReplaceSetFunction

130+ :: ( Has sch schemas schema

131+ , KnownSymbol fun

132+ , SOP.SListI args

133+ , SOP.SListI rets )

134+ => QualifiedAlias sch fun

135+ -> NP (TypeExpression schemas) args

136+ -> NP (Aliased (TypeExpression schemas)) rets

137+ -> FunctionDefinition schemas args ('ReturnsTable rets)

138+ -> Definition schemas (Alter sch (CreateOrReplace fun ('Function (args :=> 'ReturnsTable rets)) schema) schemas)

139+createOrReplaceSetFunction fun args rets fundef = UnsafeDefinition $

140+ "CREATE" <+> "OR" <+> "REPLACE" <+> "FUNCTION" <+> renderSQL fun

141+ <+> parenthesized (renderCommaSeparated renderSQL args)

142+ <+> "RETURNS" <+> "TABLE"

143+ <+> parenthesized (renderCommaSeparated renderRet rets)

144+ <+> renderSQL fundef <> ";"

145+ where

146+ renderRet :: Aliased (TypeExpression s) r -> ByteString

147+ renderRet (ty `As` col) = renderSQL col <+> renderSQL ty

148+

149+createBinaryOp

150+ :: forall op fun sch schemas schema x y z.

151+ ( Has sch schemas schema

152+ , Has fun schema ('Function ('[x,y] :=> 'Returns z))

153+ , KnownSymbol op )

154+ => QualifiedAlias sch fun

155+ -> TypeExpression schemas x

156+ -> TypeExpression schemas y

157+ -> Definition schemas

158+ (Alter sch (Create op ('Operator ('BinaryOp x y z)) schema) schemas)

159+createBinaryOp fun x y = UnsafeDefinition $

160+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op

161+ <+> parenthesized (commaSeparated opdef)

162+ where

163+ opdef =

164+ [ "FUNCTION" <+> "=" <+> renderSQL fun

165+ , "LEFTARG" <+> "=" <+> renderSQL x

166+ , "RIGHTARG" <+> "=" <+> renderSQL y ]

167+

168+createLeftOp

169+ :: forall op fun sch schemas schema x y.

170+ ( Has sch schemas schema

171+ , Has fun schema ('Function ('[x] :=> 'Returns y))

172+ , KnownSymbol op )

173+ => QualifiedAlias sch fun

174+ -> TypeExpression schemas x

175+ -> Definition schemas

176+ (Alter sch (Create op ('Operator ('LeftOp x y)) schema) schemas)

177+createLeftOp fun x = UnsafeDefinition $

178+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op

179+ <+> parenthesized (commaSeparated opdef)

180+ where

181+ opdef =

182+ [ "FUNCTION" <+> "=" <+> renderSQL fun

183+ , "RIGHTARG" <+> "=" <+> renderSQL x ]

184+

185+createRightOp

186+ :: forall op fun sch schemas schema x y.

187+ ( Has sch schemas schema

188+ , Has fun schema ('Function ('[x] :=> 'Returns y))

189+ , KnownSymbol op )

190+ => QualifiedAlias sch fun

191+ -> TypeExpression schemas x

192+ -> Definition schemas

193+ (Alter sch (Create op ('Operator ('RightOp x y)) schema) schemas)

194+createRightOp fun x = UnsafeDefinition $

195+ "CREATE" <+> "OPERATOR" <+> renderSymbol @op

196+ <+> parenthesized (commaSeparated opdef)

197+ where

198+ opdef =

199+ [ "FUNCTION" <+> "=" <+> renderSQL fun

200+ , "LEFTARG" <+> "=" <+> renderSQL x ]

201+

202+dropFunction

203+ :: (Has sch schemas schema, KnownSymbol fun)

204+ => QualifiedAlias sch fun

205+ -- ^ name of the user defined function

206+ -> Definition schemas (Alter sch (DropSchemum fun 'Function schema) schemas)

207+dropFunction fun = UnsafeDefinition $

208+ "DROP" <+> "FUNCTION" <+> renderSQL fun <> ";"

209+

210+dropFunctionIfExists

211+ :: (Has sch schemas schema, KnownSymbol fun)

212+ => QualifiedAlias sch fun

213+ -- ^ name of the user defined function

214+ -> Definition schemas (Alter sch (DropSchemumIfExists fun 'Function schema) schemas)

215+dropFunctionIfExists fun = UnsafeDefinition $

216+ "DROP FUNCTION IF EXISTS" <+> renderSQL fun <> ";"

217+

218+dropOperator

219+ :: (Has sch schemas schema, KnownSymbol op)

220+ => QualifiedAlias sch op

221+ -- ^ name of the user defined operator

222+ -> Definition schemas (Alter sch (DropSchemum op 'Operator schema) schemas)

223+dropOperator op = UnsafeDefinition $

224+ "DROP" <+> "OPERATOR" <+> renderSQL op <> ";"

225+

226+dropOperatorIfExists

227+ :: (Has sch schemas schema, KnownSymbol op)

228+ => QualifiedAlias sch op

229+ -- ^ name of the user defined operator

230+ -> Definition schemas (Alter sch (DropSchemumIfExists op 'Operator schema) schemas)

231+dropOperatorIfExists op = UnsafeDefinition $

232+ "DROP OPERATOR IF EXISTS" <+> renderSQL op <> ";"

233+

234+newtype FunctionDefinition schemas args ret = UnsafeFunctionDefinition

235+ { renderFunctionDefinition :: ByteString }

236+ deriving (Eq,Show,GHC.Generic,NFData)

237+instance RenderSQL (FunctionDefinition schemas args ret) where

238+ renderSQL = renderFunctionDefinition

squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hsnew file+159

@@ -0,0 +1,159 @@

1+{-|

2+Module: Squeal.PostgreSQL.Definition.Index

3+Description: Create and drop index definitions

4+Copyright: (c) Eitan Chatav, 2017

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Create and drop index definitions.

9+-}

10+

11+{-# LANGUAGE

12+ AllowAmbiguousTypes

13+ , ConstraintKinds

14+ , DeriveAnyClass

15+ , DeriveGeneric

16+ , DerivingStrategies

17+ , FlexibleContexts

18+ , FlexibleInstances

19+ , GADTs

20+ , LambdaCase

21+ , MultiParamTypeClasses

22+ , OverloadedLabels

23+ , OverloadedStrings

24+ , RankNTypes

25+ , ScopedTypeVariables

26+ , TypeApplications

27+ , TypeInType

28+ , TypeOperators

29+ , UndecidableSuperClasses

30+#-}

31+

32+module Squeal.PostgreSQL.Definition.Index

33+ ( createIndex

34+ , createIndexIfNotExists

35+ , dropIndex

36+ , dropIndexIfExists

37+ , IndexMethod (..)

38+ , btree

39+ , hash

40+ , gist

41+ , spgist

42+ , gin

43+ , brin

44+ ) where

45+

46+import Data.ByteString

47+import GHC.TypeLits

48+

49+import qualified GHC.Generics as GHC

50+

51+import Squeal.PostgreSQL.Alias

52+import Squeal.PostgreSQL.Definition

53+import Squeal.PostgreSQL.Expression.Sort

54+import Squeal.PostgreSQL.Render

55+import Squeal.PostgreSQL.Schema

56+

57+-- $setup

58+-- >>> import Squeal.PostgreSQL

59+

60+{- |

61+>>> :{

62+type Table = '[] :=>

63+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4

64+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]

65+:}

66+

67+>>> :{

68+let

69+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree])

70+ setup =

71+ createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>>

72+ createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast]

73+in printSQL setup

74+:}

75+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);

76+CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST);

77+-}

78+createIndex

79+ :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)

80+ => Alias ix

81+ -> QualifiedAlias sch tab

82+ -> IndexMethod method

83+ -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]

84+ -> Definition schemas (Alter sch (Create ix ('Index method) schema) schemas)

85+createIndex ix tab method cols = UnsafeDefinition $

86+ "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab

87+ <+> "USING" <+> renderSQL method

88+ <+> parenthesized (commaSeparated (renderIndex <$> cols))

89+ <> ";"

90+ where

91+ renderIndex = \case

92+ Asc expression -> parenthesized (renderSQL expression) <+> "ASC"

93+ Desc expression -> parenthesized (renderSQL expression) <+> "DESC"

94+ AscNullsFirst expression -> parenthesized (renderSQL expression)

95+ <+> "ASC NULLS FIRST"

96+ DescNullsFirst expression -> parenthesized (renderSQL expression)

97+ <+> "DESC NULLS FIRST"

98+ AscNullsLast expression -> parenthesized (renderSQL expression)

99+ <+> "ASC NULLS LAST"

100+ DescNullsLast expression -> parenthesized (renderSQL expression)

101+ <+> "DESC NULLS LAST"

102+

103+createIndexIfNotExists

104+ :: (Has sch schemas schema, Has tab schema ('Table table), KnownSymbol ix)

105+ => Alias ix

106+ -> QualifiedAlias sch tab

107+ -> IndexMethod method

108+ -> [SortExpression '[] '[] 'Ungrouped schemas '[] '[tab ::: TableToRow table]]

109+ -> Definition schemas (Alter sch (CreateIfNotExists ix ('Index method) schema) schemas)

110+createIndexIfNotExists ix tab method cols = UnsafeDefinition $

111+ "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab

112+ <+> "USING" <+> renderSQL method

113+ <+> parenthesized (commaSeparated (renderIndex <$> cols))

114+ <> ";"

115+ where

116+ renderIndex = \case

117+ Asc expression -> parenthesized (renderSQL expression) <+> "ASC"

118+ Desc expression -> parenthesized (renderSQL expression) <+> "DESC"

119+ AscNullsFirst expression -> parenthesized (renderSQL expression)

120+ <+> "ASC NULLS FIRST"

121+ DescNullsFirst expression -> parenthesized (renderSQL expression)

122+ <+> "DESC NULLS FIRST"

123+ AscNullsLast expression -> parenthesized (renderSQL expression)

124+ <+> "ASC NULLS LAST"

125+ DescNullsLast expression -> parenthesized (renderSQL expression)

126+ <+> "DESC NULLS LAST"

127+

128+newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString}

129+ deriving stock (Eq, Ord, Show, GHC.Generic)

130+instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod

131+btree :: IndexMethod 'Btree

132+btree = UnsafeIndexMethod "btree"

133+hash :: IndexMethod 'Hash

134+hash = UnsafeIndexMethod "hash"

135+gist :: IndexMethod 'Gist

136+gist = UnsafeIndexMethod "gist"

137+spgist :: IndexMethod 'Spgist

138+spgist = UnsafeIndexMethod "spgist"

139+gin :: IndexMethod 'Gin

140+gin = UnsafeIndexMethod "gin"

141+brin :: IndexMethod 'Brin

142+brin = UnsafeIndexMethod "brin"

143+

144+-- |

145+-- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[]))

146+-- DROP INDEX "ix";

147+dropIndex

148+ :: (Has sch schemas schema, KnownSymbol ix)

149+ => QualifiedAlias sch ix

150+ -- ^ name of the user defined index

151+ -> Definition schemas (Alter sch (DropSchemum ix 'Index schema) schemas)

152+dropIndex ix = UnsafeDefinition $ "DROP" <+> "INDEX" <+> renderSQL ix <> ";"

153+

154+dropIndexIfExists

155+ :: (Has sch schemas schema, KnownSymbol ix)

156+ => QualifiedAlias sch ix

157+ -- ^ name of the user defined index

158+ -> Definition schemas (Alter sch (DropSchemumIfExists ix 'Index schema) schemas)

159+dropIndexIfExists ix = UnsafeDefinition $ "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";"

squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hsnew file+96

@@ -0,0 +1,96 @@

1+{-|

2+Module: Squeal.PostgreSQL.Definition.Schema

3+Description: Create and drop schema definitions

4+Copyright: (c) Eitan Chatav, 2017

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Create and drop schema definitions.

9+-}

10+

11+{-# LANGUAGE

12+ AllowAmbiguousTypes

13+ , ConstraintKinds

14+ , DeriveAnyClass

15+ , DeriveGeneric

16+ , DerivingStrategies

17+ , FlexibleContexts

18+ , FlexibleInstances

19+ , GADTs

20+ , LambdaCase

21+ , MultiParamTypeClasses

22+ , OverloadedLabels

23+ , OverloadedStrings

24+ , RankNTypes

25+ , ScopedTypeVariables

26+ , TypeApplications

27+ , TypeInType

28+ , TypeOperators

29+ , UndecidableSuperClasses

30+#-}

31+

32+module Squeal.PostgreSQL.Definition.Schema

33+ ( createSchema

34+ , createSchemaIfNotExists

35+ , dropSchema

36+ , dropSchemaIfExists

37+ ) where

38+

39+import GHC.TypeLits

40+

41+import Squeal.PostgreSQL.Alias

42+import Squeal.PostgreSQL.Definition

43+import Squeal.PostgreSQL.Render

44+import Squeal.PostgreSQL.Schema

45+

46+-- $setup

47+-- >>> import Squeal.PostgreSQL

48+

49+{- |

50+`createSchema` enters a new schema into the current database.

51+The schema name must be distinct from the name of any existing schema

52+in the current database.

53+

54+A schema is essentially a namespace: it contains named objects

55+(tables, data types, functions, and operators) whose names

56+can duplicate those of other objects existing in other schemas.

57+Named objects are accessed by `QualifiedAlias`es with the schema

58+name as a prefix.

59+-}

60+createSchema

61+ :: KnownSymbol sch

62+ => Alias sch

63+ -> Definition schemas (Create sch '[] schemas)

64+createSchema sch = UnsafeDefinition $

65+ "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"

66+

67+{- | Idempotent version of `createSchema`. -}

68+createSchemaIfNotExists

69+ :: (KnownSymbol sch, Has sch schemas schema)

70+ => Alias sch

71+ -> Definition schemas (CreateIfNotExists sch '[] schemas)

72+createSchemaIfNotExists sch = UnsafeDefinition $

73+ "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"

74+ <+> renderSQL sch <> ";"

75+

76+-- | >>> :{

77+-- let

78+-- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]

79+-- definition = dropSchema #muh_schema

80+-- :}

81+--

82+-- >>> printSQL definition

83+-- DROP SCHEMA "muh_schema";

84+dropSchema

85+ :: KnownSymbol sch

86+ => Alias sch

87+ -- ^ user defined schema

88+ -> Definition schemas (Drop sch schemas)

89+dropSchema sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"

90+

91+dropSchemaIfExists

92+ :: KnownSymbol sch

93+ => Alias sch

94+ -- ^ user defined schema

95+ -> Definition schemas (DropIfExists sch schemas)

96+dropSchemaIfExists sch = UnsafeDefinition $ "DROP SCHEMA" <+> renderSQL sch <> ";"

squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table.hsnew file+500

@@ -0,0 +1,500 @@

1+{-|

2+Module: Squeal.PostgreSQL.Definition.Table

3+Description: Create, drop and alter table definitions

4+Copyright: (c) Eitan Chatav, 2017

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Create, drop and alter table definitions.

9+-}

10+

11+{-# LANGUAGE

12+ AllowAmbiguousTypes

13+ , ConstraintKinds

14+ , DeriveAnyClass

15+ , DeriveGeneric

16+ , DerivingStrategies

17+ , FlexibleContexts

18+ , FlexibleInstances

19+ , GADTs

20+ , LambdaCase

21+ , MultiParamTypeClasses

22+ , OverloadedLabels

23+ , OverloadedStrings

24+ , RankNTypes

25+ , ScopedTypeVariables

26+ , TypeApplications

27+ , TypeInType

28+ , TypeOperators

29+ , UndecidableSuperClasses

30+#-}

31+

32+module Squeal.PostgreSQL.Definition.Table

33+ ( createTable

34+ , createTableIfNotExists

35+ , dropTable

36+ , dropTableIfExists

37+ , alterTable

38+ , alterTableIfExists

39+ , alterTableRename

40+ , alterTableIfExistsRename

41+ , AlterTable (..)

42+ , addConstraint

43+ , dropConstraint

44+ , AddColumn (..)

45+ , dropColumn

46+ , renameColumn

47+ , alterColumn

48+ , AlterColumn (..)

49+ , setDefault

50+ , dropDefault

51+ , setNotNull

52+ , dropNotNull

53+ , alterType

54+ ) where

55+

56+import Control.DeepSeq

57+import Data.ByteString

58+import GHC.TypeLits

59+

60+import qualified Generics.SOP as SOP

61+import qualified GHC.Generics as GHC

62+

63+import Squeal.PostgreSQL.Alias

64+import Squeal.PostgreSQL.Definition

65+import Squeal.PostgreSQL.Definition.Table.Constraint

66+import Squeal.PostgreSQL.Expression

67+import Squeal.PostgreSQL.Expression.Type

68+import Squeal.PostgreSQL.List

69+import Squeal.PostgreSQL.Render

70+import Squeal.PostgreSQL.Schema

71+

72+-- $setup

73+-- >>> import Squeal.PostgreSQL

74+

75+{- | `createTable` adds a table to the schema.

76+

77+>>> :set -XOverloadedLabels

78+>>> :{

79+type Table = '[] :=>

80+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4

81+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]

82+:}

83+

84+>>> :{

85+let

86+ setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table])

87+ setup = createTable #tab

88+ (nullable int `as` #a :* nullable real `as` #b) Nil

89+in printSQL setup

90+:}

91+CREATE TABLE "tab" ("a" int NULL, "b" real NULL);

92+-}

93+createTable

94+ :: ( KnownSymbol sch

95+ , KnownSymbol tab

96+ , columns ~ (col ': cols)

97+ , SOP.SListI columns

98+ , SOP.SListI constraints

99+ , Has sch schemas0 schema0

100+ , schemas1 ~ Alter sch (Create tab ('Table (constraints :=> columns)) schema0) schemas0 )

101+ => QualifiedAlias sch tab -- ^ the name of the table to add

102+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns

103+ -- ^ the names and datatype of each column

104+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints

105+ -- ^ constraints that must hold for the table

106+ -> Definition schemas0 schemas1

107+createTable tab columns constraints = UnsafeDefinition $

108+ "CREATE TABLE" <+> renderCreation tab columns constraints

109+

110+{-| `createTableIfNotExists` creates a table if it doesn't exist, but does not add it to the schema.

111+Instead, the schema already has the table so if the table did not yet exist, the schema was wrong.

112+`createTableIfNotExists` fixes this. Interestingly, this property makes it an idempotent in

113+the `Category` of `Definition`s.

114+

115+>>> :set -XOverloadedLabels -XTypeApplications

116+>>> :{

117+type Table = '[] :=>

118+ '[ "a" ::: 'NoDef :=> 'Null 'PGint4

119+ , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]

120+:}

121+

122+>>> type Schemas = Public '["tab" ::: 'Table Table]

123+

124+>>> :{

125+let

126+ setup :: Definition Schemas Schemas

127+ setup = createTableIfNotExists #tab

128+ (nullable int `as` #a :* nullable real `as` #b) Nil

129+in printSQL setup

130+:}

131+CREATE TABLE IF NOT EXISTS "tab" ("a" int NULL, "b" real NULL);

132+-}

133+createTableIfNotExists

134+ :: ( KnownSymbol sch

135+ , KnownSymbol tab

136+ , columns ~ (col ': cols)

137+ , SOP.SListI columns

138+ , SOP.SListI constraints

139+ , Has sch schemas0 schema0

140+ , schemas1 ~ Alter sch (CreateIfNotExists tab ('Table (constraints :=> columns)) schema0) schemas0 )

141+ => QualifiedAlias sch tab -- ^ the name of the table to add

142+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns

143+ -- ^ the names and datatype of each column

144+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints

145+ -- ^ constraints that must hold for the table

146+ -> Definition schemas0 schemas1

147+createTableIfNotExists tab columns constraints = UnsafeDefinition $

148+ "CREATE TABLE IF NOT EXISTS"

149+ <+> renderCreation tab columns constraints

150+

151+-- helper function for `createTable` and `createTableIfNotExists`

152+renderCreation

153+ :: ( KnownSymbol sch

154+ , KnownSymbol tab

155+ , SOP.SListI columns

156+ , SOP.SListI constraints )

157+ => QualifiedAlias sch tab -- ^ the name of the table to add

158+ -> NP (Aliased (ColumnTypeExpression schemas0)) columns

159+ -- ^ the names and datatype of each column

160+ -> NP (Aliased (TableConstraintExpression sch tab schemas1)) constraints

161+ -- ^ constraints that must hold for the table

162+ -> ByteString

163+renderCreation tab columns constraints = renderSQL tab

164+ <+> parenthesized

165+ ( renderCommaSeparated renderColumnDef columns

166+ <> ( case constraints of

167+ Nil -> ""

168+ _ -> ", " <>

169+ renderCommaSeparated renderConstraint constraints ) )

170+ <> ";"

171+ where

172+ renderColumnDef :: Aliased (ColumnTypeExpression schemas) x -> ByteString

173+ renderColumnDef (ty `As` column) =

174+ renderSQL column <+> renderColumnTypeExpression ty

175+ renderConstraint

176+ :: Aliased (TableConstraintExpression sch tab schemas) constraint

177+ -> ByteString

178+ renderConstraint (constraint `As` alias) =

179+ "CONSTRAINT" <+> renderSQL alias <+> renderSQL constraint

180+

181+-- | `dropTable` removes a table from the schema.

182+--

183+-- >>> :{

184+-- let

185+-- definition :: Definition '["public" ::: '["muh_table" ::: 'Table t]] (Public '[])

186+-- definition = dropTable #muh_table

187+-- :}

188+--

189+-- >>> printSQL definition

190+-- DROP TABLE "muh_table";

191+dropTable

192+ :: ( Has sch schemas schema

193+ , KnownSymbol tab )

194+ => QualifiedAlias sch tab -- ^ table to remove

195+ -> Definition schemas (Alter sch (DropSchemum tab 'Table schema) schemas)

196+dropTable tab = UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> ";"

197+

198+dropTableIfExists

199+ :: ( Has sch schemas schema

200+ , KnownSymbol tab)

201+ => QualifiedAlias sch tab -- ^ table to remove

202+ -> Definition schemas (Alter sch (DropSchemumIfExists tab 'Table schema) schemas)

203+dropTableIfExists tab = UnsafeDefinition $ "DROP TABLE IF EXISTS" <+> renderSQL tab <> ";"

204+

205+-- | `alterTable` changes the definition of a table from the schema.

206+alterTable

207+ :: (Has sch schemas schema, KnownSymbol tab)

208+ => QualifiedAlias sch tab -- ^ table to alter

209+ -> AlterTable sch tab schemas table -- ^ alteration to perform

210+ -> Definition schemas (Alter sch (Alter tab ('Table table) schema) schemas)

211+alterTable tab alteration = UnsafeDefinition $

212+ "ALTER TABLE"

213+ <+> renderSQL tab

214+ <+> renderAlterTable alteration

215+ <> ";"

216+

217+-- | `alterTable` changes the definition of a table from the schema.

218+alterTableIfExists

219+ :: (Has sch schemas schema, KnownSymbol tab)

220+ => QualifiedAlias sch tab -- ^ table to alter

221+ -> AlterTable sch tab schemas table -- ^ alteration to perform

222+ -> Definition schemas (Alter sch (AlterIfExists tab ('Table table) schema) schemas)

223+alterTableIfExists tab alteration = UnsafeDefinition $

224+ "ALTER TABLE IF EXISTS"

225+ <+> renderSQL tab

226+ <+> renderAlterTable alteration

227+ <> ";"

228+

229+-- | `alterTableRename` changes the name of a table from the schema.

230+--

231+-- >>> printSQL $ alterTableRename #foo #bar

232+-- ALTER TABLE "foo" RENAME TO "bar";

233+alterTableRename

234+ :: (KnownSymbol tab0, KnownSymbol tab1)

235+ => Alias tab0 -- ^ table to rename

236+ -> Alias tab1 -- ^ what to rename it

237+ -> Definition schema (Rename tab0 tab1 schema)

238+alterTableRename tab0 tab1 = UnsafeDefinition $

239+ "ALTER TABLE" <+> renderSQL tab0

240+ <+> "RENAME TO" <+> renderSQL tab1 <> ";"

241+

242+alterTableIfExistsRename

243+ :: (KnownSymbol tab0, KnownSymbol tab1)

244+ => Alias tab0 -- ^ table to rename

245+ -> Alias tab1 -- ^ what to rename it

246+ -> Definition schema (RenameIfExists tab0 tab1 schema)

247+alterTableIfExistsRename tab0 tab1 = UnsafeDefinition $

248+ "ALTER TABLE IF EXISTS" <+> renderSQL tab0

249+ <+> "RENAME TO" <+> renderSQL tab1 <> ";"

250+

251+-- | An `AlterTable` describes the alteration to perform on the columns

252+-- of a table.

253+newtype AlterTable

254+ (sch :: Symbol)

255+ (tab :: Symbol)

256+ (schemas :: SchemasType)

257+ (table :: TableType) =

258+ UnsafeAlterTable {renderAlterTable :: ByteString}

259+ deriving (GHC.Generic,Show,Eq,Ord,NFData)

260+

261+-- | An `addConstraint` adds a table constraint.

262+--

263+-- >>> :{

264+-- let

265+-- definition :: Definition

266+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

267+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: 'Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

268+-- definition = alterTable #tab (addConstraint #positive (check #col (#col .> 0)))

269+-- in printSQL definition

270+-- :}

271+-- ALTER TABLE "tab" ADD CONSTRAINT "positive" CHECK (("col" > 0));

272+addConstraint

273+ :: ( KnownSymbol alias

274+ , Has sch schemas schema

275+ , Has tab schema ('Table table0)

276+ , table0 ~ (constraints :=> columns)

277+ , table1 ~ (Create alias constraint constraints :=> columns) )

278+ => Alias alias

279+ -> TableConstraintExpression sch tab schemas constraint

280+ -- ^ constraint to add

281+ -> AlterTable sch tab schemas table1

282+addConstraint alias constraint = UnsafeAlterTable $

283+ "ADD" <+> "CONSTRAINT" <+> renderSQL alias

284+ <+> renderSQL constraint

285+

286+-- | A `dropConstraint` drops a table constraint.

287+--

288+-- >>> :{

289+-- let

290+-- definition :: Definition

291+-- '["public" ::: '["tab" ::: 'Table ('["positive" ::: Check '["col"]] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

292+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

293+-- definition = alterTable #tab (dropConstraint #positive)

294+-- in printSQL definition

295+-- :}

296+-- ALTER TABLE "tab" DROP CONSTRAINT "positive";

297+dropConstraint

298+ :: ( KnownSymbol constraint

299+ , Has sch schemas schema

300+ , Has tab schema ('Table table0)

301+ , table0 ~ (constraints :=> columns)

302+ , table1 ~ (Drop constraint constraints :=> columns) )

303+ => Alias constraint

304+ -- ^ constraint to drop

305+ -> AlterTable sch tab schemas table1

306+dropConstraint constraint = UnsafeAlterTable $

307+ "DROP" <+> "CONSTRAINT" <+> renderSQL constraint

308+

309+-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.

310+class AddColumn ty where

311+ -- | `addColumn` adds a new column, initially filled with whatever

312+ -- default value is given or with @NULL@.

313+ --

314+ -- >>> :{

315+ -- let

316+ -- definition :: Definition

317+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]

318+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>

319+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

320+ -- , "col2" ::: 'Def :=> 'Null 'PGtext ])]]

321+ -- definition = alterTable #tab (addColumn #col2 (text & nullable & default_ "foo"))

322+ -- in printSQL definition

323+ -- :}

324+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL DEFAULT E'foo';

325+ --

326+ -- >>> :{

327+ -- let

328+ -- definition :: Definition

329+ -- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]

330+ -- '["public" ::: '["tab" ::: 'Table ('[] :=>

331+ -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

332+ -- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]

333+ -- definition = alterTable #tab (addColumn #col2 (text & nullable))

334+ -- in printSQL definition

335+ -- :}

336+ -- ALTER TABLE "tab" ADD COLUMN "col2" text NULL;

337+ addColumn

338+ :: ( KnownSymbol column

339+ , Has sch schemas schema

340+ , Has tab schema ('Table table0)

341+ , table0 ~ (constraints :=> columns) )

342+ => Alias column -- ^ column to add

343+ -> ColumnTypeExpression schemas ty -- ^ type of the new column

344+ -> AlterTable sch tab schemas (constraints :=> Create column ty columns)

345+ addColumn column ty = UnsafeAlterTable $

346+ "ADD COLUMN" <+> renderSQL column <+> renderColumnTypeExpression ty

347+instance {-# OVERLAPPING #-} AddColumn ('Def :=> ty)

348+instance {-# OVERLAPPABLE #-} AddColumn ('NoDef :=> 'Null ty)

349+

350+-- | A `dropColumn` removes a column. Whatever data was in the column

351+-- disappears. Table constraints involving the column are dropped, too.

352+-- However, if the column is referenced by a foreign key constraint of

353+-- another table, PostgreSQL will not silently drop that constraint.

354+--

355+-- >>> :{

356+-- let

357+-- definition :: Definition

358+-- '["public" ::: '["tab" ::: 'Table ('[] :=>

359+-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

360+-- , "col2" ::: 'NoDef :=> 'Null 'PGtext ])]]

361+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col1" ::: 'NoDef :=> 'Null 'PGint4])]]

362+-- definition = alterTable #tab (dropColumn #col2)

363+-- in printSQL definition

364+-- :}

365+-- ALTER TABLE "tab" DROP COLUMN "col2";

366+dropColumn

367+ :: ( KnownSymbol column

368+ , Has sch schemas schema

369+ , Has tab schema ('Table table0)

370+ , table0 ~ (constraints :=> columns)

371+ , table1 ~ (constraints :=> Drop column columns) )

372+ => Alias column -- ^ column to remove

373+ -> AlterTable sch tab schemas table1

374+dropColumn column = UnsafeAlterTable $

375+ "DROP COLUMN" <+> renderSQL column

376+

377+-- | A `renameColumn` renames a column.

378+--

379+-- >>> :{

380+-- let

381+-- definition :: Definition

382+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["foo" ::: 'NoDef :=> 'Null 'PGint4])]]

383+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["bar" ::: 'NoDef :=> 'Null 'PGint4])]]

384+-- definition = alterTable #tab (renameColumn #foo #bar)

385+-- in printSQL definition

386+-- :}

387+-- ALTER TABLE "tab" RENAME COLUMN "foo" TO "bar";

388+renameColumn

389+ :: ( KnownSymbol column0

390+ , KnownSymbol column1

391+ , Has sch schemas schema

392+ , Has tab schema ('Table table0)

393+ , table0 ~ (constraints :=> columns)

394+ , table1 ~ (constraints :=> Rename column0 column1 columns) )

395+ => Alias column0 -- ^ column to rename

396+ -> Alias column1 -- ^ what to rename the column

397+ -> AlterTable sch tab schemas table1

398+renameColumn column0 column1 = UnsafeAlterTable $

399+ "RENAME COLUMN" <+> renderSQL column0 <+> "TO" <+> renderSQL column1

400+

401+-- | An `alterColumn` alters a single column.

402+alterColumn

403+ :: ( KnownSymbol column

404+ , Has sch schemas schema

405+ , Has tab schema ('Table table0)

406+ , table0 ~ (constraints :=> columns)

407+ , Has column columns ty0

408+ , table1 ~ (constraints :=> Alter column ty1 columns))

409+ => Alias column -- ^ column to alter

410+ -> AlterColumn schemas ty0 ty1 -- ^ alteration to perform

411+ -> AlterTable sch tab schemas table1

412+alterColumn column alteration = UnsafeAlterTable $

413+ "ALTER COLUMN" <+> renderSQL column <+> renderAlterColumn alteration

414+

415+-- | An `AlterColumn` describes the alteration to perform on a single column.

416+newtype AlterColumn (schemas :: SchemasType) (ty0 :: ColumnType) (ty1 :: ColumnType) =

417+ UnsafeAlterColumn {renderAlterColumn :: ByteString}

418+ deriving (GHC.Generic,Show,Eq,Ord,NFData)

419+

420+-- | A `setDefault` sets a new default for a column. Note that this doesn't

421+-- affect any existing rows in the table, it just changes the default for

422+-- future insert and update commands.

423+--

424+-- >>> :{

425+-- let

426+-- definition :: Definition

427+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]

428+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]

429+-- definition = alterTable #tab (alterColumn #col (setDefault 5))

430+-- in printSQL definition

431+-- :}

432+-- ALTER TABLE "tab" ALTER COLUMN "col" SET DEFAULT 5;

433+setDefault

434+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty -- ^ default value to set

435+ -> AlterColumn schemas (constraint :=> ty) ('Def :=> ty)

436+setDefault expression = UnsafeAlterColumn $

437+ "SET DEFAULT" <+> renderExpression expression

438+

439+-- | A `dropDefault` removes any default value for a column.

440+--

441+-- >>> :{

442+-- let

443+-- definition :: Definition

444+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'Def :=> 'Null 'PGint4])]]

445+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]

446+-- definition = alterTable #tab (alterColumn #col dropDefault)

447+-- in printSQL definition

448+-- :}

449+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP DEFAULT;

450+dropDefault :: AlterColumn schemas ('Def :=> ty) ('NoDef :=> ty)

451+dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"

452+

453+-- | A `setNotNull` adds a @NOT NULL@ constraint to a column.

454+-- The constraint will be checked immediately, so the table data must satisfy

455+-- the constraint before it can be added.

456+--

457+-- >>> :{

458+-- let

459+-- definition :: Definition

460+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]

461+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

462+-- definition = alterTable #tab (alterColumn #col setNotNull)

463+-- in printSQL definition

464+-- :}

465+-- ALTER TABLE "tab" ALTER COLUMN "col" SET NOT NULL;

466+setNotNull

467+ :: AlterColumn schemas (constraint :=> 'Null ty) (constraint :=> 'NotNull ty)

468+setNotNull = UnsafeAlterColumn $ "SET NOT NULL"

469+

470+-- | A `dropNotNull` drops a @NOT NULL@ constraint from a column.

471+--

472+-- >>> :{

473+-- let

474+-- definition :: Definition

475+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

476+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]]

477+-- definition = alterTable #tab (alterColumn #col dropNotNull)

478+-- in printSQL definition

479+-- :}

480+-- ALTER TABLE "tab" ALTER COLUMN "col" DROP NOT NULL;

481+dropNotNull

482+ :: AlterColumn schemas (constraint :=> 'NotNull ty) (constraint :=> 'Null ty)

483+dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"

484+

485+-- | An `alterType` converts a column to a different data type.

486+-- This will succeed only if each existing entry in the column can be

487+-- converted to the new type by an implicit cast.

488+--

489+-- >>> :{

490+-- let

491+-- definition :: Definition

492+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGint4])]]

493+-- '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGnumeric])]]

494+-- definition =

495+-- alterTable #tab (alterColumn #col (alterType (numeric & notNullable)))

496+-- in printSQL definition

497+-- :}

498+-- ALTER TABLE "tab" ALTER COLUMN "col" TYPE numeric NOT NULL;

499+alterType :: ColumnTypeExpression schemas ty -> AlterColumn schemas ty0 ty

500+alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty

squeal-postgresql/src/Squeal/PostgreSQL/Definition/Table/Constraint.hsnew file+339

@@ -0,0 +1,339 @@

1+{-|

2+Module: Squeal.PostgreSQL.Definition.Table.Constraint

3+Description: Table constraint expressions

4+Copyright: (c) Eitan Chatav, 2017

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Table constraint expressions.

9+-}

10+

11+{-# LANGUAGE

12+ AllowAmbiguousTypes

13+ , ConstraintKinds

14+ , DeriveAnyClass

15+ , DeriveGeneric

16+ , DerivingStrategies

17+ , FlexibleContexts

18+ , FlexibleInstances

19+ , GADTs

20+ , LambdaCase

21+ , MultiParamTypeClasses

22+ , OverloadedLabels

23+ , OverloadedStrings

24+ , RankNTypes

25+ , ScopedTypeVariables

26+ , TypeApplications

27+ , TypeInType

28+ , TypeOperators

29+ , UndecidableSuperClasses

30+#-}

31+

32+module Squeal.PostgreSQL.Definition.Table.Constraint

33+ ( TableConstraintExpression (..)

34+ , check

35+ , unique

36+ , primaryKey

37+ , foreignKey

38+ , ForeignKeyed

39+ , OnDeleteClause (..)

40+ , OnUpdateClause (..)

41+ ) where

42+

43+import Control.DeepSeq

44+import Data.ByteString

45+import GHC.TypeLits

46+

47+import qualified Generics.SOP as SOP

48+import qualified GHC.Generics as GHC

49+

50+import Squeal.PostgreSQL.Alias

51+import Squeal.PostgreSQL.Expression.Logic

52+import Squeal.PostgreSQL.List

53+import Squeal.PostgreSQL.Render

54+import Squeal.PostgreSQL.Schema

55+

56+-- $setup

57+-- >>> import Squeal.PostgreSQL

58+

59+-- | Data types are a way to limit the kind of data that can be stored in a

60+-- table. For many applications, however, the constraint they provide is

61+-- too coarse. For example, a column containing a product price should

62+-- probably only accept positive values. But there is no standard data type

63+-- that accepts only positive numbers. Another issue is that you might want

64+-- to constrain column data with respect to other columns or rows.

65+-- For example, in a table containing product information,

66+-- there should be only one row for each product number.

67+-- `TableConstraint`s give you as much control over the data in your tables

68+-- as you wish. If a user attempts to store data in a column that would

69+-- violate a constraint, an error is raised. This applies

70+-- even if the value came from the default value definition.

71+newtype TableConstraintExpression

72+ (sch :: Symbol)

73+ (tab :: Symbol)

74+ (schemas :: SchemasType)

75+ (constraint :: TableConstraint)

76+ = UnsafeTableConstraintExpression

77+ { renderTableConstraintExpression :: ByteString }

78+ deriving (GHC.Generic,Show,Eq,Ord,NFData)

79+instance RenderSQL

80+ (TableConstraintExpression sch tab schemas constraint) where

81+ renderSQL = renderTableConstraintExpression

82+

83+{-| A `check` constraint is the most generic `TableConstraint` type.

84+It allows you to specify that the value in a certain column must satisfy

85+a Boolean (truth-value) expression.

86+

87+>>> :{

88+type Schema = '[

89+ "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[

90+ "a" ::: 'NoDef :=> 'NotNull 'PGint4,

91+ "b" ::: 'NoDef :=> 'NotNull 'PGint4

92+ ])]

93+:}

94+

95+>>> :{

96+let

97+ definition :: Definition (Public '[]) (Public Schema)

98+ definition = createTable #tab

99+ ( (int & notNullable) `as` #a :*

100+ (int & notNullable) `as` #b )

101+ ( check (#a :* #b) (#a .> #b) `as` #inequality )

102+:}

103+

104+>>> printSQL definition

105+CREATE TABLE "tab" ("a" int NOT NULL, "b" int NOT NULL, CONSTRAINT "inequality" CHECK (("a" > "b")));

106+-}

107+check

108+ :: ( Has sch schemas schema

109+ , Has tab schema ('Table table)

110+ , HasAll aliases (TableToRow table) subcolumns )

111+ => NP Alias aliases

112+ -- ^ specify the subcolumns which are getting checked

113+ -> (forall t. Condition '[] '[] 'Ungrouped schemas '[] '[t ::: subcolumns])

114+ -- ^ a closed `Condition` on those subcolumns

115+ -> TableConstraintExpression sch tab schemas ('Check aliases)

116+check _cols condition = UnsafeTableConstraintExpression $

117+ "CHECK" <+> parenthesized (renderSQL condition)

118+

119+{-| A `unique` constraint ensure that the data contained in a column,

120+or a group of columns, is unique among all the rows in the table.

121+

122+>>> :{

123+type Schema = '[

124+ "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[

125+ "a" ::: 'NoDef :=> 'Null 'PGint4,

126+ "b" ::: 'NoDef :=> 'Null 'PGint4

127+ ])]

128+:}

129+

130+>>> :{

131+let

132+ definition :: Definition (Public '[]) (Public Schema)

133+ definition = createTable #tab

134+ ( (int & nullable) `as` #a :*

135+ (int & nullable) `as` #b )

136+ ( unique (#a :* #b) `as` #uq_a_b )

137+:}

138+

139+>>> printSQL definition

140+CREATE TABLE "tab" ("a" int NULL, "b" int NULL, CONSTRAINT "uq_a_b" UNIQUE ("a", "b"));

141+-}

142+unique

143+ :: ( Has sch schemas schema

144+ , Has tab schema('Table table)

145+ , HasAll aliases (TableToRow table) subcolumns )

146+ => NP Alias aliases

147+ -- ^ specify subcolumns which together are unique for each row

148+ -> TableConstraintExpression sch tab schemas ('Unique aliases)

149+unique columns = UnsafeTableConstraintExpression $

150+ "UNIQUE" <+> parenthesized (renderSQL columns)

151+

152+{-| A `primaryKey` constraint indicates that a column, or group of columns,

153+can be used as a unique identifier for rows in the table.

154+This requires that the values be both unique and not null.

155+

156+>>> :{

157+type Schema = '[

158+ "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[

159+ "id" ::: 'Def :=> 'NotNull 'PGint4,

160+ "name" ::: 'NoDef :=> 'NotNull 'PGtext

161+ ])]

162+:}

163+

164+>>> :{

165+let

166+ definition :: Definition (Public '[]) (Public Schema)

167+ definition = createTable #tab

168+ ( serial `as` #id :*

169+ (text & notNullable) `as` #name )

170+ ( primaryKey #id `as` #pk_id )

171+:}

172+

173+>>> printSQL definition

174+CREATE TABLE "tab" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_id" PRIMARY KEY ("id"));

175+-}

176+primaryKey

177+ :: ( Has sch schemas schema

178+ , Has tab schema ('Table table)

179+ , HasAll aliases (TableToColumns table) subcolumns

180+ , AllNotNull subcolumns )

181+ => NP Alias aliases

182+ -- ^ specify the subcolumns which together form a primary key.

183+ -> TableConstraintExpression sch tab schemas ('PrimaryKey aliases)

184+primaryKey columns = UnsafeTableConstraintExpression $

185+ "PRIMARY KEY" <+> parenthesized (renderSQL columns)

186+

187+{-| A `foreignKey` specifies that the values in a column

188+(or a group of columns) must match the values appearing in some row of

189+another table. We say this maintains the referential integrity

190+between two related tables.

191+

192+>>> :{

193+type Schema =

194+ '[ "users" ::: 'Table (

195+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

196+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4

197+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext

198+ ])

199+ , "emails" ::: 'Table (

200+ '[ "pk_emails" ::: 'PrimaryKey '["id"]

201+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]

202+ ] :=>

203+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4

204+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4

205+ , "email" ::: 'NoDef :=> 'Null 'PGtext

206+ ])

207+ ]

208+:}

209+

210+>>> :{

211+let

212+ setup :: Definition (Public '[]) (Public Schema)

213+ setup =

214+ createTable #users

215+ ( serial `as` #id :*

216+ (text & notNullable) `as` #name )

217+ ( primaryKey #id `as` #pk_users ) >>>

218+ createTable #emails

219+ ( serial `as` #id :*

220+ (int & notNullable) `as` #user_id :*

221+ (text & nullable) `as` #email )

222+ ( primaryKey #id `as` #pk_emails :*

223+ foreignKey #user_id #users #id

224+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

225+in printSQL setup

226+:}

227+CREATE TABLE "users" ("id" serial, "name" text NOT NULL, CONSTRAINT "pk_users" PRIMARY KEY ("id"));

228+CREATE TABLE "emails" ("id" serial, "user_id" int NOT NULL, "email" text NULL, CONSTRAINT "pk_emails" PRIMARY KEY ("id"), CONSTRAINT "fk_user_id" FOREIGN KEY ("user_id") REFERENCES "users" ("id") ON DELETE CASCADE ON UPDATE CASCADE);

229+

230+A `foreignKey` can even be a table self-reference.

231+

232+>>> :{

233+type Schema =

234+ '[ "employees" ::: 'Table (

235+ '[ "employees_pk" ::: 'PrimaryKey '["id"]

236+ , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]

237+ ] :=>

238+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4

239+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext

240+ , "employer_id" ::: 'NoDef :=> 'Null 'PGint4

241+ ])

242+ ]

243+:}

244+

245+>>> :{

246+let

247+ setup :: Definition (Public '[]) (Public Schema)

248+ setup =

249+ createTable #employees

250+ ( serial `as` #id :*

251+ (text & notNullable) `as` #name :*

252+ (integer & nullable) `as` #employer_id )

253+ ( primaryKey #id `as` #employees_pk :*

254+ foreignKey #employer_id #employees #id

255+ OnDeleteCascade OnUpdateCascade `as` #employees_employer_fk )

256+in printSQL setup

257+:}

258+CREATE TABLE "employees" ("id" serial, "name" text NOT NULL, "employer_id" integer NULL, CONSTRAINT "employees_pk" PRIMARY KEY ("id"), CONSTRAINT "employees_employer_fk" FOREIGN KEY ("employer_id") REFERENCES "employees" ("id") ON DELETE CASCADE ON UPDATE CASCADE);

259+-}

260+foreignKey

261+ :: (ForeignKeyed schemas sch schema child parent

262+ table reftable

263+ columns refcolumns

264+ constraints cols

265+ reftys tys )

266+ => NP Alias columns

267+ -- ^ column or columns in the table

268+ -> Alias parent

269+ -- ^ reference table

270+ -> NP Alias refcolumns

271+ -- ^ reference column or columns in the reference table

272+ -> OnDeleteClause

273+ -- ^ what to do when reference is deleted

274+ -> OnUpdateClause

275+ -- ^ what to do when reference is updated

276+ -> TableConstraintExpression sch child schemas

277+ ('ForeignKey columns parent refcolumns)

278+foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $

279+ "FOREIGN KEY" <+> parenthesized (renderSQL keys)

280+ <+> "REFERENCES" <+> renderSQL parent

281+ <+> parenthesized (renderSQL refs)

282+ <+> renderSQL ondel

283+ <+> renderSQL onupd

284+

285+-- | A constraint synonym between types involved in a foreign key constraint.

286+type ForeignKeyed schemas

287+ sch

288+ schema

289+ child parent

290+ table reftable

291+ columns refcolumns

292+ constraints cols

293+ reftys tys =

294+ ( Has sch schemas schema

295+ , Has child schema ('Table table)

296+ , Has parent schema ('Table reftable)

297+ , HasAll columns (TableToColumns table) tys

298+ , reftable ~ (constraints :=> cols)

299+ , HasAll refcolumns cols reftys

300+ , SOP.AllZip SamePGType tys reftys

301+ , Uniquely refcolumns constraints )

302+

303+-- | `OnDeleteClause` indicates what to do with rows that reference a deleted row.

304+data OnDeleteClause

305+ = OnDeleteNoAction

306+ -- ^ if any referencing rows still exist when the constraint is checked,

307+ -- an error is raised

308+ | OnDeleteRestrict -- ^ prevents deletion of a referenced row

309+ | OnDeleteCascade

310+ -- ^ specifies that when a referenced row is deleted,

311+ -- row(s) referencing it should be automatically deleted as well

312+ deriving (GHC.Generic,Show,Eq,Ord)

313+instance NFData OnDeleteClause

314+-- | Render `OnDeleteClause`.

315+instance RenderSQL OnDeleteClause where

316+ renderSQL = \case

317+ OnDeleteNoAction -> "ON DELETE NO ACTION"

318+ OnDeleteRestrict -> "ON DELETE RESTRICT"

319+ OnDeleteCascade -> "ON DELETE CASCADE"

320+

321+-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked

322+-- when a referenced column is changed (updated).

323+data OnUpdateClause

324+ = OnUpdateNoAction

325+ -- ^ if any referencing rows has not changed when the constraint is checked,

326+ -- an error is raised

327+ | OnUpdateRestrict -- ^ prevents update of a referenced row

328+ | OnUpdateCascade

329+ -- ^ the updated values of the referenced column(s) should be copied

330+ -- into the referencing row(s)

331+ deriving (GHC.Generic,Show,Eq,Ord)

332+instance NFData OnUpdateClause

333+

334+-- | Render `OnUpdateClause`.

335+instance RenderSQL OnUpdateClause where

336+ renderSQL = \case

337+ OnUpdateNoAction -> "ON UPDATE NO ACTION"

338+ OnUpdateRestrict -> "ON UPDATE RESTRICT"

339+ OnUpdateCascade -> "ON UPDATE CASCADE"

squeal-postgresql/src/Squeal/PostgreSQL/Definition/Type.hsnew file+229

@@ -0,0 +1,229 @@

1+{-|

2+Module: Squeal.PostgreSQL.Definition.Type

3+Description: Create and drop type definitions

4+Copyright: (c) Eitan Chatav, 2017

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Create and drop type definitions.

9+-}

10+

11+{-# LANGUAGE

12+ AllowAmbiguousTypes

13+ , ConstraintKinds

14+ , DeriveAnyClass

15+ , DeriveGeneric

16+ , DerivingStrategies

17+ , FlexibleContexts

18+ , FlexibleInstances

19+ , GADTs

20+ , LambdaCase

21+ , MultiParamTypeClasses

22+ , OverloadedLabels

23+ , OverloadedStrings

24+ , RankNTypes

25+ , ScopedTypeVariables

26+ , TypeApplications

27+ , TypeInType

28+ , TypeOperators

29+ , UndecidableSuperClasses

30+#-}

31+

32+module Squeal.PostgreSQL.Definition.Type

33+ ( createTypeEnum

34+ , createTypeEnumFrom

35+ , createTypeComposite

36+ , createTypeCompositeFrom

37+ , createTypeRange

38+ , createDomain

39+ , dropType

40+ , dropTypeIfExists

41+ ) where

42+

43+import Data.ByteString

44+import Data.Monoid

45+import GHC.TypeLits

46+import Prelude hiding ((.), id)

47+

48+import qualified Generics.SOP as SOP

49+

50+import Squeal.PostgreSQL.Alias

51+import Squeal.PostgreSQL.Expression.Logic

52+import Squeal.PostgreSQL.Expression.Type

53+import Squeal.PostgreSQL.Definition

54+import Squeal.PostgreSQL.List

55+import Squeal.PostgreSQL.PG

56+import Squeal.PostgreSQL.Render

57+import Squeal.PostgreSQL.Schema

58+

59+-- $setup

60+-- >>> import Squeal.PostgreSQL

61+-- >>> import qualified GHC.Generics as GHC

62+-- >>> import qualified Generics.SOP as SOP

63+

64+-- | Enumerated types are created using the `createTypeEnum` command, for example

65+--

66+-- >>> printSQL $ (createTypeEnum #mood (label @"sad" :* label @"ok" :* label @"happy") :: Definition (Public '[]) '["public" ::: '["mood" ::: 'Typedef ('PGenum '["sad","ok","happy"])]])

67+-- CREATE TYPE "mood" AS ENUM ('sad', 'ok', 'happy');

68+createTypeEnum

69+ :: (KnownSymbol enum, Has sch schemas schema, SOP.All KnownSymbol labels)

70+ => QualifiedAlias sch enum

71+ -- ^ name of the user defined enumerated type

72+ -> NP PGlabel labels

73+ -- ^ labels of the enumerated type

74+ -> Definition schemas (Alter sch (Create enum ('Typedef ('PGenum labels)) schema) schemas)

75+createTypeEnum enum labels = UnsafeDefinition $

76+ "CREATE" <+> "TYPE" <+> renderSQL enum <+> "AS" <+> "ENUM" <+>

77+ parenthesized (renderSQL labels) <> ";"

78+

79+-- | Enumerated types can also be generated from a Haskell type, for example

80+--

81+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic

82+-- >>> instance SOP.Generic Schwarma

83+-- >>> instance SOP.HasDatatypeInfo Schwarma

84+-- >>> :{

85+-- let

86+-- createSchwarma :: Definition (Public '[]) '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]]

87+-- createSchwarma = createTypeEnumFrom @Schwarma #schwarma

88+-- in

89+-- printSQL createSchwarma

90+-- :}

91+-- CREATE TYPE "schwarma" AS ENUM ('Beef', 'Lamb', 'Chicken');

92+createTypeEnumFrom

93+ :: forall hask sch enum schemas schema.

94+ ( SOP.Generic hask

95+ , SOP.All KnownSymbol (LabelsPG hask)

96+ , KnownSymbol enum

97+ , Has sch schemas schema )

98+ => QualifiedAlias sch enum

99+ -- ^ name of the user defined enumerated type

100+ -> Definition schemas (Alter sch (Create enum ('Typedef (PG (Enumerated hask))) schema) schemas)

101+createTypeEnumFrom enum = createTypeEnum enum

102+ (SOP.hpure label :: NP PGlabel (LabelsPG hask))

103+

104+{- | `createTypeComposite` creates a composite type. The composite type is

105+specified by a list of attribute names and data types.

106+

107+>>> :{

108+type PGcomplex = 'PGcomposite

109+ '[ "real" ::: 'NotNull 'PGfloat8

110+ , "imaginary" ::: 'NotNull 'PGfloat8 ]

111+:}

112+

113+>>> :{

114+let

115+ setup :: Definition (Public '[]) '["public" ::: '["complex" ::: 'Typedef PGcomplex]]

116+ setup = createTypeComposite #complex

117+ (float8 `as` #real :* float8 `as` #imaginary)

118+in printSQL setup

119+:}

120+CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);

121+-}

122+createTypeComposite

123+ :: (KnownSymbol ty, Has sch schemas schema, SOP.SListI fields)

124+ => QualifiedAlias sch ty

125+ -- ^ name of the user defined composite type

126+ -> NP (Aliased (TypeExpression schemas)) fields

127+ -- ^ list of attribute names and data types

128+ -> Definition schemas (Alter sch (Create ty ('Typedef ('PGcomposite fields)) schema) schemas)

129+createTypeComposite ty fields = UnsafeDefinition $

130+ "CREATE" <+> "TYPE" <+> renderSQL ty <+> "AS" <+> parenthesized

131+ (renderCommaSeparated renderField fields) <> ";"

132+ where

133+ renderField :: Aliased (TypeExpression schemas) x -> ByteString

134+ renderField (typ `As` alias) =

135+ renderSQL alias <+> renderSQL typ

136+

137+-- | Composite types can also be generated from a Haskell type, for example

138+--

139+-- >>> data Complex = Complex {real :: Double, imaginary :: Double} deriving GHC.Generic

140+-- >>> instance SOP.Generic Complex

141+-- >>> instance SOP.HasDatatypeInfo Complex

142+-- >>> type Schema = '["complex" ::: 'Typedef (PG (Composite Complex))]

143+-- >>> :{

144+-- let

145+-- createComplex :: Definition (Public '[]) (Public Schema)

146+-- createComplex = createTypeCompositeFrom @Complex #complex

147+-- in

148+-- printSQL createComplex

149+-- :}

150+-- CREATE TYPE "complex" AS ("real" float8, "imaginary" float8);

151+createTypeCompositeFrom

152+ :: forall hask sch ty schemas schema.

153+ ( SOP.All (FieldTyped schemas) (RowPG hask)

154+ , KnownSymbol ty

155+ , Has sch schemas schema )

156+ => QualifiedAlias sch ty

157+ -- ^ name of the user defined composite type

158+ -> Definition schemas (Alter sch (Create ty ( 'Typedef (PG (Composite hask))) schema) schemas)

159+createTypeCompositeFrom ty = createTypeComposite ty

160+ (SOP.hcpure (SOP.Proxy :: SOP.Proxy (FieldTyped schemas)) fieldtype

161+ :: NP (Aliased (TypeExpression schemas)) (RowPG hask))

162+

163+{-|

164+`createDomain` creates a new domain. A domain is essentially a data type

165+with constraints (restrictions on the allowed set of values).

166+

167+Domains are useful for abstracting common constraints on fields

168+into a single location for maintenance. For example, several tables might

169+contain email address columns, all requiring the same `check` constraint

170+to verify the address syntax. Define a domain rather than setting up

171+each table's constraint individually.

172+

173+>>> :{

174+let

175+ createPositive :: Definition (Public '[]) (Public '["positive" ::: 'Typedef 'PGfloat4])

176+ createPositive = createDomain #positive real (#value .> 0 .&& (#value & isNotNull))

177+in printSQL createPositive

178+:}

179+CREATE DOMAIN "positive" AS real CHECK ((("value" > 0) AND "value" IS NOT NULL));

180+-}

181+createDomain

182+ :: (Has sch schemas schema, KnownSymbol dom)

183+ => QualifiedAlias sch dom

184+ -> (forall null. TypeExpression schemas (null ty))

185+ -> (forall tab. Condition '[] '[] 'Ungrouped schemas '[] '[tab ::: '["value" ::: 'Null ty]])

186+ -> Definition schemas (Alter sch (Create dom ('Typedef ty) schema) schemas)

187+createDomain dom ty condition =

188+ UnsafeDefinition $ "CREATE DOMAIN" <+> renderSQL dom

189+ <+> "AS" <+> renderTypeExpression ty

190+ <+> "CHECK" <+> parenthesized (renderSQL condition) <> ";"

191+

192+{- |

193+>>> :{

194+let

195+ createSmallIntRange :: Definition (Public '[]) (Public '["int2range" ::: 'Typedef ('PGrange 'PGint2)])

196+ createSmallIntRange = createTypeRange #int2range int2

197+in printSQL createSmallIntRange

198+:}

199+CREATE TYPE "int2range" AS RANGE (subtype = int2);

200+-}

201+createTypeRange

202+ :: (Has sch schemas schema, KnownSymbol range)

203+ => QualifiedAlias sch range

204+ -> (forall null. TypeExpression schemas (null ty))

205+ -> Definition schemas (Alter sch (Create range ('Typedef ('PGrange ty)) schema) schemas)

206+createTypeRange range ty = UnsafeDefinition $

207+ "CREATE" <+> "TYPE" <+> renderSQL range <+> "AS" <+> "RANGE" <+>

208+ parenthesized ("subtype" <+> "=" <+> renderTypeExpression ty) <> ";"

209+

210+-- | Drop a type.

211+--

212+-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic

213+-- >>> instance SOP.Generic Schwarma

214+-- >>> instance SOP.HasDatatypeInfo Schwarma

215+-- >>> printSQL (dropType #schwarma :: Definition '["public" ::: '["schwarma" ::: 'Typedef (PG (Enumerated Schwarma))]] (Public '[]))

216+-- DROP TYPE "schwarma";

217+dropType

218+ :: (Has sch schemas schema, KnownSymbol td)

219+ => QualifiedAlias sch td

220+ -- ^ name of the user defined type

221+ -> Definition schemas (Alter sch (DropSchemum td 'Typedef schema) schemas)

222+dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"

223+

224+dropTypeIfExists

225+ :: (Has sch schemas schema, KnownSymbol td)

226+ => QualifiedAlias sch td

227+ -- ^ name of the user defined type

228+ -> Definition schemas (Alter sch (DropSchemumIfExists td 'Typedef schema) schemas)

229+dropTypeIfExists tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderSQL tydef <> ";"

squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hsnew file+104

@@ -0,0 +1,104 @@

1+{-|

2+Module: Squeal.PostgreSQL.Definition.View

3+Description: Create and drop view definitions

4+Copyright: (c) Eitan Chatav, 2017

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Create and drop view definitions.

9+-}

10+

11+{-# LANGUAGE

12+ AllowAmbiguousTypes

13+ , ConstraintKinds

14+ , DeriveAnyClass

15+ , DeriveGeneric

16+ , DerivingStrategies

17+ , FlexibleContexts

18+ , FlexibleInstances

19+ , GADTs

20+ , LambdaCase

21+ , MultiParamTypeClasses

22+ , OverloadedLabels

23+ , OverloadedStrings

24+ , RankNTypes

25+ , ScopedTypeVariables

26+ , TypeApplications

27+ , TypeInType

28+ , TypeOperators

29+ , UndecidableSuperClasses

30+#-}

31+

32+module Squeal.PostgreSQL.Definition.View

33+ ( createView

34+ , createOrReplaceView

35+ , dropView

36+ , dropViewIfExists

37+ ) where

38+

39+import GHC.TypeLits

40+

41+import Squeal.PostgreSQL.Alias

42+import Squeal.PostgreSQL.Definition

43+import Squeal.PostgreSQL.Query

44+import Squeal.PostgreSQL.Render

45+import Squeal.PostgreSQL.Schema

46+

47+-- $setup

48+-- >>> import Squeal.PostgreSQL

49+

50+{- | Create a view.

51+>>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]

52+>>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]

53+>>> :{

54+let

55+ definition :: Definition

56+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]

57+ '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]

58+ definition =

59+ createView #bc (select_ (#b :* #c) (from (table #abc)))

60+in printSQL definition

61+:}

62+CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";

63+-}

64+createView

65+ :: (Has sch schemas schema, KnownSymbol vw)

66+ => QualifiedAlias sch vw -- ^ the name of the view to add

67+ -> Query '[] '[] schemas '[] view -- ^ query

68+ -> Definition schemas (Alter sch (Create vw ('View view) schema) schemas)

69+createView alias query = UnsafeDefinition $

70+ "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"

71+ <+> renderQuery query <> ";"

72+

73+createOrReplaceView

74+ :: (Has sch schemas schema, KnownSymbol vw)

75+ => QualifiedAlias sch vw -- ^ the name of the view to add

76+ -> Query '[] '[] schemas '[] view -- ^ query

77+ -> Definition schemas (Alter sch (CreateOrReplace vw ('View view) schema) schemas)

78+createOrReplaceView alias query = UnsafeDefinition $

79+ "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS"

80+ <+> renderQuery query <> ";"

81+

82+-- | Drop a view.

83+--

84+-- >>> :{

85+-- let

86+-- definition :: Definition

87+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])

88+-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]

89+-- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]

90+-- definition = dropView #bc

91+-- in printSQL definition

92+-- :}

93+-- DROP VIEW "bc";

94+dropView

95+ :: (Has sch schemas schema, KnownSymbol vw)

96+ => QualifiedAlias sch vw -- ^ view to remove

97+ -> Definition schemas (Alter sch (DropSchemum vw 'View schema) schemas)

98+dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"

99+

100+dropViewIfExists

101+ :: (Has sch schemas schema, KnownSymbol vw)

102+ => QualifiedAlias sch vw -- ^ view to remove

103+ -> Definition schemas (Alter sch (DropIfExists vw schema) schemas)

104+dropViewIfExists vw = UnsafeDefinition $ "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";"

squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+352−1113

@@ -1,467 +1,382 @@

11{-|

2−Module: Squeal.PostgreSQL.Query

2+Module: Squeal.PostgreSQL.Expression

33Description: Squeal expressions

4−Copyright: (c) Eitan Chatav, 2017

4+Copyright: (c) Eitan Chatav, 2019

55Maintainer: eitan@morphism.tech

66Stability: experimental

88Squeal expressions are the atoms used to build statements.

99-}

1010

11−{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

1211{-# LANGUAGE

1312 AllowAmbiguousTypes

13+ , ConstraintKinds

1414 , DeriveGeneric

1515 , FlexibleContexts

1616 , FlexibleInstances

1717 , FunctionalDependencies

18+ , GADTs

1819 , GeneralizedNewtypeDeriving

1920 , LambdaCase

2021 , MagicHash

2122 , OverloadedStrings

2223 , ScopedTypeVariables

24+ , StandaloneDeriving

2325 , TypeApplications

2426 , TypeFamilies

2527 , TypeInType

2628 , TypeOperators

2729 , UndecidableInstances

30+ , RankNTypes

2831#-}

2932

3033module Squeal.PostgreSQL.Expression

3134 ( -- * Expression

32− Expression (UnsafeExpression, renderExpression)

33− , HasParameter (parameter)

34− , param

35− -- ** Null

36− , null_

37− , notNull

38− , coalesce

39− , fromNull

40− , isNull

41− , isNotNull

42− , matchNull

43− , nullIf

44− -- ** Collections

45− , array

46− , row

47− -- ** Functions

48− , unsafeBinaryOp

49− , unsafeUnaryOp

35+ Expression (..)

36+ , Expr

37+ , type (-->)

38+ , FunctionDB

5039 , unsafeFunction

51− , atan2_

52− , cast

53− , quot_

54− , rem_

55− , trunc

56− , round_

57− , ceiling_

58− , greatest

59− , least

60− -- ** Conditions

61− , Condition

62− , true

63− , false

64− , not_

65− , (.&&)

66− , (.||)

67− , caseWhenThenElse

68− , ifThenElse

69− , (.==)

70− , (./=)

71− , (.>=)

72− , (.<)

73− , (.<=)

74− , (.>)

75− -- ** Time

76− , currentDate

77− , currentTime

78− , currentTimestamp

79− , localTime

80− , localTimestamp

81− -- ** Text

82− , lower

83− , upper

84− , charLength

85− , like

86− -- ** Aggregation

87− , unsafeAggregate, unsafeAggregateDistinct

88− , sum_, sumDistinct

89− , PGAvg (avg, avgDistinct)

90− , bitAnd, bitOr, boolAnd, boolOr

91− , bitAndDistinct, bitOrDistinct, boolAndDistinct, boolOrDistinct

92− , countStar

93− , count, countDistinct

94− , every, everyDistinct

95− , max_, maxDistinct, min_, minDistinct

96− -- * Types

97− , TypeExpression (UnsafeTypeExpression, renderTypeExpression)

98− , PGTyped (pgtype)

99− , bool

100− , int2

101− , smallint

102− , int4

103− , int

104− , integer

105− , int8

106− , bigint

107− , numeric

108− , float4

109− , real

110− , float8

111− , doublePrecision

112− , text

113− , char

114− , character

115− , varchar

116− , characterVarying

117− , bytea

118− , timestamp

119− , timestampWithTimeZone

120− , date

121− , time

122− , timeWithTimeZone

123− , interval

124− , uuid

125− , inet

126− , json

127− , jsonb

128− , vararray

129− , fixarray

40+ , function

41+ , unsafeLeftOp

42+ , leftOp

43+ , unsafeRightOp

44+ , rightOp

45+ , Operator

46+ , OperatorDB

47+ , unsafeBinaryOp

48+ , binaryOp

49+ , FunctionVar

50+ , unsafeFunctionVar

51+ , type (--->)

52+ , FunctionNDB

53+ , unsafeFunctionN

54+ , functionN

55+ , PGSubset (..)

56+ , PGIntersect (..)

13057 -- * Re-export

13158 , (&)

132− , NP ((:*), Nil)

59+ , K (..)

60+ , unK

13361 ) where

13462

13563import Control.Category

13664import Control.DeepSeq

13765import Data.ByteString (ByteString)

13866import Data.Function ((&))

139−import Data.Semigroup

140−import Data.Ratio

67+import Data.Semigroup hiding (All)

14168import Data.String

142−import Generics.SOP hiding (from)

69+import Generics.SOP hiding (All, from)

14370import GHC.OverloadedLabels

14471import GHC.TypeLits

72+import Numeric

14573import Prelude hiding (id, (.))

14674

14775import qualified GHC.Generics as GHC

14876

77+import Squeal.PostgreSQL.Alias

78+import Squeal.PostgreSQL.List

14979import Squeal.PostgreSQL.Render

15080import Squeal.PostgreSQL.Schema

15181

82+-- $setup

83+-- >>> import Squeal.PostgreSQL

84+

15285{-----------------------------------------

15386column expressions

15487-----------------------------------------}

15588

15689{- | `Expression`s are used in a variety of contexts,

157−such as in the target list of the `Squeal.PostgreSQL.Query.select` command,

90+such as in the target `Squeal.PostgreSQL.Query.List` of the

91+`Squeal.PostgreSQL.Query.select` command,

15892as new column values in `Squeal.PostgreSQL.Manipulation.insertRow` or

15993`Squeal.PostgreSQL.Manipulation.update`,

160−or in search `Condition`s in a number of commands.

94+or in search `Squeal.PostgreSQL.Logic.Condition`s in a number of commands.

16195

16296The expression syntax allows the calculation of

16397values from primitive expression using arithmetic, logical,

16498and other operations.

99+

100+The type parameters of `Expression` are

101+

102+* @outer :: @ `FromType`, the @from@ clauses of any outer queries in which

103+ the `Expression` is a correlated subquery expression;

104+* @commons :: @ `FromType`, the `Squeal.PostgreSQL.Query.CommonTableExpression`s

105+ that are in scope for the `Expression`;

106+* @grp :: @ `Grouping`, the `Grouping` of the @from@ clause which may limit

107+ which columns may be referenced by alias;

108+* @schemas :: @ `SchemasType`, the schemas of your database that are in

109+ scope for the `Expression`;

110+* @from :: @ `FromType`, the @from@ clause which the `Expression` may use

111+ to reference columns by alias;

112+* @ty :: @ `NullityType`, the type of the `Expression`.

165113-}

166114newtype Expression

167− (schema :: SchemaType)

168− (relations :: RelationsType)

169− (grouping :: Grouping)

115+ (outer :: FromType)

116+ (commons :: FromType)

117+ (grp :: Grouping)

118+ (schemas :: SchemasType)

170119 (params :: [NullityType])

120+ (from :: FromType)

171121 (ty :: NullityType)

172122 = UnsafeExpression { renderExpression :: ByteString }

173123 deriving (GHC.Generic,Show,Eq,Ord,NFData)

174−

175−{- | A `HasParameter` constraint is used to indicate a value that is

176−supplied externally to a SQL statement.

177−`Squeal.PostgreSQL.PQ.manipulateParams`,

178−`Squeal.PostgreSQL.PQ.queryParams` and

179−`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values

180−separately from the SQL command string, in which case `param`s are used to

181−refer to the out-of-line data values.

124+instance RenderSQL (Expression outer commons grp schemas params from ty) where

125+ renderSQL = renderExpression

126+

127+-- | An `Expr` is a closed `Expression`.

128+-- It is a F@RankNType@ but don't be scared.

129+-- Think of it as an expression which sees no

130+-- namespaces, so you can't use parameters

131+-- or alias references. It can be used as

132+-- a simple piece of more complex `Expression`s.

133+type Expr x

134+ = forall outer commons grp schemas params from

135+ . Expression outer commons grp schemas params from x

136+ -- ^ cannot reference aliases

137+

138+-- | A @RankNType@ for binary operators.

139+type Operator x1 x2 y

140+ = forall outer commons grp schemas params from

141+ . Expression outer commons grp schemas params from x1

142+ -- ^ left input

143+ -> Expression outer commons grp schemas params from x2

144+ -- ^ right input

145+ -> Expression outer commons grp schemas params from y

146+ -- ^ output

147+

148+type OperatorDB schemas x1 x2 y

149+ = forall outer commons grp params from

150+ . Expression outer commons grp schemas params from x1

151+ -- ^ left input

152+ -> Expression outer commons grp schemas params from x2

153+ -- ^ right input

154+ -> Expression outer commons grp schemas params from y

155+ -- ^ output

156+

157+-- | A @RankNType@ for functions with a single argument.

158+-- These could be either function calls or unary operators.

159+-- This is a subtype of the usual Haskell function type `Prelude.->`,

160+-- indeed a subcategory as it is closed under the usual

161+-- `Prelude..` and `Prelude.id`.

162+type (-->) x y

163+ = forall outer commons grp schemas params from

164+ . Expression outer commons grp schemas params from x

165+ -- ^ input

166+ -> Expression outer commons grp schemas params from y

167+ -- ^ output

168+

169+type FunctionDB schemas x y

170+ = forall outer commons grp params from

171+ . Expression outer commons grp schemas params from x

172+ -- ^ input

173+ -> Expression outer commons grp schemas params from y

174+ -- ^ output

175+

176+{- | A @RankNType@ for functions with a fixed-length list of heterogeneous arguments.

177+Use the `*:` operator to end your argument lists, like so.

178+

179+>>> printSQL (unsafeFunctionN "fun" (true :* false :* localTime *: true))

180+fun(TRUE, FALSE, LOCALTIME, TRUE)

182181-}

183−class KnownNat n => HasParameter

184− (n :: Nat)

185− (schema :: SchemaType)

186− (params :: [NullityType])

187− (ty :: NullityType)

188− | n params -> ty where

189− parameter

190− :: TypeExpression schema (PGTypeOf ty)

191− -> Expression schema relations grouping params ty

192− parameter ty = UnsafeExpression $ parenthesized $

193− "$" <> renderNat (Proxy @n) <+> "::"

194− <+> renderTypeExpression ty

195−instance {-# OVERLAPPING #-} HasParameter 1 schema (ty1:tys) ty1

196−instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) schema params ty)

197− => HasParameter n schema (ty' : params) ty

198−

199−param

200− :: forall n schema params relations grouping ty

201− . (PGTyped schema (PGTypeOf ty), HasParameter n schema params ty)

202− => Expression schema relations grouping params ty

203−param = parameter @n pgtype

204−

205−instance (HasUnique relation relations columns, Has column columns ty)

206− => IsLabel column (Expression schema relations 'Ungrouped params ty) where

207− fromLabel = UnsafeExpression $ renderAlias (Alias @column)

208−instance (HasUnique relation relations columns, Has column columns ty)

209− => IsLabel column

210− (Aliased (Expression schema relations 'Ungrouped params) (column ::: ty)) where

211− fromLabel = fromLabel @column `As` Alias @column

212−instance (HasUnique relation relations columns, Has column columns ty)

213− => IsLabel column

214− (NP (Aliased (Expression schema relations 'Ungrouped params)) '[column ::: ty]) where

215− fromLabel = fromLabel @column :* Nil

216−

217−instance (Has relation relations columns, Has column columns ty)

218− => IsQualified relation column (Expression schema relations 'Ungrouped params ty) where

219− relation ! column = UnsafeExpression $

220− renderAlias relation <> "." <> renderAlias column

221−instance (Has relation relations columns, Has column columns ty)

222− => IsQualified relation column

223− (Aliased (Expression schema relations 'Ungrouped params) (column ::: ty)) where

224− relation ! column = relation ! column `As` column

225−instance (Has relation relations columns, Has column columns ty)

226− => IsQualified relation column

227− (NP (Aliased (Expression schema relations 'Ungrouped params)) '[column ::: ty]) where

228− relation ! column = relation ! column :* Nil

182+type (--->) xs y

183+ = forall outer commons grp schemas params from

184+ . NP (Expression outer commons grp schemas params from) xs

185+ -- ^ inputs

186+ -> Expression outer commons grp schemas params from y

187+ -- ^ output

188+

189+type FunctionNDB schemas xs y

190+ = forall outer commons grp params from

191+ . NP (Expression outer commons grp schemas params from) xs

192+ -- ^ inputs

193+ -> Expression outer commons grp schemas params from y

194+ -- ^ output

195+

196+{- | A @RankNType@ for functions with a variable-length list of

197+homogeneous arguments and at least 1 more argument.

198+-}

199+type FunctionVar x0 x1 y

200+ = forall outer commons grp schemas params from

201+ . [Expression outer commons grp schemas params from x0]

202+ -- ^ inputs

203+ -> Expression outer commons grp schemas params from x1

204+ -- ^ must have at least 1 input

205+ -> Expression outer commons grp schemas params from y

206+ -- ^ output

207+

208+{- | >>> printSQL (unsafeFunctionVar "greatest" [true, null_] false)

209+greatest(TRUE, NULL, FALSE)

210+-}

211+unsafeFunctionVar :: ByteString -> FunctionVar x0 x1 y

212+unsafeFunctionVar fun xs x = UnsafeExpression $ fun <> parenthesized

213+ (commaSeparated (renderSQL <$> xs) <> ", " <> renderSQL x)

214+

215+instance (HasUnique tab (Join outer from) row, Has col row ty)

216+ => IsLabel col (Expression outer commons 'Ungrouped schemas params from ty) where

217+ fromLabel = UnsafeExpression $ renderSQL (Alias @col)

218+instance (HasUnique tab (Join outer from) row, Has col row ty, tys ~ '[ty])

219+ => IsLabel col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where

220+ fromLabel = fromLabel @col :* Nil

221+instance (HasUnique tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))

222+ => IsLabel col

223+ (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where

224+ fromLabel = fromLabel @col `As` Alias

225+instance (HasUnique tab (Join outer from) row, Has col row ty, columns ~ '[col ::: ty])

226+ => IsLabel col

227+ (NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns) where

228+ fromLabel = fromLabel @col :* Nil

229+

230+instance (Has tab (Join outer from) row, Has col row ty)

231+ => IsQualified tab col (Expression outer commons 'Ungrouped schemas params from ty) where

232+ tab ! col = UnsafeExpression $

233+ renderSQL tab <> "." <> renderSQL col

234+instance (Has tab (Join outer from) row, Has col row ty, tys ~ '[ty])

235+ => IsQualified tab col (NP (Expression outer commons 'Ungrouped schemas params from) tys) where

236+ tab ! col = tab ! col :* Nil

237+instance (Has tab (Join outer from) row, Has col row ty, column ~ (col ::: ty))

238+ => IsQualified tab col

239+ (Aliased (Expression outer commons 'Ungrouped schemas params from) column) where

240+ tab ! col = tab ! col `As` col

241+instance (Has tab (Join outer from) row, Has col row ty, columns ~ '[col ::: ty])

242+ => IsQualified tab col

243+ (NP (Aliased (Expression outer commons 'Ungrouped schemas params from)) columns) where

244+ tab ! col = tab ! col :* Nil

229245

230246instance

231− ( HasUnique relation relations columns

232− , Has column columns ty

233− , GroupedBy relation column bys

234− ) => IsLabel column

235− (Expression schema relations ('Grouped bys) params ty) where

236− fromLabel = UnsafeExpression $ renderAlias (Alias @column)

247+ ( HasUnique tab (Join outer from) row

248+ , Has col row ty

249+ , GroupedBy tab col bys

250+ ) => IsLabel col

251+ (Expression outer commons ('Grouped bys) schemas params from ty) where

252+ fromLabel = UnsafeExpression $ renderSQL (Alias @col)

253+instance

254+ ( HasUnique tab (Join outer from) row

255+ , Has col row ty

256+ , GroupedBy tab col bys

257+ , tys ~ '[ty]

258+ ) => IsLabel col

259+ (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where

260+ fromLabel = fromLabel @col :* Nil

237261instance

238− ( HasUnique relation relations columns

239− , Has column columns ty

240− , GroupedBy relation column bys

241− ) => IsLabel column

242− ( Aliased (Expression schema relations ('Grouped bys) params)

243− (column ::: ty) ) where

244− fromLabel = fromLabel @column `As` Alias @column

262+ ( HasUnique tab (Join outer from) row

263+ , Has col row ty

264+ , GroupedBy tab col bys

265+ , column ~ (col ::: ty)

266+ ) => IsLabel col

267+ (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where

268+ fromLabel = fromLabel @col `As` Alias

245269instance

246− ( HasUnique relation relations columns

247− , Has column columns ty

248− , GroupedBy relation column bys

249− ) => IsLabel column

250− ( NP (Aliased (Expression schema relations ('Grouped bys) params))

251− '[column ::: ty] ) where

252− fromLabel = fromLabel @column :* Nil

270+ ( HasUnique tab (Join outer from) row

271+ , Has col row ty

272+ , GroupedBy tab col bys

273+ , columns ~ '[col ::: ty]

274+ ) => IsLabel col

275+ (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where

276+ fromLabel = fromLabel @col :* Nil

253277

254278instance

255− ( Has relation relations columns

256− , Has column columns ty

257− , GroupedBy relation column bys

258− ) => IsQualified relation column

259− (Expression schema relations ('Grouped bys) params ty) where

260− relation ! column = UnsafeExpression $

261− renderAlias relation <> "." <> renderAlias column

279+ ( Has tab (Join outer from) row

280+ , Has col row ty

281+ , GroupedBy tab col bys

282+ ) => IsQualified tab col

283+ (Expression outer commons ('Grouped bys) schemas params from ty) where

284+ tab ! col = UnsafeExpression $

285+ renderSQL tab <> "." <> renderSQL col

262286instance

263− ( Has relation relations columns

264− , Has column columns ty

265− , GroupedBy relation column bys

266− ) => IsQualified relation column

267− (Aliased (Expression schema relations ('Grouped bys) params)

268− (column ::: ty)) where

269− relation ! column = relation ! column `As` column

287+ ( Has tab (Join outer from) row

288+ , Has col row ty

289+ , GroupedBy tab col bys

290+ , tys ~ '[ty]

291+ ) => IsQualified tab col

292+ (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where

293+ tab ! col = tab ! col :* Nil

270294instance

271− ( Has relation relations columns

272− , Has column columns ty

273− , GroupedBy relation column bys

274− ) => IsQualified relation column

275− ( NP (Aliased (Expression schema relations ('Grouped bys) params))

276− '[column ::: ty]) where

277− relation ! column = relation ! column :* Nil

278−

279−-- | analagous to `Nothing`

280−--

281−-- >>> renderExpression $ null_

282−-- "NULL"

283−null_ :: Expression schema rels grouping params ('Null ty)

284−null_ = UnsafeExpression "NULL"

285−

286−-- | analagous to `Just`

287−--

288−-- >>> renderExpression $ notNull true

289−-- "TRUE"

290−notNull

291− :: Expression schema rels grouping params ('NotNull ty)

292− -> Expression schema rels grouping params ('Null ty)

293−notNull = UnsafeExpression . renderExpression

294−

295−-- | return the leftmost value which is not NULL

296−--

297−-- >>> renderExpression $ coalesce [null_, notNull true] false

298−-- "COALESCE(NULL, TRUE, FALSE)"

299−coalesce

300− :: [Expression schema relations grouping params ('Null ty)]

301− -- ^ @NULL@s may be present

302− -> Expression schema relations grouping params ('NotNull ty)

303− -- ^ @NULL@ is absent

304− -> Expression schema relations grouping params ('NotNull ty)

305−coalesce nullxs notNullx = UnsafeExpression $

306− "COALESCE" <> parenthesized (commaSeparated

307− ((renderExpression <$> nullxs) <> [renderExpression notNullx]))

308−

309−-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@

310−--

311−-- >>> renderExpression $ fromNull true null_

312−-- "COALESCE(NULL, TRUE)"

313−fromNull

314− :: Expression schema relations grouping params ('NotNull ty)

315− -- ^ what to convert @NULL@ to

316− -> Expression schema relations grouping params ('Null ty)

317− -> Expression schema relations grouping params ('NotNull ty)

318−fromNull notNullx nullx = coalesce [nullx] notNullx

319−

320−-- | >>> renderExpression $ null_ & isNull

321−-- "NULL IS NULL"

322−isNull

323− :: Expression schema relations grouping params ('Null ty)

324− -- ^ possibly @NULL@

325− -> Condition schema relations grouping params

326−isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL"

327−

328−-- | >>> renderExpression $ null_ & isNotNull

329−-- "NULL IS NOT NULL"

330−isNotNull

331− :: Expression schema relations grouping params ('Null ty)

332− -- ^ possibly @NULL@

333− -> Condition schema relations grouping params

334−isNotNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL"

335−

336−-- | analagous to `maybe` using @IS NULL@

337−--

338−-- >>> renderExpression $ matchNull true not_ null_

339−-- "CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END"

340−matchNull

341− :: Expression schema relations grouping params (nullty)

342− -- ^ what to convert @NULL@ to

343− -> ( Expression schema relations grouping params ('NotNull ty)

344− -> Expression schema relations grouping params (nullty) )

345− -- ^ function to perform when @NULL@ is absent

346− -> Expression schema relations grouping params ('Null ty)

347− -> Expression schema relations grouping params (nullty)

348−matchNull y f x = ifThenElse (isNull x) y

349− (f (UnsafeExpression (renderExpression x)))

350−

351−-- | right inverse to `fromNull`, if its arguments are equal then

352−-- `nullIf` gives @NULL@.

353−--

354−-- >>> :set -XTypeApplications -XDataKinds

355−-- >>> renderExpression @'[] @_ @_ @'[_] $ fromNull false (nullIf false (param @1))

356−-- "COALESCE(NULL IF (FALSE, ($1 :: bool)), FALSE)"

357−nullIf

358− :: Expression schema relations grouping params ('NotNull ty)

359− -- ^ @NULL@ is absent

360− -> Expression schema relations grouping params ('NotNull ty)

361− -- ^ @NULL@ is absent

362− -> Expression schema relations grouping params ('Null ty)

363−nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized

364− (renderExpression x <> ", " <> renderExpression y)

365−

366−-- | >>> renderExpression $ array [null_, notNull false, notNull true]

367−-- "ARRAY[NULL, FALSE, TRUE]"

368−array

369− :: [Expression schema relations grouping params ('Null ty)]

370− -- ^ array elements

371− -> Expression schema relations grouping params (nullity ('PGvararray ty))

372−array xs = UnsafeExpression $

373− "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]"

295+ ( Has tab (Join outer from) row

296+ , Has col row ty

297+ , GroupedBy tab col bys

298+ , column ~ (col ::: ty)

299+ ) => IsQualified tab col

300+ (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where

301+ tab ! col = tab ! col `As` col

302+instance

303+ ( Has tab (Join outer from) row

304+ , Has col row ty

305+ , GroupedBy tab col bys

306+ , columns ~ '[col ::: ty]

307+ ) => IsQualified tab col

308+ (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where

309+ tab ! col = tab ! col :* Nil

374310

375311instance (KnownSymbol label, label `In` labels) => IsPGlabel label

376− (Expression schema relations grouping params (nullity ('PGenum labels))) where

377− label = UnsafeExpression $ renderLabel (PGlabel @label)

378−

379−-- | A row constructor is an expression that builds a row value

380−-- (also called a composite value) using values for its member fields.

381−--

382−-- >>> type Complex = PGcomposite '["real" ::: 'PGfloat8, "imaginary" ::: 'PGfloat8]

383−-- >>> let i = row (0 `As` #real :* 1 `As` #imaginary :* Nil) :: Expression '[] '[] 'Ungrouped '[] ('NotNull Complex)

384−-- >>> renderExpression i

385−-- "ROW(0, 1)"

386−row

387− :: SListI (Nulls fields)

388− => NP (Aliased (Expression schema relations grouping params)) (Nulls fields)

389− -- ^ zero or more expressions for the row field values

390− -> Expression schema relations grouping params (nullity ('PGcomposite fields))

391−row exprs = UnsafeExpression $ "ROW" <> parenthesized

392− (renderCommaSeparated (\ (expr `As` _) -> renderExpression expr) exprs)

393−

394−instance Has field fields ty => IsLabel field

395− ( Expression schema relation grouping params (nullity ('PGcomposite fields))

396− -> Expression schema relation grouping params ('Null ty) ) where

397− fromLabel expr = UnsafeExpression $

398− parenthesized (renderExpression expr) <> "." <>

399− fromString (symbolVal (Proxy @field))

400−

401−instance Semigroup

402− (Expression schema relations grouping params (nullity ('PGvararray ty))) where

403− (<>) = unsafeBinaryOp "||"

312+ (Expression outer commons grp schemas params from (null ('PGenum labels))) where

313+ label = UnsafeExpression $ renderSQL (PGlabel @label)

404314

405−instance Monoid

406− (Expression schema relations grouping params (nullity ('PGvararray ty))) where

407− mempty = array []

408− mappend = (<>)

409−

410−-- | >>> renderExpression @'[] @_ @_ @'[_] $ greatest currentTimestamp [param @1]

411−-- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))"

412−greatest

413− :: Expression schema relations grouping params (nullty)

414− -- ^ needs at least 1 argument

415− -> [Expression schema relations grouping params (nullty)]

416− -- ^ or more

417− -> Expression schema relations grouping params (nullty)

418−greatest x xs = UnsafeExpression $ "GREATEST("

419− <> commaSeparated (renderExpression <$> (x:xs)) <> ")"

420−

421−-- | >>> renderExpression $ least currentTimestamp [null_]

422−-- "LEAST(CURRENT_TIMESTAMP, NULL)"

423−least

424− :: Expression schema relations grouping params (nullty)

425− -- ^ needs at least 1 argument

426− -> [Expression schema relations grouping params (nullty)]

427− -- ^ or more

428− -> Expression schema relations grouping params (nullty)

429−least x xs = UnsafeExpression $ "LEAST("

430− <> commaSeparated (renderExpression <$> (x:xs)) <> ")"

431−

432−-- | >>> renderExpression $ unsafeBinaryOp "OR" true false

433−-- "(TRUE OR FALSE)"

434−unsafeBinaryOp

435− :: ByteString

436− -- ^ operator

437− -> Expression schema relations grouping params (ty0)

438− -> Expression schema relations grouping params (ty1)

439− -> Expression schema relations grouping params (ty2)

315+-- | >>> printSQL $ unsafeBinaryOp "OR" true false

316+-- (TRUE OR FALSE)

317+unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2

440318unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $

441− renderExpression x <+> op <+> renderExpression y

442−

443−-- | >>> renderExpression $ unsafeUnaryOp "NOT" true

444−-- "(NOT TRUE)"

445−unsafeUnaryOp

446− :: ByteString

447− -- ^ operator

448− -> Expression schema relations grouping params (ty0)

449− -> Expression schema relations grouping params (ty1)

450−unsafeUnaryOp op x = UnsafeExpression $ parenthesized $

451− op <+> renderExpression x

452−

453−-- | >>> renderExpression $ unsafeFunction "f" true

454−-- "f(TRUE)"

455−unsafeFunction

456− :: ByteString

457− -- ^ function

458− -> Expression schema relations grouping params (xty)

459− -> Expression schema relations grouping params (yty)

319+ renderSQL x <+> op <+> renderSQL y

320+

321+binaryOp

322+ :: forall op sch schemas schema x y z.

323+ ( Has sch schemas schema

324+ , Has op schema ('Operator ('BinaryOp x y z)) )

325+ => OperatorDB schemas x y z

326+binaryOp = unsafeBinaryOp $ renderSymbol @op

327+

328+-- | >>> printSQL $ unsafeLeftOp "NOT" true

329+-- (NOT TRUE)

330+unsafeLeftOp :: ByteString -> x --> y

331+unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x

332+

333+leftOp

334+ :: forall op sch schemas schema x y.

335+ ( Has sch schemas schema

336+ , Has op schema ('Operator ('LeftOp x y)) )

337+ => FunctionDB schemas x y

338+leftOp = unsafeLeftOp $ renderSymbol @op

339+

340+-- | >>> printSQL $ true & unsafeRightOp "IS NOT TRUE"

341+-- (TRUE IS NOT TRUE)

342+unsafeRightOp :: ByteString -> x --> y

343+unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op

344+

345+rightOp

346+ :: forall op sch schemas schema x y.

347+ ( Has sch schemas schema

348+ , Has op schema ('Operator ('RightOp x y)) )

349+ => FunctionDB schemas x y

350+rightOp = unsafeRightOp $ renderSymbol @op

351+

352+-- | >>> printSQL $ unsafeFunction "f" true

353+-- f(TRUE)

354+unsafeFunction :: ByteString -> x --> y

460355unsafeFunction fun x = UnsafeExpression $

461− fun <> parenthesized (renderExpression x)

462−

463−instance PGNum ty

464− => Num (Expression schema relations grouping params (nullity ty)) where

356+ fun <> parenthesized (renderSQL x)

357+

358+function

359+ :: (Has sch schemas schema, Has fun schema ('Function ('[x] :=> 'Returns y)))

360+ => QualifiedAlias sch fun

361+ -> FunctionDB schemas x y

362+function = unsafeFunction . renderSQL

363+

364+-- | >>> printSQL $ unsafeFunctionN "f" (currentTime :* localTimestamp :* false *: literal 'a')

365+-- f(CURRENT_TIME, LOCALTIMESTAMP, FALSE, E'a')

366+unsafeFunctionN :: SListI xs => ByteString -> xs ---> y

367+unsafeFunctionN fun xs = UnsafeExpression $

368+ fun <> parenthesized (renderCommaSeparated renderSQL xs)

369+

370+functionN

371+ :: ( Has sch schemas schema

372+ , Has fun schema ('Function (xs :=> 'Returns y))

373+ , SListI xs )

374+ => QualifiedAlias sch fun

375+ -> FunctionNDB schemas xs y

376+functionN = unsafeFunctionN . renderSQL

377+

378+instance ty `In` PGNum

379+ => Num (Expression outer commons grp schemas params from (null ty)) where

465380 (+) = unsafeBinaryOp "+"

466381 (-) = unsafeBinaryOp "-"

467382 (*) = unsafeBinaryOp "*"

@@ -472,19 +387,24 @@ instance PGNum ty

472387 . fromString

473388 . show

474389

475−instance (PGNum ty, PGFloating ty) => Fractional

476− (Expression schema relations grouping params (nullity ty)) where

390+instance (ty `In` PGNum, ty `In` PGFloating) => Fractional

391+ (Expression outer commons grp schemas params from (null ty)) where

477392 (/) = unsafeBinaryOp "/"

478− fromRational x = fromInteger (numerator x) / fromInteger (denominator x)

393+ fromRational

394+ = UnsafeExpression

395+ . fromString

396+ . ($ "")

397+ . showFFloat Nothing

398+ . fromRat @Double

479399

480−instance (PGNum ty, PGFloating ty) => Floating

481− (Expression schema relations grouping params (nullity ty)) where

400+instance (ty `In` PGNum, ty `In` PGFloating) => Floating

401+ (Expression outer commons grp schemas params from (null ty)) where

482402 pi = UnsafeExpression "pi()"

483403 exp = unsafeFunction "exp"

484404 log = unsafeFunction "ln"

485405 sqrt = unsafeFunction "sqrt"

486406 b ** x = UnsafeExpression $

487− "power(" <> renderExpression b <> ", " <> renderExpression x <> ")"

407+ "power(" <> renderSQL b <> ", " <> renderSQL x <> ")"

488408 logBase b y = log y / log b

489409 sin = unsafeFunction "sin"

490410 cos = unsafeFunction "cos"

@@ -499,735 +419,54 @@ instance (PGNum ty, PGFloating ty) => Floating

499419 acosh x = log (x + sqrt (x*x - 1))

500420 atanh x = log ((1 + x) / (1 - x)) / 2

501421

502−-- | >>> :{

503−-- let

504−-- expression :: Expression schema relations grouping params (nullity 'PGfloat4)

505−-- expression = atan2_ pi 2

506−-- in renderExpression expression

507−-- :}

508−-- "atan2(pi(), 2)"

509−atan2_

510− :: PGFloating float

511− => Expression schema relations grouping params (nullity float)

512− -- ^ numerator

513− -> Expression schema relations grouping params (nullity float)

514− -- ^ denominator

515− -> Expression schema relations grouping params (nullity float)

516−atan2_ y x = UnsafeExpression $

517− "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"

518−

519−-- When a `cast` is applied to an `Expression` of a known type, it

520−-- represents a run-time type conversion. The cast will succeed only if a

521−-- suitable type conversion operation has been defined.

522−--

523−-- | >>> renderExpression $ true & cast int4

524−-- "(TRUE :: int4)"

525−cast

526− :: TypeExpression schema ty1

527− -- ^ type to cast as

528− -> Expression schema relations grouping params (nullity ty0)

529− -- ^ value to convert

530− -> Expression schema relations grouping params (nullity ty1)

531−cast ty x = UnsafeExpression $ parenthesized $

532− renderExpression x <+> "::" <+> renderTypeExpression ty

533−

534−-- | integer division, truncates the result

535−--

536−-- >>> :{

537−-- let

538−-- expression :: Expression schema relations grouping params (nullity 'PGint2)

539−-- expression = 5 `quot_` 2

540−-- in renderExpression expression

541−-- :}

542−-- "(5 / 2)"

543−quot_

544− :: PGIntegral int

545− => Expression schema relations grouping params (nullity int)

546− -- ^ numerator

547− -> Expression schema relations grouping params (nullity int)

548− -- ^ denominator

549− -> Expression schema relations grouping params (nullity int)

550−quot_ = unsafeBinaryOp "/"

551−

552−-- | remainder upon integer division

553−--

554−-- >>> :{

555−-- let

556−-- expression :: Expression schema relations grouping params (nullity 'PGint2)

557−-- expression = 5 `rem_` 2

558−-- in renderExpression expression

559−-- :}

560−-- "(5 % 2)"

561−rem_

562− :: PGIntegral int

563− => Expression schema relations grouping params (nullity int)

564− -- ^ numerator

565− -> Expression schema relations grouping params (nullity int)

566− -- ^ denominator

567− -> Expression schema relations grouping params (nullity int)

568−rem_ = unsafeBinaryOp "%"

569−

570−-- | >>> :{

571−-- let

572−-- expression :: Expression schema relations grouping params (nullity 'PGfloat4)

573−-- expression = trunc pi

574−-- in renderExpression expression

575−-- :}

576−-- "trunc(pi())"

577−trunc

578− :: PGFloating frac

579− => Expression schema relations grouping params (nullity frac)

580− -- ^ fractional number

581− -> Expression schema relations grouping params (nullity frac)

582−trunc = unsafeFunction "trunc"

583−

584−-- | >>> :{

585−-- let

586−-- expression :: Expression schema relations grouping params (nullity 'PGfloat4)

587−-- expression = round_ pi

588−-- in renderExpression expression

589−-- :}

590−-- "round(pi())"

591−round_

592− :: PGFloating frac

593− => Expression schema relations grouping params (nullity frac)

594− -- ^ fractional number

595− -> Expression schema relations grouping params (nullity frac)

596−round_ = unsafeFunction "round"

597−

598−-- | >>> :{

599−-- let

600−-- expression :: Expression schema relations grouping params (nullity 'PGfloat4)

601−-- expression = ceiling_ pi

602−-- in renderExpression expression

603−-- :}

604−-- "ceiling(pi())"

605−ceiling_

606− :: PGFloating frac

607− => Expression schema relations grouping params (nullity frac)

608− -- ^ fractional number

609− -> Expression schema relations grouping params (nullity frac)

610−ceiling_ = unsafeFunction "ceiling"

611−

612−-- | A `Condition` is a boolean valued `Expression`. While SQL allows

613−-- conditions to have @NULL@, Squeal instead chooses to disallow @NULL@,

614−-- forcing one to handle the case of @NULL@ explicitly to produce

615−-- a `Condition`.

616−type Condition schema relations grouping params =

617− Expression schema relations grouping params ('NotNull 'PGbool)

618−

619−-- | >>> renderExpression true

620−-- "TRUE"

621−true :: Condition schema relations grouping params

622−true = UnsafeExpression "TRUE"

623−

624−-- | >>> renderExpression false

625−-- "FALSE"

626−false :: Condition schema relations grouping params

627−false = UnsafeExpression "FALSE"

628−

629−-- | >>> renderExpression $ not_ true

630−-- "(NOT TRUE)"

631−not_

632− :: Condition schema relations grouping params

633− -> Condition schema relations grouping params

634−not_ = unsafeUnaryOp "NOT"

635−

636−-- | >>> renderExpression $ true .&& false

637−-- "(TRUE AND FALSE)"

638−(.&&)

639− :: Condition schema relations grouping params

640− -> Condition schema relations grouping params

641− -> Condition schema relations grouping params

642−(.&&) = unsafeBinaryOp "AND"

643−

644−-- | >>> renderExpression $ true .|| false

645−-- "(TRUE OR FALSE)"

646−(.||)

647− :: Condition schema relations grouping params

648− -> Condition schema relations grouping params

649− -> Condition schema relations grouping params

650−(.||) = unsafeBinaryOp "OR"

651−

652−-- | >>> :{

653−-- let

654−-- expression :: Expression schema relations grouping params (nullity 'PGint2)

655−-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3

656−-- in renderExpression expression

657−-- :}

658−-- "CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END"

659−caseWhenThenElse

660− :: [ ( Condition schema relations grouping params

661− , Expression schema relations grouping params (ty)

662− ) ]

663− -- ^ whens and thens

664− -> Expression schema relations grouping params (ty)

665− -- ^ else

666− -> Expression schema relations grouping params (ty)

667−caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat

668− [ "CASE"

669− , mconcat

670− [ mconcat

671− [ " WHEN ", renderExpression when_

672− , " THEN ", renderExpression then_

673− ]

674− | (when_,then_) <- whenThens

675− ]

676− , " ELSE ", renderExpression else_

677− , " END"

678− ]

679−

680−-- | >>> :{

681−-- let

682−-- expression :: Expression schema relations grouping params (nullity 'PGint2)

683−-- expression = ifThenElse true 1 0

684−-- in renderExpression expression

685−-- :}

686−-- "CASE WHEN TRUE THEN 1 ELSE 0 END"

687−ifThenElse

688− :: Condition schema relations grouping params

689− -> Expression schema relations grouping params (ty) -- ^ then

690− -> Expression schema relations grouping params (ty) -- ^ else

691− -> Expression schema relations grouping params (ty)

692−ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_

693−

694−-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`

695−-- will produce @NULL@s if one of their arguments is @NULL@.

696−--

697−-- >>> renderExpression $ notNull true .== null_

698−-- "(TRUE = NULL)"

699−(.==)

700− :: Expression schema relations grouping params (nullity ty) -- ^ lhs

701− -> Expression schema relations grouping params (nullity ty) -- ^ rhs

702− -> Expression schema relations grouping params (nullity 'PGbool)

703−(.==) = unsafeBinaryOp "="

704−infix 4 .==

705−

706−-- | >>> renderExpression $ notNull true ./= null_

707−-- "(TRUE <> NULL)"

708−(./=)

709− :: Expression schema relations grouping params (nullity ty) -- ^ lhs

710− -> Expression schema relations grouping params (nullity ty) -- ^ rhs

711− -> Expression schema relations grouping params (nullity 'PGbool)

712−(./=) = unsafeBinaryOp "<>"

713−infix 4 ./=

714−

715−-- | >>> renderExpression $ notNull true .>= null_

716−-- "(TRUE >= NULL)"

717−(.>=)

718− :: Expression schema relations grouping params (nullity ty) -- ^ lhs

719− -> Expression schema relations grouping params (nullity ty) -- ^ rhs

720− -> Expression schema relations grouping params (nullity 'PGbool)

721−(.>=) = unsafeBinaryOp ">="

722−infix 4 .>=

723−

724−-- | >>> renderExpression $ notNull true .< null_

725−-- "(TRUE < NULL)"

726−(.<)

727− :: Expression schema relations grouping params (nullity ty) -- ^ lhs

728− -> Expression schema relations grouping params (nullity ty) -- ^ rhs

729− -> Expression schema relations grouping params (nullity 'PGbool)

730−(.<) = unsafeBinaryOp "<"

731−infix 4 .<

732−

733−-- | >>> renderExpression $ notNull true .<= null_

734−-- "(TRUE <= NULL)"

735−(.<=)

736− :: Expression schema relations grouping params (nullity ty) -- ^ lhs

737− -> Expression schema relations grouping params (nullity ty) -- ^ rhs

738− -> Expression schema relations grouping params (nullity 'PGbool)

739−(.<=) = unsafeBinaryOp "<="

740−infix 4 .<=

741−

742−-- | >>> renderExpression $ notNull true .> null_

743−-- "(TRUE > NULL)"

744−(.>)

745− :: Expression schema relations grouping params (nullity ty) -- ^ lhs

746− -> Expression schema relations grouping params (nullity ty) -- ^ rhs

747− -> Expression schema relations grouping params (nullity 'PGbool)

748−(.>) = unsafeBinaryOp ">"

749−infix 4 .>

750−

751−-- | >>> renderExpression currentDate

752−-- "CURRENT_DATE"

753−currentDate

754− :: Expression schema relations grouping params (nullity 'PGdate)

755−currentDate = UnsafeExpression "CURRENT_DATE"

756−

757−-- | >>> renderExpression currentTime

758−-- "CURRENT_TIME"

759−currentTime

760− :: Expression schema relations grouping params (nullity 'PGtimetz)

761−currentTime = UnsafeExpression "CURRENT_TIME"

762−

763−-- | >>> renderExpression currentTimestamp

764−-- "CURRENT_TIMESTAMP"

765−currentTimestamp

766− :: Expression schema relations grouping params (nullity 'PGtimestamptz)

767−currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"

768−

769−-- | >>> renderExpression localTime

770−-- "LOCALTIME"

771−localTime

772− :: Expression schema relations grouping params (nullity 'PGtime)

773−localTime = UnsafeExpression "LOCALTIME"

774−

775−-- | >>> renderExpression localTimestamp

776−-- "LOCALTIMESTAMP"

777−localTimestamp

778− :: Expression schema relations grouping params (nullity 'PGtimestamp)

779−localTimestamp = UnsafeExpression "LOCALTIMESTAMP"

780−

781−{-----------------------------------------

782−text

783−-----------------------------------------}

422+-- | Contained by operators

423+class PGSubset ty where

424+ (@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

425+ (@>) = unsafeBinaryOp "@>"

426+ (<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

427+ (<@) = unsafeBinaryOp "<@"

428+instance PGSubset 'PGjsonb

429+instance PGSubset 'PGtsquery

430+instance PGSubset ('PGvararray ty)

431+instance PGSubset ('PGrange ty)

432+

433+class PGIntersect ty where

434+ (@&&) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

435+ (@&&) = unsafeBinaryOp "&&"

436+instance PGIntersect ('PGvararray ty)

437+instance PGIntersect ('PGrange ty)

784438

785439instance IsString

786− (Expression schema relations grouping params (nullity 'PGtext)) where

440+ (Expression outer commons grp schemas params from (null 'PGtext)) where

787441 fromString str = UnsafeExpression $

788442 "E\'" <> fromString (escape =<< str) <> "\'"

789− where

790− escape = \case

791− '\NUL' -> "\\0"

792− '\'' -> "''"

793− '"' -> "\\\""

794− '\b' -> "\\b"

795− '\n' -> "\\n"

796− '\r' -> "\\r"

797− '\t' -> "\\t"

798− '\\' -> "\\\\"

799− c -> [c]

443+instance IsString

444+ (Expression outer commons grp schemas params from (null 'PGtsvector)) where

445+ fromString str = UnsafeExpression . parenthesized . (<> " :: tsvector") $

446+ "E\'" <> fromString (escape =<< str) <> "\'"

447+instance IsString

448+ (Expression outer commons grp schemas params from (null 'PGtsquery)) where

449+ fromString str = UnsafeExpression . parenthesized . (<> " :: tsquery") $

450+ "E\'" <> fromString (escape =<< str) <> "\'"

800451

801452instance Semigroup

802− (Expression schema relations grouping params (nullity 'PGtext)) where

453+ (Expression outer commons grp schemas params from (null ('PGvararray ty))) where

454+ (<>) = unsafeBinaryOp "||"

455+instance Semigroup

456+ (Expression outer commons grp schemas params from (null 'PGjsonb)) where

457+ (<>) = unsafeBinaryOp "||"

458+instance Semigroup

459+ (Expression outer commons grp schemas params from (null 'PGtext)) where

460+ (<>) = unsafeBinaryOp "||"

461+instance Semigroup

462+ (Expression outer commons grp schemas params from (null 'PGtsvector)) where

803463 (<>) = unsafeBinaryOp "||"

804464

805465instance Monoid

806− (Expression schema relations grouping params (nullity 'PGtext)) where

466+ (Expression outer commons grp schemas params from (null 'PGtext)) where

467+ mempty = fromString ""

468+ mappend = (<>)

469+instance Monoid

470+ (Expression outer commons grp schemas params from (null 'PGtsvector)) where

807471 mempty = fromString ""

808472 mappend = (<>)

809−

810−-- | >>> renderExpression $ lower "ARRRGGG"

811−-- "lower(E'ARRRGGG')"

812−lower

813− :: Expression schema relations grouping params (nullity 'PGtext)

814− -- ^ string to lower case

815− -> Expression schema relations grouping params (nullity 'PGtext)

816−lower = unsafeFunction "lower"

817−

818−-- | >>> renderExpression $ upper "eeee"

819−-- "upper(E'eeee')"

820−upper

821− :: Expression schema relations grouping params (nullity 'PGtext)

822− -- ^ string to upper case

823− -> Expression schema relations grouping params (nullity 'PGtext)

824−upper = unsafeFunction "upper"

825−

826−-- | >>> renderExpression $ charLength "four"

827−-- "char_length(E'four')"

828−charLength

829− :: Expression schema relations grouping params (nullity 'PGtext)

830− -- ^ string to measure

831− -> Expression schema relations grouping params (nullity 'PGint4)

832−charLength = unsafeFunction "char_length"

833−

834−-- | The `like` expression returns true if the @string@ matches

835−-- the supplied @pattern@. If @pattern@ does not contain percent signs

836−-- or underscores, then the pattern only represents the string itself;

837−-- in that case `like` acts like the equals operator. An underscore (_)

838−-- in pattern stands for (matches) any single character; a percent sign (%)

839−-- matches any sequence of zero or more characters.

840−--

841−-- >>> renderExpression $ "abc" `like` "a%"

842−-- "(E'abc' LIKE E'a%')"

843−like

844− :: Expression schema relations grouping params (nullity 'PGtext)

845− -- ^ string

846− -> Expression schema relations grouping params (nullity 'PGtext)

847− -- ^ pattern

848− -> Expression schema relations grouping params (nullity 'PGbool)

849−like = unsafeBinaryOp "LIKE"

850−

851−{-----------------------------------------

852−aggregation

853−-----------------------------------------}

854−

855−-- | escape hatch to define aggregate functions

856−unsafeAggregate

857− :: ByteString -- ^ aggregate function

858− -> Expression schema relations 'Ungrouped params (xty)

859− -> Expression schema relations ('Grouped bys) params (yty)

860−unsafeAggregate fun x = UnsafeExpression $ mconcat

861− [fun, "(", renderExpression x, ")"]

862−

863−-- | escape hatch to define aggregate functions over distinct values

864−unsafeAggregateDistinct

865− :: ByteString -- ^ aggregate function

866− -> Expression schema relations 'Ungrouped params (xty)

867− -> Expression schema relations ('Grouped bys) params (yty)

868−unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat

869− [fun, "(DISTINCT ", renderExpression x, ")"]

870−

871−-- | >>> :{

872−-- let

873−-- expression :: Expression schema '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric)

874−-- expression = sum_ #col

875−-- in renderExpression expression

876−-- :}

877−-- "sum(\"col\")"

878−sum_

879− :: PGNum ty

880− => Expression schema relations 'Ungrouped params (nullity ty)

881− -- ^ what to sum

882− -> Expression schema relations ('Grouped bys) params (nullity ty)

883−sum_ = unsafeAggregate "sum"

884−

885−-- | >>> :{

886−-- let

887−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric)

888−-- expression = sumDistinct #col

889−-- in renderExpression expression

890−-- :}

891−-- "sum(DISTINCT \"col\")"

892−sumDistinct

893− :: PGNum ty

894− => Expression schema relations 'Ungrouped params (nullity ty)

895− -- ^ what to sum

896− -> Expression schema relations ('Grouped bys) params (nullity ty)

897−sumDistinct = unsafeAggregateDistinct "sum"

898−

899−-- | A constraint for `PGType`s that you can take averages of and the resulting

900−-- `PGType`.

901−class PGAvg ty avg | ty -> avg where

902− avg, avgDistinct

903− :: Expression schema relations 'Ungrouped params (nullity ty)

904− -- ^ what to average

905− -> Expression schema relations ('Grouped bys) params (nullity avg)

906− avg = unsafeAggregate "avg"

907− avgDistinct = unsafeAggregateDistinct "avg"

908−instance PGAvg 'PGint2 'PGnumeric

909−instance PGAvg 'PGint4 'PGnumeric

910−instance PGAvg 'PGint8 'PGnumeric

911−instance PGAvg 'PGnumeric 'PGnumeric

912−instance PGAvg 'PGfloat4 'PGfloat8

913−instance PGAvg 'PGfloat8 'PGfloat8

914−instance PGAvg 'PGinterval 'PGinterval

915−

916−-- | >>> :{

917−-- let

918−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

919−-- expression = bitAnd #col

920−-- in renderExpression expression

921−-- :}

922−-- "bit_and(\"col\")"

923−bitAnd

924− :: PGIntegral int

925− => Expression schema relations 'Ungrouped params (nullity int)

926− -- ^ what to aggregate

927− -> Expression schema relations ('Grouped bys) params (nullity int)

928−bitAnd = unsafeAggregate "bit_and"

929−

930−-- | >>> :{

931−-- let

932−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

933−-- expression = bitOr #col

934−-- in renderExpression expression

935−-- :}

936−-- "bit_or(\"col\")"

937−bitOr

938− :: PGIntegral int

939− => Expression schema relations 'Ungrouped params (nullity int)

940− -- ^ what to aggregate

941− -> Expression schema relations ('Grouped bys) params (nullity int)

942−bitOr = unsafeAggregate "bit_or"

943−

944−-- | >>> :{

945−-- let

946−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

947−-- expression = bitAndDistinct #col

948−-- in renderExpression expression

949−-- :}

950−-- "bit_and(DISTINCT \"col\")"

951−bitAndDistinct

952− :: PGIntegral int

953− => Expression schema relations 'Ungrouped params (nullity int)

954− -- ^ what to aggregate

955− -> Expression schema relations ('Grouped bys) params (nullity int)

956−bitAndDistinct = unsafeAggregateDistinct "bit_and"

957−

958−-- | >>> :{

959−-- let

960−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

961−-- expression = bitOrDistinct #col

962−-- in renderExpression expression

963−-- :}

964−-- "bit_or(DISTINCT \"col\")"

965−bitOrDistinct

966− :: PGIntegral int

967− => Expression schema relations 'Ungrouped params (nullity int)

968− -- ^ what to aggregate

969− -> Expression schema relations ('Grouped bys) params (nullity int)

970−bitOrDistinct = unsafeAggregateDistinct "bit_or"

971−

972−-- | >>> :{

973−-- let

974−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

975−-- expression = boolAnd #col

976−-- in renderExpression expression

977−-- :}

978−-- "bool_and(\"col\")"

979−boolAnd

980− :: Expression schema relations 'Ungrouped params (nullity 'PGbool)

981− -- ^ what to aggregate

982− -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)

983−boolAnd = unsafeAggregate "bool_and"

984−

985−-- | >>> :{

986−-- let

987−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

988−-- expression = boolOr #col

989−-- in renderExpression expression

990−-- :}

991−-- "bool_or(\"col\")"

992−boolOr

993− :: Expression schema relations 'Ungrouped params (nullity 'PGbool)

994− -- ^ what to aggregate

995− -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)

996−boolOr = unsafeAggregate "bool_or"

997−

998−-- | >>> :{

999−-- let

1000−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

1001−-- expression = boolAndDistinct #col

1002−-- in renderExpression expression

1003−-- :}

1004−-- "bool_and(DISTINCT \"col\")"

1005−boolAndDistinct

1006− :: Expression schema relations 'Ungrouped params (nullity 'PGbool)

1007− -- ^ what to aggregate

1008− -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)

1009−boolAndDistinct = unsafeAggregateDistinct "bool_and"

1010−

1011−-- | >>> :{

1012−-- let

1013−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

1014−-- expression = boolOrDistinct #col

1015−-- in renderExpression expression

1016−-- :}

1017−-- "bool_or(DISTINCT \"col\")"

1018−boolOrDistinct

1019− :: Expression schema relations 'Ungrouped params (nullity 'PGbool)

1020− -- ^ what to aggregate

1021− -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)

1022−boolOrDistinct = unsafeAggregateDistinct "bool_or"

1023−

1024−-- | A special aggregation that does not require an input

1025−--

1026−-- >>> renderExpression countStar

1027−-- "count(*)"

1028−countStar

1029− :: Expression schema relations ('Grouped bys) params ('NotNull 'PGint8)

1030−countStar = UnsafeExpression $ "count(*)"

1031−

1032−-- | >>> :{

1033−-- let

1034−-- expression :: Expression schema '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)

1035−-- expression = count #col

1036−-- in renderExpression expression

1037−-- :}

1038−-- "count(\"col\")"

1039−count

1040− :: Expression schema relations 'Ungrouped params ty

1041− -- ^ what to count

1042− -> Expression schema relations ('Grouped bys) params ('NotNull 'PGint8)

1043−count = unsafeAggregate "count"

1044−

1045−-- | >>> :{

1046−-- let

1047−-- expression :: Expression schema '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)

1048−-- expression = countDistinct #col

1049−-- in renderExpression expression

1050−-- :}

1051−-- "count(DISTINCT \"col\")"

1052−countDistinct

1053− :: Expression schema relations 'Ungrouped params ty

1054− -- ^ what to count

1055− -> Expression schema relations ('Grouped bys) params ('NotNull 'PGint8)

1056−countDistinct = unsafeAggregateDistinct "count"

1057−

1058−-- | synonym for `boolAnd`

1059−--

1060−-- >>> :{

1061−-- let

1062−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

1063−-- expression = every #col

1064−-- in renderExpression expression

1065−-- :}

1066−-- "every(\"col\")"

1067−every

1068− :: Expression schema relations 'Ungrouped params (nullity 'PGbool)

1069− -- ^ what to aggregate

1070− -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)

1071−every = unsafeAggregate "every"

1072−

1073−-- | synonym for `boolAndDistinct`

1074−--

1075−-- >>> :{

1076−-- let

1077−-- expression :: Expression schema '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

1078−-- expression = everyDistinct #col

1079−-- in renderExpression expression

1080−-- :}

1081−-- "every(DISTINCT \"col\")"

1082−everyDistinct

1083− :: Expression schema relations 'Ungrouped params (nullity 'PGbool)

1084− -- ^ what to aggregate

1085− -> Expression schema relations ('Grouped bys) params (nullity 'PGbool)

1086−everyDistinct = unsafeAggregateDistinct "every"

1087−

1088−-- | minimum and maximum aggregation

1089−max_, min_, maxDistinct, minDistinct

1090− :: Expression schema relations 'Ungrouped params (nullity ty)

1091− -- ^ what to aggregate

1092− -> Expression schema relations ('Grouped bys) params (nullity ty)

1093−max_ = unsafeAggregate "max"

1094−min_ = unsafeAggregate "min"

1095−maxDistinct = unsafeAggregateDistinct "max"

1096−minDistinct = unsafeAggregateDistinct "min"

1097−

1098−{-----------------------------------------

1099−type expressions

1100−-----------------------------------------}

1101−

1102−-- | `TypeExpression`s are used in `cast`s and `createTable` commands.

1103−newtype TypeExpression (schema :: SchemaType) (ty :: PGType)

1104− = UnsafeTypeExpression { renderTypeExpression :: ByteString }

1105− deriving (GHC.Generic,Show,Eq,Ord,NFData)

1106−

1107−instance (Has alias schema ('Typedef ty))

1108− => IsLabel alias (TypeExpression schema ty) where

1109− fromLabel = UnsafeTypeExpression (renderAlias (fromLabel @alias))

1110−

1111−-- | logical Boolean (true/false)

1112−bool :: TypeExpression schema 'PGbool

1113−bool = UnsafeTypeExpression "bool"

1114−-- | signed two-byte integer

1115−int2, smallint :: TypeExpression schema 'PGint2

1116−int2 = UnsafeTypeExpression "int2"

1117−smallint = UnsafeTypeExpression "smallint"

1118−-- | signed four-byte integer

1119−int4, int, integer :: TypeExpression schema 'PGint4

1120−int4 = UnsafeTypeExpression "int4"

1121−int = UnsafeTypeExpression "int"

1122−integer = UnsafeTypeExpression "integer"

1123−-- | signed eight-byte integer

1124−int8, bigint :: TypeExpression schema 'PGint8

1125−int8 = UnsafeTypeExpression "int8"

1126−bigint = UnsafeTypeExpression "bigint"

1127−-- | arbitrary precision numeric type

1128−numeric :: TypeExpression schema 'PGnumeric

1129−numeric = UnsafeTypeExpression "numeric"

1130−-- | single precision floating-point number (4 bytes)

1131−float4, real :: TypeExpression schema 'PGfloat4

1132−float4 = UnsafeTypeExpression "float4"

1133−real = UnsafeTypeExpression "real"

1134−-- | double precision floating-point number (8 bytes)

1135−float8, doublePrecision :: TypeExpression schema 'PGfloat8

1136−float8 = UnsafeTypeExpression "float8"

1137−doublePrecision = UnsafeTypeExpression "double precision"

1138−-- | variable-length character string

1139−text :: TypeExpression schema 'PGtext

1140−text = UnsafeTypeExpression "text"

1141−-- | fixed-length character string

1142−char, character

1143− :: (KnownNat n, 1 <= n)

1144− => proxy n

1145− -> TypeExpression schema ('PGchar n)

1146−char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"

1147−character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"

1148−-- | variable-length character string

1149−varchar, characterVarying

1150− :: (KnownNat n, 1 <= n)

1151− => proxy n

1152− -> TypeExpression schema ('PGvarchar n)

1153−varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"

1154−characterVarying p = UnsafeTypeExpression $

1155− "character varying(" <> renderNat p <> ")"

1156−-- | binary data ("byte array")

1157−bytea :: TypeExpression schema 'PGbytea

1158−bytea = UnsafeTypeExpression "bytea"

1159−-- | date and time (no time zone)

1160−timestamp :: TypeExpression schema 'PGtimestamp

1161−timestamp = UnsafeTypeExpression "timestamp"

1162−-- | date and time, including time zone

1163−timestampWithTimeZone :: TypeExpression schema 'PGtimestamptz

1164−timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

1165−-- | calendar date (year, month, day)

1166−date :: TypeExpression schema 'PGdate

1167−date = UnsafeTypeExpression "date"

1168−-- | time of day (no time zone)

1169−time :: TypeExpression schema 'PGtime

1170−time = UnsafeTypeExpression "time"

1171−-- | time of day, including time zone

1172−timeWithTimeZone :: TypeExpression schema 'PGtimetz

1173−timeWithTimeZone = UnsafeTypeExpression "time with time zone"

1174−-- | time span

1175−interval :: TypeExpression schema 'PGinterval

1176−interval = UnsafeTypeExpression "interval"

1177−-- | universally unique identifier

1178−uuid :: TypeExpression schema 'PGuuid

1179−uuid = UnsafeTypeExpression "uuid"

1180−-- | IPv4 or IPv6 host address

1181−inet :: TypeExpression schema 'PGinet

1182−inet = UnsafeTypeExpression "inet"

1183−-- | textual JSON data

1184−json :: TypeExpression schema 'PGjson

1185−json = UnsafeTypeExpression "json"

1186−-- | binary JSON data, decomposed

1187−jsonb :: TypeExpression schema 'PGjsonb

1188−jsonb = UnsafeTypeExpression "jsonb"

1189−-- | variable length array

1190−vararray

1191− :: TypeExpression schema pg

1192− -> TypeExpression schema ('PGvararray pg)

1193−vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"

1194−-- | fixed length array

1195−--

1196−-- >>> renderTypeExpression (fixarray (Proxy @2) json)

1197−-- "json[2]"

1198−fixarray

1199− :: KnownNat n

1200− => proxy n

1201− -> TypeExpression schema pg

1202− -> TypeExpression schema ('PGfixarray n pg)

1203−fixarray p ty = UnsafeTypeExpression $

1204− renderTypeExpression ty <> "[" <> renderNat p <> "]"

1205−

1206−-- | `pgtype` is a demoted version of a `PGType`

1207−class PGTyped schema (ty :: PGType) where pgtype :: TypeExpression schema ty

1208−instance PGTyped schema 'PGbool where pgtype = bool

1209−instance PGTyped schema 'PGint2 where pgtype = int2

1210−instance PGTyped schema 'PGint4 where pgtype = int4

1211−instance PGTyped schema 'PGint8 where pgtype = int8

1212−instance PGTyped schema 'PGnumeric where pgtype = numeric

1213−instance PGTyped schema 'PGfloat4 where pgtype = float4

1214−instance PGTyped schema 'PGfloat8 where pgtype = float8

1215−instance PGTyped schema 'PGtext where pgtype = text

1216−instance (KnownNat n, 1 <= n)

1217− => PGTyped schema ('PGchar n) where pgtype = char (Proxy @n)

1218−instance (KnownNat n, 1 <= n)

1219− => PGTyped schema ('PGvarchar n) where pgtype = varchar (Proxy @n)

1220−instance PGTyped schema 'PGbytea where pgtype = bytea

1221−instance PGTyped schema 'PGtimestamp where pgtype = timestamp

1222−instance PGTyped schema 'PGtimestamptz where pgtype = timestampWithTimeZone

1223−instance PGTyped schema 'PGdate where pgtype = date

1224−instance PGTyped schema 'PGtime where pgtype = time

1225−instance PGTyped schema 'PGtimetz where pgtype = timeWithTimeZone

1226−instance PGTyped schema 'PGinterval where pgtype = interval

1227−instance PGTyped schema 'PGuuid where pgtype = uuid

1228−instance PGTyped schema 'PGjson where pgtype = json

1229−instance PGTyped schema 'PGjsonb where pgtype = jsonb

1230−instance PGTyped schema ty => PGTyped schema ('PGvararray ty) where

1231− pgtype = vararray (pgtype @schema @ty)

1232−instance (KnownNat n, PGTyped schema ty) => PGTyped schema ('PGfixarray n ty) where

1233− pgtype = fixarray (Proxy @n) (pgtype @schema @ty)

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Aggregate.hsnew file+462

@@ -0,0 +1,462 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Aggregate

3+Description: Aggregate functions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Aggregate functions

9+-}

10+

11+{-# LANGUAGE

12+ DataKinds

13+ , DeriveGeneric

14+ , FlexibleContexts

15+ , FlexibleInstances

16+ , FunctionalDependencies

17+ , LambdaCase

18+ , MultiParamTypeClasses

19+ , OverloadedStrings

20+ , PolyKinds

21+ , TypeFamilies

22+ , TypeOperators

23+ , UndecidableInstances

24+#-}

25+

26+module Squeal.PostgreSQL.Expression.Aggregate

27+ ( Aggregate (..)

28+ , Distinction (..)

29+ , PGSum

30+ , PGAvg

31+ ) where

32+

33+import Control.DeepSeq

34+import Data.ByteString (ByteString)

35+import Data.Kind

36+import GHC.TypeLits

37+

38+import qualified GHC.Generics as GHC

39+import qualified Generics.SOP as SOP

40+

41+import Squeal.PostgreSQL.Alias

42+import Squeal.PostgreSQL.Expression

43+import Squeal.PostgreSQL.List

44+import Squeal.PostgreSQL.Render

45+import Squeal.PostgreSQL.Schema

46+

47+-- $setup

48+-- >>> import Squeal.PostgreSQL

49+

50+{- |

51+`Aggregate` functions compute a single result from a set of input values.

52+`Aggregate` functions can be used as `GroupedBy` `Expression`s as well

53+as `Squeal.PostgreSQL.Expression.Window.WindowFunction`s.

54+-}

55+class Aggregate expr1 exprN aggr

56+ | aggr -> expr1, aggr -> exprN where

57+

58+ -- | A special aggregation that does not require an input

59+ --

60+ -- >>> :{

61+ -- let

62+ -- expression :: Expression '[] commons ('Grouped bys) schemas params from ('NotNull 'PGint8)

63+ -- expression = countStar

64+ -- in printSQL expression

65+ -- :}

66+ -- count(*)

67+ countStar :: aggr ('NotNull 'PGint8)

68+

69+ -- | >>> :{

70+ -- let

71+ -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null ty]] ('NotNull 'PGint8)

72+ -- expression = count (All #col)

73+ -- in printSQL expression

74+ -- :}

75+ -- count(ALL "col")

76+ count

77+ :: expr1 ty

78+ -- ^ what to count

79+ -> aggr ('NotNull 'PGint8)

80+

81+ -- | >>> :{

82+ -- let

83+ -- expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Null 'PGnumeric)

84+ -- expression = sum_ (Distinct #col)

85+ -- in printSQL expression

86+ -- :}

87+ -- sum(DISTINCT "col")

88+ sum_

89+ :: expr1 (null ty)

90+ -> aggr ('Null (PGSum ty))

91+

92+ -- | input values, including nulls, concatenated into an array

93+ arrayAgg

94+ :: expr1 ty

95+ -> aggr ('Null ('PGvararray ty))

96+

97+ -- | aggregates values as a JSON array

98+ jsonAgg

99+ :: expr1 ty

100+ -> aggr ('Null 'PGjson)

101+

102+ -- | aggregates values as a JSON array

103+ jsonbAgg

104+ :: expr1 ty

105+ -> aggr ('Null 'PGjsonb)

106+

107+ {- |

108+ the bitwise AND of all non-null input values, or null if none

109+

110+ >>> :{

111+ let

112+ expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)

113+ expression = bitAnd (Distinct #col)

114+ in printSQL expression

115+ :}

116+ bit_and(DISTINCT "col")

117+ -}

118+ bitAnd

119+ :: int `In` PGIntegral

120+ => expr1 (null int)

121+ -- ^ what to aggregate

122+ -> aggr ('Null int)

123+

124+ {- |

125+ the bitwise OR of all non-null input values, or null if none

126+

127+ >>> :{

128+ let

129+ expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGint4]] ('Null 'PGint4)

130+ expression = bitOr (All #col)

131+ in printSQL expression

132+ :}

133+ bit_or(ALL "col")

134+ -}

135+ bitOr

136+ :: int `In` PGIntegral

137+ => expr1 (null int)

138+ -- ^ what to aggregate

139+ -> aggr ('Null int)

140+

141+ {- |

142+ true if all input values are true, otherwise false

143+

144+ >>> :{

145+ let

146+ winFun :: WindowFunction '[] commons 'Ungrouped schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)

147+ winFun = boolAnd #col

148+ in printSQL winFun

149+ :}

150+ bool_and("col")

151+ -}

152+ boolAnd

153+ :: expr1 (null 'PGbool)

154+ -- ^ what to aggregate

155+ -> aggr ('Null 'PGbool)

156+

157+ {- |

158+ true if at least one input value is true, otherwise false

159+

160+ >>> :{

161+ let

162+ expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)

163+ expression = boolOr (All #col)

164+ in printSQL expression

165+ :}

166+ bool_or(ALL "col")

167+ -}

168+ boolOr

169+ :: expr1 (null 'PGbool)

170+ -- ^ what to aggregate

171+ -> aggr ('Null 'PGbool)

172+

173+ {- |

174+ equivalent to `boolAnd`

175+

176+ >>> :{

177+ let

178+ expression :: Expression '[] commons ('Grouped bys) schemas params '[tab ::: '["col" ::: null 'PGbool]] ('Null 'PGbool)

179+ expression = every (Distinct #col)

180+ in printSQL expression

181+ :}

182+ every(DISTINCT "col")

183+ -}

184+ every

185+ :: expr1 (null 'PGbool)

186+ -- ^ what to aggregate

187+ -> aggr ('Null 'PGbool)

188+

189+ {- |maximum value of expression across all input values-}

190+ max_

191+ :: expr1 (null ty)

192+ -- ^ what to maximize

193+ -> aggr ('Null ty)

194+

195+ -- | minimum value of expression across all input values

196+ min_

197+ :: expr1 (null ty)

198+ -- ^ what to minimize

199+ -> aggr ('Null ty)

200+

201+ -- | the average (arithmetic mean) of all input values

202+ avg

203+ :: expr1 (null ty)

204+ -- ^ what to average

205+ -> aggr ('Null (PGAvg ty))

206+

207+ {- | correlation coefficient

208+

209+ >>> :{

210+ let

211+ expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)

212+ expression = corr (All (#y *: #x))

213+ in printSQL expression

214+ :}

215+ corr(ALL "y", "x")

216+ -}

217+ corr

218+ :: exprN '[null 'PGfloat8, null 'PGfloat8]

219+ -> aggr ('Null 'PGfloat8)

220+

221+ {- | population covariance

222+

223+ >>> :{

224+ let

225+ expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)

226+ expression = covarPop (All (#y *: #x))

227+ in printSQL expression

228+ :}

229+ covar_pop(ALL "y", "x")

230+ -}

231+ covarPop

232+ :: exprN '[null 'PGfloat8, null 'PGfloat8]

233+ -> aggr ('Null 'PGfloat8)

234+

235+ {- | sample covariance

236+

237+ >>> :{

238+ let

239+ winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)

240+ winFun = covarSamp (#y *: #x)

241+ in printSQL winFun

242+ :}

243+ covar_samp("y", "x")

244+ -}

245+ covarSamp

246+ :: exprN '[null 'PGfloat8, null 'PGfloat8]

247+ -> aggr ('Null 'PGfloat8)

248+

249+ {- | average of the independent variable (sum(X)/N)

250+

251+ >>> :{

252+ let

253+ expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)

254+ expression = regrAvgX (All (#y *: #x))

255+ in printSQL expression

256+ :}

257+ regr_avgx(ALL "y", "x")

258+ -}

259+ regrAvgX

260+ :: exprN '[null 'PGfloat8, null 'PGfloat8]

261+ -> aggr ('Null 'PGfloat8)

262+

263+ {- | average of the dependent variable (sum(Y)/N)

264+

265+ >>> :{

266+ let

267+ winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)

268+ winFun = regrAvgY (#y *: #x)

269+ in printSQL winFun

270+ :}

271+ regr_avgy("y", "x")

272+ -}

273+ regrAvgY

274+ :: exprN '[null 'PGfloat8, null 'PGfloat8]

275+ -> aggr ('Null 'PGfloat8)

276+

277+ {- | number of input rows in which both expressions are nonnull

278+

279+ >>> :{

280+ let

281+ winFun :: WindowFunction '[] c 'Ungrouped s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGint8)

282+ winFun = regrCount (#y *: #x)

283+ in printSQL winFun

284+ :}

285+ regr_count("y", "x")

286+ -}

287+ regrCount

288+ :: exprN '[null 'PGfloat8, null 'PGfloat8]

289+ -> aggr ('Null 'PGint8)

290+

291+ {- | y-intercept of the least-squares-fit linear equation determined by the (X, Y) pairs

292+ >>> :{

293+ let

294+ expression :: Expression '[] c ('Grouped g) s p '[t ::: '["x" ::: 'NotNull 'PGfloat8, "y" ::: 'NotNull 'PGfloat8]] ('Null 'PGfloat8)

295+ expression = regrIntercept (All (#y *: #x))

296+ in printSQL expression

297+ :}

298+ regr_intercept(ALL "y", "x")

299+ -}

300+ regrIntercept

301+ :: exprN '[null 'PGfloat8, null 'PGfloat8]

302+ -> aggr ('Null 'PGfloat8)

303+

304+ -- | @regr_r2(Y, X)@, square of the correlation coefficient

305+ regrR2

306+ :: exprN '[null 'PGfloat8, null 'PGfloat8]

307+ -> aggr ('Null 'PGfloat8)

308+

309+ -- | @regr_slope(Y, X)@, slope of the least-squares-fit linear equation

310+ -- determined by the (X, Y) pairs

311+ regrSlope

312+ :: exprN '[null 'PGfloat8, null 'PGfloat8]

313+ -> aggr ('Null 'PGfloat8)

314+

315+ -- | @regr_sxx(Y, X)@, sum(X^2) - sum(X)^2/N

316+ -- (“sum of squares” of the independent variable)

317+ regrSxx

318+ :: exprN '[null 'PGfloat8, null 'PGfloat8]

319+ -> aggr ('Null 'PGfloat8)

320+

321+ -- | @regr_sxy(Y, X)@, sum(X*Y) - sum(X) * sum(Y)/N

322+ -- (“sum of products” of independent times dependent variable)

323+ regrSxy

324+ :: exprN '[null 'PGfloat8, null 'PGfloat8]

325+ -> aggr ('Null 'PGfloat8)

326+

327+ -- | @regr_syy(Y, X)@, sum(Y^2) - sum(Y)^2/N

328+ -- (“sum of squares” of the dependent variable)

329+ regrSyy

330+ :: exprN '[null 'PGfloat8, null 'PGfloat8]

331+ -> aggr ('Null 'PGfloat8)

332+

333+ -- | historical alias for `stddevSamp`

334+ stddev

335+ :: expr1 (null ty)

336+ -> aggr ('Null (PGAvg ty))

337+

338+ -- | population standard deviation of the input values

339+ stddevPop

340+ :: expr1 (null ty)

341+ -> aggr ('Null (PGAvg ty))

342+

343+ -- | sample standard deviation of the input values

344+ stddevSamp

345+ :: expr1 (null ty)

346+ -> aggr ('Null (PGAvg ty))

347+

348+ -- | historical alias for `varSamp`

349+ variance

350+ :: expr1 (null ty)

351+ -> aggr ('Null (PGAvg ty))

352+

353+ -- | population variance of the input values

354+ -- (square of the population standard deviation)

355+ varPop

356+ :: expr1 (null ty)

357+ -> aggr ('Null (PGAvg ty))

358+

359+ -- | sample variance of the input values

360+ -- (square of the sample standard deviation)

361+ varSamp

362+ :: expr1 (null ty)

363+ -> aggr ('Null (PGAvg ty))

364+

365+{- |

366+`Distinction`s are used for the input of `Aggregate` `Expression`s.

367+`All` invokes the aggregate once for each input row.

368+`Distinct` invokes the aggregate once for each distinct value of the expression

369+(or distinct set of values, for multiple expressions) found in the input

370+-}

371+data Distinction (expr :: kind -> Type) (ty :: kind)

372+ = All (expr ty)

373+ | Distinct (expr ty)

374+ deriving (GHC.Generic,Show,Eq,Ord)

375+instance NFData (Distinction (Expression outer commons grp schemas params from) ty)

376+instance RenderSQL (Distinction (Expression outer commons grp schemas params from) ty) where

377+ renderSQL = \case

378+ All x -> "ALL" <+> renderSQL x

379+ Distinct x -> "DISTINCT" <+> renderSQL x

380+instance SOP.SListI tys => RenderSQL

381+ (Distinction (NP (Expression outer commons grp schemas params from)) tys) where

382+ renderSQL = \case

383+ All xs -> "ALL" <+> renderCommaSeparated renderSQL xs

384+ Distinct xs -> "DISTINCT" <+> renderCommaSeparated renderSQL xs

385+

386+instance Aggregate

387+ (Distinction (Expression outer commons 'Ungrouped schemas params from))

388+ (Distinction (NP (Expression outer commons 'Ungrouped schemas params from)))

389+ (Expression outer commons ('Grouped bys) schemas params from) where

390+ countStar = UnsafeExpression "count(*)"

391+ count = unsafeAggregate1 "count"

392+ sum_ = unsafeAggregate1 "sum"

393+ arrayAgg = unsafeAggregate1 "array_agg"

394+ jsonAgg = unsafeAggregate1 "json_agg"

395+ jsonbAgg = unsafeAggregate1 "jsonb_agg"

396+ bitAnd = unsafeAggregate1 "bit_and"

397+ bitOr = unsafeAggregate1 "bit_or"

398+ boolAnd = unsafeAggregate1 "bool_and"

399+ boolOr = unsafeAggregate1 "bool_or"

400+ every = unsafeAggregate1 "every"

401+ max_ = unsafeAggregate1 "max"

402+ min_ = unsafeAggregate1 "min"

403+ avg = unsafeAggregate1 "avg"

404+ corr = unsafeAggregateN "corr"

405+ covarPop = unsafeAggregateN "covar_pop"

406+ covarSamp = unsafeAggregateN "covar_samp"

407+ regrAvgX = unsafeAggregateN "regr_avgx"

408+ regrAvgY = unsafeAggregateN "regr_avgy"

409+ regrCount = unsafeAggregateN "regr_count"

410+ regrIntercept = unsafeAggregateN "regr_intercept"

411+ regrR2 = unsafeAggregateN "regr_r2"

412+ regrSlope = unsafeAggregateN "regr_slope"

413+ regrSxx = unsafeAggregateN "regr_sxx"

414+ regrSxy = unsafeAggregateN "regr_sxy"

415+ regrSyy = unsafeAggregateN "regr_syy"

416+ stddev = unsafeAggregate1 "stddev"

417+ stddevPop = unsafeAggregate1 "stddev_pop"

418+ stddevSamp = unsafeAggregate1 "stddev_samp"

419+ variance = unsafeAggregate1 "variance"

420+ varPop = unsafeAggregate1 "var_pop"

421+ varSamp = unsafeAggregate1 "var_samp"

422+

423+-- | escape hatch to define aggregate functions

424+unsafeAggregate1

425+ :: ByteString -- ^ aggregate function

426+ -> Distinction (Expression outer commons 'Ungrouped schemas params from) x

427+ -> Expression outer commons ('Grouped bys) schemas params from y

428+unsafeAggregate1 fun x = UnsafeExpression $ fun <> parenthesized (renderSQL x)

429+

430+unsafeAggregateN

431+ :: SOP.SListI xs

432+ => ByteString -- ^ function

433+ -> Distinction (NP (Expression outer commons 'Ungrouped schemas params from)) xs

434+ -> Expression outer commons ('Grouped bys) schemas params from y

435+unsafeAggregateN fun xs = UnsafeExpression $ fun <> parenthesized (renderSQL xs)

436+

437+-- | A type family that calculates `PGSum``PGType` of

438+-- a given argument `PGType`.

439+type family PGSum ty where

440+ PGSum 'PGint2 = 'PGint8

441+ PGSum 'PGint4 = 'PGint8

442+ PGSum 'PGint8 = 'PGnumeric

443+ PGSum 'PGfloat4 = 'PGfloat4

444+ PGSum 'PGfloat8 = 'PGfloat8

445+ PGSum 'PGnumeric = 'PGnumeric

446+ PGSum 'PGinterval = 'PGinterval

447+ PGSum 'PGmoney = 'PGmoney

448+ PGSum pg = TypeError

449+ ( 'Text "Squeal type error: Cannot sum with argument type "

450+ ':<>: 'ShowType pg )

451+

452+-- | A type family that calculates `PGAvg` type of a `PGType`.

453+type family PGAvg ty where

454+ PGAvg 'PGint2 = 'PGnumeric

455+ PGAvg 'PGint4 = 'PGnumeric

456+ PGAvg 'PGint8 = 'PGnumeric

457+ PGAvg 'PGnumeric = 'PGnumeric

458+ PGAvg 'PGfloat4 = 'PGfloat8

459+ PGAvg 'PGfloat8 = 'PGfloat8

460+ PGAvg 'PGinterval = 'PGinterval

461+ PGAvg pg = TypeError

462+ ('Text "Squeal type error: No average for " ':<>: 'ShowType pg)

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Collection.hsnew file+169

@@ -0,0 +1,169 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Collection

3+Description: Array and composite functions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Array and composite functions

9+-}

10+

11+{-# LANGUAGE

12+ AllowAmbiguousTypes

13+ , DataKinds

14+ , FlexibleContexts

15+ , FlexibleInstances

16+ , MultiParamTypeClasses

17+ , OverloadedLabels

18+ , OverloadedStrings

19+ , RankNTypes

20+ , ScopedTypeVariables

21+ , TypeApplications

22+ , TypeFamilies

23+ , TypeOperators

24+ , UndecidableInstances

25+#-}

26+

27+module Squeal.PostgreSQL.Expression.Collection

28+ ( array

29+ , array1

30+ , array2

31+ , cardinality

32+ , index

33+ , unnest

34+ , row

35+ , field

36+ ) where

37+

38+import Data.String

39+import Data.Word (Word64)

40+

41+import qualified Generics.SOP as SOP

42+

43+import Squeal.PostgreSQL.Alias

44+import Squeal.PostgreSQL.Expression

45+import Squeal.PostgreSQL.Expression.Set

46+import Squeal.PostgreSQL.List

47+import Squeal.PostgreSQL.Render

48+import Squeal.PostgreSQL.Schema

49+

50+-- $setup

51+-- >>> import Squeal.PostgreSQL

52+

53+-- | >>> printSQL $ array [null_, false, true]

54+-- ARRAY[NULL, FALSE, TRUE]

55+array

56+ :: [Expression outer commons grp schemas params from ty]

57+ -- ^ array elements

58+ -> Expression outer commons grp schemas params from (null ('PGvararray ty))

59+array xs = UnsafeExpression $ "ARRAY" <>

60+ bracketed (commaSeparated (renderSQL <$> xs))

61+

62+{- | construct a 1-dimensional fixed length array

63+

64+>>> printSQL $ array1 (null_ :* false *: true)

65+ARRAY[NULL, FALSE, TRUE]

66+

67+>>> :type array1 (null_ :* false *: true)

68+array1 (null_ :* false *: true)

69+ :: Expression

70+ outer

71+ commons

72+ grp

73+ schemas

74+ params

75+ from

76+ (null ('PGfixarray '[3] ('Null 'PGbool)))

77+-}

78+array1

79+ :: (n ~ Length tys, SOP.All ((~) ty) tys)

80+ => NP (Expression outer commons grp schemas params from) tys

81+ -> Expression outer commons grp schemas params from (null ('PGfixarray '[n] ty))

82+array1 xs = UnsafeExpression $ "ARRAY" <>

83+ bracketed (renderCommaSeparated renderSQL xs)

84+

85+{- | construct a 2-dimensional fixed length array

86+

87+>>> printSQL $ array2 ((null_ :* false *: true) *: (false :* null_ *: true))

88+ARRAY[[NULL, FALSE, TRUE], [FALSE, NULL, TRUE]]

89+

90+>>> :type array2 ((null_ :* false *: true) *: (false :* null_ *: true))

91+array2 ((null_ :* false *: true) *: (false :* null_ *: true))

92+ :: Expression

93+ outer

94+ commons

95+ grp

96+ schemas

97+ params

98+ from

99+ (null ('PGfixarray '[2, 3] ('Null 'PGbool)))

100+-}

101+array2

102+ :: ( SOP.All ((~) tys) tyss

103+ , SOP.All SOP.SListI tyss

104+ , Length tyss ~ n1

105+ , SOP.All ((~) ty) tys

106+ , Length tys ~ n2 )

107+ => NP (NP (Expression outer commons grp schemas params from)) tyss

108+ -> Expression outer commons grp schemas params from (null ('PGfixarray '[n1,n2] ty))

109+array2 xss = UnsafeExpression $ "ARRAY" <>

110+ bracketed (renderCommaSeparatedConstraint @SOP.SListI (bracketed . renderCommaSeparated renderSQL) xss)

111+

112+-- | >>> printSQL $ cardinality (array [null_, false, true])

113+-- cardinality(ARRAY[NULL, FALSE, TRUE])

114+cardinality :: null ('PGvararray ty) --> null 'PGint8

115+cardinality = unsafeFunction "cardinality"

116+

117+-- | >>> printSQL $ array [null_, false, true] & index 2

118+-- (ARRAY[NULL, FALSE, TRUE])[2]

119+index

120+ :: Word64 -- ^ index

121+ -> null ('PGvararray ty) --> NullifyType ty

122+index n expr = UnsafeExpression $

123+ parenthesized (renderSQL expr) <> "[" <> fromString (show n) <> "]"

124+

125+-- | Expand an array to a set of rows

126+unnest :: SetFunction "unnest" (null ('PGvararray ty)) '["unnest" ::: ty]

127+unnest = unsafeSetFunction

128+

129+-- | A row constructor is an expression that builds a row value

130+-- (also called a composite value) using values for its member fields.

131+--

132+-- >>> :{

133+-- type Complex = 'PGcomposite

134+-- '[ "real" ::: 'NotNull 'PGfloat8

135+-- , "imaginary" ::: 'NotNull 'PGfloat8 ]

136+-- :}

137+--

138+-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer commons grp schemas params from ('NotNull Complex)

139+-- >>> printSQL i

140+-- ROW(0, 1)

141+row

142+ :: SOP.SListI row

143+ => NP (Aliased (Expression outer commons grp schemas params from)) row

144+ -- ^ zero or more expressions for the row field values

145+ -> Expression outer commons grp schemas params from (null ('PGcomposite row))

146+row exprs = UnsafeExpression $ "ROW" <> parenthesized

147+ (renderCommaSeparated (\ (expr `As` _) -> renderSQL expr) exprs)

148+

149+-- | >>> :{

150+-- type Complex = 'PGcomposite

151+-- '[ "real" ::: 'NotNull 'PGfloat8

152+-- , "imaginary" ::: 'NotNull 'PGfloat8 ]

153+-- type Schema = '["complex" ::: 'Typedef Complex]

154+-- :}

155+--

156+-- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression outer '[] grp (Public Schema) from params ('NotNull Complex)

157+-- >>> printSQL $ i & field #complex #imaginary

158+-- (ROW(0, 1)::"complex")."imaginary"

159+field

160+ :: ( Has sch schemas schema

161+ , Has tydef schema ('Typedef ('PGcomposite row))

162+ , Has field row ty)

163+ => QualifiedAlias sch tydef -- ^ row type

164+ -> Alias field -- ^ field name

165+ -> Expression outer commons grp schemas params from ('NotNull ('PGcomposite row))

166+ -> Expression outer commons grp schemas params from ty

167+field td fld expr = UnsafeExpression $

168+ parenthesized (renderSQL expr <> "::" <> renderSQL td)

169+ <> "." <> renderSQL fld

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hsnew file+206

@@ -0,0 +1,206 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Comparison

3+Description: Comparison expressions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Comparison functions and operators

9+-}

10+

11+{-# LANGUAGE

12+ OverloadedStrings

13+ , RankNTypes

14+ , TypeInType

15+ , TypeOperators

16+#-}

17+

18+module Squeal.PostgreSQL.Expression.Comparison

19+ ( (.==)

20+ , (./=)

21+ , (.>=)

22+ , (.<)

23+ , (.<=)

24+ , (.>)

25+ , greatest

26+ , least

27+ , BetweenExpr

28+ , between

29+ , notBetween

30+ , betweenSymmetric

31+ , notBetweenSymmetric

32+ , isDistinctFrom

33+ , isNotDistinctFrom

34+ , isTrue

35+ , isNotTrue

36+ , isFalse

37+ , isNotFalse

38+ , isUnknown

39+ , isNotUnknown

40+ ) where

41+

42+import Data.ByteString

43+

44+import Squeal.PostgreSQL.Expression

45+import Squeal.PostgreSQL.Expression.Logic

46+import Squeal.PostgreSQL.Render

47+import Squeal.PostgreSQL.Schema

48+

49+-- $setup

50+-- >>> import Squeal.PostgreSQL

51+

52+-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`

53+-- will produce @NULL@s if one of their arguments is @NULL@.

54+--

55+-- >>> printSQL $ true .== null_

56+-- (TRUE = NULL)

57+(.==) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

58+(.==) = unsafeBinaryOp "="

59+infix 4 .==

60+

61+-- | >>> printSQL $ true ./= null_

62+-- (TRUE <> NULL)

63+(./=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

64+(./=) = unsafeBinaryOp "<>"

65+infix 4 ./=

66+

67+-- | >>> printSQL $ true .>= null_

68+-- (TRUE >= NULL)

69+(.>=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

70+(.>=) = unsafeBinaryOp ">="

71+infix 4 .>=

72+

73+-- | >>> printSQL $ true .< null_

74+-- (TRUE < NULL)

75+(.<) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

76+(.<) = unsafeBinaryOp "<"

77+infix 4 .<

78+

79+-- | >>> printSQL $ true .<= null_

80+-- (TRUE <= NULL)

81+(.<=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

82+(.<=) = unsafeBinaryOp "<="

83+infix 4 .<=

84+

85+-- | >>> printSQL $ true .> null_

86+-- (TRUE > NULL)

87+(.>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

88+(.>) = unsafeBinaryOp ">"

89+infix 4 .>

90+

91+-- | >>> let expr = greatest [param @1] currentTimestamp :: Expression outer commons grp schemas '[ 'NotNull 'PGtimestamptz] from ('NotNull 'PGtimestamptz)

92+-- >>> printSQL expr

93+-- GREATEST(($1 :: timestamp with time zone), CURRENT_TIMESTAMP)

94+greatest :: FunctionVar ty ty ty

95+greatest = unsafeFunctionVar "GREATEST"

96+

97+-- | >>> printSQL $ least [null_] currentTimestamp

98+-- LEAST(NULL, CURRENT_TIMESTAMP)

99+least :: FunctionVar ty ty ty

100+least = unsafeFunctionVar "LEAST"

101+

102+{- |

103+A @RankNType@ for comparison expressions like `between`.

104+-}

105+type BetweenExpr

106+ = forall outer commons grp schemas params from ty

107+ . Expression outer commons grp schemas params from ty

108+ -> ( Expression outer commons grp schemas params from ty

109+ , Expression outer commons grp schemas params from ty ) -- ^ bounds

110+ -> Condition outer commons grp schemas params from

111+

112+unsafeBetweenExpr :: ByteString -> BetweenExpr

113+unsafeBetweenExpr fun a (x,y) = UnsafeExpression $

114+ renderSQL a <+> fun <+> renderSQL x <+> "AND" <+> renderSQL y

115+

116+{- | >>> printSQL $ true `between` (null_, false)

117+TRUE BETWEEN NULL AND FALSE

118+-}

119+between :: BetweenExpr

120+between = unsafeBetweenExpr "BETWEEN"

121+

122+{- | >>> printSQL $ true `notBetween` (null_, false)

123+TRUE NOT BETWEEN NULL AND FALSE

124+-}

125+notBetween :: BetweenExpr

126+notBetween = unsafeBetweenExpr "NOT BETWEEN"

127+

128+{- | between, after sorting the comparison values

129+

130+>>> printSQL $ true `betweenSymmetric` (null_, false)

131+TRUE BETWEEN SYMMETRIC NULL AND FALSE

132+-}

133+betweenSymmetric :: BetweenExpr

134+betweenSymmetric = unsafeBetweenExpr "BETWEEN SYMMETRIC"

135+

136+{- | not between, after sorting the comparison values

137+

138+>>> printSQL $ true `notBetweenSymmetric` (null_, false)

139+TRUE NOT BETWEEN SYMMETRIC NULL AND FALSE

140+-}

141+notBetweenSymmetric :: BetweenExpr

142+notBetweenSymmetric = unsafeBetweenExpr "NOT BETWEEN SYMMETRIC"

143+

144+{- | not equal, treating null like an ordinary value

145+

146+>>> printSQL $ true `isDistinctFrom` null_

147+(TRUE IS DISTINCT FROM NULL)

148+-}

149+isDistinctFrom :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)

150+isDistinctFrom = unsafeBinaryOp "IS DISTINCT FROM"

151+

152+{- | equal, treating null like an ordinary value

153+

154+>>> printSQL $ true `isNotDistinctFrom` null_

155+(TRUE IS NOT DISTINCT FROM NULL)

156+-}

157+isNotDistinctFrom :: Operator (null0 ty) (null1 ty) ('NotNull 'PGbool)

158+isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"

159+

160+{- | is true

161+

162+>>> printSQL $ true & isTrue

163+(TRUE IS TRUE)

164+-}

165+isTrue :: null0 'PGbool --> null1 'PGbool

166+isTrue = unsafeRightOp "IS TRUE"

167+

168+{- | is false or unknown

169+

170+>>> printSQL $ true & isNotTrue

171+(TRUE IS NOT TRUE)

172+-}

173+isNotTrue :: null0 'PGbool --> null1 'PGbool

174+isNotTrue = unsafeRightOp "IS NOT TRUE"

175+

176+{- | is false

177+

178+>>> printSQL $ true & isFalse

179+(TRUE IS FALSE)

180+-}

181+isFalse :: null0 'PGbool --> null1 'PGbool

182+isFalse = unsafeRightOp "IS FALSE"

183+

184+{- | is true or unknown

185+

186+>>> printSQL $ true & isNotFalse

187+(TRUE IS NOT FALSE)

188+-}

189+isNotFalse :: null0 'PGbool --> null1 'PGbool

190+isNotFalse = unsafeRightOp "IS NOT FALSE"

191+

192+{- | is unknown

193+

194+>>> printSQL $ true & isUnknown

195+(TRUE IS UNKNOWN)

196+-}

197+isUnknown :: null0 'PGbool --> null1 'PGbool

198+isUnknown = unsafeRightOp "IS UNKNOWN"

199+

200+{- | is true or false

201+

202+>>> printSQL $ true & isNotUnknown

203+(TRUE IS NOT UNKNOWN)

204+-}

205+isNotUnknown :: null0 'PGbool --> null1 'PGbool

206+isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Json.hsnew file+462

@@ -0,0 +1,462 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Json

3+Description: Json and Jsonb functions and operators

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Json and Jsonb functions and operators

9+-}

10+

11+{-# LANGUAGE

12+ DataKinds

13+ , FlexibleContexts

14+ , FlexibleInstances

15+ , GADTs

16+ , OverloadedLabels

17+ , OverloadedStrings

18+ , PolyKinds

19+ , RankNTypes

20+ , ScopedTypeVariables

21+ , TypeApplications

22+ , TypeOperators

23+ , UndecidableInstances

24+ , UndecidableSuperClasses

25+#-}

26+

27+module Squeal.PostgreSQL.Expression.Json

28+ ( -- * Json and Jsonb operators

29+ (.->)

30+ , (.->>)

31+ , (.#>)

32+ , (.#>>)

33+ -- * Jsonb operators

34+ , (.?)

35+ , (.?|)

36+ , (.?&)

37+ , (.-.)

38+ , (#-.)

39+ -- * Json and Jsonb functions

40+ , toJson

41+ , toJsonb

42+ , arrayToJson

43+ , rowToJson

44+ , jsonBuildArray

45+ , jsonbBuildArray

46+ , JsonBuildObject (..)

47+ , jsonObject

48+ , jsonbObject

49+ , jsonZipObject

50+ , jsonbZipObject

51+ , jsonArrayLength

52+ , jsonbArrayLength

53+ , jsonTypeof

54+ , jsonbTypeof

55+ , jsonStripNulls

56+ , jsonbStripNulls

57+ , jsonbSet

58+ , jsonbInsert

59+ , jsonbPretty

60+ -- * Json and Jsonb set returning functions

61+ , jsonEach

62+ , jsonbEach

63+ , jsonEachText

64+ , jsonbEachText

65+ , jsonObjectKeys

66+ , jsonbObjectKeys

67+ , JsonPopulateFunction

68+ , jsonPopulateRecord

69+ , jsonbPopulateRecord

70+ , jsonPopulateRecordSet

71+ , jsonbPopulateRecordSet

72+ , JsonToRecordFunction

73+ , jsonToRecord

74+ , jsonbToRecord

75+ , jsonToRecordSet

76+ , jsonbToRecordSet

77+ ) where

78+

79+import Data.ByteString (ByteString)

80+import GHC.TypeLits

81+

82+import Squeal.PostgreSQL.Alias

83+import Squeal.PostgreSQL.Expression

84+import Squeal.PostgreSQL.Expression.Set

85+import Squeal.PostgreSQL.Expression.Type

86+import Squeal.PostgreSQL.List

87+import Squeal.PostgreSQL.Query

88+import Squeal.PostgreSQL.Render

89+import Squeal.PostgreSQL.Schema

90+

91+import qualified Generics.SOP as SOP

92+

93+-- $setup

94+-- >>> import Squeal.PostgreSQL

95+-- >>> import Data.Aeson

96+

97+{-----------------------------------------

98+ -- json and jsonb support

99+

100+See https://www.postgresql.org/docs/10/static/functions-json.html -- most

101+comments lifted directly from this page.

102+

103+Table 9.44: json and jsonb operators

104+-----------------------------------------}

105+

106+-- | Get JSON value (object field or array element) at a key.

107+(.->)

108+ :: (json `In` PGJsonType, key `In` PGJsonKey)

109+ => Operator (null json) (null key) ('Null json)

110+infixl 8 .->

111+(.->) = unsafeBinaryOp "->"

112+

113+-- | Get JSON value (object field or array element) at a key, as text.

114+(.->>)

115+ :: (json `In` PGJsonType, key `In` PGJsonKey)

116+ => Operator (null json) (null key) ('Null 'PGtext)

117+infixl 8 .->>

118+(.->>) = unsafeBinaryOp "->>"

119+

120+-- | Get JSON value at a specified path.

121+(.#>)

122+ :: json `In` PGJsonType

123+ => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null json)

124+infixl 8 .#>

125+(.#>) = unsafeBinaryOp "#>"

126+

127+-- | Get JSON value at a specified path as text.

128+(.#>>)

129+ :: json `In` PGJsonType

130+ => Operator (null json) (null ('PGvararray ('NotNull 'PGtext))) ('Null 'PGtext)

131+infixl 8 .#>>

132+(.#>>) = unsafeBinaryOp "#>>"

133+

134+-- Additional jsonb operators

135+

136+-- | Does the string exist as a top-level key within the JSON value?

137+(.?) :: Operator (null 'PGjsonb) (null 'PGtext) ('Null 'PGbool)

138+infixl 9 .?

139+(.?) = unsafeBinaryOp "?"

140+

141+-- | Do any of these array strings exist as top-level keys?

142+(.?|) :: Operator

143+ (null 'PGjsonb)

144+ (null ('PGvararray ('NotNull 'PGtext)))

145+ ('Null 'PGbool)

146+infixl 9 .?|

147+(.?|) = unsafeBinaryOp "?|"

148+

149+-- | Do all of these array strings exist as top-level keys?

150+(.?&) :: Operator

151+ (null 'PGjsonb)

152+ (null ('PGvararray ('NotNull 'PGtext)))

153+ ('Null 'PGbool)

154+infixl 9 .?&

155+(.?&) = unsafeBinaryOp "?&"

156+

157+-- | Delete a key or keys from a JSON object, or remove an array element.

158+--

159+-- If the right operand is

160+--

161+-- @ text @: Delete key / value pair or string element from left operand.

162+-- Key / value pairs are matched based on their key value,

163+--

164+-- @ text[] @: Delete multiple key / value pairs or string elements

165+-- from left operand. Key / value pairs are matched based on their key value,

166+--

167+-- @ integer @: Delete the array element with specified index (Negative integers

168+-- count from the end). Throws an error if top level container is not an array.

169+(.-.)

170+ :: key `In` '[ 'PGtext, 'PGvararray ('NotNull 'PGtext), 'PGint4, 'PGint2 ]

171+ => Operator (null 'PGjsonb) (null key) (null 'PGjsonb)

172+infixl 6 .-.

173+(.-.) = unsafeBinaryOp "-"

174+

175+-- | Delete the field or element with specified path (for JSON arrays, negative

176+-- integers count from the end)

177+(#-.) :: Operator (null 'PGjsonb) (null ('PGvararray ('NotNull 'PGtext))) (null 'PGjsonb)

178+infixl 6 #-.

179+(#-.) = unsafeBinaryOp "#-"

180+

181+{-----------------------------------------

182+Table 9.45: JSON creation functions

183+-----------------------------------------}

184+

185+-- | Returns the value as json. Arrays and composites are converted

186+-- (recursively) to arrays and objects; otherwise, if there is a cast from the

187+-- type to json, the cast function will be used to perform the conversion;

188+-- otherwise, a scalar value is produced. For any scalar type other than a

189+-- number, a Boolean, or a null value, the text representation will be used, in

190+-- such a fashion that it is a valid json value.

191+toJson :: null ty --> null 'PGjson

192+toJson = unsafeFunction "to_json"

193+

194+-- | Returns the value as jsonb. Arrays and composites are converted

195+-- (recursively) to arrays and objects; otherwise, if there is a cast from the

196+-- type to json, the cast function will be used to perform the conversion;

197+-- otherwise, a scalar value is produced. For any scalar type other than a

198+-- number, a Boolean, or a null value, the text representation will be used, in

199+-- such a fashion that it is a valid jsonb value.

200+toJsonb :: null ty --> null 'PGjsonb

201+toJsonb = unsafeFunction "to_jsonb"

202+

203+-- | Returns the array as a JSON array. A PostgreSQL multidimensional array

204+-- becomes a JSON array of arrays.

205+arrayToJson :: null ('PGvararray ty) --> null 'PGjson

206+arrayToJson = unsafeFunction "array_to_json"

207+

208+-- | Returns the row as a JSON object.

209+rowToJson :: null ('PGcomposite ty) --> null 'PGjson

210+rowToJson = unsafeFunction "row_to_json"

211+

212+-- | Builds a possibly-heterogeneously-typed JSON array out of a variadic

213+-- argument list.

214+jsonBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjson

215+jsonBuildArray = unsafeFunctionN "json_build_array"

216+

217+-- | Builds a possibly-heterogeneously-typed (binary) JSON array out of a

218+-- variadic argument list.

219+jsonbBuildArray :: SOP.SListI tuple => tuple ---> null 'PGjsonb

220+jsonbBuildArray = unsafeFunctionN "jsonb_build_array"

221+

222+-- | Builds a possibly-heterogeneously-typed JSON object out of a variadic

223+-- argument list. The elements of the argument list must alternate between text

224+-- and values.

225+class SOP.SListI tys => JsonBuildObject tys where

226+

227+ jsonBuildObject :: tys ---> null 'PGjson

228+ jsonBuildObject = unsafeFunctionN "json_build_object"

229+

230+ jsonbBuildObject :: tys ---> null 'PGjsonb

231+ jsonbBuildObject = unsafeFunctionN "jsonb_build_object"

232+

233+instance JsonBuildObject '[]

234+instance (JsonBuildObject tys, key `In` PGJsonKey)

235+ => JsonBuildObject ('NotNull key ': value ': tys)

236+

237+-- | Builds a JSON object out of a text array.

238+-- The array must have two dimensions

239+-- such that each inner array has exactly two elements,

240+-- which are taken as a key/value pair.

241+jsonObject

242+ :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))

243+ --> null 'PGjson

244+jsonObject = unsafeFunction "json_object"

245+

246+-- | Builds a binary JSON object out of a text array.

247+-- The array must have two dimensions

248+-- such that each inner array has exactly two elements,

249+-- which are taken as a key/value pair.

250+jsonbObject

251+ :: null ('PGfixarray '[n,2] ('NotNull 'PGtext))

252+ --> null 'PGjsonb

253+jsonbObject = unsafeFunction "jsonb_object"

254+

255+-- | This is an alternate form of 'jsonObject' that takes two arrays; one for

256+-- keys and one for values, that are zipped pairwise to create a JSON object.

257+jsonZipObject ::

258+ '[ null ('PGvararray ('NotNull 'PGtext))

259+ , null ('PGvararray ('NotNull 'PGtext)) ]

260+ ---> null 'PGjson

261+jsonZipObject = unsafeFunctionN "json_object"

262+

263+-- | This is an alternate form of 'jsonbObject' that takes two arrays; one for

264+-- keys and one for values, that are zipped pairwise to create a binary JSON

265+-- object.

266+jsonbZipObject ::

267+ '[ null ('PGvararray ('NotNull 'PGtext))

268+ , null ('PGvararray ('NotNull 'PGtext)) ]

269+ ---> null 'PGjsonb

270+jsonbZipObject = unsafeFunctionN "jsonb_object"

271+

272+{-----------------------------------------

273+Table 9.46: JSON processing functions

274+-----------------------------------------}

275+

276+-- | Returns the number of elements in the outermost JSON array.

277+jsonArrayLength :: null 'PGjson --> null 'PGint4

278+jsonArrayLength = unsafeFunction "json_array_length"

279+

280+-- | Returns the number of elements in the outermost binary JSON array.

281+jsonbArrayLength :: null 'PGjsonb --> null 'PGint4

282+jsonbArrayLength = unsafeFunction "jsonb_array_length"

283+

284+-- | Returns the type of the outermost JSON value as a text string. Possible

285+-- types are object, array, string, number, boolean, and null.

286+jsonTypeof :: null 'PGjson --> null 'PGtext

287+jsonTypeof = unsafeFunction "json_typeof"

288+

289+-- | Returns the type of the outermost binary JSON value as a text string.

290+-- Possible types are object, array, string, number, boolean, and null.

291+jsonbTypeof :: null 'PGjsonb --> null 'PGtext

292+jsonbTypeof = unsafeFunction "jsonb_typeof"

293+

294+-- | Returns its argument with all object fields that have null values omitted.

295+-- Other null values are untouched.

296+jsonStripNulls :: null 'PGjson --> null 'PGjson

297+jsonStripNulls = unsafeFunction "json_strip_nulls"

298+

299+-- | Returns its argument with all object fields that have null values omitted.

300+-- Other null values are untouched.

301+jsonbStripNulls :: null 'PGjsonb --> null 'PGjsonb

302+jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"

303+

304+-- | @ jsonbSet target path new_value create_missing @

305+--

306+-- Returns target with the section designated by path replaced by @new_value@,

307+-- or with @new_value@ added if create_missing is

308+-- `Squeal.PostgreSQL.Expression.Logic.true` and the

309+-- item designated by path does not exist. As with the path orientated

310+-- operators, negative integers that appear in path count from the end of JSON

311+-- arrays.

312+jsonbSet ::

313+ '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))

314+ , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb

315+jsonbSet = unsafeFunctionN "jsonbSet"

316+

317+-- | @ jsonbInsert target path new_value insert_after @

318+--

319+-- Returns target with @new_value@ inserted. If target section designated by

320+-- path is in a JSONB array, @new_value@ will be inserted before target or after

321+-- if @insert_after@ is `Squeal.PostgreSQL.Expression.Logic.true`.

322+-- If target section designated by

323+-- path is in JSONB object, @new_value@ will be inserted only if target does not

324+-- exist. As with the path orientated operators, negative integers that appear

325+-- in path count from the end of JSON arrays.

326+jsonbInsert ::

327+ '[ null 'PGjsonb, null ('PGvararray ('NotNull 'PGtext))

328+ , null 'PGjsonb, null 'PGbool ] ---> null 'PGjsonb

329+jsonbInsert = unsafeFunctionN "jsonb_insert"

330+

331+-- | Returns its argument as indented JSON text.

332+jsonbPretty :: null 'PGjsonb --> null 'PGtext

333+jsonbPretty = unsafeFunction "jsonb_pretty"

334+

335+{- | Expands the outermost JSON object into a set of key/value pairs.

336+

337+>>> printSQL (select Star (from (jsonEach (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))

338+SELECT * FROM json_each(('{"a":"foo","b":"bar"}' :: json))

339+-}

340+jsonEach :: SetFunction "json_each" (null 'PGjson)

341+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]

342+jsonEach = unsafeSetFunction

343+

344+{- | Expands the outermost binary JSON object into a set of key/value pairs.

345+

346+>>> printSQL (select Star (from (jsonbEach (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))

347+SELECT * FROM jsonb_each(('{"a":"foo","b":"bar"}' :: jsonb))

348+-}

349+jsonbEach

350+ :: SetFunction "jsonb_each" (nullity 'PGjsonb)

351+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGjson]

352+jsonbEach = unsafeSetFunction

353+

354+{- | Expands the outermost JSON object into a set of key/value pairs.

355+

356+>>> printSQL (select Star (from (jsonEachText (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))))

357+SELECT * FROM json_each_text(('{"a":"foo","b":"bar"}' :: json))

358+-}

359+jsonEachText

360+ :: SetFunction "json_each_text" (null 'PGjson)

361+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]

362+jsonEachText = unsafeSetFunction

363+

364+{- | Expands the outermost binary JSON object into a set of key/value pairs.

365+

366+>>> printSQL (select Star (from (jsonbEachText (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))))

367+SELECT * FROM jsonb_each_text(('{"a":"foo","b":"bar"}' :: jsonb))

368+-}

369+jsonbEachText

370+ :: SetFunction "jsonb_each_text" (null 'PGjsonb)

371+ '["key" ::: 'NotNull 'PGtext, "value" ::: 'NotNull 'PGtext]

372+jsonbEachText = unsafeSetFunction

373+

374+{- | Returns set of keys in the outermost JSON object.

375+

376+>>> printSQL (jsonObjectKeys (literal (Json (object ["a" .= "foo", "b" .= "bar"]))))

377+json_object_keys(('{"a":"foo","b":"bar"}' :: json))

378+-}

379+jsonObjectKeys

380+ :: SetFunction "json_object_keys" (nullity 'PGjson)

381+ '["json_object_keys" ::: 'NotNull 'PGtext]

382+jsonObjectKeys = unsafeSetFunction

383+

384+{- | Returns set of keys in the outermost JSON object.

385+

386+>>> printSQL (jsonbObjectKeys (literal (Jsonb (object ["a" .= "foo", "b" .= "bar"]))))

387+jsonb_object_keys(('{"a":"foo","b":"bar"}' :: jsonb))

388+-}

389+jsonbObjectKeys

390+ :: SetFunction "jsonb_object_keys" (null 'PGjsonb)

391+ '["jsonb_object_keys" ::: 'NotNull 'PGtext]

392+jsonbObjectKeys = unsafeSetFunction

393+

394+-- | Build rows from Json types.

395+type JsonPopulateFunction fun json

396+ = forall schemas row outer commons params

397+ . json `In` PGJsonType

398+ => TypeExpression schemas ('NotNull ('PGcomposite row)) -- ^ row type

399+ -> Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)

400+ -- ^ json type

401+ -> FromClause outer commons schemas params '[fun ::: row]

402+

403+unsafePopulateFunction

404+ :: forall fun ty

405+ . KnownSymbol fun => Alias fun -> JsonPopulateFunction fun ty

406+unsafePopulateFunction _fun ty expr = UnsafeFromClause $ renderSymbol @fun

407+ <> parenthesized ("null::" <> renderSQL ty <> ", " <> renderSQL expr)

408+

409+-- | Expands the JSON expression to a row whose columns match the record

410+-- type defined by the given table.

411+jsonPopulateRecord :: JsonPopulateFunction "json_populate_record" 'PGjson

412+jsonPopulateRecord = unsafePopulateFunction #json_populate_record

413+

414+-- | Expands the binary JSON expression to a row whose columns match the record

415+-- type defined by the given table.

416+jsonbPopulateRecord :: JsonPopulateFunction "jsonb_populate_record" 'PGjsonb

417+jsonbPopulateRecord = unsafePopulateFunction #jsonb_populate_record

418+

419+-- | Expands the outermost array of objects in the given JSON expression to a

420+-- set of rows whose columns match the record type defined by the given table.

421+jsonPopulateRecordSet :: JsonPopulateFunction "json_populate_record_set" 'PGjson

422+jsonPopulateRecordSet = unsafePopulateFunction #json_populate_record_set

423+

424+-- | Expands the outermost array of objects in the given binary JSON expression

425+-- to a set of rows whose columns match the record type defined by the given

426+-- table.

427+jsonbPopulateRecordSet :: JsonPopulateFunction "jsonb_populate_record_set" 'PGjsonb

428+jsonbPopulateRecordSet = unsafePopulateFunction #jsonb_populate_record_set

429+

430+-- | Build rows from Json types.

431+type JsonToRecordFunction json

432+ = forall outer commons schemas params tab row

433+ . (SOP.SListI row, json `In` PGJsonType)

434+ => Expression outer commons 'Ungrouped schemas params '[] ('NotNull json)

435+ -- ^ json type

436+ -> Aliased (NP (Aliased (TypeExpression schemas))) (tab ::: row)

437+ -- ^ row type

438+ -> FromClause outer commons schemas params '[tab ::: row]

439+

440+unsafeRecordFunction :: ByteString -> JsonToRecordFunction json

441+unsafeRecordFunction fun expr (types `As` tab) = UnsafeFromClause $

442+ fun <> parenthesized (renderSQL expr) <+> "AS" <+> renderSQL tab

443+ <> parenthesized (renderCommaSeparated renderTy types)

444+ where

445+ renderTy :: Aliased (TypeExpression schemas) ty -> ByteString

446+ renderTy (ty `As` alias) = renderSQL alias <+> renderSQL ty

447+

448+-- | Builds an arbitrary record from a JSON object.

449+jsonToRecord :: JsonToRecordFunction 'PGjson

450+jsonToRecord = unsafeRecordFunction "json_to_record"

451+

452+-- | Builds an arbitrary record from a binary JSON object.

453+jsonbToRecord :: JsonToRecordFunction 'PGjsonb

454+jsonbToRecord = unsafeRecordFunction "jsonb_to_record"

455+

456+-- | Builds an arbitrary set of records from a JSON array of objects.

457+jsonToRecordSet :: JsonToRecordFunction 'PGjson

458+jsonToRecordSet = unsafeRecordFunction "json_to_record_set"

459+

460+-- | Builds an arbitrary set of records from a binary JSON array of objects.

461+jsonbToRecordSet :: JsonToRecordFunction 'PGjsonb

462+jsonbToRecordSet = unsafeRecordFunction "jsonb_to_record_set"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Literal.hsnew file+87

@@ -0,0 +1,87 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Literal

3+Description: Literal expressions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Literal expressions

9+-}

10+

11+{-# LANGUAGE

12+ FlexibleContexts

13+ , FlexibleInstances

14+ , LambdaCase

15+ , OverloadedStrings

16+ , RankNTypes

17+ , ScopedTypeVariables

18+ , TypeApplications

19+ , TypeSynonymInstances

20+ , UndecidableInstances

21+#-}

22+

23+module Squeal.PostgreSQL.Expression.Literal (Literal (..)) where

24+

25+import ByteString.StrictBuilder (builderBytes)

26+import Data.ByteString.Lazy (toStrict)

27+import Data.Int

28+import Data.String

29+import Data.Text (Text)

30+

31+import qualified Data.Aeson as JSON

32+import qualified Data.Text as Text

33+import qualified Data.Text.Lazy as Lazy (Text)

34+import qualified Data.Text.Lazy as Lazy.Text

35+

36+import Squeal.PostgreSQL.Binary

37+import Squeal.PostgreSQL.Expression

38+import Squeal.PostgreSQL.Expression.Logic

39+import Squeal.PostgreSQL.PG

40+import Squeal.PostgreSQL.Render

41+

42+{- |

43+The `Literal` class allows embedding a Haskell value directly

44+as an `Expression` using `literal`.

45+

46+>>> printSQL (literal 'a')

47+E'a'

48+

49+>>> printSQL (literal (1 :: Double))

50+1.0

51+

52+>>> printSQL (literal (Json [1 :: Double, 2]))

53+('[1.0,2.0]' :: json)

54+

55+>>> printSQL (literal (Enumerated GT))

56+'GT'

57+-}

58+class Literal hask where literal :: hask -> Expr (null (PG hask))

59+instance Literal Bool where

60+ literal = \case

61+ True -> true

62+ False -> false

63+instance JSON.ToJSON hask => Literal (Json hask) where

64+ literal = UnsafeExpression . parenthesized . (<> " :: json")

65+ . singleQuotedUtf8 . toStrict . JSON.encode . getJson

66+instance JSON.ToJSON hask => Literal (Jsonb hask) where

67+ literal = UnsafeExpression . parenthesized . (<> " :: jsonb")

68+ . singleQuotedUtf8 . toStrict . JSON.encode . getJsonb

69+instance Literal Char where

70+ literal chr = UnsafeExpression $

71+ "E\'" <> fromString (escape chr) <> "\'"

72+instance Literal String where literal = fromString

73+instance Literal Int16 where literal = fromIntegral

74+instance Literal Int32 where literal = fromIntegral

75+instance Literal Int64 where literal = fromIntegral

76+instance Literal Float where literal = fromRational . toRational

77+instance Literal Double where literal = fromRational . toRational

78+instance Literal Text where literal = fromString . Text.unpack

79+instance Literal Lazy.Text where literal = fromString . Lazy.Text.unpack

80+instance ToParam (Enumerated enum) (PG (Enumerated enum))

81+ => Literal (Enumerated enum) where

82+ literal

83+ = UnsafeExpression

84+ . singleQuotedUtf8

85+ . builderBytes

86+ . unK

87+ . toParam @(Enumerated enum) @(PG (Enumerated enum))

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hsnew file+105

@@ -0,0 +1,105 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Logic

3+Description: Logical expressions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Logical expressions and operators

9+-}

10+

11+{-# LANGUAGE

12+ DataKinds

13+ , OverloadedStrings

14+ , TypeOperators

15+#-}

16+

17+module Squeal.PostgreSQL.Expression.Logic

18+ ( Condition

19+ , true

20+ , false

21+ , not_

22+ , (.&&)

23+ , (.||)

24+ , caseWhenThenElse

25+ , ifThenElse

26+ ) where

27+

28+import Squeal.PostgreSQL.Expression

29+import Squeal.PostgreSQL.Render

30+import Squeal.PostgreSQL.Schema

31+

32+-- | A `Condition` is an `Expression`, which can evaluate

33+-- to `true`, `false` or `Squeal.PostgreSQL.Null.null_`. This is because SQL uses

34+-- a three valued logic.

35+type Condition outer commons grp schemas params from =

36+ Expression outer commons grp schemas params from ('Null 'PGbool)

37+

38+-- | >>> printSQL true

39+-- TRUE

40+true :: Expr (null 'PGbool)

41+true = UnsafeExpression "TRUE"

42+

43+-- | >>> printSQL false

44+-- FALSE

45+false :: Expr (null 'PGbool)

46+false = UnsafeExpression "FALSE"

47+

48+-- | >>> printSQL $ not_ true

49+-- (NOT TRUE)

50+not_ :: null 'PGbool --> null 'PGbool

51+not_ = unsafeLeftOp "NOT"

52+

53+-- | >>> printSQL $ true .&& false

54+-- (TRUE AND FALSE)

55+(.&&) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)

56+infixr 3 .&&

57+(.&&) = unsafeBinaryOp "AND"

58+

59+-- | >>> printSQL $ true .|| false

60+-- (TRUE OR FALSE)

61+(.||) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)

62+infixr 2 .||

63+(.||) = unsafeBinaryOp "OR"

64+

65+-- | >>> :{

66+-- let

67+-- expression :: Expression outer commons grp schemas params from (null 'PGint2)

68+-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3

69+-- in printSQL expression

70+-- :}

71+-- CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END

72+caseWhenThenElse

73+ :: [ ( Condition outer commons grp schemas params from

74+ , Expression outer commons grp schemas params from ty

75+ ) ]

76+ -- ^ whens and thens

77+ -> Expression outer commons grp schemas params from ty

78+ -- ^ else

79+ -> Expression outer commons grp schemas params from ty

80+caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat

81+ [ "CASE"

82+ , mconcat

83+ [ mconcat

84+ [ " WHEN ", renderSQL when_

85+ , " THEN ", renderSQL then_

86+ ]

87+ | (when_,then_) <- whenThens

88+ ]

89+ , " ELSE ", renderSQL else_

90+ , " END"

91+ ]

92+

93+-- | >>> :{

94+-- let

95+-- expression :: Expression outer commons grp schemas params from (null 'PGint2)

96+-- expression = ifThenElse true 1 0

97+-- in printSQL expression

98+-- :}

99+-- CASE WHEN TRUE THEN 1 ELSE 0 END

100+ifThenElse

101+ :: Condition outer commons grp schemas params from

102+ -> Expression outer commons grp schemas params from ty -- ^ then

103+ -> Expression outer commons grp schemas params from ty -- ^ else

104+ -> Expression outer commons grp schemas params from ty

105+ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hsnew file+100

@@ -0,0 +1,100 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Math

3+Description: Math expressions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Mathematical functions and operators

9+-}

10+

11+{-# LANGUAGE

12+ DataKinds

13+ , OverloadedStrings

14+ , TypeOperators

15+#-}

16+

17+module Squeal.PostgreSQL.Expression.Math

18+ ( atan2_

19+ , quot_

20+ , rem_

21+ , trunc

22+ , round_

23+ , ceiling_

24+ ) where

25+

26+import Squeal.PostgreSQL.Expression

27+import Squeal.PostgreSQL.List

28+import Squeal.PostgreSQL.Schema

29+

30+-- $setup

31+-- >>> import Squeal.PostgreSQL

32+

33+-- | >>> :{

34+-- let

35+-- expression :: Expr (null 'PGfloat4)

36+-- expression = atan2_ (pi *: 2)

37+-- in printSQL expression

38+-- :}

39+-- atan2(pi(), 2)

40+atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float

41+atan2_ = unsafeFunctionN "atan2"

42+

43+

44+-- | integer division, truncates the result

45+--

46+-- >>> :{

47+-- let

48+-- expression :: Expression outer commons grp schemas params from (null 'PGint2)

49+-- expression = 5 `quot_` 2

50+-- in printSQL expression

51+-- :}

52+-- (5 / 2)

53+quot_

54+ :: int `In` PGIntegral

55+ => Operator (null int) (null int) (null int)

56+quot_ = unsafeBinaryOp "/"

57+

58+-- | remainder upon integer division

59+--

60+-- >>> :{

61+-- let

62+-- expression :: Expression outer commons grp schemas params from (null 'PGint2)

63+-- expression = 5 `rem_` 2

64+-- in printSQL expression

65+-- :}

66+-- (5 % 2)

67+rem_

68+ :: int `In` PGIntegral

69+ => Operator (null int) (null int) (null int)

70+rem_ = unsafeBinaryOp "%"

71+

72+-- | >>> :{

73+-- let

74+-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)

75+-- expression = trunc pi

76+-- in printSQL expression

77+-- :}

78+-- trunc(pi())

79+trunc :: frac `In` PGFloating => null frac --> null frac

80+trunc = unsafeFunction "trunc"

81+

82+-- | >>> :{

83+-- let

84+-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)

85+-- expression = round_ pi

86+-- in printSQL expression

87+-- :}

88+-- round(pi())

89+round_ :: frac `In` PGFloating => null frac --> null frac

90+round_ = unsafeFunction "round"

91+

92+-- | >>> :{

93+-- let

94+-- expression :: Expression outer commons grp schemas params from (null 'PGfloat4)

95+-- expression = ceiling_ pi

96+-- in printSQL expression

97+-- :}

98+-- ceiling(pi())

99+ceiling_ :: frac `In` PGFloating => null frac --> null frac

100+ceiling_ = unsafeFunction "ceiling"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hsnew file+104

@@ -0,0 +1,104 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Null

3+Description: Null

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Null values and null handling functions

9+-}

10+

11+{-# LANGUAGE

12+ DataKinds

13+ , OverloadedStrings

14+ , TypeOperators

15+#-}

16+

17+module Squeal.PostgreSQL.Expression.Null

18+ ( null_

19+ , notNull

20+ , coalesce

21+ , fromNull

22+ , isNull

23+ , isNotNull

24+ , matchNull

25+ , nullIf

26+ ) where

27+

28+import Squeal.PostgreSQL.Expression

29+import Squeal.PostgreSQL.Expression.Logic

30+import Squeal.PostgreSQL.Render

31+import Squeal.PostgreSQL.Schema

32+

33+-- $setup

34+-- >>> import Squeal.PostgreSQL

35+

36+-- | analagous to `Nothing`

37+--

38+-- >>> printSQL null_

39+-- NULL

40+null_ :: Expr ('Null ty)

41+null_ = UnsafeExpression "NULL"

42+

43+-- | analagous to `Just`

44+--

45+-- >>> printSQL $ notNull true

46+-- TRUE

47+notNull :: 'NotNull ty --> 'Null ty

48+notNull = UnsafeExpression . renderSQL

49+

50+-- | return the leftmost value which is not NULL

51+--

52+-- >>> printSQL $ coalesce [null_, true] false

53+-- COALESCE(NULL, TRUE, FALSE)

54+coalesce :: FunctionVar ('Null ty) ('NotNull ty) ('NotNull ty)

55+coalesce nullxs notNullx = UnsafeExpression $

56+ "COALESCE" <> parenthesized (commaSeparated

57+ ((renderSQL <$> nullxs) <> [renderSQL notNullx]))

58+

59+-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@

60+--

61+-- >>> printSQL $ fromNull true null_

62+-- COALESCE(NULL, TRUE)

63+fromNull

64+ :: Expression outer commons grp schemas params from ('NotNull ty)

65+ -- ^ what to convert @NULL@ to

66+ -> Expression outer commons grp schemas params from ('Null ty)

67+ -> Expression outer commons grp schemas params from ('NotNull ty)

68+fromNull notNullx nullx = coalesce [nullx] notNullx

69+

70+-- | >>> printSQL $ null_ & isNull

71+-- NULL IS NULL

72+isNull :: 'Null ty --> null 'PGbool

73+isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"

74+

75+-- | >>> printSQL $ null_ & isNotNull

76+-- NULL IS NOT NULL

77+isNotNull :: 'Null ty --> null 'PGbool

78+isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"

79+

80+-- | analagous to `maybe` using @IS NULL@

81+--

82+-- >>> printSQL $ matchNull true not_ null_

83+-- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END

84+matchNull

85+ :: Expression outer commons grp schemas params from (nullty)

86+ -- ^ what to convert @NULL@ to

87+ -> ( Expression outer commons grp schemas params from ('NotNull ty)

88+ -> Expression outer commons grp schemas params from (nullty) )

89+ -- ^ function to perform when @NULL@ is absent

90+ -> Expression outer commons grp schemas params from ('Null ty)

91+ -> Expression outer commons grp schemas params from (nullty)

92+matchNull y f x = ifThenElse (isNull x) y

93+ (f (UnsafeExpression (renderSQL x)))

94+

95+{-| right inverse to `fromNull`, if its arguments are equal then

96+`nullIf` gives @NULL@.

97+

98+>>> :set -XTypeApplications -XDataKinds

99+>>> let expr = nullIf (false *: param @1) :: Expression outer commons grp schemas '[ 'NotNull 'PGbool] from ('Null 'PGbool)

100+>>> printSQL expr

101+NULLIF(FALSE, ($1 :: bool))

102+-}

103+nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty

104+nullIf = unsafeFunctionN "NULLIF"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hsnew file+80

@@ -0,0 +1,80 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Parameter

3+Description: Parameters

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Parameters, out-of-line data values

9+-}

10+

11+{-# LANGUAGE

12+ AllowAmbiguousTypes

13+ , DataKinds

14+ , FlexibleContexts

15+ , FlexibleInstances

16+ , FunctionalDependencies

17+ , KindSignatures

18+ , MultiParamTypeClasses

19+ , OverloadedStrings

20+ , RankNTypes

21+ , ScopedTypeVariables

22+ , TypeApplications

23+ , TypeOperators

24+ , UndecidableInstances

25+#-}

26+

27+module Squeal.PostgreSQL.Expression.Parameter

28+ ( HasParameter (parameter)

29+ , param

30+ ) where

31+

32+import GHC.TypeLits

33+

34+import Squeal.PostgreSQL.Expression

35+import Squeal.PostgreSQL.Expression.Type

36+import Squeal.PostgreSQL.Render

37+import Squeal.PostgreSQL.Schema

38+

39+-- $setup

40+-- >>> import Squeal.PostgreSQL

41+

42+{- | A `HasParameter` constraint is used to indicate a value that is

43+supplied externally to a SQL statement.

44+`Squeal.PostgreSQL.PQ.manipulateParams`,

45+`Squeal.PostgreSQL.PQ.queryParams` and

46+`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values

47+separately from the SQL command string, in which case `param`s are used to

48+refer to the out-of-line data values.

49+-}

50+class KnownNat n => HasParameter

51+ (n :: Nat)

52+ (params :: [NullityType])

53+ (ty :: NullityType)

54+ | n params -> ty where

55+ -- | `parameter` takes a `Nat` using type application and a `TypeExpression`.

56+ --

57+ -- >>> let expr = parameter @1 int4 :: Expression outer '[] grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)

58+ -- >>> printSQL expr

59+ -- ($1 :: int4)

60+ parameter

61+ :: TypeExpression schemas ty

62+ -> Expression outer commons grp schemas params from ty

63+ parameter ty = UnsafeExpression $ parenthesized $

64+ "$" <> renderNat @n <+> "::"

65+ <+> renderSQL ty

66+instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1

67+instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)

68+ => HasParameter n (ty' : params) ty

69+

70+-- | `param` takes a `Nat` using type application and for basic types,

71+-- infers a `TypeExpression`.

72+--

73+-- >>> let expr = param @1 :: Expression outer commons grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)

74+-- >>> printSQL expr

75+-- ($1 :: int4)

76+param

77+ :: forall n outer commons schemas params from grp ty

78+ . (PGTyped schemas ty, HasParameter n params ty)

79+ => Expression outer commons grp schemas params from ty -- ^ param

80+param = parameter @n (pgtype @schemas)

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hsnew file+230

@@ -0,0 +1,230 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Range

3+Description: range types and functions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Range types and functions

9+-}

10+

11+{-# LANGUAGE

12+ AllowAmbiguousTypes

13+ , DataKinds

14+ , DeriveAnyClass

15+ , DeriveGeneric

16+ , DeriveFoldable

17+ , DerivingStrategies

18+ , DeriveTraversable

19+ , FlexibleContexts

20+ , FlexibleInstances

21+ , LambdaCase

22+ , MultiParamTypeClasses

23+ , OverloadedLabels

24+ , OverloadedStrings

25+ , PatternSynonyms

26+ , RankNTypes

27+ , ScopedTypeVariables

28+ , TypeApplications

29+ , TypeFamilies

30+ , TypeOperators

31+ , UndecidableInstances

32+#-}

33+

34+module Squeal.PostgreSQL.Expression.Range

35+ ( range

36+ , Range (..)

37+ , (<=..<=), (<..<), (<=..<), (<..<=)

38+ , moreThan, atLeast, lessThan, atMost

39+ , singleton, whole

40+ , Bound (..)

41+ , (.<@)

42+ , (@>.)

43+ , (<<@)

44+ , (@>>)

45+ , (&<)

46+ , (&>)

47+ , (-|-)

48+ , (@+)

49+ , (@*)

50+ , (@-)

51+ , lowerBound

52+ , upperBound

53+ , isEmpty

54+ , lowerInc

55+ , lowerInf

56+ , upperInc

57+ , upperInf

58+ , rangeMerge

59+ ) where

60+

61+import BinaryParser

62+import ByteString.StrictBuilder

63+import Data.Bits

64+import qualified GHC.Generics as GHC

65+import qualified Generics.SOP as SOP

66+import qualified PostgreSQL.Binary.Decoding as Decoding

67+

68+import Squeal.PostgreSQL.Binary

69+import Squeal.PostgreSQL.Expression

70+import Squeal.PostgreSQL.Expression.Type hiding (bool)

71+import Squeal.PostgreSQL.PG

72+import Squeal.PostgreSQL.Render

73+import Squeal.PostgreSQL.Schema

74+

75+-- $setup

76+-- >>> import Squeal.PostgreSQL

77+

78+-- | Construct a `range`

79+--

80+-- >>> printSQL $ range tstzrange (atLeast now)

81+-- tstzrange(now(), NULL, '[)')

82+-- >>> printSQL $ range numrange (0 <=..< 2*pi)

83+-- numrange(0, (2 * pi()), '[)')

84+-- >>> printSQL $ range int4range Empty

85+-- ('empty' :: int4range)

86+range

87+ :: TypeExpression schemas (null ('PGrange ty))

88+ -> Range (Expression outer commons grp schemas params from ('NotNull ty))

89+ -> Expression outer commons grp schemas params from (null ('PGrange ty))

90+range ty = \case

91+ Empty -> UnsafeExpression $ parenthesized

92+ (emp <+> "::" <+> renderSQL ty)

93+ NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized

94+ (commaSeparated (args l u))

95+ where

96+ emp = singleQuote <> "empty" <> singleQuote

97+ args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote]

98+ singleQuote = "\'"

99+ arg = \case

100+ Infinite -> "NULL"; Closed x -> renderSQL x; Open x -> renderSQL x

101+ bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "("

102+ ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")"

103+

104+data Bound x = Infinite | Closed x | Open x

105+ deriving

106+ ( Eq, Ord, Show, Read, GHC.Generic

107+ , Functor, Foldable, Traversable )

108+

109+data Range x = Empty | NonEmpty (Bound x) (Bound x)

110+ deriving

111+ ( Eq, Ord, Show, Read, GHC.Generic

112+ , Functor, Foldable, Traversable )

113+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)

114+type instance PG (Range x) = 'PGrange (PG x)

115+instance ToParam x pg => ToParam (Range x) ('PGrange pg) where

116+ toParam rng = K $

117+ word8 (setFlags rng 0) <>

118+ case rng of

119+ Empty -> mempty

120+ NonEmpty lower upper -> putBound lower <> putBound upper

121+ where

122+ putBound = \case

123+ Infinite -> mempty

124+ Closed value -> putValue (unK (toParam @x @pg value))

125+ Open value -> putValue (unK (toParam @x @pg value))

126+ putValue value = int32BE (fromIntegral (builderLength value)) <> value

127+ setFlags = \case

128+ Empty -> (`setBit` 0)

129+ NonEmpty lower upper ->

130+ setLowerFlags lower . setUpperFlags upper

131+ setLowerFlags = \case

132+ Infinite -> (`setBit` 3)

133+ Closed _ -> (`setBit` 1)

134+ Open _ -> id

135+ setUpperFlags = \case

136+ Infinite -> (`setBit` 4)

137+ Closed _ -> (`setBit` 2)

138+ Open _ -> id

139+instance FromValue pg y => FromValue ('PGrange pg) (Range y) where

140+ fromValue = do

141+ flag <- byte

142+ if testBit flag 0 then return Empty else do

143+ lower <-

144+ if testBit flag 3

145+ then return Infinite

146+ else do

147+ len <- sized 4 Decoding.int

148+ l <- sized len (fromValue @pg)

149+ return $ if testBit flag 1 then Closed l else Open l

150+ upper <-

151+ if testBit flag 4

152+ then return Infinite

153+ else do

154+ len <- sized 4 Decoding.int

155+ l <- sized len (fromValue @pg)

156+ return $ if testBit flag 2 then Closed l else Open l

157+ return $ NonEmpty lower upper

158+

159+(<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x

160+infix 4 <=..<=, <..<, <=..<, <..<=

161+x <=..<= y = NonEmpty (Closed x) (Closed y)

162+x <..< y = NonEmpty (Open x) (Open y)

163+x <=..< y = NonEmpty (Closed x) (Open y)

164+x <..<= y = NonEmpty (Open x) (Closed y)

165+

166+moreThan, atLeast, lessThan, atMost :: x -> Range x

167+moreThan x = NonEmpty (Open x) Infinite

168+atLeast x = NonEmpty (Closed x) Infinite

169+lessThan x = NonEmpty Infinite (Open x)

170+atMost x = NonEmpty Infinite (Closed x)

171+

172+singleton :: x -> Range x

173+singleton x = x <=..<= x

174+

175+whole :: Range x

176+whole = NonEmpty Infinite Infinite

177+

178+(.<@) :: Operator ('NotNull ty) (null ('PGrange ty)) ('Null 'PGbool)

179+(.<@) = unsafeBinaryOp "<@"

180+

181+(@>.) :: Operator (null ('PGrange ty)) ('NotNull ty) ('Null 'PGbool)

182+(@>.) = unsafeBinaryOp "<@"

183+

184+(<<@) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)

185+(<<@) = unsafeBinaryOp "<<"

186+

187+(@>>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)

188+(@>>) = unsafeBinaryOp ">>"

189+

190+(&<) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)

191+(&<) = unsafeBinaryOp "&<"

192+

193+(&>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)

194+(&>) = unsafeBinaryOp "&>"

195+

196+(-|-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)

197+(-|-) = unsafeBinaryOp "-|-"

198+

199+(@+) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))

200+(@+) = unsafeBinaryOp "+"

201+

202+(@*) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))

203+(@*) = unsafeBinaryOp "*"

204+

205+(@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))

206+(@-) = unsafeBinaryOp "-"

207+

208+lowerBound :: null ('PGrange ty) --> 'Null ty

209+lowerBound = unsafeFunction "lower"

210+

211+upperBound :: null ('PGrange ty) --> 'Null ty

212+upperBound = unsafeFunction "upper"

213+

214+isEmpty :: null ('PGrange ty) --> 'Null 'PGbool

215+isEmpty = unsafeFunction "isempty"

216+

217+lowerInc :: null ('PGrange ty) --> 'Null 'PGbool

218+lowerInc = unsafeFunction "lower_inc"

219+

220+lowerInf :: null ('PGrange ty) --> 'Null 'PGbool

221+lowerInf = unsafeFunction "lower_inf"

222+

223+upperInc :: null ('PGrange ty) --> 'Null 'PGbool

224+upperInc = unsafeFunction "upper_inc"

225+

226+upperInf :: null ('PGrange ty) --> 'Null 'PGbool

227+upperInf = unsafeFunction "upper_inf"

228+

229+rangeMerge :: '[null ('PGrange ty), null ('PGrange ty)] ---> null ('PGrange ty)

230+rangeMerge = unsafeFunctionN "range_merge"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Set.hsnew file+139

@@ -0,0 +1,139 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Set

3+Description: Set returning functions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Set returning functions

9+-}

10+

11+{-# LANGUAGE

12+ AllowAmbiguousTypes

13+ , DataKinds

14+ , FlexibleContexts

15+ , OverloadedStrings

16+ , PolyKinds

17+ , RankNTypes

18+ , ScopedTypeVariables

19+ , TypeApplications

20+ , TypeOperators

21+#-}

22+

23+module Squeal.PostgreSQL.Expression.Set

24+ ( generateSeries

25+ , generateSeriesStep

26+ , generateSeriesTimestamp

27+ , SetFunction

28+ , unsafeSetFunction

29+ , SetFunctionDB

30+ , setFunction

31+ , SetFunctionN

32+ , unsafeSetFunctionN

33+ , SetFunctionNDB

34+ , setFunctionN

35+ ) where

36+

37+import GHC.TypeLits

38+

39+import qualified Generics.SOP as SOP

40+

41+import Squeal.PostgreSQL.Alias

42+import Squeal.PostgreSQL.Expression

43+import Squeal.PostgreSQL.List

44+import Squeal.PostgreSQL.Render

45+import Squeal.PostgreSQL.Query

46+import Squeal.PostgreSQL.Schema

47+

48+{- |

49+A @RankNType@ for set returning functions with 1 argument.

50+-}

51+type SetFunction fun ty row

52+ = forall outer commons schemas params

53+ . Expression outer commons 'Ungrouped schemas params '[] ty

54+ -- ^ input

55+ -> FromClause outer commons schemas params '[fun ::: row]

56+ -- ^ output

57+

58+type SetFunctionDB fun schemas ty row

59+ = forall outer commons params

60+ . Expression outer commons 'Ungrouped schemas params '[] ty

61+ -- ^ input

62+ -> FromClause outer commons schemas params '[fun ::: row]

63+ -- ^ output

64+

65+-- | Escape hatch for a set returning function with 1 argument.

66+unsafeSetFunction

67+ :: forall fun ty row. KnownSymbol fun

68+ => SetFunction fun ty row -- ^ set returning function

69+unsafeSetFunction x = UnsafeFromClause $

70+ renderSymbol @fun <> parenthesized (renderSQL x)

71+

72+setFunction

73+ :: ( Has sch schemas schema

74+ , Has fun schema ('Function ('[ty] :=> 'ReturnsTable row)) )

75+ => QualifiedAlias sch fun

76+ -> SetFunctionDB fun schemas ty row

77+setFunction _ = unsafeSetFunction

78+

79+{- |

80+A @RankNType@ for set returning functions with multiple argument.

81+-}

82+type SetFunctionN fun tys row

83+ = forall outer commons schemas params

84+ . NP (Expression outer commons 'Ungrouped schemas params '[]) tys

85+ -- ^ inputs

86+ -> FromClause outer commons schemas params '[fun ::: row]

87+ -- ^ output

88+

89+-- | Escape hatch for a set returning function with multiple argument.

90+unsafeSetFunctionN

91+ :: forall fun tys row. (SOP.SListI tys, KnownSymbol fun)

92+ => SetFunctionN fun tys row -- ^ set returning function

93+unsafeSetFunctionN xs = UnsafeFromClause $

94+ renderSymbol @fun <> parenthesized (renderCommaSeparated renderSQL xs)

95+

96+type SetFunctionNDB fun schemas tys row

97+ = forall outer commons params

98+ . NP (Expression outer commons 'Ungrouped schemas params '[]) tys

99+ -- ^ inputs

100+ -> FromClause outer commons schemas params '[fun ::: row]

101+ -- ^ output

102+

103+setFunctionN

104+ :: ( Has sch schemas schema

105+ , Has fun schema ('Function (tys :=> 'ReturnsTable row))

106+ , SOP.SListI tys )

107+ => QualifiedAlias sch fun

108+ -> SetFunctionNDB fun schemas tys row

109+setFunctionN _ = unsafeSetFunctionN

110+

111+{- | @generateSeries (start *: stop)@

112+

113+Generate a series of values, from @start@ to @stop@ with a step size of one

114+-}

115+generateSeries

116+ :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]

117+ => SetFunctionN "generate_series" '[ null ty, null ty]

118+ '["generate_series" ::: null ty] -- ^ set returning function

119+generateSeries = unsafeSetFunctionN

120+

121+{- | @generateSeries (start :* stop *: step)@

122+

123+Generate a series of values, from @start@ to @stop@ with a step size of @step@

124+-}

125+generateSeriesStep

126+ :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]

127+ => SetFunctionN "generate_series" '[null ty, null ty, null ty]

128+ '["generate_series" ::: null ty] -- ^ set returning function

129+generateSeriesStep = unsafeSetFunctionN

130+

131+{- | @generateSeries (start :* stop *: step)@

132+

133+Generate a series of values, from @start@ to @stop@ with a step size of @step@

134+-}

135+generateSeriesTimestamp

136+ :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]

137+ => SetFunctionN "generate_series" '[null ty, null ty, null 'PGinterval]

138+ '["generate_series" ::: null ty] -- ^ set returning function

139+generateSeriesTimestamp = unsafeSetFunctionN

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hsnew file+85

@@ -0,0 +1,85 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Sort

3+Description: Sort expressions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Sort expressions

9+-}

10+

11+{-# LANGUAGE

12+ DataKinds

13+ , GADTs

14+ , LambdaCase

15+ , OverloadedStrings

16+ , StandaloneDeriving

17+#-}

18+

19+module Squeal.PostgreSQL.Expression.Sort

20+ ( SortExpression (..)

21+ , OrderBy (..)

22+ ) where

23+

24+import Squeal.PostgreSQL.Expression

25+import Squeal.PostgreSQL.Render

26+import Squeal.PostgreSQL.Schema

27+

28+-- | `SortExpression`s are used by `orderBy` to optionally sort the results

29+-- of a `Squeal.PostgreSQL.Query.Query`. `Asc` or `Desc`

30+-- set the sort direction of a `NotNull` result

31+-- column to ascending or descending. Ascending order puts smaller values

32+-- first, where "smaller" is defined in terms of the

33+-- `Squeal.PostgreSQL.Expression.Comparison..<` operator. Similarly,

34+-- descending order is determined with the

35+-- `Squeal.PostgreSQL.Expression.Comparison..>` operator. `AscNullsFirst`,

36+-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to

37+-- determine whether nulls appear before or after non-null values in the sort

38+-- ordering of a `Null` result column.

39+data SortExpression outer commons grp schemas params from where

40+ Asc

41+ :: Expression outer commons grp schemas params from ('NotNull ty)

42+ -> SortExpression outer commons grp schemas params from

43+ Desc

44+ :: Expression outer commons grp schemas params from ('NotNull ty)

45+ -> SortExpression outer commons grp schemas params from

46+ AscNullsFirst

47+ :: Expression outer commons grp schemas params from ('Null ty)

48+ -> SortExpression outer commons grp schemas params from

49+ AscNullsLast

50+ :: Expression outer commons grp schemas params from ('Null ty)

51+ -> SortExpression outer commons grp schemas params from

52+ DescNullsFirst

53+ :: Expression outer commons grp schemas params from ('Null ty)

54+ -> SortExpression outer commons grp schemas params from

55+ DescNullsLast

56+ :: Expression outer commons grp schemas params from ('Null ty)

57+ -> SortExpression outer commons grp schemas params from

58+deriving instance Show (SortExpression outer commons grp schemas params from)

59+instance RenderSQL (SortExpression outer commons grp schemas params from) where

60+ renderSQL = \case

61+ Asc expression -> renderSQL expression <+> "ASC"

62+ Desc expression -> renderSQL expression <+> "DESC"

63+ AscNullsFirst expression -> renderSQL expression

64+ <+> "ASC NULLS FIRST"

65+ DescNullsFirst expression -> renderSQL expression

66+ <+> "DESC NULLS FIRST"

67+ AscNullsLast expression -> renderSQL expression <+> "ASC NULLS LAST"

68+ DescNullsLast expression -> renderSQL expression <+> "DESC NULLS LAST"

69+

70+{- |

71+The `orderBy` clause causes the result rows of a `Squeal.PostgreSQL.Query.TableExpression`

72+to be sorted according to the specified `SortExpression`(s).

73+If two rows are equal according to the leftmost expression,

74+they are compared according to the next expression and so on.

75+If they are equal according to all specified expressions,

76+they are returned in an implementation-dependent order.

77+

78+You can also control the order in which rows are processed by window functions

79+using `orderBy` within `Squeal.PostgreSQL.Query.Over`.

80+-}

81+class OrderBy expr where

82+ orderBy

83+ :: [SortExpression outer commons grp schemas params from]

84+ -> expr outer commons grp schemas params from

85+ -> expr outer commons grp schemas params from

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hsnew file+120

@@ -0,0 +1,120 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Subquery

3+Description: Subquery expressions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Subquery expressions

9+-}

10+

11+{-# LANGUAGE

12+ DataKinds

13+ , OverloadedStrings

14+ , RankNTypes

15+ , TypeOperators

16+#-}

17+

18+module Squeal.PostgreSQL.Expression.Subquery

19+ ( exists

20+ , in_

21+ , notIn

22+ , subAll

23+ , subAny

24+ ) where

25+

26+import Squeal.PostgreSQL.Alias

27+import Squeal.PostgreSQL.Expression

28+import Squeal.PostgreSQL.Expression.Logic

29+import Squeal.PostgreSQL.List

30+import Squeal.PostgreSQL.Query

31+import Squeal.PostgreSQL.Render

32+import Squeal.PostgreSQL.Schema

33+

34+-- $setup

35+-- >>> import Squeal.PostgreSQL

36+

37+{- |

38+The argument of `exists` is an arbitrary subquery. The subquery is evaluated

39+to determine whether it returns any rows. If it returns at least one row,

40+the result of `exists` is `true`; if the subquery returns no rows,

41+the result of `exists` is `false`.

42+

43+The subquery can refer to variables from the surrounding query,

44+which will act as constants during any one evaluation of the subquery.

45+

46+The subquery will generally only be executed long enough to determine whether

47+at least one row is returned, not all the way to completion.

48+-}

49+exists

50+ :: Query (Join outer from) commons schemas params row

51+ -> Condition outer commons grp schemas params from

52+exists query = UnsafeExpression $ "EXISTS" <+> parenthesized (renderSQL query)

53+

54+{- |

55+The right-hand side is a parenthesized subquery, which must return

56+exactly one column. The left-hand expression is evaluated and compared to each

57+row of the subquery result using the given `Operator`,

58+which must yield a Boolean result. The result of `subAll` is `true`

59+if all rows yield true (including the case where the subquery returns no rows).

60+The result is `false` if any `false` result is found.

61+The result is `Squeal.PostgreSQL.Expression.Null.null_` if

62+ no comparison with a subquery row returns `false`,

63+and at least one comparison returns `Squeal.PostgreSQL.Expression.Null.null_`.

64+

65+>>> printSQL $ subAll true (.==) (values_ (true `as` #foo))

66+(TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo")))

67+-}

68+subAll

69+ :: Expression outer commons grp schemas params from ty1 -- ^ expression

70+ -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator

71+ -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery

72+ -> Condition outer commons grp schemas params from

73+subAll expr (?) qry = expr ?

74+ (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL qry))

75+

76+{- |

77+The right-hand side is a parenthesized subquery, which must return exactly one column.

78+The left-hand expression is evaluated and compared to each row of the subquery result

79+using the given `Operator`, which must yield a Boolean result. The result of `subAny` is `true`

80+if any `true` result is obtained. The result is `false` if no true result is found

81+(including the case where the subquery returns no rows).

82+

83+>>> printSQL $ subAny "foo" like (values_ ("foobar" `as` #foo))

84+(E'foo' LIKE ANY (SELECT * FROM (VALUES (E'foobar')) AS t ("foo")))

85+-}

86+subAny

87+ :: Expression outer commons grp schemas params from ty1 -- ^ expression

88+ -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator

89+ -> Query (Join outer from) commons schemas params '[col ::: ty2] -- ^ subquery

90+ -> Condition outer commons grp schemas params from

91+subAny expr (?) qry = expr ?

92+ (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL qry))

93+

94+{- |

95+The result is `true` if the left-hand expression's result is equal

96+to any of the right-hand expressions.

97+

98+>>> printSQL $ true `in_` [true, false, null_]

99+TRUE IN (TRUE, FALSE, NULL)

100+-}

101+in_

102+ :: Expression outer commons grp schemas params from ty -- ^ expression

103+ -> [Expression outer commons grp schemas params from ty]

104+ -> Condition outer commons grp schemas params from

105+expr `in_` exprs = UnsafeExpression $ renderSQL expr <+> "IN"

106+ <+> parenthesized (commaSeparated (renderSQL <$> exprs))

107+

108+{- |

109+The result is `true` if the left-hand expression's result is not equal

110+to any of the right-hand expressions.

111+

112+>>> printSQL $ true `notIn` [false, null_]

113+TRUE NOT IN (FALSE, NULL)

114+-}

115+notIn

116+ :: Expression outer commons grp schemas params from ty -- ^ expression

117+ -> [Expression outer commons grp schemas params from ty]

118+ -> Condition outer commons grp schemas params from

119+expr `notIn` exprs = UnsafeExpression $ renderSQL expr <+> "NOT IN"

120+ <+> parenthesized (commaSeparated (renderSQL <$> exprs))

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hsnew file+64

@@ -0,0 +1,64 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Text

3+Description: Text expressions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+String functions and operators

9+-}

10+

11+{-# LANGUAGE

12+ DataKinds

13+ , OverloadedStrings

14+ , TypeOperators

15+#-}

16+

17+module Squeal.PostgreSQL.Expression.Text

18+ ( lower

19+ , upper

20+ , charLength

21+ , like

22+ , ilike

23+ ) where

24+

25+import Squeal.PostgreSQL.Expression

26+import Squeal.PostgreSQL.Schema

27+

28+-- $setup

29+-- >>> import Squeal.PostgreSQL

30+

31+-- | >>> printSQL $ lower "ARRRGGG"

32+-- lower(E'ARRRGGG')

33+lower :: null 'PGtext --> null 'PGtext

34+lower = unsafeFunction "lower"

35+

36+-- | >>> printSQL $ upper "eeee"

37+-- upper(E'eeee')

38+upper :: null 'PGtext --> null 'PGtext

39+upper = unsafeFunction "upper"

40+

41+-- | >>> printSQL $ charLength "four"

42+-- char_length(E'four')

43+charLength :: null 'PGtext --> null 'PGint4

44+charLength = unsafeFunction "char_length"

45+

46+-- | The `like` expression returns true if the @string@ matches

47+-- the supplied @pattern@. If @pattern@ does not contain percent signs

48+-- or underscores, then the pattern only represents the string itself;

49+-- in that case `like` acts like the equals operator. An underscore (_)

50+-- in pattern stands for (matches) any single character; a percent sign (%)

51+-- matches any sequence of zero or more characters.

52+--

53+-- >>> printSQL $ "abc" `like` "a%"

54+-- (E'abc' LIKE E'a%')

55+like :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)

56+like = unsafeBinaryOp "LIKE"

57+

58+-- | The key word ILIKE can be used instead of LIKE to make the

59+-- match case-insensitive according to the active locale.

60+--

61+-- >>> printSQL $ "abc" `ilike` "a%"

62+-- (E'abc' ILIKE E'a%')

63+ilike :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)

64+ilike = unsafeBinaryOp "ILIKE"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hsnew file+157

@@ -0,0 +1,157 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.TextSearch

3+Description: Text search expressions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Text search functions and operators

9+-}

10+

11+{-# LANGUAGE

12+ DataKinds

13+ , OverloadedStrings

14+ , TypeOperators

15+#-}

16+

17+module Squeal.PostgreSQL.Expression.TextSearch

18+ ( (@@)

19+ , (.&)

20+ , (.|)

21+ , (.!)

22+ , (<->)

23+ , arrayToTSvector

24+ , tsvectorLength

25+ , numnode

26+ , plainToTSquery

27+ , phraseToTSquery

28+ , websearchToTSquery

29+ , queryTree

30+ , toTSquery

31+ , toTSvector

32+ , setWeight

33+ , strip

34+ , jsonToTSvector

35+ , jsonbToTSvector

36+ , tsDelete

37+ , tsFilter

38+ , tsHeadline

39+ ) where

40+

41+import Squeal.PostgreSQL.Expression

42+import Squeal.PostgreSQL.List

43+import Squeal.PostgreSQL.Schema

44+

45+-- | `Squeal.PostgreSQL.Expression.Type.tsvector` matches tsquery ?

46+(@@) :: Operator (null 'PGtsvector) (null 'PGtsquery) ('Null 'PGbool)

47+(@@) = unsafeBinaryOp "@@"

48+

49+-- | AND `Squeal.PostgreSQL.Expression.Type.tsquery`s together

50+(.&) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)

51+(.&) = unsafeBinaryOp "&&"

52+

53+-- | OR `Squeal.PostgreSQL.Expression.Type.tsquery`s together

54+(.|) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)

55+(.|) = unsafeBinaryOp "||"

56+

57+-- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`

58+(.!) :: null 'PGtsquery --> null 'PGtsquery

59+(.!) = unsafeLeftOp "!!"

60+

61+-- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by

62+-- `Squeal.PostgreSQL.Expression.Type.tsquery`

63+(<->) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)

64+(<->) = unsafeBinaryOp "<->"

65+

66+-- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector`

67+arrayToTSvector

68+ :: null ('PGvararray ('NotNull 'PGtext))

69+ --> null 'PGtsvector

70+arrayToTSvector = unsafeFunction "array_to_tsvector"

71+

72+-- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`

73+tsvectorLength :: null 'PGtsvector --> null 'PGint4

74+tsvectorLength = unsafeFunction "length"

75+

76+-- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`

77+numnode :: null 'PGtsquery --> null 'PGint4

78+numnode = unsafeFunction "numnode"

79+

80+-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation

81+plainToTSquery :: null 'PGtext --> null 'PGtsquery

82+plainToTSquery = unsafeFunction "plainto_tsquery"

83+

84+-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase,

85+-- ignoring punctuation

86+phraseToTSquery :: null 'PGtext --> null 'PGtsquery

87+phraseToTSquery = unsafeFunction "phraseto_tsquery"

88+

89+-- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query

90+websearchToTSquery :: null 'PGtext --> null 'PGtsquery

91+websearchToTSquery = unsafeFunction "websearch_to_tsquery"

92+

93+-- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`

94+queryTree :: null 'PGtsquery --> null 'PGtext

95+queryTree = unsafeFunction "query_tree"

96+

97+-- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`

98+toTSquery :: null 'PGtext --> null 'PGtsquery

99+toTSquery = unsafeFunction "to_tsquery"

100+

101+-- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector`

102+toTSvector

103+ :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]

104+ => null ty --> null 'PGtsvector

105+toTSvector = unsafeFunction "to_tsvector"

106+

107+-- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`

108+setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector

109+setWeight = unsafeFunctionN "set_weight"

110+

111+-- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`

112+strip :: null 'PGtsvector --> null 'PGtsvector

113+strip = unsafeFunction "strip"

114+

115+-- | @jsonToTSvector (document *: filter)@

116+-- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,

117+-- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.

118+-- filter is a `Squeal.PostgreSQL.Expression.Type.json` array, that enumerates what kind of elements

119+-- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.

120+-- Possible values for filter are "string" (to include all string values),

121+-- "numeric" (to include all numeric values in the string format),

122+-- "boolean" (to include all Boolean values in the string format "true"/"false"),

123+-- "key" (to include all keys) or "all" (to include all above).

124+-- These values can be combined together to include, e.g. all string and numeric values.

125+jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector

126+jsonToTSvector = unsafeFunctionN "json_to_tsvector"

127+

128+-- | @jsonbToTSvector (document *: filter)@

129+-- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,

130+-- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.

131+-- filter is a `Squeal.PostgreSQL.Expression.Type.jsonb` array, that enumerates what kind of elements

132+-- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.

133+-- Possible values for filter are "string" (to include all string values),

134+-- "numeric" (to include all numeric values in the string format),

135+-- "boolean" (to include all Boolean values in the string format "true"/"false"),

136+-- "key" (to include all keys) or "all" (to include all above).

137+-- These values can be combined together to include, e.g. all string and numeric values.

138+jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector

139+jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"

140+

141+-- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`

142+tsDelete ::

143+ '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]

144+ ---> null 'PGtsvector

145+tsDelete = unsafeFunctionN "ts_delete"

146+

147+-- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`

148+tsFilter ::

149+ '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]

150+ ---> null 'PGtsvector

151+tsFilter = unsafeFunctionN "ts_filter"

152+

153+-- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match

154+tsHeadline

155+ :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]

156+ => '[null document, null 'PGtsquery] ---> null 'PGtext

157+tsHeadline = unsafeFunctionN "ts_headline"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hsnew file+192

@@ -0,0 +1,192 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Time

3+Description: Date/Time expressions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Date/Time functions and operators

9+-}

10+

11+{-# LANGUAGE

12+ DataKinds

13+ , DeriveGeneric

14+ , FunctionalDependencies

15+ , LambdaCase

16+ , MultiParamTypeClasses

17+ , OverloadedStrings

18+ , PolyKinds

19+ , RankNTypes

20+ , TypeOperators

21+#-}

22+

23+module Squeal.PostgreSQL.Expression.Time

24+ ( TimeOp (..)

25+ , currentDate

26+ , currentTime

27+ , currentTimestamp

28+ , localTime

29+ , localTimestamp

30+ , now

31+ , makeDate

32+ , makeTime

33+ , makeTimestamp

34+ , makeTimestamptz

35+ , interval_

36+ , TimeUnit (..)

37+ ) where

38+

39+import Data.String

40+

41+import qualified GHC.Generics as GHC

42+import qualified Generics.SOP as SOP

43+

44+import Squeal.PostgreSQL.Expression

45+import Squeal.PostgreSQL.Render

46+import Squeal.PostgreSQL.Schema

47+

48+-- $setup

49+-- >>> import Squeal.PostgreSQL

50+

51+-- | >>> printSQL currentDate

52+-- CURRENT_DATE

53+currentDate :: Expr (null 'PGdate)

54+currentDate = UnsafeExpression "CURRENT_DATE"

55+

56+-- | >>> printSQL currentTime

57+-- CURRENT_TIME

58+currentTime :: Expr (null 'PGtimetz)

59+currentTime = UnsafeExpression "CURRENT_TIME"

60+

61+-- | >>> printSQL currentTimestamp

62+-- CURRENT_TIMESTAMP

63+currentTimestamp :: Expr (null 'PGtimestamptz)

64+currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"

65+

66+-- | >>> printSQL localTime

67+-- LOCALTIME

68+localTime :: Expr (null 'PGtime)

69+localTime = UnsafeExpression "LOCALTIME"

70+

71+-- | >>> printSQL localTimestamp

72+-- LOCALTIMESTAMP

73+localTimestamp :: Expr (null 'PGtimestamp)

74+localTimestamp = UnsafeExpression "LOCALTIMESTAMP"

75+

76+-- | Current date and time (equivalent to `currentTimestamp`)

77+--

78+-- >>> printSQL now

79+-- now()

80+now :: Expr (null 'PGtimestamptz)

81+now = UnsafeExpression "now()"

82+

83+{-|

84+Create date from year, month and day fields

85+

86+>>> printSQL (makeDate (1984 :* 7 *: 3))

87+make_date(1984, 7, 3)

88+-}

89+makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate

90+makeDate = unsafeFunctionN "make_date"

91+

92+{-|

93+Create time from hour, minute and seconds fields

94+

95+>>> printSQL (makeTime (8 :* 15 *: 23.5))

96+make_time(8, 15, 23.5)

97+-}

98+makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime

99+makeTime = unsafeFunctionN "make_time"

100+

101+{-|

102+Create timestamp from year, month, day, hour, minute and seconds fields

103+

104+>>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))

105+make_timestamp(2013, 7, 15, 8, 15, 23.5)

106+-}

107+makeTimestamp ::

108+ '[ null 'PGint4, null 'PGint4, null 'PGint4

109+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp

110+makeTimestamp = unsafeFunctionN "make_timestamp"

111+

112+{-|

113+Create timestamp with time zone from

114+year, month, day, hour, minute and seconds fields;

115+the current time zone is used

116+

117+>>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))

118+make_timestamptz(2013, 7, 15, 8, 15, 23.5)

119+-}

120+makeTimestamptz ::

121+ '[ null 'PGint4, null 'PGint4, null 'PGint4

122+ , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz

123+makeTimestamptz = unsafeFunctionN "make_timestamptz"

124+

125+{-|

126+Affine space operations on time types.

127+-}

128+class TimeOp time diff | time -> diff where

129+ {-|

130+ >>> printSQL (makeDate (1984 :* 7 *: 3) !+ 365)

131+ (make_date(1984, 7, 3) + 365)

132+ -}

133+ (!+) :: Operator (null time) (null diff) (null time)

134+ (!+) = unsafeBinaryOp "+"

135+ {-|

136+ >>> printSQL (365 +! makeDate (1984 :* 7 *: 3))

137+ (365 + make_date(1984, 7, 3))

138+ -}

139+ (+!) :: Operator (null diff) (null time) (null time)

140+ (+!) = unsafeBinaryOp "+"

141+ {-|

142+ >>> printSQL (makeDate (1984 :* 7 *: 3) !- 365)

143+ (make_date(1984, 7, 3) - 365)

144+ -}

145+ (!-) :: Operator (null time) (null diff) (null time)

146+ (!-) = unsafeBinaryOp "-"

147+ {-|

148+ >>> printSQL (makeDate (1984 :* 7 *: 3) !-! currentDate)

149+ (make_date(1984, 7, 3) - CURRENT_DATE)

150+ -}

151+ (!-!) :: Operator (null time) (null time) (null diff)

152+ (!-!) = unsafeBinaryOp "-"

153+instance TimeOp 'PGtimestamp 'PGinterval

154+instance TimeOp 'PGtimestamptz 'PGinterval

155+instance TimeOp 'PGtime 'PGinterval

156+instance TimeOp 'PGtimetz 'PGinterval

157+instance TimeOp 'PGinterval 'PGinterval

158+instance TimeOp 'PGdate 'PGint4

159+infixl 6 !+

160+infixl 6 +!

161+infixl 6 !-

162+infixl 6 !-!

163+

164+-- | A `TimeUnit` to use in `interval_` construction.

165+data TimeUnit

166+ = Years | Months | Weeks | Days

167+ | Hours | Minutes | Seconds

168+ | Microseconds | Milliseconds

169+ | Decades | Centuries | Millennia

170+ deriving (Eq, Ord, Show, Read, Enum, GHC.Generic)

171+instance SOP.Generic TimeUnit

172+instance SOP.HasDatatypeInfo TimeUnit

173+instance RenderSQL TimeUnit where

174+ renderSQL = \case

175+ Years -> "years"

176+ Months -> "months"

177+ Weeks -> "weeks"

178+ Days -> "days"

179+ Hours -> "hours"

180+ Minutes -> "minutes"

181+ Seconds -> "seconds"

182+ Microseconds -> "microseconds"

183+ Milliseconds -> "milliseconds"

184+ Decades -> "decades"

185+ Centuries -> "centuries"

186+ Millennia -> "millennia"

187+

188+-- | >>> printSQL $ interval_ 7 Days

189+-- (INTERVAL '7.0 days')

190+interval_ :: Double -> TimeUnit -> Expr (null 'PGinterval)

191+interval_ num unit = UnsafeExpression . parenthesized $ "INTERVAL" <+>

192+ "'" <> fromString (show num) <+> renderSQL unit <> "'"

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Type.hsnew file+446

@@ -0,0 +1,446 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression

3+Description: Type expressions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Type expressions.

9+-}

10+

11+{-# LANGUAGE

12+ AllowAmbiguousTypes

13+ , DataKinds

14+ , DeriveGeneric

15+ , FlexibleContexts

16+ , FlexibleInstances

17+ , GADTs

18+ , GeneralizedNewtypeDeriving

19+ , KindSignatures

20+ , MultiParamTypeClasses

21+ , OverloadedStrings

22+ , RankNTypes

23+ , ScopedTypeVariables

24+ , TypeApplications

25+ , TypeOperators

26+ , UndecidableInstances

27+#-}

28+

29+module Squeal.PostgreSQL.Expression.Type

30+ ( -- * type casting

31+ cast

32+ , astype

33+ , inferredtype

34+ -- * type expressions

35+ , TypeExpression (..)

36+ , typedef

37+ , typetable

38+ , typeview

39+ , bool

40+ , int2

41+ , smallint

42+ , int4

43+ , int

44+ , integer

45+ , int8

46+ , bigint

47+ , numeric

48+ , float4

49+ , real

50+ , float8

51+ , doublePrecision

52+ , money

53+ , text

54+ , char

55+ , character

56+ , varchar

57+ , characterVarying

58+ , bytea

59+ , timestamp

60+ , timestampWithTimeZone

61+ , timestamptz

62+ , date

63+ , time

64+ , timeWithTimeZone

65+ , timetz

66+ , interval

67+ , uuid

68+ , inet

69+ , json

70+ , jsonb

71+ , vararray

72+ , fixarray

73+ , tsvector

74+ , tsquery

75+ , oid

76+ , int4range

77+ , int8range

78+ , numrange

79+ , tsrange

80+ , tstzrange

81+ , daterange

82+ -- * column type definitions

83+ , ColumnTypeExpression (..)

84+ , nullable

85+ , notNullable

86+ , default_

87+ , serial2

88+ , smallserial

89+ , serial4

90+ , serial

91+ , serial8

92+ , bigserial

93+ , hask

94+ -- * type inference

95+ , PGTyped (..)

96+ , PGNullityTyped (..)

97+ , FieldTyped (..)

98+ ) where

99+

100+import Control.DeepSeq

101+import Data.ByteString

102+import Data.String

103+import GHC.TypeLits

104+

105+import qualified Data.ByteString as ByteString

106+import qualified GHC.Generics as GHC

107+import qualified Generics.SOP as SOP

108+

109+import Squeal.PostgreSQL.Alias

110+import Squeal.PostgreSQL.Expression

111+import Squeal.PostgreSQL.PG

112+import Squeal.PostgreSQL.Render

113+import Squeal.PostgreSQL.Schema

114+

115+-- $setup

116+-- >>> import Squeal.PostgreSQL

117+

118+-- When a `cast` is applied to an `Expression` of a known type, it

119+-- represents a run-time type conversion. The cast will succeed only if a

120+-- suitable type conversion operation has been defined.

121+--

122+-- | >>> printSQL $ true & cast int4

123+-- (TRUE :: int4)

124+cast

125+ :: TypeExpression schemas ty1

126+ -- ^ type to cast as

127+ -> Expression outer commons grp schemas params from ty0

128+ -- ^ value to convert

129+ -> Expression outer commons grp schemas params from ty1

130+cast ty x = UnsafeExpression $ parenthesized $

131+ renderSQL x <+> "::" <+> renderSQL ty

132+

133+-- | A safe version of `cast` which just matches a value with its type.

134+--

135+-- >>> printSQL (1 & astype int)

136+-- (1 :: int)

137+astype

138+ :: TypeExpression schemas ty

139+ -- ^ type to specify as

140+ -> Expression outer commons grp schemas params from ty

141+ -- ^ value

142+ -> Expression outer commons grp schemas params from ty

143+astype = cast

144+

145+-- | `inferredtype` will add a type annotation to an `Expression`

146+-- which can be useful for fixing the storage type of a value.

147+--

148+-- >>> printSQL (inferredtype true)

149+-- (TRUE :: bool)

150+inferredtype

151+ :: PGTyped schemas ty

152+ => Expression outer common grp schemas params from ty

153+ -- ^ value

154+ -> Expression outer common grp schemas params from ty

155+inferredtype = astype pgtype

156+

157+{-----------------------------------------

158+type expressions

159+-----------------------------------------}

160+

161+-- | `TypeExpression`s are used in `cast`s and

162+-- `Squeal.PostgreSQL.Definition.createTable` commands.

163+newtype TypeExpression (schemas :: SchemasType) (ty :: NullityType)

164+ = UnsafeTypeExpression { renderTypeExpression :: ByteString }

165+ deriving (GHC.Generic,Show,Eq,Ord,NFData)

166+instance RenderSQL (TypeExpression schemas ty) where

167+ renderSQL = renderTypeExpression

168+

169+-- | The enum or composite type in a `Typedef` can be expressed by its alias.

170+typedef

171+ :: (Has sch schemas schema, Has td schema ('Typedef ty))

172+ => QualifiedAlias sch td

173+ -- ^ type alias

174+ -> TypeExpression schemas (null ty)

175+typedef = UnsafeTypeExpression . renderSQL

176+

177+-- | The composite type corresponding to a `Table` definition can be expressed

178+-- by its alias.

179+typetable

180+ :: (Has sch schemas schema, Has tab schema ('Table table))

181+ => QualifiedAlias sch tab

182+ -- ^ table alias

183+ -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))

184+typetable = UnsafeTypeExpression . renderSQL

185+

186+-- | The composite type corresponding to a `View` definition can be expressed

187+-- by its alias.

188+typeview

189+ :: (Has sch schemas schema, Has vw schema ('View view))

190+ => QualifiedAlias sch vw

191+ -- ^ view alias

192+ -> TypeExpression schemas (null ('PGcomposite view))

193+typeview = UnsafeTypeExpression . renderSQL

194+

195+-- | logical Boolean (true/false)

196+bool :: TypeExpression schemas (null 'PGbool)

197+bool = UnsafeTypeExpression "bool"

198+-- | signed two-byte integer

199+int2, smallint :: TypeExpression schemas (null 'PGint2)

200+int2 = UnsafeTypeExpression "int2"

201+smallint = UnsafeTypeExpression "smallint"

202+-- | signed four-byte integer

203+int4, int, integer :: TypeExpression schemas (null 'PGint4)

204+int4 = UnsafeTypeExpression "int4"

205+int = UnsafeTypeExpression "int"

206+integer = UnsafeTypeExpression "integer"

207+-- | signed eight-byte integer

208+int8, bigint :: TypeExpression schemas (null 'PGint8)

209+int8 = UnsafeTypeExpression "int8"

210+bigint = UnsafeTypeExpression "bigint"

211+-- | arbitrary precision numeric type

212+numeric :: TypeExpression schemas (null 'PGnumeric)

213+numeric = UnsafeTypeExpression "numeric"

214+-- | single precision floating-point number (4 bytes)

215+float4, real :: TypeExpression schemas (null 'PGfloat4)

216+float4 = UnsafeTypeExpression "float4"

217+real = UnsafeTypeExpression "real"

218+-- | double precision floating-point number (8 bytes)

219+float8, doublePrecision :: TypeExpression schemas (null 'PGfloat8)

220+float8 = UnsafeTypeExpression "float8"

221+doublePrecision = UnsafeTypeExpression "double precision"

222+-- | currency amount

223+money :: TypeExpression schema (null 'PGmoney)

224+money = UnsafeTypeExpression "money"

225+-- | variable-length character string

226+text :: TypeExpression schemas (null 'PGtext)

227+text = UnsafeTypeExpression "text"

228+-- | fixed-length character string

229+char, character

230+ :: forall n schemas null. (KnownNat n, 1 <= n)

231+ => TypeExpression schemas (null ('PGchar n))

232+char = UnsafeTypeExpression $ "char(" <> renderNat @n <> ")"

233+character = UnsafeTypeExpression $ "character(" <> renderNat @n <> ")"

234+-- | variable-length character string

235+varchar, characterVarying

236+ :: forall n schemas null. (KnownNat n, 1 <= n)

237+ => TypeExpression schemas (null ('PGvarchar n))

238+varchar = UnsafeTypeExpression $ "varchar(" <> renderNat @n <> ")"

239+characterVarying = UnsafeTypeExpression $

240+ "character varying(" <> renderNat @n <> ")"

241+-- | binary data ("byte array")

242+bytea :: TypeExpression schemas (null 'PGbytea)

243+bytea = UnsafeTypeExpression "bytea"

244+-- | date and time (no time zone)

245+timestamp :: TypeExpression schemas (null 'PGtimestamp)

246+timestamp = UnsafeTypeExpression "timestamp"

247+-- | date and time, including time zone

248+timestampWithTimeZone, timestamptz :: TypeExpression schemas (null 'PGtimestamptz)

249+timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

250+timestamptz = UnsafeTypeExpression "timestamptz"

251+-- | calendar date (year, month, day)

252+date :: TypeExpression schemas (null 'PGdate)

253+date = UnsafeTypeExpression "date"

254+-- | time of day (no time zone)

255+time :: TypeExpression schemas (null 'PGtime)

256+time = UnsafeTypeExpression "time"

257+-- | time of day, including time zone

258+timeWithTimeZone, timetz :: TypeExpression schemas (null 'PGtimetz)

259+timeWithTimeZone = UnsafeTypeExpression "time with time zone"

260+timetz = UnsafeTypeExpression "timetz"

261+-- | time span

262+interval :: TypeExpression schemas (null 'PGinterval)

263+interval = UnsafeTypeExpression "interval"

264+-- | universally unique identifier

265+uuid :: TypeExpression schemas (null 'PGuuid)

266+uuid = UnsafeTypeExpression "uuid"

267+-- | IPv4 or IPv6 host address

268+inet :: TypeExpression schemas (null 'PGinet)

269+inet = UnsafeTypeExpression "inet"

270+-- | textual JSON data

271+json :: TypeExpression schemas (null 'PGjson)

272+json = UnsafeTypeExpression "json"

273+-- | binary JSON data, decomposed

274+jsonb :: TypeExpression schemas (null 'PGjsonb)

275+jsonb = UnsafeTypeExpression "jsonb"

276+-- | variable length array

277+vararray

278+ :: TypeExpression schemas pg

279+ -> TypeExpression schemas (null ('PGvararray pg))

280+vararray ty = UnsafeTypeExpression $ renderSQL ty <> "[]"

281+-- | fixed length array

282+--

283+-- >>> renderSQL (fixarray @'[2] json)

284+-- "json[2]"

285+fixarray

286+ :: forall dims schemas null pg. SOP.All KnownNat dims

287+ => TypeExpression schemas pg

288+ -> TypeExpression schemas (null ('PGfixarray dims pg))

289+fixarray ty = UnsafeTypeExpression $

290+ renderSQL ty <> renderDims @dims

291+ where

292+ renderDims :: forall ns. SOP.All KnownNat ns => ByteString

293+ renderDims =

294+ ("[" <>)

295+ . (<> "]")

296+ . ByteString.intercalate "]["

297+ . SOP.hcollapse

298+ $ SOP.hcmap (SOP.Proxy @KnownNat)

299+ (K . fromString . show . natVal)

300+ (SOP.hpure SOP.Proxy :: SOP.NP SOP.Proxy ns)

301+-- | text search query

302+tsvector :: TypeExpression schemas (null 'PGtsvector)

303+tsvector = UnsafeTypeExpression "tsvector"

304+-- | text search document

305+tsquery :: TypeExpression schemas (null 'PGtsquery)

306+tsquery = UnsafeTypeExpression "tsquery"

307+-- | Object identifiers (OIDs) are used internally by PostgreSQL

308+-- as primary keys for various system tables.

309+oid :: TypeExpression schemas (null 'PGoid)

310+oid = UnsafeTypeExpression "oid"

311+-- | Range of integer

312+int4range :: TypeExpression schemas (null ('PGrange 'PGint4))

313+int4range = UnsafeTypeExpression "int4range"

314+-- | Range of bigint

315+int8range :: TypeExpression schemas (null ('PGrange 'PGint8))

316+int8range = UnsafeTypeExpression "int8range"

317+-- | Range of numeric

318+numrange :: TypeExpression schemas (null ('PGrange 'PGnumeric))

319+numrange = UnsafeTypeExpression "numrange"

320+-- | Range of timestamp without time zone

321+tsrange :: TypeExpression schemas (null ('PGrange 'PGtimestamp))

322+tsrange = UnsafeTypeExpression "tsrange"

323+-- | Range of timestamp with time zone

324+tstzrange :: TypeExpression schemas (null ('PGrange 'PGtimestamptz))

325+tstzrange = UnsafeTypeExpression "tstzrange"

326+-- | Range of date

327+daterange :: TypeExpression schemas (null ('PGrange 'PGdate))

328+daterange = UnsafeTypeExpression "daterange"

329+

330+-- | `pgtype` is a demoted version of a `PGType`

331+class PGTyped schemas (ty :: NullityType) where

332+ pgtype :: TypeExpression schemas ty

333+instance PGTyped schemas (null 'PGbool) where pgtype = bool

334+instance PGTyped schemas (null 'PGint2) where pgtype = int2

335+instance PGTyped schemas (null 'PGint4) where pgtype = int4

336+instance PGTyped schemas (null 'PGint8) where pgtype = int8

337+instance PGTyped schemas (null 'PGnumeric) where pgtype = numeric

338+instance PGTyped schemas (null 'PGfloat4) where pgtype = float4

339+instance PGTyped schemas (null 'PGfloat8) where pgtype = float8

340+instance PGTyped schemas (null 'PGmoney) where pgtype = money

341+instance PGTyped schemas (null 'PGtext) where pgtype = text

342+instance (KnownNat n, 1 <= n)

343+ => PGTyped schemas (null ('PGchar n)) where pgtype = char @n

344+instance (KnownNat n, 1 <= n)

345+ => PGTyped schemas (null ('PGvarchar n)) where pgtype = varchar @n

346+instance PGTyped schemas (null 'PGbytea) where pgtype = bytea

347+instance PGTyped schemas (null 'PGtimestamp) where pgtype = timestamp

348+instance PGTyped schemas (null 'PGtimestamptz) where pgtype = timestampWithTimeZone

349+instance PGTyped schemas (null 'PGdate) where pgtype = date

350+instance PGTyped schemas (null 'PGtime) where pgtype = time

351+instance PGTyped schemas (null 'PGtimetz) where pgtype = timeWithTimeZone

352+instance PGTyped schemas (null 'PGinterval) where pgtype = interval

353+instance PGTyped schemas (null 'PGuuid) where pgtype = uuid

354+instance PGTyped schemas (null 'PGjson) where pgtype = json

355+instance PGTyped schemas (null 'PGjsonb) where pgtype = jsonb

356+instance PGTyped schemas ty

357+ => PGTyped schemas (null ('PGvararray ty)) where

358+ pgtype = vararray (pgtype @schemas @ty)

359+instance (SOP.All KnownNat dims, PGTyped schemas ty)

360+ => PGTyped schemas (null ('PGfixarray dims ty)) where

361+ pgtype = fixarray @dims (pgtype @schemas @ty)

362+instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector

363+instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery

364+instance PGTyped schemas (null 'PGoid) where pgtype = oid

365+instance PGTyped schemas (null ('PGrange 'PGint4)) where pgtype = int4range

366+instance PGTyped schemas (null ('PGrange 'PGint8)) where pgtype = int8range

367+instance PGTyped schemas (null ('PGrange 'PGnumeric)) where pgtype = numrange

368+instance PGTyped schemas (null ('PGrange 'PGtimestamp)) where pgtype = tsrange

369+instance PGTyped schemas (null ('PGrange 'PGtimestamptz)) where pgtype = tstzrange

370+instance PGTyped schemas (null ('PGrange 'PGdate)) where pgtype = daterange

371+

372+-- | Lift `PGTyped` to a field

373+class FieldTyped schemas ty where

374+ fieldtype :: Aliased (TypeExpression schemas) ty

375+instance (KnownSymbol alias, PGTyped schemas ty)

376+ => FieldTyped schemas (alias ::: ty) where

377+ fieldtype = pgtype `As` Alias

378+

379+-- | `ColumnTypeExpression`s are used in `createTable` commands.

380+newtype ColumnTypeExpression (schemas :: SchemasType) (ty :: ColumnType)

381+ = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }

382+ deriving (GHC.Generic,Show,Eq,Ord,NFData)

383+instance RenderSQL (ColumnTypeExpression schemas ty) where

384+ renderSQL = renderColumnTypeExpression

385+

386+-- | used in `createTable` commands as a column constraint to note that

387+-- @NULL@ may be present in a column

388+nullable

389+ :: TypeExpression schemas (nullity ty)

390+ -> ColumnTypeExpression schemas ('NoDef :=> 'Null ty)

391+nullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NULL"

392+

393+-- | used in `createTable` commands as a column constraint to ensure

394+-- @NULL@ is not present in a column

395+notNullable

396+ :: TypeExpression schemas (nullity ty)

397+ -> ColumnTypeExpression schemas ('NoDef :=> 'NotNull ty)

398+notNullable ty = UnsafeColumnTypeExpression $ renderSQL ty <+> "NOT NULL"

399+

400+-- | used in `createTable` commands as a column constraint to give a default

401+default_

402+ :: Expression '[] '[] 'Ungrouped schemas '[] '[] ty

403+ -> ColumnTypeExpression schemas ('NoDef :=> ty)

404+ -> ColumnTypeExpression schemas ('Def :=> ty)

405+default_ x ty = UnsafeColumnTypeExpression $

406+ renderSQL ty <+> "DEFAULT" <+> renderExpression x

407+

408+-- | not a true type, but merely a notational convenience for creating

409+-- unique identifier columns with type `PGint2`

410+serial2, smallserial

411+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint2)

412+serial2 = UnsafeColumnTypeExpression "serial2"

413+smallserial = UnsafeColumnTypeExpression "smallserial"

414+-- | not a true type, but merely a notational convenience for creating

415+-- unique identifier columns with type `PGint4`

416+serial4, serial

417+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint4)

418+serial4 = UnsafeColumnTypeExpression "serial4"

419+serial = UnsafeColumnTypeExpression "serial"

420+-- | not a true type, but merely a notational convenience for creating

421+-- unique identifier columns with type `PGint8`

422+serial8, bigserial

423+ :: ColumnTypeExpression schemas ('Def :=> 'NotNull 'PGint8)

424+serial8 = UnsafeColumnTypeExpression "serial8"

425+bigserial = UnsafeColumnTypeExpression "bigserial"

426+

427+-- | Like @PGTyped@ but also accounts for nullity.

428+class PGNullityTyped schemas (nullty :: NullityType) where

429+ pgNullityType :: ColumnTypeExpression schemas ('NoDef :=> nullty)

430+

431+instance PGTyped schemas ('Null ty) => PGNullityTyped schemas ('Null ty) where

432+ pgNullityType = nullable (pgtype @_ @('Null ty))

433+

434+instance PGTyped schemas ('NotNull ty) => PGNullityTyped schemas ('NotNull ty) where

435+ pgNullityType = notNullable (pgtype @_ @('NotNull ty))

436+

437+-- | Allow you to specify pg column types in relation to haskell types.

438+-- >>> printSQL $ hask @(Maybe String)

439+-- text NULL

440+--

441+-- >>> printSQL $ hask @Double

442+-- float8 NOT NULL

443+hask

444+ :: forall hask schemas. PGNullityTyped schemas (NullPG hask)

445+ => ColumnTypeExpression schemas ('NoDef :=> NullPG hask)

446+hask = pgNullityType

squeal-postgresql/src/Squeal/PostgreSQL/Expression/Window.hsnew file+284

@@ -0,0 +1,284 @@

1+{-|

2+Module: Squeal.PostgreSQL.Expression.Window

3+Description: Window functions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Window functions and definitions

9+-}

10+

11+{-# LANGUAGE

12+ DataKinds

13+ , DeriveGeneric

14+ , FlexibleContexts

15+ , FlexibleInstances

16+ , GADTs

17+ , GeneralizedNewtypeDeriving

18+ , LambdaCase

19+ , MultiParamTypeClasses

20+ , OverloadedStrings

21+ , RankNTypes

22+ , KindSignatures

23+#-}

24+

25+module Squeal.PostgreSQL.Expression.Window

26+ ( -- * functions

27+ partitionBy

28+ , rank

29+ , rowNumber

30+ , denseRank

31+ , percentRank

32+ , cumeDist

33+ , ntile

34+ , lag

35+ , lead

36+ , firstValue

37+ , lastValue

38+ , nthValue

39+ , unsafeWindowFunction1

40+ , unsafeWindowFunctionN

41+ -- * types

42+ , WindowFunction (..)

43+ , WindowDefinition (..)

44+ , WinFun0

45+ , WinFun1

46+ , WinFunN

47+ ) where

48+

49+import Control.DeepSeq

50+import Data.ByteString

51+

52+import qualified GHC.Generics as GHC

53+import qualified Generics.SOP as SOP

54+

55+import Squeal.PostgreSQL.Alias

56+import Squeal.PostgreSQL.Expression

57+import Squeal.PostgreSQL.Expression.Aggregate

58+import Squeal.PostgreSQL.Expression.Sort

59+import Squeal.PostgreSQL.List

60+import Squeal.PostgreSQL.Render

61+import Squeal.PostgreSQL.Schema

62+

63+instance Aggregate

64+ (Expression outer commons grp schemas params from)

65+ (NP (Expression outer commons grp schemas params from))

66+ (WindowFunction outer commons grp schemas params from) where

67+ countStar = UnsafeWindowFunction "count(*)"

68+ count = unsafeWindowFunction1 "count"

69+ sum_ = unsafeWindowFunction1 "sum"

70+ arrayAgg = unsafeWindowFunction1 "array_agg"

71+ jsonAgg = unsafeWindowFunction1 "json_agg"

72+ jsonbAgg = unsafeWindowFunction1 "jsonb_agg"

73+ bitAnd = unsafeWindowFunction1 "bit_and"

74+ bitOr = unsafeWindowFunction1 "bit_or"

75+ boolAnd = unsafeWindowFunction1 "bool_and"

76+ boolOr = unsafeWindowFunction1 "bool_or"

77+ every = unsafeWindowFunction1 "every"

78+ max_ = unsafeWindowFunction1 "max"

79+ min_ = unsafeWindowFunction1 "min"

80+ avg = unsafeWindowFunction1 "avg"

81+ corr = unsafeWindowFunctionN "corr"

82+ covarPop = unsafeWindowFunctionN "covar_pop"

83+ covarSamp = unsafeWindowFunctionN "covar_samp"

84+ regrAvgX = unsafeWindowFunctionN "regr_avgx"

85+ regrAvgY = unsafeWindowFunctionN "regr_avgy"

86+ regrCount = unsafeWindowFunctionN "regr_count"

87+ regrIntercept = unsafeWindowFunctionN "regr_intercept"

88+ regrR2 = unsafeWindowFunctionN "regr_r2"

89+ regrSlope = unsafeWindowFunctionN "regr_slope"

90+ regrSxx = unsafeWindowFunctionN "regr_sxx"

91+ regrSxy = unsafeWindowFunctionN "regr_sxy"

92+ regrSyy = unsafeWindowFunctionN "regr_syy"

93+ stddev = unsafeWindowFunction1 "stddev"

94+ stddevPop = unsafeWindowFunction1 "stddev_pop"

95+ stddevSamp = unsafeWindowFunction1 "stddev_samp"

96+ variance = unsafeWindowFunction1 "variance"

97+ varPop = unsafeWindowFunction1 "var_pop"

98+ varSamp = unsafeWindowFunction1 "var_samp"

99+

100+-- | A `WindowDefinition` is a set of table rows that are somehow related

101+-- to the current row

102+data WindowDefinition outer commons grp schemas params from where

103+ WindowDefinition

104+ :: SOP.SListI bys

105+ => NP (Expression outer commons grp schemas params from) bys

106+ -- ^ `partitionBy` clause

107+ -> [SortExpression outer commons grp schemas params from]

108+ -- ^ `Squeal.PostgreSQL.Expression.Sort.orderBy` clause

109+ -> WindowDefinition outer commons grp schemas params from

110+

111+instance OrderBy WindowDefinition where

112+ orderBy sortsR (WindowDefinition parts sortsL)

113+ = WindowDefinition parts (sortsL ++ sortsR)

114+

115+instance RenderSQL (WindowDefinition outer commons schemas from grp params) where

116+ renderSQL (WindowDefinition part ord) =

117+ renderPartitionByClause part <> renderOrderByClause ord

118+ where

119+ renderPartitionByClause = \case

120+ Nil -> ""

121+ parts -> "PARTITION" <+> "BY" <+> renderCommaSeparated renderExpression parts

122+ renderOrderByClause = \case

123+ [] -> ""

124+ srts -> " ORDER" <+> "BY"

125+ <+> commaSeparated (renderSQL <$> srts)

126+

127+{- |

128+The `partitionBy` clause within `Squeal.PostgreSQL.Query.Over` divides the rows into groups,

129+or partitions, that share the same values of the `partitionBy` `Expression`(s).

130+For each row, the window function is computed across the rows that fall into

131+the same partition as the current row.

132+-}

133+partitionBy

134+ :: SOP.SListI bys

135+ => NP (Expression outer commons grp schemas params from) bys -- ^ partitions

136+ -> WindowDefinition outer commons grp schemas params from

137+partitionBy bys = WindowDefinition bys []

138+

139+{- |

140+A window function performs a calculation across a set of table rows

141+that are somehow related to the current row. This is comparable to the type

142+of calculation that can be done with an aggregate function.

143+However, window functions do not cause rows to become grouped into a single

144+output row like non-window aggregate calls would.

145+Instead, the rows retain their separate identities.

146+Behind the scenes, the window function is able to access more than

147+just the current row of the query result.

148+-}

149+newtype WindowFunction

150+ (outer :: FromType)

151+ (commons :: FromType)

152+ (grp :: Grouping)

153+ (schemas :: SchemasType)

154+ (params :: [NullityType])

155+ (from :: FromType)

156+ (ty :: NullityType)

157+ = UnsafeWindowFunction { renderWindowFunction :: ByteString }

158+ deriving (GHC.Generic,Show,Eq,Ord,NFData)

159+

160+instance RenderSQL (WindowFunction outer commons grp schemas params from ty) where

161+ renderSQL = renderWindowFunction

162+

163+{- |

164+A @RankNType@ for window functions with no arguments.

165+-}

166+type WinFun0 x

167+ = forall outer commons grp schemas params from

168+ . WindowFunction outer commons grp schemas params from x

169+ -- ^ cannot reference aliases

170+

171+{- |

172+A @RankNType@ for window functions with 1 argument.

173+-}

174+type WinFun1 x y

175+ = forall outer commons grp schemas params from

176+ . Expression outer commons grp schemas params from x

177+ -- ^ input

178+ -> WindowFunction outer commons grp schemas params from y

179+ -- ^ output

180+

181+{- | A @RankNType@ for window functions with a fixed-length

182+list of heterogeneous arguments.

183+Use the `*:` operator to end your argument lists.

184+-}

185+type WinFunN xs y

186+ = forall outer commons grp schemas params from

187+ . NP (Expression outer commons grp schemas params from) xs

188+ -- ^ inputs

189+ -> WindowFunction outer commons grp schemas params from y

190+ -- ^ output

191+

192+-- | escape hatch for defining window functions

193+unsafeWindowFunction1 :: ByteString -> WinFun1 x y

194+unsafeWindowFunction1 fun x

195+ = UnsafeWindowFunction $ fun <> parenthesized (renderSQL x)

196+

197+-- | escape hatch for defining multi-argument window functions

198+unsafeWindowFunctionN :: SOP.SListI xs => ByteString -> WinFunN xs y

199+unsafeWindowFunctionN fun xs = UnsafeWindowFunction $ fun <>

200+ parenthesized (renderCommaSeparated renderSQL xs)

201+

202+{- | rank of the current row with gaps; same as `rowNumber` of its first peer

203+

204+>>> printSQL rank

205+rank()

206+-}

207+rank :: WinFun0 ('NotNull 'PGint8)

208+rank = UnsafeWindowFunction "rank()"

209+

210+{- | number of the current row within its partition, counting from 1

211+

212+>>> printSQL rowNumber

213+row_number()

214+-}

215+rowNumber :: WinFun0 ('NotNull 'PGint8)

216+rowNumber = UnsafeWindowFunction "row_number()"

217+

218+{- | rank of the current row without gaps; this function counts peer groups

219+

220+>>> printSQL denseRank

221+dense_rank()

222+-}

223+denseRank :: WinFun0 ('NotNull 'PGint8)

224+denseRank = UnsafeWindowFunction "dense_rank()"

225+

226+{- | relative rank of the current row: (rank - 1) / (total partition rows - 1)

227+

228+>>> printSQL percentRank

229+percent_rank()

230+-}

231+percentRank :: WinFun0 ('NotNull 'PGfloat8)

232+percentRank = UnsafeWindowFunction "percent_rank()"

233+

234+{- | cumulative distribution: (number of partition rows

235+preceding or peer with current row) / total partition rows

236+

237+>>> printSQL cumeDist

238+cume_dist()

239+-}

240+cumeDist :: WinFun0 ('NotNull 'PGfloat8)

241+cumeDist = UnsafeWindowFunction "cume_dist()"

242+

243+{- | integer ranging from 1 to the argument value,

244+dividing the partition as equally as possible

245+

246+>>> printSQL $ ntile 5

247+ntile(5)

248+-}

249+ntile :: WinFun1 ('NotNull 'PGint4) ('NotNull 'PGint4)

250+ntile = unsafeWindowFunction1 "ntile"

251+

252+{- | returns value evaluated at the row that is offset rows before the current

253+row within the partition; if there is no such row, instead return default

254+(which must be of the same type as value). Both offset and default are

255+evaluated with respect to the current row.

256+-}

257+lag :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty

258+lag = unsafeWindowFunctionN "lag"

259+

260+{- | returns value evaluated at the row that is offset rows after the current

261+row within the partition; if there is no such row, instead return default

262+(which must be of the same type as value). Both offset and default are

263+evaluated with respect to the current row.

264+-}

265+lead :: WinFunN '[ty, 'NotNull 'PGint4, ty] ty

266+lead = unsafeWindowFunctionN "lead"

267+

268+{- | returns value evaluated at the row that is the

269+first row of the window frame

270+-}

271+firstValue :: WinFun1 ty ty

272+firstValue = unsafeWindowFunction1 "first_value"

273+

274+{- | returns value evaluated at the row that is the

275+last row of the window frame

276+-}

277+lastValue :: WinFun1 ty ty

278+lastValue = unsafeWindowFunction1 "last_value"

279+

280+{- | returns value evaluated at the row that is the nth

281+row of the window frame (counting from 1); null if no such row

282+-}

283+nthValue :: WinFunN '[null ty, 'NotNull 'PGint4] ('Null ty)

284+nthValue = unsafeWindowFunctionN "nth_value"

squeal-postgresql/src/Squeal/PostgreSQL/List.hsnew file+112

@@ -0,0 +1,112 @@

1+{-|

2+Module: Squeal.PostgreSQL.List

3+Description: List related types and functions

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Haskell singly-linked lists are very powerful. This module

9+provides functionality for type-level lists, heterogeneous

10+lists and type aligned lists.

11+-}

12+

13+{-# LANGUAGE

14+ DataKinds

15+ , FlexibleContexts

16+ , GADTs

17+ , LambdaCase

18+ , MultiParamTypeClasses

19+ , OverloadedStrings

20+ , PolyKinds

21+ , QuantifiedConstraints

22+ , RankNTypes

23+ , ScopedTypeVariables

24+ , TypeApplications

25+ , TypeFamilies

26+ , TypeOperators

27+ , UndecidableInstances

28+#-}

29+

30+module Squeal.PostgreSQL.List

31+ ( SOP.NP (..)

32+ , (*:)

33+ , Join

34+ , disjoin

35+ , Additional (..)

36+ , Path (..)

37+ , CFunctor (..)

38+ , CFoldable (..)

39+ , CFree (..)

40+ , Elem

41+ , In

42+ , Length

43+ ) where

44+

45+import Control.Category.Free

46+import Data.Function ((&))

47+import Data.Kind

48+import Data.Type.Bool

49+import GHC.TypeLits

50+

51+import Generics.SOP as SOP

52+

53+-- | `Join` is simply promoted `++` and is used in @JOIN@s in

54+-- `Squeal.PostgreSQL.Query.FromClause`s.

55+type family Join xs ys where

56+ Join '[] ys = ys

57+ Join (x ': xs) ys = x ': Join xs ys

58+

59+-- | `disjoin` is a utility function for splitting an `NP` list into pieces.

60+disjoin

61+ :: forall xs ys expr. SListI xs

62+ => NP expr (Join xs ys)

63+ -> (NP expr xs, NP expr ys)

64+disjoin = case sList @xs of

65+ SNil -> \ys -> (Nil, ys)

66+ SCons -> \(x :* xsys) ->

67+ case disjoin xsys of (xs,ys) -> (x :* xs, ys)

68+

69+-- | The `Additional` class is for appending

70+-- type-level list parameterized constructors such as `NP`,

71+-- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`.

72+class Additional expr where

73+ also :: expr ys -> expr xs -> expr (Join xs ys)

74+instance Additional (NP expr) where

75+ also ys = \case

76+ Nil -> ys

77+ x :* xs -> x :* (xs & also ys)

78+

79+-- | A useful operator for ending an `NP` list of length at least 2 without `Nil`.

80+(*:) :: f x -> f y -> NP f '[x,y]

81+x *: y = x :* y :* Nil

82+infixl 9 *:

83+

84+-- | @Elem@ is a promoted `Data.List.elem`.

85+type family Elem x xs where

86+ Elem x '[] = 'False

87+ Elem x (x ': _) = 'True

88+ Elem x (_ ': x ': _) = 'True

89+ Elem x (_ ': _ ': x ': _) = 'True

90+ Elem x (_ ': _ ': _ ': x ': _) = 'True

91+ Elem x (_ ': _ ': _ ': _ ': x ': _) = 'True

92+ Elem x (_ ': _ ': _ ': _ ': _ ': x ': _) = 'True

93+ Elem x (_ ': xs) = Elem x xs

94+

95+-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.

96+type family In x xs :: Constraint where

97+ In x xs = If (Elem x xs) (() :: Constraint)

98+ (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs))

99+

100+{- | Calculate the `Length` of a type level list

101+

102+>>> :kind! Length '[Char,String,Bool,Double]

103+Length '[Char,String,Bool,Double] :: Nat

104+= 4

105+-}

106+type family Length (xs :: [k]) :: Nat where

107+ Length (_ ': _ ': _ ': _ ': _ : xs) = 5 + Length xs

108+ Length (_ ': _ ': _ ': _ : xs) = 4 + Length xs

109+ Length (_ ': _ ': _ : xs) = 3 + Length xs

110+ Length (_ ': _ : xs) = 2 + Length xs

111+ Length (_ : xs) = 1 + Length xs

112+ Length '[] = 0

squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+422−348

@@ -11,310 +11,369 @@ Squeal data manipulation language.

1111{-# LANGUAGE

1212 DeriveGeneric

1313 , FlexibleContexts

14+ , FlexibleInstances

1415 , GADTs

1516 , GeneralizedNewtypeDeriving

1617 , LambdaCase

18+ , MultiParamTypeClasses

1719 , OverloadedStrings

20+ , PatternSynonyms

21+ , QuantifiedConstraints

1822 , RankNTypes

23+ , ScopedTypeVariables

24+ , TypeApplications

25+ , TypeFamilies

1926 , TypeInType

2027 , TypeOperators

28+ , UndecidableInstances

2129#-}

2230

2331module Squeal.PostgreSQL.Manipulation

2432 ( -- * Manipulation

25− Manipulation (UnsafeManipulation, renderManipulation)

33+ Manipulation_

34+ , Manipulation (..)

2635 , queryStatement

27− , ColumnValue (..)

28− , ReturningClause (ReturningStar, Returning)

29− , ConflictClause (OnConflictDoRaise, OnConflictDoNothing, OnConflictDoUpdate)

3036 -- * Insert

31− , insertRows

32− , insertRow

33− , insertRows_

34− , insertRow_

35− , insertQuery

36− , insertQuery_

37− , renderReturningClause

38− , renderConflictClause

37+ , insertInto

38+ , insertInto_

3939 -- * Update

4040 , update

4141 , update_

4242 -- * Delete

4343 , deleteFrom

4444 , deleteFrom_

45− -- * With

46− , with

45+ -- * Clauses

46+ , Optional (..)

47+ , QueryClause (..)

48+ , pattern Values_

49+ , ReturningClause (..)

50+ , pattern Returning_

51+ , ConflictClause (..)

52+ , ConflictTarget (..)

53+ , ConflictAction (..)

54+ , UsingClause (..)

4755 ) where

4856

4957import Control.DeepSeq

5058import Data.ByteString hiding (foldr)

51−import Data.Monoid

59+import Data.Kind (Type)

5260

5361import qualified Generics.SOP as SOP

5462import qualified GHC.Generics as GHC

5563

64+import Squeal.PostgreSQL.Alias

5665import Squeal.PostgreSQL.Expression

66+import Squeal.PostgreSQL.Expression.Logic

67+import Squeal.PostgreSQL.List

68+import Squeal.PostgreSQL.PG

5769import Squeal.PostgreSQL.Render

5870import Squeal.PostgreSQL.Query

5971import Squeal.PostgreSQL.Schema

6072

73+-- $setup

74+-- >>> import Squeal.PostgreSQL

75+-- >>> import Data.Int

76+-- >>> import Data.Time

77+

6178{- |

6279A `Manipulation` is a statement which may modify data in the database,

63−but does not alter the schema. Examples are inserts, updates and deletes.

80+but does not alter its schemas. Examples are inserts, updates and deletes.

6481A `Query` is also considered a `Manipulation` even though it does not modify data.

6582

83+The general `Manipulation` type is parameterized by

84+

85+* @commons :: FromType@ - scope for all `common` table expressions,

86+* @schemas :: SchemasType@ - scope for all `table`s and `view`s,

87+* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,

88+* @row :: RowType@ - return type of the `Query`.

89+-}

90+newtype Manipulation

91+ (commons :: FromType)

92+ (schemas :: SchemasType)

93+ (params :: [NullityType])

94+ (columns :: RowType)

95+ = UnsafeManipulation { renderManipulation :: ByteString }

96+ deriving (GHC.Generic,Show,Eq,Ord,NFData)

97+instance RenderSQL (Manipulation commons schemas params columns) where

98+ renderSQL = renderManipulation

99+instance With Manipulation where

100+ with Done manip = manip

101+ with ctes manip = UnsafeManipulation $

102+ "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL manip

103+

104+{- |

105+The top level `Manipulation_` type is parameterized by a @schemas@ `SchemasType`,

106+against which the query is type-checked, an input @parameters@ Haskell `Type`,

107+and an ouput row Haskell `Type`.

108+

109+A top-level `Manipulation_` can be run

110+using `Squeal.PostgreSQL.PQ.manipulateParams`, or if @parameters = ()@

111+using `Squeal.PostgreSQL.PQ.manipulate`.

112+

113+Generally, @parameters@ will be a Haskell tuple or record whose entries

114+may be referenced using positional

115+`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a

116+Haskell record, whose entries will be targeted using overloaded labels.

117+

118+>>> :set -XDeriveAnyClass -XDerivingStrategies

119+>>> :{

120+data Row a b = Row { col1 :: a, col2 :: b }

121+ deriving stock (GHC.Generic)

122+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)

123+:}

124+

66125simple insert:

67126

127+>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]

128+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]

68129>>> :{

69130let

70− manipulation :: Manipulation

71− '[ "tab" ::: 'Table ('[] :=>

72− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

73− , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[] '[]

131+ manipulation :: Manipulation_ (Public Schema) () ()

74132 manipulation =

75− insertRow_ #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil)

76−in renderManipulation manipulation

133+ insertInto_ #tab (Values_ (Set 2 `as` #col1 :* Default `as` #col2))

134+in printSQL manipulation

77135:}

78−"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT)"

136+INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)

79137

80138parameterized insert:

81139

140+>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]

141+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]

82142>>> :{

83143let

84− manipulation :: Manipulation

85− '[ "tab" ::: 'Table ('[] :=>

86− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

87− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]

88− '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]

144+ manipulation :: Manipulation_ (Public Schema) (Int32, Int32) ()

89145 manipulation =

90− insertRow_ #tab

91− (Set (param @1) `As` #col1 :* Set (param @2) `As` #col2 :* Nil)

92−in renderManipulation manipulation

146+ insertInto_ #tab (Values_ (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2))

147+in printSQL manipulation

93148:}

94−"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (($1 :: int4), ($2 :: int4))"

149+INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))

95150

96151returning insert:

97152

98153>>> :{

99154let

100− manipulation :: Manipulation

101− '[ "tab" ::: 'Table ('[] :=>

102− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

103− , "col2" ::: 'Def :=> 'NotNull 'PGint4 ])] '[]

104− '["fromOnly" ::: 'NotNull 'PGint4]

155+ manipulation :: Manipulation_ (Public Schema) () (Only Int32)

105156 manipulation =

106− insertRow #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil)

107− OnConflictDoRaise (Returning (#col1 `As` #fromOnly :* Nil))

108−in renderManipulation manipulation

157+ insertInto #tab (Values_ (Set 2 `as` #col1 :* Set 3 `as` #col2))

158+ OnConflictDoRaise (Returning (#col1 `as` #fromOnly))

159+in printSQL manipulation

109160:}

110−"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT) RETURNING \"col1\" AS \"fromOnly\""

161+INSERT INTO "tab" ("col1", "col2") VALUES (2, 3) RETURNING "col1" AS "fromOnly"

111162

112163upsert:

113164

165+>>> type CustomersColumns = '["name" ::: 'NoDef :=> 'NotNull 'PGtext, "email" ::: 'NoDef :=> 'NotNull 'PGtext]

166+>>> type CustomersConstraints = '["uq" ::: 'Unique '["name"]]

167+>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)]

114168>>> :{

115169let

116− manipulation :: Manipulation

117− '[ "tab" ::: 'Table ('[] :=>

118− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

119− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]

120− '[] '[ "sum" ::: 'NotNull 'PGint4]

170+ manipulation :: Manipulation_ (Public CustomersSchema) () ()

121171 manipulation =

122− insertRows #tab

123− (Set 2 `As` #col1 :* Set 4 `As` #col2 :* Nil)

124− [Set 6 `As` #col1 :* Set 8 `As` #col2 :* Nil]

125− (OnConflictDoUpdate

126− (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)

127− [#col1 .== #col2])

128− (Returning $ (#col1 + #col2) `As` #sum :* Nil)

129−in renderManipulation manipulation

172+ insertInto #customers

173+ (Values_ (Set "John Smith" `as` #name :* Set "john@smith.com" `as` #email))

174+ (OnConflict (OnConstraint #uq)

175+ (DoUpdate (Set (#excluded ! #email <> "; " <> #customers ! #email) `as` #email) []))

176+ (Returning_ Nil)

177+in printSQL manipulation

130178:}

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\""

179+INSERT INTO "customers" ("name", "email") VALUES (E'John Smith', E'john@smith.com') ON CONFLICT ON CONSTRAINT "uq" DO UPDATE SET "email" = ("excluded"."email" || (E'; ' || "customers"."email"))

132180

133181query insert:

134182

135183>>> :{

136184let

137− manipulation :: Manipulation

138− '[ "tab" ::: 'Table ('[] :=>

139− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

140− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4

141− ])

142− , "other_tab" ::: 'Table ('[] :=>

143− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

144− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4

145− ])

146− ] '[] '[]

147− manipulation =

148− insertQuery_ #tab

149− (selectStar (from (table (#other_tab `As` #t))))

150−in renderManipulation manipulation

185+ manipulation :: Manipulation_ (Public Schema) () ()

186+ manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab))))

187+in printSQL manipulation

151188:}

152−"INSERT INTO \"tab\" SELECT * FROM \"other_tab\" AS \"t\""

189+INSERT INTO "tab" SELECT * FROM "tab" AS "tab"

153190

154191update:

155192

156193>>> :{

157194let

158− manipulation :: Manipulation

159− '[ "tab" ::: 'Table ('[] :=>

160− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

161− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[]

162− manipulation =

163− update_ #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)

164− (#col1 ./= #col2)

165−in renderManipulation manipulation

195+ manipulation :: Manipulation_ (Public Schema) () ()

196+ manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)

197+in printSQL manipulation

166198:}

167−"UPDATE \"tab\" SET \"col1\" = 2 WHERE (\"col1\" <> \"col2\")"

199+UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")

168200

169201delete:

170202

171203>>> :{

172204let

173− manipulation :: Manipulation

174− '[ "tab" ::: 'Table ('[] :=>

175− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

176− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[]

177− '[ "col1" ::: 'NotNull 'PGint4

178− , "col2" ::: 'NotNull 'PGint4 ]

179− manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar

180−in renderManipulation manipulation

205+ manipulation :: Manipulation_ (Public Schema) () (Row Int32 Int32)

206+ manipulation = deleteFrom #tab NoUsing (#col1 .== #col2) (Returning Star)

207+in printSQL manipulation

181208:}

182−"DELETE FROM \"tab\" WHERE (\"col1\" = \"col2\") RETURNING *"

209+DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING *

210+

211+delete and using clause:

212+

213+>>> :{

214+type Schema3 =

215+ '[ "tab" ::: 'Table ('[] :=> Columns)

216+ , "other_tab" ::: 'Table ('[] :=> Columns)

217+ , "third_tab" ::: 'Table ('[] :=> Columns) ]

218+:}

219+

220+>>> :{

221+let

222+ manipulation :: Manipulation_ (Public Schema3) () ()

223+ manipulation =

224+ deleteFrom #tab (Using (table #other_tab & also (table #third_tab)))

225+ ( (#tab ! #col2 .== #other_tab ! #col2)

226+ .&& (#tab ! #col2 .== #third_tab ! #col2) )

227+ (Returning_ Nil)

228+in printSQL manipulation

229+:}

230+DELETE FROM "tab" USING "other_tab" AS "other_tab", "third_tab" AS "third_tab" WHERE (("tab"."col2" = "other_tab"."col2") AND ("tab"."col2" = "third_tab"."col2"))

231+

232+with manipulation:

233+

234+>>> type ProductsColumns = '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]

235+>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]

236+>>> :{

237+let

238+ manipulation :: Manipulation_ (Public ProductsSchema) (Only Day) ()

239+ manipulation = with

240+ (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del)

241+ (insertInto_ #products_deleted (Subquery (select Star (from (common #del)))))

242+in printSQL manipulation

243+:}

244+WITH "del" AS (DELETE FROM "products" WHERE ("date" < ($1 :: date)) RETURNING *) INSERT INTO "products_deleted" SELECT * FROM "del" AS "del"

183245-}

184−newtype Manipulation

185− (schema :: SchemaType)

186− (params :: [NullityType])

187− (columns :: RelationType)

188− = UnsafeManipulation { renderManipulation :: ByteString }

189− deriving (GHC.Generic,Show,Eq,Ord,NFData)

246+type family Manipulation_ (schemas :: SchemasType) (params :: Type) (row :: Type) where

247+ Manipulation_ schemas params row = Manipulation '[] schemas (TuplePG params) (RowPG row)

190248

191249-- | Convert a `Query` into a `Manipulation`.

192250queryStatement

193− :: Query schema params columns

194− -> Manipulation schema params columns

195−queryStatement q = UnsafeManipulation $ renderQuery q

251+ :: Query '[] commons schemas params columns

252+ -- ^ `Query` to embed as a `Manipulation`

253+ -> Manipulation commons schemas params columns

254+queryStatement q = UnsafeManipulation $ renderSQL q

196255

197256{-----------------------------------------

198257INSERT statements

199258-----------------------------------------}

200259

201−-- | Insert multiple rows.

202−--

203−-- When a table is created, it contains no data. The first thing to do

204−-- before a database can be of much use is to insert data. Data is

205−-- conceptually inserted one row at a time. Of course you can also insert

206−-- more than one row, but there is no way to insert less than one row.

207−-- Even if you know only some column values, a complete row must be created.

208−insertRows

209− :: ( SOP.SListI columns

210− , SOP.SListI results

211− , Has tab schema ('Table table)

212− , columns ~ TableToColumns table )

213− => Alias tab -- ^ table to insert into

214− -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert

215− -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert

216− -> ConflictClause schema columns params

217− -- ^ what to do in case of constraint conflict

218− -> ReturningClause schema columns params results -- ^ results to return

219− -> Manipulation schema params results

220−insertRows tab rw rws conflict returning = UnsafeManipulation $

221− "INSERT" <+> "INTO" <+> renderAlias tab

222− <+> parenthesized (renderCommaSeparated renderAliasPart rw)

223− <+> "VALUES"

224− <+> commaSeparated

225− ( parenthesized

226− . renderCommaSeparated renderColumnValuePart <$> rw:rws )

227− <> renderConflictClause conflict

228− <> renderReturningClause returning

229− where

230− renderAliasPart, renderColumnValuePart

231− :: Aliased (ColumnValue schema '[] params) ty -> ByteString

232− renderAliasPart (_ `As` name) = renderAlias name

233− renderColumnValuePart (value `As` _) = case value of

234− Default -> "DEFAULT"

235− Set expression -> renderExpression expression

236−

237−-- | Insert a single row.

238−insertRow

239− :: ( SOP.SListI columns

240− , SOP.SListI results

241− , Has tab schema ('Table table)

242− , columns ~ TableToColumns table )

243− => Alias tab -- ^ table to insert into

244− -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert

245− -> ConflictClause schema columns params

246− -- ^ what to do in case of constraint conflict

247− -> ReturningClause schema columns params results -- ^ results to return

248− -> Manipulation schema params results

249−insertRow tab rw = insertRows tab rw []

250−

251−-- | Insert multiple rows returning `Nil` and raising an error on conflicts.

252−insertRows_

253− :: ( SOP.SListI columns

254− , Has tab schema ('Table table)

255− , columns ~ TableToColumns table )

256− => Alias tab -- ^ table to insert into

257− -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert

258− -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert

259− -> Manipulation schema params '[]

260−insertRows_ tab rw rws =

261− insertRows tab rw rws OnConflictDoRaise (Returning Nil)

262−

263−-- | Insert a single row returning `Nil` and raising an error on conflicts.

264−insertRow_

265− :: ( SOP.SListI columns

266− , Has tab schema ('Table table)

267− , columns ~ TableToColumns table )

268− => Alias tab -- ^ table to insert into

269− -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert

270− -> Manipulation schema params '[]

271−insertRow_ tab rw = insertRow tab rw OnConflictDoRaise (Returning Nil)

272−

273−-- | Insert a `Query`.

274−insertQuery

275− :: ( SOP.SListI columns

276− , SOP.SListI results

260+{- |

261+When a table is created, it contains no data. The first thing to do

262+before a database can be of much use is to insert data. Data is

263+conceptually inserted one row at a time. Of course you can also insert

264+more than one row, but there is no way to insert less than one row.

265+Even if you know only some column values, a complete row must be created.

266+-}

267+insertInto

268+ :: ( Has sch schemas schema

277269 , Has tab schema ('Table table)

278− , columns ~ TableToColumns table )

279− => Alias tab -- ^ table to insert into

280− -> Query schema params (ColumnsToRelation columns)

281− -> ConflictClause schema columns params

282− -- ^ what to do in case of constraint conflict

283− -> ReturningClause schema columns params results -- ^ results to return

284− -> Manipulation schema params results

285−insertQuery tab query conflict returning = UnsafeManipulation $

286− "INSERT" <+> "INTO" <+> renderAlias tab

287− <+> renderQuery query

288− <> renderConflictClause conflict

289− <> renderReturningClause returning

290−

291−-- | Insert a `Query` returning `Nil` and raising an error on conflicts.

292−insertQuery_

293− :: ( SOP.SListI columns

270+ , columns ~ TableToColumns table

271+ , row0 ~ TableToRow table

272+ , SOP.SListI columns

273+ , SOP.SListI row1 )

274+ => QualifiedAlias sch tab

275+ -- ^ table

276+ -> QueryClause commons schemas params columns

277+ -- ^ what to insert

278+ -> ConflictClause tab commons schemas params table

279+ -- ^ what to do in case of conflict

280+ -> ReturningClause commons schemas params '[tab ::: row0] row1

281+ -- ^ what to return

282+ -> Manipulation commons schemas params row1

283+insertInto tab qry conflict ret = UnsafeManipulation $

284+ "INSERT" <+> "INTO" <+> renderSQL tab

285+ <+> renderSQL qry

286+ <> renderSQL conflict

287+ <> renderSQL ret

288+

289+-- | Like `insertInto` but with `OnConflictDoRaise` and `no` `ReturningClause`.

290+insertInto_

291+ :: ( Has sch schemas schema

294292 , Has tab schema ('Table table)

295− , columns ~ TableToColumns table )

296− => Alias tab -- ^ table to insert into

297− -> Query schema params (ColumnsToRelation columns)

298− -> Manipulation schema params '[]

299−insertQuery_ tab query =

300− insertQuery tab query OnConflictDoRaise (Returning Nil)

301−

302−-- | `ColumnValue`s are values to insert or update in a row

303−-- `Same` updates with the same value.

304−-- `Default` inserts or updates with the @DEFAULT@ value

305−-- `Set` a value to be an `Expression`, relative to the given

306−-- row for an update, and closed for an insert.

307−data ColumnValue

308− (schema :: SchemaType)

309− (columns :: RelationType)

310− (params :: [NullityType])

311− (ty :: ColumnType)

312− where

313− Same :: ColumnValue schema (column ': columns) params ty

314− Default :: ColumnValue schema columns params ('Def :=> ty)

315− Set

316− :: (forall table. Expression schema '[table ::: columns] 'Ungrouped params ty)

317− -> ColumnValue schema columns params (constraint :=> ty)

293+ , columns ~ TableToColumns table

294+ , row ~ TableToRow table

295+ , SOP.SListI columns )

296+ => QualifiedAlias sch tab

297+ -- ^ table

298+ -> QueryClause commons schemas params columns

299+ -- ^ what to insert

300+ -> Manipulation commons schemas params '[]

301+insertInto_ tab qry =

302+ insertInto tab qry OnConflictDoRaise (Returning_ Nil)

303+

304+-- | A `QueryClause` describes what to `insertInto` a table.

305+data QueryClause commons schemas params columns where

306+ Values

307+ :: SOP.SListI columns

308+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns

309+ -- ^ row of values

310+ -> [NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns]

311+ -- ^ additional rows of values

312+ -> QueryClause commons schemas params columns

313+ Select

314+ :: SOP.SListI columns

315+ => NP (Aliased (Optional (Expression '[] commons grp schemas params from))) columns

316+ -- ^ row of values

317+ -> TableExpression '[] commons grp schemas params from

318+ -- ^ from a table expression

319+ -> QueryClause commons schemas params columns

320+ Subquery

321+ :: ColumnsToRow columns ~ row

322+ => Query '[] commons schemas params row

323+ -- ^ subquery to insert

324+ -> QueryClause commons schemas params columns

325+

326+instance RenderSQL (QueryClause commons schemas params columns) where

327+ renderSQL = \case

328+ Values row0 rows ->

329+ parenthesized (renderCommaSeparated renderSQLPart row0)

330+ <+> "VALUES"

331+ <+> commaSeparated

332+ ( parenthesized

333+ . renderCommaSeparated renderValuePart <$> row0 : rows )

334+ Select row0 tab ->

335+ parenthesized (renderCommaSeparatedMaybe renderSQLPartMaybe row0)

336+ <+> "SELECT"

337+ <+> renderCommaSeparatedMaybe renderValuePartMaybe row0

338+ <+> renderSQL tab

339+ Subquery qry -> renderQuery qry

340+ where

341+ renderSQLPartMaybe, renderValuePartMaybe

342+ :: Aliased (Optional (Expression '[] commons grp schemas params from)) column

343+ -> Maybe ByteString

344+ renderSQLPartMaybe = \case

345+ Default `As` _ -> Nothing

346+ Set _ `As` name -> Just $ renderSQL name

347+ renderValuePartMaybe = \case

348+ Default `As` _ -> Nothing

349+ Set value `As` _ -> Just $ renderExpression value

350+ renderSQLPart, renderValuePart

351+ :: Aliased (Optional (Expression '[] commons grp schemas params from)) column

352+ -> ByteString

353+ renderSQLPart (_ `As` name) = renderSQL name

354+ renderValuePart (value `As` _) = renderSQL value

355+

356+-- | `Values_` describes a single `NP` list of `Aliased` `Optional` `Expression`s

357+-- whose `ColumnsType` must match the tables'.

358+pattern Values_

359+ :: SOP.SListI columns

360+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[]))) columns

361+ -- ^ row of values

362+ -> QueryClause commons schemas params columns

363+pattern Values_ vals = Values vals []

364+

365+-- | `Optional` is either `Default` or a value, parameterized by an appropriate

366+-- `ColumnConstraint`.

367+data Optional expr ty where

368+ -- | Use the `Default` value for a column.

369+ Default :: Optional expr ('Def :=> ty)

370+ -- | `Set` a value for a column.

371+ Set :: expr ty -> Optional expr (def :=> ty)

372+

373+instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where

374+ renderSQL = \case

375+ Default -> "DEFAULT"

376+ Set expr -> renderSQL expr

318377

319378-- | A `ReturningClause` computes and return value(s) based

320379-- on each row actually inserted, updated or deleted. This is primarily

@@ -322,72 +381,100 @@ data ColumnValue

322381-- serial sequence number. However, any expression using the table's columns

323382-- is allowed. Only rows that were successfully inserted or updated or

324383-- deleted will be returned. For example, if a row was locked

325−-- but not updated because an `OnConflictDoUpdate` condition was not satisfied,

326−-- the row will not be returned. `ReturningStar` will return all columns

327−-- in the row. Use @Returning Nil@ in the common case where no return

384+-- but not updated because an `OnConflict` `DoUpdate` condition was not satisfied,

385+-- the row will not be returned. `Returning` `Star` will return all columns

386+-- in the row. Use `Returning` `Nil` in the common case where no return

328387-- values are desired.

329−data ReturningClause

330− (schema :: SchemaType)

331− (columns :: ColumnsType)

332− (params :: [NullityType])

333− (results :: RelationType)

334− where

335− ReturningStar

336− :: results ~ ColumnsToRelation columns

337− => ReturningClause schema columns params results

338− Returning

339− :: rel ~ ColumnsToRelation columns

340− => NP (Aliased (Expression schema '[table ::: rel] 'Ungrouped params)) results

341− -> ReturningClause schema columns params results

342−

343−-- | Render a `ReturningClause`.

344−renderReturningClause

345− :: SOP.SListI results

346− => ReturningClause schema params columns results

347− -> ByteString

348−renderReturningClause = \case

349− ReturningStar -> " RETURNING *"

350− Returning Nil -> ""

351− Returning results -> " RETURNING"

352− <+> renderCommaSeparated (renderAliasedAs renderExpression) results

388+newtype ReturningClause commons schemas params from row =

389+ Returning (Selection '[] commons 'Ungrouped schemas params from row)

390+

391+instance RenderSQL (ReturningClause commons schemas params from row) where

392+ renderSQL = \case

393+ Returning (List Nil) -> ""

394+ Returning selection -> " RETURNING" <+> renderSQL selection

395+

396+-- | `Returning` a `List`

397+pattern Returning_

398+ :: SOP.SListI row

399+ => NP (Aliased (Expression '[] commons 'Ungrouped schemas params from)) row

400+ -- ^ row of values

401+ -> ReturningClause commons schemas params from row

402+pattern Returning_ list = Returning (List list)

353403

354404-- | A `ConflictClause` specifies an action to perform upon a constraint

355405-- violation. `OnConflictDoRaise` will raise an error.

356−-- `OnConflictDoNothing` simply avoids inserting a row.

357−-- `OnConflictDoUpdate` updates the existing row that conflicts with the row

406+-- `OnConflict` `DoNothing` simply avoids inserting a row.

407+-- `OnConflict` `DoUpdate` updates the existing row that conflicts with the row

358408-- proposed for insertion.

359−data ConflictClause (schema :: SchemaType) (columns :: ColumnsType) params where

360− OnConflictDoRaise :: ConflictClause schema columns params

361− OnConflictDoNothing :: ConflictClause schema columns params

362− OnConflictDoUpdate

363− :: NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns

364− -> [Condition schema '[table ::: ColumnsToRelation columns] 'Ungrouped params]

365− -> ConflictClause schema columns params

409+data ConflictClause tab commons schemas params table where

410+ OnConflictDoRaise :: ConflictClause tab commons schemas params table

411+ OnConflict

412+ :: ConflictTarget constraints

413+ -- ^ conflict target

414+ -> ConflictAction tab commons schemas params columns

415+ -- ^ conflict action

416+ -> ConflictClause tab commons schemas params (constraints :=> columns)

366417

367418-- | Render a `ConflictClause`.

368−renderConflictClause

369− :: SOP.SListI columns

370− => ConflictClause schema columns params

419+instance SOP.SListI (TableToColumns table)

420+ => RenderSQL (ConflictClause tab commons schemas params table) where

421+ renderSQL = \case

422+ OnConflictDoRaise -> ""

423+ OnConflict target action -> " ON CONFLICT"

424+ <+> renderSQL target <+> renderSQL action

425+

426+{- |

427+`ConflictAction` specifies an alternative `OnConflict` action.

428+It can be either `DoNothing`, or a `DoUpdate` clause specifying

429+the exact details of the `update` action to be performed in case of a conflict.

430+The `Set` and WHERE `Condition`s in `OnConflict` `DoUpdate` have access to the

431+existing row using the table's name (or an alias), and to rows proposed

432+for insertion using the special @#excluded@ table.

433+`OnConflict` `DoNothing` simply avoids inserting a row as its alternative action.

434+`OnConflict` `DoUpdate` updates the existing row that conflicts

435+with the row proposed for insertion as its alternative action.

436+-}

437+data ConflictAction tab commons schemas params columns where

438+ DoNothing :: ConflictAction tab commons schemas params columns

439+ DoUpdate

440+ :: ( row ~ ColumnsToRow columns

441+ , SOP.SListI columns

442+ , columns ~ (col0 ': cols)

443+ , SOP.All (HasIn columns) subcolumns

444+ , AllUnique subcolumns )

445+ => NP (Aliased (Optional (Expression '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]))) subcolumns

446+ -> [Condition '[] commons 'Ungrouped schemas params '[tab ::: row, "excluded" ::: row]]

447+ -- ^ WHERE `Condition`s

448+ -> ConflictAction tab commons schemas params columns

449+

450+instance RenderSQL (ConflictAction tab commons schemas params columns) where

451+ renderSQL = \case

452+ DoNothing -> "DO NOTHING"

453+ DoUpdate updates whs'

454+ -> "DO UPDATE SET"

455+ <+> renderCommaSeparated renderUpdate updates

456+ <> case whs' of

457+ [] -> ""

458+ wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)

459+

460+renderUpdate

461+ :: (forall x. RenderSQL (expr x))

462+ => Aliased (Optional expr) ty

371463 -> ByteString

372−renderConflictClause = \case

373− OnConflictDoRaise -> ""

374− OnConflictDoNothing -> " ON CONFLICT DO NOTHING"

375− OnConflictDoUpdate updates whs'

376− -> " ON CONFLICT DO UPDATE SET"

377− <+> renderCommaSeparatedMaybe renderUpdate updates

378− <> case whs' of

379− [] -> ""

380− wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)

381− where

382− renderUpdate

383− :: Aliased (ColumnValue schema columns params) column

384− -> Maybe ByteString

385− renderUpdate = \case

386− Same `As` _ -> Nothing

387− Default `As` column -> Just $

388− renderAlias column <+> "=" <+> "DEFAULT"

389− Set expression `As` column -> Just $

390− renderAlias column <+> "=" <+> renderExpression expression

464+renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr

465+

466+-- | A `ConflictTarget` specifies the constraint violation that triggers a

467+-- `ConflictAction`.

468+data ConflictTarget constraints where

469+ OnConstraint

470+ :: Has con constraints constraint

471+ => Alias con

472+ -> ConflictTarget constraints

473+

474+-- | Render a `ConflictTarget`

475+instance RenderSQL (ConflictTarget constraints) where

476+ renderSQL (OnConstraint con) =

477+ "ON" <+> "CONSTRAINT" <+> renderSQL con

391478

392479{-----------------------------------------

393480UPDATE statements

@@ -397,108 +484,95 @@ UPDATE statements

397484-- in all rows that satisfy the condition.

398485update

399486 :: ( SOP.SListI columns

400− , SOP.SListI results

487+ , SOP.SListI row1

488+ , Has sch schemas schema

401489 , Has tab schema ('Table table)

402− , columns ~ TableToColumns table )

403− => Alias tab -- ^ table to update

404− -> NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns

490+ , row0 ~ TableToRow table

491+ , columns ~ TableToColumns table

492+ , SOP.All (HasIn columns) subcolumns

493+ , AllUnique subcolumns )

494+ => QualifiedAlias sch tab -- ^ table to update

495+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row0]))) subcolumns

405496 -- ^ modified values to replace old values

406− -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params

497+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]

407498 -- ^ condition under which to perform update on a row

408− -> ReturningClause schema columns params results -- ^ results to return

409− -> Manipulation schema params results

499+ -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return

500+ -> Manipulation commons schemas params row1

410501update tab columns wh returning = UnsafeManipulation $

411502 "UPDATE"

412− <+> renderAlias tab

503+ <+> renderSQL tab

413504 <+> "SET"

414− <+> renderCommaSeparatedMaybe renderUpdate columns

415− <+> "WHERE" <+> renderExpression wh

416− <> renderReturningClause returning

417− where

418− renderUpdate

419− :: Aliased (ColumnValue schema columns params) column

420− -> Maybe ByteString

421− renderUpdate = \case

422− Same `As` _ -> Nothing

423− Default `As` column -> Just $

424− renderAlias column <+> "=" <+> "DEFAULT"

425− Set expression `As` column -> Just $

426− renderAlias column <+> "=" <+> renderExpression expression

505+ <+> renderCommaSeparated renderUpdate columns

506+ <+> "WHERE" <+> renderSQL wh

507+ <> renderSQL returning

427508

428509-- | Update a row returning `Nil`.

429510update_

430511 :: ( SOP.SListI columns

512+ , Has sch schemas schema

431513 , Has tab schema ('Table table)

432− , columns ~ TableToColumns table )

433− => Alias tab -- ^ table to update

434− -> NP (Aliased (ColumnValue schema (ColumnsToRelation columns) params)) columns

514+ , row ~ TableToRow table

515+ , columns ~ TableToColumns table

516+ , SOP.All (HasIn columns) subcolumns

517+ , AllUnique subcolumns )

518+ => QualifiedAlias sch tab -- ^ table to update

519+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row]))) subcolumns

435520 -- ^ modified values to replace old values

436− -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params

521+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]

437522 -- ^ condition under which to perform update on a row

438− -> Manipulation schema params '[]

439−update_ tab columns wh = update tab columns wh (Returning Nil)

523+ -> Manipulation commons schemas params '[]

524+update_ tab columns wh = update tab columns wh (Returning_ Nil)

440525

441526{-----------------------------------------

442527DELETE statements

443528-----------------------------------------}

444529

445−-- | Delete rows of a table.

530+-- | Specify additional tables with `Using`

531+-- an `also` list of table expressions, allowing columns

532+-- from other tables to appear in the WHERE condition.

533+-- This is similar to the list of tables that can be specified

534+-- in the FROM Clause of a SELECT statement;

535+-- for example, an alias for the table name can be specified.

536+-- Do not repeat the target table in the `Using` list,

537+-- unless you wish to set up a self-join.

538+-- `NoUsing` if no additional tables are to be used.

539+data UsingClause commons schemas params from where

540+ NoUsing :: UsingClause commons schemas params '[]

541+ Using

542+ :: FromClause '[] commons schemas params from

543+ -- ^ what to use

544+ -> UsingClause commons schemas params from

545+

546+-- | Delete rows from a table.

446547deleteFrom

447− :: ( SOP.SListI results

548+ :: ( SOP.SListI row1

549+ , Has sch schemas schema

448550 , Has tab schema ('Table table)

551+ , row0 ~ TableToRow table

449552 , columns ~ TableToColumns table )

450− => Alias tab -- ^ table to delete from

451− -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params

553+ => QualifiedAlias sch tab -- ^ table to delete from

554+ -> UsingClause commons schemas params from

555+ -> Condition '[] commons 'Ungrouped schemas params (tab ::: row0 ': from)

452556 -- ^ condition under which to delete a row

453− -> ReturningClause schema columns params results -- ^ results to return

454− -> Manipulation schema params results

455−deleteFrom tab wh returning = UnsafeManipulation $

456− "DELETE FROM" <+> renderAlias tab

457− <+> "WHERE" <+> renderExpression wh

458− <> renderReturningClause returning

557+ -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return

558+ -> Manipulation commons schemas params row1

559+deleteFrom tab using wh returning = UnsafeManipulation $

560+ "DELETE FROM"

561+ <+> renderSQL tab

562+ <> case using of

563+ NoUsing -> ""

564+ Using tables -> " USING" <+> renderSQL tables

565+ <+> "WHERE" <+> renderSQL wh

566+ <> renderSQL returning

459567

460568-- | Delete rows returning `Nil`.

461569deleteFrom_

462− :: ( Has tab schema ('Table table)

570+ :: ( Has sch schemas schema

571+ , Has tab schema ('Table table)

572+ , row ~ TableToRow table

463573 , columns ~ TableToColumns table )

464− => Alias tab -- ^ table to delete from

465− -> Condition schema '[tab ::: ColumnsToRelation columns] 'Ungrouped params

574+ => QualifiedAlias sch tab -- ^ table to delete from

575+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]

466576 -- ^ condition under which to delete a row

467− -> Manipulation schema params '[]

468−deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil)

469−

470−{-----------------------------------------

471−WITH statements

472−-----------------------------------------}

473−

474−-- | `with` provides a way to write auxiliary statements for use in a larger statement.

475−-- These statements, which are often referred to as Common Table Expressions or CTEs,

476−-- can be thought of as defining temporary tables that exist just for one statement.

477−--

478−-- >>> type ProductsTable = '[] :=> '["product" ::: 'NoDef :=> 'NotNull 'PGtext, "date" ::: 'Def :=> 'NotNull 'PGdate]

479−--

480−-- >>> :{

481−-- let

482−-- manipulation :: Manipulation '["products" ::: 'Table ProductsTable, "products_deleted" ::: 'Table ProductsTable] '[ 'NotNull 'PGdate] '[]

483−-- manipulation = with

484−-- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rows :* Nil)

485−-- (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rows `As` #t)))))

486−-- in renderManipulation manipulation

487−-- :}

488−-- "WITH \"deleted_rows\" AS (DELETE FROM \"products\" WHERE (\"date\" < ($1 :: date)) RETURNING *) INSERT INTO \"products_deleted\" SELECT * FROM \"deleted_rows\" AS \"t\""

489−with

490− :: SOP.SListI commons

491− => NP (Aliased (Manipulation schema params)) commons

492− -- ^ common table expressions

493− -> Manipulation (With commons schema) params results

494− -> Manipulation schema params results

495−with commons manipulation = UnsafeManipulation $

496− "WITH" <+> renderCommaSeparated renderCommon commons

497− <+> renderManipulation manipulation

498− where

499− renderCommon

500− :: Aliased (Manipulation schema params) common

501− -> ByteString

502− renderCommon (common `As` alias) =

503− renderAlias alias <+> "AS" <+>

504− parenthesized (renderManipulation common)

577+ -> Manipulation commons schemas params '[]

578+deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil)

squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+347−215

@@ -8,8 +8,13 @@ Stability: experimental

88This module defines a `Migration` type to safely

99change the schema of your database over time. Let's see an example!

1010

11+First turn on some extensions.

12+

1113>>> :set -XDataKinds -XOverloadedLabels

1214>>> :set -XOverloadedStrings -XFlexibleContexts -XTypeOperators

15+

16+Next, let's define our `TableType`s.

17+

1318>>> :{

1419type UsersTable =

1520 '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

@@ -20,7 +25,7 @@ type UsersTable =

2025

2126>>> :{

2227type EmailsTable =

23− '[ "pk_emails" ::: 'PrimaryKey '["id"]

28+ '[ "pk_emails" ::: 'PrimaryKey '["id"]

2429 , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]

2530 ] :=>

2631 '[ "id" ::: 'Def :=> 'NotNull 'PGint4

@@ -29,248 +34,293 @@ type EmailsTable =

2934 ]

3035:}

3136

37+Now we can define some `Migration`s to make our tables.

38+

3239>>> :{

3340let

34− makeUsers :: Migration IO '[] '["users" ::: 'Table UsersTable]

41+ makeUsers :: Migration Definition (Public '[]) '["public" ::: '["users" ::: 'Table UsersTable]]

3542 makeUsers = Migration

3643 { name = "make users table"

37− , up = void . define $

38− createTable #users

39− ( serial `As` #id :*

40− (text & notNullable) `As` #name :* Nil )

41− ( primaryKey #id `As` #pk_users :* Nil )

42− , down = void . define $ dropTable #users

44+ , up = createTable #users

45+ ( serial `as` #id :*

46+ notNullable text `as` #name )

47+ ( primaryKey #id `as` #pk_users )

48+ , down = dropTable #users

4349 }

4450:}

4551

4652>>> :{

4753let

48− makeEmails :: Migration IO '["users" ::: 'Table UsersTable]

49− '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]

54+ makeEmails :: Migration Definition '["public" ::: '["users" ::: 'Table UsersTable]]

55+ '["public" ::: '["users" ::: 'Table UsersTable, "emails" ::: 'Table EmailsTable]]

5056 makeEmails = Migration

5157 { name = "make emails table"

52− , up = void . define $

53− createTable #emails

54− ( serial `As` #id :*

55− (int & notNullable) `As` #user_id :*

56− (text & nullable) `As` #email :* Nil )

57− ( primaryKey #id `As` #pk_emails :*

58+ , up = createTable #emails

59+ ( serial `as` #id :*

60+ notNullable int `as` #user_id :*

61+ nullable text `as` #email )

62+ ( primaryKey #id `as` #pk_emails :*

5863 foreignKey #user_id #users #id

59− OnDeleteCascade OnUpdateCascade `As` #fk_user_id :* Nil )

60− , down = void . define $ dropTable #emails

64+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

65+ , down = dropTable #emails

6166 }

6267:}

6368

64−Now that we have a couple migrations we can chain them together.

69+Now that we have a couple migrations we can chain them together into a `Path`.

6570

6671>>> let migrations = makeUsers :>> makeEmails :>> Done

6772

68−>>> :{

69−let

70− numMigrations

71− :: Has "schema_migrations" schema ('Table MigrationsTable)

72− => PQ schema schema IO ()

73− numMigrations = do

74− result <- runQuery (selectStar (from (table (#schema_migrations `As` #m))))

75− num <- ntuples result

76− liftBase $ print num

77−:}

73+Now run the migrations.

7874

75+>>> import Control.Monad.IO.Class

7976>>> :{

8077withConnection "host=localhost port=5432 dbname=exampledb" $

8178 manipulate (UnsafeManipulation "SET client_min_messages TO WARNING;")

8279 -- suppress notices

80+ & pqThen (liftIO (putStrLn "Migrate"))

8381 & pqThen (migrateUp migrations)

84− & pqThen numMigrations

82+ & pqThen (liftIO (putStrLn "Rollback"))

8583 & pqThen (migrateDown migrations)

86− & pqThen numMigrations

8784:}

88−Row 2

89−Row 0

85+Migrate

86+Rollback

87+

88+We can also create a simple executable using `defaultMain`.

89+

90+>>> let main = defaultMain "host=localhost port=5432 dbname=exampledb" migrations

91+

92+>>> withArgs [] main

93+Invalid command: "". Use:

94+migrate to run all available migrations

95+rollback to rollback all available migrations

96+status to display migrations run and migrations left to run

97+

98+>>> withArgs ["status"] main

99+Migrations already run:

100+ None

101+Migrations left to run:

102+ - make users table

103+ - make emails table

104+

105+>>> withArgs ["migrate"] main

106+Migrations already run:

107+ - make users table

108+ - make emails table

109+Migrations left to run:

110+ None

111+

112+>>> withArgs ["rollback"] main

113+Migrations already run:

114+ None

115+Migrations left to run:

116+ - make users table

117+ - make emails table

118+

119+In addition to enabling `Migration`s using pure SQL `Definition`s for

120+the `up` and `down` instructions, you can also perform impure `IO` actions

121+by using a `Migration`s over the `Terminally` `PQ` `IO` category.

90122-}

91123

92124{-# LANGUAGE

93125 DataKinds

126+ , DeriveGeneric

127+ , FlexibleContexts

128+ , FlexibleInstances

94129 , GADTs

95130 , LambdaCase

96− , PolyKinds

97131 , OverloadedLabels

132+ , OverloadedStrings

133+ , PolyKinds

134+ , QuantifiedConstraints

135+ , RankNTypes

98136 , TypeApplications

99− , FlexibleContexts

100137 , TypeOperators

101138#-}

102139

103140module Squeal.PostgreSQL.Migration

104141 ( -- * Migration

105142 Migration (..)

106− , migrateUp

107− , migrateDown

108− -- * Aligned lists

109− , AlignedList (..)

110− , single

111− -- * Migration table

143+ , Migratory (..)

144+ , Terminally (..)

145+ , terminally

146+ , pureMigration

112147 , MigrationsTable

113− , createMigrations

114− , insertMigration

115− , deleteMigration

116− , selectMigration

148+ , defaultMain

117149 ) where

118150

119151import Control.Category

120152import Control.Monad

121−import Control.Monad.Base

122−import Control.Monad.Trans.Control

123−import Data.Monoid

124−import Generics.SOP (K(..))

153+import Data.ByteString (ByteString)

154+import Data.Foldable (traverse_)

125155import Data.Function ((&))

156+import Data.List ((\\))

126157import Data.Text (Text)

127−import Prelude hiding (id, (.))

158+import Data.Time (UTCTime)

159+import Prelude hiding ((.), id)

160+import System.Environment

161+import UnliftIO (MonadIO (..))

162+

163+import qualified Data.Text.IO as Text (putStrLn)

164+import qualified Generics.SOP as SOP

165+import qualified GHC.Generics as GHC

128166

129−import Squeal.PostgreSQL

167+import Squeal.PostgreSQL.Alias

168+import Squeal.PostgreSQL.Binary

169+import Squeal.PostgreSQL.Definition

170+import Squeal.PostgreSQL.Definition.Table

171+import Squeal.PostgreSQL.Definition.Table.Constraint

172+import Squeal.PostgreSQL.Expression.Comparison

173+import Squeal.PostgreSQL.Expression.Parameter

174+import Squeal.PostgreSQL.Expression.Time

175+import Squeal.PostgreSQL.Expression.Type

176+import Squeal.PostgreSQL.List

177+import Squeal.PostgreSQL.Manipulation

178+import Squeal.PostgreSQL.PQ

179+import Squeal.PostgreSQL.Query

180+import Squeal.PostgreSQL.Schema

181+import Squeal.PostgreSQL.Transaction

130182

131−-- | A `Migration` should contain an inverse pair of

132−-- `up` and `down` instructions and a unique `name`.

133−data Migration io schema0 schema1 = Migration

183+-- | A `Migration` is a named "isomorphism" over a given category.

184+-- It should contain an inverse pair of `up` and `down`

185+-- instructions and a unique `name`.

186+data Migration p schemas0 schemas1 = Migration

134187 { name :: Text -- ^ The `name` of a `Migration`.

135188 -- Each `name` in a `Migration` should be unique.

136− , up :: PQ schema0 schema1 io () -- ^ The `up` instruction of a `Migration`.

137− , down :: PQ schema1 schema0 io () -- ^ The `down` instruction of a `Migration`.

189+ , up :: p schemas0 schemas1 -- ^ The `up` instruction of a `Migration`.

190+ , down :: p schemas1 schemas0 -- ^ The `down` instruction of a `Migration`.

191+ } deriving (GHC.Generic)

192+

193+{- |

194+A `Migratory` @p@ is a `Category` for which one can execute or rewind

195+a `Path` of `Migration`s over @p@. This includes the category of pure

196+SQL `Definition`s and the category of impure `Terminally` `PQ` `IO` actions.

197+-}

198+class Category p => Migratory p where

199+

200+ {- |

201+ Run a `Path` of `Migration`s.

202+ Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.

203+ In one transaction, for each each `Migration` query to see if the `Migration` has been executed;

204+ if not, `up` the `Migration` and insert its `name` in the `MigrationsTable`.

205+ -}

206+ migrateUp

207+ :: Path (Migration p) schemas0 schemas1

208+ -> PQ schemas0 schemas1 IO ()

209+

210+ {- |

211+ Rewind a `Path` of `Migration`s.

212+ Create the `MigrationsTable` as @public.schema_migrations@ if it does not already exist.

213+ In one transaction, for each each `Migration` query to see if the `Migration` has been executed;

214+ if so, `down` the `Migration` and delete its `name` in the `MigrationsTable`.

215+ -}

216+ migrateDown

217+ :: Path (Migration p) schemas0 schemas1

218+ -> PQ schemas1 schemas0 IO ()

219+

220+instance Migratory Definition where

221+ migrateUp = migrateUp . cmap pureMigration

222+ migrateDown = migrateDown . cmap pureMigration

223+

224+{- | `Terminally` turns an indexed monad transformer and the monad it transforms

225+into a category by restricting the return type to @()@ and permuting the type variables.

226+This is similar to how applying a monad to @()@ yields a monoid.

227+Since a `Terminally` action has a trivial return value, the only reason

228+to run one is for the side effects, in particular database and other IO effects.

229+-}

230+newtype Terminally trans monad x0 x1 = Terminally

231+ { runTerminally :: trans x0 x1 monad () }

232+ deriving GHC.Generic

233+

234+instance

235+ ( IndexedMonadTransPQ trans

236+ , Monad monad

237+ , forall x0 x1. x0 ~ x1 => Monad (trans x0 x1 monad) )

238+ => Category (Terminally trans monad) where

239+ id = Terminally (return ())

240+ Terminally g . Terminally f = Terminally $ pqThen g f

241+

242+-- | `terminally` ignores the output of a computation, returning @()@ and

243+-- wrapping it up into a `Terminally`. You can lift an action in the base monad

244+-- by using @terminally . lift@.

245+terminally

246+ :: Functor (trans x0 x1 monad)

247+ => trans x0 x1 monad ignore

248+ -> Terminally trans monad x0 x1

249+terminally = Terminally . void

250+

251+-- | A `pureMigration` turns a `Migration` involving only pure SQL

252+-- `Definition`s into a `Migration` that may be combined with arbitrary `IO`.

253+pureMigration

254+ :: Migration Definition schemas0 schemas1

255+ -> Migration (Terminally PQ IO) schemas0 schemas1

256+pureMigration migration = Migration

257+ { name = name migration

258+ , up = terminally . define $ up migration

259+ , down = terminally . define $ down migration

138260 }

139261

140−-- | An `AlignedList` is a type-aligned list or free category.

141−data AlignedList p x0 x1 where

142− Done :: AlignedList p x x

143− (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2

144−infixr 7 :>>

145−instance Category (AlignedList p) where

146− id = Done

147− (.) list = \case

148− Done -> list

149− step :>> steps -> step :>> (steps >>> list)

150−

151−-- | A `single` step.

152−single :: p x0 x1 -> AlignedList p x0 x1

153−single step = step :>> Done

154−

155−-- | Run `Migration`s by creating the `MigrationsTable`

156−-- if it does not exist and then in a transaction, for each each `Migration`

157−-- query to see if the `Migration` is executed. If not, then

158−-- execute the `Migration` and insert its row in the `MigrationsTable`.

159−migrateUp

160− :: MonadBaseControl IO io

161− => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run

162− -> PQ

163− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

164− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

165− io ()

166−migrateUp migration =

167− define createMigrations

168− & pqBind okResult

169− & pqThen (transactionallySchema_ (upMigrations migration))

170− where

262+instance Migratory (Terminally PQ IO) where

171263

172− upMigrations

173− :: MonadBaseControl IO io

174− => AlignedList (Migration io) schema0 schema1

175− -> PQ

176− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

177− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

178− io ()

179− upMigrations = \case

180− Done -> return ()

181− step :>> steps -> upMigration step & pqThen (upMigrations steps)

182−

183− upMigration

184− :: MonadBase IO io

185− => Migration io schema0 schema1 -> PQ

186− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

187− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

188− io ()

189− upMigration step =

190− queryExecuted step

191− & pqBind (\ executed ->

192− if executed == 1 -- up step has already been executed

193− then PQ (\ _ -> return (K ())) -- unsafely switch schemas

194− else

195− pqEmbed (up step) -- safely switch schemas

196− & pqThen (manipulateParams insertMigration (Only (name step)))

197− -- insert execution record

198− & pqBind okResult)

199−

200− queryExecuted

201− :: MonadBase IO io

202− => Migration io schema0 schema1 -> PQ

203− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

204− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

205− io Row

206− queryExecuted step = do

207− result <- runQueryParams selectMigration (Only (name step))

208− okResult result

209− ntuples result

210−

211−-- | Rewind `Migration`s by creating the `MigrationsTable`

212−-- if it does not exist and then in a transaction, for each each `Migration`

213−-- query to see if the `Migration` is executed. If it is, then

214−-- rewind the `Migration` and delete its row in the `MigrationsTable`.

215−migrateDown

216− :: MonadBaseControl IO io

217− => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind

218− -> PQ

219− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

220− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

221− io ()

222−migrateDown migrations =

223− define createMigrations

224− & pqBind okResult

225− & pqThen (transactionallySchema_ (downMigrations migrations))

226− where

264+ migrateUp migration = unsafePQ . transactionally_ $ do

265+ define createMigrations

266+ upMigrations migration

267+

268+ where

269+

270+ upMigrations

271+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1

272+ -> PQ MigrationsSchemas MigrationsSchemas IO ()

273+ upMigrations = \case

274+ Done -> return ()

275+ step :>> steps -> upMigration step >> upMigrations steps

276+

277+ upMigration

278+ :: Migration (Terminally PQ IO) schemas0 schemas1

279+ -> PQ MigrationsSchemas MigrationsSchemas IO ()

280+ upMigration step = do

281+ executed <- queryExecuted step

282+ unless (executed == 1) $ do

283+ unsafePQ . runTerminally $ up step

284+ manipulateParams_ insertMigration (Only (name step))

285+

286+ queryExecuted

287+ :: Migration (Terminally PQ IO) schemas0 schemas1

288+ -> PQ MigrationsSchemas MigrationsSchemas IO Row

289+ queryExecuted step = do

290+ result <- runQueryParams selectMigration (Only (name step))

291+ ntuples result

292+

293+ migrateDown migrations = unsafePQ . transactionally_ $ do

294+ define createMigrations

295+ downMigrations migrations

296+

297+ where

298+

299+ downMigrations

300+ :: Path (Migration (Terminally PQ IO)) schemas0 schemas1

301+ -> PQ MigrationsSchemas MigrationsSchemas IO ()

302+ downMigrations = \case

303+ Done -> return ()

304+ step :>> steps -> downMigrations steps >> downMigration step

227305

228− downMigrations

229− :: MonadBaseControl IO io

230− => AlignedList (Migration io) schema0 schema1 -> PQ

231− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

232− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

233− io ()

234− downMigrations = \case

235− Done -> return ()

236− step :>> steps -> downMigrations steps & pqThen (downMigration step)

237−

238− downMigration

239− :: MonadBase IO io

240− => Migration io schema0 schema1 -> PQ

241− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

242− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

243− io ()

244− downMigration step =

245− queryExecuted step

246− & pqBind (\ executed ->

247− if executed == 0 -- up step has not been executed

248− then PQ (\ _ -> return (K ())) -- unsafely switch schemas

249− else

250− pqEmbed (down step) -- safely switch schemas

251− & pqThen (manipulateParams deleteMigration (Only (name step)))

252− -- delete execution record

253− & pqBind okResult)

254−

255− queryExecuted

256− :: MonadBase IO io

257− => Migration io schema0 schema1 -> PQ

258− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

259− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

260− io Row

261− queryExecuted step = do

262− result <- runQueryParams selectMigration (Only (name step))

263− okResult result

264− ntuples result

265−

266−okResult :: MonadBase IO io => K Result results -> PQ schema schema io ()

267−okResult result = do

268− status <- resultStatus result

269− when (not (status `elem` [CommandOk, TuplesOk])) $ do

270− errorMessageMaybe <- resultErrorMessage result

271− case errorMessageMaybe of

272− Nothing -> error "migrateDown: unknown error"

273− Just msg -> error ("migrationDown: " <> show msg)

306+ downMigration

307+ :: Migration (Terminally PQ IO) schemas0 schemas1

308+ -> PQ MigrationsSchemas MigrationsSchemas IO ()

309+ downMigration step = do

310+ executed <- queryExecuted step

311+ unless (executed == 0) $ do

312+ unsafePQ . runTerminally $ down step

313+ manipulateParams_ deleteMigration (Only (name step))

314+

315+ queryExecuted

316+ :: Migration (Terminally PQ IO) schemas0 schemas1

317+ -> PQ MigrationsSchemas MigrationsSchemas IO Row

318+ queryExecuted step = do

319+ result <- runQueryParams selectMigration (Only (name step))

320+ ntuples result

321+

322+unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x

323+unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK

274324

275325-- | The `TableType` for a Squeal migration.

276326type MigrationsTable =

@@ -279,38 +329,120 @@ type MigrationsTable =

279329 , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz

280330 ]

281331

332+data MigrationRow =

333+ MigrationRow { migrationName :: Text

334+ , migrationTime :: UTCTime }

335+ deriving (GHC.Generic, Show)

336+

337+instance SOP.Generic MigrationRow

338+instance SOP.HasDatatypeInfo MigrationRow

339+

340+type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable]

341+type MigrationsSchemas = Public MigrationsSchema

342+

282343-- | Creates a `MigrationsTable` if it does not already exist.

283−createMigrations

284− :: Has "schema_migrations" schema ('Table MigrationsTable)

285− => Definition schema schema

344+createMigrations :: Definition MigrationsSchemas MigrationsSchemas

286345createMigrations =

287346 createTableIfNotExists #schema_migrations

288− ( (text & notNullable) `As` #name :*

347+ ( (text & notNullable) `as` #name :*

289348 (timestampWithTimeZone & notNullable & default_ currentTimestamp)

290− `As` #executed_at :* Nil )

291− ( unique (#name :* Nil) `As` #migrations_unique_name :* Nil )

292−

293−-- | Inserts a `Migration` into the `MigrationsTable`

294−insertMigration

295− :: Has "schema_migrations" schema ('Table MigrationsTable)

296− => Manipulation schema '[ 'NotNull 'PGtext] '[]

297−insertMigration = insertRow_ #schema_migrations

298− ( Set (param @1) `As` #name :*

299− Default `As` #executed_at :* Nil )

300−

301−-- | Deletes a `Migration` from the `MigrationsTable`

302−deleteMigration

303− :: Has "schema_migrations" schema ('Table MigrationsTable)

304− => Manipulation schema '[ 'NotNull 'PGtext ] '[]

349+ `as` #executed_at )

350+ ( unique #name `as` #migrations_unique_name )

351+

352+-- | Inserts a `Migration` into the `MigrationsTable`, returning

353+-- the time at which it was inserted.

354+insertMigration :: Manipulation_ MigrationsSchemas (Only Text) ()

355+insertMigration = insertInto_ #schema_migrations

356+ (Values_ (Set (param @1) `as` #name :* Default `as` #executed_at))

357+

358+-- | Deletes a `Migration` from the `MigrationsTable`, returning

359+-- the time at which it was inserted.

360+deleteMigration :: Manipulation_ MigrationsSchemas (Only Text) ()

305361deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)

306362

307363-- | Selects a `Migration` from the `MigrationsTable`, returning

308−-- the time at which it was executed.

364+-- the time at which it was inserted.

309365selectMigration

310− :: Has "schema_migrations" schema ('Table MigrationsTable)

311− => Query schema '[ 'NotNull 'PGtext ]

312− '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]

313−selectMigration = select

314− (#executed_at `As` #executed_at :* Nil)

315− ( from (table (#schema_migrations `As` #m))

316− & where_ (#name .== param @1))

366+ :: Query_ MigrationsSchemas (Only Text) (Only UTCTime)

367+selectMigration = select_ (#executed_at `as` #fromOnly)

368+ $ from (table (#schema_migrations))

369+ & where_ (#name .== param @1)

370+

371+selectMigrations :: Query_ MigrationsSchemas () MigrationRow

372+selectMigrations = select_

373+ (#name `as` #migrationName :* #executed_at `as` #migrationTime)

374+ (from (table #schema_migrations))

375+

376+data MigrateCommand

377+ = MigrateStatus

378+ | MigrateUp

379+ | MigrateDown deriving (GHC.Generic, Show)

380+

381+{- | `defaultMain` creates a simple executable

382+from a connection string and a list of `Migration`s. -}

383+defaultMain

384+ :: Migratory p

385+ => ByteString

386+ -- ^ connection string

387+ -> Path (Migration p) db0 db1

388+ -- ^ migrations

389+ -> IO ()

390+defaultMain connectTo migrations = do

391+ command <- readCommandFromArgs

392+ maybe (pure ()) performCommand command

393+

394+ where

395+

396+ performCommand :: MigrateCommand -> IO ()

397+ performCommand = \case

398+ MigrateStatus -> withConnection connectTo $

399+ suppressNotices >> migrateStatus

400+ MigrateUp -> withConnection connectTo $

401+ suppressNotices & pqThen (migrateUp migrations) & pqThen migrateStatus

402+ MigrateDown -> withConnection connectTo $

403+ suppressNotices & pqThen (migrateDown migrations) & pqThen migrateStatus

404+

405+ migrateStatus :: PQ schema schema IO ()

406+ migrateStatus = unsafePQ $ do

407+ runNames <- getRunMigrationNames

408+ let names = ctoList name migrations

409+ unrunNames = names \\ runNames

410+ liftIO $ displayRunned runNames >> displayUnrunned unrunNames

411+

412+ suppressNotices :: PQ schema schema IO ()

413+ suppressNotices = manipulate_ $

414+ UnsafeManipulation "SET client_min_messages TO WARNING;"

415+

416+ readCommandFromArgs :: IO (Maybe MigrateCommand)

417+ readCommandFromArgs = getArgs >>= \case

418+ ["migrate"] -> pure . Just $ MigrateUp

419+ ["rollback"] -> pure . Just $ MigrateDown

420+ ["status"] -> pure . Just $ MigrateStatus

421+ args -> displayUsage args >> pure Nothing

422+

423+ displayUsage :: [String] -> IO ()

424+ displayUsage args = do

425+ putStrLn $ "Invalid command: \"" <> unwords args <> "\". Use:"

426+ putStrLn "migrate to run all available migrations"

427+ putStrLn "rollback to rollback all available migrations"

428+ putStrLn "status to display migrations run and migrations left to run"

429+

430+ getRunMigrationNames :: (MonadIO m) => PQ db0 db0 m [Text]

431+ getRunMigrationNames =

432+ fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery selectMigrations)) >>= getRows)

433+

434+ displayListOfNames :: [Text] -> IO ()

435+ displayListOfNames [] = Text.putStrLn " None"

436+ displayListOfNames xs =

437+ let singleName n = Text.putStrLn $ " - " <> n

438+ in traverse_ singleName xs

439+

440+ displayUnrunned :: [Text] -> IO ()

441+ displayUnrunned unrunned =

442+ Text.putStrLn "Migrations left to run:"

443+ >> displayListOfNames unrunned

444+

445+ displayRunned :: [Text] -> IO ()

446+ displayRunned runned =

447+ Text.putStrLn "Migrations already run:"

448+ >> displayListOfNames runned

squeal-postgresql/src/Squeal/PostgreSQL/PG.hsnew file+388

@@ -0,0 +1,388 @@

1+{-|

2+Module: Squeal.PostgreSQL.PG

3+Description: Embedding of Haskell types into Postgres's type system

4+Copyright: (c) Eitan Chatav, 2010

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+`Squeal.PostgreSQL.PG` provides type families for turning Haskell

9+`Type`s into corresponding Postgres types.

10+-}

11+{-# LANGUAGE

12+ AllowAmbiguousTypes

13+ , DeriveAnyClass

14+ , DeriveFoldable

15+ , DeriveFunctor

16+ , DeriveGeneric

17+ , DeriveTraversable

18+ , DerivingStrategies

19+ , DefaultSignatures

20+ , FlexibleContexts

21+ , FlexibleInstances

22+ , FunctionalDependencies

23+ , GADTs

24+ , LambdaCase

25+ , MultiParamTypeClasses

26+ , OverloadedStrings

27+ , ScopedTypeVariables

28+ , TypeApplications

29+ , TypeFamilies

30+ , TypeInType

31+ , TypeOperators

32+ , UndecidableInstances

33+ , UndecidableSuperClasses

34+#-}

35+

36+module Squeal.PostgreSQL.PG

37+ ( -- * PG embeddings

38+ PG

39+ , NullPG

40+ , TuplePG

41+ , RowPG

42+ -- * Storage newtypes

43+ , Money (..)

44+ , Json (..)

45+ , Jsonb (..)

46+ , Composite (..)

47+ , Enumerated (..)

48+ , VarArray (..)

49+ , FixArray (..)

50+ , LibPQ.Oid (..)

51+ -- * Type families

52+ , LabelsPG

53+ , DimPG

54+ , FixPG

55+ , TupleOf

56+ , TupleCodeOf

57+ , RowOf

58+ , ConstructorsOf

59+ , ConstructorNameOf

60+ , ConstructorNamesOf

61+ ) where

62+

63+import Data.Aeson (Value)

64+import Data.Kind (Type)

65+import Data.Int (Int16, Int32, Int64)

66+import Data.Scientific (Scientific)

67+import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)

68+import Data.Vector (Vector)

69+import Data.UUID.Types (UUID)

70+import GHC.TypeLits

71+import Network.IP.Addr (NetAddr, IP)

72+

73+import qualified Data.ByteString.Lazy as Lazy (ByteString)

74+import qualified Data.ByteString as Strict (ByteString)

75+import qualified Data.Text.Lazy as Lazy (Text)

76+import qualified Data.Text as Strict (Text)

77+import qualified Database.PostgreSQL.LibPQ as LibPQ

78+import qualified GHC.Generics as GHC

79+import qualified Generics.SOP as SOP

80+import qualified Generics.SOP.Record as SOP

81+import qualified Generics.SOP.Type.Metadata as Type

82+

83+import Squeal.PostgreSQL.Alias

84+import Squeal.PostgreSQL.Schema

85+

86+-- $setup

87+-- >>> import Squeal.PostgreSQL

88+-- >>> import Data.Text (Text)

89+

90+{- | The `PG` type family embeds a subset of Haskell types

91+as Postgres types. As an open type family, `PG` is extensible.

92+

93+>>> :kind! PG LocalTime

94+PG LocalTime :: PGType

95+= 'PGtimestamp

96+

97+>>> newtype MyDouble = My Double

98+>>> :set -XTypeFamilies

99+>>> type instance PG MyDouble = 'PGfloat8

100+-}

101+type family PG (hask :: Type) :: PGType

102+-- | `PGbool`

103+type instance PG Bool = 'PGbool

104+-- | `PGint2`

105+type instance PG Int16 = 'PGint2

106+-- | `PGint4`

107+type instance PG Int32 = 'PGint4

108+-- | `PGint8`

109+type instance PG Int64 = 'PGint8

110+-- | `PGint2`

111+type instance PG LibPQ.Oid = 'PGoid

112+-- | `PGnumeric`

113+type instance PG Scientific = 'PGnumeric

114+-- | `PGfloat4`

115+type instance PG Float = 'PGfloat4

116+-- | `PGfloat8`

117+type instance PG Double = 'PGfloat8

118+-- | `PGchar` @1@

119+type instance PG Char = 'PGchar 1

120+-- | `PGtext`

121+type instance PG Strict.Text = 'PGtext

122+-- | `PGtext`

123+type instance PG Lazy.Text = 'PGtext

124+-- | `PGtext`

125+type instance PG String = 'PGtext

126+-- | `PGbytea`

127+type instance PG Strict.ByteString = 'PGbytea

128+-- | `PGbytea`

129+type instance PG Lazy.ByteString = 'PGbytea

130+-- | `PGtimestamp`

131+type instance PG LocalTime = 'PGtimestamp

132+-- | `PGtimestamptz`

133+type instance PG UTCTime = 'PGtimestamptz

134+-- | `PGdate`

135+type instance PG Day = 'PGdate

136+-- | `PGtime`

137+type instance PG TimeOfDay = 'PGtime

138+-- | `PGtimetz`

139+type instance PG (TimeOfDay, TimeZone) = 'PGtimetz

140+-- | `PGinterval`

141+type instance PG DiffTime = 'PGinterval

142+-- | `PGuuid`

143+type instance PG UUID = 'PGuuid

144+-- | `PGinet`

145+type instance PG (NetAddr IP) = 'PGinet

146+-- | `PGjson`

147+type instance PG Value = 'PGjson

148+

149+{-| The `LabelsPG` type family calculates the constructors of a

150+Haskell enum type.

151+

152+>>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic

153+>>> instance SOP.Generic Schwarma

154+>>> instance SOP.HasDatatypeInfo Schwarma

155+>>> :kind! LabelsPG Schwarma

156+LabelsPG Schwarma :: [Type.ConstructorName]

157+= '["Beef", "Lamb", "Chicken"]

158+-}

159+type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where

160+ LabelsPG hask =

161+ ConstructorNamesOf (ConstructorsOf (SOP.DatatypeInfoOf hask))

162+

163+{- |

164+`RowPG` turns a Haskell `Type` into a `RowType`.

165+

166+`RowPG` may be applied to normal Haskell record types provided they

167+have `SOP.Generic` and `SOP.HasDatatypeInfo` instances;

168+

169+>>> data Person = Person { name :: Strict.Text, age :: Int32 } deriving GHC.Generic

170+>>> instance SOP.Generic Person

171+>>> instance SOP.HasDatatypeInfo Person

172+>>> :kind! RowPG Person

173+RowPG Person :: [(Symbol, NullityType)]

174+= '["name" ::: 'NotNull 'PGtext, "age" ::: 'NotNull 'PGint4]

175+-}

176+type family RowPG (hask :: Type) :: RowType where

177+ RowPG hask = RowOf (SOP.RecordCodeOf hask)

178+

179+-- | `RowOf` applies `NullPG` to the fields of a list.

180+type family RowOf (record :: [(Symbol, Type)]) :: RowType where

181+ RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': col4 ::: ty4 ': record) =

182+ col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': col4 ::: NullPG ty4 ': RowOf record

183+ RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': col3 ::: ty3 ': record) =

184+ col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': col3 ::: NullPG ty3 ': RowOf record

185+ RowOf (col ::: ty ': col1 ::: ty1 ': col2 ::: ty2 ': record) =

186+ col ::: NullPG ty ': col1 ::: NullPG ty1 ': col2 ::: NullPG ty2 ': RowOf record

187+ RowOf (col ::: ty ': col1 ::: ty1 ': record) =

188+ col ::: NullPG ty ': col1::: NullPG ty1 ': RowOf record

189+ RowOf (col ::: ty ': record) = col ::: NullPG ty ': RowOf record

190+ RowOf '[] = '[]

191+

192+{- | `NullPG` turns a Haskell type into a `NullityType`.

193+

194+>>> :kind! NullPG Double

195+NullPG Double :: NullityType

196+= 'NotNull 'PGfloat8

197+>>> :kind! NullPG (Maybe Double)

198+NullPG (Maybe Double) :: NullityType

199+= 'Null 'PGfloat8

200+-}

201+type family NullPG (hask :: Type) :: NullityType where

202+ NullPG (Maybe hask) = 'Null (PG hask)

203+ NullPG hask = 'NotNull (PG hask)

204+

205+{- | `TuplePG` turns a Haskell tuple type (including record types) into

206+the corresponding list of `NullityType`s.

207+

208+>>> :kind! TuplePG (Double, Maybe Char)

209+TuplePG (Double, Maybe Char) :: [NullityType]

210+= '[ 'NotNull 'PGfloat8, 'Null ('PGchar 1)]

211+-}

212+type family TuplePG (hask :: Type) :: [NullityType] where

213+ TuplePG hask = TupleOf (TupleCodeOf hask (SOP.Code hask))

214+

215+-- | `TupleOf` turns a list of Haskell `Type`s into a list of `NullityType`s.

216+type family TupleOf (tuple :: [Type]) :: [NullityType] where

217+ TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': hask5 ': tuple) =

218+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': NullPG hask5 ': TupleOf tuple

219+ TupleOf (hask ': hask1 ': hask2 ': hask3 ': hask4 ': tuple) =

220+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': NullPG hask4 ': TupleOf tuple

221+ TupleOf (hask ': hask1 ': hask2 ': hask3 ': tuple) =

222+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': NullPG hask3 ': TupleOf tuple

223+ TupleOf (hask ': hask1 ': hask2 ': tuple) =

224+ NullPG hask ': NullPG hask1 ': NullPG hask2 ': TupleOf tuple

225+ TupleOf (hask ': hask1 ': tuple) = NullPG hask ': NullPG hask1 ': TupleOf tuple

226+ TupleOf (hask ': tuple) = NullPG hask ': TupleOf tuple

227+ TupleOf '[] = '[]

228+

229+-- | `TupleCodeOf` takes the `SOP.Code` of a haskell `Type`

230+-- and if it's a simple product returns it, otherwise giving a `TypeError`.

231+type family TupleCodeOf (hask :: Type) (code :: [[Type]]) :: [Type] where

232+ TupleCodeOf hask '[tuple] = tuple

233+ TupleCodeOf hask '[] =

234+ TypeError

235+ ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."

236+ ':$$: 'Text "It is a void type with no constructors."

237+ )

238+ TupleCodeOf hask (_ ': _ ': _) =

239+ TypeError

240+ ( 'Text "The type `" ':<>: 'ShowType hask ':<>: 'Text "' is not a tuple type."

241+ ':$$: 'Text "It is a sum type with more than one constructor."

242+ )

243+

244+-- | Calculates constructors of a datatype.

245+type family ConstructorsOf (datatype :: Type.DatatypeInfo)

246+ :: [Type.ConstructorInfo] where

247+ ConstructorsOf ('Type.ADT _module _datatype constructors) =

248+ constructors

249+ ConstructorsOf ('Type.Newtype _module _datatype constructor) =

250+ '[constructor]

251+

252+-- | Calculates the name of a nullary constructor, otherwise

253+-- generates a type error.

254+type family ConstructorNameOf (constructor :: Type.ConstructorInfo)

255+ :: Type.ConstructorName where

256+ ConstructorNameOf ('Type.Constructor name) = name

257+ ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError

258+ ('Text "ConstructorNameOf error: non-nullary constructor "

259+ ':<>: 'Text name)

260+ ConstructorNameOf ('Type.Record name _fields) = TypeError

261+ ('Text "ConstructorNameOf error: non-nullary constructor "

262+ ':<>: 'Text name)

263+

264+-- | Calculate the names of nullary constructors.

265+type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])

266+ :: [Type.ConstructorName] where

267+ ConstructorNamesOf '[] = '[]

268+ ConstructorNamesOf (constructor ': constructors) =

269+ ConstructorNameOf constructor ': ConstructorNamesOf constructors

270+

271+-- | `DimPG` turns Haskell nested homogeneous tuples into a list of lengths.

272+type family DimPG (hask :: Type) :: [Nat] where

273+ DimPG (x,x) = 2 ': DimPG x

274+ DimPG (x,x,x) = 3 ': DimPG x

275+ DimPG (x,x,x,x) = 4 ': DimPG x

276+ DimPG (x,x,x,x,x) = 5 ': DimPG x

277+ DimPG (x,x,x,x,x,x) = 6 ': DimPG x

278+ DimPG (x,x,x,x,x,x,x) = 7 ': DimPG x

279+ DimPG (x,x,x,x,x,x,x,x) = 8 ': DimPG x

280+ DimPG (x,x,x,x,x,x,x,x,x) = 9 ': DimPG x

281+ DimPG (x,x,x,x,x,x,x,x,x,x) = 10 ': DimPG x

282+ DimPG x = '[]

283+

284+-- | `FixPG` extracts `NullPG` of the base type of nested homogeneous tuples.

285+type family FixPG (hask :: Type) :: NullityType where

286+ FixPG (x,x) = FixPG x

287+ FixPG (x,x,x) = FixPG x

288+ FixPG (x,x,x,x) = FixPG x

289+ FixPG (x,x,x,x,x) = FixPG x

290+ FixPG (x,x,x,x,x,x) = FixPG x

291+ FixPG (x,x,x,x,x,x,x) = FixPG x

292+ FixPG (x,x,x,x,x,x,x,x) = FixPG x

293+ FixPG (x,x,x,x,x,x,x,x,x) = FixPG x

294+ FixPG (x,x,x,x,x,x,x,x,x,x) = FixPG x

295+ FixPG (x,x,x,x,x,x,x,x,x,x,x) = FixPG x

296+ FixPG x = NullPG x

297+

298+{- | The `Money` newtype stores a monetary value in terms

299+of the number of cents, i.e. @$2,000.20@ would be expressed as

300+@Money { cents = 200020 }@.

301+

302+>>> import Control.Monad (void)

303+>>> import Control.Monad.IO.Class (liftIO)

304+>>> import Squeal.PostgreSQL

305+>>> :{

306+let

307+ roundTrip :: Query_ (Public '[]) (Only Money) (Only Money)

308+ roundTrip = values_ $ parameter @1 money `as` #fromOnly

309+:}

310+

311+>>> let input = Only (Money 20020)

312+

313+>>> :{

314+withConnection "host=localhost port=5432 dbname=exampledb" $ do

315+ result <- runQueryParams roundTrip input

316+ Just output <- firstRow result

317+ liftIO . print $ input == output

318+:}

319+True

320+-}

321+newtype Money = Money { cents :: Int64 }

322+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)

323+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)

324+-- | `PGmoney`

325+type instance PG Money = 'PGmoney

326+

327+{- | The `Json` newtype is an indication that the Haskell

328+type it's applied to should be stored as a `PGjson`.

329+-}

330+newtype Json hask = Json {getJson :: hask}

331+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)

332+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)

333+-- | `PGjson`

334+type instance PG (Json hask) = 'PGjson

335+

336+{- | The `Jsonb` newtype is an indication that the Haskell

337+type it's applied to should be stored as a `PGjsonb`.

338+-}

339+newtype Jsonb hask = Jsonb {getJsonb :: hask}

340+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)

341+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)

342+-- | `PGjsonb`

343+type instance PG (Jsonb hask) = 'PGjsonb

344+

345+{- | The `Composite` newtype is an indication that the Haskell

346+type it's applied to should be stored as a `PGcomposite`.

347+-}

348+newtype Composite record = Composite {getComposite :: record}

349+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)

350+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)

351+-- | `PGcomposite` @(@`RowPG` @hask)@

352+type instance PG (Composite hask) = 'PGcomposite (RowPG hask)

353+

354+{- | The `Enumerated` newtype is an indication that the Haskell

355+type it's applied to should be stored as a `PGenum`.

356+-}

357+newtype Enumerated enum = Enumerated {getEnumerated :: enum}

358+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)

359+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)

360+-- | `PGenum` @(@`LabelsPG` @hask)@

361+type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)

362+

363+{- | The `VarArray` newtype is an indication that the Haskell

364+type it's applied to should be stored as a `PGvararray`.

365+

366+>>> :kind! PG (VarArray (Vector Double))

367+PG (VarArray (Vector Double)) :: PGType

368+= 'PGvararray ('NotNull 'PGfloat8)

369+-}

370+newtype VarArray arr = VarArray {getVarArray :: arr}

371+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)

372+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)

373+-- | `PGvararray` @(@`NullPG` @hask)@

374+type instance PG (VarArray (Vector hask)) = 'PGvararray (NullPG hask)

375+type instance PG (VarArray [hask]) = 'PGvararray (NullPG hask)

376+

377+{- | The `FixArray` newtype is an indication that the Haskell

378+type it's applied to should be stored as a `PGfixarray`.

379+

380+>>> :kind! PG (FixArray ((Double, Double), (Double, Double)))

381+PG (FixArray ((Double, Double), (Double, Double))) :: PGType

382+= 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)

383+-}

384+newtype FixArray arr = FixArray {getFixArray :: arr}

385+ deriving stock (Eq, Ord, Show, Read, GHC.Generic)

386+ deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)

387+-- | `PGfixarray` @(@`DimPG` @hask) (@`FixPG` @hask)@

388+type instance PG (FixArray hask) = 'PGfixarray (DimPG hask) (FixPG hask)

squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+312−211

@@ -6,12 +6,12 @@ Maintainer: eitan@morphism.tech

66Stability: experimental

88This module is where Squeal commands actually get executed by

9−`LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing

9+`Database.PostgreSQL.LibPQ`. It containts two typeclasses, `IndexedMonadTransPQ` for executing

1010a `Definition` and `MonadPQ` for executing a `Manipulation` or `Query`,

1111and a `PQ` type with instances for them.

1212

1313Using Squeal in your application will come down to defining

14−the @schema@ of your database and including @PQ schema schema@ in your

14+the @schemas@ of your database and including @PQ schemas schemas@ in your

1515application's monad transformer stack, giving it an instance of `MonadPQ`.

1616

1717This module also provides functions for retrieving rows from the `LibPQ.Result`

@@ -24,6 +24,7 @@ of executing Squeal commands.

2424 , FunctionalDependencies

2525 , FlexibleContexts

2626 , FlexibleInstances

27+ , InstanceSigs

2728 , OverloadedStrings

2829 , RankNTypes

2930 , ScopedTypeVariables

@@ -48,9 +49,7 @@ module Squeal.PostgreSQL.PQ

4849 , evalPQ

4950 , IndexedMonadTransPQ (..)

5051 , MonadPQ (..)

51− , PQRun

52− , pqliftWith

53− -- * Result

52+ -- * Results

5453 , LibPQ.Result

5554 , LibPQ.Row

5655 , ntuples

@@ -62,22 +61,33 @@ module Squeal.PostgreSQL.PQ

6261 , LibPQ.ExecStatus (..)

6362 , resultStatus

6463 , resultErrorMessage

64+ , resultErrorCode

65+ -- * Exceptions

66+ , SquealException (..)

67+ , PQState (..)

68+ , okResult

69+ , catchSqueal

70+ , handleSqueal

71+ , trySqueal

6572 ) where

6673

67−import Control.Exception.Lifted

68−import Control.Monad.Base

74+import Control.Exception (Exception, throw)

6975import Control.Monad.Except

7076import Control.Monad.Morph

71−import Control.Monad.Trans.Control

77+import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try)

7278import Data.ByteString (ByteString)

7379import Data.Foldable

7480import Data.Function ((&))

81+import Data.Functor ((<&>))

7582import Data.Kind

76−import Data.Monoid

83+import Data.Text (pack, Text)

7784import Data.Traversable

7885import Generics.SOP

86+import PostgreSQL.Binary.Encoding (encodingBytes)

7987

88+import qualified Control.Monad.Fail as Fail

8089import qualified Database.PostgreSQL.LibPQ as LibPQ

90+import qualified PostgreSQL.Binary.Encoding as Encoding

8191

8292import Squeal.PostgreSQL.Binary

8393import Squeal.PostgreSQL.Definition

@@ -90,7 +100,6 @@ import Control.Monad.Trans.Identity

90100import Control.Monad.Trans.Reader

91101import Control.Monad.Trans.Maybe

92102import Control.Monad.Trans.Cont

93−import Control.Monad.Trans.List

94103

95104import qualified Control.Monad.Trans.State.Lazy as Lazy

96105import qualified Control.Monad.Trans.State.Strict as Strict

@@ -99,6 +108,9 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict

99108import qualified Control.Monad.Trans.RWS.Lazy as Lazy

100109import qualified Control.Monad.Trans.RWS.Strict as Strict

101110

111+-- $setup

112+-- >>> import Squeal.PostgreSQL

113+

102114{- | Makes a new connection to the database server.

103115

104116This function opens a new database connection using the parameters taken

@@ -125,22 +137,22 @@ Note that, for now, squeal doesn't offer any protection from connecting

125137with the wrong schema!

126138-}

127139connectdb

128− :: forall schema io

129− . MonadBase IO io

140+ :: forall schemas io

141+ . MonadIO io

130142 => ByteString -- ^ conninfo

131− -> io (K LibPQ.Connection schema)

132−connectdb = fmap K . liftBase . LibPQ.connectdb

143+ -> io (K LibPQ.Connection schemas)

144+connectdb = fmap K . liftIO . LibPQ.connectdb

133145

134146-- | Closes the connection to the server.

135−finish :: MonadBase IO io => K LibPQ.Connection schema -> io ()

136−finish = liftBase . LibPQ.finish . unK

147+finish :: MonadIO io => K LibPQ.Connection schemas -> io ()

148+finish = liftIO . LibPQ.finish . unK

137149

138150-- | Do `connectdb` and `finish` before and after a computation.

139151withConnection

140− :: forall schema0 schema1 io x

141− . MonadBaseControl IO io

152+ :: forall schemas0 schemas1 io x

153+ . MonadUnliftIO io

142154 => ByteString

143− -> PQ schema0 schema1 io x

155+ -> PQ schemas0 schemas1 io x

144156 -> io x

145157withConnection connString action = do

146158 K x <- bracket (connectdb connString) finish (unPQ action)

@@ -148,47 +160,47 @@ withConnection connString action = do

148160

149161-- | Safely `lowerConnection` to a smaller schema.

150162lowerConnection

151− :: K LibPQ.Connection (table ': schema)

152− -> K LibPQ.Connection schema

163+ :: K LibPQ.Connection (schema ': schemas)

164+ -> K LibPQ.Connection schemas

153165lowerConnection (K conn) = K conn

154166

155167-- | We keep track of the schema via an Atkey indexed state monad transformer,

156168-- `PQ`.

157169newtype PQ

158− (schema0 :: SchemaType)

159− (schema1 :: SchemaType)

170+ (schemas0 :: SchemasType)

171+ (schemas1 :: SchemasType)

160172 (m :: Type -> Type)

161173 (x :: Type) =

162− PQ { unPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }

174+ PQ { unPQ :: K LibPQ.Connection schemas0 -> m (K x schemas1) }

163175

164−instance Monad m => Functor (PQ schema0 schema1 m) where

176+instance Monad m => Functor (PQ schemas0 schemas1 m) where

165177 fmap f (PQ pq) = PQ $ \ conn -> do

166178 K x <- pq conn

167179 return $ K (f x)

168180

169−-- | Run a `PQ` and keep the result and the `Connection`.

181+-- | Run a `PQ` and keep the result and the `LibPQ.Connection`.

170182runPQ

171183 :: Functor m

172− => PQ schema0 schema1 m x

173− -> K LibPQ.Connection schema0

174− -> m (x, K LibPQ.Connection schema1)

184+ => PQ schemas0 schemas1 m x

185+ -> K LibPQ.Connection schemas0

186+ -> m (x, K LibPQ.Connection schemas1)

175187runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn

176188 -- K x <- pq conn

177189 -- return (x, K (unK conn))

178190

179−-- | Execute a `PQ` and discard the result but keep the `Connection`.

191+-- | Execute a `PQ` and discard the result but keep the `LibPQ.Connection`.

180192execPQ

181193 :: Functor m

182− => PQ schema0 schema1 m x

183− -> K LibPQ.Connection schema0

184− -> m (K LibPQ.Connection schema1)

194+ => PQ schemas0 schemas1 m x

195+ -> K LibPQ.Connection schemas0

196+ -> m (K LibPQ.Connection schemas1)

185197execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn

186198

187−-- | Evaluate a `PQ` and discard the `Connection` but keep the result.

199+-- | Evaluate a `PQ` and discard the `LibPQ.Connection` but keep the result.

188200evalPQ

189201 :: Functor m

190− => PQ schema0 schema1 m x

191− -> K LibPQ.Connection schema0

202+ => PQ schemas0 schemas1 m x

203+ -> K LibPQ.Connection schemas0

192204 -> m x

193205evalPQ (PQ pq) conn = unK <$> pq conn

194206

@@ -196,60 +208,56 @@ evalPQ (PQ pq) conn = unK <$> pq conn

196208-- [enriched category](https://ncatlab.org/nlab/show/enriched+category).

197209-- An indexed monad transformer transforms a `Monad` into an indexed monad.

198210-- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that

199−-- support running `Definition`s using `define` and embedding a computation

200−-- in a larger schema using `pqEmbed`.

211+-- support running `Definition`s using `define`.

201212class IndexedMonadTransPQ pq where

202213

203214 -- | indexed analog of `<*>`

204215 pqAp

205216 :: Monad m

206− => pq schema0 schema1 m (x -> y)

207− -> pq schema1 schema2 m x

208− -> pq schema0 schema2 m y

217+ => pq schemas0 schemas1 m (x -> y)

218+ -> pq schemas1 schemas2 m x

219+ -> pq schemas0 schemas2 m y

209220

210221 -- | indexed analog of `join`

211222 pqJoin

212223 :: Monad m

213− => pq schema0 schema1 m (pq schema1 schema2 m y)

214− -> pq schema0 schema2 m y

224+ => pq schemas0 schemas1 m (pq schemas1 schemas2 m y)

225+ -> pq schemas0 schemas2 m y

215226 pqJoin pq = pq & pqBind id

216227

217228 -- | indexed analog of `=<<`

218229 pqBind

219230 :: Monad m

220− => (x -> pq schema1 schema2 m y)

221− -> pq schema0 schema1 m x

222− -> pq schema0 schema2 m y

231+ => (x -> pq schemas1 schemas2 m y)

232+ -> pq schemas0 schemas1 m x

233+ -> pq schemas0 schemas2 m y

223234

224235 -- | indexed analog of flipped `>>`

225236 pqThen

226237 :: Monad m

227− => pq schema1 schema2 m y

228− -> pq schema0 schema1 m x

229− -> pq schema0 schema2 m y

238+ => pq schemas1 schemas2 m y

239+ -> pq schemas0 schemas1 m x

240+ -> pq schemas0 schemas2 m y

230241 pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)

231242

232243 -- | indexed analog of `<=<`

233244 pqAndThen

234245 :: Monad m

235− => (y -> pq schema1 schema2 m z)

236− -> (x -> pq schema0 schema1 m y)

237− -> x -> pq schema0 schema2 m z

246+ => (y -> pq schemas1 schemas2 m z)

247+ -> (x -> pq schemas0 schemas1 m y)

248+ -> x -> pq schemas0 schemas2 m z

238249 pqAndThen g f x = pqBind g (f x)

239250

240− -- | Safely embed a computation in a larger schema.

241− pqEmbed

242− :: Monad m

243− => pq schema0 schema1 m x

244− -> pq (table ': schema0) (table : schema1) m x

245−

246− -- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law

251+ -- | Run a `Definition` with `LibPQ.exec`.

252+ --

253+ -- It should be functorial in effect.

247254 --

248− -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@

255+ -- @define id = return ()@

256+ -- @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@

249257 define

250− :: MonadBase IO io

251− => Definition schema0 schema1

252− -> pq schema0 schema1 io (K LibPQ.Result '[])

258+ :: MonadIO io

259+ => Definition schemas0 schemas1

260+ -> pq schemas0 schemas1 io ()

253261

254262instance IndexedMonadTransPQ PQ where

255263

@@ -262,26 +270,26 @@ instance IndexedMonadTransPQ PQ where

262270 K x' <- x conn

263271 unPQ (f x') (K (unK conn))

264272

265− pqEmbed (PQ pq) = PQ $ \ (K conn) -> do

266− K x <- pq (K conn)

267− return $ K x

268−

269273 define (UnsafeDefinition q) = PQ $ \ (K conn) -> do

270− resultMaybe <- liftBase $ LibPQ.exec conn q

274+ resultMaybe <- liftIO $ LibPQ.exec conn q

271275 case resultMaybe of

272− Nothing -> error

276+ Nothing -> throw $ ResultException

273277 "define: LibPQ.exec returned no results"

274− Just result -> return $ K (K result)

278+ Just result -> K <$> okResult_ result

275279

276−{- | `MonadPQ` is an `mtl` style constraint, similar to

277−`Control.Monad.State.Class.MonadState`, for using `LibPQ` to

280+{- | `MonadPQ` is an @mtl@ style constraint, similar to

281+`Control.Monad.State.Class.MonadState`, for using `Database.PostgreSQL.LibPQ` to

278282

279283* `manipulateParams` runs a `Manipulation` with params from a type

280284 with a `ToParams` constraint. It calls `LibPQ.execParams` and

281285 doesn't afraid of anything.

282286

287+* `manipulateParams_` is like `manipulateParams` for a returning-free statement.

288+

283289* `manipulate` is like `manipulateParams` for a parameter-free statement.

284290

291+* `manipulate_` is like `manipulate` for a returning-free statement.

292+

285293* `runQueryParams` is like `manipulateParams` for query statements.

286294

287295* `runQuery` is like `runQueryParams` for a parameter-free statement.

@@ -295,11 +303,11 @@ instance IndexedMonadTransPQ PQ where

295303* `forPrepared` is a flipped `traversePrepared`

296304

297305* `traversePrepared_` is like `traversePrepared` but works on `Foldable`

298− containers and returns unit.

306+ containers for a returning-free statement.

299307

300308* `forPrepared_` is a flipped `traversePrepared_`.

301309

302−* `liftPQ` lets you lift actions from `LibPQ` that require a connection

310+* `liftPQ` lets you lift actions from `Database.PostgreSQL.LibPQ` that require a connection

303311 into your monad.

304312

305313To define an instance, you can minimally define only `manipulateParams`,

@@ -307,305 +315,398 @@ To define an instance, you can minimally define only `manipulateParams`,

307315a default instance.

308316

309317-}

310−class Monad pq => MonadPQ schema pq | pq -> schema where

318+class Monad pq => MonadPQ schemas pq | pq -> schemas where

311319 manipulateParams

312− :: ToParams x params

313− => Manipulation schema params ys

314− -- ^ `insertRows`, `update` or `deleteFrom`

320+ :: (ToParams x params, All OidOfParam params)

321+ => Manipulation '[] schemas params ys

322+ -- ^ `insertInto`, `update` or `deleteFrom`

315323 -> x -> pq (K LibPQ.Result ys)

316324 default manipulateParams

317− :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

318− => ToParams x params

319− => Manipulation schema params ys

320− -- ^ `insertRows`, `update` or `deleteFrom`

325+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)

326+ => (ToParams x params, All OidOfParam params)

327+ => Manipulation '[] schemas params ys

328+ -- ^ `insertInto`, `update` or `deleteFrom`

321329 -> x -> pq (K LibPQ.Result ys)

322330 manipulateParams manipulation params = lift $

323331 manipulateParams manipulation params

324332

325− manipulate :: Manipulation schema '[] ys -> pq (K LibPQ.Result ys)

333+ manipulateParams_

334+ :: (ToParams x params, All OidOfParam params)

335+ => Manipulation '[] schemas params '[]

336+ -- ^ `insertInto`, `update` or `deleteFrom`

337+ -> x -> pq ()

338+ manipulateParams_ q x = void $ manipulateParams q x

339+

340+ manipulate :: Manipulation '[] schemas '[] ys -> pq (K LibPQ.Result ys)

326341 manipulate statement = manipulateParams statement ()

327342

343+ manipulate_ :: Manipulation '[] schemas '[] '[] -> pq ()

344+ manipulate_ = void . manipulate

345+

328346 runQueryParams

329− :: ToParams x params

330− => Query schema params ys

347+ :: (ToParams x params, All OidOfParam params)

348+ => Query '[] '[] schemas params ys

331349 -- ^ `select` and friends

332350 -> x -> pq (K LibPQ.Result ys)

333351 runQueryParams = manipulateParams . queryStatement

334352

335353 runQuery

336− :: Query schema '[] ys

354+ :: Query '[] '[] schemas '[] ys

337355 -- ^ `select` and friends

338356 -> pq (K LibPQ.Result ys)

339357 runQuery q = runQueryParams q ()

340358

341359 traversePrepared

342− :: (ToParams x params, Traversable list)

343− => Manipulation schema params ys

344− -- ^ `insertRows`, `update`, or `deleteFrom`, and friends

360+ :: (ToParams x params, Traversable list, All OidOfParam params)

361+ => Manipulation '[] schemas params ys

362+ -- ^ `insertInto`, `update`, or `deleteFrom`, and friends

345363 -> list x -> pq (list (K LibPQ.Result ys))

346364 default traversePrepared

347− :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

348− => (ToParams x params, Traversable list)

349− => Manipulation schema params ys -> list x -> pq (list (K LibPQ.Result ys))

365+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)

366+ => (ToParams x params, Traversable list, All OidOfParam params)

367+ => Manipulation '[] schemas params ys -> list x -> pq (list (K LibPQ.Result ys))

350368 traversePrepared manipulation params = lift $

351369 traversePrepared manipulation params

352370

353371 forPrepared

354− :: (ToParams x params, Traversable list)

372+ :: (ToParams x params, Traversable list, All OidOfParam params)

355373 => list x

356− -> Manipulation schema params ys

357− -- ^ `insertRows`, `update` or `deleteFrom`

374+ -> Manipulation '[] schemas params ys

375+ -- ^ `insertInto`, `update` or `deleteFrom`

358376 -> pq (list (K LibPQ.Result ys))

359377 forPrepared = flip traversePrepared

360378

361379 traversePrepared_

362− :: (ToParams x params, Foldable list)

363− => Manipulation schema params '[]

364− -- ^ `insertRows`, `update` or `deleteFrom`

380+ :: (ToParams x params, Foldable list, All OidOfParam params)

381+ => Manipulation '[] schemas params '[]

382+ -- ^ `insertInto`, `update` or `deleteFrom`

365383 -> list x -> pq ()

366384 default traversePrepared_

367− :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

368− => (ToParams x params, Foldable list)

369− => Manipulation schema params '[]

370− -- ^ `insertRows`, `update` or `deleteFrom`

385+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)

386+ => (ToParams x params, Foldable list, All OidOfParam params)

387+ => Manipulation '[] schemas params '[]

388+ -- ^ `insertInto`, `update` or `deleteFrom`

371389 -> list x -> pq ()

372390 traversePrepared_ manipulation params = lift $

373391 traversePrepared_ manipulation params

374392

375393 forPrepared_

376− :: (ToParams x params, Foldable list)

394+ :: (ToParams x params, Foldable list, All OidOfParam params)

377395 => list x

378− -> Manipulation schema params '[]

379− -- ^ `insertRows`, `update` or `deleteFrom`

396+ -> Manipulation '[] schemas params '[]

397+ -- ^ `insertInto`, `update` or `deleteFrom`

380398 -> pq ()

381399 forPrepared_ = flip traversePrepared_

382400

383401 liftPQ :: (LibPQ.Connection -> IO a) -> pq a

384402 default liftPQ

385− :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

403+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)

386404 => (LibPQ.Connection -> IO a) -> pq a

387405 liftPQ = lift . liftPQ

388406

389−instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)

390− => MonadPQ schema (PQ schema0 schema1 io) where

407+instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)

408+ => MonadPQ schemas (PQ schemas0 schemas1 io) where

391409

392410 manipulateParams

393− (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =

411+ (UnsafeManipulation q :: Manipulation '[] schemas ps ys) (params :: x) =

394412 PQ $ \ (K conn) -> do

395413 let

396− toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)

397− params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))

414+ paramSet

415+ :: forall param. OidOfParam param

416+ => K (Maybe Encoding.Encoding) param

417+ -> K (Maybe (LibPQ.Oid, ByteString, LibPQ.Format)) param

418+ paramSet (K maybeEncoding) = K $

419+ maybeEncoding <&> \encoding ->

420+ (oidOfParam @param, encodingBytes encoding, LibPQ.Binary)

421+ params'

422+ = hcollapse

423+ . hcmap (Proxy @OidOfParam) paramSet

424+ $ toParams @x @ps params

398425 q' = q <> ";"

399− resultMaybe <- liftBase $ LibPQ.execParams conn q' params' LibPQ.Binary

426+ resultMaybe <- liftIO $ LibPQ.execParams conn q' params' LibPQ.Binary

400427 case resultMaybe of

401− Nothing -> error

428+ Nothing -> throw $ ResultException

402429 "manipulateParams: LibPQ.execParams returned no results"

403− Just result -> return $ K (K result)

430+ Just result -> do

431+ okResult_ result

432+ return $ K (K result)

404433

405434 traversePrepared

406− (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

407− PQ $ \ (K conn) -> liftBase $ do

408− let temp = "temporary_statement"

409− prepResultMaybe <- LibPQ.prepare conn temp q Nothing

435+ (UnsafeManipulation q :: Manipulation '[] schemas xs ys) (list :: list x) =

436+ PQ $ \ (K conn) -> liftIO $ do

437+ let

438+ temp = "temporary_statement"

439+ paramOid :: forall p. OidOfParam p => K LibPQ.Oid p

440+ paramOid = K (oidOfParam @p)

441+ paramOids :: NP (K LibPQ.Oid) xs

442+ paramOids = hcpure (Proxy @OidOfParam) paramOid

443+ paramOids' :: [LibPQ.Oid]

444+ paramOids' = hcollapse paramOids

445+ prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')

410446 case prepResultMaybe of

411− Nothing -> error

447+ Nothing -> throw $ ResultException

412448 "traversePrepared: LibPQ.prepare returned no results"

413− Just prepResult -> do

414− status <- LibPQ.resultStatus prepResult

415− unless (status == LibPQ.CommandOk) . error $

416− "traversePrepared: LibPQ.prepare status " <> show status

449+ Just prepResult -> okResult_ prepResult

417450 results <- for list $ \ params -> do

418451 let

419− toParam' bytes = (bytes,LibPQ.Binary)

452+ toParam' encoding = (encodingBytes encoding, LibPQ.Binary)

420453 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

421454 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary

422455 case resultMaybe of

423− Nothing -> error

456+ Nothing -> throw $ ResultException

424457 "traversePrepared: LibPQ.execParams returned no results"

425− Just result -> return $ K result

458+ Just result -> do

459+ okResult_ result

460+ return $ K result

426461 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

427462 case deallocResultMaybe of

428− Nothing -> error

463+ Nothing -> throw $ ResultException

429464 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

430− Just deallocResult -> do

431− status <- LibPQ.resultStatus deallocResult

432− unless (status == LibPQ.CommandOk) . error $

433− "traversePrepared: DEALLOCATE status " <> show status

465+ Just deallocResult -> okResult_ deallocResult

434466 return (K results)

435467

436468 traversePrepared_

437− (UnsafeManipulation q :: Manipulation schema xs '[]) (list :: list x) =

438− PQ $ \ (K conn) -> liftBase $ do

439− let temp = "temporary_statement"

440− prepResultMaybe <- LibPQ.prepare conn temp q Nothing

469+ (UnsafeManipulation q :: Manipulation '[] schemas xs '[]) (list :: list x) =

470+ PQ $ \ (K conn) -> liftIO $ do

471+ let

472+ temp = "temporary_statement"

473+ paramOid :: forall p. OidOfParam p => K LibPQ.Oid p

474+ paramOid = K (oidOfParam @p)

475+ paramOids :: NP (K LibPQ.Oid) xs

476+ paramOids = hcpure (Proxy @OidOfParam) paramOid

477+ paramOids' :: [LibPQ.Oid]

478+ paramOids' = hcollapse paramOids

479+ prepResultMaybe <- LibPQ.prepare conn temp q (Just paramOids')

441480 case prepResultMaybe of

442− Nothing -> error

481+ Nothing -> throw $ ResultException

443482 "traversePrepared_: LibPQ.prepare returned no results"

444− Just prepResult -> do

445− status <- LibPQ.resultStatus prepResult

446− unless (status == LibPQ.CommandOk) . error $

447− "traversePrepared: LibPQ.prepare status " <> show status

483+ Just prepResult -> okResult_ prepResult

448484 for_ list $ \ params -> do

449485 let

450− toParam' bytes = (bytes,LibPQ.Binary)

486+ toParam' encoding = (encodingBytes encoding, LibPQ.Binary)

451487 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

452488 resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary

453489 case resultMaybe of

454− Nothing -> error

490+ Nothing -> throw $ ResultException

455491 "traversePrepared_: LibPQ.execParams returned no results"

456− Just _result -> return ()

492+ Just result -> okResult_ result

457493 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

458494 case deallocResultMaybe of

459− Nothing -> error

495+ Nothing -> throw $ ResultException

460496 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

461− Just deallocResult -> do

462− status <- LibPQ.resultStatus deallocResult

463− unless (status == LibPQ.CommandOk) . error $

464− "traversePrepared: DEALLOCATE status " <> show status

497+ Just deallocResult -> okResult_ deallocResult

465498 return (K ())

466499

467500 liftPQ pq = PQ $ \ (K conn) -> do

468− y <- liftBase $ pq conn

501+ y <- liftIO $ pq conn

469502 return (K y)

470503

471−instance MonadPQ schema m => MonadPQ schema (IdentityT m)

472−instance MonadPQ schema m => MonadPQ schema (ReaderT r m)

473−instance MonadPQ schema m => MonadPQ schema (Strict.StateT s m)

474−instance MonadPQ schema m => MonadPQ schema (Lazy.StateT s m)

475−instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Strict.WriterT w m)

476−instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Lazy.WriterT w m)

477−instance MonadPQ schema m => MonadPQ schema (MaybeT m)

478−instance MonadPQ schema m => MonadPQ schema (ExceptT e m)

479−instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Strict.RWST r w s m)

480−instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Lazy.RWST r w s m)

481−instance MonadPQ schema m => MonadPQ schema (ContT r m)

482−instance MonadPQ schema m => MonadPQ schema (ListT m)

483−

484−instance (Monad m, schema0 ~ schema1)

485− => Applicative (PQ schema0 schema1 m) where

504+instance MonadPQ schemas m => MonadPQ schemas (IdentityT m)

505+instance MonadPQ schemas m => MonadPQ schemas (ReaderT r m)

506+instance MonadPQ schemas m => MonadPQ schemas (Strict.StateT s m)

507+instance MonadPQ schemas m => MonadPQ schemas (Lazy.StateT s m)

508+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.WriterT w m)

509+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.WriterT w m)

510+instance MonadPQ schemas m => MonadPQ schemas (MaybeT m)

511+instance MonadPQ schemas m => MonadPQ schemas (ExceptT e m)

512+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Strict.RWST r w s m)

513+instance (Monoid w, MonadPQ schemas m) => MonadPQ schemas (Lazy.RWST r w s m)

514+instance MonadPQ schemas m => MonadPQ schemas (ContT r m)

515+

516+instance (Monad m, schemas0 ~ schemas1)

517+ => Applicative (PQ schemas0 schemas1 m) where

486518 pure x = PQ $ \ _conn -> pure (K x)

487519 (<*>) = pqAp

488520

489−instance (Monad m, schema0 ~ schema1)

490− => Monad (PQ schema0 schema1 m) where

521+instance (Monad m, schemas0 ~ schemas1)

522+ => Monad (PQ schemas0 schemas1 m) where

491523 return = pure

492524 (>>=) = flip pqBind

493525

494−instance schema0 ~ schema1 => MFunctor (PQ schema0 schema1) where

526+instance (Monad m, schemas0 ~ schemas1)

527+ => Fail.MonadFail (PQ schemas0 schemas1 m) where

528+ fail = Fail.fail

529+

530+instance schemas0 ~ schemas1 => MFunctor (PQ schemas0 schemas1) where

495531 hoist f (PQ pq) = PQ (f . pq)

496532

497−instance schema0 ~ schema1 => MonadTrans (PQ schema0 schema1) where

533+instance schemas0 ~ schemas1 => MonadTrans (PQ schemas0 schemas1) where

498534 lift m = PQ $ \ _conn -> do

499535 x <- m

500536 return (K x)

501537

502−instance schema0 ~ schema1 => MMonad (PQ schema0 schema1) where

538+instance schemas0 ~ schemas1 => MMonad (PQ schemas0 schemas1) where

503539 embed f (PQ pq) = PQ $ \ conn -> do

504540 evalPQ (f (pq conn)) conn

505541

506−instance (MonadBase b m, schema0 ~ schema1)

507− => MonadBase b (PQ schema0 schema1 m) where

508− liftBase = lift . liftBase

542+instance (MonadIO m, schema0 ~ schema1)

543+ => MonadIO (PQ schema0 schema1 m) where

544+ liftIO = lift . liftIO

509545

510−-- | A snapshot of the state of a `PQ` computation.

511−type PQRun schema =

512− forall m x. Monad m => PQ schema schema m x -> m (K x schema)

513−

514−-- | Helper function in defining `MonadBaseControl` instance for `PQ`.

515−pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a

516−pqliftWith f = PQ $ \ conn ->

517− fmap K (f $ \ pq -> unPQ pq conn)

518−

519−instance (MonadBaseControl b m, schema0 ~ schema1)

520− => MonadBaseControl b (PQ schema0 schema1 m) where

521− type StM (PQ schema0 schema1 m) x = StM m (K x schema0)

522− liftBaseWith f =

523− pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run

524− restoreM = PQ . const . restoreM

546+instance (MonadUnliftIO m, schemas0 ~ schemas1)

547+ => MonadUnliftIO (PQ schemas0 schemas1 m) where

548+ withRunInIO

549+ :: ((forall a . PQ schemas0 schema1 m a -> IO a) -> IO b)

550+ -> PQ schemas0 schema1 m b

551+ withRunInIO inner = PQ $ \conn ->

552+ withRunInIO $ \(run :: (forall x . m x -> IO x)) ->

553+ K <$> inner (\pq -> run $ unK <$> unPQ pq conn)

525554

526555-- | Get a row corresponding to a given row number from a `LibPQ.Result`,

527556-- throwing an exception if the row number is out of bounds.

528557getRow

529− :: (FromRow columns y, MonadBase IO io)

558+ :: (FromRow columns y, MonadIO io)

530559 => LibPQ.Row

531560 -- ^ row number

532561 -> K LibPQ.Result columns

533562 -- ^ result

534563 -> io y

535−getRow r (K result :: K LibPQ.Result columns) = liftBase $ do

564+getRow r (K result :: K LibPQ.Result columns) = liftIO $ do

536565 numRows <- LibPQ.ntuples result

537− when (numRows < r) $ error $

538− "getRow: expected at least " <> show r <> "rows but only saw "

539− <> show numRows

566+ when (numRows < r) $ throw $ ResultException $

567+ "getRow: expected at least " <> pack (show r) <> "rows but only saw "

568+ <> pack (show numRows)

540569 let len = fromIntegral (lengthSList (Proxy @columns))

541570 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

542571 case fromList row' of

543− Nothing -> error "getRow: found unexpected length"

544− Just row -> return $ fromRow @columns row

572+ Nothing -> throw $ ResultException "getRow: found unexpected length"

573+ Just row -> case fromRow @columns row of

574+ Left parseError -> throw $ ParseException $ "getRow: " <> parseError

575+ Right y -> return y

545576

546577-- | Intended to be used for unfolding in streaming libraries, `nextRow`

547578-- takes a total number of rows (which can be found with `ntuples`)

548579-- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`,

549580-- otherwise returning the row along with the next row number.

550581nextRow

551− :: (FromRow columns y, MonadBase IO io)

582+ :: (FromRow columns y, MonadIO io)

552583 => LibPQ.Row -- ^ total number of rows

553584 -> K LibPQ.Result columns -- ^ result

554585 -> LibPQ.Row -- ^ row number

555586 -> io (Maybe (LibPQ.Row,y))

556587nextRow total (K result :: K LibPQ.Result columns) r

557− = liftBase $ if r >= total then return Nothing else do

588+ = liftIO $ if r >= total then return Nothing else do

558589 let len = fromIntegral (lengthSList (Proxy @columns))

559590 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

560591 case fromList row' of

561− Nothing -> error "nextRow: found unexpected length"

562− Just row -> return $ Just (r+1, fromRow @columns row)

592+ Nothing -> throw $ ResultException "nextRow: found unexpected length"

593+ Just row -> case fromRow @columns row of

594+ Left parseError -> throw $ ParseException $ "nextRow: " <> parseError

595+ Right y -> return $ Just (r+1, y)

563596

564597-- | Get all rows from a `LibPQ.Result`.

565598getRows

566− :: (FromRow columns y, MonadBase IO io)

599+ :: (FromRow columns y, MonadIO io)

567600 => K LibPQ.Result columns -- ^ result

568601 -> io [y]

569−getRows (K result :: K LibPQ.Result columns) = liftBase $ do

602+getRows (K result :: K LibPQ.Result columns) = liftIO $ do

570603 let len = fromIntegral (lengthSList (Proxy @columns))

571604 numRows <- LibPQ.ntuples result

572605 for [0 .. numRows - 1] $ \ r -> do

573606 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

574607 case fromList row' of

575− Nothing -> error "getRows: found unexpected length"

576− Just row -> return $ fromRow @columns row

608+ Nothing -> throw $ ResultException "getRows: found unexpected length"

609+ Just row -> case fromRow @columns row of

610+ Left parseError -> throw $ ParseException $ "getRows: " <> parseError

611+ Right y -> return y

577612

578613-- | Get the first row if possible from a `LibPQ.Result`.

579614firstRow

580− :: (FromRow columns y, MonadBase IO io)

615+ :: (FromRow columns y, MonadIO io)

581616 => K LibPQ.Result columns -- ^ result

582617 -> io (Maybe y)

583−firstRow (K result :: K LibPQ.Result columns) = liftBase $ do

618+firstRow (K result :: K LibPQ.Result columns) = liftIO $ do

584619 numRows <- LibPQ.ntuples result

585620 if numRows <= 0 then return Nothing else do

586621 let len = fromIntegral (lengthSList (Proxy @columns))

587622 row' <- traverse (LibPQ.getvalue result 0) [0 .. len - 1]

588623 case fromList row' of

589− Nothing -> error "firstRow: found unexpected length"

590− Just row -> return . Just $ fromRow @columns row

624+ Nothing -> throw $ ResultException "firstRow: found unexpected length"

625+ Just row -> case fromRow @columns row of

626+ Left parseError -> throw $ ParseException $ "firstRow: " <> parseError

627+ Right y -> return $ Just y

591628

592629-- | Lifts actions on results from @LibPQ@.

593630liftResult

594− :: MonadBase IO io

631+ :: MonadIO io

595632 => (LibPQ.Result -> IO x)

596633 -> K LibPQ.Result results -> io x

597−liftResult f (K result) = liftBase $ f result

634+liftResult f (K result) = liftIO $ f result

598635

599636-- | Returns the number of rows (tuples) in the query result.

600−ntuples :: MonadBase IO io => K LibPQ.Result columns -> io LibPQ.Row

637+ntuples :: MonadIO io => K LibPQ.Result columns -> io LibPQ.Row

601638ntuples = liftResult LibPQ.ntuples

602639

603640-- | Returns the result status of the command.

604−resultStatus :: MonadBase IO io => K LibPQ.Result results -> io LibPQ.ExecStatus

641+resultStatus :: MonadIO io => K LibPQ.Result results -> io LibPQ.ExecStatus

605642resultStatus = liftResult LibPQ.resultStatus

606643

607644-- | Returns the error message most recently generated by an operation

608645-- on the connection.

609646resultErrorMessage

610− :: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)

647+ :: MonadIO io => K LibPQ.Result results -> io (Maybe ByteString)

611648resultErrorMessage = liftResult LibPQ.resultErrorMessage

649+

650+-- | Returns the error code most recently generated by an operation

651+-- on the connection.

652+--

653+-- https://www.postgresql.org/docs/current/static/errcodes-appendix.html

654+resultErrorCode

655+ :: MonadIO io

656+ => K LibPQ.Result results

657+ -> io (Maybe ByteString)

658+resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)

659+

660+-- | the state of LibPQ

661+data PQState = PQState

662+ { sqlExecStatus :: LibPQ.ExecStatus

663+ , sqlStateCode :: Maybe ByteString

664+ -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html

665+ , sqlErrorMessage :: Maybe ByteString

666+ } deriving (Eq, Show)

667+

668+-- | `Exception`s that can be thrown by Squeal.

669+data SquealException

670+ = PQException PQState

671+ | ResultException Text

672+ | ParseException Text

673+ deriving (Eq, Show)

674+instance Exception SquealException

675+

676+okResult_ :: MonadIO io => LibPQ.Result -> io ()

677+okResult_ result = liftIO $ do

678+ status <- LibPQ.resultStatus result

679+ case status of

680+ LibPQ.CommandOk -> return ()

681+ LibPQ.TuplesOk -> return ()

682+ _ -> do

683+ stateCode <- LibPQ.resultErrorField result LibPQ.DiagSqlstate

684+ msg <- LibPQ.resultErrorMessage result

685+ throw . PQException $ PQState status stateCode msg

686+

687+-- | Check if a `LibPQ.Result`'s status is either `LibPQ.CommandOk`

688+-- or `LibPQ.TuplesOk` otherwise `throw` a `PQException`.

689+okResult :: MonadIO io => K LibPQ.Result row -> io ()

690+okResult = okResult_ . unK

691+

692+-- | Catch `SquealException`s.

693+catchSqueal

694+ :: MonadUnliftIO io

695+ => io a

696+ -> (SquealException -> io a) -- ^ handler

697+ -> io a

698+catchSqueal = catch

699+

700+-- | Handle `SquealException`s.

701+handleSqueal

702+ :: MonadUnliftIO io

703+ => (SquealException -> io a) -- ^ handler

704+ -> io a -> io a

705+handleSqueal = handle

706+

707+-- | `Either` return a `SquealException` or a result.

708+trySqueal

709+ :: MonadUnliftIO io

710+ => io a

711+ -> io (Either SquealException a)

712+trySqueal = try

squeal-postgresql/src/Squeal/PostgreSQL/Pool.hs+69−79

@@ -1,17 +1,40 @@

11{-|

2−Module: Squeal.PostgreSQL.Definition

3−Description: Pooled connections

2+Module: Squeal.PostgreSQL.Pool

3+Description: Connection pools

44Copyright: (c) Eitan Chatav, 2017

55Maintainer: eitan@morphism.tech

66Stability: experimental

8−A `MonadPQ` for pooled connections.

8+Connection pools.

10+Typical use case would be to create your pool using `createConnectionPool`

11+and run anything that requires the pool connection with `usingConnectionPool`.

12+

13+Here's a simplified example:

14+

15+>>> import Squeal.PostgreSQL

16+

17+>>> :{

18+do

19+ let

20+ query :: Query_ (Public '[]) () (Only Char)

21+ query = values_ (literal 'a' `as` #fromOnly)

22+ pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb" 1 0.5 10

23+ chr <- usingConnectionPool pool $ do

24+ result <- runQuery query

25+ Just (Only a) <- firstRow result

26+ return a

27+ destroyConnectionPool pool

28+ putChar chr

29+:}

30+a

931-}

1032

1133{-# LANGUAGE

1234 DeriveFunctor

1335 , FlexibleContexts

1436 , FlexibleInstances

37+ , InstanceSigs

1538 , MultiParamTypeClasses

1639 , RankNTypes

1740 , ScopedTypeVariables

@@ -22,34 +45,24 @@ A `MonadPQ` for pooled connections.

2245

2346module Squeal.PostgreSQL.Pool

2447 ( -- * Pools

25− PoolPQ (..)

48+ Pool

2649 , createConnectionPool

27− , Pool

28− , destroyAllResources

29− , PoolPQRun

30− , poolpqliftWith

50+ , usingConnectionPool

51+ , destroyConnectionPool

3152 ) where

3253

33−import Control.Monad.Base

34−import Control.Monad.Trans

35−import Control.Monad.Trans.Control

3654import Data.ByteString

37−import Data.Pool

3855import Data.Time

39−import Generics.SOP (K(..))

56+import Generics.SOP (K(..), unK)

57+import UnliftIO (MonadUnliftIO (..))

58+import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)

4059

4160import Squeal.PostgreSQL.PQ

42−import Squeal.PostgreSQL.Schema

43−

44−-- | `PoolPQ` @schema@ should be a drop-in replacement for `PQ` @schema schema@.

45−newtype PoolPQ (schema :: SchemaType) m x =

46− PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x }

47− deriving Functor

4861

4962-- | Create a striped pool of connections.

5063-- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyAllResources` when you're done with the pool so that the connections are freed up as soon as possible.

5164createConnectionPool

52− :: MonadBase IO io

65+ :: MonadUnliftIO io

5366 => ByteString

5467 -- ^ The passed string can be empty to use all default parameters, or it can

5568 -- contain one or more parameter settings separated by whitespace.

@@ -65,68 +78,45 @@ createConnectionPool

6578 -> Int

6679 -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1.

6780 -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.

68− -> io (Pool (K Connection schema))

69−createConnectionPool conninfo stripes idle maxResrc = liftBase $

81+ -> io (Pool (K Connection schemas))

82+createConnectionPool conninfo stripes idle maxResrc =

7083 createPool (connectdb conninfo) finish stripes idle maxResrc

7184

72−-- | `Applicative` instance for `PoolPQ`.

73−instance Monad m => Applicative (PoolPQ schema m) where

74− pure x = PoolPQ $ \ _ -> pure x

75− PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do

76− f' <- f pool

77− x' <- x pool

78− return $ f' x'

79−

80−-- | `Monad` instance for `PoolPQ`.

81−instance Monad m => Monad (PoolPQ schema m) where

82− return = pure

83− PoolPQ x >>= f = PoolPQ $ \ pool -> do

84− x' <- x pool

85− runPoolPQ (f x') pool

86−

87−-- | `MonadTrans` instance for `PoolPQ`.

88−instance MonadTrans (PoolPQ schema) where

89− lift m = PoolPQ $ \ _pool -> m

90−

91−-- | `MonadBase` instance for `PoolPQ`.

92−instance MonadBase b m => MonadBase b (PoolPQ schema m) where

93− liftBase = lift . liftBase

85+{-|

86+Temporarily take a connection from a `Pool`, perform an action with it,

87+and return it to the pool afterwards.

9488

95−-- | `MonadPQ` instance for `PoolPQ`.

96−instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where

97− manipulateParams manipulation params = PoolPQ $ \ pool -> do

98− withResource pool $ \ conn -> do

99− (K result :: K (K Result ys) schema) <- flip unPQ conn $

100− manipulateParams manipulation params

101− return result

102− traversePrepared manipulation params = PoolPQ $ \ pool ->

103− withResource pool $ \ conn -> do

104− (K result :: K (list (K Result ys)) schema) <- flip unPQ conn $

105− traversePrepared manipulation params

106− return result

107− traversePrepared_ manipulation params = PoolPQ $ \ pool -> do

108− withResource pool $ \ conn -> do

109− (_ :: K () schema) <- flip unPQ conn $

110− traversePrepared_ manipulation params

111− return ()

112− liftPQ m = PoolPQ $ \ pool ->

113− withResource pool $ \ conn -> do

114− (K result :: K result schema) <- flip unPQ conn $

115− liftPQ m

116− return result

89+If the pool has an idle connection available, it is used immediately.

90+Otherwise, if the maximum number of connections has not yet been reached,

91+a new connection is created and used.

92+If the maximum number of connections has been reached, this function blocks

93+until a connection becomes available.

94+-}

95+usingConnectionPool

96+ :: MonadUnliftIO io

97+ => Pool (K Connection schemas) -- ^ pool

98+ -> PQ schemas schemas io x -- ^ session

99+ -> io x

100+usingConnectionPool pool (PQ session) = unK <$> withResource pool session

117101

118−-- | A snapshot of the state of a `PoolPQ` computation.

119−type PoolPQRun schema =

120− forall m x. Monad m => PoolPQ schema m x -> m x

102+{- |

103+Destroy all connections in all stripes in the pool.

104+Note that this will ignore any exceptions in the destroy function.

121105

122−-- | Helper function in defining `MonadBaseControl` instance for `PoolPQ`.

123−poolpqliftWith :: Functor m => (PoolPQRun schema -> m a) -> PoolPQ schema m a

124−poolpqliftWith f = PoolPQ $ \ pool ->

125− (f $ \ pq -> runPoolPQ pq pool)

106+This function is useful when you detect that all connections

107+in the pool are broken. For example after a database has been

108+restarted all connections opened before the restart will be broken.

109+In that case it's better to close those connections so that

110+`usingConnectionPool` won't take a broken connection from the pool

111+but will open a new connection instead.

126112

127−-- | `MonadBaseControl` instance for `PoolPQ`.

128−instance MonadBaseControl b m => MonadBaseControl b (PoolPQ schema m) where

129− type StM (PoolPQ schema m) x = StM m x

130− liftBaseWith f =

131− poolpqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run

132− restoreM = PoolPQ . const . restoreM

113+Another use-case for this function is that when you know you are done

114+with the pool you can destroy all idle connections immediately

115+instead of waiting on the garbage collector to destroy them,

116+thus freeing up those connections sooner.

117+-}

118+destroyConnectionPool

119+ :: MonadUnliftIO io

120+ => Pool (K Connection schemas) -- ^ pool

121+ -> io ()

122+destroyConnectionPool = destroyAllResources

squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+694−454

@@ -1,7 +1,7 @@

11{-|

22Module: Squeal.PostgreSQL.Query

33Description: Squeal queries

4−Copyright: (c) Eitan Chatav, 2017

4+Copyright: (c) Eitan Chatav, 2019

55Maintainer: eitan@morphism.tech

66Stability: experimental

@@ -9,70 +9,81 @@ Squeal queries.

99-}

1010

1111{-# LANGUAGE

12− DeriveGeneric

12+ ConstraintKinds

13+ , DeriveGeneric

1314 , FlexibleContexts

15+ , FlexibleInstances

1416 , GADTs

1517 , GeneralizedNewtypeDeriving

1618 , LambdaCase

19+ , MultiParamTypeClasses

20+ , OverloadedLabels

1721 , OverloadedStrings

22+ , QuantifiedConstraints

23+ , ScopedTypeVariables

1824 , StandaloneDeriving

25+ , TypeApplications

26+ , TypeFamilies

1927 , TypeInType

2028 , TypeOperators

21−#-}

29+ , RankNTypes

30+ , UndecidableInstances

31+ #-}

2232

2333module Squeal.PostgreSQL.Query

2434 ( -- * Queries

25− Query (UnsafeQuery, renderQuery)

35+ Query_

36+ , Query (..)

37+ -- ** Select

38+ , select

39+ , select_

40+ , selectDistinct

41+ , selectDistinct_

42+ , selectDistinctOn

43+ , selectDistinctOn_

44+ , Selection (..)

45+ -- ** Values

46+ , values

47+ , values_

48+ -- ** Set Operations

2649 , union

2750 , unionAll

2851 , intersect

2952 , intersectAll

3053 , except

3154 , exceptAll

32− -- * Select

33− , select

34− , selectDistinct

35− , selectStar

36− , selectDistinctStar

37− , selectDotStar

38− , selectDistinctDotStar

39− , values

40− , values_

55+ -- ** With

56+ , With (..)

57+ , CommonTableExpression (..)

58+ , withRecursive

4159 -- * Table Expressions

4260 , TableExpression (..)

43− , renderTableExpression

4461 , from

4562 , where_

46− , group

63+ , groupBy

4764 , having

48− , orderBy

4965 , limit

5066 , offset

51− -- * From

67+ -- * From Clauses

5268 , FromClause (..)

5369 , table

5470 , subquery

5571 , view

72+ , common

5673 , crossJoin

5774 , innerJoin

5875 , leftOuterJoin

5976 , rightOuterJoin

6077 , fullOuterJoin

6178 -- * Grouping

62− , By (By, By2)

63− , renderBy

64− , GroupByClause (NoGroups, Group)

65− , renderGroupByClause

66− , HavingClause (NoHaving, Having)

67− , renderHavingClause

68− -- * Sorting

69− , SortExpression (..)

70− , renderSortExpression

79+ , By (..)

80+ , GroupByClause (..)

81+ , HavingClause (..)

7182 ) where

7283

7384import Control.DeepSeq

7485import Data.ByteString (ByteString)

75−import Data.Monoid hiding (All)

86+import Data.Kind (Type)

7687import Data.String

7788import Data.Word

7889import Generics.SOP hiding (from)

@@ -80,352 +91,538 @@ import GHC.TypeLits

8091

8192import qualified GHC.Generics as GHC

8293

94+import Squeal.PostgreSQL.Alias

8395import Squeal.PostgreSQL.Expression

96+import Squeal.PostgreSQL.Expression.Logic

97+import Squeal.PostgreSQL.Expression.Sort

98+import Squeal.PostgreSQL.Expression.Window

99+import Squeal.PostgreSQL.List

100+import Squeal.PostgreSQL.PG

84101import Squeal.PostgreSQL.Render

85102import Squeal.PostgreSQL.Schema

86103

104+-- $setup

105+-- >>> import Squeal.PostgreSQL

106+-- >>> import Data.Int (Int32, Int64)

107+-- >>> import Data.Monoid (Sum (..))

108+-- >>> import Data.Text (Text)

109+-- >>> import qualified Generics.SOP as SOP

110+

111+{- |

112+The process of retrieving or the command to retrieve data from

113+a database is called a `Query`.

114+

115+The general `Query` type is parameterized by

116+

117+* @outer :: FromType@ - outer scope for a correlated subquery,

118+* @commons :: FromType@ - scope for all `common` table expressions,

119+* @schemas :: SchemasType@ - scope for all `table`s and `view`s,

120+* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,

121+* @row :: RowType@ - return type of the `Query`.

122+-}

123+newtype Query

124+ (outer :: FromType)

125+ (commons :: FromType)

126+ (schemas :: SchemasType)

127+ (params :: [NullityType])

128+ (row :: RowType)

129+ = UnsafeQuery { renderQuery :: ByteString }

130+ deriving (GHC.Generic,Show,Eq,Ord,NFData)

131+instance RenderSQL (Query outer commons schemas params row) where renderSQL = renderQuery

132+

87133{- |

88−The process of retrieving or the command to retrieve data from a database

89−is called a `Query`. The `select`, `selectStar`, `selectDotStar`,

90−`selectDistinct`, `selectDistinctStar` and `selectDistinctDotStar` commands

91−are used to specify queries.

134+The top level `Query_` type is parameterized by a @schemas@ `SchemasType`,

135+against which the query is type-checked, an input @parameters@ Haskell `Type`,

136+and an ouput row Haskell `Type`.

137+

138+A top-level query can be run

139+using `Squeal.PostgreSQL.PQ.runQueryParams`, or if @parameters = ()@

140+using `Squeal.PostgreSQL.PQ.runQuery`.

141+

142+Generally, @parameters@ will be a Haskell tuple or record whose entries

143+may be referenced using positional

144+`Squeal.PostgreSQL.Expression.Parameter.parameter`s and @row@ will be a

145+Haskell record, whose entries will be targeted using overloaded labels.

146+

147+Let's see some examples of queries.

148+

149+>>> :set -XDeriveAnyClass -XDerivingStrategies

150+>>> :{

151+data Row a b = Row { col1 :: a, col2 :: b }

152+ deriving stock (GHC.Generic)

153+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)

154+:}

92155

93156simple query:

94157

158+>>> type Columns = '["col1" ::: 'NoDef :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]

159+>>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]

95160>>> :{

96161let

97− query :: Query

98− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

99− '[]

100− '["col" ::: 'Null 'PGint4]

101− query = selectStar (from (table #tab))

102−in renderQuery query

162+ query :: Query_ (Public Schema) () (Row Int32 Int32)

163+ query = select Star (from (table #tab))

164+in printSQL query

103165:}

104−"SELECT * FROM \"tab\" AS \"tab\""

166+SELECT * FROM "tab" AS "tab"

105167

106168restricted query:

107169

108170>>> :{

109171let

110− query :: Query

111− '[ "tab" ::: 'Table ('[] :=>

112− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

113− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]

114− '[]

115− '[ "sum" ::: 'NotNull 'PGint4

116− , "col1" ::: 'NotNull 'PGint4 ]

172+ query :: Query_ (Public Schema) () (Row Int32 Int32)

117173 query =

118− select

119− ((#col1 + #col2) `As` #sum :* #col1 :* Nil)

174+ select_ ((#col1 + #col2) `as` #col1 :* #col1 `as` #col2)

120175 ( from (table #tab)

121176 & where_ (#col1 .> #col2)

122177 & where_ (#col2 .> 0) )

123−in renderQuery query

178+in printSQL query

124179:}

125−"SELECT (\"col1\" + \"col2\") AS \"sum\", \"col1\" AS \"col1\" FROM \"tab\" AS \"tab\" WHERE ((\"col1\" > \"col2\") AND (\"col2\" > 0))"

180+SELECT ("col1" + "col2") AS "col1", "col1" AS "col2" FROM "tab" AS "tab" WHERE (("col1" > "col2") AND ("col2" > 0))

126181

127182subquery:

128183

129184>>> :{

130185let

131− query :: Query

132− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

133− '[]

134− '["col" ::: 'Null 'PGint4]

135− query =

136− selectStar

137− (from (subquery (selectStar (from (table #tab)) `As` #sub)))

138−in renderQuery query

186+ query :: Query_ (Public Schema) () (Row Int32 Int32)

187+ query = select Star (from (subquery (select Star (from (table #tab)) `as` #sub)))

188+in printSQL query

139189:}

140−"SELECT * FROM (SELECT * FROM \"tab\" AS \"tab\") AS \"sub\""

190+SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub"

141191

142192limits and offsets:

143193

144194>>> :{

145195let

146− query :: Query

147− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

148− '[]

149− '["col" ::: 'Null 'PGint4]

150− query = selectStar

151− (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)

152−in renderQuery query

196+ query :: Query_ (Public Schema) () (Row Int32 Int32)

197+ query = select Star (from (table #tab) & limit 100 & offset 2 & limit 50 & offset 2)

198+in printSQL query

153199:}

154−"SELECT * FROM \"tab\" AS \"tab\" LIMIT 50 OFFSET 4"

200+SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4

155201

156202parameterized query:

157203

158204>>> :{

159205let

160− query :: Query

161− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8])]

162− '[ 'NotNull 'PGfloat8]

163− '["col" ::: 'NotNull 'PGfloat8]

164− query = selectStar

165− (from (table #tab) & where_ (#col .> param @1))

166−in renderQuery query

206+ query :: Query_ (Public Schema) (Only Int32) (Row Int32 Int32)

207+ query = select Star (from (table #tab) & where_ (#col1 .> param @1))

208+in printSQL query

167209:}

168−"SELECT * FROM \"tab\" AS \"tab\" WHERE (\"col\" > ($1 :: float8))"

210+SELECT * FROM "tab" AS "tab" WHERE ("col1" > ($1 :: int4))

169211

170212aggregation query:

171213

172214>>> :{

173215let

174− query :: Query

175− '[ "tab" ::: 'Table ('[] :=>

176− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

177− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]

178− '[]

179− '[ "sum" ::: 'NotNull 'PGint4

180− , "col1" ::: 'NotNull 'PGint4 ]

216+ query :: Query_ (Public Schema) () (Row Int64 Int32)

181217 query =

182− select (sum_ #col2 `As` #sum :* #col1 :* Nil)

183− ( from (table (#tab `As` #table1))

184− & group (By #col1 :* Nil)

185− & having (#col1 + sum_ #col2 .> 1) )

186−in renderQuery query

218+ select_ ((fromNull 0 (sum_ (All #col2))) `as` #col1 :* #col1 `as` #col2)

219+ ( from (table (#tab `as` #table1))

220+ & groupBy #col1

221+ & having (sum_ (Distinct #col2) .> 1) )

222+in printSQL query

187223:}

188−"SELECT sum(\"col2\") AS \"sum\", \"col1\" AS \"col1\" FROM \"tab\" AS \"table1\" GROUP BY \"col1\" HAVING ((\"col1\" + sum(\"col2\")) > 1)"

224+SELECT COALESCE(sum(ALL "col2"), 0) AS "col1", "col1" AS "col2" FROM "tab" AS "table1" GROUP BY "col1" HAVING (sum(DISTINCT "col2") > 1)

189225

190226sorted query:

191227

192228>>> :{

193229let

194− query :: Query

195− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

196− '[]

197− '["col" ::: 'Null 'PGint4]

198− query = selectStar

199− (from (table #tab) & orderBy [#col & AscNullsFirst])

200−in renderQuery query

230+ query :: Query_ (Public Schema) () (Row Int32 Int32)

231+ query = select Star (from (table #tab) & orderBy [#col1 & Asc])

232+in printSQL query

201233:}

202−"SELECT * FROM \"tab\" AS \"tab\" ORDER BY \"col\" ASC NULLS FIRST"

234+SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC

203235

204236joins:

205237

206−>>> :set -XFlexibleContexts

238+>>> :{

239+type OrdersColumns =

240+ '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

241+ , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4

242+ , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4

243+ , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4 ]

244+:}

245+

246+>>> :{

247+type OrdersConstraints =

248+ '["pk_orders" ::: PrimaryKey '["id"]

249+ ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]

250+ ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"] ]

251+:}

252+

253+>>> type NamesColumns = '["id" ::: 'NoDef :=> 'NotNull 'PGint4, "name" ::: 'NoDef :=> 'NotNull 'PGtext]

254+>>> type CustomersConstraints = '["pk_customers" ::: PrimaryKey '["id"]]

255+>>> type ShippersConstraints = '["pk_shippers" ::: PrimaryKey '["id"]]

256+>>> :{

257+type OrdersSchema =

258+ '[ "orders" ::: 'Table (OrdersConstraints :=> OrdersColumns)

259+ , "customers" ::: 'Table (CustomersConstraints :=> NamesColumns)

260+ , "shippers" ::: 'Table (ShippersConstraints :=> NamesColumns) ]

261+:}

262+

263+>>> :{

264+data Order = Order

265+ { price :: Float

266+ , customerName :: Text

267+ , shipperName :: Text

268+ } deriving GHC.Generic

269+instance SOP.Generic Order

270+instance SOP.HasDatatypeInfo Order

271+:}

272+

207273>>> :{

208274let

209− query :: Query

210− '[ "orders" ::: 'Table (

211− '["pk_orders" ::: PrimaryKey '["id"]

212− ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]

213− ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"]] :=>

214− '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

215− , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4

216− , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4

217− , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4

218− ])

219− , "customers" ::: 'Table (

220− '["pk_customers" ::: PrimaryKey '["id"]] :=>

221− '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

222− , "name" ::: 'NoDef :=> 'NotNull 'PGtext

223− ])

224− , "shippers" ::: 'Table (

225− '["pk_shippers" ::: PrimaryKey '["id"]] :=>

226− '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

227− , "name" ::: 'NoDef :=> 'NotNull 'PGtext

228− ])

229− ]

230− '[]

231− '[ "order_price" ::: 'NotNull 'PGfloat4

232− , "customer_name" ::: 'NotNull 'PGtext

233− , "shipper_name" ::: 'NotNull 'PGtext

234− ]

235− query = select

236− ( #o ! #price `As` #order_price :*

237− #c ! #name `As` #customer_name :*

238− #s ! #name `As` #shipper_name :* Nil )

239− ( from (table (#orders `As` #o)

240− & innerJoin (table (#customers `As` #c))

275+ query :: Query_ (Public OrdersSchema) () Order

276+ query = select_

277+ ( #o ! #price `as` #price :*

278+ #c ! #name `as` #customerName :*

279+ #s ! #name `as` #shipperName )

280+ ( from (table (#orders `as` #o)

281+ & innerJoin (table (#customers `as` #c))

241282 (#o ! #customer_id .== #c ! #id)

242− & innerJoin (table (#shippers `As` #s))

283+ & innerJoin (table (#shippers `as` #s))

243284 (#o ! #shipper_id .== #s ! #id)) )

244−in renderQuery query

285+in printSQL query

245286:}

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\")"

287+SELECT "o"."price" AS "price", "c"."name" AS "customerName", "s"."name" AS "shipperName" FROM "orders" AS "o" INNER JOIN "customers" AS "c" ON ("o"."customer_id" = "c"."id") INNER JOIN "shippers" AS "s" ON ("o"."shipper_id" = "s"."id")

247288

248289self-join:

249290

250291>>> :{

251292let

252− query :: Query

253− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

254− '[]

255− '["col" ::: 'Null 'PGint4]

256− query = selectDotStar #t1

257− (from (table (#tab `As` #t1) & crossJoin (table (#tab `As` #t2))))

258−in renderQuery query

293+ query :: Query_ (Public Schema) () (Row Int32 Int32)

294+ query = select

295+ (#t1 & DotStar)

296+ (from (table (#tab `as` #t1) & crossJoin (table (#tab `as` #t2))))

297+in printSQL query

259298:}

260−"SELECT \"t1\".* FROM \"tab\" AS \"t1\" CROSS JOIN \"tab\" AS \"t2\""

299+SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2"

300+

301+value queries:

302+

303+>>> :{

304+let

305+ query :: Query_ schemas () (Row String Bool)

306+ query = values

307+ ("true" `as` #col1 :* true `as` #col2)

308+ ["false" `as` #col1 :* false `as` #col2]

309+in printSQL query

310+:}

311+SELECT * FROM (VALUES (E'true', TRUE), (E'false', FALSE)) AS t ("col1", "col2")

261312

262313set operations:

263314

264315>>> :{

265316let

266− query :: Query

267− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

268− '[]

269− '["col" ::: 'Null 'PGint4]

317+ query :: Query_ (Public Schema) () (Row Int32 Int32)

318+ query = select Star (from (table #tab)) `unionAll` select Star (from (table #tab))

319+in printSQL query

320+:}

321+(SELECT * FROM "tab" AS "tab") UNION ALL (SELECT * FROM "tab" AS "tab")

322+

323+with queries:

324+

325+>>> :{

326+let

327+ query :: Query_ (Public Schema) () (Row Int32 Int32)

328+ query = with (

329+ select Star (from (table #tab)) `as` #cte1 :>>

330+ select Star (from (common #cte1)) `as` #cte2

331+ ) (select Star (from (common #cte2)))

332+in printSQL query

333+:}

334+WITH "cte1" AS (SELECT * FROM "tab" AS "tab"), "cte2" AS (SELECT * FROM "cte1" AS "cte1") SELECT * FROM "cte2" AS "cte2"

335+

336+window function queries

337+

338+>>> :{

339+let

340+ query :: Query_ (Public Schema) () (Row Int32 Int64)

341+ query = select

342+ (#col1 & Also (rank `as` #col2 `Over` (partitionBy #col1 & orderBy [#col2 & Asc])))

343+ (from (table #tab))

344+in printSQL query

345+:}

346+SELECT "col1" AS "col1", rank() OVER (PARTITION BY "col1" ORDER BY "col2" ASC) AS "col2" FROM "tab" AS "tab"

347+

348+correlated subqueries

349+

350+>>> :{

351+let

352+ query :: Query_ (Public Schema) () (Only Int32)

270353 query =

271− selectStar (from (table #tab))

272− `unionAll`

273− selectStar (from (table #tab))

274−in renderQuery query

354+ select (#col1 `as` #fromOnly) (from (table (#tab `as` #t1))

355+ & where_ (exists (

356+ select Star (from (table (#tab `as` #t2))

357+ & where_ (#t2 ! #col2 .== #t1 ! #col1)))))

358+in printSQL query

275359:}

276−"(SELECT * FROM \"tab\" AS \"tab\") UNION ALL (SELECT * FROM \"tab\" AS \"tab\")"

360+SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))

361+

277362-}

278−newtype Query

279− (schema :: SchemaType)

280− (params :: [NullityType])

281− (columns :: RelationType)

282− = UnsafeQuery { renderQuery :: ByteString }

283− deriving (GHC.Generic,Show,Eq,Ord,NFData)

363+type family Query_

364+ (schemas :: SchemasType)

365+ (parameters :: Type)

366+ (row :: Type) where

367+ Query_ schemas params row =

368+ Query '[] '[] schemas (TuplePG params) (RowPG row)

284369

285370-- | The results of two queries can be combined using the set operation

286371-- `union`. Duplicate rows are eliminated.

287372union

288− :: Query schema params columns

289− -> Query schema params columns

290− -> Query schema params columns

373+ :: Query outer commons schemas params columns

374+ -> Query outer commons schemas params columns

375+ -> Query outer commons schemas params columns

291376q1 `union` q2 = UnsafeQuery $

292− parenthesized (renderQuery q1)

377+ parenthesized (renderSQL q1)

293378 <+> "UNION"

294− <+> parenthesized (renderQuery q2)

379+ <+> parenthesized (renderSQL q2)

295380

296381-- | The results of two queries can be combined using the set operation

297382-- `unionAll`, the disjoint union. Duplicate rows are retained.

298383unionAll

299− :: Query schema params columns

300− -> Query schema params columns

301− -> Query schema params columns

384+ :: Query outer commons schemas params columns

385+ -> Query outer commons schemas params columns

386+ -> Query outer commons schemas params columns

302387q1 `unionAll` q2 = UnsafeQuery $

303− parenthesized (renderQuery q1)

388+ parenthesized (renderSQL q1)

304389 <+> "UNION" <+> "ALL"

305− <+> parenthesized (renderQuery q2)

390+ <+> parenthesized (renderSQL q2)

306391

307392-- | The results of two queries can be combined using the set operation

308393-- `intersect`, the intersection. Duplicate rows are eliminated.

309394intersect

310− :: Query schema params columns

311− -> Query schema params columns

312− -> Query schema params columns

395+ :: Query outer commons schemas params columns

396+ -> Query outer commons schemas params columns

397+ -> Query outer commons schemas params columns

313398q1 `intersect` q2 = UnsafeQuery $

314− parenthesized (renderQuery q1)

399+ parenthesized (renderSQL q1)

315400 <+> "INTERSECT"

316− <+> parenthesized (renderQuery q2)

401+ <+> parenthesized (renderSQL q2)

317402

318403-- | The results of two queries can be combined using the set operation

319404-- `intersectAll`, the intersection. Duplicate rows are retained.

320405intersectAll

321− :: Query schema params columns

322− -> Query schema params columns

323− -> Query schema params columns

406+ :: Query outer commons schemas params columns

407+ -> Query outer commons schemas params columns

408+ -> Query outer commons schemas params columns

324409q1 `intersectAll` q2 = UnsafeQuery $

325− parenthesized (renderQuery q1)

410+ parenthesized (renderSQL q1)

326411 <+> "INTERSECT" <+> "ALL"

327− <+> parenthesized (renderQuery q2)

412+ <+> parenthesized (renderSQL q2)

328413

329414-- | The results of two queries can be combined using the set operation

330415-- `except`, the set difference. Duplicate rows are eliminated.

331416except

332− :: Query schema params columns

333− -> Query schema params columns

334− -> Query schema params columns

417+ :: Query outer commons schemas params columns

418+ -> Query outer commons schemas params columns

419+ -> Query outer commons schemas params columns

335420q1 `except` q2 = UnsafeQuery $

336− parenthesized (renderQuery q1)

421+ parenthesized (renderSQL q1)

337422 <+> "EXCEPT"

338− <+> parenthesized (renderQuery q2)

423+ <+> parenthesized (renderSQL q2)

339424

340425-- | The results of two queries can be combined using the set operation

341426-- `exceptAll`, the set difference. Duplicate rows are retained.

342427exceptAll

343− :: Query schema params columns

344− -> Query schema params columns

345− -> Query schema params columns

428+ :: Query outer commons schemas params columns

429+ -> Query outer commons schemas params columns

430+ -> Query outer commons schemas params columns

346431q1 `exceptAll` q2 = UnsafeQuery $

347− parenthesized (renderQuery q1)

432+ parenthesized (renderSQL q1)

348433 <+> "EXCEPT" <+> "ALL"

349− <+> parenthesized (renderQuery q2)

434+ <+> parenthesized (renderSQL q2)

350435

351436{-----------------------------------------

352437SELECT queries

353438-----------------------------------------}

354439

440+{- | The simplest kinds of `Selection` are `Star` and `DotStar` which

441+emits all columns that a `TableExpression` produces. A select `List`

442+is a list of `Expression`s. A `Selection` could be a list of

443+`WindowFunction`s `Over` `WindowDefinition`. `Additional` `Selection`s can

444+be selected with `Also`.

445+-}

446+data Selection outer commons grp schemas params from row where

447+ Star

448+ :: HasUnique tab from row

449+ => Selection outer commons 'Ungrouped schemas params from row

450+ -- ^ `HasUnique` table in the `FromClause`

451+ DotStar

452+ :: Has tab from row

453+ => Alias tab

454+ -- ^ `Has` table with `Alias`

455+ -> Selection outer commons 'Ungrouped schemas params from row

456+ List

457+ :: SListI row

458+ => NP (Aliased (Expression outer commons grp schemas params from)) row

459+ -- ^ `NP` list of `Aliased` `Expression`s

460+ -> Selection outer commons grp schemas params from row

461+ Over

462+ :: SListI row

463+ => NP (Aliased (WindowFunction outer commons grp schemas params from)) row

464+ -- ^ `NP` list of `Aliased` `WindowFunction`s

465+ -> WindowDefinition outer commons grp schemas params from

466+ -> Selection outer commons grp schemas params from row

467+ Also

468+ :: Selection outer commons grp schemas params from right

469+ -- ^ `Additional` `Selection`

470+ -> Selection outer commons grp schemas params from left

471+ -> Selection outer commons grp schemas params from (Join left right)

472+instance Additional (Selection outer commons grp schemas params from) where

473+ also = Also

474+instance (KnownSymbol col, row ~ '[col ::: ty])

475+ => Aliasable col

476+ (Expression outer commons grp schemas params from ty)

477+ (Selection outer commons grp schemas params from row) where

478+ expr `as` col = List (expr `as` col)

479+instance (Has tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty])

480+ => IsQualified tab col

481+ (Selection outer commons 'Ungrouped schemas params from row1) where

482+ tab ! col = tab ! col `as` col

483+instance

484+ ( Has tab (Join outer from) row0

485+ , Has col row0 ty

486+ , row1 ~ '[col ::: ty]

487+ , GroupedBy tab col bys )

488+ => IsQualified tab col

489+ (Selection outer commons ('Grouped bys) schemas params from row1) where

490+ tab ! col = tab ! col `as` col

491+instance (HasUnique tab (Join outer from) row0, Has col row0 ty, row1 ~ '[col ::: ty])

492+ => IsLabel col

493+ (Selection outer commons 'Ungrouped schemas params from row1) where

494+ fromLabel = fromLabel @col `as` Alias

495+instance

496+ ( HasUnique tab (Join outer from) row0

497+ , Has col row0 ty

498+ , row1 ~ '[col ::: ty]

499+ , GroupedBy tab col bys )

500+ => IsLabel col

501+ (Selection outer commons ('Grouped bys) schemas params from row1) where

502+ fromLabel = fromLabel @col `as` Alias

503+

504+instance RenderSQL (Selection outer commons grp schemas params from row) where

505+ renderSQL = \case

506+ List list -> renderCommaSeparated (renderAliased renderSQL) list

507+ Star -> "*"

508+ DotStar tab -> renderSQL tab <> ".*"

509+ Also right left -> renderSQL left <> ", " <> renderSQL right

510+ Over winFns winDef ->

511+ let

512+ renderOver

513+ :: Aliased (WindowFunction outer commons grp schemas params from) field

514+ -> ByteString

515+ renderOver (winFn `As` col) = renderSQL winFn

516+ <+> "OVER" <+> parenthesized (renderSQL winDef)

517+ <+> "AS" <+> renderSQL col

518+ in

519+ renderCommaSeparated renderOver winFns

520+

521+instance IsString

522+ (Selection outer commons grp schemas params from '["fromOnly" ::: 'NotNull 'PGtext]) where

523+ fromString str = fromString str `as` Alias

524+

355525-- | the `TableExpression` in the `select` command constructs an intermediate

356526-- virtual table by possibly combining tables, views, eliminating rows,

357527-- grouping, etc. This table is finally passed on to processing by

358−-- the select list. The select list determines which columns of

528+-- the select list. The `Selection` determines which columns of

359529-- the intermediate table are actually output.

360530select

361− :: SListI columns

362− => NP (Aliased (Expression schema relations grouping params)) (column ': columns)

363− -- ^ select list

364− -> TableExpression schema params relations grouping

531+ :: (SListI row, row ~ (x ': xs))

532+ => Selection outer commons grp schemas params from row

533+ -- ^ selection

534+ -> TableExpression outer commons grp schemas params from

365535 -- ^ intermediate virtual table

366− -> Query schema params (column ': columns)

367−select list rels = UnsafeQuery $

536+ -> Query outer commons schemas params row

537+select selection tabexpr = UnsafeQuery $

368538 "SELECT"

369− <+> renderCommaSeparated (renderAliasedAs renderExpression) list

370− <+> renderTableExpression rels

539+ <+> renderSQL selection

540+ <+> renderSQL tabexpr

541+

542+-- | Like `select` but takes an `NP` list of `Expression`s instead

543+-- of a general `Selection`.

544+select_

545+ :: (SListI row, row ~ (x ': xs))

546+ => NP (Aliased (Expression outer commons grp schemas params from)) row

547+ -- ^ select list

548+ -> TableExpression outer commons grp schemas params from

549+ -- ^ intermediate virtual table

550+ -> Query outer commons schemas params row

551+select_ = select . List

371552

372553-- | After the select list has been processed, the result table can

373554-- be subject to the elimination of duplicate rows using `selectDistinct`.

374555selectDistinct

375− :: SListI columns

376− => NP (Aliased (Expression schema relations 'Ungrouped params)) (column ': columns)

377− -- ^ select list

378− -> TableExpression schema params relations 'Ungrouped

556+ :: (SListI columns, columns ~ (col ': cols))

557+ => Selection outer commons grp schemas params from columns

558+ -- ^ selection

559+ -> TableExpression outer commons grp schemas params from

379560 -- ^ intermediate virtual table

380− -> Query schema params (column ': columns)

381−selectDistinct list rels = UnsafeQuery $

561+ -> Query outer commons schemas params columns

562+selectDistinct selection tabexpr = UnsafeQuery $

382563 "SELECT DISTINCT"

383− <+> renderCommaSeparated (renderAliasedAs renderExpression) list

384− <+> renderTableExpression rels

385−

386−-- | The simplest kind of query is `selectStar` which emits all columns

387−-- that the table expression produces.

388−selectStar

389− :: HasUnique relation relations columns

390− => TableExpression schema params relations 'Ungrouped

391− -- ^ intermediate virtual table

392− -> Query schema params columns

393−selectStar rels = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression rels

394−

395−-- | A `selectDistinctStar` emits all columns that the table expression

396−-- produces and eliminates duplicate rows.

397−selectDistinctStar

398− :: HasUnique relation relations columns

399− => TableExpression schema params relations 'Ungrouped

564+ <+> renderSQL selection

565+ <+> renderSQL tabexpr

566+

567+-- | Like `selectDistinct` but takes an `NP` list of `Expression`s instead

568+-- of a general `Selection`.

569+selectDistinct_

570+ :: (SListI columns, columns ~ (col ': cols))

571+ => NP (Aliased (Expression outer commons grp schemas params from)) columns

572+ -- ^ select list

573+ -> TableExpression outer commons grp schemas params from

400574 -- ^ intermediate virtual table

401− -> Query schema params columns

402−selectDistinctStar rels = UnsafeQuery $

403− "SELECT DISTINCT" <+> "*" <+> renderTableExpression rels

404−

405−-- | When working with multiple tables, it can also be useful to ask

406−-- for all the columns of a particular table, using `selectDotStar`.

407−selectDotStar

408− :: Has relation relations columns

409− => Alias relation

410− -- ^ particular virtual subtable

411− -> TableExpression schema params relations 'Ungrouped

575+ -> Query outer commons schemas params columns

576+selectDistinct_ = selectDistinct . List

577+

578+{-|

579+`selectDistinctOn` keeps only the first row of each set of rows where

580+the given expressions evaluate to equal. The DISTINCT ON expressions are

581+interpreted using the same rules as for ORDER BY. ORDER BY is used to

582+ensure that the desired row appears first.

583+

584+The DISTINCT ON expression(s) must match the leftmost ORDER BY expression(s).

585+The ORDER BY clause will normally contain additional expression(s) that

586+determine the desired precedence of rows within each DISTINCT ON group.

587+

588+In order to guarantee they match and reduce redundancy, this function

589+will prepend the The DISTINCT ON expressions to the ORDER BY clause.

590+-}

591+selectDistinctOn

592+ :: (SListI columns, columns ~ (col ': cols))

593+ => [SortExpression outer commons grp schemas params from]

594+ -- ^ DISTINCT ON expression(s) and prepended to ORDER BY clause

595+ -> Selection outer commons grp schemas params from columns

596+ -- ^ selection

597+ -> TableExpression outer commons grp schemas params from

412598 -- ^ intermediate virtual table

413− -> Query schema params columns

414−selectDotStar rel relations = UnsafeQuery $

415− "SELECT" <+> renderAlias rel <> ".*" <+> renderTableExpression relations

416−

417−-- | A `selectDistinctDotStar` asks for all the columns of a particular table,

418−-- and eliminates duplicate rows.

419−selectDistinctDotStar

420− :: Has relation relations columns

421− => Alias relation

422− -- ^ particular virtual table

423− -> TableExpression schema params relations 'Ungrouped

599+ -> Query outer commons schemas params columns

600+selectDistinctOn distincts selection tab = UnsafeQuery $

601+ "SELECT DISTINCT ON"

602+ <+> parenthesized (commaSeparated (renderDistinctOn <$> distincts))

603+ <+> renderSQL selection

604+ <+> renderSQL (tab {orderByClause = distincts <> orderByClause tab})

605+ where

606+ renderDistinctOn = \case

607+ Asc expression -> renderSQL expression

608+ Desc expression -> renderSQL expression

609+ AscNullsFirst expression -> renderSQL expression

610+ DescNullsFirst expression -> renderSQL expression

611+ AscNullsLast expression -> renderSQL expression

612+ DescNullsLast expression -> renderSQL expression

613+

614+-- | Like `selectDistinctOn` but takes an `NP` list of `Expression`s instead

615+-- of a general `Selection`.

616+selectDistinctOn_

617+ :: (SListI columns, columns ~ (col ': cols))

618+ => [SortExpression outer commons grp schemas params from]

619+ -- ^ distinct on and return the first row in ordering

620+ -> NP (Aliased (Expression outer commons grp schemas params from)) columns

621+ -- ^ selection

622+ -> TableExpression outer commons grp schemas params from

424623 -- ^ intermediate virtual table

425− -> Query schema params columns

426−selectDistinctDotStar rel relations = UnsafeQuery $

427− "SELECT DISTINCT" <+> renderAlias rel <> ".*"

428− <+> renderTableExpression relations

624+ -> Query outer commons schemas params columns

625+selectDistinctOn_ distincts = selectDistinctOn distincts . List

429626

430627-- | `values` computes a row value or set of row values

431628-- specified by value expressions. It is most commonly used

@@ -433,16 +630,16 @@ selectDistinctDotStar rel relations = UnsafeQuery $

433630-- but it can be used on its own.

434631--

435632-- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]

436−-- >>> let query = values (1 `As` #a :* "one" `As` #b :* Nil) [] :: Query '[] '[] Row

437−-- >>> renderQuery query

438−-- "SELECT * FROM (VALUES (1, E'one')) AS t (\"a\", \"b\")"

633+-- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query outer commons schemas '[] Row

634+-- >>> printSQL query

635+-- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b")

439636values

440637 :: SListI cols

441− => NP (Aliased (Expression schema '[] 'Ungrouped params)) cols

442− -> [NP (Aliased (Expression schema '[] 'Ungrouped params)) cols]

638+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols

639+ -> [NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols]

443640 -- ^ When more than one row is specified, all the rows must

444641 -- must have the same number of elements

445− -> Query schema params cols

642+ -> Query outer commons schemas params cols

446643values rw rws = UnsafeQuery $ "SELECT * FROM"

447644 <+> parenthesized (

448645 "VALUES"

@@ -453,17 +650,17 @@ values rw rws = UnsafeQuery $ "SELECT * FROM"

453650 <+> parenthesized (renderCommaSeparated renderAliasPart rw)

454651 where

455652 renderAliasPart, renderValuePart

456− :: Aliased (Expression schema '[] 'Ungrouped params) ty -> ByteString

457− renderAliasPart (_ `As` name) = renderAlias name

458− renderValuePart (value `As` _) = renderExpression value

653+ :: Aliased (Expression outer commons 'Ungrouped schemas params '[] ) ty -> ByteString

654+ renderAliasPart (_ `As` name) = renderSQL name

655+ renderValuePart (value `As` _) = renderSQL value

459656

460657-- | `values_` computes a row value or set of row values

461658-- specified by value expressions.

462659values_

463660 :: SListI cols

464− => NP (Aliased (Expression schema '[] 'Ungrouped params)) cols

661+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols

465662 -- ^ one row of values

466− -> Query schema params cols

663+ -> Query outer commons schemas params cols

467664values_ rw = values rw []

468665

469666{-----------------------------------------

@@ -477,15 +674,17 @@ Table Expressions

477674-- to a table on disk, a so-called base table, but more complex expressions

478675-- can be used to modify or combine base tables in various ways.

479676data TableExpression

480− (schema :: SchemaType)

677+ (outer :: FromType)

678+ (commons :: FromType)

679+ (grp :: Grouping)

680+ (schemas :: SchemasType)

481681 (params :: [NullityType])

482− (relations :: RelationsType)

483− (grouping :: Grouping)

682+ (from :: FromType)

484683 = TableExpression

485− { fromClause :: FromClause schema params relations

684+ { fromClause :: FromClause outer commons schemas params from

486685 -- ^ A table reference that can be a table name, or a derived table such

487686 -- as a subquery, a @JOIN@ construct, or complex combinations of these.

488− , whereClause :: [Condition schema relations 'Ungrouped params]

687+ , whereClause :: [Condition outer commons 'Ungrouped schemas params from]

489688 -- ^ optional search coditions, combined with `.&&`. After the processing

490689 -- of the `fromClause` is done, each row of the derived virtual table

491690 -- is checked against the search condition. If the result of the

@@ -494,20 +693,20 @@ data TableExpression

494693 -- at least one column of the table generated in the `fromClause`;

495694 -- this is not required, but otherwise the WHERE clause will

496695 -- be fairly useless.

497− , groupByClause :: GroupByClause relations grouping

696+ , groupByClause :: GroupByClause grp from

498697 -- ^ The `groupByClause` is used to group together those rows in a table

499698 -- that have the same values in all the columns listed. The order in which

500699 -- the columns are listed does not matter. The effect is to combine each

501700 -- set of rows having common values into one group row that represents all

502701 -- rows in the group. This is done to eliminate redundancy in the output

503702 -- and/or compute aggregates that apply to these groups.

504− , havingClause :: HavingClause schema relations grouping params

703+ , havingClause :: HavingClause outer commons grp schemas params from

505704 -- ^ If a table has been grouped using `groupBy`, but only certain groups

506705 -- are of interest, the `havingClause` can be used, much like a

507706 -- `whereClause`, to eliminate groups from the result. Expressions in the

508707 -- `havingClause` can refer both to grouped expressions and to ungrouped

509708 -- expressions (which necessarily involve an aggregate function).

510− , orderByClause :: [SortExpression schema relations grouping params]

709+ , orderByClause :: [SortExpression outer commons grp schemas params from]

511710 -- ^ The `orderByClause` is for optional sorting. When more than one

512711 -- `SortExpression` is specified, the later (right) values are used to sort

513712 -- rows that are equal according to the earlier (left) values.

@@ -517,72 +716,69 @@ data TableExpression

517716 -- will be returned (but possibly fewer, if the query itself yields

518717 -- fewer rows).

519718 , offsetClause :: [Word64]

520− -- ^ The `offsetClause` is combined with `+` to give an offset count

719+ -- ^ The `offsetClause` is combined with `Prelude.+` to give an offset count

521720 -- if nonempty. The offset count says to skip that many rows before

522721 -- beginning to return rows. The rows are skipped before the limit count

523722 -- is applied.

524− }

723+ } deriving (GHC.Generic)

525724

526725-- | Render a `TableExpression`

527−renderTableExpression

528− :: TableExpression schema params relations grouping

529− -> ByteString

530−renderTableExpression

531− (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat

532− [ "FROM ", renderFromClause frm'

533− , renderWheres whs'

534− , renderGroupByClause grps'

535− , renderHavingClause hvs'

536− , renderOrderByClause srts'

537− , renderLimits lims'

538− , renderOffsets offs'

539− ]

540− where

541− renderWheres = \case

542− [] -> ""

543− wh:[] -> " WHERE" <+> renderExpression wh

544− wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)

545− renderOrderByClause = \case

546− [] -> ""

547− srts -> " ORDER BY"

548− <+> commaSeparated (renderSortExpression <$> srts)

549− renderLimits = \case

550− [] -> ""

551− lims -> " LIMIT" <+> fromString (show (minimum lims))

552− renderOffsets = \case

553− [] -> ""

554− offs -> " OFFSET" <+> fromString (show (sum offs))

726+instance RenderSQL (TableExpression outer commons grp schemas params from) where

727+ renderSQL

728+ (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat

729+ [ "FROM ", renderSQL frm'

730+ , renderWheres whs'

731+ , renderSQL grps'

732+ , renderSQL hvs'

733+ , renderOrderByClause srts'

734+ , renderLimits lims'

735+ , renderOffsets offs' ]

736+ where

737+ renderWheres = \case

738+ [] -> ""

739+ wh:[] -> " WHERE" <+> renderSQL wh

740+ wh:whs -> " WHERE" <+> renderSQL (foldr (.&&) wh whs)

741+ renderOrderByClause = \case

742+ [] -> ""

743+ srts -> " ORDER BY"

744+ <+> commaSeparated (renderSQL <$> srts)

745+ renderLimits = \case

746+ [] -> ""

747+ lims -> " LIMIT" <+> fromString (show (minimum lims))

748+ renderOffsets = \case

749+ [] -> ""

750+ offs -> " OFFSET" <+> fromString (show (sum offs))

555751

556752-- | A `from` generates a `TableExpression` from a table reference that can be

557753-- a table name, or a derived table such as a subquery, a JOIN construct,

558754-- or complex combinations of these. A `from` may be transformed by `where_`,

559−-- `group`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator

755+-- `groupBy`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator

560756-- to match the left-to-right sequencing of their placement in SQL.

561757from

562− :: FromClause schema params relations -- ^ table reference

563− -> TableExpression schema params relations 'Ungrouped

564−from rels = TableExpression rels [] NoGroups NoHaving [] [] []

758+ :: FromClause outer commons schemas params from -- ^ table reference

759+ -> TableExpression outer commons 'Ungrouped schemas params from

760+from tab = TableExpression tab [] noGroups NoHaving [] [] []

565761

566762-- | A `where_` is an endomorphism of `TableExpression`s which adds a

567763-- search condition to the `whereClause`.

568764where_

569− :: Condition schema relations 'Ungrouped params -- ^ filtering condition

570− -> TableExpression schema params relations grouping

571− -> TableExpression schema params relations grouping

765+ :: Condition outer commons 'Ungrouped schemas params from -- ^ filtering condition

766+ -> TableExpression outer commons grp schemas params from

767+ -> TableExpression outer commons grp schemas params from

572768where_ wh rels = rels {whereClause = wh : whereClause rels}

573769

574−-- | A `group` is a transformation of `TableExpression`s which switches

575−-- its `Grouping` from `Ungrouped` to `Grouped`. Use @group Nil@ to perform

770+-- | A `groupBy` is a transformation of `TableExpression`s which switches

771+-- its `Grouping` from `Ungrouped` to `Grouped`. Use @groupBy Nil@ to perform

576772-- a "grand total" aggregation query.

577−group

773+groupBy

578774 :: SListI bys

579− => NP (By relations) bys -- ^ grouped columns

580− -> TableExpression schema params relations 'Ungrouped

581− -> TableExpression schema params relations ('Grouped bys)

582−group bys rels = TableExpression

775+ => NP (By from) bys -- ^ grouped columns

776+ -> TableExpression outer commons 'Ungrouped schemas params from

777+ -> TableExpression outer commons ('Grouped bys) schemas params from

778+groupBy bys rels = TableExpression

583779 { fromClause = fromClause rels

584780 , whereClause = whereClause rels

585− , groupByClause = Group bys

781+ , groupByClause = group bys

586782 , havingClause = Having []

587783 , orderByClause = []

588784 , limitClause = limitClause rels

@@ -592,34 +788,29 @@ group bys rels = TableExpression

592788-- | A `having` is an endomorphism of `TableExpression`s which adds a

593789-- search condition to the `havingClause`.

594790having

595− :: Condition schema relations ('Grouped bys) params -- ^ having condition

596− -> TableExpression schema params relations ('Grouped bys)

597− -> TableExpression schema params relations ('Grouped bys)

791+ :: Condition outer commons ('Grouped bys) schemas params from -- ^ having condition

792+ -> TableExpression outer commons ('Grouped bys) schemas params from

793+ -> TableExpression outer commons ('Grouped bys) schemas params from

598794having hv rels = rels

599795 { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) }

600796

601−-- | An `orderBy` is an endomorphism of `TableExpression`s which appends an

602−-- ordering to the right of the `orderByClause`.

603−orderBy

604− :: [SortExpression schema relations grouping params] -- ^ sort expressions

605− -> TableExpression schema params relations grouping

606− -> TableExpression schema params relations grouping

607−orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}

797+instance OrderBy TableExpression where

798+ orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}

608799

609800-- | A `limit` is an endomorphism of `TableExpression`s which adds to the

610801-- `limitClause`.

611802limit

612803 :: Word64 -- ^ limit parameter

613− -> TableExpression schema params relations grouping

614− -> TableExpression schema params relations grouping

804+ -> TableExpression outer commons grp schemas params from

805+ -> TableExpression outer commons grp schemas params from

615806limit lim rels = rels {limitClause = lim : limitClause rels}

616807

617808-- | An `offset` is an endomorphism of `TableExpression`s which adds to the

618809-- `offsetClause`.

619810offset

620811 :: Word64 -- ^ offset parameter

621− -> TableExpression schema params relations grouping

622− -> TableExpression schema params relations grouping

812+ -> TableExpression outer commons grp schemas params from

813+ -> TableExpression outer commons grp schemas params from

623814offset off rels = rels {offsetClause = off : offsetClause rels}

624815

625816{-----------------------------------------

@@ -630,61 +821,76 @@ FROM clauses

630821A `FromClause` can be a table name, or a derived table such

631822as a subquery, a @JOIN@ construct, or complex combinations of these.

632823-}

633−newtype FromClause schema params relations

824+newtype FromClause outer commons schemas params from

634825 = UnsafeFromClause { renderFromClause :: ByteString }

635826 deriving (GHC.Generic,Show,Eq,Ord,NFData)

827+instance RenderSQL (FromClause outer commons schemas params from) where

828+ renderSQL = renderFromClause

636829

637−-- | A real `table` is a table from the schema.

830+-- | A real `table` is a table from the database.

638831table

639− :: Has tab schema ('Table table)

640− => Aliased Alias (alias ::: tab)

641− -> FromClause schema params '[alias ::: TableToRelation table]

832+ :: (Has sch schemas schema, Has tab schema ('Table table))

833+ => Aliased (QualifiedAlias sch) (alias ::: tab)

834+ -> FromClause outer commons schemas params '[alias ::: TableToRow table]

642835table (tab `As` alias) = UnsafeFromClause $

643− renderAlias tab <+> "AS" <+> renderAlias alias

836+ renderSQL tab <+> "AS" <+> renderSQL alias

644837

645838-- | `subquery` derives a table from a `Query`.

646839subquery

647− :: Aliased (Query schema params) rel

648− -> FromClause schema params '[rel]

649−subquery = UnsafeFromClause . renderAliasedAs (parenthesized . renderQuery)

840+ :: Aliased (Query outer commons schemas params) query

841+ -> FromClause outer commons schemas params '[query]

842+subquery = UnsafeFromClause . renderAliased (parenthesized . renderSQL)

650843

651844-- | `view` derives a table from a `View`.

652845view

653− :: Has view schema ('View rel)

654− => Aliased Alias (alias ::: view)

655− -> FromClause schema params '[alias ::: rel]

846+ :: (Has sch schemas schema, Has vw schema ('View view))

847+ => Aliased (QualifiedAlias sch) (alias ::: vw)

848+ -> FromClause outer commons schemas params '[alias ::: view]

656849view (vw `As` alias) = UnsafeFromClause $

657− renderAlias vw <+> "AS" <+> renderAlias alias

850+ renderSQL vw <+> "AS" <+> renderSQL alias

658851

659−{- | @left & crossJoin right@. For every possible combination of rows from

660− @left@ and @right@ (i.e., a Cartesian product), the joined table will contain

661− a row consisting of all columns in @left@ followed by all columns in @right@.

662− If the tables have @n@ and @m@ rows respectively, the joined table will

663− have @n * m@ rows.

852+-- | `common` derives a table from a common table expression.

853+common

854+ :: Has cte commons common

855+ => Aliased Alias (alias ::: cte)

856+ -> FromClause outer commons schemas params '[alias ::: common]

857+common (cte `As` alias) = UnsafeFromClause $

858+ renderSQL cte <+> "AS" <+> renderSQL alias

859+

860+instance Additional (FromClause outer commons schemas params) where

861+ also right left = UnsafeFromClause $

862+ renderSQL left <> ", " <> renderSQL right

863+

864+{- |

865+@left & crossJoin right@. For every possible combination of rows from

866+@left@ and @right@ (i.e., a Cartesian product), the joined table will contain

867+a row consisting of all columns in @left@ followed by all columns in @right@.

868+If the tables have @n@ and @m@ rows respectively, the joined table will

869+have @n * m@ rows.

664870-}

665871crossJoin

666− :: FromClause schema params right

872+ :: FromClause outer commons schemas params right

667873 -- ^ right

668− -> FromClause schema params left

874+ -> FromClause outer commons schemas params left

669875 -- ^ left

670− -> FromClause schema params (Join left right)

876+ -> FromClause outer commons schemas params (Join left right)

671877crossJoin right left = UnsafeFromClause $

672− renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right

878+ renderSQL left <+> "CROSS JOIN" <+> renderSQL right

673879

674880{- | @left & innerJoin right on@. The joined table is filtered by

675881the @on@ condition.

676882-}

677883innerJoin

678− :: FromClause schema params right

884+ :: FromClause outer commons schemas params right

679885 -- ^ right

680− -> Condition schema (Join left right) 'Ungrouped params

886+ -> Condition outer commons 'Ungrouped schemas params (Join left right)

681887 -- ^ @on@ condition

682− -> FromClause schema params left

888+ -> FromClause outer commons schemas params left

683889 -- ^ left

684− -> FromClause schema params (Join left right)

890+ -> FromClause outer commons schemas params (Join left right)

685891innerJoin right on left = UnsafeFromClause $

686− renderFromClause left <+> "INNER JOIN" <+> renderFromClause right

687− <+> "ON" <+> renderExpression on

892+ renderSQL left <+> "INNER JOIN" <+> renderSQL right

893+ <+> "ON" <+> renderSQL on

688894

689895{- | @left & leftOuterJoin right on@. First, an inner join is performed.

690896 Then, for each row in @left@ that does not satisfy the @on@ condition with

@@ -692,16 +898,16 @@ innerJoin right on left = UnsafeFromClause $

692898 Thus, the joined table always has at least one row for each row in @left@.

693899-}

694900leftOuterJoin

695− :: FromClause schema params right

901+ :: FromClause outer commons schemas params right

696902 -- ^ right

697− -> Condition schema (Join left right) 'Ungrouped params

903+ -> Condition outer commons 'Ungrouped schemas params (Join left right)

698904 -- ^ @on@ condition

699− -> FromClause schema params left

905+ -> FromClause outer commons schemas params left

700906 -- ^ left

701− -> FromClause schema params (Join left (NullifyRelations right))

907+ -> FromClause outer commons schemas params (Join left (NullifyFrom right))

702908leftOuterJoin right on left = UnsafeFromClause $

703− renderFromClause left <+> "LEFT OUTER JOIN" <+> renderFromClause right

704− <+> "ON" <+> renderExpression on

909+ renderSQL left <+> "LEFT OUTER JOIN" <+> renderSQL right

910+ <+> "ON" <+> renderSQL on

705911

706912{- | @left & rightOuterJoin right on@. First, an inner join is performed.

707913 Then, for each row in @right@ that does not satisfy the @on@ condition with

@@ -710,16 +916,16 @@ leftOuterJoin right on left = UnsafeFromClause $

710916 have a row for each row in @right@.

711917-}

712918rightOuterJoin

713− :: FromClause schema params right

919+ :: FromClause outer commons schemas params right

714920 -- ^ right

715− -> Condition schema (Join left right) 'Ungrouped params

921+ -> Condition outer commons 'Ungrouped schemas params (Join left right)

716922 -- ^ @on@ condition

717− -> FromClause schema params left

923+ -> FromClause outer commons schemas params left

718924 -- ^ left

719− -> FromClause schema params (Join (NullifyRelations left) right)

925+ -> FromClause outer commons schemas params (Join (NullifyFrom left) right)

720926rightOuterJoin right on left = UnsafeFromClause $

721− renderFromClause left <+> "RIGHT OUTER JOIN" <+> renderFromClause right

722− <+> "ON" <+> renderExpression on

927+ renderSQL left <+> "RIGHT OUTER JOIN" <+> renderSQL right

928+ <+> "ON" <+> renderSQL on

723929

724930{- | @left & fullOuterJoin right on@. First, an inner join is performed.

725931 Then, for each row in @left@ that does not satisfy the @on@ condition with

@@ -729,47 +935,56 @@ rightOuterJoin right on left = UnsafeFromClause $

729935 is added.

730936-}

731937fullOuterJoin

732− :: FromClause schema params right

938+ :: FromClause outer commons schemas params right

733939 -- ^ right

734− -> Condition schema (Join left right) 'Ungrouped params

940+ -> Condition outer commons 'Ungrouped schemas params (Join left right)

735941 -- ^ @on@ condition

736− -> FromClause schema params left

942+ -> FromClause outer commons schemas params left

737943 -- ^ left

738− -> FromClause schema params

739− (Join (NullifyRelations left) (NullifyRelations right))

944+ -> FromClause outer commons schemas params

945+ (Join (NullifyFrom left) (NullifyFrom right))

740946fullOuterJoin right on left = UnsafeFromClause $

741− renderFromClause left <+> "FULL OUTER JOIN" <+> renderFromClause right

742− <+> "ON" <+> renderExpression on

947+ renderSQL left <+> "FULL OUTER JOIN" <+> renderSQL right

948+ <+> "ON" <+> renderSQL on

743949

744950{-----------------------------------------

745951Grouping

746952-----------------------------------------}

747953

748−-- | `By`s are used in `group` to reference a list of columns which are then

954+-- | `By`s are used in `groupBy` to reference a list of columns which are then

749955-- used to group together those rows in a table that have the same values

750956-- in all the columns listed. @By \#col@ will reference an unambiguous

751957-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table

752958-- qualified column @tab.col@.

753959data By

754− (relations :: RelationsType)

960+ (from :: FromType)

755961 (by :: (Symbol,Symbol)) where

756− By

757− :: (HasUnique relation relations columns, Has column columns ty)

962+ By1

963+ :: (HasUnique table from columns, Has column columns ty)

758964 => Alias column

759− -> By relations '(relation, column)

965+ -> By from '(table, column)

760966 By2

761− :: (Has relation relations columns, Has column columns ty)

762− => (Alias relation, Alias column)

763− -> By relations '(relation, column)

764−deriving instance Show (By relations by)

765−deriving instance Eq (By relations by)

766−deriving instance Ord (By relations by)

767−

768−-- | Renders a `By`.

769−renderBy :: By relations by -> ByteString

770−renderBy = \case

771− By column -> renderAlias column

772− By2 (rel, column) -> renderAlias rel <> "." <> renderAlias column

967+ :: (Has table from columns, Has column columns ty)

968+ => Alias table

969+ -> Alias column

970+ -> By from '(table, column)

971+deriving instance Show (By from by)

972+deriving instance Eq (By from by)

973+deriving instance Ord (By from by)

974+instance RenderSQL (By from by) where

975+ renderSQL = \case

976+ By1 column -> renderSQL column

977+ By2 rel column -> renderSQL rel <> "." <> renderSQL column

978+

979+instance (HasUnique rel rels cols, Has col cols ty, by ~ '(rel, col))

980+ => IsLabel col (By rels by) where fromLabel = By1 fromLabel

981+instance (HasUnique rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])

982+ => IsLabel col (NP (By rels) bys) where fromLabel = By1 fromLabel :* Nil

983+instance (Has rel rels cols, Has col cols ty, by ~ '(rel, col))

984+ => IsQualified rel col (By rels by) where (!) = By2

985+instance (Has rel rels cols, Has col cols ty, bys ~ '[ '(rel, col)])

986+ => IsQualified rel col (NP (By rels) bys) where

987+ rel ! col = By2 rel col :* Nil

773988

774989-- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.

775990-- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`.

@@ -777,82 +992,107 @@ renderBy = \case

777992-- done on @NoGroups@ while all output `Expression`s must be aggregated

778993-- in @Group Nil@. In general, all output `Expression`s in the

779994-- complement of @bys@ must be aggregated in @Group bys@.

780−data GroupByClause relations grouping where

781− NoGroups :: GroupByClause relations 'Ungrouped

782− Group

783− :: SListI bys

784− => NP (By relations) bys

785− -> GroupByClause relations ('Grouped bys)

786−

787−-- | Renders a `GroupByClause`.

788−renderGroupByClause :: GroupByClause relations grouping -> ByteString

789−renderGroupByClause = \case

790− NoGroups -> ""

791− Group Nil -> ""

792− Group bys -> " GROUP BY" <+> renderCommaSeparated renderBy bys

995+newtype GroupByClause grp from = UnsafeGroupByClause

996+ { renderGroupByClause :: ByteString }

997+ deriving (GHC.Generic,Show,Eq,Ord,NFData)

998+instance RenderSQL (GroupByClause grp from) where

999+ renderSQL = renderGroupByClause

1000+noGroups :: GroupByClause 'Ungrouped from

1001+noGroups = UnsafeGroupByClause ""

1002+group

1003+ :: SListI bys

1004+ => NP (By from) bys

1005+ -> GroupByClause ('Grouped bys) from

1006+group bys = UnsafeGroupByClause $ case bys of

1007+ Nil -> ""

1008+ bys' -> " GROUP BY" <+> renderCommaSeparated renderSQL bys'

7931009

7941010-- | A `HavingClause` is used to eliminate groups that are not of interest.

7951011-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`

7961012-- `TableExpression` must use `Having` whose conditions are combined with

7971013-- `.&&`.

798−data HavingClause schema relations grouping params where

799− NoHaving :: HavingClause schema relations 'Ungrouped params

1014+data HavingClause outer commons grp schemas params from where

1015+ NoHaving :: HavingClause outer commons 'Ungrouped schemas params from

8001016 Having

801− :: [Condition schema relations ('Grouped bys) params]

802− -> HavingClause schema relations ('Grouped bys) params

803−deriving instance Show (HavingClause schema relations grouping params)

804−deriving instance Eq (HavingClause schema relations grouping params)

805−deriving instance Ord (HavingClause schema relations grouping params)

1017+ :: [Condition outer commons ('Grouped bys) schemas params from]

1018+ -> HavingClause outer commons ('Grouped bys) schemas params from

1019+deriving instance Show (HavingClause outer commons grp schemas params from)

1020+deriving instance Eq (HavingClause outer commons grp schemas params from)

1021+deriving instance Ord (HavingClause outer commons grp schemas params from)

8061022

8071023-- | Render a `HavingClause`.

808−renderHavingClause :: HavingClause schema relations grouping params -> ByteString

809−renderHavingClause = \case

810− NoHaving -> ""

811− Having [] -> ""

812− Having conditions ->

813− " HAVING" <+> commaSeparated (renderExpression <$> conditions)

814−

815−{-----------------------------------------

816−Sorting

817−-----------------------------------------}

1024+instance RenderSQL (HavingClause outer commons grp schemas params from) where

1025+ renderSQL = \case

1026+ NoHaving -> ""

1027+ Having [] -> ""

1028+ Having conditions ->

1029+ " HAVING" <+> commaSeparated (renderSQL <$> conditions)

1030+

1031+-- | A `CommonTableExpression` is an auxiliary statement in a `with` clause.

1032+data CommonTableExpression statement

1033+ (schemas :: SchemasType)

1034+ (params :: [NullityType])

1035+ (commons0 :: FromType)

1036+ (commons1 :: FromType) where

1037+ CommonTableExpression

1038+ :: Aliased (statement commons schemas params) (cte ::: common)

1039+ -> CommonTableExpression statement schemas params commons (cte ::: common ': commons)

1040+instance

1041+ ( KnownSymbol cte

1042+ , commons1 ~ (cte ::: common ': commons)

1043+ ) => Aliasable cte

1044+ (statement commons schemas params common)

1045+ (CommonTableExpression statement schemas params commons commons1) where

1046+ statement `as` cte = CommonTableExpression (statement `as` cte)

1047+instance

1048+ ( KnownSymbol cte

1049+ , commons1 ~ (cte ::: common ': commons)

1050+ ) => Aliasable cte

1051+ (statement commons schemas params common)

1052+ (Path (CommonTableExpression statement schemas params) commons commons1) where

1053+ statement `as` cte = csingleton (statement `as` cte)

1054+

1055+instance (forall c s p r. RenderSQL (statement c s p r)) => RenderSQL

1056+ (CommonTableExpression statement schemas params commons0 commons1) where

1057+ renderSQL (CommonTableExpression (statement `As` cte)) =

1058+ renderSQL cte <+> "AS" <+> parenthesized (renderSQL statement)

1059+

1060+-- | `with` provides a way to write auxiliary statements for use in a larger query.

1061+-- These statements, referred to as `CommonTableExpression`s, can be thought of as

1062+-- defining temporary tables that exist just for one query.

1063+class With statement where

1064+ with

1065+ :: Path (CommonTableExpression statement schemas params) commons0 commons1

1066+ -- ^ common table expressions

1067+ -> statement commons1 schemas params row

1068+ -- ^ larger query

1069+ -> statement commons0 schemas params row

1070+instance With (Query outer) where

1071+ with Done query = query

1072+ with ctes query = UnsafeQuery $

1073+ "WITH" <+> commaSeparated (ctoList renderSQL ctes) <+> renderSQL query

8181074

819−-- | `SortExpression`s are used by `sortBy` to optionally sort the results

820−-- of a `Query`. `Asc` or `Desc` set the sort direction of a `NotNull` result

821−-- column to ascending or descending. Ascending order puts smaller values

822−-- first, where "smaller" is defined in terms of the `.<` operator. Similarly,

823−-- descending order is determined with the `.>` operator. `AscNullsFirst`,

824−-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to

825−-- determine whether nulls appear before or after non-null values in the sort

826−-- ordering of a `Null` result column.

827−data SortExpression schema relations grouping params where

828− Asc

829− :: Expression schema relations grouping params ('NotNull ty)

830− -> SortExpression schema relations grouping params

831− Desc

832− :: Expression schema relations grouping params ('NotNull ty)

833− -> SortExpression schema relations grouping params

834− AscNullsFirst

835− :: Expression schema relations grouping params ('Null ty)

836− -> SortExpression schema relations grouping params

837− AscNullsLast

838− :: Expression schema relations grouping params ('Null ty)

839− -> SortExpression schema relations grouping params

840− DescNullsFirst

841− :: Expression schema relations grouping params ('Null ty)

842− -> SortExpression schema relations grouping params

843− DescNullsLast

844− :: Expression schema relations grouping params ('Null ty)

845− -> SortExpression schema relations grouping params

846−deriving instance Show (SortExpression schema relations grouping params)

847−

848−-- | Render a `SortExpression`.

849−renderSortExpression :: SortExpression schema relations grouping params -> ByteString

850−renderSortExpression = \case

851− Asc expression -> renderExpression expression <+> "ASC"

852− Desc expression -> renderExpression expression <+> "DESC"

853− AscNullsFirst expression -> renderExpression expression

854− <+> "ASC NULLS FIRST"

855− DescNullsFirst expression -> renderExpression expression

856− <+> "DESC NULLS FIRST"

857− AscNullsLast expression -> renderExpression expression <+> "ASC NULLS LAST"

858− DescNullsLast expression -> renderExpression expression <+> "DESC NULLS LAST"

1075+{- |

1076+>>> import Data.Monoid (Sum (..))

1077+>>> import Data.Int (Int64)

1078+>>> :{

1079+ let

1080+ query :: Query_ schema () (Sum Int64)

1081+ query = withRecursive

1082+ ( values_ ((1 & astype int) `as` #n)

1083+ `unionAll`

1084+ select_ ((#n + 1) `as` #n)

1085+ (from (common #t) & where_ (#n .< 100)) `as` #t )

1086+ ( select_ (fromNull 0 (sum_ (All #n)) `as` #getSum) (from (common #t) & groupBy Nil))

1087+ in printSQL query

1088+:}

1089+WITH RECURSIVE "t" AS ((SELECT * FROM (VALUES ((1 :: int))) AS t ("n")) UNION ALL (SELECT ("n" + 1) AS "n" FROM "t" AS "t" WHERE ("n" < 100))) SELECT COALESCE(sum(ALL "n"), 0) AS "getSum" FROM "t" AS "t"

1090+-}

1091+withRecursive

1092+ :: Aliased (Query outer (recursive ': commons) schemas params) recursive

1093+ -> Query outer (recursive ': commons) schemas params row

1094+ -> Query outer commons schemas params row

1095+withRecursive (recursive `As` cte) query = UnsafeQuery $

1096+ "WITH RECURSIVE" <+> renderSQL cte

1097+ <+> "AS" <+> parenthesized (renderSQL recursive)

1098+ <+> renderSQL query

squeal-postgresql/src/Squeal/PostgreSQL/Render.hs+72−6

@@ -9,39 +9,62 @@ Rendering helper functions.

99-}

1010

1111{-# LANGUAGE

12− MagicHash

12+ AllowAmbiguousTypes

13+ , ConstraintKinds

14+ , FlexibleContexts

15+ , LambdaCase

16+ , MagicHash

1317 , OverloadedStrings

1418 , PolyKinds

1519 , RankNTypes

1620 , ScopedTypeVariables

21+ , TypeApplications

1722#-}

1823

1924module Squeal.PostgreSQL.Render

2025 ( -- * Render

21− parenthesized

26+ RenderSQL (..)

27+ , printSQL

28+ , escape

29+ , parenthesized

30+ , bracketed

2231 , (<+>)

2332 , commaSeparated

2433 , doubleQuoted

34+ , singleQuotedText

35+ , singleQuotedUtf8

2536 , renderCommaSeparated

37+ , renderCommaSeparatedConstraint

2638 , renderCommaSeparatedMaybe

2739 , renderNat

40+ , renderSymbol

2841 ) where

2942

43+import Control.Monad.IO.Class (MonadIO (..))

3044import Data.ByteString (ByteString)

31−import Data.Maybe

45+import Data.Maybe (catMaybes)

3246import Data.Monoid ((<>))

47+import Data.Text (Text)

3348import Generics.SOP

3449import GHC.Exts

35−import GHC.TypeLits

50+import GHC.TypeLits hiding (Text)

3651

52+import qualified Data.Text as Text

53+import qualified Data.Text.Encoding as Text

3754import qualified Data.ByteString as ByteString

55+import qualified Data.ByteString.Char8 as Char8

3856

3957-- | Parenthesize a `ByteString`.

4058parenthesized :: ByteString -> ByteString

4159parenthesized str = "(" <> str <> ")"

4260

61+-- | Square bracket a `ByteString`

62+bracketed :: ByteString -> ByteString

63+bracketed str = "[" <> str <> "]"

64+

4365-- | Concatenate two `ByteString`s with a space between.

4466(<+>) :: ByteString -> ByteString -> ByteString

67+infixr 7 <+>

4568str1 <+> str2 = str1 <> " " <> str2

4669

4770-- | Comma separate a list of `ByteString`s.

@@ -52,6 +75,15 @@ commaSeparated = ByteString.intercalate ", "

5275doubleQuoted :: ByteString -> ByteString

5376doubleQuoted str = "\"" <> str <> "\""

5477

78+-- | Add single quotes around a `Text` and escape single quotes within it.

79+singleQuotedText :: Text -> ByteString

80+singleQuotedText str =

81+ "'" <> Text.encodeUtf8 (Text.replace "'" "''" str) <> "'"

82+

83+-- | Add single quotes around a `ByteString` and escape single quotes within it.

84+singleQuotedUtf8 :: ByteString -> ByteString

85+singleQuotedUtf8 = singleQuotedText . Text.decodeUtf8

86+

5587-- | Comma separate the renderings of a heterogeneous list.

5688renderCommaSeparated

5789 :: SListI xs

@@ -62,6 +94,16 @@ renderCommaSeparated render

6294 . hcollapse

6395 . hmap (K . render)

6496

97+-- | Comma separate the renderings of a heterogeneous list.

98+renderCommaSeparatedConstraint

99+ :: forall c xs expression. (All c xs, SListI xs)

100+ => (forall x. c x => expression x -> ByteString)

101+ -> NP expression xs -> ByteString

102+renderCommaSeparatedConstraint render

103+ = commaSeparated

104+ . hcollapse

105+ . hcmap (Proxy @c) (K . render)

106+

65107-- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping

66108-- `Nothing`s.

67109renderCommaSeparatedMaybe

@@ -75,5 +117,29 @@ renderCommaSeparatedMaybe render

75117 . hmap (K . render)

76118

77119-- | Render a promoted `Nat`.

78−renderNat :: KnownNat n => proxy n -> ByteString

79−renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))

120+renderNat :: forall n. KnownNat n => ByteString

121+renderNat = fromString (show (natVal' (proxy# :: Proxy# n)))

122+

123+-- | Render a promoted `Symbol`.

124+renderSymbol :: forall s. KnownSymbol s => ByteString

125+renderSymbol = fromString (symbolVal' (proxy# :: Proxy# s))

126+

127+-- | A class for rendering SQL

128+class RenderSQL sql where renderSQL :: sql -> ByteString

129+

130+-- | Print SQL.

131+printSQL :: (RenderSQL sql, MonadIO io) => sql -> io ()

132+printSQL = liftIO . Char8.putStrLn . renderSQL

133+

134+-- | `escape` a character to prevent injection

135+escape :: Char -> String

136+escape = \case

137+ '\NUL' -> "\\0"

138+ '\'' -> "''"

139+ '"' -> "\\\""

140+ '\b' -> "\\b"

141+ '\n' -> "\\n"

142+ '\r' -> "\\r"

143+ '\t' -> "\\t"

144+ '\\' -> "\\\\"

145+ c -> [c]

squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+324−575

@@ -1,13 +1,15 @@

11{-|

22Module: Squeal.PostgreSQL.Schema

33Description: Embedding of PostgreSQL type and alias system

4−Copyright: (c) Eitan Chatav, 2017

4+Copyright: (c) Eitan Chatav, 2019

55Maintainer: eitan@morphism.tech

66Stability: experimental

8−A type-level DSL for kinds of PostgreSQL types, constraints, and aliases.

8+`Squeal.PostgreSQL.Schema` provides a type-level DSL for kinds of Postgres types,

9+tables, schema, constraints, aliases, enumerated labels, and groupings.

10+It also defines useful type families to operate on these. Finally,

11+it defines an embedding of Haskell types into Postgres types.

912-}

10−

1113{-# LANGUAGE

1214 AllowAmbiguousTypes

1315 , ConstraintKinds

@@ -17,7 +19,9 @@ A type-level DSL for kinds of PostgreSQL types, constraints, and aliases.

1719 , FlexibleInstances

1820 , FunctionalDependencies

1921 , GADTs

22+ , LambdaCase

2023 , OverloadedStrings

24+ , QuantifiedConstraints

2125 , RankNTypes

2226 , ScopedTypeVariables

2327 , StandaloneDeriving

@@ -30,124 +34,85 @@ A type-level DSL for kinds of PostgreSQL types, constraints, and aliases.

3034#-}

3135

3236module Squeal.PostgreSQL.Schema

33− ( -- * Types

37+ ( -- * Postgres Types

3438 PGType (..)

35− , HasOid (..)

3639 , NullityType (..)

40+ , RowType

41+ , FromType

42+ -- * Schema Types

3743 , ColumnType

3844 , ColumnsType

39− , RelationType

40− , NilRelation

41− , RelationsType

4245 , TableType

43− -- * Schema

4446 , SchemumType (..)

47+ , IndexType (..)

48+ , FunctionType

49+ , OperatorType (..)

50+ , ReturnsType (..)

4551 , SchemaType

46− -- * Grouping

47− , Grouping (..)

48− , GroupedBy

52+ , SchemasType

53+ , Public

4954 -- * Constraints

5055 , (:=>)

5156 , ColumnConstraint (..)

5257 , TableConstraint (..)

5358 , TableConstraints

54− , NilTableConstraints

5559 , Uniquely

56− -- * Aliases

57− , (:::)

58− , Alias (Alias)

59− , renderAlias

60− , renderAliases

61− , Aliased (As)

62− , renderAliasedAs

63− , AliasesOf

64− , ZipAliased (..)

65− , Has

66− , HasUnique

67− , HasAll

68− , IsLabel (..)

69− , IsQualified (..)

70− -- * Type Families

71− , Join

72− , With

60+ -- * Enumerated Labels

61+ , IsPGlabel (..)

62+ , PGlabel (..)

63+ -- * Data Definitions

7364 , Create

65+ , CreateIfNotExists

66+ , CreateOrReplace

7467 , Drop

68+ , DropSchemum

69+ , DropIfExists

70+ , DropSchemumIfExists

7571 , Alter

72+ , AlterIfExists

7673 , Rename

77− , Elem

78− , In

74+ , RenameIfExists

75+ , ConstraintInvolves

76+ , DropIfConstraintsInvolve

77+ , IsNotElem

78+ , AllUnique

79+ -- * Type Classifications

7980 , PGNum

8081 , PGIntegral

8182 , PGFloating

8283 , PGTypeOf

83− , SameTypes

84+ , PGJsonType

85+ , PGJsonKey

8486 , SamePGType

8587 , AllNotNull

8688 , NotAllNull

89+ -- * Nullifications

8790 , NullifyType

88− , NullifyRelation

89− , NullifyRelations

90− , ColumnsToRelation

91+ , NullifyRow

92+ , NullifyFrom

93+ -- * Table Conversions

9194 , TableToColumns

92− , TableToRelation

93− , ConstraintInvolves

94− , DropIfConstraintsInvolve

95− -- * Generics

96− , MapMaybes (..)

97− , Nulls

98− -- * Enum Labels

99− , IsPGlabel (..)

100− , PGlabel (..)

101− , renderLabel

102− , renderLabels

103− , LabelOf

104− , LabelsOf

105− -- * Embedding

106− , PG

107− , EnumWith

108− , LabelsWith

109− , CompositeWith

110− , FieldNamesWith

111− , FieldTypesWith

112− , ConstructorsOf

113− , ConstructorNameOf

114− , ConstructorNamesOf

115− , FieldsOf

116− , FieldNameOf

117− , FieldNamesOf

118− , FieldTypeOf

119− , FieldTypesOf

120− , RecordCodeOf

95+ , ColumnsToRow

96+ , TableToRow

12197 ) where

12298

123−import Control.DeepSeq

124−import Data.Aeson (Value)

125−import Data.ByteString (ByteString)

126−import Data.Int (Int16, Int32, Int64)

99+import Control.Category

127100import Data.Kind

128101import Data.Monoid hiding (All)

129−import Data.Scientific (Scientific)

130−import Data.String

131−import Data.Text (Text)

132−import Data.Time

133−import Data.Word (Word16, Word32, Word64)

134102import Data.Type.Bool

135−import Data.UUID.Types (UUID)

136103import Generics.SOP

137−import GHC.OverloadedLabels

138104import GHC.TypeLits

139−import Network.IP.Addr

140−

141−import qualified Data.ByteString.Lazy as Lazy

142−import qualified Data.Text.Lazy as Lazy

143−import qualified GHC.Generics as GHC

144−import qualified Generics.SOP.Type.Metadata as Type

105+import Prelude hiding (id, (.))

145106

107+import Squeal.PostgreSQL.Alias

108+import Squeal.PostgreSQL.List

146109import Squeal.PostgreSQL.Render

147110

111+-- $setup

112+-- >>> import Squeal.PostgreSQL

113+

148114-- | `PGType` is the promoted datakind of PostgreSQL types.

149115--

150−-- >>> import Squeal.PostgreSQL.Schema

151116-- >>> :kind 'PGbool

152117-- 'PGbool :: PGType

153118data PGType

@@ -158,6 +123,7 @@ data PGType

158123 | PGnumeric -- ^ arbitrary precision numeric type

159124 | PGfloat4 -- ^ single precision floating-point number (4 bytes)

160125 | PGfloat8 -- ^ double precision floating-point number (8 bytes)

126+ | PGmoney -- ^ currency amount

161127 | PGchar Nat -- ^ fixed-length character string

162128 | PGvarchar Nat -- ^ variable-length character string

163129 | PGtext -- ^ variable-length character string

@@ -172,40 +138,16 @@ data PGType

172138 | PGinet -- ^ IPv4 or IPv6 host address

173139 | PGjson -- ^ textual JSON data

174140 | PGjsonb -- ^ binary JSON data, decomposed

175− | PGvararray PGType -- ^ variable length array

176− | PGfixarray Nat PGType -- ^ fixed length array

177− | PGenum [Symbol]

178− | PGcomposite [(Symbol, PGType)]

141+ | PGvararray NullityType -- ^ variable length array

142+ | PGfixarray [Nat] NullityType -- ^ fixed length array

143+ | PGenum [Symbol] -- ^ enumerated (enum) types are data types that comprise a static, ordered set of values.

144+ | PGcomposite RowType -- ^ a composite type represents the structure of a row or record; it is essentially just a list of field names and their data types.

145+ | PGtsvector -- ^ A tsvector value is a sorted list of distinct lexemes, which are words that have been normalized to merge different variants of the same word.

146+ | PGtsquery -- ^ A tsquery value stores lexemes that are to be searched for.

147+ | PGoid -- Object identifiers (OIDs) are used internally by PostgreSQL as primary keys for various system tables.

148+ | PGrange PGType -- ^ Range types are data types representing a range of values of some element type (called the range's subtype).

179149 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types

180150

181−-- | The object identifier of a `PGType`.

182−--

183−-- >>> :set -XTypeApplications

184−-- >>> oid @'PGbool

185−-- 16

186−class HasOid (ty :: PGType) where oid :: Word32

187−instance HasOid 'PGbool where oid = 16

188−instance HasOid 'PGint2 where oid = 21

189−instance HasOid 'PGint4 where oid = 23

190−instance HasOid 'PGint8 where oid = 20

191−instance HasOid 'PGnumeric where oid = 1700

192−instance HasOid 'PGfloat4 where oid = 700

193−instance HasOid 'PGfloat8 where oid = 701

194−instance HasOid ('PGchar n) where oid = 18

195−instance HasOid ('PGvarchar n) where oid = 1043

196−instance HasOid 'PGtext where oid = 25

197−instance HasOid 'PGbytea where oid = 17

198−instance HasOid 'PGtimestamp where oid = 1114

199−instance HasOid 'PGtimestamptz where oid = 1184

200−instance HasOid 'PGdate where oid = 1082

201−instance HasOid 'PGtime where oid = 1083

202−instance HasOid 'PGtimetz where oid = 1266

203−instance HasOid 'PGinterval where oid = 1186

204−instance HasOid 'PGuuid where oid = 2950

205−instance HasOid 'PGinet where oid = 869

206−instance HasOid 'PGjson where oid = 114

207−instance HasOid 'PGjsonb where oid = 3802

208−

209151-- | `NullityType` encodes the potential presence or definite absence of a

210152-- @NULL@ allowing operations which are sensitive to such to be well typed.

211153--

@@ -224,14 +166,6 @@ data NullityType

224166type (:=>) constraint ty = '(constraint,ty)

225167infixr 7 :=>

226168

227−-- | The alias operator `:::` is like a promoted version of `As`,

228−-- a type level pair between

229−-- an alias and some type, like a column alias and either a `ColumnType` or

230−-- `NullityType` or a table alias and either a `TableType` or a `RelationType`

231−-- or a constraint alias and a `TableConstraint`.

232−type (:::) (alias :: Symbol) ty = '(alias,ty)

233−infixr 6 :::

234−

235169-- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates.

236170-- A column can be assigned a default value.

237171-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also

@@ -273,11 +207,14 @@ data TableConstraint

273207 | PrimaryKey [Symbol]

274208 | ForeignKey [Symbol] Symbol [Symbol]

275209

276−-- | A `TableConstraints` is a row of `TableConstraint`s.

210+{- | A `TableConstraints` is a row of `TableConstraint`s.

211+

212+>>> :{

213+type family UsersConstraints :: TableConstraints where

214+ UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ]

215+:}

216+-}

277217type TableConstraints = [(Symbol,TableConstraint)]

278−-- | A monokinded empty `TableConstraints`.

279−type family NilTableConstraints :: TableConstraints where

280− NilTableConstraints = '[]

281218

282219-- | A `ForeignKey` must reference columns that either are

283220-- a `PrimaryKey` or form a `Unique` constraint.

@@ -301,224 +238,64 @@ type family Uniquely

301238-- :}

302239type TableType = (TableConstraints,ColumnsType)

303240

304−-- | `RelationType` is a row of `NullityType`

305−--

306−-- >>> :{

307−-- type family PersonRelation :: RelationType where

308−-- PersonRelation =

309−-- '[ "name" ::: 'NotNull 'PGtext

310−-- , "age" ::: 'NotNull 'PGint4

311−-- , "dateOfBirth" ::: 'Null 'PGdate

312−-- ]

313−-- :}

314−type RelationType = [(Symbol,NullityType)]

315−-- | A monokinded empty `RelationType`.

316−type family NilRelation :: RelationType where NilRelation = '[]

317−

318−-- | `RelationsType` is a row of `RelationType`s, thought of as a product.

319−type RelationsType = [(Symbol,RelationType)]

241+{- | A `RowType` is a row of `NullityType`. They correspond to Haskell

242+record types by means of `Squeal.PostgreSQL.Binary.RowPG` and are used in many places.

243+

244+>>> :{

245+type family PersonRow :: RowType where

246+ PersonRow =

247+ '[ "name" ::: 'NotNull 'PGtext

248+ , "age" ::: 'NotNull 'PGint4

249+ , "dateOfBirth" ::: 'Null 'PGdate

250+ ]

251+:}

252+-}

253+type RowType = [(Symbol,NullityType)]

320254

321−-- | `ColumnsToRelation` removes column constraints.

322−type family ColumnsToRelation (columns :: ColumnsType) :: RelationType where

323− ColumnsToRelation '[] = '[]

324− ColumnsToRelation (column ::: constraint :=> ty ': columns) =

325− column ::: ty ': ColumnsToRelation columns

255+{- | `FromType` is a row of `RowType`s. It can be thought of as

256+a product, or horizontal gluing and is used in `Squeal.PostgreSQL.Query.FromClause`s

257+and `Squeal.PostgreSQL.Query.TableExpression`s.

258+-}

259+type FromType = [(Symbol,RowType)]

260+

261+-- | `ColumnsToRow` removes column constraints.

262+type family ColumnsToRow (columns :: ColumnsType) :: RowType where

263+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': column5 ::: _ :=> ty5 ': columns) =

264+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': ColumnsToRow columns

265+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': column4 ::: _ :=> ty4 ': columns) =

266+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': ColumnsToRow columns

267+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': column3 ::: _ :=> ty3 ': columns) =

268+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': ColumnsToRow columns

269+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': column2 ::: _ :=> ty2 ': columns) =

270+ column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': ColumnsToRow columns

271+ ColumnsToRow (column ::: _ :=> ty ': column1 ::: _ :=> ty1 ': columns) =

272+ column ::: ty ': column1 ::: ty1 ': ColumnsToRow columns

273+ ColumnsToRow (column ::: _ :=> ty ': columns) =

274+ column ::: ty ': ColumnsToRow columns

275+ ColumnsToRow '[] = '[]

326276

327277-- | `TableToColumns` removes table constraints.

328278type family TableToColumns (table :: TableType) :: ColumnsType where

329279 TableToColumns (constraints :=> columns) = columns

330280

331−-- | Convert a table to a relation.

332−type family TableToRelation (table :: TableType) :: RelationType where

333− TableToRelation tab = ColumnsToRelation (TableToColumns tab)

281+-- | Convert a table to a row type.

282+type family TableToRow (table :: TableType) :: RowType where

283+ TableToRow tab = ColumnsToRow (TableToColumns tab)

334284

335−-- | `Grouping` is an auxiliary namespace, created by

336−-- @GROUP BY@ clauses (`Squeal.PostgreSQL.Query.group`), and used

337−-- for typesafe aggregation

338−data Grouping

339− = Ungrouped -- ^ no aggregation permitted

340− | Grouped [(Symbol,Symbol)] -- ^ aggregation required for any column which is not grouped

285+-- | Numeric Postgres types.

286+type PGNum =

287+ '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]

341288

342−{- | A `GroupedBy` constraint indicates that a table qualified column is

343−a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,

344−may be called in an output `Squeal.PostgreSQL.Expression.Expression` without aggregating.

345−-}

346−class (KnownSymbol relation, KnownSymbol column)

347− => GroupedBy relation column bys where

348−instance {-# OVERLAPPING #-} (KnownSymbol relation, KnownSymbol column)

349− => GroupedBy relation column ('(table,column) ': bys)

350−instance {-# OVERLAPPABLE #-}

351− ( KnownSymbol relation

352− , KnownSymbol column

353− , GroupedBy relation column bys

354− ) => GroupedBy relation column (tabcol ': bys)

355−

356−-- | `Alias`es are proxies for a type level string or `Symbol`

357−-- and have an `IsLabel` instance so that with @-XOverloadedLabels@

358−--

359−-- >>> :set -XOverloadedLabels

360−-- >>> #foobar :: Alias "foobar"

361−-- Alias

362−data Alias (alias :: Symbol) = Alias

363− deriving (Eq,GHC.Generic,Ord,Show,NFData)

364−instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where

365− fromLabel = Alias

366−instance aliases ~ '[alias] => IsLabel alias (NP Alias aliases) where

367− fromLabel = fromLabel :* Nil

368−

369−-- | >>> renderAlias #jimbob

370−-- "\"jimbob\""

371−renderAlias :: KnownSymbol alias => Alias alias -> ByteString

372−renderAlias = doubleQuoted . fromString . symbolVal

373−

374−-- | >>> import Generics.SOP (NP(..))

375−-- >>> renderAliases (#jimbob :* #kandi :* Nil)

376−-- ["\"jimbob\"","\"kandi\""]

377−renderAliases

378− :: All KnownSymbol aliases => NP Alias aliases -> [ByteString]

379−renderAliases = hcollapse

380− . hcmap (Proxy @KnownSymbol) (K . renderAlias)

381−

382−-- | The `As` operator is used to name an expression. `As` is like a demoted

383−-- version of `:::`.

384−--

385−-- >>> Just "hello" `As` #hi :: Aliased Maybe ("hi" ::: String)

386−-- As (Just "hello") Alias

387−data Aliased expression aliased where

388− As

389− :: KnownSymbol alias

390− => expression ty

391− -> Alias alias

392− -> Aliased expression (alias ::: ty)

393−deriving instance Show (expression ty)

394− => Show (Aliased expression (alias ::: ty))

395−deriving instance Eq (expression ty)

396− => Eq (Aliased expression (alias ::: ty))

397−deriving instance Ord (expression ty)

398− => Ord (Aliased expression (alias ::: ty))

399−instance (alias0 ~ alias1, alias0 ~ alias2, KnownSymbol alias2)

400− => IsLabel alias0 (Aliased Alias (alias1 ::: alias2)) where

401− fromLabel = fromLabel @alias2 `As` fromLabel @alias1

402−

403−-- | >>> let renderMaybe = fromString . maybe "Nothing" (const "Just")

404−-- >>> renderAliasedAs renderMaybe (Just (3::Int) `As` #an_int)

405−-- "Just AS \"an_int\""

406−renderAliasedAs

407− :: (forall ty. expression ty -> ByteString)

408− -> Aliased expression aliased

409− -> ByteString

410−renderAliasedAs render (expression `As` alias) =

411− render expression <> " AS " <> renderAlias alias

412−

413−-- | `AliasesOf` retains the AliasesOf in a row.

414−type family AliasesOf aliaseds where

415− AliasesOf '[] = '[]

416− AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys

417−

418−-- | The `ZipAliased` class provides a type family for zipping

419−-- `Symbol` lists together with arbitrary lists of the same size,

420−-- with an associated type family `ZipAs`, together with

421−-- a method `zipAs` for zipping heterogeneous lists of `Alias`es

422−-- together with a heterogeneous list of expressions into

423−-- a heterogeneous list of `Aliased` expressions.

424−class

425− ( SListI (ZipAs ns xs)

426− , All KnownSymbol ns

427− ) => ZipAliased ns xs where

428−

429− type family ZipAs

430− (ns :: [Symbol]) (xs :: [k]) = (zs :: [(Symbol,k)]) | zs -> ns xs

431−

432− zipAs

433− :: NP Alias ns

434− -> NP expr xs

435− -> NP (Aliased expr) (ZipAs ns xs)

436−

437−instance ZipAliased '[] '[] where

438− type ZipAs '[] '[] = '[]

439− zipAs Nil Nil = Nil

440−

441−instance

442− ( KnownSymbol n

443− , ZipAliased ns xs

444− ) => ZipAliased (n ': ns) (x ': xs) where

445− type ZipAs (n ': ns) (x ': xs) = '(n,x) ': ZipAs ns xs

446− zipAs (n :* ns) (x :* xs) = x `As` n :* zipAs ns xs

447−

448−-- | @HasUnique alias fields field@ is a constraint that proves that

449−-- @fields@ is a singleton of @alias ::: field@.

450−type HasUnique alias fields field = fields ~ '[alias ::: field]

451−

452−-- | @Has alias fields field@ is a constraint that proves that

453−-- @fields@ has a field of @alias ::: field@, inferring @field@

454−-- from @alias@ and @fields@.

455−class KnownSymbol alias =>

456− Has (alias :: Symbol) (fields :: [(Symbol,kind)]) (field :: kind)

457− | alias fields -> field where

458−instance {-# OVERLAPPING #-} KnownSymbol alias

459− => Has alias (alias ::: field ': fields) field

460−instance {-# OVERLAPPABLE #-} (KnownSymbol alias, Has alias fields field)

461− => Has alias (field' ': fields) field

462−

463−-- | `HasAll` extends `Has` to take lists of @aliases@ and @fields@ and infer

464−-- a list of @subfields@.

465−class

466− ( All KnownSymbol aliases

467− ) => HasAll

468− (aliases :: [Symbol])

469− (fields :: [(Symbol,kind)])

470− (subfields :: [(Symbol,kind)])

471− | aliases fields -> subfields where

472−instance {-# OVERLAPPING #-} HasAll '[] fields '[]

473−instance {-# OVERLAPPABLE #-}

474− (Has alias fields field, HasAll aliases fields subfields)

475− => HasAll (alias ': aliases) fields (alias ::: field ': subfields)

476−

477−-- | Analagous to `IsLabel`, the constraint

478−-- `IsQualified` defines `!` for a column alias qualified

479−-- by a table alias.

480−class IsQualified table column expression where

481− (!) :: Alias table -> Alias column -> expression

482− infixl 9 !

483−instance IsQualified table column (Alias table, Alias column) where (!) = (,)

484−

485−-- | @Elem@ is a promoted `Data.List.elem`.

486−type family Elem x xs where

487− Elem x '[] = 'False

488− Elem x (x ': xs) = 'True

489− Elem x (_ ': xs) = Elem x xs

490−

491−-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.

492−type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True

493−

494−-- | `PGNum` is a constraint on `PGType` whose

495−-- `Squeal.PostgreSQL.Expression.Expression`s have a `Num` constraint.

496−type PGNum ty =

497− In ty '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]

498−

499−-- | `PGFloating` is a constraint on `PGType` whose

500−-- `Squeal.PostgreSQL.Expression.Expression`s

501−-- have `Fractional` and `Floating` constraints.

502−type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]

503−

504−-- | `PGIntegral` is a constraint on `PGType` whose

505−-- `Squeal.PostgreSQL.Expression.Expression`s

506−-- have `Squeal.PostgreSQL.Expression.div_` and

507−-- `Squeal.PostgreSQL.Expression.mod_` functions.

508−type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]

289+-- | Floating Postgres types.

290+type PGFloating = '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]

291+

292+-- | Integral Postgres types.

293+type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8]

509294

510295-- | `PGTypeOf` forgets about @NULL@ and any column constraints.

511296type family PGTypeOf (ty :: NullityType) :: PGType where

512297 PGTypeOf (nullity pg) = pg

513298

514−-- | `SameTypes` is a constraint that proves two `ColumnsType`s have the same

515−-- length and the same `ColumnType`s.

516−type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType)

517− :: Constraint where

518− SameTypes '[] '[] = ()

519− SameTypes (column0 ::: def0 :=> ty0 ': columns0) (column1 ::: def1 :=> ty1 ': columns1)

520− = (ty0 ~ ty1, SameTypes columns0 columns1)

521−

522299-- | Equality constraint on the underlying `PGType` of two columns.

523300class SamePGType

524301 (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where

@@ -528,39 +305,63 @@ instance ty0 ~ ty1 => SamePGType

528305

529306-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.

530307type family AllNotNull (columns :: ColumnsType) :: Constraint where

308+ AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns

309+ AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns

310+ AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns

311+ AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns

312+ AllNotNull (_ ::: _ :=> 'NotNull _ ': _ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns

313+ AllNotNull (_ ::: _ :=> 'NotNull _ ': columns) = AllNotNull columns

531314 AllNotNull '[] = ()

532− AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns

533315

534316-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some

535317-- @NOT NULL@.

536318type family NotAllNull (columns :: ColumnsType) :: Constraint where

537− NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()

538− NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns

539−

540−-- | `NullifyType` is an idempotent that nullifies a `ColumnType`.

319+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()

320+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()

321+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()

322+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()

323+ NotAllNull (_ ::: _ :=> _ _ ': _ ::: _ :=> 'NotNull _ ': _) = ()

324+ NotAllNull (_ ::: _ :=> 'NotNull _ ': _) = ()

325+ NotAllNull (_ ::: _ :=> 'Null _ ': columns) = NotAllNull columns

326+

327+-- | `NullifyType` is an idempotent that nullifies a `NullityType`.

541328type family NullifyType (ty :: NullityType) :: NullityType where

542329 NullifyType ('Null ty) = 'Null ty

543330 NullifyType ('NotNull ty) = 'Null ty

544331

545−-- | `NullifyRelation` is an idempotent that nullifies a `ColumnsType`.

546−type family NullifyRelation (columns :: RelationType) :: RelationType where

547− NullifyRelation '[] = '[]

548− NullifyRelation (column ::: ty ': columns) =

549− column ::: NullifyType ty ': NullifyRelation columns

550−

551−-- | `NullifyRelations` is an idempotent that nullifies a `RelationsType`

332+-- | `NullifyRow` is an idempotent that nullifies a `RowType`.

333+type family NullifyRow (columns :: RowType) :: RowType where

334+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': column5 ::: ty5 ': columns) =

335+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': column4 ::: NullifyType ty4 ': column5 ::: NullifyType ty5 ': NullifyRow columns

336+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': column4 ::: ty4 ': columns) =

337+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': column4 ::: NullifyType ty4 ': NullifyRow columns

338+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': column3 ::: ty3 ': columns) =

339+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': column3 ::: NullifyType ty3 ': NullifyRow columns

340+ NullifyRow (column ::: ty ': column1 ::: ty1 ': column2 ::: ty2 ': columns) =

341+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': column2 ::: NullifyType ty2 ': NullifyRow columns

342+ NullifyRow (column ::: ty ': column1 ::: ty1 ': columns) =

343+ column ::: NullifyType ty ': column1 ::: NullifyType ty1 ': NullifyRow columns

344+ NullifyRow (column ::: ty ': columns) =

345+ column ::: NullifyType ty ': NullifyRow columns

346+ NullifyRow '[] = '[]

347+

348+-- | `NullifyFrom` is an idempotent that nullifies a `FromType`

552349-- used to nullify the left or right hand side of an outer join

553350-- in a `Squeal.PostgreSQL.Query.FromClause`.

554−type family NullifyRelations (tables :: RelationsType) :: RelationsType where

555− NullifyRelations '[] = '[]

556− NullifyRelations (table ::: columns ': tables) =

557− table ::: NullifyRelation columns ': NullifyRelations tables

558−

559−-- | `Join` is simply promoted `++` and is used in @JOIN@s in

560−-- `Squeal.PostgreSQL.Query.FromClause`s.

561−type family Join xs ys where

562− Join '[] ys = ys

563− Join (x ': xs) ys = x ': Join xs ys

351+type family NullifyFrom (tables :: FromType) :: FromType where

352+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': table5 ::: columns5 ': tables) =

353+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': table4 ::: NullifyRow columns5 ': table5 ::: NullifyRow columns4 ': NullifyFrom tables

354+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': table4 ::: columns4 ': tables) =

355+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': table4 ::: NullifyRow columns4 ': NullifyFrom tables

356+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': table3 ::: columns3 ': tables) =

357+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': table3 ::: NullifyRow columns3 ': NullifyFrom tables

358+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': table2 ::: columns2 ': tables) =

359+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': table2 ::: NullifyRow columns2 ': NullifyFrom tables

360+ NullifyFrom (table ::: columns ': table1 ::: columns1 ': tables) =

361+ table ::: NullifyRow columns ': table1 ::: NullifyRow columns1 ': NullifyFrom tables

362+ NullifyFrom (table ::: columns ': tables) =

363+ table ::: NullifyRow columns ': NullifyFrom tables

364+ NullifyFrom '[] = '[]

564365

565366-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in

566367-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@

@@ -570,62 +371,100 @@ type family Create alias x xs where

570371 Create alias x (alias ::: y ': xs) = TypeError

571372 ('Text "Create: alias "

572373 ':<>: 'ShowType alias

573− ':<>: 'Text "already in use")

374+ ':<>: 'Text "already exists")

574375 Create alias y (x ': xs) = x ': Create alias y xs

575376

377+type family CreateIfNotExists alias x xs where

378+ CreateIfNotExists alias x '[] = '[alias ::: x]

379+ CreateIfNotExists alias x (alias ::: y ': xs) = alias ::: y ': xs

380+ CreateIfNotExists alias y (x ': xs) = x ': CreateIfNotExists alias y xs

381+

382+type family CreateOrReplace alias x xs where

383+ CreateOrReplace alias x '[] = '[alias ::: x]

384+ CreateOrReplace alias x (alias ::: x ': xs) = alias ::: x ': xs

385+ CreateOrReplace alias x (alias ::: y ': xs) = TypeError

386+ ('Text "CreateOrReplace: expected type "

387+ ':<>: 'ShowType x

388+ ':<>: 'Text " but alias "

389+ ':<>: 'ShowType alias

390+ ':<>: 'Text " has type "

391+ ':<>: 'ShowType y)

392+ CreateOrReplace alias y (x ': xs) = x ': CreateOrReplace alias y xs

393+

576394-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@

577395-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements

578396-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.

579397type family Drop alias xs where

580− Drop alias ((alias ::: x) ': xs) = xs

398+ Drop alias '[] = TypeError

399+ ('Text "Drop: alias "

400+ ':<>: 'ShowType alias

401+ ':<>: 'Text " does not exist" )

402+ Drop alias (alias ::: x ': xs) = xs

581403 Drop alias (x ': xs) = x ': Drop alias xs

582404

405+type family DropSchemum alias sch xs where

406+ DropSchemum alias sch '[] = TypeError

407+ ('Text "DropSchemum: alias "

408+ ':<>: 'ShowType alias

409+ ':<>: 'Text " does not exist" )

410+ DropSchemum alias sch (alias ::: sch x ': xs) = xs

411+ DropSchemum alias sch0 (alias ::: sch1 x ': xs) = TypeError

412+ ('Text "DropSchemum: expected schemum "

413+ ':<>: 'ShowType sch0

414+ ':<>: 'Text " but alias "

415+ ':<>: 'ShowType alias

416+ ':<>: 'Text " has schemum "

417+ ':<>: 'ShowType sch1)

418+ DropSchemum alias sch (x ': xs) = x ': DropSchemum alias sch xs

419+

420+type family DropIfExists alias xs where

421+ DropIfExists alias '[] = '[]

422+ DropIfExists alias (alias ::: x ': xs) = xs

423+ DropIfExists alias (x ': xs) = x ': DropIfExists alias xs

424+

425+type family DropSchemumIfExists alias sch xs where

426+ DropSchemumIfExists alias sch '[] = '[]

427+ DropSchemumIfExists alias sch (alias ::: sch x ': xs) = xs

428+ DropSchemumIfExists alias sch0 (alias ::: sch1 x ': xs) = TypeError

429+ ('Text "DropSchemumIfExists: expected schemum "

430+ ':<>: 'ShowType sch1

431+ ':<>: 'Text " but alias "

432+ ':<>: 'ShowType alias

433+ ':<>: 'Text " has schemum "

434+ ':<>: 'ShowType sch0)

435+ DropSchemumIfExists alias sch (x ': xs) = x ': DropSchemumIfExists alias sch xs

436+

583437-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@

584−-- with the type `x` and is used in `Squeal.PostgreSQL.Definition.alterTable`

438+-- with the type @x@ and is used in `Squeal.PostgreSQL.Definition.alterTable`

585439-- and `Squeal.PostgreSQL.Definition.alterColumn`.

586440type family Alter alias x xs where

441+ Alter alias x '[] = TypeError

442+ ('Text "Alter: alias "

443+ ':<>: 'ShowType alias

444+ ':<>: 'Text " does not exist" )

587445 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs

588446 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs

589447

590−-- type family AddConstraint constraint ty where

591−-- AddConstraint constraint (constraints :=> ty)

592−-- = AsSet (constraint ': constraints) :=> ty

593−

594−-- type family DeleteFromList (e :: elem) (list :: [elem]) where

595−-- DeleteFromList elem '[] = '[]

596−-- DeleteFromList elem (x ': xs) =

597−-- If (Cmp elem x == 'EQ) xs (x ': DeleteFromList elem xs)

598−

599−-- type family DropConstraint constraint ty where

600−-- DropConstraint constraint (constraints :=> ty)

601−-- = (AsSet (DeleteFromList constraint constraints)) :=> ty

448+type family AlterIfExists alias x xs where

449+ AlterIfExists alias x '[] = '[]

450+ AlterIfExists alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs

451+ AlterIfExists alias x1 (x0 ': xs) = x0 ': AlterIfExists alias x1 xs

602452

603453-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@

604454-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and

605455-- `Squeal.PostgreSQL.Definition.renameColumn`.

606456type family Rename alias0 alias1 xs where

457+ Rename alias0 alias1 '[] = TypeError

458+ ('Text "Rename: alias "

459+ ':<>: 'ShowType alias0

460+ ':<>: 'Text " does not exist" )

607461 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs

608462 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs

609463

610−-- | `MapMaybes` is used in the binary instances of composite types.

611−class MapMaybes xs where

612− type family Maybes (xs :: [Type]) = (mxs :: [Type]) | mxs -> xs

613− maybes :: NP Maybe xs -> NP I (Maybes xs)

614− unMaybes :: NP I (Maybes xs) -> NP Maybe xs

615−instance MapMaybes '[] where

616− type Maybes '[] = '[]

617− maybes Nil = Nil

618− unMaybes Nil = Nil

619−instance MapMaybes xs => MapMaybes (x ': xs) where

620− type Maybes (x ': xs) = Maybe x ': Maybes xs

621− maybes (x :* xs) = I x :* maybes xs

622− unMaybes (I mx :* xs) = mx :* unMaybes xs

623−

624−-- | `Nulls` is used to construct a `Squeal.Postgresql.Expression.row`

625−-- of a composite type.

626−type family Nulls tys where

627− Nulls '[] = '[]

628− Nulls (field ::: ty ': tys) = field ::: 'Null ty ': Nulls tys

464+type family RenameIfExists alias0 alias1 xs where

465+ RenameIfExists alias x '[] = '[]

466+ RenameIfExists alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs

467+ RenameIfExists alias0 alias1 (x ': xs) = x ': RenameIfExists alias0 alias1 xs

629468

630469-- | Check if a `TableConstraint` involves a column

631470type family ConstraintInvolves column constraint where

@@ -647,201 +486,111 @@ type family DropIfConstraintsInvolve column constraints where

647486-- `View` or `Typedef`.

648487data SchemumType

649488 = Table TableType

650− | View RelationType

489+ | View RowType

651490 | Typedef PGType

652−

653−-- | The schema of a database consists of a list of aliased,

654−-- user-defined `SchemumType`s.

491+ | Index IndexType

492+ | Function FunctionType

493+ | Operator OperatorType

494+ | UnsafeSchemum Symbol

495+

496+type FunctionType = ([NullityType], ReturnsType)

497+

498+data IndexType

499+ = Btree

500+ | Hash

501+ | Gist

502+ | Spgist

503+ | Gin

504+ | Brin

505+

506+data ReturnsType

507+ = Returns NullityType

508+ | ReturnsTable RowType

509+

510+data OperatorType

511+ = BinaryOp NullityType NullityType NullityType

512+ | LeftOp NullityType NullityType

513+ | RightOp NullityType NullityType

514+

515+{- | The schema of a database consists of a list of aliased,

516+user-defined `SchemumType`s.

517+

518+>>> :{

519+type family Schema :: SchemaType where

520+ Schema =

521+ '[ "users" ::: 'Table (

522+ '[ "pk_users" ::: 'PrimaryKey '["id"] ] :=>

523+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4

524+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext

525+ ])

526+ , "emails" ::: 'Table (

527+ '[ "pk_emails" ::: 'PrimaryKey '["id"]

528+ , "fk_user_id" ::: 'ForeignKey '["user_id"] "users" '["id"]

529+ ] :=>

530+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4

531+ , "user_id" ::: 'NoDef :=> 'NotNull 'PGint4

532+ , "email" ::: 'NoDef :=> 'Null 'PGtext

533+ ])

534+ ]

535+:}

536+-}

655537type SchemaType = [(Symbol,SchemumType)]

656538

657−-- | Used in `Squeal.Postgresql.Manipulation.with`.

658−type family With

659− (relations :: RelationsType)

660− (schema :: SchemaType)

661− :: SchemaType where

662− With '[] schema = schema

663− With (alias ::: rel ': rels) schema =

664− alias ::: 'View rel ': With rels schema

539+{- |

540+A database contains one or more named schemas, which in turn contain tables.

541+The same object name can be used in different schemas without conflict;

542+for example, both schema1 and myschema can contain tables named mytable.

543+Unlike databases, schemas are not rigidly separated:

544+a user can access objects in any of the schemas in the database they are connected to,

545+if they have privileges to do so.

546+

547+There are several reasons why one might want to use schemas:

548+

549+ * To allow many users to use one database without interfering with each other.

550+ * To organize database objects into logical groups to make them more manageable.

551+ * Third-party applications can be put into separate schemas

552+ so they do not collide with the names of other objects.

553+-}

554+type SchemasType = [(Symbol,SchemaType)]

555+

556+-- | A type family to use for a single schema database.

557+type family Public (schema :: SchemaType) :: SchemasType

558+ where Public schema = '["public" ::: schema]

665559

666560-- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas

667561-- the overloaded label, `fromLabel` is used for column references,

668562-- `label`s are used for enum terms. A `label` is called with

669563-- type application like `label @"beef"`.

670564class IsPGlabel (label :: Symbol) expr where label :: expr

671−instance label ~ label'

672− => IsPGlabel label (PGlabel label') where label = PGlabel

565+instance label ~ label1

566+ => IsPGlabel label (PGlabel label1) where label = PGlabel

567+instance labels ~ '[label]

568+ => IsPGlabel label (NP PGlabel labels) where label = PGlabel :* Nil

673569-- | A `PGlabel` unit type with an `IsPGlabel` instance

674570data PGlabel (label :: Symbol) = PGlabel

675−-- | Renders a label

676−renderLabel :: KnownSymbol label => proxy label -> ByteString

677−renderLabel (_ :: proxy label) =

678− "\'" <> fromString (symbolVal (Proxy @label)) <> "\'"

679−-- | Renders a list of labels

680−renderLabels

681− :: All KnownSymbol labels => NP PGlabel labels -> [ByteString]

682−renderLabels = hcollapse

683− . hcmap (Proxy @KnownSymbol) (K . renderLabel)

684−-- | Gets the name of a type constructor

685−type family LabelOf (cons :: Type.ConstructorInfo) :: Symbol where

686− LabelOf ('Type.Constructor name) = name

687−-- | Gets the names of a list of type constructors

688−type family LabelsOf (conss :: [Type.ConstructorInfo]) :: [Symbol] where

689− LabelsOf '[] = '[]

690− LabelsOf (cons ': conss) = LabelOf cons ': LabelsOf conss

691−

692−-- | The `PG` type family embeds a subset of Haskell types

693−-- as Postgres basic types.

694−--

695−-- >>> :kind! PG LocalTime

696−-- PG LocalTime :: PGType

697−-- = 'PGtimestamp

698−type family PG (hask :: Type) :: PGType where

699− PG Bool = 'PGbool

700− PG Int16 = 'PGint2

701− PG Int32 = 'PGint4

702− PG Int64 = 'PGint8

703− PG Word16 = 'PGint2

704− PG Word32 = 'PGint4

705− PG Word64 = 'PGint8

706− PG Scientific = 'PGnumeric

707− PG Float = 'PGfloat4

708− PG Double = 'PGfloat8

709− PG Char = 'PGchar 1

710− PG Text = 'PGtext

711− PG Lazy.Text = 'PGtext

712− PG ByteString = 'PGbytea

713− PG Lazy.ByteString = 'PGbytea

714− PG LocalTime = 'PGtimestamp

715− PG UTCTime = 'PGtimestamptz

716− PG Day = 'PGdate

717− PG TimeOfDay = 'PGtime

718− PG (TimeOfDay, TimeZone) = 'PGtimetz

719− PG DiffTime = 'PGinterval

720− PG UUID = 'PGuuid

721− PG (NetAddr IP) = 'PGinet

722− PG Value = 'PGjson

723− PG ty = TypeError

724− ('Text "There is no Postgres basic type for " ':<>: 'ShowType ty)

725−

726−-- | The `EnumWith` type family embeds Haskell enum types, ADTs with

727−-- nullary constructors, as Postgres enum types

728−--

729−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic

730−-- >>> instance Generic Schwarma

731−-- >>> instance HasDatatypeInfo Schwarma

732−-- >>> :kind! EnumWith Schwarma

733−-- EnumWith Schwarma :: PGType

734−-- = 'PGenum '["Beef", "Lamb", "Chicken"]

735−type family EnumWith (hask :: Type) :: PGType where

736− EnumWith hask = 'PGenum (LabelsWith hask)

737−

738−-- | The `LabelsWith` type family calculates the constructors of a

739−-- Haskell enum type.

740−--

741−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic

742−-- >>> instance Generic Schwarma

743−-- >>> instance HasDatatypeInfo Schwarma

744−-- >>> :kind! LabelsWith Schwarma

745−-- LabelsWith Schwarma :: [Type.ConstructorName]

746−-- = '["Beef", "Lamb", "Chicken"]

747−type family LabelsWith (hask :: Type) :: [Type.ConstructorName] where

748− LabelsWith hask =

749− ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask))

750−

751−-- | The `CompositeWith` type family embeds Haskell record types as

752−-- Postgres composite types, as long as the record fields

753−-- are `Maybe`s of Haskell types that can be embedded as basic types

754−-- with the `PG` type family.

755−--

756−-- >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic

757−-- >>> instance Generic Row

758−-- >>> instance HasDatatypeInfo Row

759−-- >>> :kind! CompositeWith Row

760−-- CompositeWith Row :: PGType

761−-- = 'PGcomposite '['("a", 'PGint2), '("b", 'PGtimestamp)]

762−type family CompositeWith (hask :: Type) :: PGType where

763− CompositeWith hask =

764− 'PGcomposite (ZipAs (FieldNamesWith hask) (FieldTypesWith hask))

765−

766−-- | >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic

767−-- >>> instance Generic Row

768−-- >>> instance HasDatatypeInfo Row

769−-- >>> :kind! FieldNamesWith Row

770−-- FieldNamesWith Row :: [Type.FieldName]

771−-- = '["a", "b"]

772−type family FieldNamesWith (hask :: Type) :: [Type.FieldName] where

773− FieldNamesWith hask = FieldNamesOf (FieldsOf (DatatypeInfoOf hask))

774−

775−-- | >>> data Row = Row { a :: Maybe Int16, b :: Maybe LocalTime } deriving GHC.Generic

776−-- >>> instance Generic Row

777−-- >>> instance HasDatatypeInfo Row

778−-- >>> :kind! FieldTypesWith Row

779−-- FieldTypesWith Row :: [PGType]

780−-- = '['PGint2, 'PGtimestamp]

781−type family FieldTypesWith (hask :: Type) :: [PGType] where

782− FieldTypesWith hask = FieldTypesOf (RecordCodeOf hask (Code hask))

783−

784−-- | Calculates constructors of a datatype.

785−type family ConstructorsOf (datatype :: Type.DatatypeInfo)

786− :: [Type.ConstructorInfo] where

787− ConstructorsOf ('Type.ADT _module _datatype constructors) =

788− constructors

789− ConstructorsOf ('Type.Newtype _module _datatype constructor) =

790− '[constructor]

791−

792−-- | Calculates the name of a nullary constructor, otherwise

793−-- generates a type error.

794−type family ConstructorNameOf (constructors :: Type.ConstructorInfo)

795− :: Type.ConstructorName where

796− ConstructorNameOf ('Type.Constructor name) = name

797− ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError

798− ('Text "ConstructorNameOf error: non-nullary constructor "

799− ':<>: 'Text name)

800− ConstructorNameOf ('Type.Record name _fields) = TypeError

801− ('Text "ConstructorNameOf error: non-nullary constructor "

802− ':<>: 'Text name)

803−

804−-- | Calculate the names of nullary constructors.

805−type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])

806− :: [Type.ConstructorName] where

807− ConstructorNamesOf '[] = '[]

808− ConstructorNamesOf (constructor ': constructors) =

809− ConstructorNameOf constructor ': ConstructorNamesOf constructors

810−

811−-- | Calculate the fields of a datatype.

812−type family FieldsOf (datatype :: Type.DatatypeInfo)

813− :: [Type.FieldInfo] where

814− FieldsOf ('Type.ADT _module _datatype '[ 'Type.Record _name fields]) =

815− fields

816− FieldsOf ('Type.Newtype _module _datatype ('Type.Record _name fields)) =

817− fields

818−

819−-- | Calculate the name of a field.

820−type family FieldNameOf (field :: Type.FieldInfo) :: Type.FieldName where

821− FieldNameOf ('Type.FieldInfo name) = name

822−

823−-- | Calculate the names of fields.

824−type family FieldNamesOf (fields :: [Type.FieldInfo])

825− :: [Type.FieldName] where

826− FieldNamesOf '[] = '[]

827− FieldNamesOf (field ': fields) = FieldNameOf field ': FieldNamesOf fields

828−

829−-- | >>> :kind! FieldTypeOf (Maybe Int16)

830−-- FieldTypeOf (Maybe Int16) :: PGType

831−-- = 'PGint2

832−type family FieldTypeOf (maybe :: Type) where

833− FieldTypeOf (Maybe hask) = PG hask

834− FieldTypeOf ty = TypeError

835− ('Text "FieldTypeOf error: non-Maybe type " ':<>: 'ShowType ty)

836−

837−-- | Calculate the types of fields.

838−type family FieldTypesOf (fields :: [Type]) where

839− FieldTypesOf '[] = '[]

840− FieldTypesOf (field ': fields) = FieldTypeOf field ': FieldTypesOf fields

841−

842−-- | Inspect the code of an algebraic datatype and ensure it's a product,

843−-- otherwise generate a type error

844−type family RecordCodeOf (hask :: Type) (code ::[[Type]]) :: [Type] where

845− RecordCodeOf _hask '[tys] = tys

846− RecordCodeOf hask _tys = TypeError

847− ('Text "RecordCodeOf error: non-Record type " ':<>: 'ShowType hask)

571+instance KnownSymbol label => RenderSQL (PGlabel label) where

572+ renderSQL _ = "\'" <> renderSymbol @label <> "\'"

573+instance All KnownSymbol labels => RenderSQL (NP PGlabel labels) where

574+ renderSQL

575+ = commaSeparated

576+ . hcollapse

577+ . hcmap (Proxy @KnownSymbol) (K . renderSQL)

578+

579+-- | Is a type a valid JSON key?

580+type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]

581+

582+-- | Is a type a valid JSON type?

583+type PGJsonType = '[ 'PGjson, 'PGjsonb ]

584+

585+-- | Utility class for `AllUnique` to provide nicer error messages.

586+class IsNotElem x isElem where

587+instance IsNotElem x 'False where

588+instance (TypeError ( 'Text "Cannot assign to "

589+ ':<>: 'ShowType alias

590+ ':<>: 'Text " more than once"))

591+ => IsNotElem '(alias, a) 'True where

592+

593+-- | No elem of @xs@ appears more than once, in the context of assignment.

594+class AllUnique (xs :: [(Symbol, a)]) where

595+instance AllUnique '[] where

596+instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where

squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+101−74

@@ -1,7 +1,7 @@

11{-|

22Module: Squeal.PostgreSQL.Transaction

33Description: Squeal transaction control language

4−Copyright: (c) Eitan Chatav, 2017

4+Copyright: (c) Eitan Chatav, 2019

55Maintainer: eitan@morphism.tech

66Stability: experimental

@@ -9,98 +9,125 @@ Squeal transaction control language.

99-}

1010

1111{-# LANGUAGE

12− FlexibleContexts

12+ DataKinds

13+ , FlexibleContexts

1314 , LambdaCase

1415 , OverloadedStrings

16+ , TypeInType

1517#-}

1618

1719module Squeal.PostgreSQL.Transaction

1820 ( -- * Transaction

1921 transactionally

2022 , transactionally_

23+ , transactionallyRetry

24+ , ephemerally

25+ , ephemerally_

2126 , begin

2227 , commit

2328 , rollback

24− , transactionallySchema

25− , transactionallySchema_

2629 -- * Transaction Mode

2730 , TransactionMode (..)

2831 , defaultMode

2932 , longRunningMode

3033 , IsolationLevel (..)

31− , renderIsolationLevel

3234 , AccessMode (..)

33− , renderAccessMode

3435 , DeferrableMode (..)

35− , renderDeferrableMode

3636 ) where

3737

38−import Control.Exception.Lifted

39−import Control.Monad.Base

40−import Control.Monad.Trans.Control

41−import Data.ByteString

42−import Data.Monoid

43−import Generics.SOP

44−

45−import qualified Database.PostgreSQL.LibPQ as LibPQ

38+import UnliftIO

4639

4740import Squeal.PostgreSQL.Manipulation

4841import Squeal.PostgreSQL.Render

4942import Squeal.PostgreSQL.PQ

50−import Squeal.PostgreSQL.Schema

5143

52−-- | Run a schema invariant computation `transactionally`.

44+{- | Run a computation `transactionally`;

45+first `begin`,

46+then run the computation,

47+`onException` `rollback` and rethrow the exception,

48+otherwise `commit` and `return` the result.

49+-}

5350transactionally

54− :: (MonadBaseControl IO tx, MonadPQ schema tx)

51+ :: (MonadUnliftIO tx, MonadPQ schemas tx)

5552 => TransactionMode

5653 -> tx x -- ^ run inside a transaction

5754 -> tx x

5855transactionally mode tx = mask $ \restore -> do

59− _ <- begin mode

60− result <- restore tx `onException` rollback

61− _ <- commit

56+ manipulate_ $ begin mode

57+ result <- restore tx `onException` (manipulate_ rollback)

58+ manipulate_ commit

6259 return result

6360

64−-- | Run a schema invariant computation `transactionally_` in `defaultMode`.

61+-- | Run a computation `transactionally_`, in `defaultMode`.

6562transactionally_

66− :: (MonadBaseControl IO tx, MonadPQ schema tx)

63+ :: (MonadUnliftIO tx, MonadPQ schemas tx)

6764 => tx x -- ^ run inside a transaction

6865 -> tx x

6966transactionally_ = transactionally defaultMode

7067

71−-- | @BEGIN@ a transaction.

72−begin :: MonadPQ schema tx => TransactionMode -> tx (K Result NilRelation)

73−begin mode = manipulate . UnsafeManipulation $

74− "BEGIN" <+> renderTransactionMode mode <> ";"

68+{- |

69+`transactionallyRetry` a computation;

70+

71+* first `begin`,

72+* then `try` the computation,

73+ - if it raises a serialization failure then `rollback` and restart the transaction,

74+ - if it raises any other exception then `rollback` and rethrow the exception,

75+ - otherwise `commit` and `return` the result.

76+-}

77+transactionallyRetry

78+ :: (MonadUnliftIO tx, MonadPQ schemas tx)

79+ => TransactionMode

80+ -> tx x -- ^ run inside a transaction

81+ -> tx x

82+transactionallyRetry mode tx = mask $ \restore ->

83+ loop . try $ do

84+ x <- restore tx

85+ manipulate_ commit

86+ return x

87+ where

88+ loop attempt = do

89+ manipulate_ $ begin mode

90+ attempt >>= \case

91+ Left (PQException (PQState _ (Just "40001") _)) -> do

92+ manipulate_ rollback

93+ loop attempt

94+ Left err -> do

95+ manipulate_ rollback

96+ throwIO err

97+ Right x -> return x

98+

99+{- | Run a computation `ephemerally`;

100+Like `transactionally` but always `rollback`, useful in testing.

101+-}

102+ephemerally

103+ :: (MonadUnliftIO tx, MonadPQ schemas tx)

104+ => TransactionMode

105+ -> tx x -- ^ run inside an ephemeral transaction

106+ -> tx x

107+ephemerally mode tx = mask $ \restore -> do

108+ manipulate_ $ begin mode

109+ result <- restore tx `onException` (manipulate_ rollback)

110+ manipulate_ rollback

111+ return result

75112

76−-- | @COMMIT@ a schema invariant transaction.

77−commit :: MonadPQ schema tx => tx (K Result NilRelation)

78−commit = manipulate $ UnsafeManipulation "COMMIT;"

113+{- | Run a computation `ephemerally` in `defaultMode`. -}

114+ephemerally_

115+ :: (MonadUnliftIO tx, MonadPQ schemas tx)

116+ => tx x -- ^ run inside an ephemeral transaction

117+ -> tx x

118+ephemerally_ = ephemerally defaultMode

119+

120+-- | @BEGIN@ a transaction.

121+begin :: TransactionMode -> Manipulation_ schemas () ()

122+begin mode = UnsafeManipulation $ "BEGIN" <+> renderSQL mode

79123

80−-- | @ROLLBACK@ a schema invariant transaction.

81−rollback :: MonadPQ schema tx => tx (K Result NilRelation)

82−rollback = manipulate $ UnsafeManipulation "ROLLBACK;"

124+-- | @COMMIT@ a transaction.

125+commit :: Manipulation_ schemas () ()

126+commit = UnsafeManipulation "COMMIT"

83127

84−-- | Run a schema changing computation `transactionallySchema`.

85−transactionallySchema

86− :: MonadBaseControl IO io

87− => TransactionMode

88− -> PQ schema0 schema1 io x

89− -> PQ schema0 schema1 io x

90−transactionallySchema mode u = PQ $ \ conn -> mask $ \ restore -> do

91− _ <- liftBase . LibPQ.exec (unK conn) $

92− "BEGIN" <+> renderTransactionMode mode <> ";"

93− x <- restore (unPQ u conn)

94− `onException` (liftBase (LibPQ.exec (unK conn) "ROLLBACK"))

95− _ <- liftBase $ LibPQ.exec (unK conn) "COMMIT"

96− return x

97−

98−-- | Run a schema changing computation `transactionallySchema_` in `DefaultMode`.

99−transactionallySchema_

100− :: MonadBaseControl IO io

101− => PQ schema0 schema1 io x

102− -> PQ schema0 schema1 io x

103−transactionallySchema_ = transactionallySchema defaultMode

128+-- | @ROLLBACK@ a transaction.

129+rollback :: Manipulation_ schemas () ()

130+rollback = UnsafeManipulation "ROLLBACK"

104131

105132-- | The available transaction characteristics are the transaction `IsolationLevel`,

106133-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.

@@ -113,7 +140,7 @@ data TransactionMode = TransactionMode

113140-- | `TransactionMode` with a `Serializable` `IsolationLevel`,

114141-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.

115142defaultMode :: TransactionMode

116−defaultMode = TransactionMode Serializable ReadWrite NotDeferrable

143+defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable

117144

118145-- | `TransactionMode` with a `Serializable` `IsolationLevel`,

119146-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.

@@ -122,12 +149,12 @@ longRunningMode :: TransactionMode

122149longRunningMode = TransactionMode Serializable ReadOnly Deferrable

123150

124151-- | Render a `TransactionMode`.

125−renderTransactionMode :: TransactionMode -> ByteString

126−renderTransactionMode mode =

127− "ISOLATION LEVEL"

128− <+> renderIsolationLevel (isolationLevel mode)

129− <+> renderAccessMode (accessMode mode)

130− <+> renderDeferrableMode (deferrableMode mode)

152+instance RenderSQL TransactionMode where

153+ renderSQL mode =

154+ "ISOLATION LEVEL"

155+ <+> renderSQL (isolationLevel mode)

156+ <+> renderSQL (accessMode mode)

157+ <+> renderSQL (deferrableMode mode)

131158

132159-- | The SQL standard defines four levels of transaction isolation.

133160-- The most strict is `Serializable`, which is defined by the standard in a paragraph

@@ -178,12 +205,12 @@ data IsolationLevel

178205 deriving (Show, Eq)

179206

180207-- | Render an `IsolationLevel`.

181−renderIsolationLevel :: IsolationLevel -> ByteString

182−renderIsolationLevel = \case

183− Serializable -> "SERIALIZABLE"

184− ReadCommitted -> "READ COMMITTED"

185− ReadUncommitted -> "READ UNCOMMITTED"

186− RepeatableRead -> "REPEATABLE READ"

208+instance RenderSQL IsolationLevel where

209+ renderSQL = \case

210+ Serializable -> "SERIALIZABLE"

211+ ReadCommitted -> "READ COMMITTED"

212+ ReadUncommitted -> "READ UNCOMMITTED"

213+ RepeatableRead -> "REPEATABLE READ"

187214

188215-- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`.

189216-- `ReadWrite` is the default. When a transaction is `ReadOnly`,

@@ -200,10 +227,10 @@ data AccessMode

200227 deriving (Show, Eq)

201228

202229-- | Render an `AccessMode`.

203−renderAccessMode :: AccessMode -> ByteString

204−renderAccessMode = \case

205− ReadWrite -> "READ WRITE"

206− ReadOnly -> "READ ONLY"

230+instance RenderSQL AccessMode where

231+ renderSQL = \case

232+ ReadWrite -> "READ WRITE"

233+ ReadOnly -> "READ ONLY"

207234

208235-- | The `Deferrable` transaction property has no effect

209236-- unless the transaction is also `Serializable` and `ReadOnly`.

@@ -219,7 +246,7 @@ data DeferrableMode

219246 deriving (Show, Eq)

220247

221248-- | Render a `DeferrableMode`.

222−renderDeferrableMode :: DeferrableMode -> ByteString

223−renderDeferrableMode = \case

224− Deferrable -> "DEFERRABLE"

225− NotDeferrable -> "NOT DEFERRABLE"

249+instance RenderSQL DeferrableMode where

250+ renderSQL = \case

251+ Deferrable -> "DEFERRABLE"

252+ NotDeferrable -> "NOT DEFERRABLE"

squeal-postgresql/test/Doc.hsnew file+6

@@ -0,0 +1,6 @@

1+module Main (main) where

3+import Test.DocTest

5+main :: IO ()

6+main = doctest [ "-isrc", "src" ]

squeal-postgresql/test/DocTest.hsdeleted−18

@@ -1,18 +0,0 @@

1−module Main (main) where

2−

3−import Test.DocTest

4−

5−main :: IO ()

6−main = doctest

7− [ "-isrc"

8− , "src/Squeal/PostgreSQL.hs"

9− , "src/Squeal/PostgreSQL/Binary.hs"

10− , "src/Squeal/PostgreSQL/Definition.hs"

11− , "src/Squeal/PostgreSQL/Manipulation.hs"

12− , "src/Squeal/PostgreSQL/Query.hs"

13− , "src/Squeal/PostgreSQL/Expression.hs"

14− , "src/Squeal/PostgreSQL/PQ.hs"

15− , "src/Squeal/PostgreSQL/Migration.hs"

16− , "src/Squeal/PostgreSQL/Transaction.hs"

17− , "src/Squeal/PostgreSQL/Pool.hs"

18− ]

squeal-postgresql/test/Property.hsnew file+166

@@ -0,0 +1,166 @@

1+{-# LANGUAGE

2+ DataKinds

3+ , GADTs

4+ , LambdaCase

5+ , OverloadedLabels

6+ , OverloadedStrings

7+ , TypeApplications

8+ , TypeOperators

9+#-}

10+

11+module Main (main) where

12+

13+import Control.Monad.Trans

14+import Data.ByteString (ByteString)

15+import Data.ByteString.Char8 (unpack)

16+import Data.Scientific (fromFloatDigits)

17+import Data.Fixed (Fixed(MkFixed), Micro, Pico)

18+import Data.String (IsString(fromString))

19+import Data.Time

20+import Squeal.PostgreSQL hiding (check, defaultMain, Group)

21+import Hedgehog hiding (Range)

22+import qualified Hedgehog.Gen as Gen

23+import qualified Hedgehog.Main as Main

24+import qualified Hedgehog.Range as Range

25+

26+main :: IO ()

27+main = Main.defaultMain [checkSequential roundtrips]

28+

29+roundtrips :: Group

30+roundtrips = Group "roundtrips"

31+ [ roundtrip int2 genInt16

32+ , roundtrip int4 genInt32

33+ , roundtrip int8 genInt64

34+ , roundtrip bool Gen.bool

35+ , roundtrip numeric genScientific

36+ , roundtrip float4 genFloat

37+ , roundtrip float8 genDouble

38+ , roundtripOn normalizeTimeOfDay time genTimeOfDay

39+ -- , roundtrip timetz genTimeWithZone normalizeTimeWithZone

40+ , roundtripOn normalizeLocalTime timestamp genLocalTime

41+ , roundtrip timestamptz genUTCTime

42+ , roundtrip date genDay

43+ , roundtrip interval genDiffTime

44+ , roundtripOn normalizeIntRange int4range (genRange genInt32)

45+ , roundtripOn normalizeIntRange int8range (genRange genInt64)

46+ , roundtrip numrange (genRange genScientific)

47+ , roundtripOn (fmap normalizeLocalTime) tsrange (genRange genLocalTime)

48+ , roundtrip tstzrange (genRange genUTCTime)

49+ , roundtripOn normalizeIntRange daterange (genRange genDay)

50+ ]

51+ where

52+ genInt16 = Gen.int16 Range.exponentialBounded

53+ genInt32 = Gen.int32 Range.exponentialBounded

54+ genInt64 = Gen.int64 Range.exponentialBounded

55+ genScientific = fromFloatDigits <$> genFloat

56+ genPosFloat = Gen.float

57+ (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)

58+ genFloat = Gen.prune $ Gen.choice

59+ [ genPosFloat

60+ , negate <$> genPosFloat

61+ , Gen.element [0,1/0] ]

62+ genPosDouble = Gen.double

63+ (Range.exponentialFloatFrom 1 minPosFloat maxPosFloat)

64+ genDouble = Gen.prune $ Gen.choice

65+ [ genPosDouble

66+ , negate <$> genPosDouble

67+ , Gen.element [0,1/0] ]

68+ genRange gen = do

69+ lb <- gen

70+ ub <- Gen.filter (lb <) gen

71+ Gen.element

72+ [ Empty, singleton lb, whole

73+ , lb <=..<= ub , lb <=..< ub, lb <..<= ub, lb <..< ub

74+ , atLeast lb, moreThan lb, atMost ub, lessThan ub ]

75+ genDay = do

76+ y <- toInteger <$> Gen.int (Range.constant 2000 2019)

77+ m <- Gen.int (Range.constant 1 12)

78+ d <- Gen.int (Range.constant 1 28)

79+ return $ fromGregorian y m d

80+ genDiffTime = secondsToDiffTime . toInteger <$>

81+ Gen.int (Range.constant 0 86401)

82+ genUTCTime = UTCTime <$> genDay <*> genDiffTime

83+ genTimeOfDay = do

84+ h <- Gen.int (Range.constant 0 23)

85+ m <- Gen.int (Range.constant 0 59)

86+ s <- MkFixed . toInteger <$> Gen.int (Range.constant 0 59)

87+ return $ TimeOfDay h m s

88+ genLocalTime = LocalTime <$> genDay <*> genTimeOfDay

89+ -- genTimeZone = Gen.element $ map (read @TimeZone)

90+ -- [ "UTC", "UT", "GMT", "EST", "EDT", "CST"

91+ -- , "CDT", "MST", "MDT", "PST", "PDT" ]

92+ -- genTimeWithZone = (,) <$> genTimeOfDay <*> genTimeZone

93+

94+roundtrip

95+ :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)

96+ => TypeExpression schemas ('NotNull ty)

97+ -> Gen x

98+ -> (PropertyName, Property)

99+roundtrip = roundtripOn id

100+

101+roundtripOn

102+ :: (OidOf ty, ToParam x ty, FromValue ty x, Show x, Eq x)

103+ => (x -> x)

104+ -> TypeExpression schemas ('NotNull ty)

105+ -> Gen x

106+ -> (PropertyName, Property)

107+roundtripOn norm ty gen = propertyWithName $ do

108+ x <- forAll gen

109+ Just (Only y) <- lift . withConnection connectionString $

110+ firstRow =<< runQueryParams

111+ (values_ (parameter @1 ty `as` #fromOnly)) (Only x)

112+ norm x === y

113+ where

114+ propertyWithName prop =

115+ (fromString (unpack (renderSQL ty)), property prop)

116+

117+maxPosFloat :: RealFloat a => a

118+maxPosFloat = x

119+ where

120+ n = floatDigits x

121+ b = floatRadix x

122+ (_, u) = floatRange x

123+ x = encodeFloat (b^n - 1) (u - n)

124+

125+minPosFloat :: RealFloat a => a

126+minPosFloat = x

127+ where

128+ n = floatDigits x

129+ b = floatRadix x

130+ (l, _) = floatRange x

131+ x = encodeFloat (b^n - 1) (l - n - 1)

132+

133+connectionString :: ByteString

134+connectionString = "host=localhost port=5432 dbname=exampledb"

135+

136+normalizeIntRange :: (Enum int, Ord int) => Range int -> Range int

137+normalizeIntRange = \case

138+ Empty -> Empty

139+ NonEmpty l u ->

140+ let

141+ l' = normalizeL l

142+ u' = normalizeU u

143+ in if emptyNormalized l' u' then Empty else NonEmpty l' u'

144+ where

145+ normalizeL = \case

146+ Open l -> Closed (succ l)

147+ normalized -> normalized

148+ normalizeU = \case

149+ Closed u -> Open (succ u)

150+ normalized -> normalized

151+ emptyNormalized (Closed l) (Open u) = l >= u

152+ emptyNormalized _ _ = False

153+

154+normalizeTimeOfDay :: TimeOfDay -> TimeOfDay

155+normalizeTimeOfDay (TimeOfDay h m s) = TimeOfDay h m

156+ . fromRational @Pico

157+ . toRational @Micro

158+ . fromRational @Micro

159+ . toRational @Pico

160+ $ s

161+

162+normalizeLocalTime :: LocalTime -> LocalTime

163+normalizeLocalTime (LocalTime d t) = LocalTime d (normalizeTimeOfDay t)

164+

165+-- normalizeTimeWithZone :: (TimeOfDay, TimeZone) -> (TimeOfDay, TimeZone)

166+-- normalizeTimeWithZone (t, z) = (normalizeTimeOfDay t, z)

squeal-postgresql/test/Spec.hsnew file+136

@@ -0,0 +1,136 @@

1+{-# LANGUAGE

2+ DataKinds

3+ , DeriveAnyClass

4+ , DeriveGeneric

5+ , DerivingStrategies

6+ , DuplicateRecordFields

7+ , FlexibleContexts

8+ , OverloadedLabels

9+ , OverloadedLists

10+ , OverloadedStrings

11+ , TypeApplications

12+ , TypeFamilies

13+ , TypeInType

14+ , TypeOperators

15+#-}

16+

17+module Main (main) where

18+

19+import Control.Concurrent.Async (replicateConcurrently)

20+import Data.ByteString (ByteString)

21+import Data.Int (Int32)

22+import Data.Text (Text)

23+import Test.Hspec

24+

25+import qualified Generics.SOP as SOP

26+import qualified GHC.Generics as GHC

27+

28+import Squeal.PostgreSQL

29+

30+main :: IO ()

31+main = hspec spec

32+

33+type Schemas = Public

34+ '[ "users" ::: 'Table (

35+ '[ "pk_users" ::: 'PrimaryKey '["id"]

36+ , "unique_names" ::: 'Unique '["name"]

37+ ] :=>

38+ '[ "id" ::: 'Def :=> 'NotNull 'PGint4

39+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext ] ) ]

40+

41+data User = User

42+ { userName :: Text

43+ } deriving stock (Eq, Show, GHC.Generic)

44+ deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)

45+

46+insertUser :: Manipulation_ Schemas User ()

47+insertUser = insertInto_ #users

48+ (Values_ (Default `as` #id :* Set (param @1) `as` #name))

49+

50+setup :: Definition (Public '[]) Schemas

51+setup =

52+ createTable #users

53+ ( serial `as` #id :*

54+ notNullable text `as` #name )

55+ ( primaryKey #id `as` #pk_users :*

56+ unique #name `as` #unique_names )

57+

58+teardown :: Definition Schemas (Public '[])

59+teardown = dropTable #users

60+

61+silence :: MonadPQ schemas pq => pq ()

62+silence = manipulate_ $

63+ UnsafeManipulation "SET client_min_messages TO WARNING;"

64+

65+setupDB :: IO ()

66+setupDB = withConnection connectionString $

67+ silence & pqThen (define setup)

68+

69+dropDB :: IO ()

70+dropDB = withConnection connectionString $

71+ silence & pqThen (define teardown)

72+

73+connectionString :: ByteString

74+connectionString = "host=localhost port=5432 dbname=exampledb"

75+

76+spec :: Spec

77+spec = before_ setupDB . after_ dropDB $ do

78+

79+ describe "Exceptions" $ do

80+

81+ let

82+ testUser = User "TestUser"

83+ newUser = manipulateParams_ insertUser

84+ insertUserTwice = newUser testUser >> newUser testUser

85+ err23505 = PQException $ PQState FatalError (Just "23505")

86+ (Just "ERROR: duplicate key value violates unique constraint \"unique_names\"\nDETAIL: Key (name)=(TestUser) already exists.\n")

87+

88+ it "should be thrown for constraint violation" $

89+ withConnection connectionString insertUserTwice

90+ `shouldThrow` (== err23505)

91+

92+ it "should be rethrown for constraint violation in a transaction" $

93+ withConnection connectionString (transactionally_ insertUserTwice)

94+ `shouldThrow` (== err23505)

95+

96+ describe "Pools" $

97+

98+ it "should manage concurrent transactions" $ do

99+ pool <- createConnectionPool

100+ "host=localhost port=5432 dbname=exampledb" 1 0.5 10

101+ let

102+ query :: Query_ (Public '[]) () (Only Char)

103+ query = values_ (literal 'a' `as` #fromOnly)

104+ session = usingConnectionPool pool . transactionally_ $ do

105+ result <- runQuery query

106+ Just (Only chr) <- firstRow result

107+ return chr

108+ chrs <- replicateConcurrently 10 session

109+ chrs `shouldSatisfy` all (== 'a')

110+

111+ describe "Ranges" $

112+

113+ it "should correctly decode ranges" $ do

114+

115+ rangesOut <- withConnection connectionString $ do

116+ let

117+ query :: Query_ (Public '[]) () (Only (Range Int32))

118+ query = values

119+ ( range int4range (atLeast 3) `as` #fromOnly )

120+ [ range int4range (3 <=..< 5) `as` #fromOnly

121+ , range int4range Empty `as` #fromOnly

122+ , range int4range whole `as` #fromOnly ]

123+ getRows =<< runQuery query

124+ (fromOnly <$> rangesOut :: [Range Int32]) `shouldBe`

125+ [ atLeast 3, 3 <=..< 5, Empty, whole ]

126+

127+ describe "Parameters" $ do

128+

129+ it "should run queries that don't reference all their parameters" $ do

130+

131+ out <- withConnection connectionString $ do

132+ let

133+ query :: Query_ (Public '[]) (Char,Int32) (Only Int32)

134+ query = values_ (param @2 `as` #fromOnly)

135+ firstRow =<< runQueryParams query ('a', 3 :: Int32)

136+ (fromOnly <$> out :: Maybe Int32) `shouldBe` Just 3

squeal-presentation-raveline.mdnew file+794

@@ -0,0 +1,794 @@

1+# Squeal

3+_A bridge between SQL and Haskell_

5+by [@Raveline](https://github.com/raveline)

7+---

9+# Rationale

10+

11+Using `postgresql-simple` you have a typical "Trial, error, despair" workflow:

12+

13+- Write query manually or semi-automatically

14+

15+- Write haskell code using the query

16+

17+- Pray that the query syntax is correct

18+

19+- Pray that it returns what you want

20+

21+- Realize the inefficiency of prayer when it comes to SQL

22+

23+- Iterate till it works

24+

25+---

26+

27+![Can't take this anymore](http://gif.eraveline.eu/static/img/0x16e.gif)

28+

29+---

30+

31+# Use your best friend: GHC

32+

33+Squeal provides several eDSL to make your SQL typesafe:

34+

35+- Type level eDSL to express schema;

36+

37+- Value level eDSL to manipulate schema (plus migration, yeehaw !);

38+

39+- Type level eDSL to express queries;

40+

41+- Value level eDSL to perform queries

42+

43+However, it's not an ORM. There's no caching, lazy loading - you retain control over your memory. Also, joins - and mostly aggregation after joins - have to be handled manually.

44+

45+---

46+

47+# Part I. Schema & migration

48+

49+---

50+

51+# The Schema

52+

53+- The schema will be used to validate _everything_: migration, queries, etc.

54+

55+- A schema is mostly a collection of tables.

56+

57+- In this presentation, we will create a very basic database modeling a parliament. We will store _members of parliament_ and _parliamentary groups_.

58+

59+- A simple Schema to represent a Parliament could be:

60+

61+```haskell

62+type Schema = '[ "mp" ::: 'Table MemberOfParliament

63+ , "groupp" ::: 'Table ParliamentGroup ]

64+```

65+

66+---

67+

68+> _note_ We need the `DataKinds` extension to be able to express heterogenous lists containing

69+> specific types like this one.

70+

71+> You can perfectly call your table "group" and not "groupp" even though it is a

72+> keyword in SQL - Squeal queries will be properly escaped.

73+

74+---

75+

76+# A small example

77+

78+```haskell

79+type ParliamentaryGroup =

80+ '[ "pk_groupp" ::: 'PrimaryKey '["groupp_id"]]

81+ :=>

82+ '[ "groupp_id" ::: 'NoDef :=> 'NotNull 'PGuuid

83+ , "name" ::: 'NoDef :=> 'NotNull 'PGtext

84+ ]

85+```

86+

87+- That's a whole simple table defined in one go.

88+

89+- `:::` lets us define a column or a constraint.

90+

91+- `:=>` associates the constraints to the column.

92+

93+- Let's split constraints and column to study the syntax a bit more.

94+

95+---

96+

97+> _note_ We are using `:::` and `:=>` to quickly express associations when writing

98+> our schema. We need the `TypeOperators` extension.]

99+

100+---

101+

102+![What does this means ?!](http://gif.eraveline.eu/static/img/0x27e.gif)

103+

104+---

105+

106+# Defining a table

107+

108+```haskell

109+type MemberOfParliament =

110+ '[ "pk_mp" ::: 'PrimaryKey '["mp_id"]

111+ , "fk_mp_groupp" ::: 'ForeignKey '["mp_group"] "groupp" '["groupp_id"]

112+ ] :=> MpCols

113+```

114+

115+- A table is a collection of constraints associated to a collection of columns.

116+

117+- We defined a table named "mp".

118+

119+- It has a constraint named "pk_mp", defining its primary key on column "mp_id".

120+

121+- It has a constraint named "fk_mp_groupp" defining a foreign key on column "mg_group", connected to the column "groupp_id" of table "groupp".

122+

123+- These constraints will be associated to the columns defined in `MpCols`.

124+

125+---

126+

127+# Defining columns

128+

129+```haskell

130+type MpCols =

131+ '[ "mp_id" ::: 'NoDef :=> 'NotNull 'PGuuid

132+ , "first_name" ::: 'NoDef :=> 'NotNull 'PGtext

133+ , "last_name" ::: 'NoDef :=> 'NotNull 'PGtext

134+ ]

135+```

136+

137+- A listing of column associate, for each element:

138+

139+ * a name;

140+

141+ * the mention of an eventual default value;

142+

143+ * the nullability;

144+

145+ * the type (obviously).

146+

147+---

148+

149+> _note_ GHC is already helping. If I named the "mp_id" column differently,

150+> GHC would yell because I promised a primary key constraint on a column named `mp_id`, so there must be one.]

151+

152+---

153+

154+# Implementating the schema

155+

156+- We will carry this schema type pretty much everywhere.

157+

158+- But before we play with this schema, we need to implement it.

159+

160+---

161+

162+```haskell

163+setup :: Definition '[] Schema

164+setup =

165+ createTable #groupp

166+ ( notNullable uuid `as` #groupp_id

167+ :* notNullable text `as` #name)

168+ ( primaryKey #groupp_id `as` #pk_groupp )

169+ >>> createTable #mp

170+ ( notNullable uuid `as` #mp_id

171+ :* notNullable text `as` #first_name

172+ :* notNullable text `as` #last_name

173+ :* notNullable text `as` #mp_group)

174+ ( primaryKey #mp_id `as` #pk_mp

175+ :* foreignKey #mp_group #groupp #groupp_id

176+ OnDeleteCascade OnUpdateCascade

177+ `as` #fk_mp_groupp)

178+```

179+

180+---

181+

182+# Damn, that's verbose

183+

184+- Yes. But you need verbosity to get type safety.

185+

186+- On the plus side, it's fairly straightforward.

187+

188+- You use `:*` to compose the element of the heterogenous list of columns.

189+

190+- You use `>>>` to compose table creation.

191+

192+> _note_ The compiler will catch any mistype between Schema and

193+> definition; wrong nullability, wrong type, wrong name, etc.

194+

195+---

196+

197+> _note_ You'll also need `OverloadedLabels`, for naming stuff.

198+> This is mostly to avoid having to write manual proxies all

199+> the time and for convenience.

200+

201+---

202+

203+# Setting up the schema

204+

205+- Squeal comes with a very good migration manager, handling _upgrades_ AND

206+_downgrades_.

207+

208+- A migration is a simple type:

209+

210+```haskell

211+Migration io schema0 schema1

212+```

213+

214+- The first parameter is a BaseMonad (typically, IO).

215+

216+- The second parameter is "the current schema of your DB".

217+

218+- The last one is "what you will migrate to".

219+

220+- The `Definition` type used to define upgrade and downgrade functions use the

221+ same logic (from one schema to the other).

222+

223+---

224+

225+# Defining our first migration

226+

227+- We have the setup bit, we need the teardown:

228+

229+```haskell

230+tearDown :: Definition Schema '[]

231+tearDown = dropTable #mp >>> dropTable #groupp

232+```

233+

234+> _note_ GHC will also detect the _proper_ order of what you typed in

235+> downgrade and upgrade should there be any conflict (with foreign keys).

236+

237+```haskell

238+initDB :: Migration IO '[] Schema

239+initDB =

240+ Migration { name = "Schema creation"

241+ , up = void $ define setup

242+ , down = void $ define tearDown }

243+```

244+

245+---

246+

247+# Simple migrator example

248+

249+```haskell

250+main :: IO ()

251+main = do

252+ printSQL setup

253+ void $ withConnection connectionString $

254+ migrateUp $ single initDB

255+```

256+

257+- We print the migration query; you can do this for all queries generated through Squeal.

258+

259+- We use `migrateUp` to perform the migration.

260+

261+- You can run several migration at the same time, to run only one use `single`.

262+

263+---

264+

265+![That was easy](http://gif.eraveline.eu/static/img/0x47f.gif)

266+

267+---

268+

269+# Part II. Insertions

270+

271+---

272+

273+# Manipulations & Queries

274+

275+Besides the specific case of migration, you will mostly perform:

276+

277+- `Manipulation` : inserting, updating and deleting data.

278+

279+- `Query` : fetching data.

280+

281+- Both types are parametric over the same things:

282+

283+ * A schema

284+

285+ * Input parameters

286+

287+ * Output

288+

289+- Simplified, they look like this:

290+

291+```haskell

292+Manipulation schema params columns

293+

294+Query schema params columns

295+```

296+

297+

298+---

299+

300+# Our Haskell model

301+

302+```haskell

303+type Parliament = [Group]

304+

305+data Group =

306+ Group { name :: Text

307+ , members :: [MemberOfParliament] }

308+

309+data MemberOfParliament =

310+ MemberOfParliament { firstName :: Text

311+ , lastName :: Text }

312+```

313+

314+> _note_ We didn't use anything from Squeal.

315+> The model can be entirely separated from the persistence layer.

316+

317+---

318+

319+# Inserting a Parliamentary Group

320+

321+- A group is very simple: it's a uuid and a name. Let's define our params:

322+

323+```haskell

324+type GroupInsertionParams = '[ 'NotNull 'PGuuid

325+ , 'NotNull 'PGtext ]

326+```

327+

328+- Params are not named, but they are indexed. You just need nullability and type.

329+

330+---

331+

332+```haskell

333+groupInsertion :: Manipulation Schema GroupInsertionParams '[]

334+groupInsertion =

335+ insertRow_ #groupp ( Set (param @1) `as` #groupp_id

336+ :* Set (param @2) `as` #name )

337+```

338+

339+---

340+

341+- `TypeApplication` lets us use the index of parameters (counting from 1).

342+

343+- Once again: all this is checked by the compiler. Wrong name, wrong type... you'll get a compile error.

344+

345+- `insertRow_` is a simplified version of `insertRow`. `insertRow` lets you express a `RETURNING` clause and the expected behaviour in case of conflict.

346+

347+---

348+

349+_Inserting a Member of Parliament_

350+# Doing an INSERT INTO ... SELECT

351+

352+- We could create a naive query that takes MP uuid, first name, last name and group uuid...

353+

354+---

355+

356+- But that's boring. So let's use the `INSERT INTO ... SELECT`.

357+

358+---

359+

360+- We will build a query that will return as constants our MP's uuid, first name and last name...

361+

362+---

363+

364+- ... and fetch the uuid of a group given the name of the group.

365+

366+---

367+

368+- There's a `insertQuery` utility function for that. All we have to do is write the `select` !

369+

370+```haskell

371+mpInsertion :: Manipulation Schema MpParams '[]

372+mpInsertion =

373+ insertQuery_ #mp selectGroup -- we just have to write selectGroup !

374+```

375+

376+---

377+

378+_Inserting a Member of Parliament_

379+# The query type

380+

381+- A query looks just like a `Manipulation`:

382+

383+```haskell

384+Query schema params returns

385+```

386+

387+- Returns use a special syntax, that demands names, nullability and types:

388+

389+```haskell

390+type ExampleReturnType = '[ "some_column" ::: 'NotNull 'PGuuid

391+ , "other_column" ::: 'Null 'PGtext ]

392+```

393+

394+- It is not the same as the column definition we used in the schema. That one also expects that you specify, for each column, an eventual default:

395+

396+```haskell

397+type ExampleSchemaCols =

398+ '[ "some_column" ::: 'NoDef :=> 'NotNull 'PGuuid

399+ , "other_column" ::: 'NoDef :=> 'Null 'PGtext ]

400+```

401+

402+---

403+

404+_Inserting a Member of Parliament_

405+# Don't rewrite column definitions

406+

407+- We want our return type to be "all columns from table MP expressed as return type".

408+

409+- But we cannot reuse our neat `MpCols` alias, since the type do not match as we've just seen.

410+

411+- Hopefully, there's a neat Type Family that will let you convert any table you defined to the type of the equivalent row: `TableToRow`.

412+

413+- We finally have the signature for our SELECT query.

414+

415+```haskell

416+selectGroup :: Query Schema MpParams (TableToRow MemberOfParliament)

417+```

418+

419+---

420+

421+_Inserting a Member of Parliament_

422+# Our final Select query

423+

424+- Our intermediate query looks like this:

425+

426+```haskell

427+selectGroup =

428+ select

429+ ( param @1 `as` #mp_id

430+ :* param @2 `as` #first_name

431+ :* param @3 `as` #last_name

432+ :* #groupp ! #groupp_id `as` #mp_group

433+ )

434+ ( from (table #groupp)

435+ & where_ ( #groupp ! #name .== param @4 )

436+ )

437+```

438+

439+- The first three columns are constant defined through our params;

440+

441+- ... we alias the column name using `as`...

442+

443+- ... and when we need the result from the table we use the `#table ! #column` syntax.

444+

445+- We'll go back to the "from" block later.

446+

447+---

448+

449+# Dealing with the connection context

450+

451+- Queries are runned in a connection context:

452+

453+ * When dealing with a single-connection context, use the type `PQ`.

454+

455+ * When dealing with a pool of connection, use the type `PoolPQ`.

456+

457+- Or get rid of the context and use `mtl` style, with the typeclass `MonadPQ`.

458+

459+- We'll use that to demonstrate how to actually run our queries.

460+

461+---

462+

463+# Inserting a whole group

464+

465+```haskell

466+insertGroup :: (MonadPQ Schema m, MonadBaseControl IO m) => Group -> m ()

467+insertGroup g@(Group name _) = do

468+ uuid' <- liftBase nextRandom

469+ void $ manipulateParams groupInsertion (uuid', name)

470+ insertMps g

471+```

472+

473+- Remember that we defined a group as a name and a list of MPs.

474+

475+- We are in `MonadBaseControl`, so we cannot use `liftIO`, we need `liftBase`.

476+

477+- To perform a simple insertion, use `manipulateParams`. It takes into parameter

478+instances of `ToParam`, but you will typically use tuples or Generic-SOP.

479+

480+---

481+

482+# Inserting a bunch of MPs

483+

484+```haskell

485+insertMps :: (MonadPQ Schema m, MonadBaseControl IO m) => Group -> m ()

486+insertMps (Group groupName mps) =

487+ let tuplify Mp{..} = (, firstName, lastName, groupName) <$> nextRandom

488+ params = traverse tuplify mps

489+ in void $ liftBase params >>= traversePrepared mpInsertion

490+```

491+

492+- This time, we want to do a `preparedStatement`. We'll use `traversePrepare`

493+which behaves like `manipulateParams`, but expect a list of `ToParam`

494+instances.

495+

496+- We build our tuple manually again, mostly because we want to generate UUID on

497+the fly and we don't want to have them in our model.

498+

499+---

500+

501+# Inserting a whole parliament

502+

503+```haskell

504+insertParliament ::

505+ (MonadPQ Schema m, MonadBaseControl IO m) => Parliament -> m ()

506+insertParliament = traverse_ insertGroup

507+```

508+

509+- That's simple enough !

510+

511+- If we want to be a bit safer, though, we can wrap this call in a

512+`transactionally_` function, which will put all that in a transaction.

513+

514+---

515+

516+![Very simple](https://media1.tenor.com/images/0188c63209aced59f1583e1ca94e509e/tenor.gif?itemid=3550689)

517+

518+

519+---

520+

521+# Part III. Selects

522+

523+---

524+

525+# Composable queries

526+

527+- Building basic queries is easy, and is well documented.

528+

529+- However, the real interest of a tool like Squeal is in DRYness, and the documentation is still lacking in "how-to" related to composability.

530+

531+- I'll build an example showing how column selections and from clause can be factorized.

532+

533+- We want to write two queries:

534+

535+ * One to get all members of a specific group.

536+

537+ * One to get all the parliament.

538+

539+---

540+

541+# Decomposing a `Query`

542+

543+- A query typically stars with `select` (variants are available).

544+

545+- It then takes:

546+

547+ * A heterogenous list of fields with a scary signature;

548+

549+ * A virtual table (the from clause and filter clauses), called a `TableExpression`.

550+

551+- And return fields. Ours will look like this:

552+

553+```haskell

554+type GroupRowResult =

555+ '[ "groupName" ::: 'NotNull 'PGtext

556+ , "firstName" ::: 'NotNull 'PGtext

557+ , "lastName" ::: 'NotNull 'PGtext ]

558+```

559+

560+---

561+

562+# The Table Expression

563+

564+- It necessarily contains a `fromClause` (table, view or subquery, plus optional joins).

565+

566+- You can add where, groups, "HAVING" clause, order, etc.

567+

568+- `from` creates a basic `TableExpression` that you extend through various function to add clauses.

569+

570+- For our queries, we will share a common `FromClause`.

571+

572+---

573+

574+# The From Clause

575+

576+```

577+FromClause schema params from

578+```

579+

580+- We need Schema, input parameters and a `FromType` giving the available fields of the expression.

581+

582+- In our case, we'll join the table `mp` and the table `groupp`, meaning the `from` will be all fields of these tables.

583+

584+- We can use `TableToRow` to be more DRY:

585+

586+```haskell

587+type BaseParliamentSelection =

588+ '[ "g" ::: TableToRow GroupCols

589+ , "m" ::: TableToRow MpCols ]

590+```

591+

592+> _note_ We've also put everything with table aliases: "g" and "m".

593+

594+---

595+

596+# Writing our from clause

597+

598+```haskell

599+baseParliamentTables ::

600+ FromClause Schema (param :: [NullityType]) BaseParliamentSelection

601+baseParliamentTables =

602+ table

603+ (#groupp `as` #g)

604+ & innerJoin

605+ (table (#mp `as` #m))

606+ (#m ! #mp_group .== #g ! #groupp_id)

607+```

608+

609+- When picking "from" something, you need to specify the type with a function: `table` for a table, `view` for a view, etc.

610+

611+- All joins are available. `innerJoin` is the most basic one. It takes the joined table and the joining condition.

612+

613+- We have to specifiy the type of `param` (current limitation of the lib), even though _any_ params will be compatible with this, so we can plug `where` clauses depending on params should we need to !

614+

615+---

616+

617+# Typing the common selection

618+

619+- Both our querie will need the same fields. This has to be factorized too.

620+

621+- The scary signature of selection fields:

622+

623+```haskell

624+NP (Aliased (Expression schema from grouping params)) cols

625+```

626+

627+- `NP` is for heterogenous lists ("n-ary product").

628+

629+- `from` is the virtual table type, so our `BaseParliamentSelection`.

630+

631+- `grouping` is there to make a distinction between aggregated / unaggregated queries.

632+

633+- And finally, cols is the return type.

634+

635+---

636+

637+# Our common selection

638+

639+```haskell

640+groupSelection ::

641+ NP (Aliased (Expression Schema BaseParliamentSelection 'Ungrouped param))

642+ GroupRowResult

643+groupSelection =

644+ #g ! #name `as` #groupName

645+ :* #m ! #first_name `as` #firstName

646+ :* #m ! #last_name `as` #lastName

647+```

648+

649+- I hope you like big signatures.

650+

651+- But it's what let GHC checks that all alias and columns are available.

652+

653+- And that you're returning what you really intend to return.

654+

655+---

656+

657+# Putting it all together

658+

659+```haskell

660+selectParliament :: Query Schema '[] GroupRowResult

661+selectParliament =

662+ select groupSelection (from baseParliamentTables)

663+```

664+

665+```haskell

666+selectGroupMembers :: Query Schema '[ 'NotNull 'PGtext] GroupRowResult

667+selectGroupMembers =

668+ select groupSelection

669+ (from baseParliamentTables

670+ & where_ (#g ! #name .== param @1))

671+```

672+

673+- That is fairly DRY. And _entirely typesafe_.

674+

675+---

676+

677+# Actually fetching the data

678+

679+- We'll build an intermediary datatype representing our rows.

680+

681+- We'll make it match our row.

682+

683+- And we'll add generic-SOP so that we can build them from query results.

684+

685+```haskell

686+type GroupRowResult =

687+ '[ "groupName" ::: 'NotNull 'PGtext

688+ , "firstName" ::: 'NotNull 'PGtext

689+ , "lastName" ::: 'NotNull 'PGtext ]

690+```

691+

692+```haskell

693+data GroupRow =

694+ GroupRow { groupName :: Text

695+ , firstName :: Text

696+ , lastName :: Text }

697+ deriving (Generic)

698+

699+instance SOP.Generic GroupRow

700+instance SOP.HasDatatypeInfo GroupRow

701+```

702+

703+---

704+

705+# Aggregate result logic

706+

707+- We will get tabular, SQL data.

708+

709+- Our results will be `[GroupRow]`.

710+

711+- We'll build `Groups` from this:

712+

713+```haskell

714+buildGroup :: NE.NonEmpty GroupRow -> Group

715+buildGroup grs =

716+ let buildMP (GroupRow _ f l) = Mp f l

717+ name = groupName . NE.head $ grs

718+ members = NE.toList (buildMP <$> grs)

719+ in Group{..}

720+

721+rowToGroups :: [GroupRow] -> [Group]

722+rowToGroups =

723+ let grouped = fmap NE.fromList . L.groupBy ((==) `on` groupName)

724+ in fmap buildGroup . grouped

725+```

726+

727+---

728+

729+# Finally calling our queries

730+

731+- Query with params will use `runQueryParams`.

732+

733+- Query without params will use `runQuery`.

734+

735+- Result is inside a `MonadPQ` and of type `K` from generic-sop.

736+

737+- You get your actual result using `getRows`. Exemple:

738+

739+```haskell

740+getParliament :: (MonadPQ Schema m, MonadBaseControl IO m) => m [Group]

741+getParliament = do

742+ res <- runQuery selectParliament

743+ rows <- getRows res

744+ pure $ rowToGroups rows

745+```

746+

747+- In real life of course you'll write:

748+

749+```haskell

750+getParliament =

751+ rowToGroups <$> (runQuery selectParliament >>= getRows)

752+```

753+

754+---

755+

756+# Our query with params

757+

758+```haskell

759+getGroupMembers ::

760+ (MonadPQ Schema m, MonadBaseControl IO m) => Text -> m (Maybe Group)

761+getGroupMembers =

762+ listToMaybe . rowToGroups <$>

763+ (runQueryParams selectGroupMembers (Only t) >>= getRows)

764+```

765+

766+- And that's it.

767+

768+---

769+

770+![Eazy](https://media.tenor.com/images/8fc7c4077efe11b4a3a3b9ae4e643e87/tenor.gif)

771+

772+---

773+

774+# Conclusion

775+

776+---

777+

778+# Pros & Cons

779+

780+- Not everything is included: some cool stuff like array_agg and window functions are not available yet.

781+

782+- But development is _very_ active. `IN` clauses were missing but were added in the 4.0 released recently.

783+

784+- It's bleeding edge. You need latest LTS to be comfortable and psql >= 9.5.

785+

786+- It's Postgres-only but I would say that's a feature. Multi-DB tools are even more complex.

787+

788+- The author & maintainer is <3.

789+

790+- Typesafe. 'nuff said.

791+

792+---

793+

794+# Thank you !

stack.yaml+6−1

@@ -1,3 +1,8 @@

1−resolver: lts-11.1

1+resolver: nightly-2019-07-14

22packages:

33- squeal-postgresql

5+extra-deps:

6+- unliftio-pool-0.2.1.0

7+- github: morphismtech/free-categories

8+ commit: c0e555fbefb5c21619e532264c4dfeac556d0630