d531baa...dev · squeal

git.iko.soy/squeal

52 files changed+11998−4422

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 & hasNotNull) `As` #name :* Nil )

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

132− createTable #emails

133− ( serial `As` #id :*

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

135− (text & hasNull) `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 & hasNotNull) `As` #name :*

49− (vararray int2 & hasNotNull) `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 & hasNotNull) `As` #user_id :*

55− (text & hasNull) `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+74−13

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

11name: squeal-postgresql

2−version: 0.2.1.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

41− , binary-parser

42− , bytestring-strict-builder

68+ , base >= 4.11.1.0 && < 5.0

69+ , binary-parser >= 0.5.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+233−222

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

1−-- | Module: Squeal.PostgreSQL

2−-- Description: Squeel export module

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

4−-- Maintainer: eitan@morphism.tech

5−-- Stability: experimental

6−--

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

8−-- Let's see an example!

9−--

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

11−-- features.

12−--

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

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

15−--

16−-- We'll need some imports.

17−--

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

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

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

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

22−-- >>> import Squeal.PostgreSQL

23−--

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

25−--

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

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

28−--

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

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

31−--

32−-- >>> :{

33−-- type Schema =

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

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

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

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

38−-- ])

39−-- , "emails" ::: 'Table (

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

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

42−-- ] :=>

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

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

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

46−-- ])

47−-- ]

48−-- :}

49−--

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

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

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

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

54−-- yielding a `ColumnType`.

55−--

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

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

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

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

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

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

62−--

63−-- >>> :{

64−-- let

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

66−-- setup =

67−-- createTable #users

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

69−-- (text & hasNotNull) `As` #name :* Nil )

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

71−-- createTable #emails

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

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

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

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

76−-- foreignKey #user_id #users #id

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

78−-- :}

79−--

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

81−--

82−-- >>> renderDefinition setup

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

84−--

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

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

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

88−-- `Definition` is simpler.

89−--

90−-- >>> :{

91−-- let

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

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

94−-- :}

95−--

96−-- >>> renderDefinition teardown

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

98−--

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

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

101−-- or `deleteFrom` command and

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

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

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

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

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

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

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

109−-- of our inserts.

110−--

111−-- >>> :{

112−-- let

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

114−-- insertUser = insertRow #users

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

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

117−-- :}

118−--

119−-- >>> :{

120−-- let

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

122−-- insertEmail = insertRow #emails

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

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

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

126−-- OnConflictDoNothing (Returning Nil)

127−-- :}

128−--

129−-- >>> renderManipulation insertUser

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

131−-- >>> renderManipulation insertEmail

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

133−--

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

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

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

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

138−--

139−-- >>> :{

140−-- let

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

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

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

144−-- getUsers = select

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

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

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

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

149−-- :}

150−--

151−-- >>> renderQuery getUsers

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

153−--

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

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

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

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

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

159−--

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

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

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

163−--

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

165−--

166−-- >>> :{

167−-- let

168−-- users :: [User]

169−-- users =

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

171−-- , User "Bob" Nothing

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

173−-- ]

174−-- :}

175−--

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

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

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

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

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

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

182−-- `MonadPQ` functionality.

183−--

184−-- >>> :{

185−-- let

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

187−-- session = do

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

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

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

191−-- usersResult <- runQuery getUsers

192−-- usersRows <- getRows usersResult

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

194−-- :}

195−--

196−-- >>> :{

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

198−-- define setup

199−-- & pqThen session

200−-- & pqThen (define teardown)

201−-- :}

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

203−

204−module Squeal.PostgreSQL

205− ( module Squeal.PostgreSQL.Binary

206− , module Squeal.PostgreSQL.Definition

207− , module Squeal.PostgreSQL.Expression

208− , module Squeal.PostgreSQL.Manipulation

209− , module Squeal.PostgreSQL.PQ

210− , module Squeal.PostgreSQL.Query

211− , module Squeal.PostgreSQL.Schema

212− , module Squeal.PostgreSQL.Transaction

213− ) where

214−

215−import Squeal.PostgreSQL.Binary

216−import Squeal.PostgreSQL.Definition

217−import Squeal.PostgreSQL.Expression

218−import Squeal.PostgreSQL.Manipulation

219−import Squeal.PostgreSQL.PQ

220−import Squeal.PostgreSQL.Query

221−import Squeal.PostgreSQL.Schema

222−import Squeal.PostgreSQL.Transaction

1+{-|

2+Module: Squeal.PostgreSQL

3+Description: Squeal export module

4+Copyright: (c) Eitan Chatav, 2019

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

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

9+Let's see an example!

10+

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

12+features.

13+

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

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

16+

17+We'll need some imports.

18+

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

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

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

22+>>> import Squeal.PostgreSQL

23+

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

25+

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

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

28+

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

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

31+

32+>>> :{

33+type UsersColumns =

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

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

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

37+type EmailsColumns =

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

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

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

41+type EmailsConstraints =

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

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

44+type Schema =

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

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

47+type Schemas = Public Schema

48+:}

49+

50+Notice the use of type operators.

51+

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

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

54+operator.

55+

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

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

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

59+

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

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

62+has two type parameters, corresponding to the schema

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

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

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

66+

67+>>> :{

68+let

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

70+ setup =

71+ createTable #users

72+ ( serial `as` #id :*

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

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

75+ createTable #emails

76+ ( serial `as` #id :*

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

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

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

80+ foreignKey #user_id #users #id

81+ OnDeleteCascade OnUpdateCascade `as` #fk_user_id )

82+:}

83+

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

85+

86+>>> printSQL setup

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

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

89+

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

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

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

93+`Definition` is simpler.

94+

95+>>> :{

96+let

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

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

99+:}

100+

101+>>> printSQL teardown

102+DROP TABLE "emails";

103+DROP TABLE "users";

104+

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

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

107+

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

109+>>> instance SOP.Generic User

110+>>> instance SOP.HasDatatypeInfo User

111+

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

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

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

115+and an output row. When

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

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

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

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

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

121+`with` statement.

122+

123+>>> :{

124+let

125+ insertUser :: Manipulation_ Schemas User ()

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

127+ where

128+ u = insertInto #users

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

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

131+ e = insertInto_ #emails $ Select

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

133+ (from (common #u))

134+:}

135+

136+>>> printSQL insertUser

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

138+

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

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

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

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

143+

144+>>> :{

145+let

146+ getUsers :: Query_ Schemas () User

147+ getUsers = select_

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

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

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

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

152+:}

153+

154+>>> printSQL getUsers

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

156+

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

158+

159+>>> :{

160+let

161+ users :: [User]

162+ users =

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

164+ , User "Bob" Nothing

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

166+ ]

167+:}

168+

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

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

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

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

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

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

175+`MonadPQ` functionality.

176+

177+>>> :{

178+let

179+ session :: PQ Schemas Schemas IO ()

180+ session = do

181+ _ <- traversePrepared_ insertUser users

182+ usersResult <- runQuery getUsers

183+ usersRows <- getRows usersResult

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

185+in

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

187+ define setup

188+ & pqThen session

189+ & pqThen (define teardown)

190+:}

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

192+-}

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

194+

195+import Squeal.PostgreSQL.Alias as X

196+import Squeal.PostgreSQL.Binary as X

197+import Squeal.PostgreSQL.Definition as X

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

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

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

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

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

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

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

205+import Squeal.PostgreSQL.Expression as X

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

224+import Squeal.PostgreSQL.List as X

225+import Squeal.PostgreSQL.Manipulation as X

226+import Squeal.PostgreSQL.Migration as X

227+import Squeal.PostgreSQL.PG as X

228+import Squeal.PostgreSQL.Pool as X

229+import Squeal.PostgreSQL.PQ as X

230+import Squeal.PostgreSQL.Query as X

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

232+import Squeal.PostgreSQL.Schema as X

233+import Squeal.PostgreSQL.Transaction as X

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+607−174

@@ -5,7 +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 `SOP.Generic` and `SOP.HasDatatypeInfo` typeclasses, so you absolutely

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

12+to encode Haskell values into statement parameters.

13+

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

15+

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

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

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

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

20+>>> import Squeal.PostgreSQL

21+

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

23+round trip query.

24+

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

26+>>> instance Generic Row

27+>>> instance HasDatatypeInfo Row

28+>>> :{

29+let

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

31+ roundTrip = values_ $

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

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

34+ parameter @3 bool `as` #col3

35+:}

36+

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

38+the input and output should be equal.

39+

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

41+>>> :{

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

43+ result <- runQueryParams roundTrip input

44+ Just output <- firstRow result

45+ liftIO . print $ input == output

46+:}

47+True

48+

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

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

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

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

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

54+create multi-dimensional fixed length arrays.

55+

56+>>> :{

57+data Row = Row

58+ { col1 :: VarArray (Vector Int16)

59+ , col2 :: FixArray (Maybe Int16,Maybe Int16)

60+ , col3 :: FixArray ((Int16,Int16),(Int16,Int16),(Int16,Int16))

61+ } deriving (Eq, GHC.Generic)

62+:}

63+

64+>>> instance Generic Row

65+>>> instance HasDatatypeInfo Row

66+

67+Once again, we define a simple round trip query.

68+

69+>>> :{

70+let

71+ roundTrip :: Query_ (Public '[]) Row Row

72+ roundTrip = values_ $

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

74+ parameter @2 (int2 & fixarray @'[2]) `as` #col2 :*

75+ parameter @3 (int2 & fixarray @'[3,2]) `as` #col3

76+:}

77+

78+>>> :set -XOverloadedLists

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

80+>>> :{

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

82+ result <- runQueryParams roundTrip input

83+ Just output <- firstRow result

84+ liftIO . print $ input == output

85+:}

86+True

87+

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

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

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

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

92+

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

94+>>> instance Generic Schwarma

95+>>> instance HasDatatypeInfo Schwarma

96+

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

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

99+

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

101+>>> instance Generic Person

102+>>> instance HasDatatypeInfo Person

103+>>> instance Aeson.FromJSON Person

104+>>> instance Aeson.ToJSON Person

105+

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

107+

108+>>> :{

109+type Schema =

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

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

112+ ]

113+:}

114+

115+>>> :{

116+let

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

118+ setup =

119+ createTypeEnumFrom @Schwarma #schwarma >>>

120+ createTypeCompositeFrom @Person #person

121+:}

122+

123+Let's demonstrate how to associate our Haskell types @Schwarma@ and @Person@

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

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

126+

127+>>> :{

128+data Row = Row

129+ { schwarma :: Enumerated Schwarma

130+ , person1 :: Composite Person

131+ , person2 :: Json Person

132+ } deriving (Eq, GHC.Generic)

133+:}

134+

135+>>> instance Generic Row

136+>>> instance HasDatatypeInfo Row

137+>>> :{

138+let

139+ input = Row

140+ (Enumerated Chicken)

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

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

143+:}

144+

145+Once again, define a round trip query.

146+

147+>>> :{

148+let

149+ roundTrip :: Query_ (Public Schema) Row Row

150+ roundTrip = values_ $

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

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

153+ parameter @3 json `as` #person2

154+:}

155+

156+Finally, we can drop our type definitions.

157+

158+>>> :{

159+let

160+ teardown :: Definition (Public Schema) (Public '[])

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

162+:}

163+

164+Now let's run it.

165+

166+>>> :{

167+let

168+ session = do

169+ result <- runQueryParams roundTrip input

170+ Just output <- firstRow result

171+ liftIO . print $ input == output

172+in

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

174+ define setup

175+ & pqThen session

176+ & pqThen (define teardown)

177+:}

178+True

9179-}

10180

11181{-# LANGUAGE

@@ -14,55 +184,76 @@ Binary encoding and decoding between Haskell and PostgreSQL types.

14184 , DeriveFunctor

15185 , DeriveGeneric

16186 , DeriveTraversable

187+ , DefaultSignatures

17188 , FlexibleContexts

18189 , FlexibleInstances

190+ , FunctionalDependencies

19191 , GADTs

20192 , LambdaCase

193+ , OverloadedStrings

21194 , MultiParamTypeClasses

22195 , ScopedTypeVariables

23196 , TypeApplications

197+ , TypeFamilies

24198 , TypeInType

25199 , TypeOperators

26200 , UndecidableInstances

201+ , UndecidableSuperClasses

27202#-}

28203

29204module Squeal.PostgreSQL.Binary

30205 ( -- * Encoding

31206 ToParam (..)

32− , ToColumnParam (..)

33207 , ToParams (..)

208+ , ToNullityParam (..)

209+ , ToField (..)

210+ , ToFixArray (..)

34211 -- * Decoding

35212 , FromValue (..)

36− , FromColumnValue (..)

37213 , FromRow (..)

214+ , FromField (..)

215+ , FromFixArray (..)

38216 -- * Only

39217 , Only (..)

218+ -- * Oid

219+ , OidOf (..)

220+ , OidOfParam (..)

221+ , OidOfField (..)

40222 ) where

41223

42224import BinaryParser

43−import ByteString.StrictBuilder

44−import Data.Aeson hiding (Null)

225+import ByteString.StrictBuilder (builderLength, int32BE, int64BE, word32BE)

226+import Control.Arrow (left)

227+import Control.Monad

45228import Data.Int

46229import Data.Kind

47−import Data.Monoid hiding (All)

48230import Data.Scientific

49231import Data.Time

50232import Data.UUID.Types

51233import Data.Vector (Vector)

52234import Data.Word

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

53236import Generics.SOP

237+import Generics.SOP.Record

54238import GHC.TypeLits

55239import Network.IP.Addr

56240

57−import qualified Data.ByteString.Lazy as Lazy

58−import qualified Data.ByteString as Strict hiding (pack, unpack)

59−import qualified Data.Text.Lazy as Lazy

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

61248import qualified Data.Vector as Vector

249+import qualified Database.PostgreSQL.LibPQ as LibPQ

62250import qualified GHC.Generics as GHC

63251import qualified PostgreSQL.Binary.Decoding as Decoding

64252import qualified PostgreSQL.Binary.Encoding as Encoding

65253

254+import Squeal.PostgreSQL.Alias

255+import Squeal.PostgreSQL.List

256+import Squeal.PostgreSQL.PG

66257import Squeal.PostgreSQL.Schema

67258

68259-- | A `ToParam` constraint gives an encoding of a Haskell `Type` into

@@ -86,19 +277,20 @@ class ToParam (x :: Type) (pg :: PGType) where

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

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

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

89−instance ToParam Word16 'PGint2 where toParam = K . Encoding.int2_word16

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

91−instance ToParam Word32 'PGint4 where toParam = K . Encoding.int4_word32

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

93−instance ToParam Word64 'PGint8 where toParam = K . Encoding.int8_word64

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

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

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

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

286+instance ToParam Money 'PGmoney where toParam = K . Encoding.int8_int64 . cents

97287instance ToParam UUID 'PGuuid where toParam = K . Encoding.uuid

98288instance ToParam (NetAddr IP) 'PGinet where toParam = K . Encoding.inet

99289instance ToParam Char ('PGchar 1) where toParam = K . Encoding.char_utf8

100290instance ToParam Strict.Text 'PGtext where toParam = K . Encoding.text_strict

101291instance 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

102294instance ToParam Strict.ByteString 'PGbytea where

103295 toParam = K . Encoding.bytea_strict

104296instance ToParam Lazy.ByteString 'PGbytea where

@@ -112,17 +304,40 @@ instance ToParam LocalTime 'PGtimestamp where

112304instance ToParam UTCTime 'PGtimestamptz where

113305 toParam = K . Encoding.timestamptz_int

114306instance ToParam DiffTime 'PGinterval where toParam = K . Encoding.interval_int

115−instance ToParam Value 'PGjson where toParam = K . Encoding.json_ast

116−instance ToParam Value 'PGjsonb where toParam = K . Encoding.jsonb_ast

117−instance (HasOid pg, ToParam x pg)

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

119− toParam = K . Encoding.nullableArray_vector

120− (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

121336instance

122337 ( IsEnumType x

123338 , HasDatatypeInfo x

124− , LabelsWith x ~ labels

125− ) => ToParam x ('PGenum labels) where

339+ , LabelsPG x ~ labels

340+ ) => ToParam (Enumerated x) ('PGenum labels) where

126341 toParam =

127342 let

128343 gshowConstructor :: NP ConstructorInfo xss -> SOP I xss -> String

@@ -133,24 +348,23 @@ instance

133348 gshowConstructor constructors (SOP xs)

134349 in

135350 K . Encoding.text_strict

136− . Strict.pack

351+ . Strict.Text.pack

137352 . gshowConstructor (constructorInfo (datatypeInfo (Proxy @x)))

138353 . from

354+ . getEnumerated

139355instance

140356 ( SListI fields

141− , MapMaybes xs

142− , IsProductType x (Maybes xs)

143− , AllZip ToAliasedParam xs fields

144− , FieldNamesWith x ~ AliasesOf fields

145− , All HasAliasedOid fields

146− ) => 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

147361 toParam =

148362 let

149363

150− encoders = htrans (Proxy @ToAliasedParam) toAliasedParam

364+ encoders = htrans (Proxy @ToField) toField

151365

152366 composite

153− :: All HasAliasedOid row

367+ :: All OidOfField row

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

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

156370 composite fields = K $

@@ -167,53 +381,179 @@ instance

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

168382 let

169383 each

170− :: HasAliasedOid field

384+ :: OidOfField field

171385 => K (Maybe Encoding.Encoding) field

172386 -> Encoding.Encoding

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

174− word32BE (aliasedOid @field)

388+ word32BE (getOid (oidOfField @field))

175389 <> case field of

176390 Nothing -> int64BE (-1)

177391 Just value ->

178392 int32BE (fromIntegral (builderLength value))

179393 <> value

180394 in

181− hcfoldMap (Proxy @HasAliasedOid) each fields

395+ hcfoldMap (Proxy @OidOfField) each fields

182396

183397 in

184− composite . encoders . unMaybes . unZ . unSOP . from

185−

186−class HasAliasedOid (field :: (Symbol, PGType)) where aliasedOid :: Word32

187−instance HasOid ty => HasAliasedOid (alias ::: ty) where aliasedOid = oid @ty

188−

189−class ToAliasedParam (x :: Type) (field :: (Symbol, PGType)) where

190− toAliasedParam :: Maybe x -> K (Maybe Encoding.Encoding) field

191−instance ToParam x ty => ToAliasedParam x (alias ::: ty) where

192− toAliasedParam = \case

193− Nothing -> K Nothing

194− Just x -> K . Just . unK $ toParam @x @ty x

195−

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

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

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

199−class ToColumnParam (x :: Type) (ty :: NullityType) where

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

201− -- K (Just "\NUL\NUL")

202− --

203− -- >>> toColumnParam @(Maybe Int16) @('Null 'PGint2) (Just 0)

204− -- K (Just "\NUL\NUL")

205− --

206− -- >>> toColumnParam @(Maybe Int16) @('Null 'PGint2) Nothing

207− -- K Nothing

208− toColumnParam :: x -> K (Maybe Strict.ByteString) ty

209−instance ToParam x pg => ToColumnParam x ('NotNull pg) where

210− toColumnParam = K . Just . Encoding.encodingBytes . unK . toParam @x @pg

211−instance ToParam x pg => ToColumnParam (Maybe x) ('Null pg) where

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

213553

214554-- | A `ToParams` constraint generically sequences the encodings of `Type`s

215555-- of the fields of a tuple or record to a row of `ColumnType`s. You should

216−-- not define instances of `ToParams`. Instead define `Generic` instances

556+-- not define instances of `ToParams`. Instead define `SOP.Generic` instances

217557-- which in turn provide `ToParams` instances.

218558class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where

219559 -- | >>> type Params = '[ 'NotNull 'PGbool, 'Null 'PGint2]

@@ -225,61 +565,98 @@ class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where

225565 -- >>> instance Generic Tuple

226566 -- >>> toParams @Tuple @Params (Tuple False (Just 0))

227567 -- K (Just "\NUL") :* K (Just "\NUL\NUL") :* Nil

228− toParams :: x -> NP (K (Maybe Strict.ByteString)) tys

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

230570 => ToParams x tys where

231571 toParams

232− = htrans (Proxy @ToColumnParam) (toColumnParam . unI)

572+ = htrans (Proxy @ToNullityParam) (toNullityParam . unI)

233573 . unZ . unSOP . from

234574

235575-- | A `FromValue` constraint gives a parser from the binary format of

236576-- a PostgreSQL `PGType` into a Haskell `Type`.

237577class FromValue (pg :: PGType) (y :: Type) where

238578 -- | >>> newtype Id = Id { getId :: Int16 } deriving Show

239− -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue

240− fromValue :: proxy pg -> Decoding.Value y

241−instance FromValue 'PGbool Bool where fromValue _ = Decoding.bool

242−instance FromValue 'PGint2 Int16 where fromValue _ = Decoding.int

243−instance FromValue 'PGint4 Int32 where fromValue _ = Decoding.int

244−instance FromValue 'PGint8 Int64 where fromValue _ = Decoding.int

245−instance FromValue 'PGfloat4 Float where fromValue _ = Decoding.float4

246−instance FromValue 'PGfloat8 Double where fromValue _ = Decoding.float8

247−instance FromValue 'PGnumeric Scientific where fromValue _ = Decoding.numeric

248−instance FromValue 'PGuuid UUID where fromValue _ = Decoding.uuid

249−instance FromValue 'PGinet (NetAddr IP) where fromValue _ = Decoding.inet

250−instance FromValue ('PGchar 1) Char where fromValue _ = Decoding.char

251−instance FromValue 'PGtext Strict.Text where fromValue _ = Decoding.text_strict

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

253597instance FromValue 'PGbytea Strict.ByteString where

254− fromValue _ = Decoding.bytea_strict

598+ fromValue = Decoding.bytea_strict

255599instance FromValue 'PGbytea Lazy.ByteString where

256− fromValue _ = Decoding.bytea_lazy

257−instance FromValue 'PGdate Day where fromValue _ = Decoding.date

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

259603instance FromValue 'PGtimetz (TimeOfDay, TimeZone) where

260− fromValue _ = Decoding.timetz_int

604+ fromValue = Decoding.timetz_int

261605instance FromValue 'PGtimestamp LocalTime where

262− fromValue _ = Decoding.timestamp_int

606+ fromValue = Decoding.timestamp_int

263607instance FromValue 'PGtimestamptz UTCTime where

264− fromValue _ = Decoding.timestamptz_int

608+ fromValue = Decoding.timestamptz_int

265609instance FromValue 'PGinterval DiffTime where

266− fromValue _ = Decoding.interval_int

267−instance FromValue 'PGjson Value where fromValue _ = Decoding.json_ast

268−instance FromValue 'PGjsonb Value where fromValue _ = Decoding.jsonb_ast

269−instance FromValue pg y => FromValue ('PGvararray pg) (Vector (Maybe y)) where

270− fromValue _ = Decoding.array

271− (Decoding.dimensionArray Vector.replicateM

272− (Decoding.nullableValueArray (fromValue (Proxy @pg))))

273−instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where

274− fromValue _ = Decoding.array

275− (Decoding.dimensionArray Vector.replicateM

276− (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)

277654instance

278655 ( IsEnumType y

279656 , HasDatatypeInfo y

280− , LabelsWith y ~ labels

281− ) => FromValue ('PGenum labels) y where

282− fromValue _ =

657+ , LabelsPG y ~ labels

658+ ) => FromValue ('PGenum labels) (Enumerated y) where

659+ fromValue =

283660 let

284661 greadConstructor

285662 :: All ((~) '[]) xss

@@ -292,29 +669,16 @@ instance

292669 then Just (SOP (Z Nil))

293670 else SOP . S . unSOP <$> greadConstructor constructors name

294671 in

295− Decoding.enum

672+ fmap Enumerated

673+ . Decoding.enum

296674 $ fmap to

297675 . greadConstructor (constructorInfo (datatypeInfo (Proxy @y)))

298− . Strict.unpack

299−

676+ . Strict.Text.unpack

300677instance

301− ( SListI fields

302− , MapMaybes ys

303− , IsProductType y (Maybes ys)

304− , AllZip FromAliasedValue fields ys

305− , FieldNamesWith y ~ AliasesOf fields

306− ) => FromValue ('PGcomposite fields) y where

678+ ( FromRow fields y

679+ ) => FromValue ('PGcomposite fields) (Composite y) where

307680 fromValue =

308681 let

309− decoders

310− :: forall pgs zs proxy

311− . AllZip FromAliasedValue pgs zs

312− => proxy ('PGcomposite pgs)

313− -> NP Decoding.Value zs

314− decoders _ = htrans (Proxy @FromAliasedValue) fromAliasedValue

315− (hpure Proxy :: NP Proxy pgs)

316−

317− composite fields = do

318682 -- <number of fields: 4 bytes>

319683 -- [for each field]

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

@@ -325,80 +689,133 @@ instance

325689 -- <value: <length> bytes>

326690 -- [end if]

327691 -- [end for]

692+ composite = Decoding.valueParser $ do

328693 unitOfSize 4

329− let

330− each field = do

331− unitOfSize 4

332− len <- sized 4 Decoding.int

333− if len == -1 then return Nothing else Just <$> sized len field

334− htraverse' each fields

335−

336− in fmap (to . SOP . Z . maybes) . composite . decoders

337−

338−class FromAliasedValue (pg :: (Symbol,PGType)) (y :: Type) where

339− fromAliasedValue :: proxy pg -> Decoding.Value y

340−instance FromValue pg y => FromAliasedValue (alias ::: pg) y where

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

342702

343−-- | A `FromColumnValue` constraint lifts the `FromValue` parser

703+-- | A `FromField` constraint lifts the `FromValue` parser

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

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

346−-- `FromColumnValue`, just use the provided instances.

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

348− -- | >>> :set -XTypeOperators -XOverloadedStrings

349− -- >>> newtype Id = Id { getId :: Int16 } deriving Show

350− -- >>> instance FromValue 'PGint2 Id where fromValue = fmap Id . fromValue

351− -- >>> fromColumnValue @("col" ::: 'NotNull 'PGint2) @Id (K (Just "\NUL\SOH"))

352− -- Id {getId = 1}

353− --

354− -- >>> fromColumnValue @("col" ::: 'Null 'PGint2) @(Maybe Id) (K (Just "\NUL\SOH"))

355− -- Just (Id {getId = 1})

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

357711instance FromValue pg y

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

359− fromColumnValue = \case

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

361− K (Just bs) ->

362− let

363− errOrValue =

364− Decoding.valueParser (fromValue @pg @y Proxy) bs

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

366− in

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

368717instance FromValue pg y

369− => FromColumnValue (column ::: ('Null pg)) (Maybe y) where

370− fromColumnValue (K nullOrBytes)

371− = either err id

372− . Decoding.valueParser (fromValue @pg @y Proxy)

373− <$> nullOrBytes

374− where

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

376745

377746-- | A `FromRow` constraint generically sequences the parsings of the columns

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

379748-- the same field names. You should not define instances of `FromRow`.

380−-- Instead define `Generic` and `HasDatatypeInfo` instances which in turn

749+-- Instead define `SOP.Generic` and `SOP.HasDatatypeInfo` instances which in turn

381750-- provide `FromRow` instances.

382−class SListI results => FromRow (results :: RelationType) y where

751+class SListI result => FromRow (result :: RowType) y where

383752 -- | >>> :set -XOverloadedStrings

384753 -- >>> import Data.Text

385754 -- >>> newtype UserId = UserId { getUserId :: Int16 } deriving Show

386− -- >>> instance FromValue 'PGint2 UserId where fromValue = fmap UserId . fromValue

755+ -- >>> instance FromValue 'PGint2 UserId where fromValue = UserId <$> fromValue @'PGint2

387756 -- >>> data UserRow = UserRow { userId :: UserId, userName :: Maybe Text } deriving (Show, GHC.Generic)

388757 -- >>> instance Generic UserRow

389758 -- >>> instance HasDatatypeInfo UserRow

390759 -- >>> type User = '["userId" ::: 'NotNull 'PGint2, "userName" ::: 'Null 'PGtext]

391760 -- >>> fromRow @User @UserRow (K (Just "\NUL\SOH") :* K (Just "bloodninja") :* Nil)

392− -- UserRow {userId = UserId {getUserId = 1}, userName = Just "bloodninja"}

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

394763instance

395− ( SListI results

396− , IsProductType y ys

397− , AllZip FromColumnValue results ys

398− , FieldNamesWith y ~ AliasesOf results

399− ) => FromRow results y where

764+ ( SListI result

765+ , IsRecord y ys

766+ , AllZip FromField result ys

767+ ) => FromRow result y where

400768 fromRow

401− = 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)

402819

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

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

@@ -408,8 +825,24 @@ instance

408825-- K (Just "foo") :* Nil

409826--

410827-- >>> fromRow @'["fromOnly" ::: 'Null 'PGtext] @(Only (Maybe Text)) (K (Just "bar") :* Nil)

411−-- Only {fromOnly = Just "bar"}

828+-- Right (Only {fromOnly = Just "bar"})

412829newtype Only x = Only { fromOnly :: x }

413830 deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)

414831instance Generic (Only x)

415832instance 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+26−825

@@ -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,857 +27,56 @@ Squeal data definition language.

2527 , TypeInType

2628 , TypeOperators

2729 , UndecidableSuperClasses

30+ , UndecidableInstances

2831#-}

2932

3033module Squeal.PostgreSQL.Definition

31− ( -- * Definition

32− Definition (UnsafeDefinition, renderDefinition)

34+ ( -- * Definition

35+ Definition (..)

3336 , (>>>)

34− -- * Create

35− , createTable

36− , createTableIfNotExists

37− , TableConstraintExpression (..)

38− , check

39− , unique

40− , primaryKey

41− , foreignKey

42− , ForeignKeyed

43− , OnDeleteClause (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade)

44− , renderOnDeleteClause

45− , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)

46− , renderOnUpdateClause

47− -- * Drop

48− , dropTable

49− -- * Alter

50− , alterTable

51− , alterTableRename

52− , AlterTable (UnsafeAlterTable, renderAlterTable)

53− , addConstraint

54− , dropConstraint

55− , AddColumn (addColumn)

56− , dropColumn

57− , renameColumn

58− , alterColumn

59− , AlterColumn (UnsafeAlterColumn, renderAlterColumn)

60− , setDefault

61− , dropDefault

62− , setNotNull

63− , dropNotNull

64− , alterType

65− -- * Views

66− , createView

67− , dropView

68− -- * Types

69− , createTypeComposite

70− , createTypeEnum

71− , HasPGcomposite (..)

72− , HasPGenum (..)

73− , dropType

74− , ColumnTypeExpression (..)

75− , hasNull

76− , hasNotNull

77− , default_

78− , serial2

79− , smallserial

80− , serial4

81− , serial

82− , serial8

83− , bigserial

37+ , manipDefinition

8438 ) where

8539

8640import Control.Category

8741import Control.DeepSeq

8842import Data.ByteString

8943import Data.Monoid

90−import GHC.TypeLits

9144import Prelude hiding ((.), id)

9245

93−import qualified Generics.SOP as SOP

9446import qualified GHC.Generics as GHC

9547

96−import Squeal.PostgreSQL.Expression

97−import Squeal.PostgreSQL.Query

48+import Squeal.PostgreSQL.Manipulation

9849import Squeal.PostgreSQL.Render

9950import Squeal.PostgreSQL.Schema

10051

52+-- $setup

53+-- >>> import Squeal.PostgreSQL

54+

10155{-----------------------------------------

10256statements

10357-----------------------------------------}

10458

105−-- | A `Definition` is a statement that changes the schema of the

59+-- | A `Definition` is a statement that changes the schemas of the

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

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

10862newtype Definition

109− (schema0 :: SchemaType)

110− (schema1 :: SchemaType)

63+ (schemas0 :: SchemasType)

64+ (schemas1 :: SchemasType)

11165 = UnsafeDefinition { renderDefinition :: ByteString }

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

11367

68+instance RenderSQL (Definition schemas0 schemas1) where

69+ renderSQL = renderDefinition

70+

11471instance Category Definition where

11572 id = UnsafeDefinition ";"

11673 ddl1 . ddl0 = UnsafeDefinition $

117− renderDefinition ddl0 <+> renderDefinition ddl1

118−

119−{-----------------------------------------

120−CREATE statements

121−-----------------------------------------}

122−

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

124−--

125−-- >>> :set -XOverloadedLabels

126−-- >>> :{

127−-- renderDefinition $

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

129−-- :}

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

131−createTable

132− :: ( KnownSymbol table

133− , columns ~ (col ': cols)

134− , SOP.SListI columns

135− , SOP.SListI constraints

136− , schema1 ~ Create table ('Table (constraints :=> columns)) schema0 )

137− => Alias table -- ^ the name of the table to add

138− -> NP (Aliased (ColumnTypeExpression schema0)) columns

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

140− -> NP (Aliased (TableConstraintExpression schema1 table)) constraints

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

142− -> Definition schema0 schema1

143−createTable tab columns constraints = UnsafeDefinition $

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

145−

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

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

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

149−--

150−-- >>> :set -XOverloadedLabels -XTypeApplications

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

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

153−-- >>> :{

154−-- renderDefinition

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

156−-- :}

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

158−createTableIfNotExists

159− :: ( Has table schema ('Table (constraints :=> columns))

160− , SOP.SListI columns

161− , SOP.SListI constraints )

162− => Alias table -- ^ the name of the table to add

163− -> NP (Aliased (ColumnTypeExpression schema)) columns

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

165− -> NP (Aliased (TableConstraintExpression schema table)) constraints

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

167− -> Definition schema schema

168−createTableIfNotExists tab columns constraints = UnsafeDefinition $

169− "CREATE TABLE IF NOT EXISTS"

170− <+> renderCreation tab columns constraints

171−

172−-- helper function for `createTable` and `createTableIfNotExists`

173−renderCreation

174− :: ( KnownSymbol table

175− , SOP.SListI columns

176− , SOP.SListI constraints )

177− => Alias table -- ^ the name of the table to add

178− -> NP (Aliased (ColumnTypeExpression schema0)) columns

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

180− -> NP (Aliased (TableConstraintExpression schema1 table)) constraints

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

182− -> ByteString

183−renderCreation tab columns constraints = renderAlias tab

184− <+> parenthesized

185− ( renderCommaSeparated renderColumnDef columns

186− <> ( case constraints of

187− Nil -> ""

188− _ -> ", " <>

189− renderCommaSeparated renderConstraint constraints ) )

190− <> ";"

191− where

192− renderColumnDef :: Aliased (ColumnTypeExpression schema) x -> ByteString

193− renderColumnDef (ty `As` column) =

194− renderAlias column <+> renderColumnTypeExpression ty

195− renderConstraint

196− :: Aliased (TableConstraintExpression schema columns) constraint

197− -> ByteString

198− renderConstraint (constraint `As` alias) =

199− "CONSTRAINT" <+> renderAlias alias <+> renderTableConstraintExpression constraint

200−

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

202−-- table. For many applications, however, the constraint they provide is

203−-- too coarse. For example, a column containing a product price should

204−-- probably only accept positive values. But there is no standard data type

205−-- that accepts only positive numbers. Another issue is that you might want

206−-- to constrain column data with respect to other columns or rows.

207−-- For example, in a table containing product information,

208−-- there should be only one row for each product number.

209−-- `TableConstraint`s give you as much control over the data in your tables

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

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

212−-- even if the value came from the default value definition.

213−newtype TableConstraintExpression

214− (schema :: SchemaType)

215− (table :: Symbol)

216− (tableConstraint :: TableConstraint)

217− = UnsafeTableConstraintExpression

218− { renderTableConstraintExpression :: ByteString }

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

220−

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

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

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

224−--

225−-- >>> :{

226−-- type Schema = '[

227−-- "tab" ::: 'Table ('[ "inequality" ::: 'Check '["a","b"]] :=> '[

228−-- "a" ::: 'NoDef :=> 'NotNull 'PGint4,

229−-- "b" ::: 'NoDef :=> 'NotNull 'PGint4

230−-- ])]

231−-- :}

232−--

233−-- >>> :{

234−-- let

235−-- definition :: Definition '[] Schema

236−-- definition = createTable #tab

237−-- ( (int & hasNotNull) `As` #a :*

238−-- (int & hasNotNull) `As` #b :* Nil )

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

240−-- :}

241−--

242−-- >>> renderDefinition definition

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

244−check

245− :: ( Has alias schema ('Table table)

246− , HasAll aliases (TableToRelation table) subcolumns )

247− => NP Alias aliases

248− -> (forall tab. Condition '[tab ::: subcolumns] 'Ungrouped '[])

249− -> TableConstraintExpression schema alias ('Check aliases)

250−check _cols condition = UnsafeTableConstraintExpression $

251− "CHECK" <+> parenthesized (renderExpression condition)

252−

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

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

255−--

256−-- >>> :{

257−-- type Schema = '[

258−-- "tab" ::: 'Table( '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[

259−-- "a" ::: 'NoDef :=> 'Null 'PGint4,

260−-- "b" ::: 'NoDef :=> 'Null 'PGint4

261−-- ])]

262−-- :}

263−--

264−-- >>> :{

265−-- let

266−-- definition :: Definition '[] Schema

267−-- definition = createTable #tab

268−-- ( (int & hasNull) `As` #a :*

269−-- (int & hasNull) `As` #b :* Nil )

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

271−-- :}

272−--

273−-- >>> renderDefinition definition

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

275−unique

276− :: ( Has alias schema ('Table table)

277− , HasAll aliases (TableToRelation table) subcolumns )

278− => NP Alias aliases

279− -> TableConstraintExpression schema alias ('Unique aliases)

280−unique columns = UnsafeTableConstraintExpression $

281− "UNIQUE" <+> parenthesized (commaSeparated (renderAliases columns))

282−

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

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

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

286−--

287−-- >>> :{

288−-- type Schema = '[

289−-- "tab" ::: 'Table ('[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[

290−-- "id" ::: 'Def :=> 'NotNull 'PGint4,

291−-- "name" ::: 'NoDef :=> 'NotNull 'PGtext

292−-- ])]

293−-- :}

294−--

295−-- >>> :{

296−-- let

297−-- definition :: Definition '[] Schema

298−-- definition = createTable #tab

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

300−-- (text & hasNotNull) `As` #name :* Nil )

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

302−-- :}

303−--

304−-- >>> renderDefinition definition

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

306−primaryKey

307− :: ( Has alias schema ('Table table)

308− , HasAll aliases (TableToColumns table) subcolumns

309− , AllNotNull subcolumns )

310− => NP Alias aliases

311− -> TableConstraintExpression schema alias ('PrimaryKey aliases)

312−primaryKey columns = UnsafeTableConstraintExpression $

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

314−

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

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

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

318−-- between two related tables.

319−--

320−-- >>> :{

321−-- type Schema =

322−-- '[ "users" ::: 'Table (

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

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

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

326−-- ])

327−-- , "emails" ::: 'Table (

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

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

330−-- ] :=>

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

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

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

334−-- ])

335−-- ]

336−-- :}

337−--

338−-- >>> :{

339−-- let

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

341−-- setup =

342−-- createTable #users

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

344−-- (text & hasNotNull) `As` #name :* Nil )

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

346−-- createTable #emails

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

348−-- (int & hasNotNull) `As` #user_id :*

349−-- (text & hasNull) `As` #email :* Nil )

350−-- ( primaryKey #id `As` #pk_emails :*

351−-- foreignKey #user_id #users #id

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

353−-- in renderDefinition setup

354−-- :}

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

356−--

357−-- A `foreignKey` can even be a table self-reference.

358−--

359−-- >>> :{

360−-- type Schema =

361−-- '[ "employees" ::: 'Table (

362−-- '[ "employees_pk" ::: 'PrimaryKey '["id"]

363−-- , "employees_employer_fk" ::: 'ForeignKey '["employer_id"] "employees" '["id"]

364−-- ] :=>

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

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

367−-- , "employer_id" ::: 'NoDef :=> 'Null 'PGint4

368−-- ])

369−-- ]

370−-- :}

371−--

372−-- >>> :{

373−-- let

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

375−-- setup =

376−-- createTable #employees

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

378−-- (text & hasNotNull) `As` #name :*

379−-- (integer & hasNull) `As` #employer_id :* Nil )

380−-- ( primaryKey #id `As` #employees_pk :*

381−-- foreignKey #employer_id #employees #id

382−-- OnDeleteCascade OnUpdateCascade `As` #employees_employer_fk :* Nil )

383−-- in renderDefinition setup

384−-- :}

385−-- "CREATE TABLE \"employees\" (\"id\" serial, \"name\" text NOT NULL, \"employer_id\" integer NULL, CONSTRAINT \"employees_pk\" PRIMARY KEY (\"id\"), CONSTRAINT \"employees_employer_fk\" FOREIGN KEY (\"employer_id\") REFERENCES \"employees\" (\"id\") ON DELETE CASCADE ON UPDATE CASCADE);"

386−--

387−foreignKey

388− :: (ForeignKeyed schema child parent

389− table reftable

390− columns refcolumns

391− constraints cols

392− reftys tys )

393− => NP Alias columns

394− -- ^ column or columns in the table

395− -> Alias parent

396− -- ^ reference table

397− -> NP Alias refcolumns

398− -- ^ reference column or columns in the reference table

399− -> OnDeleteClause

400− -- ^ what to do when reference is deleted

401− -> OnUpdateClause

402− -- ^ what to do when reference is updated

403− -> TableConstraintExpression schema child

404− ('ForeignKey columns parent refcolumns)

405−foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $

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

407− <+> "REFERENCES" <+> renderAlias parent

408− <+> parenthesized (commaSeparated (renderAliases refs))

409− <+> renderOnDeleteClause ondel

410− <+> renderOnUpdateClause onupd

411−

412−type ForeignKeyed schema

413− child parent

414− table reftable

415− columns refcolumns

416− constraints cols

417− reftys tys =

418− ( Has child schema ('Table table)

419− , Has parent schema ('Table reftable)

420− , HasAll columns (TableToColumns table) tys

421− , reftable ~ (constraints :=> cols)

422− , HasAll refcolumns cols reftys

423− , SOP.AllZip SamePGType tys reftys

424− , Uniquely refcolumns constraints )

425−

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

427−data OnDeleteClause

428− = OnDeleteNoAction

429− -- ^ if any referencing rows still exist when the constraint is checked,

430− -- an error is raised

431− | OnDeleteRestrict -- ^ prevents deletion of a referenced row

432− | OnDeleteCascade

433− -- ^ specifies that when a referenced row is deleted,

434− -- row(s) referencing it should be automatically deleted as well

435− deriving (GHC.Generic,Show,Eq,Ord)

436−instance NFData OnDeleteClause

437−

438−-- | Render `OnDeleteClause`.

439−renderOnDeleteClause :: OnDeleteClause -> ByteString

440−renderOnDeleteClause = \case

441− OnDeleteNoAction -> "ON DELETE NO ACTION"

442− OnDeleteRestrict -> "ON DELETE RESTRICT"

443− OnDeleteCascade -> "ON DELETE CASCADE"

444−

445−-- | Analagous to `OnDeleteClause` there is also `OnUpdateClause` which is invoked

446−-- when a referenced column is changed (updated).

447−data OnUpdateClause

448− = OnUpdateNoAction

449− -- ^ if any referencing rows has not changed when the constraint is checked,

450− -- an error is raised

451− | OnUpdateRestrict -- ^ prevents update of a referenced row

452− | OnUpdateCascade

453− -- ^ the updated values of the referenced column(s) should be copied

454− -- into the referencing row(s)

455− deriving (GHC.Generic,Show,Eq,Ord)

456−instance NFData OnUpdateClause

457−

458−-- | Render `OnUpdateClause`.

459−renderOnUpdateClause :: OnUpdateClause -> ByteString

460−renderOnUpdateClause = \case

461− OnUpdateNoAction -> "ON UPDATE NO ACTION"

462− OnUpdateRestrict -> "ON UPDATE RESTRICT"

463− OnUpdateCascade -> "ON UPDATE CASCADE"

464−

465−{-----------------------------------------

466−DROP statements

467−-----------------------------------------}

468−

469−-- | `dropTable` removes a table from the schema.

470−--

471−-- >>> :{

472−-- let

473−-- definition :: Definition '["muh_table" ::: 'Table t] '[]

474−-- definition = dropTable #muh_table

475−-- :}

476−--

477−-- >>> renderDefinition definition

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

479−dropTable

480− :: Has table schema ('Table t)

481− => Alias table -- ^ table to remove

482− -> Definition schema (Drop table schema)

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

484−

485−{-----------------------------------------

486−ALTER statements

487−-----------------------------------------}

488−

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

490−alterTable

491− :: KnownSymbol alias

492− => Alias alias -- ^ table to alter

493− -> AlterTable alias table schema -- ^ alteration to perform

494− -> Definition schema (Alter alias ('Table table) schema)

495−alterTable tab alteration = UnsafeDefinition $

496− "ALTER TABLE"

497− <+> renderAlias tab

498− <+> renderAlterTable alteration

499− <> ";"

500−

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

502−--

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

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

505−alterTableRename

506− :: (KnownSymbol table0, KnownSymbol table1)

507− => Alias table0 -- ^ table to rename

508− -> Alias table1 -- ^ what to rename it

509− -> Definition schema (Rename table0 table1 schema)

510−alterTableRename table0 table1 = UnsafeDefinition $

511− "ALTER TABLE" <+> renderAlias table0

512− <+> "RENAME TO" <+> renderAlias table1 <> ";"

513−

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

515−-- of a table.

516−newtype AlterTable

517− (alias :: Symbol)

518− (table :: TableType)

519− (schema :: SchemaType) =

520− UnsafeAlterTable {renderAlterTable :: ByteString}

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

522−

523−-- | An `addConstraint` adds a table constraint.

524−--

525−-- >>> :{

526−-- let

527−-- definition :: Definition

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

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

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

531−-- in renderDefinition definition

532−-- :}

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

534−addConstraint

535− :: ( KnownSymbol alias

536− , Has tab schema ('Table table0)

537− , table0 ~ (constraints :=> columns)

538− , table1 ~ (Create alias constraint constraints :=> columns) )

539− => Alias alias

540− -> TableConstraintExpression schema tab constraint

541− -- ^ constraint to add

542− -> AlterTable tab table1 schema

543−addConstraint alias constraint = UnsafeAlterTable $

544− "ADD" <+> "CONSTRAINT" <+> renderAlias alias

545− <+> renderTableConstraintExpression constraint

546−

547−-- | A `dropConstraint` drops a table constraint.

548−--

549−-- >>> :{

550−-- let

551−-- definition :: Definition

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

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

554−-- definition = alterTable #tab (dropConstraint #positive)

555−-- in renderDefinition definition

556−-- :}

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

558−dropConstraint

559− :: ( KnownSymbol constraint

560− , Has tab schema ('Table table0)

561− , table0 ~ (constraints :=> columns)

562− , table1 ~ (Drop constraint constraints :=> columns) )

563− => Alias constraint

564− -- ^ constraint to drop

565− -> AlterTable tab table1 schema

566−dropConstraint constraint = UnsafeAlterTable $

567− "DROP" <+> "CONSTRAINT" <+> renderAlias constraint

568−

569−-- | An `AddColumn` is either @NULL@ or has @DEFAULT@.

570−class AddColumn ty where

571− -- | `addColumn` adds a new column, initially filled with whatever

572− -- default value is given or with @NULL@.

573− --

574− -- >>> :{

575− -- let

576− -- definition :: Definition

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

578− -- '["tab" ::: 'Table ('[] :=>

579− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

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

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

582− -- in renderDefinition definition

583− -- :}

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

585− --

586− -- >>> :{

587− -- let

588− -- definition :: Definition

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

590− -- '["tab" ::: 'Table ('[] :=>

591− -- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

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

593− -- definition = alterTable #tab (addColumn #col2 (text & hasNull))

594− -- in renderDefinition definition

595− -- :}

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

597− addColumn

598− :: ( KnownSymbol column

599− , Has tab schema ('Table table0)

600− , table0 ~ (constraints :=> columns)

601− , table1 ~ (constraints :=> Create column ty columns) )

602− => Alias column -- ^ column to add

603− -> ColumnTypeExpression schema ty -- ^ type of the new column

604− -> AlterTable tab table1 schema

605− addColumn column ty = UnsafeAlterTable $

606− "ADD COLUMN" <+> renderAlias column <+> renderColumnTypeExpression ty

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

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

609−

610−-- | A `dropColumn` removes a column. Whatever data was in the column

611−-- disappears. Table constraints involving the column are dropped, too.

612−-- However, if the column is referenced by a foreign key constraint of

613−-- another table, PostgreSQL will not silently drop that constraint.

614−--

615−-- >>> :{

616−-- let

617−-- definition :: Definition

618−-- '["tab" ::: 'Table ('[] :=>

619−-- '[ "col1" ::: 'NoDef :=> 'Null 'PGint4

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

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

622−-- definition = alterTable #tab (dropColumn #col2)

623−-- in renderDefinition definition

624−-- :}

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

626−dropColumn

627− :: ( KnownSymbol column

628− , Has tab schema ('Table table0)

629− , table0 ~ (constraints :=> columns)

630− , table1 ~ (constraints :=> Drop column columns) )

631− => Alias column -- ^ column to remove

632− -> AlterTable tab table1 schema

633−dropColumn column = UnsafeAlterTable $

634− "DROP COLUMN" <+> renderAlias column

635−

636−-- | A `renameColumn` renames a column.

637−--

638−-- >>> :{

639−-- let

640−-- definition :: Definition

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

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

643−-- definition = alterTable #tab (renameColumn #foo #bar)

644−-- in renderDefinition definition

645−-- :}

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

647−renameColumn

648− :: ( KnownSymbol column0

649− , KnownSymbol column1

650− , Has tab schema ('Table table0)

651− , table0 ~ (constraints :=> columns)

652− , table1 ~ (constraints :=> Rename column0 column1 columns) )

653− => Alias column0 -- ^ column to rename

654− -> Alias column1 -- ^ what to rename the column

655− -> AlterTable tab table1 schema

656−renameColumn column0 column1 = UnsafeAlterTable $

657− "RENAME COLUMN" <+> renderAlias column0 <+> "TO" <+> renderAlias column1

658−

659−-- | An `alterColumn` alters a single column.

660−alterColumn

661− :: ( KnownSymbol column

662− , Has tab schema ('Table table0)

663− , table0 ~ (constraints :=> columns)

664− , Has column columns ty0

665− , tables1 ~ (constraints :=> Alter column ty1 columns))

666− => Alias column -- ^ column to alter

667− -> AlterColumn schema ty0 ty1 -- ^ alteration to perform

668− -> AlterTable tab table1 schema

669−alterColumn column alteration = UnsafeAlterTable $

670− "ALTER COLUMN" <+> renderAlias column <+> renderAlterColumn alteration

671−

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

673−newtype AlterColumn (schema :: SchemaType) (ty0 :: ColumnType) (ty1 :: ColumnType) =

674− UnsafeAlterColumn {renderAlterColumn :: ByteString}

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

676−

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

678−-- affect any existing rows in the table, it just changes the default for

679−-- future insert and update commands.

680−--

681−-- >>> :{

682−-- let

683−-- definition :: Definition

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

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

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

687−-- in renderDefinition definition

688−-- :}

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

690−setDefault

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

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

693−setDefault expression = UnsafeAlterColumn $

694− "SET DEFAULT" <+> renderExpression expression

695−

696−-- | A `dropDefault` removes any default value for a column.

697−--

698−-- >>> :{

699−-- let

700−-- definition :: Definition

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

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

703−-- definition = alterTable #tab (alterColumn #col dropDefault)

704−-- in renderDefinition definition

705−-- :}

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

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

708−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"

709−

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

711−-- The constraint will be checked immediately, so the table data must satisfy

712−-- the constraint before it can be added.

713−--

714−-- >>> :{

715−-- let

716−-- definition :: Definition

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

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

719−-- definition = alterTable #tab (alterColumn #col setNotNull)

720−-- in renderDefinition definition

721−-- :}

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

723−setNotNull

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

725−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"

726−

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

728−--

729−-- >>> :{

730−-- let

731−-- definition :: Definition

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

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

734−-- definition = alterTable #tab (alterColumn #col dropNotNull)

735−-- in renderDefinition definition

736−-- :}

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

738−dropNotNull

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

740−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"

741−

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

743−-- This will succeed only if each existing entry in the column can be

744−-- converted to the new type by an implicit cast.

745−--

746−-- >>> :{

747−-- let

748−-- definition :: Definition

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

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

751−-- definition =

752−-- alterTable #tab (alterColumn #col (alterType (numeric & hasNotNull)))

753−-- in renderDefinition definition

754−-- :}

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

756−alterType :: ColumnTypeExpression schema ty -> AlterColumn schema ty0 ty

757−alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderColumnTypeExpression ty

758−

759−-- | create a view...

760−-- >>> :{

761−-- let

762−-- definition :: Definition

763−-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]

764−-- '[ "abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])

765−-- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]

766−-- definition =

767−-- createView #bc (select (#b `As` #b :* #c `As` #c :* Nil) (from (table (#abc `As` #abc))))

768−-- in renderDefinition definition

769−-- :}

770−-- "CREATE VIEW \"bc\" AS SELECT \"b\" AS \"b\", \"c\" AS \"c\" FROM \"abc\" AS \"abc\";"

771−createView

772− :: KnownSymbol view

773− => Alias view -- ^ the name of the table to add

774− -> Query schema '[] relation

775− -- ^ query

776− -> Definition schema (Create view ('View relation) schema)

777−createView alias query = UnsafeDefinition $

778− "CREATE" <+> "VIEW" <+> renderAlias alias <+> "AS"

779− <+> renderQuery query <> ";"

780−

781−dropView

782− :: Has view schema ('View v)

783− => Alias view -- ^ view to remove

784− -> Definition schema (Drop view schema)

785−dropView v = UnsafeDefinition $ "DROP VIEW" <+> renderAlias v <> ";"

786−

787−createTypeEnum

788− :: (KnownSymbol enum, SOP.All KnownSymbol labels)

789− => Alias enum

790− -> NP PGlabel labels

791− -> Definition schema (Create enum ('Typedef ('PGenum labels)) schema)

792−createTypeEnum enum labels = UnsafeDefinition $

793− "CREATE" <+> "TYPE" <+> renderAlias enum <+> "AS" <+>

794− parenthesized (commaSeparated (renderLabels labels)) <> ";"

795−

796−class

797− ( SOP.IsEnumType hask

798− , SOP.All KnownSymbol (LabelsWith hask)

799− ) => HasPGenum hask where

800− createTypeEnumWith

801− :: KnownSymbol enum

802− => Alias enum

803− -> Definition schema (Create enum ('Typedef (EnumWith hask)) schema)

804− createTypeEnumWith enum = createTypeEnum enum

805− (SOP.hpure label :: NP PGlabel (LabelsWith hask))

806−

807−createTypeComposite

808− :: (KnownSymbol ty, SOP.SListI fields)

809− => Alias ty

810− -> NP (Aliased TypeExpression) fields

811− -> Definition schema (Create ty ('Typedef ('PGcomposite fields)) schema)

812−createTypeComposite ty fields = UnsafeDefinition $

813− "CREATE" <+> "TYPE" <+> renderAlias ty <+> "AS" <+> parenthesized

814− (renderCommaSeparated (renderAliasedAs renderTypeExpression) fields) <> ";"

815−

816−class

817− ( ZipAliased (FieldNamesWith hask) (FieldTypesWith hask)

818− , SOP.All PGTyped (FieldTypesWith hask)

819− ) => HasPGcomposite hask where

820− createTypeCompositeWith

821− :: KnownSymbol ty

822− => Alias ty

823− -> Definition schema (Create ty ( 'Typedef (CompositeWith hask)) schema)

824− createTypeCompositeWith ty = createTypeComposite ty $ zipAs

825− (SOP.hpure Alias :: NP Alias (FieldNamesWith hask))

826− (SOP.hcpure (SOP.Proxy :: SOP.Proxy PGTyped) pgtype

827− :: NP TypeExpression (FieldTypesWith hask))

828−

829−dropType

830− :: Has tydef schema ('Typedef ty)

831− => Alias tydef

832− -> Definition schema (Drop tydef schema)

833−dropType tydef = UnsafeDefinition $ "DROP" <+> "TYPE" <+> renderAlias tydef <> ";"

834−

835−-- | `ColumnTypeExpression`s are used in `createTable` commands.

836−newtype ColumnTypeExpression (schema :: SchemaType) (ty :: ColumnType)

837− = UnsafeColumnTypeExpression { renderColumnTypeExpression :: ByteString }

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

839−

840−instance (Has alias schema ('Typedef ty))

841− => IsLabel alias (ColumnTypeExpression schema ('NoDef :=> 'NotNull ty)) where

842− fromLabel = UnsafeColumnTypeExpression (renderAlias (fromLabel @alias))

843−

844−hasNull

845− :: TypeExpression ty

846− -> ColumnTypeExpression schema ('NoDef :=> 'Null ty)

847−hasNull ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NULL"

848−

849−-- | used in `createTable` commands as a column constraint to ensure

850−-- @NULL@ is not present

851−hasNotNull

852− :: TypeExpression ty

853− -> ColumnTypeExpression schema (def :=> 'NotNull ty)

854−hasNotNull ty = UnsafeColumnTypeExpression $ renderTypeExpression ty <+> "NOT NULL"

855−

856−-- | used in `createTable` commands as a column constraint to give a default

857−default_

858− :: Expression '[] 'Ungrouped '[] ty

859− -> ColumnTypeExpression schema ('NoDef :=> ty)

860− -> ColumnTypeExpression schema ('Def :=> ty)

861−default_ x ty = UnsafeColumnTypeExpression $

862− renderColumnTypeExpression ty <+> "DEFAULT" <+> renderExpression x

863−

864−-- | not a true type, but merely a notational convenience for creating

865−-- unique identifier columns with type `'PGint2`

866−serial2, smallserial

867− :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint2)

868−serial2 = UnsafeColumnTypeExpression "serial2"

869−smallserial = UnsafeColumnTypeExpression "smallserial"

870−-- | not a true type, but merely a notational convenience for creating

871−-- unique identifier columns with type `'PGint4`

872−serial4, serial

873− :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint4)

874−serial4 = UnsafeColumnTypeExpression "serial4"

875−serial = UnsafeColumnTypeExpression "serial"

876−-- | not a true type, but merely a notational convenience for creating

877−-- unique identifier columns with type `'PGint8`

878−serial8, bigserial

879− :: ColumnTypeExpression schema ('Def :=> 'NotNull 'PGint8)

880−serial8 = UnsafeColumnTypeExpression "serial8"

881−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+355−1116

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

30−module Squeal.PostgreSQL.Expression

33+module Squeal.PostgreSQL.Expression

3134 ( -- * Expression

32− Expression (UnsafeExpression, renderExpression)

33− , HasParameter (param)

34− -- ** Null

35− , null_

36− , notNull

37− , coalesce

38− , fromNull

39− , isNull

40− , isNotNull

41− , matchNull

42− , nullIf

43− -- ** Arrays, Enums, Composites

44− , array

45− , row

46− -- ** Functions

47− , unsafeBinaryOp

48− , unsafeUnaryOp

35+ Expression (..)

36+ , Expr

37+ , type (-->)

38+ , FunctionDB

4939 , unsafeFunction

50− , atan2_

51− , cast

52− , quot_

53− , rem_

54− , trunc

55− , round_

56− , ceiling_

57− , greatest

58− , least

59− -- ** Conditions

60− , Condition

61− , true

62− , false

63− , not_

64− , (.&&)

65− , (.||)

66− , caseWhenThenElse

67− , ifThenElse

68− , (.==)

69− , (./=)

70− , (.>=)

71− , (.<)

72− , (.<=)

73− , (.>)

74− -- ** Time

75− , currentDate

76− , currentTime

77− , currentTimestamp

78− , localTime

79− , localTimestamp

80− -- ** Text

81− , lower

82− , upper

83− , charLength

84− , like

85− -- ** Aggregation

86− , unsafeAggregate, unsafeAggregateDistinct

87− , sum_, sumDistinct

88− , PGAvg (avg, avgDistinct)

89− , bitAnd, bitOr, boolAnd, boolOr

90− , bitAndDistinct, bitOrDistinct, boolAndDistinct, boolOrDistinct

91− , countStar

92− , count, countDistinct

93− , every, everyDistinct

94− , max_, maxDistinct, min_, minDistinct

95− -- * Tables

96− , Table (UnsafeTable, renderTable)

97− , View (UnsafeView, renderView)

98− -- * Types

99− , TypeExpression (UnsafeTypeExpression, renderTypeExpression)

100− , PGTyped (pgtype)

101− , bool

102− , int2

103− , smallint

104− , int4

105− , int

106− , integer

107− , int8

108− , bigint

109− , numeric

110− , float4

111− , real

112− , float8

113− , doublePrecision

114− , text

115− , char

116− , character

117− , varchar

118− , characterVarying

119− , bytea

120− , timestamp

121− , timestampWithTimeZone

122− , date

123− , time

124− , timeWithTimeZone

125− , interval

126− , uuid

127− , inet

128− , json

129− , jsonb

130− , vararray

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

13257 -- * Re-export

13358 , (&)

134− , NP ((:*), Nil)

59+ , K (..)

60+ , unK

13561 ) where

13662

13763import Control.Category

13864import Control.DeepSeq

13965import Data.ByteString (ByteString)

14066import Data.Function ((&))

141−import Data.Semigroup

142−import Data.Ratio

67+import Data.Semigroup hiding (All)

14368import Data.String

144−import Generics.SOP hiding (from)

69+import Generics.SOP hiding (All, from)

14570import GHC.OverloadedLabels

14671import GHC.TypeLits

72+import Numeric

14773import Prelude hiding (id, (.))

14874

14975import qualified GHC.Generics as GHC

15076

77+import Squeal.PostgreSQL.Alias

78+import Squeal.PostgreSQL.List

15179import Squeal.PostgreSQL.Render

15280import Squeal.PostgreSQL.Schema

15381

82+-- $setup

83+-- >>> import Squeal.PostgreSQL

84+

15485{-----------------------------------------

15586column expressions

15687-----------------------------------------}

15788

15889{- | `Expression`s are used in a variety of contexts,

159−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,

16092as new column values in `Squeal.PostgreSQL.Manipulation.insertRow` or

16193`Squeal.PostgreSQL.Manipulation.update`,

162−or in search `Condition`s in a number of commands.

94+or in search `Squeal.PostgreSQL.Logic.Condition`s in a number of commands.

16395

16496The expression syntax allows the calculation of

16597values from primitive expression using arithmetic, logical,

16698and 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`.

167113-}

168114newtype Expression

169− (relations :: RelationsType)

170− (grouping :: Grouping)

115+ (outer :: FromType)

116+ (commons :: FromType)

117+ (grp :: Grouping)

118+ (schemas :: SchemasType)

171119 (params :: [NullityType])

120+ (from :: FromType)

172121 (ty :: NullityType)

173122 = UnsafeExpression { renderExpression :: ByteString }

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

175−

176−{- | A `HasParameter` constraint is used to indicate a value that is

177−supplied externally to a SQL statement.

178−`Squeal.PostgreSQL.PQ.manipulateParams`,

179−`Squeal.PostgreSQL.PQ.queryParams` and

180−`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values

181−separately from the SQL command string, in which case `param`s are used to

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

183181-}

184−class (PGTyped (PGTypeOf ty), KnownNat n) => HasParameter

185− (n :: Nat)

186− (params :: [NullityType])

187− (ty :: NullityType)

188− | n params -> ty where

189− param :: Expression relations grouping params ty

190− param = UnsafeExpression $ parenthesized $

191− "$" <> renderNat (Proxy @n) <+> "::"

192− <+> renderTypeExpression (pgtype @(PGTypeOf ty))

193−instance {-# OVERLAPPING #-} PGTyped (PGTypeOf ty1)

194− => HasParameter 1 (ty1:tys) ty1

195−instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)

196− => HasParameter n (ty' : params) ty

197−

198−instance (HasUnique relation relations columns, Has column columns ty)

199− => IsLabel column (Expression relations 'Ungrouped params ty) where

200− fromLabel = UnsafeExpression $ renderAlias (Alias @column)

201−

202−instance (HasUnique relation relations columns, Has column columns ty)

203− => IsLabel column

204− (Aliased (Expression relations 'Ungrouped params) (column ::: ty)) where

205− fromLabel = fromLabel @column `As` Alias @column

206−

207−instance (HasUnique relation relations columns, Has column columns ty)

208− => IsLabel column

209− (NP (Aliased (Expression relations 'Ungrouped params)) '[column ::: ty]) where

210− fromLabel = fromLabel @column :* Nil

211−

212−instance (Has relation relations columns, Has column columns ty)

213− => IsQualified relation column (Expression relations 'Ungrouped params ty) where

214− relation ! column = UnsafeExpression $

215− renderAlias relation <> "." <> renderAlias column

216−

217−instance (Has relation relations columns, Has column columns ty)

218− => IsQualified relation column

219− (Aliased (Expression relations 'Ungrouped params) (column ::: ty)) where

220− relation ! column = relation ! column `As` column

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

221245

222−instance (Has relation relations columns, Has column columns ty)

223− => IsQualified relation column

224− (NP (Aliased (Expression relations 'Ungrouped params)) '[column ::: ty]) where

225− relation ! column = relation ! column :* Nil

226−

227246instance

228− ( HasUnique relation relations columns

229− , Has column columns ty

230− , GroupedBy relation column bys

231− ) => IsLabel column

232− (Expression relations ('Grouped bys) params ty) where

233− fromLabel = UnsafeExpression $ renderAlias (Alias @column)

234−

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)

235253instance

236− ( Has relation relations columns

237− , Has column columns ty

238− , GroupedBy relation column bys

239− ) => IsQualified relation column

240− (Expression relations ('Grouped bys) params ty) where

241− relation ! column = UnsafeExpression $

242− renderAlias relation <> "." <> renderAlias column

243−

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

244261instance

245− ( Has relation relations columns

246− , Has column columns ty

247− , GroupedBy relation column bys

248− ) => IsQualified relation column

249− (Aliased (Expression relations ('Grouped bys) params)

250− (column ::: ty)) where

251− relation ! column = relation ! column `As` column

252−

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

253269instance

254− ( Has relation relations columns

255− , Has column columns ty

256− , GroupedBy relation column bys

257− ) => IsQualified relation column

258− ( NP (Aliased (Expression relations ('Grouped bys) params))

259− '[column ::: ty]) where

260− relation ! column = relation ! column :* Nil

261−

262−-- | analagous to `Nothing`

263−--

264−-- >>> renderExpression $ null_

265−-- "NULL"

266−null_ :: Expression rels grouping params ('Null ty)

267−null_ = UnsafeExpression "NULL"

268−

269−-- | analagous to `Just`

270−--

271−-- >>> renderExpression $ notNull true

272−-- "TRUE"

273−notNull

274− :: Expression rels grouping params ('NotNull ty)

275− -> Expression rels grouping params ('Null ty)

276−notNull = UnsafeExpression . renderExpression

277−

278−-- | return the leftmost value which is not NULL

279−--

280−-- >>> renderExpression $ coalesce [null_, notNull true] false

281−-- "COALESCE(NULL, TRUE, FALSE)"

282−coalesce

283− :: [Expression relations grouping params ('Null ty)]

284− -- ^ @NULL@s may be present

285− -> Expression relations grouping params ('NotNull ty)

286− -- ^ @NULL@ is absent

287− -> Expression relations grouping params ('NotNull ty)

288−coalesce nullxs notNullx = UnsafeExpression $

289− "COALESCE" <> parenthesized (commaSeparated

290− ((renderExpression <$> nullxs) <> [renderExpression notNullx]))

291−

292−-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@

293−--

294−-- >>> renderExpression $ fromNull true null_

295−-- "COALESCE(NULL, TRUE)"

296−fromNull

297− :: Expression relations grouping params ('NotNull ty)

298− -- ^ what to convert @NULL@ to

299− -> Expression relations grouping params ('Null ty)

300− -> Expression relations grouping params ('NotNull ty)

301−fromNull notNullx nullx = coalesce [nullx] notNullx

302−

303−-- | >>> renderExpression $ null_ & isNull

304−-- "NULL IS NULL"

305−isNull

306− :: Expression relations grouping params ('Null ty)

307− -- ^ possibly @NULL@

308− -> Condition relations grouping params

309−isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL"

310−

311−-- | >>> renderExpression $ null_ & isNotNull

312−-- "NULL IS NOT NULL"

313−isNotNull

314− :: Expression relations grouping params ('Null ty)

315− -- ^ possibly @NULL@

316− -> Condition relations grouping params

317−isNotNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL"

318−

319−-- | analagous to `maybe` using @IS NULL@

320−--

321−-- >>> renderExpression $ matchNull true not_ null_

322−-- "CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END"

323−matchNull

324− :: Expression relations grouping params (nullty)

325− -- ^ what to convert @NULL@ to

326− -> ( Expression relations grouping params ('NotNull ty)

327− -> Expression relations grouping params (nullty) )

328− -- ^ function to perform when @NULL@ is absent

329− -> Expression relations grouping params ('Null ty)

330− -> Expression relations grouping params (nullty)

331−matchNull y f x = ifThenElse (isNull x) y

332− (f (UnsafeExpression (renderExpression x)))

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

333277

334−-- | right inverse to `fromNull`, if its arguments are equal then

335−-- `nullIf` gives @NULL@.

336−--

337−-- >>> :set -XTypeApplications -XDataKinds

338−-- >>> renderExpression @_ @_ @'[_] $ fromNull false (nullIf false (param @1))

339−-- "COALESCE(NULL IF (FALSE, ($1 :: bool)), FALSE)"

340−nullIf

341− :: Expression relations grouping params ('NotNull ty)

342− -- ^ @NULL@ is absent

343− -> Expression relations grouping params ('NotNull ty)

344− -- ^ @NULL@ is absent

345− -> Expression relations grouping params ('Null ty)

346−nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized

347− (renderExpression x <> ", " <> renderExpression y)

348−

349−-- | >>> renderExpression $ array [null_, notNull false, notNull true]

350−-- "ARRAY[NULL, FALSE, TRUE]"

351−array

352− :: [Expression relations grouping params ('Null ty)]

353− -- ^ array elements

354− -> Expression relations grouping params (nullity ('PGvararray ty))

355−array xs = UnsafeExpression $

356− "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]"

278+instance

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

286+instance

287+ ( Has tab (Join outer from) row

288+ , Has col row ty

289+ , GroupedBy tab col bys

290+ , tys ~ '[ty]

291+ ) => IsQualified tab col

292+ (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where

293+ tab ! col = tab ! col :* Nil

294+instance

295+ ( Has tab (Join outer from) row

296+ , Has col row ty

297+ , GroupedBy tab col bys

298+ , column ~ (col ::: ty)

299+ ) => IsQualified tab col

300+ (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where

301+ tab ! col = tab ! col `As` col

302+instance

303+ ( Has tab (Join outer from) row

304+ , Has col row ty

305+ , GroupedBy tab col bys

306+ , columns ~ '[col ::: ty]

307+ ) => IsQualified tab col

308+ (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where

309+ tab ! col = tab ! col :* Nil

357310

358311instance (KnownSymbol label, label `In` labels) => IsPGlabel label

359− (Expression relations grouping params (nullity ('PGenum labels))) where

360− label = UnsafeExpression $ renderLabel (PGlabel @label)

361−

362−row

363− :: (SListI (Nulls fields))

364− => NP (Aliased (Expression relation grouping params)) (Nulls fields)

365− -> Expression relation grouping params (nullity ('PGcomposite fields))

366−row exprs = UnsafeExpression $ "ROW" <> parenthesized

367− (renderCommaSeparated (\ (expr `As` _) -> renderExpression expr) exprs)

312+ (Expression outer commons grp schemas params from (null ('PGenum labels))) where

313+ label = UnsafeExpression $ renderSQL (PGlabel @label)

368314

369−instance Has field fields ty => IsLabel field

370− ( Expression relation grouping params (nullity ('PGcomposite fields))

371− -> Expression relation grouping params ('Null ty) ) where

372− fromLabel expr = UnsafeExpression $

373− parenthesized (renderExpression expr) <> "." <>

374− fromString (symbolVal (Proxy @field))

375−

376−instance Semigroup

377− (Expression relations grouping params (nullity ('PGvararray ty))) where

378− (<>) = unsafeBinaryOp "||"

379−

380−instance Monoid

381− (Expression relations grouping params (nullity ('PGvararray ty))) where

382− mempty = array []

383− mappend = (<>)

384−

385−-- | >>> renderExpression @_ @_ @'[_] $ greatest currentTimestamp [param @1]

386−-- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))"

387−greatest

388− :: Expression relations grouping params (nullty)

389− -- ^ needs at least 1 argument

390− -> [Expression relations grouping params (nullty)]

391− -- ^ or more

392− -> Expression relations grouping params (nullty)

393−greatest x xs = UnsafeExpression $ "GREATEST("

394− <> commaSeparated (renderExpression <$> (x:xs)) <> ")"

395−

396−-- | >>> renderExpression $ least currentTimestamp [null_]

397−-- "LEAST(CURRENT_TIMESTAMP, NULL)"

398−least

399− :: Expression relations grouping params (nullty)

400− -- ^ needs at least 1 argument

401− -> [Expression relations grouping params (nullty)]

402− -- ^ or more

403− -> Expression relations grouping params (nullty)

404−least x xs = UnsafeExpression $ "LEAST("

405− <> commaSeparated (renderExpression <$> (x:xs)) <> ")"

406−

407−-- | >>> renderExpression $ unsafeBinaryOp "OR" true false

408−-- "(TRUE OR FALSE)"

409−unsafeBinaryOp

410− :: ByteString

411− -- ^ operator

412− -> Expression relations grouping params (ty0)

413− -> Expression relations grouping params (ty1)

414− -> Expression relations grouping params (ty2)

315+-- | >>> printSQL $ unsafeBinaryOp "OR" true false

316+-- (TRUE OR FALSE)

317+unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2

415318unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $

416− renderExpression x <+> op <+> renderExpression y

417−

418−-- | >>> renderExpression $ unsafeUnaryOp "NOT" true

419−-- "(NOT TRUE)"

420−unsafeUnaryOp

421− :: ByteString

422− -- ^ operator

423− -> Expression relations grouping params (ty0)

424− -> Expression relations grouping params (ty1)

425−unsafeUnaryOp op x = UnsafeExpression $ parenthesized $

426− op <+> renderExpression x

427−

428−-- | >>> renderExpression $ unsafeFunction "f" true

429−-- "f(TRUE)"

430−unsafeFunction

431− :: ByteString

432− -- ^ function

433− -> Expression relations grouping params (xty)

434− -> Expression 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

435355unsafeFunction fun x = UnsafeExpression $

436− fun <> parenthesized (renderExpression x)

437−

438−instance PGNum ty

439− => Num (Expression 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

440380 (+) = unsafeBinaryOp "+"

441381 (-) = unsafeBinaryOp "-"

442382 (*) = unsafeBinaryOp "*"

@@ -447,19 +387,24 @@ instance PGNum ty

447387 . fromString

448388 . show

449389

450−instance (PGNum ty, PGFloating ty) => Fractional

451− (Expression 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

452392 (/) = unsafeBinaryOp "/"

453− fromRational x = fromInteger (numerator x) / fromInteger (denominator x)

393+ fromRational

394+ = UnsafeExpression

395+ . fromString

396+ . ($ "")

397+ . showFFloat Nothing

398+ . fromRat @Double

454399

455−instance (PGNum ty, PGFloating ty) => Floating

456− (Expression 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

457402 pi = UnsafeExpression "pi()"

458403 exp = unsafeFunction "exp"

459404 log = unsafeFunction "ln"

460405 sqrt = unsafeFunction "sqrt"

461406 b ** x = UnsafeExpression $

462− "power(" <> renderExpression b <> ", " <> renderExpression x <> ")"

407+ "power(" <> renderSQL b <> ", " <> renderSQL x <> ")"

463408 logBase b y = log y / log b

464409 sin = unsafeFunction "sin"

465410 cos = unsafeFunction "cos"

@@ -474,760 +419,54 @@ instance (PGNum ty, PGFloating ty) => Floating

474419 acosh x = log (x + sqrt (x*x - 1))

475420 atanh x = log ((1 + x) / (1 - x)) / 2

476421

477−-- | >>> :{

478−-- let

479−-- expression :: Expression relations grouping params (nullity 'PGfloat4)

480−-- expression = atan2_ pi 2

481−-- in renderExpression expression

482−-- :}

483−-- "atan2(pi(), 2)"

484−atan2_

485− :: PGFloating float

486− => Expression relations grouping params (nullity float)

487− -- ^ numerator

488− -> Expression relations grouping params (nullity float)

489− -- ^ denominator

490− -> Expression relations grouping params (nullity float)

491−atan2_ y x = UnsafeExpression $

492− "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"

493−

494−-- When a `cast` is applied to an `Expression` of a known type, it

495−-- represents a run-time type conversion. The cast will succeed only if a

496−-- suitable type conversion operation has been defined.

497−--

498−-- | >>> renderExpression $ true & cast int4

499−-- "(TRUE :: int4)"

500−cast

501− :: TypeExpression ty1

502− -- ^ type to cast as

503− -> Expression relations grouping params (nullity ty0)

504− -- ^ value to convert

505− -> Expression relations grouping params (nullity ty1)

506−cast ty x = UnsafeExpression $ parenthesized $

507− renderExpression x <+> "::" <+> renderTypeExpression ty

508−

509−-- | integer division, truncates the result

510−--

511−-- >>> :{

512−-- let

513−-- expression :: Expression relations grouping params (nullity 'PGint2)

514−-- expression = 5 `quot_` 2

515−-- in renderExpression expression

516−-- :}

517−-- "(5 / 2)"

518−quot_

519− :: PGIntegral int

520− => Expression relations grouping params (nullity int)

521− -- ^ numerator

522− -> Expression relations grouping params (nullity int)

523− -- ^ denominator

524− -> Expression relations grouping params (nullity int)

525−quot_ = unsafeBinaryOp "/"

526−

527−-- | remainder upon integer division

528−--

529−-- >>> :{

530−-- let

531−-- expression :: Expression relations grouping params (nullity 'PGint2)

532−-- expression = 5 `rem_` 2

533−-- in renderExpression expression

534−-- :}

535−-- "(5 % 2)"

536−rem_

537− :: PGIntegral int

538− => Expression relations grouping params (nullity int)

539− -- ^ numerator

540− -> Expression relations grouping params (nullity int)

541− -- ^ denominator

542− -> Expression relations grouping params (nullity int)

543−rem_ = unsafeBinaryOp "%"

544−

545−-- | >>> :{

546−-- let

547−-- expression :: Expression relations grouping params (nullity 'PGfloat4)

548−-- expression = trunc pi

549−-- in renderExpression expression

550−-- :}

551−-- "trunc(pi())"

552−trunc

553− :: PGFloating frac

554− => Expression relations grouping params (nullity frac)

555− -- ^ fractional number

556− -> Expression relations grouping params (nullity frac)

557−trunc = unsafeFunction "trunc"

558−

559−-- | >>> :{

560−-- let

561−-- expression :: Expression relations grouping params (nullity 'PGfloat4)

562−-- expression = round_ pi

563−-- in renderExpression expression

564−-- :}

565−-- "round(pi())"

566−round_

567− :: PGFloating frac

568− => Expression relations grouping params (nullity frac)

569− -- ^ fractional number

570− -> Expression relations grouping params (nullity frac)

571−round_ = unsafeFunction "round"

572−

573−-- | >>> :{

574−-- let

575−-- expression :: Expression relations grouping params (nullity 'PGfloat4)

576−-- expression = ceiling_ pi

577−-- in renderExpression expression

578−-- :}

579−-- "ceiling(pi())"

580−ceiling_

581− :: PGFloating frac

582− => Expression relations grouping params (nullity frac)

583− -- ^ fractional number

584− -> Expression relations grouping params (nullity frac)

585−ceiling_ = unsafeFunction "ceiling"

586−

587−-- | A `Condition` is a boolean valued `Expression`. While SQL allows

588−-- conditions to have @NULL@, Squeal instead chooses to disallow @NULL@,

589−-- forcing one to handle the case of @NULL@ explicitly to produce

590−-- a `Condition`.

591−type Condition relations grouping params =

592− Expression relations grouping params ('NotNull 'PGbool)

593−

594−-- | >>> renderExpression true

595−-- "TRUE"

596−true :: Condition relations grouping params

597−true = UnsafeExpression "TRUE"

598−

599−-- | >>> renderExpression false

600−-- "FALSE"

601−false :: Condition relations grouping params

602−false = UnsafeExpression "FALSE"

603−

604−-- | >>> renderExpression $ not_ true

605−-- "(NOT TRUE)"

606−not_

607− :: Condition relations grouping params

608− -> Condition relations grouping params

609−not_ = unsafeUnaryOp "NOT"

610−

611−-- | >>> renderExpression $ true .&& false

612−-- "(TRUE AND FALSE)"

613−(.&&)

614− :: Condition relations grouping params

615− -> Condition relations grouping params

616− -> Condition relations grouping params

617−(.&&) = unsafeBinaryOp "AND"

618−

619−-- | >>> renderExpression $ true .|| false

620−-- "(TRUE OR FALSE)"

621−(.||)

622− :: Condition relations grouping params

623− -> Condition relations grouping params

624− -> Condition relations grouping params

625−(.||) = unsafeBinaryOp "OR"

626−

627−-- | >>> :{

628−-- let

629−-- expression :: Expression relations grouping params (nullity 'PGint2)

630−-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3

631−-- in renderExpression expression

632−-- :}

633−-- "CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END"

634−caseWhenThenElse

635− :: [ ( Condition relations grouping params

636− , Expression relations grouping params (ty)

637− ) ]

638− -- ^ whens and thens

639− -> Expression relations grouping params (ty)

640− -- ^ else

641− -> Expression relations grouping params (ty)

642−caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat

643− [ "CASE"

644− , mconcat

645− [ mconcat

646− [ " WHEN ", renderExpression when_

647− , " THEN ", renderExpression then_

648− ]

649− | (when_,then_) <- whenThens

650− ]

651− , " ELSE ", renderExpression else_

652− , " END"

653− ]

654−

655−-- | >>> :{

656−-- let

657−-- expression :: Expression relations grouping params (nullity 'PGint2)

658−-- expression = ifThenElse true 1 0

659−-- in renderExpression expression

660−-- :}

661−-- "CASE WHEN TRUE THEN 1 ELSE 0 END"

662−ifThenElse

663− :: Condition relations grouping params

664− -> Expression relations grouping params (ty) -- ^ then

665− -> Expression relations grouping params (ty) -- ^ else

666− -> Expression relations grouping params (ty)

667−ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_

668−

669−-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`

670−-- will produce @NULL@s if one of their arguments is @NULL@.

671−--

672−-- >>> renderExpression $ notNull true .== null_

673−-- "(TRUE = NULL)"

674−(.==)

675− :: Expression relations grouping params (nullity ty) -- ^ lhs

676− -> Expression relations grouping params (nullity ty) -- ^ rhs

677− -> Expression relations grouping params (nullity 'PGbool)

678−(.==) = unsafeBinaryOp "="

679−infix 4 .==

680−

681−-- | >>> renderExpression $ notNull true ./= null_

682−-- "(TRUE <> NULL)"

683−(./=)

684− :: Expression relations grouping params (nullity ty) -- ^ lhs

685− -> Expression relations grouping params (nullity ty) -- ^ rhs

686− -> Expression relations grouping params (nullity 'PGbool)

687−(./=) = unsafeBinaryOp "<>"

688−infix 4 ./=

689−

690−-- | >>> renderExpression $ notNull true .>= null_

691−-- "(TRUE >= NULL)"

692−(.>=)

693− :: Expression relations grouping params (nullity ty) -- ^ lhs

694− -> Expression relations grouping params (nullity ty) -- ^ rhs

695− -> Expression relations grouping params (nullity 'PGbool)

696−(.>=) = unsafeBinaryOp ">="

697−infix 4 .>=

698−

699−-- | >>> renderExpression $ notNull true .< null_

700−-- "(TRUE < NULL)"

701−(.<)

702− :: Expression relations grouping params (nullity ty) -- ^ lhs

703− -> Expression relations grouping params (nullity ty) -- ^ rhs

704− -> Expression relations grouping params (nullity 'PGbool)

705−(.<) = unsafeBinaryOp "<"

706−infix 4 .<

707−

708−-- | >>> renderExpression $ notNull true .<= null_

709−-- "(TRUE <= NULL)"

710−(.<=)

711− :: Expression relations grouping params (nullity ty) -- ^ lhs

712− -> Expression relations grouping params (nullity ty) -- ^ rhs

713− -> Expression relations grouping params (nullity 'PGbool)

714−(.<=) = unsafeBinaryOp "<="

715−infix 4 .<=

716−

717−-- | >>> renderExpression $ notNull true .> null_

718−-- "(TRUE > NULL)"

719−(.>)

720− :: Expression relations grouping params (nullity ty) -- ^ lhs

721− -> Expression relations grouping params (nullity ty) -- ^ rhs

722− -> Expression relations grouping params (nullity 'PGbool)

723−(.>) = unsafeBinaryOp ">"

724−infix 4 .>

725−

726−-- | >>> renderExpression currentDate

727−-- "CURRENT_DATE"

728−currentDate

729− :: Expression relations grouping params (nullity 'PGdate)

730−currentDate = UnsafeExpression "CURRENT_DATE"

731−

732−-- | >>> renderExpression currentTime

733−-- "CURRENT_TIME"

734−currentTime

735− :: Expression relations grouping params (nullity 'PGtimetz)

736−currentTime = UnsafeExpression "CURRENT_TIME"

737−

738−-- | >>> renderExpression currentTimestamp

739−-- "CURRENT_TIMESTAMP"

740−currentTimestamp

741− :: Expression relations grouping params (nullity 'PGtimestamptz)

742−currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"

743−

744−-- | >>> renderExpression localTime

745−-- "LOCALTIME"

746−localTime

747− :: Expression relations grouping params (nullity 'PGtime)

748−localTime = UnsafeExpression "LOCALTIME"

749−

750−-- | >>> renderExpression localTimestamp

751−-- "LOCALTIMESTAMP"

752−localTimestamp

753− :: Expression relations grouping params (nullity 'PGtimestamp)

754−localTimestamp = UnsafeExpression "LOCALTIMESTAMP"

755−

756−{-----------------------------------------

757−text

758−-----------------------------------------}

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)

759438

760439instance IsString

761− (Expression relations grouping params (nullity 'PGtext)) where

440+ (Expression outer commons grp schemas params from (null 'PGtext)) where

762441 fromString str = UnsafeExpression $

763442 "E\'" <> fromString (escape =<< str) <> "\'"

764− where

765− escape = \case

766− '\NUL' -> "\\0"

767− '\'' -> "''"

768− '"' -> "\\\""

769− '\b' -> "\\b"

770− '\n' -> "\\n"

771− '\r' -> "\\r"

772− '\t' -> "\\t"

773− '\\' -> "\\\\"

774− 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) <> "\'"

775451

776452instance Semigroup

777− (Expression 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

778463 (<>) = unsafeBinaryOp "||"

779464

780465instance Monoid

781− (Expression 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

782471 mempty = fromString ""

783472 mappend = (<>)

784−

785−-- | >>> renderExpression $ lower "ARRRGGG"

786−-- "lower(E'ARRRGGG')"

787−lower

788− :: Expression relations grouping params (nullity 'PGtext)

789− -- ^ string to lower case

790− -> Expression relations grouping params (nullity 'PGtext)

791−lower = unsafeFunction "lower"

792−

793−-- | >>> renderExpression $ upper "eeee"

794−-- "upper(E'eeee')"

795−upper

796− :: Expression relations grouping params (nullity 'PGtext)

797− -- ^ string to upper case

798− -> Expression relations grouping params (nullity 'PGtext)

799−upper = unsafeFunction "upper"

800−

801−-- | >>> renderExpression $ charLength "four"

802−-- "char_length(E'four')"

803−charLength

804− :: Expression relations grouping params (nullity 'PGtext)

805− -- ^ string to measure

806− -> Expression relations grouping params (nullity 'PGint4)

807−charLength = unsafeFunction "char_length"

808−

809−-- | The `like` expression returns true if the @string@ matches

810−-- the supplied @pattern@. If @pattern@ does not contain percent signs

811−-- or underscores, then the pattern only represents the string itself;

812−-- in that case `like` acts like the equals operator. An underscore (_)

813−-- in pattern stands for (matches) any single character; a percent sign (%)

814−-- matches any sequence of zero or more characters.

815−--

816−-- >>> renderExpression $ "abc" `like` "a%"

817−-- "(E'abc' LIKE E'a%')"

818−like

819− :: Expression relations grouping params (nullity 'PGtext)

820− -- ^ string

821− -> Expression relations grouping params (nullity 'PGtext)

822− -- ^ pattern

823− -> Expression relations grouping params (nullity 'PGbool)

824−like = unsafeBinaryOp "LIKE"

825−

826−{-----------------------------------------

827−aggregation

828−-----------------------------------------}

829−

830−-- | escape hatch to define aggregate functions

831−unsafeAggregate

832− :: ByteString -- ^ aggregate function

833− -> Expression relations 'Ungrouped params (xty)

834− -> Expression relations ('Grouped bys) params (yty)

835−unsafeAggregate fun x = UnsafeExpression $ mconcat

836− [fun, "(", renderExpression x, ")"]

837−

838−-- | escape hatch to define aggregate functions over distinct values

839−unsafeAggregateDistinct

840− :: ByteString -- ^ aggregate function

841− -> Expression relations 'Ungrouped params (xty)

842− -> Expression relations ('Grouped bys) params (yty)

843−unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat

844− [fun, "(DISTINCT ", renderExpression x, ")"]

845−

846−-- | >>> :{

847−-- let

848−-- expression :: Expression '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric)

849−-- expression = sum_ #col

850−-- in renderExpression expression

851−-- :}

852−-- "sum(\"col\")"

853−sum_

854− :: PGNum ty

855− => Expression relations 'Ungrouped params (nullity ty)

856− -- ^ what to sum

857− -> Expression relations ('Grouped bys) params (nullity ty)

858−sum_ = unsafeAggregate "sum"

859−

860−-- | >>> :{

861−-- let

862−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric)

863−-- expression = sumDistinct #col

864−-- in renderExpression expression

865−-- :}

866−-- "sum(DISTINCT \"col\")"

867−sumDistinct

868− :: PGNum ty

869− => Expression relations 'Ungrouped params (nullity ty)

870− -- ^ what to sum

871− -> Expression relations ('Grouped bys) params (nullity ty)

872−sumDistinct = unsafeAggregateDistinct "sum"

873−

874−-- | A constraint for `PGType`s that you can take averages of and the resulting

875−-- `PGType`.

876−class PGAvg ty avg | ty -> avg where

877− avg, avgDistinct

878− :: Expression relations 'Ungrouped params (nullity ty)

879− -- ^ what to average

880− -> Expression relations ('Grouped bys) params (nullity avg)

881− avg = unsafeAggregate "avg"

882− avgDistinct = unsafeAggregateDistinct "avg"

883−instance PGAvg 'PGint2 'PGnumeric

884−instance PGAvg 'PGint4 'PGnumeric

885−instance PGAvg 'PGint8 'PGnumeric

886−instance PGAvg 'PGnumeric 'PGnumeric

887−instance PGAvg 'PGfloat4 'PGfloat8

888−instance PGAvg 'PGfloat8 'PGfloat8

889−instance PGAvg 'PGinterval 'PGinterval

890−

891−-- | >>> :{

892−-- let

893−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

894−-- expression = bitAnd #col

895−-- in renderExpression expression

896−-- :}

897−-- "bit_and(\"col\")"

898−bitAnd

899− :: PGIntegral int

900− => Expression relations 'Ungrouped params (nullity int)

901− -- ^ what to aggregate

902− -> Expression relations ('Grouped bys) params (nullity int)

903−bitAnd = unsafeAggregate "bit_and"

904−

905−-- | >>> :{

906−-- let

907−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

908−-- expression = bitOr #col

909−-- in renderExpression expression

910−-- :}

911−-- "bit_or(\"col\")"

912−bitOr

913− :: PGIntegral int

914− => Expression relations 'Ungrouped params (nullity int)

915− -- ^ what to aggregate

916− -> Expression relations ('Grouped bys) params (nullity int)

917−bitOr = unsafeAggregate "bit_or"

918−

919−-- | >>> :{

920−-- let

921−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

922−-- expression = bitAndDistinct #col

923−-- in renderExpression expression

924−-- :}

925−-- "bit_and(DISTINCT \"col\")"

926−bitAndDistinct

927− :: PGIntegral int

928− => Expression relations 'Ungrouped params (nullity int)

929− -- ^ what to aggregate

930− -> Expression relations ('Grouped bys) params (nullity int)

931−bitAndDistinct = unsafeAggregateDistinct "bit_and"

932−

933−-- | >>> :{

934−-- let

935−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

936−-- expression = bitOrDistinct #col

937−-- in renderExpression expression

938−-- :}

939−-- "bit_or(DISTINCT \"col\")"

940−bitOrDistinct

941− :: PGIntegral int

942− => Expression relations 'Ungrouped params (nullity int)

943− -- ^ what to aggregate

944− -> Expression relations ('Grouped bys) params (nullity int)

945−bitOrDistinct = unsafeAggregateDistinct "bit_or"

946−

947−-- | >>> :{

948−-- let

949−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

950−-- expression = boolAnd #col

951−-- in renderExpression expression

952−-- :}

953−-- "bool_and(\"col\")"

954−boolAnd

955− :: Expression relations 'Ungrouped params (nullity 'PGbool)

956− -- ^ what to aggregate

957− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

958−boolAnd = unsafeAggregate "bool_and"

959−

960−-- | >>> :{

961−-- let

962−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

963−-- expression = boolOr #col

964−-- in renderExpression expression

965−-- :}

966−-- "bool_or(\"col\")"

967−boolOr

968− :: Expression relations 'Ungrouped params (nullity 'PGbool)

969− -- ^ what to aggregate

970− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

971−boolOr = unsafeAggregate "bool_or"

972−

973−-- | >>> :{

974−-- let

975−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

976−-- expression = boolAndDistinct #col

977−-- in renderExpression expression

978−-- :}

979−-- "bool_and(DISTINCT \"col\")"

980−boolAndDistinct

981− :: Expression relations 'Ungrouped params (nullity 'PGbool)

982− -- ^ what to aggregate

983− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

984−boolAndDistinct = unsafeAggregateDistinct "bool_and"

985−

986−-- | >>> :{

987−-- let

988−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

989−-- expression = boolOrDistinct #col

990−-- in renderExpression expression

991−-- :}

992−-- "bool_or(DISTINCT \"col\")"

993−boolOrDistinct

994− :: Expression relations 'Ungrouped params (nullity 'PGbool)

995− -- ^ what to aggregate

996− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

997−boolOrDistinct = unsafeAggregateDistinct "bool_or"

998−

999−-- | A special aggregation that does not require an input

1000−--

1001−-- >>> renderExpression countStar

1002−-- "count(*)"

1003−countStar

1004− :: Expression relations ('Grouped bys) params ('NotNull 'PGint8)

1005−countStar = UnsafeExpression $ "count(*)"

1006−

1007−-- | >>> :{

1008−-- let

1009−-- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)

1010−-- expression = count #col

1011−-- in renderExpression expression

1012−-- :}

1013−-- "count(\"col\")"

1014−count

1015− :: Expression relations 'Ungrouped params ty

1016− -- ^ what to count

1017− -> Expression relations ('Grouped bys) params ('NotNull 'PGint8)

1018−count = unsafeAggregate "count"

1019−

1020−-- | >>> :{

1021−-- let

1022−-- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)

1023−-- expression = countDistinct #col

1024−-- in renderExpression expression

1025−-- :}

1026−-- "count(DISTINCT \"col\")"

1027−countDistinct

1028− :: Expression relations 'Ungrouped params ty

1029− -- ^ what to count

1030− -> Expression relations ('Grouped bys) params ('NotNull 'PGint8)

1031−countDistinct = unsafeAggregateDistinct "count"

1032−

1033−-- | synonym for `boolAnd`

1034−--

1035−-- >>> :{

1036−-- let

1037−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

1038−-- expression = every #col

1039−-- in renderExpression expression

1040−-- :}

1041−-- "every(\"col\")"

1042−every

1043− :: Expression relations 'Ungrouped params (nullity 'PGbool)

1044− -- ^ what to aggregate

1045− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

1046−every = unsafeAggregate "every"

1047−

1048−-- | synonym for `boolAndDistinct`

1049−--

1050−-- >>> :{

1051−-- let

1052−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

1053−-- expression = everyDistinct #col

1054−-- in renderExpression expression

1055−-- :}

1056−-- "every(DISTINCT \"col\")"

1057−everyDistinct

1058− :: Expression relations 'Ungrouped params (nullity 'PGbool)

1059− -- ^ what to aggregate

1060− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

1061−everyDistinct = unsafeAggregateDistinct "every"

1062−

1063−-- | minimum and maximum aggregation

1064−max_, min_, maxDistinct, minDistinct

1065− :: Expression relations 'Ungrouped params (nullity ty)

1066− -- ^ what to aggregate

1067− -> Expression relations ('Grouped bys) params (nullity ty)

1068−max_ = unsafeAggregate "max"

1069−min_ = unsafeAggregate "min"

1070−maxDistinct = unsafeAggregateDistinct "max"

1071−minDistinct = unsafeAggregateDistinct "min"

1072−

1073−{-----------------------------------------

1074−tables

1075−-----------------------------------------}

1076−

1077−-- | A `Table` from a table expression is a way

1078−-- to call a table reference by its alias.

1079−newtype Table

1080− (schema :: SchemaType)

1081− (columns :: RelationType)

1082− = UnsafeTable { renderTable :: ByteString }

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

1084−instance

1085− ( Has alias schema ('Table table)

1086− , relation ~ TableToRelation table

1087− ) => IsLabel alias (Table schema relation) where

1088− fromLabel = UnsafeTable $ renderAlias (Alias @alias)

1089−

1090−-- | A `View` from a table expression is a way

1091−-- to call a table reference by its alias.

1092−newtype View

1093− (schema :: SchemaType)

1094− (columns :: RelationType)

1095− = UnsafeView { renderView :: ByteString }

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

1097−instance

1098− ( Has alias schema ('View columns)

1099− ) => IsLabel alias (View schema columns) where

1100− fromLabel = UnsafeView $ renderAlias (Alias @alias)

1101−

1102−{-----------------------------------------

1103−type expressions

1104−-----------------------------------------}

1105−

1106−-- | `TypeExpression`s are used in `cast`s and `createTable` commands.

1107−newtype TypeExpression (ty :: PGType)

1108− = UnsafeTypeExpression { renderTypeExpression :: ByteString }

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

1110−

1111−-- | logical Boolean (true/false)

1112−bool :: TypeExpression 'PGbool

1113−bool = UnsafeTypeExpression "bool"

1114−-- | signed two-byte integer

1115−int2, smallint :: TypeExpression 'PGint2

1116−int2 = UnsafeTypeExpression "int2"

1117−smallint = UnsafeTypeExpression "smallint"

1118−-- | signed four-byte integer

1119−int4, int, integer :: TypeExpression 'PGint4

1120−int4 = UnsafeTypeExpression "int4"

1121−int = UnsafeTypeExpression "int"

1122−integer = UnsafeTypeExpression "integer"

1123−-- | signed eight-byte integer

1124−int8, bigint :: TypeExpression 'PGint8

1125−int8 = UnsafeTypeExpression "int8"

1126−bigint = UnsafeTypeExpression "bigint"

1127−-- | arbitrary precision numeric type

1128−numeric :: TypeExpression 'PGnumeric

1129−numeric = UnsafeTypeExpression "numeric"

1130−-- | single precision floating-point number (4 bytes)

1131−float4, real :: TypeExpression 'PGfloat4

1132−float4 = UnsafeTypeExpression "float4"

1133−real = UnsafeTypeExpression "real"

1134−-- | double precision floating-point number (8 bytes)

1135−float8, doublePrecision :: TypeExpression 'PGfloat8

1136−float8 = UnsafeTypeExpression "float8"

1137−doublePrecision = UnsafeTypeExpression "double precision"

1138−-- | variable-length character string

1139−text :: TypeExpression 'PGtext

1140−text = UnsafeTypeExpression "text"

1141−-- | fixed-length character string

1142−char, character

1143− :: (KnownNat n, 1 <= n)

1144− => proxy n

1145− -> TypeExpression ('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 ('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 'PGbytea

1158−bytea = UnsafeTypeExpression "bytea"

1159−-- | date and time (no time zone)

1160−timestamp :: TypeExpression 'PGtimestamp

1161−timestamp = UnsafeTypeExpression "timestamp"

1162−-- | date and time, including time zone

1163−timestampWithTimeZone :: TypeExpression 'PGtimestamptz

1164−timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

1165−-- | calendar date (year, month, day)

1166−date :: TypeExpression 'PGdate

1167−date = UnsafeTypeExpression "date"

1168−-- | time of day (no time zone)

1169−time :: TypeExpression 'PGtime

1170−time = UnsafeTypeExpression "time"

1171−-- | time of day, including time zone

1172−timeWithTimeZone :: TypeExpression 'PGtimetz

1173−timeWithTimeZone = UnsafeTypeExpression "time with time zone"

1174−-- | time span

1175−interval :: TypeExpression 'PGinterval

1176−interval = UnsafeTypeExpression "interval"

1177−-- | universally unique identifier

1178−uuid :: TypeExpression 'PGuuid

1179−uuid = UnsafeTypeExpression "uuid"

1180−-- | IPv4 or IPv6 host address

1181−inet :: TypeExpression 'PGinet

1182−inet = UnsafeTypeExpression "inet"

1183−-- | textual JSON data

1184−json :: TypeExpression 'PGjson

1185−json = UnsafeTypeExpression "json"

1186−-- | binary JSON data, decomposed

1187−jsonb :: TypeExpression 'PGjsonb

1188−jsonb = UnsafeTypeExpression "jsonb"

1189−-- | variable length array

1190−vararray

1191− :: TypeExpression pg

1192− -> TypeExpression ('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 pg

1202− -> TypeExpression ('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 (ty :: PGType) where pgtype :: TypeExpression ty

1208−instance PGTyped 'PGbool where pgtype = bool

1209−instance PGTyped 'PGint2 where pgtype = int2

1210−instance PGTyped 'PGint4 where pgtype = int4

1211−instance PGTyped 'PGint8 where pgtype = int8

1212−instance PGTyped 'PGnumeric where pgtype = numeric

1213−instance PGTyped 'PGfloat4 where pgtype = float4

1214−instance PGTyped 'PGfloat8 where pgtype = float8

1215−instance PGTyped 'PGtext where pgtype = text

1216−instance (KnownNat n, 1 <= n)

1217− => PGTyped ('PGchar n) where pgtype = char (Proxy @n)

1218−instance (KnownNat n, 1 <= n)

1219− => PGTyped ('PGvarchar n) where pgtype = varchar (Proxy @n)

1220−instance PGTyped 'PGbytea where pgtype = bytea

1221−instance PGTyped 'PGtimestamp where pgtype = timestamp

1222−instance PGTyped 'PGtimestamptz where pgtype = timestampWithTimeZone

1223−instance PGTyped 'PGdate where pgtype = date

1224−instance PGTyped 'PGtime where pgtype = time

1225−instance PGTyped 'PGtimetz where pgtype = timeWithTimeZone

1226−instance PGTyped 'PGinterval where pgtype = interval

1227−instance PGTyped 'PGuuid where pgtype = uuid

1228−instance PGTyped 'PGjson where pgtype = json

1229−instance PGTyped 'PGjsonb where pgtype = jsonb

1230−instance PGTyped ty => PGTyped ('PGvararray ty) where

1231− pgtype = vararray (pgtype @ty)

1232−instance (KnownNat n, PGTyped ty) => PGTyped ('PGfixarray n ty) where

1233− pgtype = fixarray (Proxy @n) (pgtype @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−346

@@ -11,309 +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

208+:}

209+DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING *

210+

211+delete and using clause:

212+

213+>>> :{

214+type Schema3 =

215+ '[ "tab" ::: 'Table ('[] :=> Columns)

216+ , "other_tab" ::: 'Table ('[] :=> Columns)

217+ , "third_tab" ::: 'Table ('[] :=> Columns) ]

218+:}

219+

220+>>> :{

221+let

222+ manipulation :: Manipulation_ (Public Schema3) () ()

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

181243:}

182−"DELETE FROM \"tab\" WHERE (\"col1\" = \"col2\") RETURNING *"

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 '[] params)) columns -- ^ row to insert

215− -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert

216− -> ConflictClause columns params

217− -- ^ what to do in case of constraint conflict

218− -> ReturningClause 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 '[] 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 '[] params)) columns -- ^ row to insert

245− -> ConflictClause columns params

246− -- ^ what to do in case of constraint conflict

247− -> ReturningClause 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 '[] params)) columns -- ^ row to insert

258− -> [NP (Aliased (ColumnValue '[] 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 '[] 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 columns params

282− -- ^ what to do in case of constraint conflict

283− -> ReturningClause 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− (columns :: RelationType)

309− (params :: [NullityType])

310− (ty :: ColumnType)

311− where

312− Same :: ColumnValue (column ': columns) params ty

313− Default :: ColumnValue columns params ('Def :=> ty)

314− Set

315− :: (forall table. Expression '[table ::: columns] 'Ungrouped params ty)

316− -> ColumnValue 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

317377

318378-- | A `ReturningClause` computes and return value(s) based

319379-- on each row actually inserted, updated or deleted. This is primarily

@@ -321,71 +381,100 @@ data ColumnValue

321381-- serial sequence number. However, any expression using the table's columns

322382-- is allowed. Only rows that were successfully inserted or updated or

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

324−-- but not updated because an `OnConflictDoUpdate` condition was not satisfied,

325−-- the row will not be returned. `ReturningStar` will return all columns

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

327387-- values are desired.

328−data ReturningClause

329− (columns :: ColumnsType)

330− (params :: [NullityType])

331− (results :: RelationType)

332− where

333− ReturningStar

334− :: results ~ ColumnsToRelation columns

335− => ReturningClause columns params results

336− Returning

337− :: rel ~ ColumnsToRelation columns

338− => NP (Aliased (Expression '[table ::: rel] 'Ungrouped params)) results

339− -> ReturningClause columns params results

340−

341−-- | Render a `ReturningClause`.

342−renderReturningClause

343− :: SOP.SListI results

344− => ReturningClause params columns results

345− -> ByteString

346−renderReturningClause = \case

347− ReturningStar -> " RETURNING *"

348− Returning Nil -> ""

349− Returning results -> " RETURNING"

350− <+> 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)

351403

352404-- | A `ConflictClause` specifies an action to perform upon a constraint

353405-- violation. `OnConflictDoRaise` will raise an error.

354−-- `OnConflictDoNothing` simply avoids inserting a row.

355−-- `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

356408-- proposed for insertion.

357−data ConflictClause (columns :: ColumnsType) params where

358− OnConflictDoRaise :: ConflictClause columns params

359− OnConflictDoNothing :: ConflictClause columns params

360− OnConflictDoUpdate

361− :: NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns

362− -> [Condition '[table ::: ColumnsToRelation columns] 'Ungrouped params]

363− -> ConflictClause 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)

364417

365418-- | Render a `ConflictClause`.

366−renderConflictClause

367− :: SOP.SListI columns

368− => ConflictClause 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

369463 -> ByteString

370−renderConflictClause = \case

371− OnConflictDoRaise -> ""

372− OnConflictDoNothing -> " ON CONFLICT DO NOTHING"

373− OnConflictDoUpdate updates whs'

374− -> " ON CONFLICT DO UPDATE SET"

375− <+> renderCommaSeparatedMaybe renderUpdate updates

376− <> case whs' of

377− [] -> ""

378− wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)

379− where

380− renderUpdate

381− :: Aliased (ColumnValue columns params) column

382− -> Maybe ByteString

383− renderUpdate = \case

384− Same `As` _ -> Nothing

385− Default `As` column -> Just $

386− renderAlias column <+> "=" <+> "DEFAULT"

387− Set expression `As` column -> Just $

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

389478

390479{-----------------------------------------

391480UPDATE statements

@@ -395,108 +484,95 @@ UPDATE statements

395484-- in all rows that satisfy the condition.

396485update

397486 :: ( SOP.SListI columns

398− , SOP.SListI results

487+ , SOP.SListI row1

488+ , Has sch schemas schema

399489 , Has tab schema ('Table table)

400− , columns ~ TableToColumns table )

401− => Alias tab -- ^ table to update

402− -> NP (Aliased (ColumnValue (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

403496 -- ^ modified values to replace old values

404− -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params

497+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]

405498 -- ^ condition under which to perform update on a row

406− -> ReturningClause columns params results -- ^ results to return

407− -> Manipulation schema params results

499+ -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return

500+ -> Manipulation commons schemas params row1

408501update tab columns wh returning = UnsafeManipulation $

409502 "UPDATE"

410− <+> renderAlias tab

503+ <+> renderSQL tab

411504 <+> "SET"

412− <+> renderCommaSeparatedMaybe renderUpdate columns

413− <+> "WHERE" <+> renderExpression wh

414− <> renderReturningClause returning

415− where

416− renderUpdate

417− :: Aliased (ColumnValue columns params) column

418− -> Maybe ByteString

419− renderUpdate = \case

420− Same `As` _ -> Nothing

421− Default `As` column -> Just $

422− renderAlias column <+> "=" <+> "DEFAULT"

423− Set expression `As` column -> Just $

424− renderAlias column <+> "=" <+> renderExpression expression

505+ <+> renderCommaSeparated renderUpdate columns

506+ <+> "WHERE" <+> renderSQL wh

507+ <> renderSQL returning

425508

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

427510update_

428511 :: ( SOP.SListI columns

512+ , Has sch schemas schema

429513 , Has tab schema ('Table table)

430− , columns ~ TableToColumns table )

431− => Alias tab -- ^ table to update

432− -> NP (Aliased (ColumnValue (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

433520 -- ^ modified values to replace old values

434− -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params

521+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]

435522 -- ^ condition under which to perform update on a row

436− -> Manipulation schema params '[]

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

438525

439526{-----------------------------------------

440527DELETE statements

441528-----------------------------------------}

442529

443−-- | 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.

444547deleteFrom

445− :: ( SOP.SListI results

548+ :: ( SOP.SListI row1

549+ , Has sch schemas schema

446550 , Has tab schema ('Table table)

551+ , row0 ~ TableToRow table

447552 , columns ~ TableToColumns table )

448− => Alias tab -- ^ table to delete from

449− -> Condition '[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)

450556 -- ^ condition under which to delete a row

451− -> ReturningClause columns params results -- ^ results to return

452− -> Manipulation schema params results

453−deleteFrom tab wh returning = UnsafeManipulation $

454− "DELETE FROM" <+> renderAlias tab

455− <+> "WHERE" <+> renderExpression wh

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

457567

458568-- | Delete rows returning `Nil`.

459569deleteFrom_

460− :: ( Has tab schema ('Table table)

570+ :: ( Has sch schemas schema

571+ , Has tab schema ('Table table)

572+ , row ~ TableToRow table

461573 , columns ~ TableToColumns table )

462− => Alias tab -- ^ table to delete from

463− -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params

574+ => QualifiedAlias sch tab -- ^ table to delete from

575+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]

464576 -- ^ condition under which to delete a row

465− -> Manipulation schema params '[]

466−deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil)

467−

468−{-----------------------------------------

469−WITH statements

470−-----------------------------------------}

471−

472−-- | `with` provides a way to write auxiliary statements for use in a larger statement.

473−-- These statements, which are often referred to as Common Table Expressions or CTEs,

474−-- can be thought of as defining temporary tables that exist just for one statement.

475−--

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

477−--

478−-- >>> :{

479−-- let

480−-- manipulation :: Manipulation '["products" ::: 'Table ProductsTable, "products_deleted" ::: 'Table ProductsTable] '[ 'NotNull 'PGdate] '[]

481−-- manipulation = with

482−-- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rows :* Nil)

483−-- (insertQuery_ #products_deleted (selectStar (from (view (#deleted_rows `As` #t)))))

484−-- in renderManipulation manipulation

485−-- :}

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

487−with

488− :: SOP.SListI commons

489− => NP (Aliased (Manipulation schema params)) commons

490− -- ^ common table expressions

491− -> Manipulation (With commons schema) params results

492− -> Manipulation schema params results

493−with commons manipulation = UnsafeManipulation $

494− "WITH" <+> renderCommaSeparated renderCommon commons

495− <+> renderManipulation manipulation

496− where

497− renderCommon

498− :: Aliased (Manipulation schema params) common

499− -> ByteString

500− renderCommon (common `As` alias) =

501− renderAlias alias <+> "AS" <+>

502− 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+348−216

@@ -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 & hasNotNull) `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 & hasNotNull) `As` #user_id :*

56− (text & hasNull) `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 & hasNotNull) `As` #name :*

289− (timestampWithTimeZone & hasNotNull & 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 ] '[]

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

348+ (timestampWithTimeZone & notNullable & default_ currentTimestamp)

349+ `as` #executed_at )

350+ ( unique #name `as` #migrations_unique_name )

351+

352+-- | Inserts a `Migration` into the `MigrationsTable`, returning

353+-- the time at which it was inserted.

354+insertMigration :: Manipulation_ MigrationsSchemas (Only Text) ()

355+insertMigration = insertInto_ #schema_migrations

356+ (Values_ (Set (param @1) `as` #name :* Default `as` #executed_at))

357+

358+-- | Deletes a `Migration` from the `MigrationsTable`, returning

359+-- the time at which it was inserted.

360+deleteMigration :: Manipulation_ MigrationsSchemas (Only Text) ()

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+717−451

@@ -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,68 +9,81 @@ Squeal queries.

99-}

1010

1111{-# LANGUAGE

12− DeriveGeneric

12+ ConstraintKinds

13+ , DeriveGeneric

14+ , FlexibleContexts

15+ , FlexibleInstances

1316 , GADTs

1417 , GeneralizedNewtypeDeriving

1518 , LambdaCase

19+ , MultiParamTypeClasses

20+ , OverloadedLabels

1621 , OverloadedStrings

22+ , QuantifiedConstraints

23+ , ScopedTypeVariables

1724 , StandaloneDeriving

25+ , TypeApplications

26+ , TypeFamilies

1827 , TypeInType

1928 , TypeOperators

20−#-}

29+ , RankNTypes

30+ , UndecidableInstances

31+ #-}

2132

2233module Squeal.PostgreSQL.Query

2334 ( -- * Queries

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

2549 , union

2650 , unionAll

2751 , intersect

2852 , intersectAll

2953 , except

3054 , exceptAll

31− -- * Select

32− , select

33− , selectDistinct

34− , selectStar

35− , selectDistinctStar

36− , selectDotStar

37− , selectDistinctDotStar

38− , values

55+ -- ** With

56+ , With (..)

57+ , CommonTableExpression (..)

58+ , withRecursive

3959 -- * Table Expressions

4060 , TableExpression (..)

41− , renderTableExpression

4261 , from

4362 , where_

44− , group

63+ , groupBy

4564 , having

46− , orderBy

4765 , limit

4866 , offset

49− -- * From

67+ -- * From Clauses

5068 , FromClause (..)

5169 , table

5270 , subquery

5371 , view

72+ , common

5473 , crossJoin

5574 , innerJoin

5675 , leftOuterJoin

5776 , rightOuterJoin

5877 , fullOuterJoin

5978 -- * Grouping

60− , By (By, By2)

61− , renderBy

62− , GroupByClause (NoGroups, Group)

63− , renderGroupByClause

64− , HavingClause (NoHaving, Having)

65− , renderHavingClause

66− -- * Sorting

67− , SortExpression (..)

68− , renderSortExpression

79+ , By (..)

80+ , GroupByClause (..)

81+ , HavingClause (..)

6982 ) where

7083

7184import Control.DeepSeq

7285import Data.ByteString (ByteString)

73−import Data.Monoid hiding (All)

86+import Data.Kind (Type)

7487import Data.String

7588import Data.Word

7689import Generics.SOP hiding (from)

@@ -78,358 +91,555 @@ import GHC.TypeLits

7891

7992import qualified GHC.Generics as GHC

8093

94+import Squeal.PostgreSQL.Alias

8195import 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

82101import Squeal.PostgreSQL.Render

83102import Squeal.PostgreSQL.Schema

84103

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+

85133{- |

86−The process of retrieving or the command to retrieve data from a database

87−is called a `Query`. The `select`, `selectStar`, `selectDotStar`,

88−`selectDistinct`, `selectDistinctStar` and `selectDistinctDotStar` commands

89−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+:}

90155

91156simple query:

92157

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

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

93160>>> :{

94161let

95− query :: Query

96− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

97− '[]

98− '["col" ::: 'Null 'PGint4]

99− query = selectStar (from (table (#tab `As` #t)))

100−in renderQuery query

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

163+ query = select Star (from (table #tab))

164+in printSQL query

101165:}

102−"SELECT * FROM \"tab\" AS \"t\""

166+SELECT * FROM "tab" AS "tab"

103167

104168restricted query:

105169

106170>>> :{

107171let

108− query :: Query

109− '[ "tab" ::: 'Table ('[] :=>

110− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

111− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]

112− '[]

113− '[ "sum" ::: 'NotNull 'PGint4

114− , "col1" ::: 'NotNull 'PGint4 ]

115− query =

116− select

117− ((#col1 + #col2) `As` #sum :* #col1 :* Nil)

118− ( from (table (#tab `As` #t))

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

173+ query =

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

175+ ( from (table #tab)

119176 & where_ (#col1 .> #col2)

120177 & where_ (#col2 .> 0) )

121−in renderQuery query

178+in printSQL query

122179:}

123−"SELECT (\"col1\" + \"col2\") AS \"sum\", \"col1\" AS \"col1\" FROM \"tab\" AS \"t\" 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))

124181

125182subquery:

126183

127184>>> :{

128185let

129− query :: Query

130− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

131− '[]

132− '["col" ::: 'Null 'PGint4]

133− query =

134− selectStar

135− (from (subquery (selectStar (from (table (#tab `As` #t))) `As` #sub)))

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

137189:}

138−"SELECT * FROM (SELECT * FROM \"tab\" AS \"t\") AS \"sub\""

190+SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub"

139191

140192limits and offsets:

141193

142194>>> :{

143195let

144− query :: Query

145− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

146− '[]

147− '["col" ::: 'Null 'PGint4]

148− query = selectStar

149− (from (table (#tab `As` #t)) & limit 100 & offset 2 & limit 50 & offset 2)

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

151199:}

152−"SELECT * FROM \"tab\" AS \"t\" LIMIT 50 OFFSET 4"

200+SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4

153201

154202parameterized query:

155203

156204>>> :{

157205let

158− query :: Query

159− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8])]

160− '[ 'NotNull 'PGfloat8]

161− '["col" ::: 'NotNull 'PGfloat8]

162− query = selectStar

163− (from (table (#tab `As` #t)) & where_ (#col .> param @1))

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

165209:}

166−"SELECT * FROM \"tab\" AS \"t\" WHERE (\"col\" > ($1 :: float8))"

210+SELECT * FROM "tab" AS "tab" WHERE ("col1" > ($1 :: int4))

167211

168212aggregation query:

169213

170214>>> :{

171215let

172− query :: Query

173− '[ "tab" ::: 'Table ('[] :=>

174− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

175− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])]

176− '[]

177− '[ "sum" ::: 'NotNull 'PGint4

178− , "col1" ::: 'NotNull 'PGint4 ]

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

179217 query =

180− select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil)

181− ( from (table (#tab `As` #table1))

182− & group (By #col1 :* Nil)

183− & having (#col1 + sum_ #col2 .> 1) )

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

185223:}

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

187225

188226sorted query:

189227

190228>>> :{

191229let

192− query :: Query

193− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

194− '[]

195− '["col" ::: 'Null 'PGint4]

196− query = selectStar

197− (from (table (#tab `As` #t)) & orderBy [#col & AscNullsFirst])

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

199233:}

200−"SELECT * FROM \"tab\" AS \"t\" ORDER BY \"col\" ASC NULLS FIRST"

234+SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC

201235

202236joins:

203237

204−>>> :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+

205273>>> :{

206274let

207− query :: Query

208− '[ "orders" ::: 'Table (

209− '["pk_orders" ::: PrimaryKey '["id"]

210− ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]

211− ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"]] :=>

212− '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

213− , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4

214− , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4

215− , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4

216− ])

217− , "customers" ::: 'Table (

218− '["pk_customers" ::: PrimaryKey '["id"]] :=>

219− '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

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

221− ])

222− , "shippers" ::: 'Table (

223− '["pk_shippers" ::: PrimaryKey '["id"]] :=>

224− '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

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

226− ])

227− ]

228− '[]

229− '[ "order_price" ::: 'NotNull 'PGfloat4

230− , "customer_name" ::: 'NotNull 'PGtext

231− , "shipper_name" ::: 'NotNull 'PGtext

232− ]

233− query = select

234− ( #o ! #price `As` #order_price :*

235− #c ! #name `As` #customer_name :*

236− #s ! #name `As` #shipper_name :* Nil )

237− ( from (table (#orders `As` #o)

238− & 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))

239282 (#o ! #customer_id .== #c ! #id)

240− & innerJoin (table (#shippers `As` #s))

283+ & innerJoin (table (#shippers `as` #s))

241284 (#o ! #shipper_id .== #s ! #id)) )

242−in renderQuery query

285+in printSQL query

243286:}

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

245288

246289self-join:

247290

248291>>> :{

249292let

250− query :: Query

251− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

252− '[]

253− '["col" ::: 'Null 'PGint4]

254− query = selectDotStar #t1

255− (from (table (#tab `As` #t1) & crossJoin (table (#tab `As` #t2))))

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

298+:}

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

257310:}

258−"SELECT \"t1\".* FROM \"tab\" AS \"t1\" CROSS JOIN \"tab\" AS \"t2\""

311+SELECT * FROM (VALUES (E'true', TRUE), (E'false', FALSE)) AS t ("col1", "col2")

259312

260313set operations:

261314

262315>>> :{

263316let

264− query :: Query

265− '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint4])]

266− '[]

267− '["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)

268353 query =

269− selectStar (from (table (#tab `As` #t)))

270− `unionAll`

271− selectStar (from (table (#tab `As` #t)))

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

273359:}

274−"(SELECT * FROM \"tab\" AS \"t\") UNION ALL (SELECT * FROM \"tab\" AS \"t\")"

360+SELECT "col1" AS "fromOnly" FROM "tab" AS "t1" WHERE EXISTS (SELECT * FROM "tab" AS "t2" WHERE ("t2"."col2" = "t1"."col1"))

361+

275362-}

276−newtype Query

277− (schema :: SchemaType)

278− (params :: [NullityType])

279− (columns :: RelationType)

280− = UnsafeQuery { renderQuery :: ByteString }

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

282369

283370-- | The results of two queries can be combined using the set operation

284−-- `union`. Duplicate rows are eliminated.

371+-- `union`. Duplicate rows are eliminated.

285372union

286− :: Query schema params columns

287− -> Query schema params columns

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

289376q1 `union` q2 = UnsafeQuery $

290− parenthesized (renderQuery q1)

377+ parenthesized (renderSQL q1)

291378 <+> "UNION"

292− <+> parenthesized (renderQuery q2)

379+ <+> parenthesized (renderSQL q2)

293380

294381-- | The results of two queries can be combined using the set operation

295382-- `unionAll`, the disjoint union. Duplicate rows are retained.

296383unionAll

297− :: Query schema params columns

298− -> Query schema params columns

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

300387q1 `unionAll` q2 = UnsafeQuery $

301− parenthesized (renderQuery q1)

388+ parenthesized (renderSQL q1)

302389 <+> "UNION" <+> "ALL"

303− <+> parenthesized (renderQuery q2)

390+ <+> parenthesized (renderSQL q2)

304391

305392-- | The results of two queries can be combined using the set operation

306393-- `intersect`, the intersection. Duplicate rows are eliminated.

307394intersect

308− :: Query schema params columns

309− -> Query schema params columns

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

311398q1 `intersect` q2 = UnsafeQuery $

312− parenthesized (renderQuery q1)

399+ parenthesized (renderSQL q1)

313400 <+> "INTERSECT"

314− <+> parenthesized (renderQuery q2)

401+ <+> parenthesized (renderSQL q2)

315402

316403-- | The results of two queries can be combined using the set operation

317404-- `intersectAll`, the intersection. Duplicate rows are retained.

318405intersectAll

319− :: Query schema params columns

320− -> Query schema params columns

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

322409q1 `intersectAll` q2 = UnsafeQuery $

323− parenthesized (renderQuery q1)

410+ parenthesized (renderSQL q1)

324411 <+> "INTERSECT" <+> "ALL"

325− <+> parenthesized (renderQuery q2)

412+ <+> parenthesized (renderSQL q2)

326413

327414-- | The results of two queries can be combined using the set operation

328415-- `except`, the set difference. Duplicate rows are eliminated.

329416except

330− :: Query schema params columns

331− -> Query schema params columns

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

333420q1 `except` q2 = UnsafeQuery $

334− parenthesized (renderQuery q1)

421+ parenthesized (renderSQL q1)

335422 <+> "EXCEPT"

336− <+> parenthesized (renderQuery q2)

423+ <+> parenthesized (renderSQL q2)

337424

338425-- | The results of two queries can be combined using the set operation

339426-- `exceptAll`, the set difference. Duplicate rows are retained.

340427exceptAll

341− :: Query schema params columns

342− -> Query schema params columns

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

344431q1 `exceptAll` q2 = UnsafeQuery $

345− parenthesized (renderQuery q1)

432+ parenthesized (renderSQL q1)

346433 <+> "EXCEPT" <+> "ALL"

347− <+> parenthesized (renderQuery q2)

434+ <+> parenthesized (renderSQL q2)

348435

349436{-----------------------------------------

350437SELECT queries

351438-----------------------------------------}

352439

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+

353525-- | the `TableExpression` in the `select` command constructs an intermediate

354526-- virtual table by possibly combining tables, views, eliminating rows,

355527-- grouping, etc. This table is finally passed on to processing by

356−-- the select list. The select list determines which columns of

528+-- the select list. The `Selection` determines which columns of

357529-- the intermediate table are actually output.

358530select

359− :: SListI columns

360− => NP (Aliased (Expression relations grouping params)) (column ': columns)

361− -- ^ select list

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

363535 -- ^ intermediate virtual table

364− -> Query schema params (column ': columns)

365−select list rels = UnsafeQuery $

536+ -> Query outer commons schemas params row

537+select selection tabexpr = UnsafeQuery $

366538 "SELECT"

367− <+> renderCommaSeparated (renderAliasedAs renderExpression) list

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

369552

370553-- | After the select list has been processed, the result table can

371554-- be subject to the elimination of duplicate rows using `selectDistinct`.

372555selectDistinct

373− :: SListI columns

374− => NP (Aliased (Expression relations 'Ungrouped params)) (column ': columns)

375− -- ^ select list

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

377560 -- ^ intermediate virtual table

378− -> Query schema params (column ': columns)

379−selectDistinct list rels = UnsafeQuery $

561+ -> Query outer commons schemas params columns

562+selectDistinct selection tabexpr = UnsafeQuery $

380563 "SELECT DISTINCT"

381− <+> renderCommaSeparated (renderAliasedAs renderExpression) list

382− <+> renderTableExpression rels

383−

384−-- | The simplest kind of query is `selectStar` which emits all columns

385−-- that the table expression produces.

386−selectStar

387− :: HasUnique relation relations columns

388− => TableExpression schema params relations 'Ungrouped

389− -- ^ intermediate virtual table

390− -> Query schema params columns

391−selectStar rels = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression rels

392−

393−-- | A `selectDistinctStar` emits all columns that the table expression

394−-- produces and eliminates duplicate rows.

395−selectDistinctStar

396− :: HasUnique relation relations columns

397− => 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

398574 -- ^ intermediate virtual table

399− -> Query schema params columns

400−selectDistinctStar rels = UnsafeQuery $

401− "SELECT DISTINCT" <+> "*" <+> renderTableExpression rels

402−

403−-- | When working with multiple tables, it can also be useful to ask

404−-- for all the columns of a particular table, using `selectDotStar`.

405−selectDotStar

406− :: Has relation relations columns

407− => Alias relation

408− -- ^ particular virtual subtable

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

410598 -- ^ intermediate virtual table

411− -> Query schema params columns

412−selectDotStar rel relations = UnsafeQuery $

413− "SELECT" <+> renderAlias rel <> ".*" <+> renderTableExpression relations

414−

415−-- | A `selectDistinctDotStar` asks for all the columns of a particular table,

416−-- and eliminates duplicate rows.

417−selectDistinctDotStar

418− :: Has relation relations columns

419− => Alias relation

420− -- ^ particular virtual table

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

422623 -- ^ intermediate virtual table

423− -> Query schema params columns

424−selectDistinctDotStar rel relations = UnsafeQuery $

425− "SELECT DISTINCT" <+> renderAlias rel <> ".*"

426− <+> renderTableExpression relations

427−

624+ -> Query outer commons schemas params columns

625+selectDistinctOn_ distincts = selectDistinctOn distincts . List

626+

627+-- | `values` computes a row value or set of row values

628+-- specified by value expressions. It is most commonly used

629+-- to generate a “constant table” within a larger command,

630+-- but it can be used on its own.

631+--

632+-- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]

633+-- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query outer commons schemas '[] Row

634+-- >>> printSQL query

635+-- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b")

428636values

429637 :: SListI cols

430− => NP (Aliased (Expression '[] 'Ungrouped params)) cols

431− -> [NP (Aliased (Expression '[] 'Ungrouped params)) cols]

432− -> Query schema params cols

638+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols

639+ -> [NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols]

640+ -- ^ When more than one row is specified, all the rows must

641+ -- must have the same number of elements

642+ -> Query outer commons schemas params cols

433643values rw rws = UnsafeQuery $ "SELECT * FROM"

434644 <+> parenthesized (

435645 "VALUES"

@@ -440,9 +650,18 @@ values rw rws = UnsafeQuery $ "SELECT * FROM"

440650 <+> parenthesized (renderCommaSeparated renderAliasPart rw)

441651 where

442652 renderAliasPart, renderValuePart

443− :: Aliased (Expression '[] 'Ungrouped params) ty -> ByteString

444− renderAliasPart (_ `As` name) = renderAlias name

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

656+

657+-- | `values_` computes a row value or set of row values

658+-- specified by value expressions.

659+values_

660+ :: SListI cols

661+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols

662+ -- ^ one row of values

663+ -> Query outer commons schemas params cols

664+values_ rw = values rw []

446665

447666{-----------------------------------------

448667Table Expressions

@@ -455,15 +674,17 @@ Table Expressions

455674-- to a table on disk, a so-called base table, but more complex expressions

456675-- can be used to modify or combine base tables in various ways.

457676data TableExpression

458− (schema :: SchemaType)

677+ (outer :: FromType)

678+ (commons :: FromType)

679+ (grp :: Grouping)

680+ (schemas :: SchemasType)

459681 (params :: [NullityType])

460− (relations :: RelationsType)

461− (grouping :: Grouping)

682+ (from :: FromType)

462683 = TableExpression

463− { fromClause :: FromClause schema params relations

684+ { fromClause :: FromClause outer commons schemas params from

464685 -- ^ A table reference that can be a table name, or a derived table such

465686 -- as a subquery, a @JOIN@ construct, or complex combinations of these.

466− , whereClause :: [Condition relations 'Ungrouped params]

687+ , whereClause :: [Condition outer commons 'Ungrouped schemas params from]

467688 -- ^ optional search coditions, combined with `.&&`. After the processing

468689 -- of the `fromClause` is done, each row of the derived virtual table

469690 -- is checked against the search condition. If the result of the

@@ -472,20 +693,20 @@ data TableExpression

472693 -- at least one column of the table generated in the `fromClause`;

473694 -- this is not required, but otherwise the WHERE clause will

474695 -- be fairly useless.

475− , groupByClause :: GroupByClause relations grouping

696+ , groupByClause :: GroupByClause grp from

476697 -- ^ The `groupByClause` is used to group together those rows in a table

477698 -- that have the same values in all the columns listed. The order in which

478699 -- the columns are listed does not matter. The effect is to combine each

479700 -- set of rows having common values into one group row that represents all

480701 -- rows in the group. This is done to eliminate redundancy in the output

481702 -- and/or compute aggregates that apply to these groups.

482− , havingClause :: HavingClause relations grouping params

703+ , havingClause :: HavingClause outer commons grp schemas params from

483704 -- ^ If a table has been grouped using `groupBy`, but only certain groups

484705 -- are of interest, the `havingClause` can be used, much like a

485706 -- `whereClause`, to eliminate groups from the result. Expressions in the

486707 -- `havingClause` can refer both to grouped expressions and to ungrouped

487708 -- expressions (which necessarily involve an aggregate function).

488− , orderByClause :: [SortExpression relations grouping params]

709+ , orderByClause :: [SortExpression outer commons grp schemas params from]

489710 -- ^ The `orderByClause` is for optional sorting. When more than one

490711 -- `SortExpression` is specified, the later (right) values are used to sort

491712 -- rows that are equal according to the earlier (left) values.

@@ -495,72 +716,69 @@ data TableExpression

495716 -- will be returned (but possibly fewer, if the query itself yields

496717 -- fewer rows).

497718 , offsetClause :: [Word64]

498− -- ^ The `offsetClause` is combined with `+` to give an offset count

719+ -- ^ The `offsetClause` is combined with `Prelude.+` to give an offset count

499720 -- if nonempty. The offset count says to skip that many rows before

500721 -- beginning to return rows. The rows are skipped before the limit count

501722 -- is applied.

502− }

723+ } deriving (GHC.Generic)

503724

504725-- | Render a `TableExpression`

505−renderTableExpression

506− :: TableExpression schema params relations grouping

507− -> ByteString

508−renderTableExpression

509− (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat

510− [ "FROM ", renderFromClause frm'

511− , renderWheres whs'

512− , renderGroupByClause grps'

513− , renderHavingClause hvs'

514− , renderOrderByClause srts'

515− , renderLimits lims'

516− , renderOffsets offs'

517− ]

518− where

519− renderWheres = \case

520− [] -> ""

521− wh:[] -> " WHERE" <+> renderExpression wh

522− wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)

523− renderOrderByClause = \case

524− [] -> ""

525− srts -> " ORDER BY"

526− <+> commaSeparated (renderSortExpression <$> srts)

527− renderLimits = \case

528− [] -> ""

529− lims -> " LIMIT" <+> fromString (show (minimum lims))

530− renderOffsets = \case

531− [] -> ""

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

533751

534752-- | A `from` generates a `TableExpression` from a table reference that can be

535753-- a table name, or a derived table such as a subquery, a JOIN construct,

536754-- or complex combinations of these. A `from` may be transformed by `where_`,

537−-- `group`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator

755+-- `groupBy`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator

538756-- to match the left-to-right sequencing of their placement in SQL.

539757from

540− :: FromClause schema params relations -- ^ table reference

541− -> TableExpression schema params relations 'Ungrouped

542−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 [] [] []

543761

544762-- | A `where_` is an endomorphism of `TableExpression`s which adds a

545763-- search condition to the `whereClause`.

546764where_

547− :: Condition relations 'Ungrouped params -- ^ filtering condition

548− -> TableExpression schema params relations grouping

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

550768where_ wh rels = rels {whereClause = wh : whereClause rels}

551769

552−-- | A `group` is a transformation of `TableExpression`s which switches

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

554772-- a "grand total" aggregation query.

555−group

773+groupBy

556774 :: SListI bys

557− => NP (By relations) bys -- ^ grouped columns

558− -> TableExpression schema params relations 'Ungrouped

559− -> TableExpression schema params relations ('Grouped bys)

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

561779 { fromClause = fromClause rels

562780 , whereClause = whereClause rels

563− , groupByClause = Group bys

781+ , groupByClause = group bys

564782 , havingClause = Having []

565783 , orderByClause = []

566784 , limitClause = limitClause rels

@@ -570,34 +788,29 @@ group bys rels = TableExpression

570788-- | A `having` is an endomorphism of `TableExpression`s which adds a

571789-- search condition to the `havingClause`.

572790having

573− :: Condition relations ('Grouped bys) params -- ^ having condition

574− -> TableExpression schema params relations ('Grouped bys)

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

576794having hv rels = rels

577795 { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) }

578796

579−-- | An `orderBy` is an endomorphism of `TableExpression`s which appends an

580−-- ordering to the right of the `orderByClause`.

581−orderBy

582− :: [SortExpression relations grouping params] -- ^ sort expressions

583− -> TableExpression schema params relations grouping

584− -> TableExpression schema params relations grouping

585−orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}

797+instance OrderBy TableExpression where

798+ orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}

586799

587800-- | A `limit` is an endomorphism of `TableExpression`s which adds to the

588801-- `limitClause`.

589802limit

590803 :: Word64 -- ^ limit parameter

591− -> TableExpression schema params relations grouping

592− -> TableExpression schema params relations grouping

804+ -> TableExpression outer commons grp schemas params from

805+ -> TableExpression outer commons grp schemas params from

593806limit lim rels = rels {limitClause = lim : limitClause rels}

594807

595808-- | An `offset` is an endomorphism of `TableExpression`s which adds to the

596809-- `offsetClause`.

597810offset

598811 :: Word64 -- ^ offset parameter

599− -> TableExpression schema params relations grouping

600− -> TableExpression schema params relations grouping

812+ -> TableExpression outer commons grp schemas params from

813+ -> TableExpression outer commons grp schemas params from

601814offset off rels = rels {offsetClause = off : offsetClause rels}

602815

603816{-----------------------------------------

@@ -608,57 +821,76 @@ FROM clauses

608821A `FromClause` can be a table name, or a derived table such

609822as a subquery, a @JOIN@ construct, or complex combinations of these.

610823-}

611−newtype FromClause schema params relations

824+newtype FromClause outer commons schemas params from

612825 = UnsafeFromClause { renderFromClause :: ByteString }

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

827+instance RenderSQL (FromClause outer commons schemas params from) where

828+ renderSQL = renderFromClause

614829

615−-- | A real `table` is a table from the schema.

830+-- | A real `table` is a table from the database.

616831table

617− :: Aliased (Table schema) table

618− -> FromClause schema params '[table]

619−table = UnsafeFromClause . renderAliasedAs renderTable

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

833+ => Aliased (QualifiedAlias sch) (alias ::: tab)

834+ -> FromClause outer commons schemas params '[alias ::: TableToRow table]

835+table (tab `As` alias) = UnsafeFromClause $

836+ renderSQL tab <+> "AS" <+> renderSQL alias

620837

621838-- | `subquery` derives a table from a `Query`.

622839subquery

623− :: Aliased (Query schema params) table

624− -> FromClause schema params '[table]

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

626843

627844-- | `view` derives a table from a `View`.

628845view

629− :: Aliased (View schema) table

630− -> FromClause schema params '[table]

631−view = UnsafeFromClause . renderAliasedAs renderView

632−

633−{- | @left & crossJoin right@. For every possible combination of rows from

634− @left@ and @right@ (i.e., a Cartesian product), the joined table will contain

635− a row consisting of all columns in @left@ followed by all columns in @right@.

636− If the tables have @n@ and @m@ rows respectively, the joined table will

637− have @n * m@ rows.

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

847+ => Aliased (QualifiedAlias sch) (alias ::: vw)

848+ -> FromClause outer commons schemas params '[alias ::: view]

849+view (vw `As` alias) = UnsafeFromClause $

850+ renderSQL vw <+> "AS" <+> renderSQL alias

851+

852+-- | `common` derives a table from a common table expression.

853+common

854+ :: Has cte commons common

855+ => Aliased Alias (alias ::: cte)

856+ -> FromClause outer commons schemas params '[alias ::: common]

857+common (cte `As` alias) = UnsafeFromClause $

858+ renderSQL cte <+> "AS" <+> renderSQL alias

859+

860+instance Additional (FromClause outer commons schemas params) where

861+ also right left = UnsafeFromClause $

862+ renderSQL left <> ", " <> renderSQL right

863+

864+{- |

865+@left & crossJoin right@. For every possible combination of rows from

866+@left@ and @right@ (i.e., a Cartesian product), the joined table will contain

867+a row consisting of all columns in @left@ followed by all columns in @right@.

868+If the tables have @n@ and @m@ rows respectively, the joined table will

869+have @n * m@ rows.

638870-}

639871crossJoin

640− :: FromClause schema params right

872+ :: FromClause outer commons schemas params right

641873 -- ^ right

642− -> FromClause schema params left

874+ -> FromClause outer commons schemas params left

643875 -- ^ left

644− -> FromClause schema params (Join left right)

876+ -> FromClause outer commons schemas params (Join left right)

645877crossJoin right left = UnsafeFromClause $

646− renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right

878+ renderSQL left <+> "CROSS JOIN" <+> renderSQL right

647879

648880{- | @left & innerJoin right on@. The joined table is filtered by

649881the @on@ condition.

650882-}

651883innerJoin

652− :: FromClause schema params right

884+ :: FromClause outer commons schemas params right

653885 -- ^ right

654− -> Condition (Join left right) 'Ungrouped params

886+ -> Condition outer commons 'Ungrouped schemas params (Join left right)

655887 -- ^ @on@ condition

656− -> FromClause schema params left

888+ -> FromClause outer commons schemas params left

657889 -- ^ left

658− -> FromClause schema params (Join left right)

890+ -> FromClause outer commons schemas params (Join left right)

659891innerJoin right on left = UnsafeFromClause $

660− renderFromClause left <+> "INNER JOIN" <+> renderFromClause right

661− <+> "ON" <+> renderExpression on

892+ renderSQL left <+> "INNER JOIN" <+> renderSQL right

893+ <+> "ON" <+> renderSQL on

662894

663895{- | @left & leftOuterJoin right on@. First, an inner join is performed.

664896 Then, for each row in @left@ that does not satisfy the @on@ condition with

@@ -666,16 +898,16 @@ innerJoin right on left = UnsafeFromClause $

666898 Thus, the joined table always has at least one row for each row in @left@.

667899-}

668900leftOuterJoin

669− :: FromClause schema params right

901+ :: FromClause outer commons schemas params right

670902 -- ^ right

671− -> Condition (Join left right) 'Ungrouped params

903+ -> Condition outer commons 'Ungrouped schemas params (Join left right)

672904 -- ^ @on@ condition

673− -> FromClause schema params left

905+ -> FromClause outer commons schemas params left

674906 -- ^ left

675− -> FromClause schema params (Join left (NullifyRelations right))

907+ -> FromClause outer commons schemas params (Join left (NullifyFrom right))

676908leftOuterJoin right on left = UnsafeFromClause $

677− renderFromClause left <+> "LEFT OUTER JOIN" <+> renderFromClause right

678− <+> "ON" <+> renderExpression on

909+ renderSQL left <+> "LEFT OUTER JOIN" <+> renderSQL right

910+ <+> "ON" <+> renderSQL on

679911

680912{- | @left & rightOuterJoin right on@. First, an inner join is performed.

681913 Then, for each row in @right@ that does not satisfy the @on@ condition with

@@ -684,16 +916,16 @@ leftOuterJoin right on left = UnsafeFromClause $

684916 have a row for each row in @right@.

685917-}

686918rightOuterJoin

687− :: FromClause schema params right

919+ :: FromClause outer commons schemas params right

688920 -- ^ right

689− -> Condition (Join left right) 'Ungrouped params

921+ -> Condition outer commons 'Ungrouped schemas params (Join left right)

690922 -- ^ @on@ condition

691− -> FromClause schema params left

923+ -> FromClause outer commons schemas params left

692924 -- ^ left

693− -> FromClause schema params (Join (NullifyRelations left) right)

925+ -> FromClause outer commons schemas params (Join (NullifyFrom left) right)

694926rightOuterJoin right on left = UnsafeFromClause $

695− renderFromClause left <+> "RIGHT OUTER JOIN" <+> renderFromClause right

696− <+> "ON" <+> renderExpression on

927+ renderSQL left <+> "RIGHT OUTER JOIN" <+> renderSQL right

928+ <+> "ON" <+> renderSQL on

697929

698930{- | @left & fullOuterJoin right on@. First, an inner join is performed.

699931 Then, for each row in @left@ that does not satisfy the @on@ condition with

@@ -703,47 +935,56 @@ rightOuterJoin right on left = UnsafeFromClause $

703935 is added.

704936-}

705937fullOuterJoin

706− :: FromClause schema params right

938+ :: FromClause outer commons schemas params right

707939 -- ^ right

708− -> Condition (Join left right) 'Ungrouped params

940+ -> Condition outer commons 'Ungrouped schemas params (Join left right)

709941 -- ^ @on@ condition

710− -> FromClause schema params left

942+ -> FromClause outer commons schemas params left

711943 -- ^ left

712− -> FromClause schema params

713− (Join (NullifyRelations left) (NullifyRelations right))

944+ -> FromClause outer commons schemas params

945+ (Join (NullifyFrom left) (NullifyFrom right))

714946fullOuterJoin right on left = UnsafeFromClause $

715− renderFromClause left <+> "FULL OUTER JOIN" <+> renderFromClause right

716− <+> "ON" <+> renderExpression on

947+ renderSQL left <+> "FULL OUTER JOIN" <+> renderSQL right

948+ <+> "ON" <+> renderSQL on

717949

718950{-----------------------------------------

719951Grouping

720952-----------------------------------------}

721953

722−-- | `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

723955-- used to group together those rows in a table that have the same values

724956-- in all the columns listed. @By \#col@ will reference an unambiguous

725957-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table

726958-- qualified column @tab.col@.

727959data By

728− (relations :: RelationsType)

960+ (from :: FromType)

729961 (by :: (Symbol,Symbol)) where

730− By

731− :: (HasUnique relation relations columns, Has column columns ty)

962+ By1

963+ :: (HasUnique table from columns, Has column columns ty)

732964 => Alias column

733− -> By relations '(relation, column)

965+ -> By from '(table, column)

734966 By2

735− :: (Has relation relations columns, Has column columns ty)

736− => (Alias relation, Alias column)

737− -> By relations '(relation, column)

738−deriving instance Show (By relations by)

739−deriving instance Eq (By relations by)

740−deriving instance Ord (By relations by)

741−

742−-- | Renders a `By`.

743−renderBy :: By relations by -> ByteString

744−renderBy = \case

745− By column -> renderAlias column

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

747988

748989-- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.

749990-- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`.

@@ -751,82 +992,107 @@ renderBy = \case

751992-- done on @NoGroups@ while all output `Expression`s must be aggregated

752993-- in @Group Nil@. In general, all output `Expression`s in the

753994-- complement of @bys@ must be aggregated in @Group bys@.

754−data GroupByClause relations grouping where

755− NoGroups :: GroupByClause relations 'Ungrouped

756− Group

757− :: SListI bys

758− => NP (By relations) bys

759− -> GroupByClause relations ('Grouped bys)

760−

761−-- | Renders a `GroupByClause`.

762−renderGroupByClause :: GroupByClause relations grouping -> ByteString

763−renderGroupByClause = \case

764− NoGroups -> ""

765− Group Nil -> ""

766− 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'

7671009

7681010-- | A `HavingClause` is used to eliminate groups that are not of interest.

7691011-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`

7701012-- `TableExpression` must use `Having` whose conditions are combined with

7711013-- `.&&`.

772−data HavingClause relations grouping params where

773− NoHaving :: HavingClause relations 'Ungrouped params

1014+data HavingClause outer commons grp schemas params from where

1015+ NoHaving :: HavingClause outer commons 'Ungrouped schemas params from

7741016 Having

775− :: [Condition relations ('Grouped bys) params]

776− -> HavingClause relations ('Grouped bys) params

777−deriving instance Show (HavingClause relations grouping params)

778−deriving instance Eq (HavingClause relations grouping params)

779−deriving instance Ord (HavingClause 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)

7801022

7811023-- | Render a `HavingClause`.

782−renderHavingClause :: HavingClause relations grouping params -> ByteString

783−renderHavingClause = \case

784− NoHaving -> ""

785− Having [] -> ""

786− Having conditions ->

787− " HAVING" <+> commaSeparated (renderExpression <$> conditions)

788−

789−{-----------------------------------------

790−Sorting

791−-----------------------------------------}

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

7921074

793−-- | `SortExpression`s are used by `sortBy` to optionally sort the results

794−-- of a `Query`. `Asc` or `Desc` set the sort direction of a `NotNull` result

795−-- column to ascending or descending. Ascending order puts smaller values

796−-- first, where "smaller" is defined in terms of the `.<` operator. Similarly,

797−-- descending order is determined with the `.>` operator. `AscNullsFirst`,

798−-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to

799−-- determine whether nulls appear before or after non-null values in the sort

800−-- ordering of a `Null` result column.

801−data SortExpression relations grouping params where

802− Asc

803− :: Expression relations grouping params ('NotNull ty)

804− -> SortExpression relations grouping params

805− Desc

806− :: Expression relations grouping params ('NotNull ty)

807− -> SortExpression relations grouping params

808− AscNullsFirst

809− :: Expression relations grouping params ('Null ty)

810− -> SortExpression relations grouping params

811− AscNullsLast

812− :: Expression relations grouping params ('Null ty)

813− -> SortExpression relations grouping params

814− DescNullsFirst

815− :: Expression relations grouping params ('Null ty)

816− -> SortExpression relations grouping params

817− DescNullsLast

818− :: Expression relations grouping params ('Null ty)

819− -> SortExpression relations grouping params

820−deriving instance Show (SortExpression relations grouping params)

821−

822−-- | Render a `SortExpression`.

823−renderSortExpression :: SortExpression relations grouping params -> ByteString

824−renderSortExpression = \case

825− Asc expression -> renderExpression expression <+> "ASC"

826− Desc expression -> renderExpression expression <+> "DESC"

827− AscNullsFirst expression -> renderExpression expression

828− <+> "ASC NULLS FIRST"

829− DescNullsFirst expression -> renderExpression expression

830− <+> "DESC NULLS FIRST"

831− AscNullsLast expression -> renderExpression expression <+> "ASC NULLS LAST"

832− 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+332−496

@@ -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,211 +238,65 @@ 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−type family TableToRelation (table :: TableType) :: RelationType where

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

333284

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

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

336−-- for typesafe aggregation

337−data Grouping

338− = Ungrouped -- ^ no aggregation permitted

339− | 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]

340288

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

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

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

344−-}

345−class (KnownSymbol relation, KnownSymbol column)

346− => GroupedBy relation column bys where

347−instance {-# OVERLAPPING #-} (KnownSymbol relation, KnownSymbol column)

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

349−instance {-# OVERLAPPABLE #-}

350− ( KnownSymbol relation

351− , KnownSymbol column

352− , GroupedBy relation column bys

353− ) => GroupedBy relation column (tabcol ': bys)

354−

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

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

357−--

358−-- >>> :set -XOverloadedLabels

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

360−-- Alias

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

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

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

364− fromLabel = Alias

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

366− fromLabel = fromLabel :* Nil

367−

368−-- | >>> renderAlias #jimbob

369−-- "\"jimbob\""

370−renderAlias :: KnownSymbol alias => Alias alias -> ByteString

371−renderAlias = doubleQuoted . fromString . symbolVal

372−

373−-- | >>> import Generics.SOP (NP(..))

374−-- >>> renderAliases (#jimbob :* #kandi :* Nil)

375−-- ["\"jimbob\"","\"kandi\""]

376−renderAliases

377− :: All KnownSymbol aliases => NP Alias aliases -> [ByteString]

378−renderAliases = hcollapse

379− . hcmap (Proxy @KnownSymbol) (K . renderAlias)

380−

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

382−-- version of `:::`.

383−--

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

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

386−data Aliased expression aliased where

387− As

388− :: KnownSymbol alias

389− => expression ty

390− -> Alias alias

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

392−deriving instance Show (expression ty)

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

394−deriving instance Eq (expression ty)

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

396−deriving instance Ord (expression ty)

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

398−

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

400−-- >>> renderAliasedAs renderMaybe (Just (3::Int) `As` #an_int)

401−-- "Just AS \"an_int\""

402−renderAliasedAs

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

404− -> Aliased expression aliased

405− -> ByteString

406−renderAliasedAs render (expression `As` alias) =

407− render expression <> " AS " <> renderAlias alias

408−

409−-- | `AliasesOf` retains the AliasesOf in a row.

410−type family AliasesOf aliaseds where

411− AliasesOf '[] = '[]

412− AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys

413−

414−class

415− ( SListI (ZipAs ns xs)

416− , All KnownSymbol ns

417− ) => ZipAliased ns xs where

418−

419− type family ZipAs

420− (ns :: [Symbol]) (xs :: [k]) = (zs :: [(Symbol,k)]) | zs -> ns xs

421−

422− zipAs

423− :: NP Alias ns

424− -> NP expr xs

425− -> NP (Aliased expr) (ZipAs ns xs)

426−

427−instance ZipAliased '[] '[] where

428− type ZipAs '[] '[] = '[]

429− zipAs Nil Nil = Nil

430−

431−instance

432− ( KnownSymbol n

433− , ZipAliased ns xs

434− ) => ZipAliased (n ': ns) (x ': xs) where

435− type ZipAs (n ': ns) (x ': xs) = '(n,x) ': ZipAs ns xs

436− zipAs (n :* ns) (x :* xs) = x `As` n :* zipAs ns xs

437−

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

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

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

441−

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

443−-- @fields@ has a field of @alias ::: field@.

444−class KnownSymbol alias =>

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

446− | alias fields -> field where

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

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

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

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

451−

452−class

453− ( All KnownSymbol aliases

454− ) => HasAll

455− (aliases :: [Symbol])

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

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

458− | aliases fields -> subfields where

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

460−instance {-# OVERLAPPABLE #-}

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

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

463−

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

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

466−-- by a table alias.

467−class IsQualified table column expression where

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

469− infixl 9 !

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

471−

472−-- | @Elem@ is a promoted `Data.List.elem`.

473−type family Elem x xs where

474− Elem x '[] = 'False

475− Elem x (x ': xs) = 'True

476− Elem x (_ ': xs) = Elem x xs

477−

478−-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.

479−type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True

480−

481−-- | `PGNum` is a constraint on `PGType` whose

482−-- `Squeal.PostgreSQL.Expression.Expression`s have a `Num` constraint.

483−type PGNum ty =

484− In ty '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]

485−

486−-- | `PGFloating` is a constraint on `PGType` whose

487−-- `Squeal.PostgreSQL.Expression.Expression`s

488−-- have `Fractional` and `Floating` constraints.

489−type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]

490−

491−-- | `PGIntegral` is a constraint on `PGType` whose

492−-- `Squeal.PostgreSQL.Expression.Expression`s

493−-- have `Squeal.PostgreSQL.Expression.div_` and

494−-- `Squeal.PostgreSQL.Expression.mod_` functions.

495−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]

496294

497295-- | `PGTypeOf` forgets about @NULL@ and any column constraints.

498296type family PGTypeOf (ty :: NullityType) :: PGType where

499297 PGTypeOf (nullity pg) = pg

500298

501−-- | `SameTypes` is a constraint that proves two `ColumnsType`s have the same

502−-- length and the same `ColumnType`s.

503−type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType)

504− :: Constraint where

505− SameTypes '[] '[] = ()

506− SameTypes (column0 ::: def0 :=> ty0 ': columns0) (column1 ::: def1 :=> ty1 ': columns1)

507− = (ty0 ~ ty1, SameTypes columns0 columns1)

508−

299+-- | Equality constraint on the underlying `PGType` of two columns.

509300class SamePGType

510301 (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where

511302instance ty0 ~ ty1 => SamePGType

@@ -514,39 +305,63 @@ instance ty0 ~ ty1 => SamePGType

514305

515306-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.

516307type 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

517314 AllNotNull '[] = ()

518− AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns

519315

520316-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some

521317-- @NOT NULL@.

522318type family NotAllNull (columns :: ColumnsType) :: Constraint where

523− NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()

524− NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns

525−

526−-- | `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`.

527328type family NullifyType (ty :: NullityType) :: NullityType where

528329 NullifyType ('Null ty) = 'Null ty

529330 NullifyType ('NotNull ty) = 'Null ty

530331

531−-- | `NullifyRelation` is an idempotent that nullifies a `ColumnsType`.

532−type family NullifyRelation (columns :: RelationType) :: RelationType where

533− NullifyRelation '[] = '[]

534− NullifyRelation (column ::: ty ': columns) =

535− column ::: NullifyType ty ': NullifyRelation columns

536−

537−-- | `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`

538349-- used to nullify the left or right hand side of an outer join

539350-- in a `Squeal.PostgreSQL.Query.FromClause`.

540−type family NullifyRelations (tables :: RelationsType) :: RelationsType where

541− NullifyRelations '[] = '[]

542− NullifyRelations (table ::: columns ': tables) =

543− table ::: NullifyRelation columns ': NullifyRelations tables

544−

545−-- | `Join` is simply promoted `++` and is used in @JOIN@s in

546−-- `Squeal.PostgreSQL.Query.FromClause`s.

547−type family Join xs ys where

548− Join '[] ys = ys

549− 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 '[] = '[]

550365

551366-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in

552367-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@

@@ -556,59 +371,100 @@ type family Create alias x xs where

556371 Create alias x (alias ::: y ': xs) = TypeError

557372 ('Text "Create: alias "

558373 ':<>: 'ShowType alias

559− ':<>: 'Text "already in use")

374+ ':<>: 'Text "already exists")

560375 Create alias y (x ': xs) = x ': Create alias y xs

561376

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+

562394-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@

563395-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements

564396-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.

565397type family Drop alias xs where

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

567403 Drop alias (x ': xs) = x ': Drop alias xs

568404

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+

569437-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@

570−-- 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`

571439-- and `Squeal.PostgreSQL.Definition.alterColumn`.

572440type family Alter alias x xs where

441+ Alter alias x '[] = TypeError

442+ ('Text "Alter: alias "

443+ ':<>: 'ShowType alias

444+ ':<>: 'Text " does not exist" )

573445 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs

574446 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs

575447

576−-- type family AddConstraint constraint ty where

577−-- AddConstraint constraint (constraints :=> ty)

578−-- = AsSet (constraint ': constraints) :=> ty

579−

580−-- type family DeleteFromList (e :: elem) (list :: [elem]) where

581−-- DeleteFromList elem '[] = '[]

582−-- DeleteFromList elem (x ': xs) =

583−-- If (Cmp elem x == 'EQ) xs (x ': DeleteFromList elem xs)

584−

585−-- type family DropConstraint constraint ty where

586−-- DropConstraint constraint (constraints :=> ty)

587−-- = (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

588452

589453-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@

590454-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and

591455-- `Squeal.PostgreSQL.Definition.renameColumn`.

592456type family Rename alias0 alias1 xs where

457+ Rename alias0 alias1 '[] = TypeError

458+ ('Text "Rename: alias "

459+ ':<>: 'ShowType alias0

460+ ':<>: 'Text " does not exist" )

593461 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs

594462 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs

595463

596−class MapMaybes xs where

597− type family Maybes (xs :: [Type]) = (mxs :: [Type]) | mxs -> xs

598− maybes :: NP Maybe xs -> NP I (Maybes xs)

599− unMaybes :: NP I (Maybes xs) -> NP Maybe xs

600−instance MapMaybes '[] where

601− type Maybes '[] = '[]

602− maybes Nil = Nil

603− unMaybes Nil = Nil

604−instance MapMaybes xs => MapMaybes (x ': xs) where

605− type Maybes (x ': xs) = Maybe x ': Maybes xs

606− maybes (x :* xs) = I x :* maybes xs

607− unMaybes (I mx :* xs) = mx :* unMaybes xs

608−

609−type family Nulls tys where

610− Nulls '[] = '[]

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

612468

613469-- | Check if a `TableConstraint` involves a column

614470type family ConstraintInvolves column constraint where

@@ -626,135 +482,115 @@ type family DropIfConstraintsInvolve column constraints where

626482 (DropIfConstraintsInvolve column constraints)

627483 (alias ::: constraint ': DropIfConstraintsInvolve column constraints)

628484

485+-- | A `SchemumType` is a user-defined type, either a `Table`,

486+-- `View` or `Typedef`.

629487data SchemumType

630488 = Table TableType

631− | View RelationType

489+ | View RowType

632490 | Typedef PGType

633−

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

634537type SchemaType = [(Symbol,SchemumType)]

635538

636−type family With

637− (relations :: RelationsType)

638− (schema :: SchemaType)

639− :: SchemaType where

640− With '[] schema = schema

641− With (alias ::: rel ': rels) schema =

642− 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]

643559

560+-- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas

561+-- the overloaded label, `fromLabel` is used for column references,

562+-- `label`s are used for enum terms. A `label` is called with

563+-- type application like `label @"beef"`.

644564class IsPGlabel (label :: Symbol) expr where label :: expr

645−instance label ~ label'

646− => 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

569+-- | A `PGlabel` unit type with an `IsPGlabel` instance

647570data PGlabel (label :: Symbol) = PGlabel

648−

649−renderLabel :: KnownSymbol label => proxy label -> ByteString

650−renderLabel (_ :: proxy label) =

651− "\'" <> fromString (symbolVal (Proxy @label)) <> "\'"

652−

653−renderLabels

654− :: All KnownSymbol labels => NP PGlabel labels -> [ByteString]

655−renderLabels = hcollapse

656− . hcmap (Proxy @KnownSymbol) (K . renderLabel)

657−

658−type family LabelOf (cons :: Type.ConstructorInfo) :: Symbol where

659− LabelOf ('Type.Constructor name) = name

660−

661−type family LabelsOf (conss :: [Type.ConstructorInfo]) :: [Symbol] where

662− LabelsOf '[] = '[]

663− LabelsOf (cons ': conss) = LabelOf cons ': LabelsOf conss

664−

665−type family PG (hask :: Type) :: PGType where

666− PG Bool = 'PGbool

667− PG Int16 = 'PGint2

668− PG Int32 = 'PGint4

669− PG Int64 = 'PGint8

670− PG Word16 = 'PGint2

671− PG Word32 = 'PGint4

672− PG Word64 = 'PGint8

673− PG Scientific = 'PGnumeric

674− PG Float = 'PGfloat4

675− PG Double = 'PGfloat8

676− PG Char = 'PGchar 1

677− PG Text = 'PGtext

678− PG Lazy.Text = 'PGtext

679− PG ByteString = 'PGbytea

680− PG Lazy.ByteString = 'PGbytea

681− PG LocalTime = 'PGtimestamp

682− PG UTCTime = 'PGtimestamptz

683− PG Day = 'PGdate

684− PG TimeOfDay = 'PGtime

685− PG (TimeOfDay, TimeZone) = 'PGtimetz

686− PG DiffTime = 'PGinterval

687− PG UUID = 'PGuuid

688− PG (NetAddr IP) = 'PGinet

689− PG Value = 'PGjson

690− PG ty = TypeError

691− ('Text "There is no basic Postgres type for " ':<>: 'ShowType ty)

692−

693−type family EnumWith (hask :: Type) :: PGType where

694− EnumWith hask = 'PGenum (LabelsWith hask)

695−

696−type family LabelsWith (hask :: Type) :: [Type.ConstructorName] where

697− LabelsWith hask =

698− ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask))

699−

700−type family CompositeWith (hask :: Type) :: PGType where

701− CompositeWith hask =

702− 'PGcomposite (ZipAs (FieldNamesWith hask) (FieldTypesWith hask))

703−

704−type family FieldNamesWith (hask :: Type) :: [Type.FieldName] where

705− FieldNamesWith hask = FieldNamesOf (FieldsOf (DatatypeInfoOf hask))

706−

707−type family FieldTypesWith (hask :: Type) :: [PGType] where

708− FieldTypesWith hask = FieldTypesOf (RecordCodeOf hask (Code hask))

709−

710−type family ConstructorsOf (datatype :: Type.DatatypeInfo)

711− :: [Type.ConstructorInfo] where

712− ConstructorsOf ('Type.ADT _module _datatype constructors) =

713− constructors

714− ConstructorsOf ('Type.Newtype _module _datatype constructor) =

715− '[constructor]

716−

717−type family ConstructorNameOf (constructors :: Type.ConstructorInfo)

718− :: Type.ConstructorName where

719− ConstructorNameOf ('Type.Constructor name) = name

720− ConstructorNameOf ('Type.Infix name _assoc _fix) = TypeError

721− ('Text "ConstructorNameOf error: non-nullary constructor "

722− ':<>: 'Text name)

723− ConstructorNameOf ('Type.Record name _fields) = TypeError

724− ('Text "ConstructorNameOf error: non-nullary constructor "

725− ':<>: 'Text name)

726−

727−type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])

728− :: [Type.ConstructorName] where

729− ConstructorNamesOf '[] = '[]

730− ConstructorNamesOf (constructor ': constructors) =

731− ConstructorNameOf constructor ': ConstructorNamesOf constructors

732−

733−type family FieldsOf (constructor :: Type.DatatypeInfo)

734− :: [Type.FieldInfo] where

735− FieldsOf ('Type.ADT _module _datatype '[ 'Type.Record _name fields]) =

736− fields

737− FieldsOf ('Type.Newtype _module _datatype ('Type.Record _name fields)) =

738− fields

739−

740−type family FieldNameOf (field :: Type.FieldInfo) :: Type.FieldName where

741− FieldNameOf ('Type.FieldInfo name) = name

742−

743−type family FieldNamesOf (fields :: [Type.FieldInfo])

744− :: [Type.FieldName] where

745− FieldNamesOf '[] = '[]

746− FieldNamesOf (field ': fields) = FieldNameOf field ': FieldNamesOf fields

747−

748−type family FieldTypeOf (maybe :: Type) where

749− FieldTypeOf (Maybe hask) = PG hask

750− FieldTypeOf ty = TypeError

751− ('Text "FieldTypeOf error: non-Maybe type " ':<>: 'ShowType ty)

752−

753−type family FieldTypesOf (fields :: [Type]) where

754− FieldTypesOf '[] = '[]

755− FieldTypesOf (field ': fields) = FieldTypeOf field ': FieldTypesOf fields

756−

757−type family RecordCodeOf (hask :: Type) (code ::[[Type]]) :: [Type] where

758− RecordCodeOf _hask '[tys] = tys

759− RecordCodeOf hask _tys = TypeError

760− ('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+105−78

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

@@ -158,32 +185,32 @@ data IsolationLevel

158185 = Serializable

159186 -- ^ Dirty read is not possible.

160187 -- Nonrepeatable read is not possible.

161− -- Phantom read is not possible.

188+ -- Phantom read is not possible.

162189 -- Serialization anomaly is not possible.

163190 | RepeatableRead

164191 -- ^ Dirty read is not possible.

165192 -- Nonrepeatable read is not possible.

166− -- Phantom read is not possible.

193+ -- Phantom read is not possible.

167194 -- Serialization anomaly is possible.

168195 | ReadCommitted

169196 -- ^ Dirty read is not possible.

170197 -- Nonrepeatable read is possible.

171− -- Phantom read is possible.

198+ -- Phantom read is possible.

172199 -- Serialization anomaly is possible.

173200 | ReadUncommitted

174201 -- ^ Dirty read is not possible.

175202 -- Nonrepeatable read is possible.

176− -- Phantom read is possible.

203+ -- Phantom read is possible.

177204 -- Serialization anomaly is possible.

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