6cb5916...dev · squeal

git.iko.soy/squeal

52 files changed+12119−4158

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

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

132− createTable #emails

133− ( serial `As` #id :*

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

135− text `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+50−53

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

@@ -25,86 +24,84 @@ import qualified Generics.SOP as SOP

2524import qualified GHC.Generics as GHC

2625

2726type Schema =

28− '[ "users" :::

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

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

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

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

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

33− ]

34− , "emails" :::

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

32+ ])

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

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

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

3736 ] :=>

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

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

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

41− ]

40+ ])

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

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

55− text `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−11

@@ -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,52 +22,116 @@ library

2222 hs-source-dirs: src

2323 exposed-modules:

2424 Squeal.PostgreSQL

25+ Squeal.PostgreSQL.Alias

2526 Squeal.PostgreSQL.Binary

2627 Squeal.PostgreSQL.Definition

28+ Squeal.PostgreSQL.Definition.Function

29+ Squeal.PostgreSQL.Definition.Index

30+ Squeal.PostgreSQL.Definition.Table

31+ Squeal.PostgreSQL.Definition.Table.Constraint

32+ Squeal.PostgreSQL.Definition.Type

33+ Squeal.PostgreSQL.Definition.Schema

34+ Squeal.PostgreSQL.Definition.View

2735 Squeal.PostgreSQL.Expression

36+ Squeal.PostgreSQL.Expression.Aggregate

37+ Squeal.PostgreSQL.Expression.Collection

38+ Squeal.PostgreSQL.Expression.Comparison

39+ Squeal.PostgreSQL.Expression.Json

40+ Squeal.PostgreSQL.Expression.Literal

41+ Squeal.PostgreSQL.Expression.Logic

42+ Squeal.PostgreSQL.Expression.Math

43+ Squeal.PostgreSQL.Expression.Null

44+ Squeal.PostgreSQL.Expression.Parameter

45+ Squeal.PostgreSQL.Expression.Range

46+ Squeal.PostgreSQL.Expression.Set

47+ Squeal.PostgreSQL.Expression.Sort

48+ Squeal.PostgreSQL.Expression.Subquery

49+ Squeal.PostgreSQL.Expression.Text

50+ Squeal.PostgreSQL.Expression.TextSearch

51+ Squeal.PostgreSQL.Expression.Time

52+ Squeal.PostgreSQL.Expression.Type

53+ Squeal.PostgreSQL.Expression.Window

54+ Squeal.PostgreSQL.List

2855 Squeal.PostgreSQL.Manipulation

2956 Squeal.PostgreSQL.Migration

3057 Squeal.PostgreSQL.Pool

58+ Squeal.PostgreSQL.PG

3159 Squeal.PostgreSQL.PQ

3260 Squeal.PostgreSQL.Render

3361 Squeal.PostgreSQL.Query

3462 Squeal.PostgreSQL.Schema

3563 Squeal.PostgreSQL.Transaction

3664 default-language: Haskell2010

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

65+ ghc-options: -Wall

3866 build-depends:

3967 aeson >= 1.2.4.0

40− , base >= 4.10.1.0 && < 5.0

68+ , base >= 4.11.1.0 && < 5.0

69+ , binary-parser >= 0.5.5

4170 , bytestring >= 0.10.8.2

71+ , bytestring-strict-builder >= 0.4.5

4272 , deepseq >= 1.4.3.0

43− , generics-sop >= 0.3.2.0

44− , lifted-base >= 0.2.3.12

73+ , free-categories >= 0.1.0.0

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

4575 , mmorph >= 1.1.1

46− , monad-control >= 1.0.2.3

4776 , mtl >= 2.2.2

4877 , network-ip >= 0.3.0.2

4978 , postgresql-binary >= 0.12.1

5079 , postgresql-libpq >= 0.9.4.1

80+ , records-sop >= 0.1.0.0

5181 , resource-pool >= 0.2.3.2

5282 , scientific >= 0.3.5.3

5383 , text >= 1.2.3.0

5484 , time >= 1.8.0.2

5585 , transformers >= 0.5.2.0

56− , transformers-base >= 0.4.4

86+ , unliftio >= 0.2.10

87+ , unliftio-pool >= 0.2.1.0

5788 , uuid-types >= 1.0.3

5889 , vector >= 0.12.0.1

5990

60−test-suite squeal-postgresql-doctest

91+test-suite doctest

6192 default-language: Haskell2010

6293 type: exitcode-stdio-1.0

6394 hs-source-dirs: test

6495 ghc-options: -Wall

65− main-is: DocTest.hs

96+ main-is: Doc.hs

6697 build-depends:

6798 base >= 4.10.0.0

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

69133

70−executable squeal-postgresql-example

134+executable example

71135 default-language: Haskell2010

72136 hs-source-dirs: exe

73137 ghc-options: -Wall

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

80144 , squeal-postgresql

81145 , text >= 1.2.2.2

82146 , transformers >= 0.5.2.0

83− , transformers-base >= 0.4.4

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

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

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

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

38−-- ]

39−-- , "emails" :::

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

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

42−-- ] :=>

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

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

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

46−-- ]

47−-- ]

48−-- :}

49−--

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

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

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

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

54−-- yielding a `ColumnType`.

55−--

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

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

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

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

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

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

62−--

63−-- >>> :{

64−-- let

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

66−-- setup =

67−-- createTable #users

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

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

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

71−-- createTable #emails

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

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

74−-- text `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, 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+690−119

@@ -5,22 +5,192 @@ 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

12− ConstraintKinds

13− , DataKinds

14− , DefaultSignatures

182+ AllowAmbiguousTypes

15183 , DeriveFoldable

16184 , DeriveFunctor

17185 , DeriveGeneric

18186 , DeriveTraversable

187+ , DefaultSignatures

19188 , FlexibleContexts

20189 , FlexibleInstances

190+ , FunctionalDependencies

21191 , GADTs

22192 , LambdaCase

23− , KindSignatures

193+ , OverloadedStrings

24194 , MultiParamTypeClasses

25195 , ScopedTypeVariables

26196 , TypeApplications

@@ -28,22 +198,33 @@ Binary encoding and decoding between Haskell and PostgreSQL types.

28198 , TypeInType

29199 , TypeOperators

30200 , UndecidableInstances

201+ , UndecidableSuperClasses

31202#-}

32203

33204module Squeal.PostgreSQL.Binary

34205 ( -- * Encoding

35206 ToParam (..)

36− , ToColumnParam (..)

37207 , ToParams (..)

208+ , ToNullityParam (..)

209+ , ToField (..)

210+ , ToFixArray (..)

38211 -- * Decoding

39212 , FromValue (..)

40− , FromColumnValue (..)

41213 , FromRow (..)

214+ , FromField (..)

215+ , FromFixArray (..)

42216 -- * Only

43217 , Only (..)

218+ -- * Oid

219+ , OidOf (..)

220+ , OidOfParam (..)

221+ , OidOfField (..)

44222 ) where

45223

46−import Data.Aeson hiding (Null)

224+import BinaryParser

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

226+import Control.Arrow (left)

227+import Control.Monad

47228import Data.Int

48229import Data.Kind

49230import Data.Scientific

@@ -51,19 +232,28 @@ import Data.Time

51232import Data.UUID.Types

52233import Data.Vector (Vector)

53234import Data.Word

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

54236import Generics.SOP

237+import Generics.SOP.Record

55238import GHC.TypeLits

56239import Network.IP.Addr

57240

58−import qualified Data.ByteString.Lazy as Lazy

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

60−import qualified Data.Text.Lazy as Lazy

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

62248import qualified Data.Vector as Vector

249+import qualified Database.PostgreSQL.LibPQ as LibPQ

63250import qualified GHC.Generics as GHC

64251import qualified PostgreSQL.Binary.Decoding as Decoding

65252import qualified PostgreSQL.Binary.Encoding as Encoding

66253

254+import Squeal.PostgreSQL.Alias

255+import Squeal.PostgreSQL.List

256+import Squeal.PostgreSQL.PG

67257import Squeal.PostgreSQL.Schema

68258

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

103294instance ToParam Strict.ByteString 'PGbytea where

104295 toParam = K . Encoding.bytea_strict

105296instance ToParam Lazy.ByteString 'PGbytea where

@@ -113,34 +304,256 @@ instance ToParam LocalTime 'PGtimestamp where

113304instance ToParam UTCTime 'PGtimestamptz where

114305 toParam = K . Encoding.timestamptz_int

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

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

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

118−instance (HasOid pg, ToParam x pg)

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

120− toParam = K . Encoding.nullableArray_vector

121− (oid @pg) (unK . toParam @x @pg)

122−

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

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

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

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

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

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

129− --

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

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

132− --

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

134− -- K Nothing

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

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

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

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

139− toColumnParam = K . fmap (Encoding.encodingBytes . 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

336+instance

337+ ( IsEnumType x

338+ , HasDatatypeInfo x

339+ , LabelsPG x ~ labels

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

341+ toParam =

342+ let

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

344+ gshowConstructor Nil _ = ""

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

346+ constructorName constructor

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

348+ gshowConstructor constructors (SOP xs)

349+ in

350+ K . Encoding.text_strict

351+ . Strict.Text.pack

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

353+ . from

354+ . getEnumerated

355+instance

356+ ( SListI fields

357+ , IsRecord x xs

358+ , AllZip ToField xs fields

359+ , All OidOfField fields

360+ ) => ToParam (Composite x) ('PGcomposite fields) where

361+ toParam =

362+ let

363+

364+ encoders = htrans (Proxy @ToField) toField

365+

366+ composite

367+ :: All OidOfField row

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

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

370+ composite fields = K $

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

372+ -- [for each field]

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

374+ -- [if value is NULL]

375+ -- <-1: 4 bytes>

376+ -- [else]

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

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

379+ -- [end if]

380+ -- [end for]

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

382+ let

383+ each

384+ :: OidOfField field

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

386+ -> Encoding.Encoding

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

388+ word32BE (getOid (oidOfField @field))

389+ <> case field of

390+ Nothing -> int64BE (-1)

391+ Just value ->

392+ int32BE (fromIntegral (builderLength value))

393+ <> value

394+ in

395+ hcfoldMap (Proxy @OidOfField) each fields

396+

397+ in

398+ composite . encoders . toRecord . getComposite

399+

400+-- | The object identifier of a `PGType`.

401+--

402+-- >>> :set -XTypeApplications

403+-- >>> oidOf @'PGbool

404+-- Oid 16

405+class OidOf (ty :: PGType) where oidOf :: LibPQ.Oid

406+instance OidOf 'PGbool where oidOf = LibPQ.Oid 16

407+instance OidOf ('PGfixarray ns (null 'PGbool)) where oidOf = LibPQ.Oid 1000

408+instance OidOf ('PGvararray (null 'PGbool)) where oidOf = LibPQ.Oid 1000

409+instance OidOf 'PGint2 where oidOf = LibPQ.Oid 21

410+instance OidOf ('PGfixarray ns (null 'PGint2)) where oidOf = LibPQ.Oid 1005

411+instance OidOf ('PGvararray (null 'PGint2)) where oidOf = LibPQ.Oid 1005

412+instance OidOf 'PGint4 where oidOf = LibPQ.Oid 23

413+instance OidOf ('PGfixarray ns (null 'PGint4)) where oidOf = LibPQ.Oid 1007

414+instance OidOf ('PGvararray (null 'PGint4)) where oidOf = LibPQ.Oid 1007

415+instance OidOf 'PGint8 where oidOf = LibPQ.Oid 20

416+instance OidOf ('PGfixarray ns (null 'PGint8)) where oidOf = LibPQ.Oid 1016

417+instance OidOf ('PGvararray (null 'PGint8)) where oidOf = LibPQ.Oid 1016

418+instance OidOf 'PGnumeric where oidOf = LibPQ.Oid 1700

419+instance OidOf ('PGfixarray ns (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231

420+instance OidOf ('PGvararray (null 'PGnumeric)) where oidOf = LibPQ.Oid 1231

421+instance OidOf 'PGfloat4 where oidOf = LibPQ.Oid 700

422+instance OidOf ('PGfixarray ns (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021

423+instance OidOf ('PGvararray (null 'PGfloat4)) where oidOf = LibPQ.Oid 1021

424+instance OidOf 'PGfloat8 where oidOf = LibPQ.Oid 701

425+instance OidOf ('PGfixarray ns (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022

426+instance OidOf ('PGvararray (null 'PGfloat8)) where oidOf = LibPQ.Oid 1022

427+instance OidOf 'PGmoney where oidOf = LibPQ.Oid 790

428+instance OidOf ('PGfixarray ns (null 'PGmoney)) where oidOf = LibPQ.Oid 791

429+instance OidOf ('PGvararray (null 'PGmoney)) where oidOf = LibPQ.Oid 791

430+instance OidOf ('PGchar n) where oidOf = LibPQ.Oid 18

431+instance OidOf ('PGfixarray ns (null ('PGchar n))) where oidOf = LibPQ.Oid 1002

432+instance OidOf ('PGvararray (null ('PGchar n))) where oidOf = LibPQ.Oid 1002

433+instance OidOf ('PGvarchar n) where oidOf = LibPQ.Oid 1043

434+instance OidOf ('PGfixarray ns (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015

435+instance OidOf ('PGvararray (null ('PGvarchar n))) where oidOf = LibPQ.Oid 1015

436+instance OidOf 'PGtext where oidOf = LibPQ.Oid 25

437+instance OidOf ('PGfixarray ns (null 'PGtext)) where oidOf = LibPQ.Oid 1009

438+instance OidOf ('PGvararray (null 'PGtext)) where oidOf = LibPQ.Oid 1009

439+instance OidOf 'PGbytea where oidOf = LibPQ.Oid 17

440+instance OidOf ('PGfixarray ns (null 'PGbytea)) where oidOf = LibPQ.Oid 1001

441+instance OidOf ('PGvararray (null 'PGbytea)) where oidOf = LibPQ.Oid 1001

442+instance OidOf 'PGtimestamp where oidOf = LibPQ.Oid 1114

443+instance OidOf ('PGfixarray ns (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115

444+instance OidOf ('PGvararray (null 'PGtimestamp)) where oidOf = LibPQ.Oid 1115

445+instance OidOf 'PGtimestamptz where oidOf = LibPQ.Oid 1184

446+instance OidOf ('PGfixarray ns (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185

447+instance OidOf ('PGvararray (null 'PGtimestamptz)) where oidOf = LibPQ.Oid 1185

448+instance OidOf 'PGdate where oidOf = LibPQ.Oid 1082

449+instance OidOf ('PGfixarray ns (null 'PGdate)) where oidOf = LibPQ.Oid 1182

450+instance OidOf ('PGvararray (null 'PGdate)) where oidOf = LibPQ.Oid 1182

451+instance OidOf 'PGtime where oidOf = LibPQ.Oid 1083

452+instance OidOf ('PGfixarray ns (null 'PGtime)) where oidOf = LibPQ.Oid 1183

453+instance OidOf ('PGvararray (null 'PGtime)) where oidOf = LibPQ.Oid 1183

454+instance OidOf 'PGtimetz where oidOf = LibPQ.Oid 1266

455+instance OidOf ('PGfixarray ns (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270

456+instance OidOf ('PGvararray (null 'PGtimetz)) where oidOf = LibPQ.Oid 1270

457+instance OidOf 'PGinterval where oidOf = LibPQ.Oid 1186

458+instance OidOf ('PGfixarray ns (null 'PGinterval)) where oidOf = LibPQ.Oid 1187

459+instance OidOf ('PGvararray (null 'PGinterval)) where oidOf = LibPQ.Oid 1187

460+instance OidOf 'PGuuid where oidOf = LibPQ.Oid 2950

461+instance OidOf ('PGfixarray ns (null 'PGuuid)) where oidOf = LibPQ.Oid 2951

462+instance OidOf ('PGvararray (null 'PGuuid)) where oidOf = LibPQ.Oid 2951

463+instance OidOf 'PGinet where oidOf = LibPQ.Oid 869

464+instance OidOf ('PGfixarray ns (null 'PGinet)) where oidOf = LibPQ.Oid 1041

465+instance OidOf ('PGvararray (null 'PGinet)) where oidOf = LibPQ.Oid 1041

466+instance OidOf 'PGjson where oidOf = LibPQ.Oid 114

467+instance OidOf ('PGfixarray ns (null 'PGjson)) where oidOf = LibPQ.Oid 199

468+instance OidOf ('PGvararray (null 'PGjson)) where oidOf = LibPQ.Oid 199

469+instance OidOf 'PGjsonb where oidOf = LibPQ.Oid 3802

470+instance OidOf ('PGfixarray ns (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807

471+instance OidOf ('PGvararray (null 'PGjsonb)) where oidOf = LibPQ.Oid 3807

472+instance OidOf 'PGtsvector where oidOf = LibPQ.Oid 3614

473+instance OidOf ('PGfixarray ns (null 'PGtsvector)) where oidOf = LibPQ.Oid 3643

474+instance OidOf ('PGvararray (null 'PGtsvector)) where oidOf = LibPQ.Oid 3643

475+instance OidOf 'PGtsquery where oidOf = LibPQ.Oid 3615

476+instance OidOf ('PGfixarray ns (null 'PGtsquery)) where oidOf = LibPQ.Oid 3645

477+instance OidOf ('PGvararray (null 'PGtsquery)) where oidOf = LibPQ.Oid 3645

478+instance OidOf 'PGoid where oidOf = LibPQ.Oid 26

479+instance OidOf ('PGfixarray ns (null 'PGoid)) where oidOf = LibPQ.Oid 1028

480+instance OidOf ('PGvararray (null 'PGoid)) where oidOf = LibPQ.Oid 1028

481+instance OidOf ('PGrange 'PGint4) where oidOf = LibPQ.Oid 3904

482+instance OidOf ('PGfixarray ns (null ('PGrange 'PGint4))) where oidOf = LibPQ.Oid 3905

483+instance OidOf ('PGvararray (null ('PGrange 'PGint4))) where oidOf = LibPQ.Oid 3905

484+instance OidOf ('PGrange 'PGint8) where oidOf = LibPQ.Oid 3926

485+instance OidOf ('PGfixarray ns (null ('PGrange 'PGint8))) where oidOf = LibPQ.Oid 3927

486+instance OidOf ('PGvararray (null ('PGrange 'PGint8))) where oidOf = LibPQ.Oid 3927

487+instance OidOf ('PGrange 'PGnumeric) where oidOf = LibPQ.Oid 3906

488+instance OidOf ('PGfixarray ns (null ('PGrange 'PGnumeric))) where oidOf = LibPQ.Oid 3907

489+instance OidOf ('PGvararray (null ('PGrange 'PGnumeric))) where oidOf = LibPQ.Oid 3907

490+instance OidOf ('PGrange 'PGtimestamp) where oidOf = LibPQ.Oid 3908

491+instance OidOf ('PGfixarray ns (null ('PGrange 'PGtimestamp))) where oidOf = LibPQ.Oid 3909

492+instance OidOf ('PGvararray (null ('PGrange 'PGtimestamp))) where oidOf = LibPQ.Oid 3909

493+instance OidOf ('PGrange 'PGtimestamptz) where oidOf = LibPQ.Oid 3910

494+instance OidOf ('PGfixarray ns (null ('PGrange 'PGtimestamptz))) where oidOf = LibPQ.Oid 3911

495+instance OidOf ('PGvararray (null ('PGrange 'PGtimestamptz))) where oidOf = LibPQ.Oid 3911

496+instance OidOf ('PGrange 'PGdate) where oidOf = LibPQ.Oid 3912

497+instance OidOf ('PGfixarray ns (null ('PGrange 'PGdate))) where oidOf = LibPQ.Oid 3913

498+instance OidOf ('PGvararray (null ('PGrange 'PGdate))) where oidOf = LibPQ.Oid 3913

499+instance {-# OVERLAPPABLE #-} OidOf ('PGrange ty) where oidOf = LibPQ.invalidOid

500+instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGrange ty))) where oidOf = LibPQ.invalidOid

501+instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGrange ty))) where oidOf = LibPQ.invalidOid

502+instance {-# OVERLAPPABLE #-} OidOf ('PGcomposite row) where oidOf = LibPQ.invalidOid

503+instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGcomposite row))) where oidOf = LibPQ.invalidOid

504+instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGcomposite row))) where oidOf = LibPQ.invalidOid

505+instance {-# OVERLAPPABLE #-} OidOf ('PGenum labels) where oidOf = LibPQ.invalidOid

506+instance {-# OVERLAPPABLE #-} OidOf ('PGfixarray ns (null ('PGenum labels))) where oidOf = LibPQ.invalidOid

507+instance {-# OVERLAPPABLE #-} OidOf ('PGvararray (null ('PGenum labels))) where oidOf = LibPQ.invalidOid

508+

509+class OidOfParam (ty :: NullityType) where oidOfParam :: Oid

510+instance OidOf ty => OidOfParam (null ty) where oidOfParam = oidOf @ty

511+

512+-- | Lifts a `OidOf` constraint to a field.

513+class OidOfField (field :: (Symbol, NullityType)) where

514+ oidOfField :: Oid

515+instance OidOf ty => OidOfField (alias ::: nullity ty) where

516+ oidOfField = oidOf @ty

517+

518+-- | A `ToNullityParam` constraint gives an encoding of a Haskell `Type` into

519+-- into the binary format of a PostgreSQL `NullityType`.

520+class ToNullityParam (x :: Type) (ty :: NullityType) where

521+ toNullityParam :: x -> K (Maybe Encoding.Encoding) ty

522+instance ToParam x pg => ToNullityParam x ('NotNull pg) where

523+ toNullityParam = K . Just . unK . toParam @x @pg

524+instance ToParam x pg => ToNullityParam (Maybe x) ('Null pg) where

525+ toNullityParam = K . fmap (unK . toParam @x @pg)

526+

527+-- | A `ToField` constraint lifts the `ToParam` parser

528+-- to an encoding of a @(Symbol, Type)@ to a @(Symbol, NullityType)@,

529+-- encoding `Null`s to `Maybe`s. You should not define instances for

530+-- `FromField`, just use the provided instances.

531+class ToField (x :: (Symbol, Type)) (field :: (Symbol, NullityType)) where

532+ toField :: P x -> K (Maybe Encoding.Encoding) field

533+instance ToNullityParam x ty => ToField (alias ::: x) (alias ::: ty) where

534+ toField (P x) = K . unK $ toNullityParam @x @ty x

535+

536+-- | A `ToFixArray` constraint gives an encoding of a Haskell `Type`

537+-- into the binary format of a PostgreSQL fixed-length array.

538+-- You should not define instances for

539+-- `ToFixArray`, just use the provided instances.

540+class ToFixArray (x :: Type) (dims :: [Nat]) (array :: NullityType) where

541+ toFixArray :: x -> K (K Encoding.Array dims) array

542+instance ToNullityParam x ty => ToFixArray x '[] ty where

543+ toFixArray = K . K . maybe Encoding.nullArray Encoding.encodingArray . unK

544+ . toNullityParam @x @ty

545+instance

546+ ( IsProductType product xs

547+ , Length xs ~ dim

548+ , All ((~) x) xs

549+ , ToFixArray x dims ty )

550+ => ToFixArray product (dim ': dims) ty where

551+ toFixArray = K . K . Encoding.dimensionArray foldlN

552+ (unK . unK . toFixArray @x @dims @ty) . unZ . unSOP . from

140553

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

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

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

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

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

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

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

@@ -152,115 +565,257 @@ class SListI tys => ToParams (x :: Type) (tys :: [NullityType]) where

152565 -- >>> instance Generic Tuple

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

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

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

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

157570 => ToParams x tys where

158571 toParams

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

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

160573 . unZ . unSOP . from

161574

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

180597instance FromValue 'PGbytea Strict.ByteString where

181− fromValue _ = Decoding.bytea_strict

598+ fromValue = Decoding.bytea_strict

182599instance FromValue 'PGbytea Lazy.ByteString where

183− fromValue _ = Decoding.bytea_lazy

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

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

186603instance FromValue 'PGtimetz (TimeOfDay, TimeZone) where

187− fromValue _ = Decoding.timetz_int

604+ fromValue = Decoding.timetz_int

188605instance FromValue 'PGtimestamp LocalTime where

189− fromValue _ = Decoding.timestamp_int

606+ fromValue = Decoding.timestamp_int

190607instance FromValue 'PGtimestamptz UTCTime where

191− fromValue _ = Decoding.timestamptz_int

608+ fromValue = Decoding.timestamptz_int

192609instance FromValue 'PGinterval DiffTime where

193− fromValue _ = Decoding.interval_int

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

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

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

197− fromValue _ = Decoding.array

198− (Decoding.dimensionArray Vector.replicateM

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

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

201− fromValue _ = Decoding.array

202− (Decoding.dimensionArray Vector.replicateM

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

204−

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

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

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)

654+instance

655+ ( IsEnumType y

656+ , HasDatatypeInfo y

657+ , LabelsPG y ~ labels

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

659+ fromValue =

660+ let

661+ greadConstructor

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

663+ => NP ConstructorInfo xss

664+ -> String

665+ -> Maybe (SOP I xss)

666+ greadConstructor Nil _ = Nothing

667+ greadConstructor (constructor :* constructors) name =

668+ if name == constructorName constructor

669+ then Just (SOP (Z Nil))

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

671+ in

672+ fmap Enumerated

673+ . Decoding.enum

674+ $ fmap to

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

676+ . Strict.Text.unpack

677+instance

678+ ( FromRow fields y

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

680+ fromValue =

681+ let

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

683+ -- [for each field]

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

685+ -- [if value is NULL]

686+ -- <-1: 4 bytes>

687+ -- [else]

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

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

690+ -- [end if]

691+ -- [end for]

692+ composite = Decoding.valueParser $ do

693+ unitOfSize 4

694+ hsequence' $ hpure $ Comp $ do

695+ unitOfSize 4

696+ len <- sized 4 Decoding.int

697+ if len == -1

698+ then return (K Nothing)

699+ else K . Just <$> bytesOfSize len

700+ in

701+ fmap Composite (Decoding.fn (fromRow @fields <=< composite))

702+

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

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

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

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

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

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

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

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

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

214− -- Id {getId = 1}

215− --

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

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

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

219711instance FromValue pg y

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

221− fromColumnValue = \case

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

223− K (Just bytes) ->

224− let

225− errOrValue =

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

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

228− in

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

230717instance FromValue pg y

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

232− fromColumnValue (K nullOrBytes)

233− = either err id

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

235− <$> nullOrBytes

236− where

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

238745

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

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

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

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

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

243750-- provide `FromRow` instances.

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

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

245752 -- | >>> :set -XOverloadedStrings

246753 -- >>> import Data.Text

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

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

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

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

250757 -- >>> instance Generic UserRow

251758 -- >>> instance HasDatatypeInfo UserRow

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

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

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

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

256763instance

257− ( SListI results

258− , IsProductType y ys

259− , AllZip FromColumnValue results ys

260− , SameFields (DatatypeInfoOf y) results

261− ) => FromRow results y where

764+ ( SListI result

765+ , IsRecord y ys

766+ , AllZip FromField result ys

767+ ) => FromRow result y where

262768 fromRow

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

264819

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

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

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

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

271826--

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

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

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

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

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

276831instance Generic (Only x)

277832instance 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+29−700

@@ -9,745 +9,74 @@ Squeal data definition language.

99-}

1010

1111{-# LANGUAGE

12− ConstraintKinds

13− , DataKinds

14− , DeriveDataTypeable

12+ AllowAmbiguousTypes

13+ , ConstraintKinds

14+ , DeriveAnyClass

1515 , DeriveGeneric

16+ , DerivingStrategies

1617 , FlexibleContexts

1718 , FlexibleInstances

1819 , GADTs

19− , GeneralizedNewtypeDeriving

20− , KindSignatures

2120 , LambdaCase

2221 , MultiParamTypeClasses

22+ , OverloadedLabels

2323 , OverloadedStrings

2424 , RankNTypes

2525 , ScopedTypeVariables

26− , StandaloneDeriving

2726 , TypeApplications

2827 , TypeInType

2928 , TypeOperators

29+ , UndecidableSuperClasses

30+ , UndecidableInstances

3031#-}

3132

3233module Squeal.PostgreSQL.Definition

33− ( -- * Definition

34− Definition (UnsafeDefinition, renderDefinition)

34+ ( -- * Definition

35+ Definition (..)

3536 , (>>>)

36− -- * Create

37− , createTable

38− , createTableIfNotExists

39− , TableConstraintExpression (..)

40− , check

41− , unique

42− , primaryKey

43− , foreignKey

44− , ForeignKeyed

45− , OnDeleteClause (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade)

46− , renderOnDeleteClause

47− , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)

48− , renderOnUpdateClause

49− -- * Drop

50− , dropTable

51− -- * Alter

52− , alterTable

53− , alterTableRename

54− , AlterTable (UnsafeAlterTable, renderAlterTable)

55− , addConstraint

56− , dropConstraint

57− , AddColumn (addColumn)

58− , dropColumn

59− , renameColumn

60− , alterColumn

61− , AlterColumn (UnsafeAlterColumn, renderAlterColumn)

62− , setDefault

63− , dropDefault

64− , setNotNull

65− , dropNotNull

66− , alterType

67− -- * Views

68− , createView

69− , dropView

37+ , manipDefinition

7038 ) where

7139

7240import Control.Category

7341import Control.DeepSeq

7442import Data.ByteString

7543import Data.Monoid

76−import GHC.TypeLits

7744import Prelude hiding ((.), id)

7845

79−import qualified Generics.SOP as SOP

8046import qualified GHC.Generics as GHC

8147

82−import Squeal.PostgreSQL.Expression

83−import Squeal.PostgreSQL.Query

48+import Squeal.PostgreSQL.Manipulation

8449import Squeal.PostgreSQL.Render

8550import Squeal.PostgreSQL.Schema

8651

52+-- $setup

53+-- >>> import Squeal.PostgreSQL

54+

8755{-----------------------------------------

8856statements

8957-----------------------------------------}

9058

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

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

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

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

9462newtype Definition

95− (schema0 :: SchemaType)

96− (schema1 :: SchemaType)

63+ (schemas0 :: SchemasType)

64+ (schemas1 :: SchemasType)

9765 = UnsafeDefinition { renderDefinition :: ByteString }

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

9967

68+instance RenderSQL (Definition schemas0 schemas1) where

69+ renderSQL = renderDefinition

70+

10071instance Category Definition where

10172 id = UnsafeDefinition ";"

10273 ddl1 . ddl0 = UnsafeDefinition $

103− renderDefinition ddl0 <+> renderDefinition ddl1

104−

105−{-----------------------------------------

106−CREATE statements

107−-----------------------------------------}

108−

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

110−--

111−-- >>> :set -XOverloadedLabels

112−-- >>> :{

113−-- renderDefinition $

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

115−-- :}

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

117−createTable

118− :: ( KnownSymbol table

119− , columns ~ (col ': cols)

120− , SOP.SListI columns

121− , SOP.SListI constraints

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

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

124− -> NP (Aliased TypeExpression) columns

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

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

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

128− -> Definition schema0 schema1

129−createTable tab columns constraints = UnsafeDefinition $

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

131−

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

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

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

135−--

136−-- >>> :set -XOverloadedLabels -XTypeApplications

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

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

139−-- >>> :{

140−-- renderDefinition

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

142−-- :}

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

144−createTableIfNotExists

145− :: ( Has table (TablesOf schema) (constraints :=> columns)

146− , SOP.SListI columns

147− , SOP.SListI constraints )

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

149− -> NP (Aliased TypeExpression) columns

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

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

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

153− -> Definition schema schema

154−createTableIfNotExists tab columns constraints = UnsafeDefinition $

155− "CREATE TABLE IF NOT EXISTS"

156− <+> renderCreation tab columns constraints

157−

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

159−renderCreation

160− :: ( KnownSymbol table

161− , SOP.SListI columns

162− , SOP.SListI constraints )

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

164− -> NP (Aliased TypeExpression) columns

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

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

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

168− -> ByteString

169−renderCreation tab columns constraints = renderAlias tab

170− <+> parenthesized

171− ( renderCommaSeparated renderColumnDef columns

172− <> ( case constraints of

173− Nil -> ""

174− _ -> ", " <>

175− renderCommaSeparated renderConstraint constraints ) )

176− <> ";"

177− where

178− renderColumnDef :: Aliased TypeExpression x -> ByteString

179− renderColumnDef (ty `As` column) =

180− renderAlias column <+> renderTypeExpression ty

181− renderConstraint

182− :: Aliased (TableConstraintExpression schema columns) constraint

183− -> ByteString

184− renderConstraint (constraint `As` alias) =

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

186−

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

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

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

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

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

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

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

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

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

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

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

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

199−newtype TableConstraintExpression

200− (schema :: SchemaType)

201− (table :: Symbol)

202− (tableConstraint :: TableConstraint)

203− = UnsafeTableConstraintExpression

204− { renderTableConstraintExpression :: ByteString }

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

206−

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

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

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

210−--

211−-- >>> :{

212−-- type Schema = '[

213−-- "tab" ::: '[ "inequality" ::: 'Check '["a","b"]] :=> '[

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

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

216−-- ]]

217−-- :}

218−--

219−-- >>> :{

220−-- let

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

222−-- definition = createTable #tab

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

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

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

226−-- :}

227−--

228−-- >>> renderDefinition definition

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

230−check

231− :: ( Has alias (TablesOf schema) table

232− , HasAll aliases (TableToColumns table) subcolumns )

233− => NP Alias aliases

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

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

236−check _cols condition = UnsafeTableConstraintExpression $

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

238−

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

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

241−--

242−-- >>> :{

243−-- type Schema = '[

244−-- "tab" ::: '[ "uq_a_b" ::: 'Unique '["a","b"]] :=> '[

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

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

247−-- ]]

248−-- :}

249−--

250−-- >>> :{

251−-- let

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

253−-- definition = createTable #tab

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

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

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

257−-- :}

258−--

259−-- >>> renderDefinition definition

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

261−unique

262− :: ( Has alias (TablesOf schema) table

263− , HasAll aliases (TableToColumns table) subcolumns )

264− => NP Alias aliases

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

266−unique columns = UnsafeTableConstraintExpression $

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

268−

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

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

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

272−--

273−-- >>> :{

274−-- type Schema = '[

275−-- "tab" ::: '[ "pk_id" ::: 'PrimaryKey '["id"]] :=> '[

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

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

278−-- ]]

279−-- :}

280−--

281−-- >>> :{

282−-- let

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

284−-- definition = createTable #tab

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

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

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

288−-- :}

289−--

290−-- >>> renderDefinition definition

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

292−primaryKey

293− :: ( Has alias (TablesOf schema) table

294− , HasAll aliases (TableToColumns table) subcolumns

295− , AllNotNull subcolumns )

296− => NP Alias aliases

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

298−primaryKey columns = UnsafeTableConstraintExpression $

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

300−

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

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

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

304−-- between two related tables.

305−--

306−-- >>> :{

307−-- type Schema =

308−-- '[ "users" :::

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

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

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

312−-- ]

313−-- , "emails" :::

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

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

316−-- ] :=>

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

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

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

320−-- ]

321−-- ]

322−-- :}

323−--

324−-- >>> :{

325−-- let

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

327−-- setup =

328−-- createTable #users

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

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

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

332−-- createTable #emails

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

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

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

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

337−-- foreignKey #user_id #users #id

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

339−-- in renderDefinition setup

340−-- :}

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

342−--

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

344−--

345−-- >>> :{

346−-- type Schema =

347−-- '[ "employees" :::

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

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

350−-- ] :=>

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

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

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

354−-- ]

355−-- ]

356−-- :}

357−--

358−-- >>> :{

359−-- let

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

361−-- setup =

362−-- createTable #employees

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

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

365−-- integer `As` #employer_id :* Nil )

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

367−-- foreignKey #employer_id #employees #id

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

369−-- in renderDefinition setup

370−-- :}

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

372−--

373−foreignKey

374− :: (ForeignKeyed schema child parent

375− table reftable

376− columns refcolumns

377− constraints cols

378− reftys tys )

379− => NP Alias columns

380− -- ^ column or columns in the table

381− -> Alias parent

382− -- ^ reference table

383− -> NP Alias refcolumns

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

385− -> OnDeleteClause

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

387− -> OnUpdateClause

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

389− -> TableConstraintExpression schema child

390− ('ForeignKey columns parent refcolumns)

391−foreignKey keys parent refs ondel onupd = UnsafeTableConstraintExpression $

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

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

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

395− <+> renderOnDeleteClause ondel

396− <+> renderOnUpdateClause onupd

397−

398−type ForeignKeyed schema

399− child parent

400− table reftable

401− columns refcolumns

402− constraints cols

403− reftys tys =

404− ( Has child (TablesOf schema) table

405− , Has parent (TablesOf schema) reftable

406− , HasAll columns (TableToColumns table) tys

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

408− , HasAll refcolumns cols reftys

409− , SOP.AllZip SamePGType tys reftys

410− , Uniquely refcolumns constraints )

411−

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

413−data OnDeleteClause

414− = OnDeleteNoAction

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

416− -- an error is raised

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

418− | OnDeleteCascade

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

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

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

422−instance NFData OnDeleteClause

423−

424−-- | Render `OnDeleteClause`.

425−renderOnDeleteClause :: OnDeleteClause -> ByteString

426−renderOnDeleteClause = \case

427− OnDeleteNoAction -> "ON DELETE NO ACTION"

428− OnDeleteRestrict -> "ON DELETE RESTRICT"

429− OnDeleteCascade -> "ON DELETE CASCADE"

430−

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

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

433−data OnUpdateClause

434− = OnUpdateNoAction

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

436− -- an error is raised

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

438− | OnUpdateCascade

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

440− -- into the referencing row(s)

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

442−instance NFData OnUpdateClause

443−

444−-- | Render `OnUpdateClause`.

445−renderOnUpdateClause :: OnUpdateClause -> ByteString

446−renderOnUpdateClause = \case

447− OnUpdateNoAction -> "ON UPDATE NO ACTION"

448− OnUpdateRestrict -> "ON UPDATE RESTRICT"

449− OnUpdateCascade -> "ON UPDATE CASCADE"

450−

451−{-----------------------------------------

452−DROP statements

453−-----------------------------------------}

454−

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

456−--

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

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

459−dropTable

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

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

462− -> Definition schema (Drop table schema)

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

464−

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

466−ALTER statements

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

468−

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

470−alterTable

471− :: KnownSymbol alias

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

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

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

475−alterTable tab alteration = UnsafeDefinition $

476− "ALTER TABLE"

477− <+> renderAlias tab

478− <+> renderAlterTable alteration

479− <> ";"

480−

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

482−--

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

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

485−alterTableRename

486− :: (KnownSymbol table0, KnownSymbol table1)

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

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

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

490−alterTableRename table0 table1 = UnsafeDefinition $

491− "ALTER TABLE" <+> renderAlias table0

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

493−

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

495−-- of a table.

496−newtype AlterTable

497− (alias :: Symbol)

498− (table :: TableType)

499− (schema :: SchemaType) =

500− UnsafeAlterTable {renderAlterTable :: ByteString}

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

502−

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

504−--

505−-- >>> :{

506−-- let

507−-- definition :: Definition

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

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

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

511−-- in renderDefinition definition

512−-- :}

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

514−addConstraint

515− :: ( KnownSymbol alias

516− , Has tab (TablesOf schema) table0

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

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

519− => Alias alias

520− -> TableConstraintExpression schema tab constraint

521− -- ^ constraint to add

522− -> AlterTable tab table1 schema

523−addConstraint alias constraint = UnsafeAlterTable $

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

525− <+> renderTableConstraintExpression constraint

526−

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

528−--

529−-- >>> :{

530−-- let

531−-- definition :: Definition

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

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

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

535−-- in renderDefinition definition

536−-- :}

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

538−dropConstraint

539− :: ( KnownSymbol constraint

540− , Has tab (TablesOf schema) table0

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

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

543− => Alias constraint

544− -- ^ constraint to drop

545− -> AlterTable tab table1 schema

546−dropConstraint constraint = UnsafeAlterTable $

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

548−

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

550−class AddColumn ty where

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

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

553− --

554− -- >>> :{

555− -- let

556− -- definition :: Definition

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

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

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

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

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

562− -- in renderDefinition definition

563− -- :}

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

565− --

566− -- >>> :{

567− -- let

568− -- definition :: Definition

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

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

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

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

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

574− -- in renderDefinition definition

575− -- :}

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

577− addColumn

578− :: ( KnownSymbol column

579− , Has tab (TablesOf schema) table0

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

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

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

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

584− -> AlterTable tab table1 schema

585− addColumn column ty = UnsafeAlterTable $

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

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

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

589−

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

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

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

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

594−--

595−-- >>> :{

596−-- let

597−-- definition :: Definition

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

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

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

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

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

603−-- in renderDefinition definition

604−-- :}

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

606−dropColumn

607− :: ( KnownSymbol column

608− , Has tab (TablesOf schema) table0

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

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

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

612− -> AlterTable tab table1 schema

613−dropColumn column = UnsafeAlterTable $

614− "DROP COLUMN" <+> renderAlias column

615−

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

617−--

618−-- >>> :{

619−-- let

620−-- definition :: Definition

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

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

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

624−-- in renderDefinition definition

625−-- :}

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

627−renameColumn

628− :: ( KnownSymbol column0

629− , KnownSymbol column1

630− , Has tab (TablesOf schema) table0

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

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

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

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

635− -> AlterTable tab table1 schema

636−renameColumn column0 column1 = UnsafeAlterTable $

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

638−

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

640−alterColumn

641− :: ( KnownSymbol column

642− , Has tab (TablesOf schema) table0

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

644− , Has column columns ty0

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

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

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

648− -> AlterTable tab table1 schema

649−alterColumn column alteration = UnsafeAlterTable $

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

651−

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

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

654− UnsafeAlterColumn {renderAlterColumn :: ByteString}

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

656−

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

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

659−-- future insert and update commands.

660−--

661−-- >>> :{

662−-- let

663−-- definition :: Definition

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

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

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

667−-- in renderDefinition definition

668−-- :}

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

670−setDefault

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

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

673−setDefault expression = UnsafeAlterColumn $

674− "SET DEFAULT" <+> renderExpression expression

675−

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

677−--

678−-- >>> :{

679−-- let

680−-- definition :: Definition

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

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

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

684−-- in renderDefinition definition

685−-- :}

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

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

688−dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"

689−

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

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

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

693−--

694−-- >>> :{

695−-- let

696−-- definition :: Definition

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

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

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

700−-- in renderDefinition definition

701−-- :}

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

703−setNotNull

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

705−setNotNull = UnsafeAlterColumn $ "SET NOT NULL"

706−

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

708−--

709−-- >>> :{

710−-- let

711−-- definition :: Definition

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

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

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

715−-- in renderDefinition definition

716−-- :}

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

718−dropNotNull

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

720−dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"

721−

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

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

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

725−--

726−-- >>> :{

727−-- let

728−-- definition :: Definition

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

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

731−-- definition =

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

733−-- in renderDefinition definition

734−-- :}

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

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

737−alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderTypeExpression ty

738−

739−createView

740− :: KnownSymbol view

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

742− -> Query schema '[] relation

743− -- ^ query

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

745−createView alias query = UnsafeDefinition $

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

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

748−

749−dropView

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

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

752− -> Definition schema (Drop view schema)

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

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+362−1107

@@ -1,19 +1,17 @@

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

14− , DataKinds

13+ , ConstraintKinds

1514 , DeriveGeneric

16− , DeriveDataTypeable

1715 , FlexibleContexts

1816 , FlexibleInstances

1917 , FunctionalDependencies

@@ -22,8 +20,6 @@ Squeal expressions are the atoms used to build statements.

2220 , LambdaCase

2321 , MagicHash

2422 , OverloadedStrings

25− , PolyKinds

26− , RankNTypes

2723 , ScopedTypeVariables

2824 , StandaloneDeriving

2925 , TypeApplications

@@ -31,366 +27,356 @@ Squeal expressions are the atoms used to build statements.

3127 , TypeInType

3228 , TypeOperators

3329 , UndecidableInstances

30+ , RankNTypes

3431#-}

3532

36−module Squeal.PostgreSQL.Expression

33+module Squeal.PostgreSQL.Expression

3734 ( -- * Expression

38− Expression (UnsafeExpression, renderExpression)

39− , HasParameter (param)

40− -- ** Null

41− , null_

42− , unNull

43− , coalesce

44− , fromNull

45− , isNull

46− , isn'tNull

47− , matchNull

48− , nullIf

49− -- ** Arrays

50− , array

51− -- ** Functions

52− , unsafeBinaryOp

53− , unsafeUnaryOp

35+ Expression (..)

36+ , Expr

37+ , type (-->)

38+ , FunctionDB

5439 , unsafeFunction

55− , atan2_

56− , cast

57− , quot_

58− , rem_

59− , trunc

60− , round_

61− , ceiling_

62− , greatest

63− , least

64− -- ** Conditions

65− , Condition

66− , true

67− , false

68− , not_

69− , (.&&)

70− , (.||)

71− , caseWhenThenElse

72− , ifThenElse

73− , (.==)

74− , (./=)

75− , (.>=)

76− , (.<)

77− , (.<=)

78− , (.>)

79− -- ** Time

80− , currentDate

81− , currentTime

82− , currentTimestamp

83− , localTime

84− , localTimestamp

85− -- ** Text

86− , lower

87− , upper

88− , charLength

89− , like

90− -- ** Aggregation

91− , unsafeAggregate, unsafeAggregateDistinct

92− , sum_, sumDistinct

93− , PGAvg (avg, avgDistinct)

94− , bitAnd, bitOr, boolAnd, boolOr

95− , bitAndDistinct, bitOrDistinct, boolAndDistinct, boolOrDistinct

96− , countStar

97− , count, countDistinct

98− , every, everyDistinct

99− , max_, maxDistinct, min_, minDistinct

100− -- * Tables

101− , Table (UnsafeTable, renderTable)

102− , View (UnsafeView, renderView)

103− -- * Types

104− , TypeExpression (UnsafeTypeExpression, renderTypeExpression)

105− , PGTyped (pgtype)

106− , bool

107− , int2

108− , smallint

109− , int4

110− , int

111− , integer

112− , int8

113− , bigint

114− , numeric

115− , float4

116− , real

117− , float8

118− , doublePrecision

119− , serial2

120− , smallserial

121− , serial4

122− , serial

123− , serial8

124− , bigserial

125− , text

126− , char

127− , character

128− , varchar

129− , characterVarying

130− , bytea

131− , timestamp

132− , timestampWithTimeZone

133− , date

134− , time

135− , timeWithTimeZone

136− , interval

137− , uuid

138− , inet

139− , json

140− , jsonb

141− , vararray

142− , fixarray

143− , notNull

144− , default_

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

14557 -- * Re-export

14658 , (&)

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

59+ , K (..)

60+ , unK

14861 ) where

14962

15063import Control.Category

15164import Control.DeepSeq

15265import Data.ByteString (ByteString)

15366import Data.Function ((&))

154−import Data.Monoid hiding (All)

155−import Data.Ratio

67+import Data.Semigroup hiding (All)

15668import Data.String

157−import Generics.SOP hiding (from)

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

15870import GHC.OverloadedLabels

15971import GHC.TypeLits

72+import Numeric

16073import Prelude hiding (id, (.))

16174

16275import qualified GHC.Generics as GHC

16376

77+import Squeal.PostgreSQL.Alias

78+import Squeal.PostgreSQL.List

16479import Squeal.PostgreSQL.Render

16580import Squeal.PostgreSQL.Schema

16681

82+-- $setup

83+-- >>> import Squeal.PostgreSQL

84+

16785{-----------------------------------------

16886column expressions

16987-----------------------------------------}

17088

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

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

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

17493`Squeal.PostgreSQL.Manipulation.update`,

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

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

17695

17796The expression syntax allows the calculation of

17897values from primitive expression using arithmetic, logical,

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

180113-}

181114newtype Expression

182− (relations :: RelationsType)

183− (grouping :: Grouping)

115+ (outer :: FromType)

116+ (commons :: FromType)

117+ (grp :: Grouping)

118+ (schemas :: SchemasType)

184119 (params :: [NullityType])

120+ (from :: FromType)

185121 (ty :: NullityType)

186122 = UnsafeExpression { renderExpression :: ByteString }

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

188−

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

190−supplied externally to a SQL statement.

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

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

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

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

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

196181-}

197−class (PGTyped (PGTypeOf ty), KnownNat n) => HasParameter

198− (n :: Nat)

199− (params :: [NullityType])

200− (ty :: NullityType)

201− | n params -> ty where

202− param :: Expression relations grouping params ty

203− param = UnsafeExpression $ parenthesized $

204− "$" <> renderNat (Proxy @n) <+> "::"

205− <+> renderTypeExpression (pgtype @(PGTypeOf ty))

206−instance {-# OVERLAPPING #-} PGTyped (PGTypeOf ty1)

207− => HasParameter 1 (ty1:tys) ty1

208−instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)

209− => HasParameter n (ty' : params) ty

210−

211−instance (HasUnique relation relations columns, Has column columns ty)

212− => IsLabel column (Expression relations 'Ungrouped params ty) where

213− fromLabel = UnsafeExpression $ renderAlias (Alias @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

214245

215−instance (Has relation relations columns, Has column columns ty)

216− => IsQualified relation column (Expression relations 'Ungrouped params ty) where

217− relation ! column = UnsafeExpression $

218− renderAlias relation <> "." <> renderAlias column

219−

220246instance

221− ( HasUnique relation relations columns

222− , Has column columns ty

223− , GroupedBy relation column bys

224− ) => IsLabel column

225− (Expression relations ('Grouped bys) params ty) where

226− fromLabel = UnsafeExpression $ renderAlias (Alias @column)

227−

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)

228253instance

229− ( Has relation relations columns

230− , Has column columns ty

231− , GroupedBy relation column bys

232− ) => IsQualified relation column

233− (Expression relations ('Grouped bys) params ty) where

234− relation ! column = UnsafeExpression $

235− renderAlias relation <> "." <> renderAlias column

236−

237−-- | analagous to `Nothing`

238−--

239−-- >>> renderExpression $ null_

240−-- "NULL"

241−null_ :: Expression relations grouping params ('Null ty)

242−null_ = UnsafeExpression "NULL"

243−

244−-- | analagous to `Just`

245−--

246−-- >>> renderExpression $ unNull true

247−-- "TRUE"

248−unNull

249− :: Expression relations grouping params ('NotNull ty)

250− -- ^ not @NULL@

251− -> Expression relations grouping params ('Null ty)

252−unNull = UnsafeExpression . renderExpression

253−

254−-- | return the leftmost value which is not NULL

255−--

256−-- >>> renderExpression $ coalesce [null_, unNull true] false

257−-- "COALESCE(NULL, TRUE, FALSE)"

258−coalesce

259− :: [Expression relations grouping params ('Null ty)]

260− -- ^ @NULL@s may be present

261− -> Expression relations grouping params ('NotNull ty)

262− -- ^ @NULL@ is absent

263− -> Expression relations grouping params ('NotNull ty)

264−coalesce nullxs notNullx = UnsafeExpression $

265− "COALESCE" <> parenthesized (commaSeparated

266− ((renderExpression <$> nullxs) <> [renderExpression notNullx]))

267−

268−-- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@

269−--

270−-- >>> renderExpression $ fromNull true null_

271−-- "COALESCE(NULL, TRUE)"

272−fromNull

273− :: Expression relations grouping params ('NotNull ty)

274− -- ^ what to convert @NULL@ to

275− -> Expression relations grouping params ('Null ty)

276− -> Expression relations grouping params ('NotNull ty)

277−fromNull notNullx nullx = coalesce [nullx] notNullx

278−

279−-- | >>> renderExpression $ null_ & isNull

280−-- "NULL IS NULL"

281−isNull

282− :: Expression relations grouping params ('Null ty)

283− -- ^ possibly @NULL@

284− -> Condition relations grouping params

285−isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL"

286−

287−-- | >>> renderExpression $ null_ & isn'tNull

288−-- "NULL IS NOT NULL"

289−isn'tNull

290− :: Expression relations grouping params ('Null ty)

291− -- ^ possibly @NULL@

292− -> Condition relations grouping params

293−isn'tNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL"

294−

295−-- | analagous to `maybe` using @IS NULL@

296−--

297−-- >>> renderExpression $ matchNull true not_ null_

298−-- "CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END"

299−matchNull

300− :: Expression relations grouping params (nullty)

301− -- ^ what to convert @NULL@ to

302− -> ( Expression relations grouping params ('NotNull ty)

303− -> Expression relations grouping params (nullty) )

304− -- ^ function to perform when @NULL@ is absent

305− -> Expression relations grouping params ('Null ty)

306− -> Expression relations grouping params (nullty)

307−matchNull y f x = ifThenElse (isNull x) y

308− (f (UnsafeExpression (renderExpression x)))

309−

310−-- | right inverse to `fromNull`, if its arguments are equal then

311−-- `nullIf` gives @NULL@.

312−--

313−-- >>> :set -XTypeApplications -XDataKinds

314−-- >>> renderExpression @_ @_ @'[_] $ fromNull false (nullIf false (param @1))

315−-- "COALESCE(NULL IF (FALSE, ($1 :: bool)), FALSE)"

316−nullIf

317− :: Expression relations grouping params ('NotNull ty)

318− -- ^ @NULL@ is absent

319− -> Expression relations grouping params ('NotNull ty)

320− -- ^ @NULL@ is absent

321− -> Expression relations grouping params ('Null ty)

322−nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized

323− (renderExpression x <> ", " <> renderExpression y)

324−

325−-- | >>> renderExpression $ array [null_, unNull false, unNull true]

326−-- "ARRAY[NULL, FALSE, TRUE]"

327−array

328− :: [Expression relations grouping params ('Null ty)]

329− -- ^ array elements

330− -> Expression relations grouping params (nullity ('PGvararray ty))

331−array xs = UnsafeExpression $

332− "ARRAY[" <> commaSeparated (renderExpression <$> xs) <> "]"

333−

334−instance Monoid

335− (Expression relations grouping params (nullity ('PGvararray ty))) where

336− mempty = array []

337− mappend = unsafeBinaryOp "||"

338−

339−-- | >>> renderExpression @_ @_ @'[_] $ greatest currentTimestamp [param @1]

340−-- "GREATEST(CURRENT_TIMESTAMP, ($1 :: timestamp with time zone))"

341−greatest

342− :: Expression relations grouping params (nullty)

343− -- ^ needs at least 1 argument

344− -> [Expression relations grouping params (nullty)]

345− -- ^ or more

346− -> Expression relations grouping params (nullty)

347−greatest x xs = UnsafeExpression $ "GREATEST("

348− <> commaSeparated (renderExpression <$> (x:xs)) <> ")"

349−

350−-- | >>> renderExpression $ least currentTimestamp [null_]

351−-- "LEAST(CURRENT_TIMESTAMP, NULL)"

352−least

353− :: Expression relations grouping params (nullty)

354− -- ^ needs at least 1 argument

355− -> [Expression relations grouping params (nullty)]

356− -- ^ or more

357− -> Expression relations grouping params (nullty)

358−least x xs = UnsafeExpression $ "LEAST("

359− <> commaSeparated (renderExpression <$> (x:xs)) <> ")"

254+ ( HasUnique tab (Join outer from) row

255+ , Has col row ty

256+ , GroupedBy tab col bys

257+ , tys ~ '[ty]

258+ ) => IsLabel col

259+ (NP (Expression outer commons ('Grouped bys) schemas params from) tys) where

260+ fromLabel = fromLabel @col :* Nil

261+instance

262+ ( HasUnique tab (Join outer from) row

263+ , Has col row ty

264+ , GroupedBy tab col bys

265+ , column ~ (col ::: ty)

266+ ) => IsLabel col

267+ (Aliased (Expression outer commons ('Grouped bys) schemas params from) column) where

268+ fromLabel = fromLabel @col `As` Alias

269+instance

270+ ( HasUnique tab (Join outer from) row

271+ , Has col row ty

272+ , GroupedBy tab col bys

273+ , columns ~ '[col ::: ty]

274+ ) => IsLabel col

275+ (NP (Aliased (Expression outer commons ('Grouped bys) schemas params from)) columns) where

276+ fromLabel = fromLabel @col :* Nil

360277

361−-- | >>> renderExpression $ unsafeBinaryOp "OR" true false

362−-- "(TRUE OR FALSE)"

363−unsafeBinaryOp

364− :: ByteString

365− -- ^ operator

366− -> Expression relations grouping params (ty0)

367− -> Expression relations grouping params (ty1)

368− -> Expression relations grouping params (ty2)

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

310+

311+instance (KnownSymbol label, label `In` labels) => IsPGlabel label

312+ (Expression outer commons grp schemas params from (null ('PGenum labels))) where

313+ label = UnsafeExpression $ renderSQL (PGlabel @label)

314+

315+-- | >>> printSQL $ unsafeBinaryOp "OR" true false

316+-- (TRUE OR FALSE)

317+unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2

369318unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $

370− renderExpression x <+> op <+> renderExpression y

371−

372−-- | >>> renderExpression $ unsafeUnaryOp "NOT" true

373−-- "(NOT TRUE)"

374−unsafeUnaryOp

375− :: ByteString

376− -- ^ operator

377− -> Expression relations grouping params (ty0)

378− -> Expression relations grouping params (ty1)

379−unsafeUnaryOp op x = UnsafeExpression $ parenthesized $

380− op <+> renderExpression x

381−

382−-- | >>> renderExpression $ unsafeFunction "f" true

383−-- "f(TRUE)"

384−unsafeFunction

385− :: ByteString

386− -- ^ function

387− -> Expression relations grouping params (xty)

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

389355unsafeFunction fun x = UnsafeExpression $

390− fun <> parenthesized (renderExpression x)

391−

392−instance PGNum ty

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

394380 (+) = unsafeBinaryOp "+"

395381 (-) = unsafeBinaryOp "-"

396382 (*) = unsafeBinaryOp "*"

@@ -401,19 +387,24 @@ instance PGNum ty

401387 . fromString

402388 . show

403389

404−instance (PGNum ty, PGFloating ty) => Fractional

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

406392 (/) = unsafeBinaryOp "/"

407− fromRational x = fromInteger (numerator x) / fromInteger (denominator x)

393+ fromRational

394+ = UnsafeExpression

395+ . fromString

396+ . ($ "")

397+ . showFFloat Nothing

398+ . fromRat @Double

408399

409−instance (PGNum ty, PGFloating ty) => Floating

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

411402 pi = UnsafeExpression "pi()"

412403 exp = unsafeFunction "exp"

413404 log = unsafeFunction "ln"

414405 sqrt = unsafeFunction "sqrt"

415406 b ** x = UnsafeExpression $

416− "power(" <> renderExpression b <> ", " <> renderExpression x <> ")"

407+ "power(" <> renderSQL b <> ", " <> renderSQL x <> ")"

417408 logBase b y = log y / log b

418409 sin = unsafeFunction "sin"

419410 cos = unsafeFunction "cos"

@@ -428,790 +419,54 @@ instance (PGNum ty, PGFloating ty) => Floating

428419 acosh x = log (x + sqrt (x*x - 1))

429420 atanh x = log ((1 + x) / (1 - x)) / 2

430421

431−-- | >>> :{

432−-- let

433−-- expression :: Expression relations grouping params (nullity 'PGfloat4)

434−-- expression = atan2_ pi 2

435−-- in renderExpression expression

436−-- :}

437−-- "atan2(pi(), 2)"

438−atan2_

439− :: PGFloating float

440− => Expression relations grouping params (nullity float)

441− -- ^ numerator

442− -> Expression relations grouping params (nullity float)

443− -- ^ denominator

444− -> Expression relations grouping params (nullity float)

445−atan2_ y x = UnsafeExpression $

446− "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"

447−

448−-- When a `cast` is applied to an `Expression` of a known type, it

449−-- represents a run-time type conversion. The cast will succeed only if a

450−-- suitable type conversion operation has been defined.

451−--

452−-- | >>> renderExpression $ true & cast int4

453−-- "(TRUE :: int4)"

454−cast

455− :: TypeExpression ('NoDef :=> 'Null ty1)

456− -- ^ type to cast as

457− -> Expression relations grouping params (nullity ty0)

458− -- ^ value to convert

459− -> Expression relations grouping params (nullity ty1)

460−cast ty x = UnsafeExpression $ parenthesized $

461− renderExpression x <+> "::" <+> renderTypeExpression ty

462−

463−-- | integer division, truncates the result

464−--

465−-- >>> :{

466−-- let

467−-- expression :: Expression relations grouping params (nullity 'PGint2)

468−-- expression = 5 `quot_` 2

469−-- in renderExpression expression

470−-- :}

471−-- "(5 / 2)"

472−quot_

473− :: PGIntegral int

474− => Expression relations grouping params (nullity int)

475− -- ^ numerator

476− -> Expression relations grouping params (nullity int)

477− -- ^ denominator

478− -> Expression relations grouping params (nullity int)

479−quot_ = unsafeBinaryOp "/"

480−

481−-- | remainder upon integer division

482−--

483−-- >>> :{

484−-- let

485−-- expression :: Expression relations grouping params (nullity 'PGint2)

486−-- expression = 5 `rem_` 2

487−-- in renderExpression expression

488−-- :}

489−-- "(5 % 2)"

490−rem_

491− :: PGIntegral int

492− => Expression relations grouping params (nullity int)

493− -- ^ numerator

494− -> Expression relations grouping params (nullity int)

495− -- ^ denominator

496− -> Expression relations grouping params (nullity int)

497−rem_ = unsafeBinaryOp "%"

498−

499−-- | >>> :{

500−-- let

501−-- expression :: Expression relations grouping params (nullity 'PGfloat4)

502−-- expression = trunc pi

503−-- in renderExpression expression

504−-- :}

505−-- "trunc(pi())"

506−trunc

507− :: PGFloating frac

508− => Expression relations grouping params (nullity frac)

509− -- ^ fractional number

510− -> Expression relations grouping params (nullity frac)

511−trunc = unsafeFunction "trunc"

512−

513−-- | >>> :{

514−-- let

515−-- expression :: Expression relations grouping params (nullity 'PGfloat4)

516−-- expression = round_ pi

517−-- in renderExpression expression

518−-- :}

519−-- "round(pi())"

520−round_

521− :: PGFloating frac

522− => Expression relations grouping params (nullity frac)

523− -- ^ fractional number

524− -> Expression relations grouping params (nullity frac)

525−round_ = unsafeFunction "round"

526−

527−-- | >>> :{

528−-- let

529−-- expression :: Expression relations grouping params (nullity 'PGfloat4)

530−-- expression = ceiling_ pi

531−-- in renderExpression expression

532−-- :}

533−-- "ceiling(pi())"

534−ceiling_

535− :: PGFloating frac

536− => Expression relations grouping params (nullity frac)

537− -- ^ fractional number

538− -> Expression relations grouping params (nullity frac)

539−ceiling_ = unsafeFunction "ceiling"

540−

541−-- | A `Condition` is a boolean valued `Expression`. While SQL allows

542−-- conditions to have @NULL@, Squeal instead chooses to disallow @NULL@,

543−-- forcing one to handle the case of @NULL@ explicitly to produce

544−-- a `Condition`.

545−type Condition relations grouping params =

546− Expression relations grouping params ('NotNull 'PGbool)

547−

548−-- | >>> renderExpression true

549−-- "TRUE"

550−true :: Condition relations grouping params

551−true = UnsafeExpression "TRUE"

552−

553−-- | >>> renderExpression false

554−-- "FALSE"

555−false :: Condition relations grouping params

556−false = UnsafeExpression "FALSE"

557−

558−-- | >>> renderExpression $ not_ true

559−-- "(NOT TRUE)"

560−not_

561− :: Condition relations grouping params

562− -> Condition relations grouping params

563−not_ = unsafeUnaryOp "NOT"

564−

565−-- | >>> renderExpression $ true .&& false

566−-- "(TRUE AND FALSE)"

567−(.&&)

568− :: Condition relations grouping params

569− -> Condition relations grouping params

570− -> Condition relations grouping params

571−(.&&) = unsafeBinaryOp "AND"

572−

573−-- | >>> renderExpression $ true .|| false

574−-- "(TRUE OR FALSE)"

575−(.||)

576− :: Condition relations grouping params

577− -> Condition relations grouping params

578− -> Condition relations grouping params

579−(.||) = unsafeBinaryOp "OR"

580−

581−-- | >>> :{

582−-- let

583−-- expression :: Expression relations grouping params (nullity 'PGint2)

584−-- expression = caseWhenThenElse [(true, 1), (false, 2)] 3

585−-- in renderExpression expression

586−-- :}

587−-- "CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END"

588−caseWhenThenElse

589− :: [ ( Condition relations grouping params

590− , Expression relations grouping params (ty)

591− ) ]

592− -- ^ whens and thens

593− -> Expression relations grouping params (ty)

594− -- ^ else

595− -> Expression relations grouping params (ty)

596−caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat

597− [ "CASE"

598− , mconcat

599− [ mconcat

600− [ " WHEN ", renderExpression when_

601− , " THEN ", renderExpression then_

602− ]

603− | (when_,then_) <- whenThens

604− ]

605− , " ELSE ", renderExpression else_

606− , " END"

607− ]

608−

609−-- | >>> :{

610−-- let

611−-- expression :: Expression relations grouping params (nullity 'PGint2)

612−-- expression = ifThenElse true 1 0

613−-- in renderExpression expression

614−-- :}

615−-- "CASE WHEN TRUE THEN 1 ELSE 0 END"

616−ifThenElse

617− :: Condition relations grouping params

618− -> Expression relations grouping params (ty) -- ^ then

619− -> Expression relations grouping params (ty) -- ^ else

620− -> Expression relations grouping params (ty)

621−ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_

622−

623−-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`

624−-- will produce @NULL@s if one of their arguments is @NULL@.

625−--

626−-- >>> renderExpression $ unNull true .== null_

627−-- "(TRUE = NULL)"

628−(.==)

629− :: Expression relations grouping params (nullity ty) -- ^ lhs

630− -> Expression relations grouping params (nullity ty) -- ^ rhs

631− -> Expression relations grouping params (nullity 'PGbool)

632−(.==) = unsafeBinaryOp "="

633−infix 4 .==

634−

635−-- | >>> renderExpression $ unNull true ./= null_

636−-- "(TRUE <> NULL)"

637−(./=)

638− :: Expression relations grouping params (nullity ty) -- ^ lhs

639− -> Expression relations grouping params (nullity ty) -- ^ rhs

640− -> Expression relations grouping params (nullity 'PGbool)

641−(./=) = unsafeBinaryOp "<>"

642−infix 4 ./=

643−

644−-- | >>> renderExpression $ unNull true .>= null_

645−-- "(TRUE >= NULL)"

646−(.>=)

647− :: Expression relations grouping params (nullity ty) -- ^ lhs

648− -> Expression relations grouping params (nullity ty) -- ^ rhs

649− -> Expression relations grouping params (nullity 'PGbool)

650−(.>=) = unsafeBinaryOp ">="

651−infix 4 .>=

652−

653−-- | >>> renderExpression $ unNull true .< null_

654−-- "(TRUE < NULL)"

655−(.<)

656− :: Expression relations grouping params (nullity ty) -- ^ lhs

657− -> Expression relations grouping params (nullity ty) -- ^ rhs

658− -> Expression relations grouping params (nullity 'PGbool)

659−(.<) = unsafeBinaryOp "<"

660−infix 4 .<

661−

662−-- | >>> renderExpression $ unNull true .<= null_

663−-- "(TRUE <= NULL)"

664−(.<=)

665− :: Expression relations grouping params (nullity ty) -- ^ lhs

666− -> Expression relations grouping params (nullity ty) -- ^ rhs

667− -> Expression relations grouping params (nullity 'PGbool)

668−(.<=) = unsafeBinaryOp "<="

669−infix 4 .<=

670−

671−-- | >>> renderExpression $ unNull true .> null_

672−-- "(TRUE > NULL)"

673−(.>)

674− :: Expression relations grouping params (nullity ty) -- ^ lhs

675− -> Expression relations grouping params (nullity ty) -- ^ rhs

676− -> Expression relations grouping params (nullity 'PGbool)

677−(.>) = unsafeBinaryOp ">"

678−infix 4 .>

679−

680−-- | >>> renderExpression currentDate

681−-- "CURRENT_DATE"

682−currentDate

683− :: Expression relations grouping params (nullity 'PGdate)

684−currentDate = UnsafeExpression "CURRENT_DATE"

685−

686−-- | >>> renderExpression currentTime

687−-- "CURRENT_TIME"

688−currentTime

689− :: Expression relations grouping params (nullity 'PGtimetz)

690−currentTime = UnsafeExpression "CURRENT_TIME"

691−

692−-- | >>> renderExpression currentTimestamp

693−-- "CURRENT_TIMESTAMP"

694−currentTimestamp

695− :: Expression relations grouping params (nullity 'PGtimestamptz)

696−currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"

697−

698−-- | >>> renderExpression localTime

699−-- "LOCALTIME"

700−localTime

701− :: Expression relations grouping params (nullity 'PGtime)

702−localTime = UnsafeExpression "LOCALTIME"

703−

704−-- | >>> renderExpression localTimestamp

705−-- "LOCALTIMESTAMP"

706−localTimestamp

707− :: Expression relations grouping params (nullity 'PGtimestamp)

708−localTimestamp = UnsafeExpression "LOCALTIMESTAMP"

709−

710−{-----------------------------------------

711−text

712−-----------------------------------------}

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)

713438

714439instance IsString

715− (Expression relations grouping params (nullity 'PGtext)) where

440+ (Expression outer commons grp schemas params from (null 'PGtext)) where

716441 fromString str = UnsafeExpression $

717442 "E\'" <> fromString (escape =<< str) <> "\'"

718− where

719− escape = \case

720− '\NUL' -> "\\0"

721− '\'' -> "''"

722− '"' -> "\\\""

723− '\b' -> "\\b"

724− '\n' -> "\\n"

725− '\r' -> "\\r"

726− '\t' -> "\\t"

727− '\\' -> "\\\\"

728− 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) <> "\'"

451+

452+instance Semigroup

453+ (Expression outer commons grp schemas params from (null ('PGvararray ty))) where

454+ (<>) = unsafeBinaryOp "||"

455+instance Semigroup

456+ (Expression outer commons grp schemas params from (null 'PGjsonb)) where

457+ (<>) = unsafeBinaryOp "||"

458+instance Semigroup

459+ (Expression outer commons grp schemas params from (null 'PGtext)) where

460+ (<>) = unsafeBinaryOp "||"

461+instance Semigroup

462+ (Expression outer commons grp schemas params from (null 'PGtsvector)) where

463+ (<>) = unsafeBinaryOp "||"

729464

730465instance Monoid

731− (Expression relations grouping params (nullity 'PGtext)) where

466+ (Expression outer commons grp schemas params from (null 'PGtext)) where

732467 mempty = fromString ""

733− mappend = unsafeBinaryOp "||"

734−

735−-- | >>> renderExpression $ lower "ARRRGGG"

736−-- "lower(E'ARRRGGG')"

737−lower

738− :: Expression relations grouping params (nullity 'PGtext)

739− -- ^ string to lower case

740− -> Expression relations grouping params (nullity 'PGtext)

741−lower = unsafeFunction "lower"

742−

743−-- | >>> renderExpression $ upper "eeee"

744−-- "upper(E'eeee')"

745−upper

746− :: Expression relations grouping params (nullity 'PGtext)

747− -- ^ string to upper case

748− -> Expression relations grouping params (nullity 'PGtext)

749−upper = unsafeFunction "upper"

750−

751−-- | >>> renderExpression $ charLength "four"

752−-- "char_length(E'four')"

753−charLength

754− :: Expression relations grouping params (nullity 'PGtext)

755− -- ^ string to measure

756− -> Expression relations grouping params (nullity 'PGint4)

757−charLength = unsafeFunction "char_length"

758−

759−-- | The `like` expression returns true if the @string@ matches

760−-- the supplied @pattern@. If @pattern@ does not contain percent signs

761−-- or underscores, then the pattern only represents the string itself;

762−-- in that case `like` acts like the equals operator. An underscore (_)

763−-- in pattern stands for (matches) any single character; a percent sign (%)

764−-- matches any sequence of zero or more characters.

765−--

766−-- >>> renderExpression $ "abc" `like` "a%"

767−-- "(E'abc' LIKE E'a%')"

768−like

769− :: Expression relations grouping params (nullity 'PGtext)

770− -- ^ string

771− -> Expression relations grouping params (nullity 'PGtext)

772− -- ^ pattern

773− -> Expression relations grouping params (nullity 'PGbool)

774−like = unsafeBinaryOp "LIKE"

775−

776−{-----------------------------------------

777−aggregation

778−-----------------------------------------}

779−

780−-- | escape hatch to define aggregate functions

781−unsafeAggregate

782− :: ByteString -- ^ aggregate function

783− -> Expression relations 'Ungrouped params (xty)

784− -> Expression relations ('Grouped bys) params (yty)

785−unsafeAggregate fun x = UnsafeExpression $ mconcat

786− [fun, "(", renderExpression x, ")"]

787−

788−-- | escape hatch to define aggregate functions over distinct values

789−unsafeAggregateDistinct

790− :: ByteString -- ^ aggregate function

791− -> Expression relations 'Ungrouped params (xty)

792− -> Expression relations ('Grouped bys) params (yty)

793−unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat

794− [fun, "(DISTINCT ", renderExpression x, ")"]

795−

796−-- | >>> :{

797−-- let

798−-- expression :: Expression '[tab ::: '["col" ::: 'Null 'PGnumeric]] ('Grouped bys) params ('Null 'PGnumeric)

799−-- expression = sum_ #col

800−-- in renderExpression expression

801−-- :}

802−-- "sum(\"col\")"

803−sum_

804− :: PGNum ty

805− => Expression relations 'Ungrouped params (nullity ty)

806− -- ^ what to sum

807− -> Expression relations ('Grouped bys) params (nullity ty)

808−sum_ = unsafeAggregate "sum"

809−

810−-- | >>> :{

811−-- let

812−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGnumeric]] ('Grouped bys) params (nullity 'PGnumeric)

813−-- expression = sumDistinct #col

814−-- in renderExpression expression

815−-- :}

816−-- "sum(DISTINCT \"col\")"

817−sumDistinct

818− :: PGNum ty

819− => Expression relations 'Ungrouped params (nullity ty)

820− -- ^ what to sum

821− -> Expression relations ('Grouped bys) params (nullity ty)

822−sumDistinct = unsafeAggregateDistinct "sum"

823−

824−-- | A constraint for `PGType`s that you can take averages of and the resulting

825−-- `PGType`.

826−class PGAvg ty avg | ty -> avg where

827− avg, avgDistinct

828− :: Expression relations 'Ungrouped params (nullity ty)

829− -- ^ what to average

830− -> Expression relations ('Grouped bys) params (nullity avg)

831− avg = unsafeAggregate "avg"

832− avgDistinct = unsafeAggregateDistinct "avg"

833−instance PGAvg 'PGint2 'PGnumeric

834−instance PGAvg 'PGint4 'PGnumeric

835−instance PGAvg 'PGint8 'PGnumeric

836−instance PGAvg 'PGnumeric 'PGnumeric

837−instance PGAvg 'PGfloat4 'PGfloat8

838−instance PGAvg 'PGfloat8 'PGfloat8

839−instance PGAvg 'PGinterval 'PGinterval

840−

841−-- | >>> :{

842−-- let

843−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

844−-- expression = bitAnd #col

845−-- in renderExpression expression

846−-- :}

847−-- "bit_and(\"col\")"

848−bitAnd

849− :: PGIntegral int

850− => Expression relations 'Ungrouped params (nullity int)

851− -- ^ what to aggregate

852− -> Expression relations ('Grouped bys) params (nullity int)

853−bitAnd = unsafeAggregate "bit_and"

854−

855−-- | >>> :{

856−-- let

857−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

858−-- expression = bitOr #col

859−-- in renderExpression expression

860−-- :}

861−-- "bit_or(\"col\")"

862−bitOr

863− :: PGIntegral int

864− => Expression relations 'Ungrouped params (nullity int)

865− -- ^ what to aggregate

866− -> Expression relations ('Grouped bys) params (nullity int)

867−bitOr = unsafeAggregate "bit_or"

868−

869−-- | >>> :{

870−-- let

871−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

872−-- expression = bitAndDistinct #col

873−-- in renderExpression expression

874−-- :}

875−-- "bit_and(DISTINCT \"col\")"

876−bitAndDistinct

877− :: PGIntegral int

878− => Expression relations 'Ungrouped params (nullity int)

879− -- ^ what to aggregate

880− -> Expression relations ('Grouped bys) params (nullity int)

881−bitAndDistinct = unsafeAggregateDistinct "bit_and"

882−

883−-- | >>> :{

884−-- let

885−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGint4]] (Grouped bys) params (nullity 'PGint4)

886−-- expression = bitOrDistinct #col

887−-- in renderExpression expression

888−-- :}

889−-- "bit_or(DISTINCT \"col\")"

890−bitOrDistinct

891− :: PGIntegral int

892− => Expression relations 'Ungrouped params (nullity int)

893− -- ^ what to aggregate

894− -> Expression relations ('Grouped bys) params (nullity int)

895−bitOrDistinct = unsafeAggregateDistinct "bit_or"

896−

897−-- | >>> :{

898−-- let

899−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

900−-- expression = boolAnd #col

901−-- in renderExpression expression

902−-- :}

903−-- "bool_and(\"col\")"

904−boolAnd

905− :: Expression relations 'Ungrouped params (nullity 'PGbool)

906− -- ^ what to aggregate

907− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

908−boolAnd = unsafeAggregate "bool_and"

909−

910−-- | >>> :{

911−-- let

912−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

913−-- expression = boolOr #col

914−-- in renderExpression expression

915−-- :}

916−-- "bool_or(\"col\")"

917−boolOr

918− :: Expression relations 'Ungrouped params (nullity 'PGbool)

919− -- ^ what to aggregate

920− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

921−boolOr = unsafeAggregate "bool_or"

922−

923−-- | >>> :{

924−-- let

925−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

926−-- expression = boolAndDistinct #col

927−-- in renderExpression expression

928−-- :}

929−-- "bool_and(DISTINCT \"col\")"

930−boolAndDistinct

931− :: Expression relations 'Ungrouped params (nullity 'PGbool)

932− -- ^ what to aggregate

933− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

934−boolAndDistinct = unsafeAggregateDistinct "bool_and"

935−

936−-- | >>> :{

937−-- let

938−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

939−-- expression = boolOrDistinct #col

940−-- in renderExpression expression

941−-- :}

942−-- "bool_or(DISTINCT \"col\")"

943−boolOrDistinct

944− :: Expression relations 'Ungrouped params (nullity 'PGbool)

945− -- ^ what to aggregate

946− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

947−boolOrDistinct = unsafeAggregateDistinct "bool_or"

948−

949−-- | A special aggregation that does not require an input

950−--

951−-- >>> renderExpression countStar

952−-- "count(*)"

953−countStar

954− :: Expression relations ('Grouped bys) params ('NotNull 'PGint8)

955−countStar = UnsafeExpression $ "count(*)"

956−

957−-- | >>> :{

958−-- let

959−-- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)

960−-- expression = count #col

961−-- in renderExpression expression

962−-- :}

963−-- "count(\"col\")"

964−count

965− :: Expression relations 'Ungrouped params ty

966− -- ^ what to count

967− -> Expression relations ('Grouped bys) params ('NotNull 'PGint8)

968−count = unsafeAggregate "count"

969−

970−-- | >>> :{

971−-- let

972−-- expression :: Expression '[tab ::: '["col" ::: nullity ty]] (Grouped bys) params ('NotNull 'PGint8)

973−-- expression = countDistinct #col

974−-- in renderExpression expression

975−-- :}

976−-- "count(DISTINCT \"col\")"

977−countDistinct

978− :: Expression relations 'Ungrouped params ty

979− -- ^ what to count

980− -> Expression relations ('Grouped bys) params ('NotNull 'PGint8)

981−countDistinct = unsafeAggregateDistinct "count"

982−

983−-- | synonym for `boolAnd`

984−--

985−-- >>> :{

986−-- let

987−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

988−-- expression = every #col

989−-- in renderExpression expression

990−-- :}

991−-- "every(\"col\")"

992−every

993− :: Expression relations 'Ungrouped params (nullity 'PGbool)

994− -- ^ what to aggregate

995− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

996−every = unsafeAggregate "every"

997−

998−-- | synonym for `boolAndDistinct`

999−--

1000−-- >>> :{

1001−-- let

1002−-- expression :: Expression '[tab ::: '["col" ::: nullity 'PGbool]] (Grouped bys) params (nullity 'PGbool)

1003−-- expression = everyDistinct #col

1004−-- in renderExpression expression

1005−-- :}

1006−-- "every(DISTINCT \"col\")"

1007−everyDistinct

1008− :: Expression relations 'Ungrouped params (nullity 'PGbool)

1009− -- ^ what to aggregate

1010− -> Expression relations ('Grouped bys) params (nullity 'PGbool)

1011−everyDistinct = unsafeAggregateDistinct "every"

1012−

1013−-- | minimum and maximum aggregation

1014−max_, min_, maxDistinct, minDistinct

1015− :: Expression relations 'Ungrouped params (nullity ty)

1016− -- ^ what to aggregate

1017− -> Expression relations ('Grouped bys) params (nullity ty)

1018−max_ = unsafeAggregate "max"

1019−min_ = unsafeAggregate "min"

1020−maxDistinct = unsafeAggregateDistinct "max"

1021−minDistinct = unsafeAggregateDistinct "min"

1022−

1023−{-----------------------------------------

1024−tables

1025−-----------------------------------------}

1026−

1027−-- | A `Table` from a table expression is a way

1028−-- to call a table reference by its alias.

1029−newtype Table

1030− (schema :: SchemaType)

1031− (columns :: RelationType)

1032− = UnsafeTable { renderTable :: ByteString }

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

1034−instance

1035− ( Has alias (TablesOf schema) table

1036− , relation ~ ColumnsToRelation (TableToColumns table)

1037− ) => IsLabel alias (Table schema relation) where

1038− fromLabel = UnsafeTable $ renderAlias (Alias @alias)

1039−

1040−-- | A `View` from a table expression is a way

1041−-- to call a table reference by its alias.

1042−newtype View

1043− (schema :: SchemaType)

1044− (columns :: RelationType)

1045− = UnsafeView { renderView :: ByteString }

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

1047−instance

1048− ( Has alias (ViewsOf schema) columns

1049− ) => IsLabel alias (View schema columns) where

1050− fromLabel = UnsafeView $ renderAlias (Alias @alias)

1051−

1052−{-----------------------------------------

1053−type expressions

1054−-----------------------------------------}

1055−

1056−-- | `TypeExpression`s are used in `cast`s and `createTable` commands.

1057−newtype TypeExpression (ty :: ColumnType)

1058− = UnsafeTypeExpression { renderTypeExpression :: ByteString }

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

1060−

1061−-- | logical Boolean (true/false)

1062−bool :: TypeExpression ('NoDef :=> 'Null 'PGbool)

1063−bool = UnsafeTypeExpression "bool"

1064−-- | signed two-byte integer

1065−int2, smallint :: TypeExpression ('NoDef :=> 'Null 'PGint2)

1066−int2 = UnsafeTypeExpression "int2"

1067−smallint = UnsafeTypeExpression "smallint"

1068−-- | signed four-byte integer

1069−int4, int, integer :: TypeExpression ('NoDef :=> 'Null 'PGint4)

1070−int4 = UnsafeTypeExpression "int4"

1071−int = UnsafeTypeExpression "int"

1072−integer = UnsafeTypeExpression "integer"

1073−-- | signed eight-byte integer

1074−int8, bigint :: TypeExpression ('NoDef :=> 'Null 'PGint8)

1075−int8 = UnsafeTypeExpression "int8"

1076−bigint = UnsafeTypeExpression "bigint"

1077−-- | arbitrary precision numeric type

1078−numeric :: TypeExpression ('NoDef :=> 'Null 'PGnumeric)

1079−numeric = UnsafeTypeExpression "numeric"

1080−-- | single precision floating-point number (4 bytes)

1081−float4, real :: TypeExpression ('NoDef :=> 'Null 'PGfloat4)

1082−float4 = UnsafeTypeExpression "float4"

1083−real = UnsafeTypeExpression "real"

1084−-- | double precision floating-point number (8 bytes)

1085−float8, doublePrecision :: TypeExpression ('NoDef :=> 'Null 'PGfloat8)

1086−float8 = UnsafeTypeExpression "float8"

1087−doublePrecision = UnsafeTypeExpression "double precision"

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

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

1090−serial2, smallserial

1091− :: TypeExpression ('Def :=> 'NotNull 'PGint2)

1092−serial2 = UnsafeTypeExpression "serial2"

1093−smallserial = UnsafeTypeExpression "smallserial"

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

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

1096−serial4, serial

1097− :: TypeExpression ('Def :=> 'NotNull 'PGint4)

1098−serial4 = UnsafeTypeExpression "serial4"

1099−serial = UnsafeTypeExpression "serial"

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

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

1102−serial8, bigserial

1103− :: TypeExpression ('Def :=> 'NotNull 'PGint8)

1104−serial8 = UnsafeTypeExpression "serial8"

1105−bigserial = UnsafeTypeExpression "bigserial"

1106−-- | variable-length character string

1107−text :: TypeExpression ('NoDef :=> 'Null 'PGtext)

1108−text = UnsafeTypeExpression "text"

1109−-- | fixed-length character string

1110−char, character

1111− :: (KnownNat n, 1 <= n)

1112− => proxy n

1113− -> TypeExpression ('NoDef :=> 'Null ('PGchar n))

1114−char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"

1115−character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"

1116−-- | variable-length character string

1117−varchar, characterVarying

1118− :: (KnownNat n, 1 <= n)

1119− => proxy n

1120− -> TypeExpression ('NoDef :=> 'Null ('PGvarchar n))

1121−varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"

1122−characterVarying p = UnsafeTypeExpression $

1123− "character varying(" <> renderNat p <> ")"

1124−-- | binary data ("byte array")

1125−bytea :: TypeExpression ('NoDef :=> 'Null 'PGbytea)

1126−bytea = UnsafeTypeExpression "bytea"

1127−-- | date and time (no time zone)

1128−timestamp :: TypeExpression ('NoDef :=> 'Null 'PGtimestamp)

1129−timestamp = UnsafeTypeExpression "timestamp"

1130−-- | date and time, including time zone

1131−timestampWithTimeZone :: TypeExpression ('NoDef :=> 'Null 'PGtimestamptz)

1132−timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

1133−-- | calendar date (year, month, day)

1134−date :: TypeExpression ('NoDef :=> 'Null 'PGdate)

1135−date = UnsafeTypeExpression "date"

1136−-- | time of day (no time zone)

1137−time :: TypeExpression ('NoDef :=> 'Null 'PGtime)

1138−time = UnsafeTypeExpression "time"

1139−-- | time of day, including time zone

1140−timeWithTimeZone :: TypeExpression ('NoDef :=> 'Null 'PGtimetz)

1141−timeWithTimeZone = UnsafeTypeExpression "time with time zone"

1142−-- | time span

1143−interval :: TypeExpression ('NoDef :=> 'Null 'PGinterval)

1144−interval = UnsafeTypeExpression "interval"

1145−-- | universally unique identifier

1146−uuid :: TypeExpression ('NoDef :=> 'Null 'PGuuid)

1147−uuid = UnsafeTypeExpression "uuid"

1148−-- | IPv4 or IPv6 host address

1149−inet :: TypeExpression ('NoDef :=> 'Null 'PGinet)

1150−inet = UnsafeTypeExpression "inet"

1151−-- | textual JSON data

1152−json :: TypeExpression ('NoDef :=> 'Null 'PGjson)

1153−json = UnsafeTypeExpression "json"

1154−-- | binary JSON data, decomposed

1155−jsonb :: TypeExpression ('NoDef :=> 'Null 'PGjsonb)

1156−jsonb = UnsafeTypeExpression "jsonb"

1157−-- | variable length array

1158−vararray

1159− :: TypeExpression ('NoDef :=> 'Null pg)

1160− -> TypeExpression ('NoDef :=> 'Null ('PGvararray pg))

1161−vararray ty = UnsafeTypeExpression $ renderTypeExpression ty <> "[]"

1162−-- | fixed length array

1163−--

1164−-- >>> renderTypeExpression (fixarray (Proxy @2) json)

1165−-- "json[2]"

1166−fixarray

1167− :: KnownNat n

1168− => proxy n

1169− -> TypeExpression ('NoDef :=> 'Null pg)

1170− -> TypeExpression ('NoDef :=> 'Null ('PGfixarray n pg))

1171−fixarray p ty = UnsafeTypeExpression $

1172− renderTypeExpression ty <> "[" <> renderNat p <> "]"

1173−

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

1175−-- @NULL@ is not present

1176−notNull

1177− :: TypeExpression (def :=> 'Null ty)

1178− -> TypeExpression (def :=> 'NotNull ty)

1179−notNull ty = UnsafeTypeExpression $ renderTypeExpression ty <+> "NOT NULL"

1180−

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

1182−default_

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

1184− -> TypeExpression ('NoDef :=> ty)

1185− -> TypeExpression ('Def :=> ty)

1186−default_ x ty = UnsafeTypeExpression $

1187− renderTypeExpression ty <+> "DEFAULT" <+> renderExpression x

1188−

1189−-- | `pgtype` is a demoted version of a `PGType`

1190−class PGTyped (ty :: PGType) where

1191− pgtype :: TypeExpression ('NoDef :=> 'Null ty)

1192−instance PGTyped 'PGbool where pgtype = bool

1193−instance PGTyped 'PGint2 where pgtype = int2

1194−instance PGTyped 'PGint4 where pgtype = int4

1195−instance PGTyped 'PGint8 where pgtype = int8

1196−instance PGTyped 'PGnumeric where pgtype = numeric

1197−instance PGTyped 'PGfloat4 where pgtype = float4

1198−instance PGTyped 'PGfloat8 where pgtype = float8

1199−instance PGTyped 'PGtext where pgtype = text

1200−instance (KnownNat n, 1 <= n)

1201− => PGTyped ('PGchar n) where pgtype = char (Proxy @n)

1202−instance (KnownNat n, 1 <= n)

1203− => PGTyped ('PGvarchar n) where pgtype = varchar (Proxy @n)

1204−instance PGTyped 'PGbytea where pgtype = bytea

1205−instance PGTyped 'PGtimestamp where pgtype = timestamp

1206−instance PGTyped 'PGtimestamptz where pgtype = timestampWithTimeZone

1207−instance PGTyped 'PGdate where pgtype = date

1208−instance PGTyped 'PGtime where pgtype = time

1209−instance PGTyped 'PGtimetz where pgtype = timeWithTimeZone

1210−instance PGTyped 'PGinterval where pgtype = interval

1211−instance PGTyped 'PGuuid where pgtype = uuid

1212−instance PGTyped 'PGjson where pgtype = json

1213−instance PGTyped 'PGjsonb where pgtype = jsonb

1214−instance PGTyped ty => PGTyped ('PGvararray ty) where

1215− pgtype = vararray (pgtype @ty)

1216−instance (KnownNat n, PGTyped ty) => PGTyped ('PGfixarray n ty) where

1217− pgtype = fixarray (Proxy @n) (pgtype @ty)

468+ mappend = (<>)

469+instance Monoid

470+ (Expression outer commons grp schemas params from (null 'PGtsvector)) where

471+ mempty = fromString ""

472+ mappend = (<>)

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+427−361

@@ -9,316 +9,371 @@ Squeal data manipulation language.

99-}

1010

1111{-# LANGUAGE

12− DataKinds

13− , DeriveDataTypeable

14− , DeriveGeneric

12+ DeriveGeneric

1513 , FlexibleContexts

14+ , FlexibleInstances

1615 , GADTs

1716 , GeneralizedNewtypeDeriving

18− , KindSignatures

1917 , LambdaCase

18+ , MultiParamTypeClasses

2019 , OverloadedStrings

20+ , PatternSynonyms

21+ , QuantifiedConstraints

2122 , RankNTypes

22− , StandaloneDeriving

23+ , ScopedTypeVariables

24+ , TypeApplications

25+ , TypeFamilies

2326 , TypeInType

2427 , TypeOperators

28+ , UndecidableInstances

2529#-}

2630

2731module Squeal.PostgreSQL.Manipulation

2832 ( -- * Manipulation

29− Manipulation (UnsafeManipulation, renderManipulation)

33+ Manipulation_

34+ , Manipulation (..)

3035 , queryStatement

31− , ColumnValue (..)

32− , ReturningClause (ReturningStar, Returning)

33− , ConflictClause (OnConflictDoRaise, OnConflictDoNothing, OnConflictDoUpdate)

3436 -- * Insert

35− , insertRows

36− , insertRow

37− , insertRows_

38− , insertRow_

39− , insertQuery

40− , insertQuery_

41− , renderReturningClause

42− , renderConflictClause

37+ , insertInto

38+ , insertInto_

4339 -- * Update

4440 , update

4541 , update_

4642 -- * Delete

4743 , deleteFrom

4844 , deleteFrom_

49− -- * With

50− , with

45+ -- * Clauses

46+ , Optional (..)

47+ , QueryClause (..)

48+ , pattern Values_

49+ , ReturningClause (..)

50+ , pattern Returning_

51+ , ConflictClause (..)

52+ , ConflictTarget (..)

53+ , ConflictAction (..)

54+ , UsingClause (..)

5155 ) where

5256

5357import Control.DeepSeq

5458import Data.ByteString hiding (foldr)

55−import Data.Monoid

59+import Data.Kind (Type)

5660

57−import qualified Data.ByteString as ByteString

5861import qualified Generics.SOP as SOP

5962import qualified GHC.Generics as GHC

6063

64+import Squeal.PostgreSQL.Alias

6165import Squeal.PostgreSQL.Expression

66+import Squeal.PostgreSQL.Expression.Logic

67+import Squeal.PostgreSQL.List

68+import Squeal.PostgreSQL.PG

6269import Squeal.PostgreSQL.Render

6370import Squeal.PostgreSQL.Query

6471import Squeal.PostgreSQL.Schema

6572

73+-- $setup

74+-- >>> import Squeal.PostgreSQL

75+-- >>> import Data.Int

76+-- >>> import Data.Time

77+

6678{- |

6779A `Manipulation` is a statement which may modify data in the database,

68−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.

6981A `Query` is also considered a `Manipulation` even though it does not modify data.

7082

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+

71125simple insert:

72126

127+>>> type Columns = '["col1" ::: 'NoDef :=> 'Null 'PGint4, "col2" ::: 'Def :=> 'NotNull 'PGint4]

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

73129>>> :{

74130let

75− manipulation :: Manipulation

76− '[ "tab" ::: '[] :=>

77− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

78− , "col2" ::: 'Def :=> 'NotNull 'PGint4 ]] '[] '[]

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

79132 manipulation =

80− insertRow_ #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil)

81−in renderManipulation manipulation

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

134+in printSQL manipulation

82135:}

83−"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, DEFAULT);"

136+INSERT INTO "tab" ("col1", "col2") VALUES (2, DEFAULT)

84137

85138parameterized insert:

86139

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

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

87142>>> :{

88143let

89− manipulation :: Manipulation

90− '[ "tab" ::: '[] :=>

91− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

92− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]

93− '[ 'NotNull 'PGint4, 'NotNull 'PGint4 ] '[]

144+ manipulation :: Manipulation_ (Public Schema) (Int32, Int32) ()

94145 manipulation =

95− insertRow_ #tab

96− (Set (param @1) `As` #col1 :* Set (param @2) `As` #col2 :* Nil)

97−in renderManipulation manipulation

146+ insertInto_ #tab (Values_ (Set (param @1) `as` #col1 :* Set (param @2) `as` #col2))

147+in printSQL manipulation

98148:}

99−"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (($1 :: int4), ($2 :: int4));"

149+INSERT INTO "tab" ("col1", "col2") VALUES (($1 :: int4), ($2 :: int4))

100150

101151returning insert:

102152

103153>>> :{

104154let

105− manipulation :: Manipulation

106− '[ "tab" ::: '[] :=>

107− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

108− , "col2" ::: 'Def :=> 'NotNull 'PGint4 ]] '[]

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

155+ manipulation :: Manipulation_ (Public Schema) () (Only Int32)

110156 manipulation =

111− insertRow #tab (Set 2 `As` #col1 :* Default `As` #col2 :* Nil)

112− OnConflictDoRaise (Returning (#col1 `As` #fromOnly :* Nil))

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

114160:}

115−"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"

116162

117163upsert:

118164

165+>>> type CustomersColumns = '["name" ::: 'NoDef :=> 'NotNull 'PGtext, "email" ::: 'NoDef :=> 'NotNull 'PGtext]

166+>>> type CustomersConstraints = '["uq" ::: 'Unique '["name"]]

167+>>> type CustomersSchema = '["customers" ::: 'Table (CustomersConstraints :=> CustomersColumns)]

119168>>> :{

120169let

121− manipulation :: Manipulation

122− '[ "tab" ::: '[] :=>

123− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

124− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]

125− '[] '[ "sum" ::: 'NotNull 'PGint4]

170+ manipulation :: Manipulation_ (Public CustomersSchema) () ()

126171 manipulation =

127− insertRows #tab

128− (Set 2 `As` #col1 :* Set 4 `As` #col2 :* Nil)

129− [Set 6 `As` #col1 :* Set 8 `As` #col2 :* Nil]

130− (OnConflictDoUpdate

131− (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)

132− [#col1 .== #col2])

133− (Returning $ (#col1 + #col2) `As` #sum :* Nil)

134−in renderManipulation manipulation

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

135178:}

136−"INSERT INTO \"tab\" (\"col1\", \"col2\") VALUES (2, 4), (6, 8) ON CONFLICT DO UPDATE SET \"col1\" = 2 WHERE (\"col1\" = \"col2\") RETURNING (\"col1\" + \"col2\") AS \"sum\";"

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

137180

138181query insert:

139182

140183>>> :{

141184let

142− manipulation :: Manipulation

143− '[ "tab" ::: '[] :=>

144− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

145− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4

146− ]

147− , "other_tab" ::: '[] :=>

148− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

149− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4

150− ]

151− ] '[] '[]

152− manipulation =

153− insertQuery_ #tab

154− (selectStar (from (table (#other_tab `As` #t))))

155−in renderManipulation manipulation

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

186+ manipulation = insertInto_ #tab (Subquery (select Star (from (table #tab))))

187+in printSQL manipulation

156188:}

157−"INSERT INTO \"tab\" SELECT * FROM \"other_tab\" AS \"t\";"

189+INSERT INTO "tab" SELECT * FROM "tab" AS "tab"

158190

159191update:

160192

161193>>> :{

162194let

163− manipulation :: Manipulation

164− '[ "tab" ::: '[] :=>

165− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

166− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[] '[]

167− manipulation =

168− update_ #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)

169− (#col1 ./= #col2)

170−in renderManipulation manipulation

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

196+ manipulation = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)

197+in printSQL manipulation

171198:}

172−"UPDATE \"tab\" SET \"col1\" = 2 WHERE (\"col1\" <> \"col2\");"

199+UPDATE "tab" SET "col1" = 2 WHERE ("col1" <> "col2")

173200

174201delete:

175202

176203>>> :{

177204let

178− manipulation :: Manipulation

179− '[ "tab" ::: '[] :=>

180− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

181− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]] '[]

182− '[ "col1" ::: 'NotNull 'PGint4

183− , "col2" ::: 'NotNull 'PGint4 ]

184− manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar

185−in renderManipulation manipulation

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

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

207+in printSQL manipulation

186208:}

187−"DELETE FROM \"tab\" WHERE (\"col1\" = \"col2\") RETURNING *;"

209+DELETE FROM "tab" WHERE ("col1" = "col2") RETURNING *

210+

211+delete and using clause:

212+

213+>>> :{

214+type Schema3 =

215+ '[ "tab" ::: 'Table ('[] :=> Columns)

216+ , "other_tab" ::: 'Table ('[] :=> Columns)

217+ , "third_tab" ::: 'Table ('[] :=> Columns) ]

218+:}

219+

220+>>> :{

221+let

222+ manipulation :: Manipulation_ (Public Schema3) () ()

223+ manipulation =

224+ deleteFrom #tab (Using (table #other_tab & also (table #third_tab)))

225+ ( (#tab ! #col2 .== #other_tab ! #col2)

226+ .&& (#tab ! #col2 .== #third_tab ! #col2) )

227+ (Returning_ Nil)

228+in printSQL manipulation

229+:}

230+DELETE FROM "tab" USING "other_tab" AS "other_tab", "third_tab" AS "third_tab" WHERE (("tab"."col2" = "other_tab"."col2") AND ("tab"."col2" = "third_tab"."col2"))

231+

232+with manipulation:

233+

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

235+>>> type ProductsSchema = '["products" ::: 'Table ('[] :=> ProductsColumns), "products_deleted" ::: 'Table ('[] :=> ProductsColumns)]

236+>>> :{

237+let

238+ manipulation :: Manipulation_ (Public ProductsSchema) (Only Day) ()

239+ manipulation = with

240+ (deleteFrom #products NoUsing (#date .< param @1) (Returning Star) `as` #del)

241+ (insertInto_ #products_deleted (Subquery (select Star (from (common #del)))))

242+in printSQL manipulation

243+:}

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

188245-}

189−newtype Manipulation

190− (schema :: SchemaType)

191− (params :: [NullityType])

192− (columns :: RelationType)

193− = UnsafeManipulation { renderManipulation :: ByteString }

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

195248

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

197250queryStatement

198− :: Query schema params columns

199− -> Manipulation schema params columns

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

201255

202256{-----------------------------------------

203257INSERT statements

204258-----------------------------------------}

205259

206−-- | Insert multiple rows.

207−--

208−-- When a table is created, it contains no data. The first thing to do

209−-- before a database can be of much use is to insert data. Data is

210−-- conceptually inserted one row at a time. Of course you can also insert

211−-- more than one row, but there is no way to insert less than one row.

212−-- Even if you know only some column values, a complete row must be created.

213−insertRows

214− :: ( SOP.SListI columns

215− , SOP.SListI results

216− , Has tab (TablesOf schema) table

217− , columns ~ TableToColumns table )

218− => Alias tab -- ^ table to insert into

219− -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert

220− -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert

221− -> ConflictClause columns params

222− -- ^ what to do in case of constraint conflict

223− -> ReturningClause columns params results -- ^ results to return

224− -> Manipulation schema params results

225−insertRows tab row rows conflict returning = UnsafeManipulation $

226− "INSERT" <+> "INTO" <+> renderAlias tab

227− <+> parenthesized (renderCommaSeparated renderAliasPart row)

228− <+> "VALUES"

229− <+> commaSeparated

230− ( parenthesized

231− . renderCommaSeparated renderColumnValuePart <$> row:rows )

232− <> renderConflictClause conflict

233− <> renderReturningClause returning

260+{- |

261+When a table is created, it contains no data. The first thing to do

262+before a database can be of much use is to insert data. Data is

263+conceptually inserted one row at a time. Of course you can also insert

264+more than one row, but there is no way to insert less than one row.

265+Even if you know only some column values, a complete row must be created.

266+-}

267+insertInto

268+ :: ( Has sch schemas schema

269+ , Has tab schema ('Table table)

270+ , columns ~ TableToColumns table

271+ , row0 ~ TableToRow table

272+ , SOP.SListI columns

273+ , SOP.SListI row1 )

274+ => QualifiedAlias sch tab

275+ -- ^ table

276+ -> QueryClause commons schemas params columns

277+ -- ^ what to insert

278+ -> ConflictClause tab commons schemas params table

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

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

281+ -- ^ what to return

282+ -> Manipulation commons schemas params row1

283+insertInto tab qry conflict ret = UnsafeManipulation $

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

285+ <+> renderSQL qry

286+ <> renderSQL conflict

287+ <> renderSQL ret

288+

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

290+insertInto_

291+ :: ( Has sch schemas schema

292+ , Has tab schema ('Table table)

293+ , columns ~ TableToColumns table

294+ , row ~ TableToRow table

295+ , SOP.SListI columns )

296+ => QualifiedAlias sch tab

297+ -- ^ table

298+ -> QueryClause commons schemas params columns

299+ -- ^ what to insert

300+ -> Manipulation commons schemas params '[]

301+insertInto_ tab qry =

302+ insertInto tab qry OnConflictDoRaise (Returning_ Nil)

303+

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

305+data QueryClause commons schemas params columns where

306+ Values

307+ :: SOP.SListI columns

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

309+ -- ^ row of values

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

311+ -- ^ additional rows of values

312+ -> QueryClause commons schemas params columns

313+ Select

314+ :: SOP.SListI columns

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

316+ -- ^ row of values

317+ -> TableExpression '[] commons grp schemas params from

318+ -- ^ from a table expression

319+ -> QueryClause commons schemas params columns

320+ Subquery

321+ :: ColumnsToRow columns ~ row

322+ => Query '[] commons schemas params row

323+ -- ^ subquery to insert

324+ -> QueryClause commons schemas params columns

325+

326+instance RenderSQL (QueryClause commons schemas params columns) where

327+ renderSQL = \case

328+ Values row0 rows ->

329+ parenthesized (renderCommaSeparated renderSQLPart row0)

330+ <+> "VALUES"

331+ <+> commaSeparated

332+ ( parenthesized

333+ . renderCommaSeparated renderValuePart <$> row0 : rows )

334+ Select row0 tab ->

335+ parenthesized (renderCommaSeparatedMaybe renderSQLPartMaybe row0)

336+ <+> "SELECT"

337+ <+> renderCommaSeparatedMaybe renderValuePartMaybe row0

338+ <+> renderSQL tab

339+ Subquery qry -> renderQuery qry

234340 where

235− renderAliasPart, renderColumnValuePart

236− :: Aliased (ColumnValue '[] params) ty -> ByteString

237− renderAliasPart (_ `As` name) = renderAlias name

238− renderColumnValuePart (value `As` _) = case value of

239− Default -> "DEFAULT"

240− Set expression -> renderExpression expression

241−

242−-- | Insert a single row.

243−insertRow

244− :: ( SOP.SListI columns

245− , SOP.SListI results

246− , Has tab (TablesOf schema) table

247− , columns ~ TableToColumns table )

248− => Alias tab -- ^ table to insert into

249− -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert

250− -> ConflictClause columns params

251− -- ^ what to do in case of constraint conflict

252− -> ReturningClause columns params results -- ^ results to return

253− -> Manipulation schema params results

254−insertRow tab row = insertRows tab row []

255−

256−-- | Insert multiple rows returning `Nil` and raising an error on conflicts.

257−insertRows_

258− :: ( SOP.SListI columns

259− , Has tab (TablesOf schema) table

260− , columns ~ TableToColumns table )

261− => Alias tab -- ^ table to insert into

262− -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert

263− -> [NP (Aliased (ColumnValue '[] params)) columns] -- ^ more rows to insert

264− -> Manipulation schema params '[]

265−insertRows_ tab row rows =

266− insertRows tab row rows OnConflictDoRaise (Returning Nil)

267−

268−-- | Insert a single row returning `Nil` and raising an error on conflicts.

269−insertRow_

270− :: ( SOP.SListI columns

271− , Has tab (TablesOf schema) table

272− , columns ~ TableToColumns table )

273− => Alias tab -- ^ table to insert into

274− -> NP (Aliased (ColumnValue '[] params)) columns -- ^ row to insert

275− -> Manipulation schema params '[]

276−insertRow_ tab row = insertRow tab row OnConflictDoRaise (Returning Nil)

277−

278−-- | Insert a `Query`.

279−insertQuery

280− :: ( SOP.SListI columns

281− , SOP.SListI results

282− , Has tab (TablesOf schema) table

283− , columns ~ TableToColumns table )

284− => Alias tab -- ^ table to insert into

285− -> Query schema params (ColumnsToRelation columns)

286− -> ConflictClause columns params

287− -- ^ what to do in case of constraint conflict

288− -> ReturningClause columns params results -- ^ results to return

289− -> Manipulation schema params results

290−insertQuery tab query conflict returning = UnsafeManipulation $

291− "INSERT" <+> "INTO" <+> renderAlias tab

292− <+> renderQuery query

293− <> renderConflictClause conflict

294− <> renderReturningClause returning

295−

296−-- | Insert a `Query` returning `Nil` and raising an error on conflicts.

297−insertQuery_

298− :: ( SOP.SListI columns

299− , Has tab (TablesOf schema) table

300− , columns ~ TableToColumns table )

301− => Alias tab -- ^ table to insert into

302− -> Query schema params (ColumnsToRelation columns)

303− -> Manipulation schema params '[]

304−insertQuery_ tab query =

305− insertQuery tab query OnConflictDoRaise (Returning Nil)

306−

307−-- | `ColumnValue`s are values to insert or update in a row

308−-- `Same` updates with the same value.

309−-- `Default` inserts or updates with the @DEFAULT@ value

310−-- `Set` a value to be an `Expression`, relative to the given

311−-- row for an update, and closed for an insert.

312−data ColumnValue

313− (columns :: RelationType)

314− (params :: [NullityType])

315− (ty :: ColumnType)

316− where

317− Same :: ColumnValue (column ': columns) params ty

318− Default :: ColumnValue columns params ('Def :=> ty)

319− Set

320− :: (forall table. Expression '[table ::: columns] 'Ungrouped params ty)

321− -> ColumnValue columns params (constraint :=> ty)

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

322377

323378-- | A `ReturningClause` computes and return value(s) based

324379-- on each row actually inserted, updated or deleted. This is primarily

@@ -326,71 +381,100 @@ data ColumnValue

326381-- serial sequence number. However, any expression using the table's columns

327382-- is allowed. Only rows that were successfully inserted or updated or

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

329−-- but not updated because an `OnConflictDoUpdate` condition was not satisfied,

330−-- the row will not be returned. `ReturningStar` will return all columns

331−-- in the row. Use @Returning Nil@ in the common case where no return

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

332387-- values are desired.

333−data ReturningClause

334− (columns :: ColumnsType)

335− (params :: [NullityType])

336− (results :: RelationType)

337− where

338− ReturningStar

339− :: results ~ ColumnsToRelation columns

340− => ReturningClause columns params results

341− Returning

342− :: rel ~ ColumnsToRelation columns

343− => NP (Aliased (Expression '[table ::: rel] 'Ungrouped params)) results

344− -> ReturningClause columns params results

345−

346−-- | Render a `ReturningClause`.

347−renderReturningClause

348− :: SOP.SListI results

349− => ReturningClause params columns results

350− -> ByteString

351−renderReturningClause = \case

352− ReturningStar -> " RETURNING *;"

353− Returning Nil -> ";"

354− Returning results -> " RETURNING"

355− <+> renderCommaSeparated (renderAliasedAs renderExpression) results <> ";"

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)

356403

357404-- | A `ConflictClause` specifies an action to perform upon a constraint

358405-- violation. `OnConflictDoRaise` will raise an error.

359−-- `OnConflictDoNothing` simply avoids inserting a row.

360−-- `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

361408-- proposed for insertion.

362−data ConflictClause (columns :: ColumnsType) params where

363− OnConflictDoRaise :: ConflictClause columns params

364− OnConflictDoNothing :: ConflictClause columns params

365− OnConflictDoUpdate

366− :: NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns

367− -> [Condition '[table ::: ColumnsToRelation columns] 'Ungrouped params]

368− -> ConflictClause columns params

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)

369417

370418-- | Render a `ConflictClause`.

371−renderConflictClause

372− :: SOP.SListI columns

373− => 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

374463 -> ByteString

375−renderConflictClause = \case

376− OnConflictDoRaise -> ""

377− OnConflictDoNothing -> " ON CONFLICT DO NOTHING"

378− OnConflictDoUpdate updates whs'

379− -> " ON CONFLICT DO UPDATE SET"

380− <+> renderCommaSeparatedMaybe renderUpdate updates

381− <> case whs' of

382− [] -> ""

383− wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)

384− where

385− renderUpdate

386− :: Aliased (ColumnValue columns params) column

387− -> Maybe ByteString

388− renderUpdate = \case

389− Same `As` _ -> Nothing

390− Default `As` column -> Just $

391− renderAlias column <+> "=" <+> "DEFAULT"

392− Set expression `As` column -> Just $

393− renderAlias column <+> "=" <+> renderExpression expression

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

394478

395479{-----------------------------------------

396480UPDATE statements

@@ -400,113 +484,95 @@ UPDATE statements

400484-- in all rows that satisfy the condition.

401485update

402486 :: ( SOP.SListI columns

403− , SOP.SListI results

404− , Has tab (TablesOf schema) table

405− , columns ~ TableToColumns table )

406− => Alias tab -- ^ table to update

407− -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns

487+ , SOP.SListI row1

488+ , Has sch schemas schema

489+ , Has tab schema ('Table table)

490+ , row0 ~ TableToRow table

491+ , columns ~ TableToColumns table

492+ , SOP.All (HasIn columns) subcolumns

493+ , AllUnique subcolumns )

494+ => QualifiedAlias sch tab -- ^ table to update

495+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row0]))) subcolumns

408496 -- ^ modified values to replace old values

409− -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params

497+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row0]

410498 -- ^ condition under which to perform update on a row

411− -> ReturningClause columns params results -- ^ results to return

412− -> Manipulation schema params results

499+ -> ReturningClause commons schemas params '[tab ::: row0] row1 -- ^ results to return

500+ -> Manipulation commons schemas params row1

413501update tab columns wh returning = UnsafeManipulation $

414502 "UPDATE"

415− <+> renderAlias tab

503+ <+> renderSQL tab

416504 <+> "SET"

417− <+> renderCommaSeparatedMaybe renderUpdate columns

418− <+> "WHERE" <+> renderExpression wh

419− <> renderReturningClause returning

420− where

421− renderUpdate

422− :: Aliased (ColumnValue columns params) column

423− -> Maybe ByteString

424− renderUpdate = \case

425− Same `As` _ -> Nothing

426− Default `As` column -> Just $

427− renderAlias column <+> "=" <+> "DEFAULT"

428− Set expression `As` column -> Just $

429− renderAlias column <+> "=" <+> renderExpression expression

505+ <+> renderCommaSeparated renderUpdate columns

506+ <+> "WHERE" <+> renderSQL wh

507+ <> renderSQL returning

430508

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

432510update_

433511 :: ( SOP.SListI columns

434− , Has tab (TablesOf schema) table

435− , columns ~ TableToColumns table )

436− => Alias tab -- ^ table to update

437− -> NP (Aliased (ColumnValue (ColumnsToRelation columns) params)) columns

512+ , Has sch schemas schema

513+ , Has tab schema ('Table table)

514+ , row ~ TableToRow table

515+ , columns ~ TableToColumns table

516+ , SOP.All (HasIn columns) subcolumns

517+ , AllUnique subcolumns )

518+ => QualifiedAlias sch tab -- ^ table to update

519+ -> NP (Aliased (Optional (Expression '[] '[] 'Ungrouped schemas params '[tab ::: row]))) subcolumns

438520 -- ^ modified values to replace old values

439− -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params

521+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]

440522 -- ^ condition under which to perform update on a row

441− -> Manipulation schema params '[]

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

443525

444526{-----------------------------------------

445527DELETE statements

446528-----------------------------------------}

447529

448−-- | 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.

449547deleteFrom

450− :: ( SOP.SListI results

451− , Has tab (TablesOf schema) table

548+ :: ( SOP.SListI row1

549+ , Has sch schemas schema

550+ , Has tab schema ('Table table)

551+ , row0 ~ TableToRow table

452552 , columns ~ TableToColumns table )

453− => Alias tab -- ^ table to delete from

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

455556 -- ^ condition under which to delete a row

456− -> ReturningClause columns params results -- ^ results to return

457− -> Manipulation schema params results

458−deleteFrom tab wh returning = UnsafeManipulation $

459− "DELETE FROM" <+> renderAlias tab

460− <+> "WHERE" <+> renderExpression wh

461− <> renderReturningClause returning

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

462567

463568-- | Delete rows returning `Nil`.

464569deleteFrom_

465− :: ( Has tab (TablesOf schema) table

570+ :: ( Has sch schemas schema

571+ , Has tab schema ('Table table)

572+ , row ~ TableToRow table

466573 , columns ~ TableToColumns table )

467− => Alias tab -- ^ table to delete from

468− -> Condition '[tab ::: ColumnsToRelation columns] 'Ungrouped params

574+ => QualifiedAlias sch tab -- ^ table to delete from

575+ -> Condition '[] commons 'Ungrouped schemas params '[tab ::: row]

469576 -- ^ condition under which to delete a row

470− -> Manipulation schema params '[]

471−deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil)

472−

473−{-----------------------------------------

474−WITH statements

475−-----------------------------------------}

476−

477−-- | `with` provides a way to write auxiliary statements for use in a larger statement.

478−-- These statements, which are often referred to as Common Table Expressions or CTEs,

479−-- can be thought of as defining temporary tables that exist just for one statement.

480−--

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

482−--

483−-- >>> :{

484−-- let

485−-- manipulation :: Manipulation '["products" ::: ProductsTable, "products_deleted" ::: ProductsTable] '[ 'NotNull 'PGdate] '[]

486−-- manipulation = with

487−-- (deleteFrom #products (#date .< param @1) ReturningStar `As` #deleted_rows :* Nil)

488−-- (insertQuery_ #products_deleted (selectStar (from (table (#deleted_rows `As` #t)))))

489−-- in renderManipulation manipulation

490−-- :}

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

492−with

493− :: SOP.SListI commons

494− => NP (Aliased (Manipulation schema params)) commons

495− -- ^ common table expressions

496− -> Manipulation (With commons schema) params results

497− -> Manipulation schema params results

498−with commons manipulation = UnsafeManipulation $

499− "WITH" <+> renderCommaSeparated renderCommon commons

500− <+> renderManipulation manipulation

501− where

502− renderCommon

503− :: Aliased (Manipulation schema params) common

504− -> ByteString

505− renderCommon (common `As` alias) =

506− renderAlias alias <+> "AS" <+>

507− let

508− str = renderManipulation common

509− len = ByteString.length str

510− str' = ByteString.take (len - 1) str -- remove ';'

511− in

512− parenthesized str'

577+ -> Manipulation commons schemas params '[]

578+deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil)

squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+349−219

@@ -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,250 +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" ::: 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 & notNull) `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" ::: UsersTable]

49− '["users" ::: UsersTable, "emails" ::: 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 & notNull) `As` #user_id :*

56− text `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 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

93− ScopedTypeVariables

94− , OverloadedStrings

95− , DataKinds

125+ DataKinds

126+ , DeriveGeneric

127+ , FlexibleContexts

128+ , FlexibleInstances

96129 , GADTs

97130 , LambdaCase

98− , PolyKinds

99131 , OverloadedLabels

132+ , OverloadedStrings

133+ , PolyKinds

134+ , QuantifiedConstraints

135+ , RankNTypes

100136 , TypeApplications

101− , FlexibleContexts

102137 , TypeOperators

103138#-}

104139

105140module Squeal.PostgreSQL.Migration

106141 ( -- * Migration

107142 Migration (..)

108− , migrateUp

109− , migrateDown

110− -- * Aligned lists

111− , AlignedList (..)

112− , single

113− -- * Migration table

143+ , Migratory (..)

144+ , Terminally (..)

145+ , terminally

146+ , pureMigration

114147 , MigrationsTable

115− , createMigrations

116− , insertMigration

117− , deleteMigration

118− , selectMigration

148+ , defaultMain

119149 ) where

120150

121151import Control.Category

122152import Control.Monad

123−import Control.Monad.Base

124−import Control.Monad.Trans.Control

125−import Data.Monoid

126−import Generics.SOP (K(..))

153+import Data.ByteString (ByteString)

154+import Data.Foldable (traverse_)

127155import Data.Function ((&))

156+import Data.List ((\\))

128157import Data.Text (Text)

129−import Prelude hiding (id, (.))

158+import Data.Time (UTCTime)

159+import Prelude hiding ((.), id)

160+import System.Environment

161+import UnliftIO (MonadIO (..))

130162

131−import Squeal.PostgreSQL

163+import qualified Data.Text.IO as Text (putStrLn)

164+import qualified Generics.SOP as SOP

165+import qualified GHC.Generics as GHC

132166

133−-- | A `Migration` should contain an inverse pair of

134−-- `up` and `down` instructions and a unique `name`.

135−data Migration io schema0 schema1 = Migration

167+import Squeal.PostgreSQL.Alias

168+import Squeal.PostgreSQL.Binary

169+import Squeal.PostgreSQL.Definition

170+import Squeal.PostgreSQL.Definition.Table

171+import Squeal.PostgreSQL.Definition.Table.Constraint

172+import Squeal.PostgreSQL.Expression.Comparison

173+import Squeal.PostgreSQL.Expression.Parameter

174+import Squeal.PostgreSQL.Expression.Time

175+import Squeal.PostgreSQL.Expression.Type

176+import Squeal.PostgreSQL.List

177+import Squeal.PostgreSQL.Manipulation

178+import Squeal.PostgreSQL.PQ

179+import Squeal.PostgreSQL.Query

180+import Squeal.PostgreSQL.Schema

181+import Squeal.PostgreSQL.Transaction

182+

183+-- | A `Migration` is a named "isomorphism" over a given category.

184+-- It should contain an inverse pair of `up` and `down`

185+-- instructions and a unique `name`.

186+data Migration p schemas0 schemas1 = Migration

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

137188 -- Each `name` in a `Migration` should be unique.

138− , up :: PQ schema0 schema1 io () -- ^ The `up` instruction of a `Migration`.

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

140260 }

141261

142−-- | An `AlignedList` is a type-aligned list or free category.

143−data AlignedList p x0 x1 where

144− Done :: AlignedList p x x

145− (:>>) :: p x0 x1 -> AlignedList p x1 x2 -> AlignedList p x0 x2

146−infixr 7 :>>

147−instance Category (AlignedList p) where

148− id = Done

149− (.) list = \case

150− Done -> list

151− step :>> steps -> step :>> (steps >>> list)

152−

153−-- | A `single` step.

154−single :: p x0 x1 -> AlignedList p x0 x1

155−single step = step :>> Done

156−

157−-- | Run `Migration`s by creating the `MigrationsTable`

158−-- if it does not exist and then in a transaction, for each each `Migration`

159−-- query to see if the `Migration` is executed. If not, then

160−-- execute the `Migration` and insert its row in the `MigrationsTable`.

161−migrateUp

162− :: MonadBaseControl IO io

163− => AlignedList (Migration io) schema0 schema1 -- ^ migrations to run

164− -> PQ

165− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

166− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

167− io ()

168−migrateUp migration =

169− define createMigrations

170− & pqBind okResult

171− & pqThen (transactionallySchema_ (upMigrations migration))

172− where

262+instance Migratory (Terminally PQ IO) where

173263

174− upMigrations

175− :: MonadBaseControl IO io

176− => AlignedList (Migration io) schema0 schema1

177− -> PQ

178− ("schema_migrations" ::: MigrationsTable ': schema0)

179− ("schema_migrations" ::: MigrationsTable ': schema1)

180− io ()

181− upMigrations = \case

182− Done -> return ()

183− step :>> steps -> upMigration step & pqThen (upMigrations steps)

184−

185− upMigration

186− :: MonadBase IO io

187− => Migration io schema0 schema1 -> PQ

188− ("schema_migrations" ::: MigrationsTable ': schema0)

189− ("schema_migrations" ::: MigrationsTable ': schema1)

190− io ()

191− upMigration step =

192− queryExecuted step

193− & pqBind (\ executed ->

194− if executed == 1 -- up step has already been executed

195− then PQ (\ _ -> return (K ())) -- unsafely switch schemas

196− else

197− pqEmbed (up step) -- safely switch schemas

198− & pqThen (manipulateParams insertMigration (Only (name step)))

199− -- insert execution record

200− & pqBind okResult)

201−

202− queryExecuted

203− :: MonadBase IO io

204− => Migration io schema0 schema1 -> PQ

205− ("schema_migrations" ::: MigrationsTable ': schema0)

206− ("schema_migrations" ::: MigrationsTable ': schema0)

207− io Row

208− queryExecuted step = do

209− result <- runQueryParams selectMigration (Only (name step))

210− okResult result

211− ntuples result

212−

213−-- | Rewind `Migration`s by creating the `MigrationsTable`

214−-- if it does not exist and then in a transaction, for each each `Migration`

215−-- query to see if the `Migration` is executed. If it is, then

216−-- rewind the `Migration` and delete its row in the `MigrationsTable`.

217−migrateDown

218− :: MonadBaseControl IO io

219− => AlignedList (Migration io) schema0 schema1 -- ^ migrations to rewind

220− -> PQ

221− ("schema_migrations" ::: 'Table MigrationsTable ': schema1)

222− ("schema_migrations" ::: 'Table MigrationsTable ': schema0)

223− io ()

224−migrateDown migrations =

225− define createMigrations

226− & pqBind okResult

227− & pqThen (transactionallySchema_ (downMigrations migrations))

228− where

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

229298

230− downMigrations

231− :: MonadBaseControl IO io

232− => AlignedList (Migration io) schema0 schema1 -> PQ

233− ("schema_migrations" ::: MigrationsTable ': schema1)

234− ("schema_migrations" ::: MigrationsTable ': schema0)

235− io ()

236− downMigrations = \case

237− Done -> return ()

238− step :>> steps -> downMigrations steps & pqThen (downMigration step)

239−

240− downMigration

241− :: MonadBase IO io

242− => Migration io schema0 schema1 -> PQ

243− ("schema_migrations" ::: MigrationsTable ': schema1)

244− ("schema_migrations" ::: MigrationsTable ': schema0)

245− io ()

246− downMigration step =

247− queryExecuted step

248− & pqBind (\ executed ->

249− if executed == 0 -- up step has not been executed

250− then PQ (\ _ -> return (K ())) -- unsafely switch schemas

251− else

252− pqEmbed (down step) -- safely switch schemas

253− & pqThen (manipulateParams deleteMigration (Only (name step)))

254− -- delete execution record

255− & pqBind okResult)

256−

257− queryExecuted

258− :: MonadBase IO io

259− => Migration io schema0 schema1 -> PQ

260− ("schema_migrations" ::: MigrationsTable ': schema1)

261− ("schema_migrations" ::: MigrationsTable ': schema1)

262− io Row

263− queryExecuted step = do

264− result <- runQueryParams selectMigration (Only (name step))

265− okResult result

266− ntuples result

267−

268−okResult :: MonadBase IO io => K Result results -> PQ schema schema io ()

269−okResult result = do

270− status <- resultStatus result

271− when (not (status `elem` [CommandOk, TuplesOk])) $ do

272− errorMessageMaybe <- resultErrorMessage result

273− case errorMessageMaybe of

274− Nothing -> error "migrateDown: unknown error"

275− Just msg -> error ("migrationDown: " <> show msg)

299+ downMigrations

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

301+ -> PQ MigrationsSchemas MigrationsSchemas IO ()

302+ downMigrations = \case

303+ Done -> return ()

304+ step :>> steps -> downMigrations steps >> downMigration step

305+

306+ downMigration

307+ :: Migration (Terminally PQ IO) schemas0 schemas1

308+ -> PQ MigrationsSchemas MigrationsSchemas IO ()

309+ downMigration step = do

310+ executed <- queryExecuted step

311+ unless (executed == 0) $ do

312+ unsafePQ . runTerminally $ down step

313+ manipulateParams_ deleteMigration (Only (name step))

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

276324

277325-- | The `TableType` for a Squeal migration.

278326type MigrationsTable =

@@ -281,38 +329,120 @@ type MigrationsTable =

281329 , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz

282330 ]

283331

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+

284343-- | Creates a `MigrationsTable` if it does not already exist.

285−createMigrations

286− :: Has "schema_migrations" (TablesOf schema) MigrationsTable

287− => Definition schema schema

344+createMigrations :: Definition MigrationsSchemas MigrationsSchemas

288345createMigrations =

289346 createTableIfNotExists #schema_migrations

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

291− (timestampWithTimeZone & notNull & default_ currentTimestamp)

292− `As` #executed_at :* Nil )

293− ( unique (#name :* Nil) `As` #migrations_unique_name :* Nil )

294−

295−-- | Inserts a `Migration` into the `MigrationsTable`

296−insertMigration

297− :: Has "schema_migrations" (TablesOf schema) MigrationsTable

298− => Manipulation schema '[ 'NotNull 'PGtext] '[]

299−insertMigration = insertRow_ #schema_migrations

300− ( Set (param @1) `As` #name :*

301− Default `As` #executed_at :* Nil )

302−

303−-- | Deletes a `Migration` from the `MigrationsTable`

304−deleteMigration

305− :: Has "schema_migrations" (TablesOf schema) MigrationsTable

306− => 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) ()

307361deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)

308362

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

310−-- the time at which it was executed.

364+-- the time at which it was inserted.

311365selectMigration

312− :: Has "schema_migrations" schema MigrationsTable

313− => Query schema '[ 'NotNull 'PGtext ]

314− '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]

315−selectMigration = select

316− (#executed_at `As` #executed_at :* Nil)

317− ( from (table (#schema_migrations `As` #m))

318− & where_ (#name .== param @1))

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+314−217

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

@@ -20,15 +20,11 @@ of executing Squeal commands.

2020

2121{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

2222{-# LANGUAGE

23− DataKinds

24− , DefaultSignatures

23+ DefaultSignatures

2524 , FunctionalDependencies

26− , PolyKinds

27− , DeriveFunctor

2825 , FlexibleContexts

2926 , FlexibleInstances

30− , MagicHash

31− , MultiParamTypeClasses

27+ , InstanceSigs

3228 , OverloadedStrings

3329 , RankNTypes

3430 , ScopedTypeVariables

@@ -53,9 +49,7 @@ module Squeal.PostgreSQL.PQ

5349 , evalPQ

5450 , IndexedMonadTransPQ (..)

5551 , MonadPQ (..)

56− , PQRun

57− , pqliftWith

58− -- * Result

52+ -- * Results

5953 , LibPQ.Result

6054 , LibPQ.Row

6155 , ntuples

@@ -67,22 +61,33 @@ module Squeal.PostgreSQL.PQ

6761 , LibPQ.ExecStatus (..)

6862 , resultStatus

6963 , resultErrorMessage

64+ , resultErrorCode

65+ -- * Exceptions

66+ , SquealException (..)

67+ , PQState (..)

68+ , okResult

69+ , catchSqueal

70+ , handleSqueal

71+ , trySqueal

7072 ) where

7173

72−import Control.Exception.Lifted

73−import Control.Monad.Base

74+import Control.Exception (Exception, throw)

7475import Control.Monad.Except

7576import Control.Monad.Morph

76−import Control.Monad.Trans.Control

77+import UnliftIO (MonadUnliftIO (..), bracket, catch, handle, try)

7778import Data.ByteString (ByteString)

7879import Data.Foldable

7980import Data.Function ((&))

81+import Data.Functor ((<&>))

8082import Data.Kind

81−import Data.Monoid

83+import Data.Text (pack, Text)

8284import Data.Traversable

8385import Generics.SOP

86+import PostgreSQL.Binary.Encoding (encodingBytes)

8487

88+import qualified Control.Monad.Fail as Fail

8589import qualified Database.PostgreSQL.LibPQ as LibPQ

90+import qualified PostgreSQL.Binary.Encoding as Encoding

8691

8792import Squeal.PostgreSQL.Binary

8893import Squeal.PostgreSQL.Definition

@@ -95,7 +100,6 @@ import Control.Monad.Trans.Identity

95100import Control.Monad.Trans.Reader

96101import Control.Monad.Trans.Maybe

97102import Control.Monad.Trans.Cont

98−import Control.Monad.Trans.List

99103

100104import qualified Control.Monad.Trans.State.Lazy as Lazy

101105import qualified Control.Monad.Trans.State.Strict as Strict

@@ -104,6 +108,9 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict

104108import qualified Control.Monad.Trans.RWS.Lazy as Lazy

105109import qualified Control.Monad.Trans.RWS.Strict as Strict

106110

111+-- $setup

112+-- >>> import Squeal.PostgreSQL

113+

107114{- | Makes a new connection to the database server.

108115

109116This function opens a new database connection using the parameters taken

@@ -130,22 +137,22 @@ Note that, for now, squeal doesn't offer any protection from connecting

130137with the wrong schema!

131138-}

132139connectdb

133− :: forall schema io

134− . MonadBase IO io

140+ :: forall schemas io

141+ . MonadIO io

135142 => ByteString -- ^ conninfo

136− -> io (K LibPQ.Connection schema)

137−connectdb = fmap K . liftBase . LibPQ.connectdb

143+ -> io (K LibPQ.Connection schemas)

144+connectdb = fmap K . liftIO . LibPQ.connectdb

138145

139146-- | Closes the connection to the server.

140−finish :: MonadBase IO io => K LibPQ.Connection schema -> io ()

141−finish = liftBase . LibPQ.finish . unK

147+finish :: MonadIO io => K LibPQ.Connection schemas -> io ()

148+finish = liftIO . LibPQ.finish . unK

142149

143150-- | Do `connectdb` and `finish` before and after a computation.

144151withConnection

145− :: forall schema0 schema1 io x

146− . MonadBaseControl IO io

152+ :: forall schemas0 schemas1 io x

153+ . MonadUnliftIO io

147154 => ByteString

148− -> PQ schema0 schema1 io x

155+ -> PQ schemas0 schemas1 io x

149156 -> io x

150157withConnection connString action = do

151158 K x <- bracket (connectdb connString) finish (unPQ action)

@@ -153,47 +160,47 @@ withConnection connString action = do

153160

154161-- | Safely `lowerConnection` to a smaller schema.

155162lowerConnection

156− :: K LibPQ.Connection (table ': schema)

157− -> K LibPQ.Connection schema

163+ :: K LibPQ.Connection (schema ': schemas)

164+ -> K LibPQ.Connection schemas

158165lowerConnection (K conn) = K conn

159166

160167-- | We keep track of the schema via an Atkey indexed state monad transformer,

161168-- `PQ`.

162169newtype PQ

163− (schema0 :: SchemaType)

164− (schema1 :: SchemaType)

170+ (schemas0 :: SchemasType)

171+ (schemas1 :: SchemasType)

165172 (m :: Type -> Type)

166173 (x :: Type) =

167− PQ { unPQ :: K LibPQ.Connection schema0 -> m (K x schema1) }

174+ PQ { unPQ :: K LibPQ.Connection schemas0 -> m (K x schemas1) }

168175

169−instance Monad m => Functor (PQ schema0 schema1 m) where

176+instance Monad m => Functor (PQ schemas0 schemas1 m) where

170177 fmap f (PQ pq) = PQ $ \ conn -> do

171178 K x <- pq conn

172179 return $ K (f x)

173180

174−-- | Run a `PQ` and keep the result and the `Connection`.

181+-- | Run a `PQ` and keep the result and the `LibPQ.Connection`.

175182runPQ

176183 :: Functor m

177− => PQ schema0 schema1 m x

178− -> K LibPQ.Connection schema0

179− -> m (x, K LibPQ.Connection schema1)

184+ => PQ schemas0 schemas1 m x

185+ -> K LibPQ.Connection schemas0

186+ -> m (x, K LibPQ.Connection schemas1)

180187runPQ (PQ pq) conn = (\ x -> (unK x, K (unK conn))) <$> pq conn

181188 -- K x <- pq conn

182189 -- return (x, K (unK conn))

183190

184−-- | Execute a `PQ` and discard the result but keep the `Connection`.

191+-- | Execute a `PQ` and discard the result but keep the `LibPQ.Connection`.

185192execPQ

186193 :: Functor m

187− => PQ schema0 schema1 m x

188− -> K LibPQ.Connection schema0

189− -> m (K LibPQ.Connection schema1)

194+ => PQ schemas0 schemas1 m x

195+ -> K LibPQ.Connection schemas0

196+ -> m (K LibPQ.Connection schemas1)

190197execPQ (PQ pq) conn = mapKK (\ _ -> unK conn) <$> pq conn

191198

192−-- | Evaluate a `PQ` and discard the `Connection` but keep the result.

199+-- | Evaluate a `PQ` and discard the `LibPQ.Connection` but keep the result.

193200evalPQ

194201 :: Functor m

195− => PQ schema0 schema1 m x

196− -> K LibPQ.Connection schema0

202+ => PQ schemas0 schemas1 m x

203+ -> K LibPQ.Connection schemas0

197204 -> m x

198205evalPQ (PQ pq) conn = unK <$> pq conn

199206

@@ -201,60 +208,56 @@ evalPQ (PQ pq) conn = unK <$> pq conn

201208-- [enriched category](https://ncatlab.org/nlab/show/enriched+category).

202209-- An indexed monad transformer transforms a `Monad` into an indexed monad.

203210-- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that

204−-- support running `Definition`s using `define` and embedding a computation

205−-- in a larger schema using `pqEmbed`.

211+-- support running `Definition`s using `define`.

206212class IndexedMonadTransPQ pq where

207213

208214 -- | indexed analog of `<*>`

209215 pqAp

210216 :: Monad m

211− => pq schema0 schema1 m (x -> y)

212− -> pq schema1 schema2 m x

213− -> pq schema0 schema2 m y

217+ => pq schemas0 schemas1 m (x -> y)

218+ -> pq schemas1 schemas2 m x

219+ -> pq schemas0 schemas2 m y

214220

215221 -- | indexed analog of `join`

216222 pqJoin

217223 :: Monad m

218− => pq schema0 schema1 m (pq schema1 schema2 m y)

219− -> pq schema0 schema2 m y

224+ => pq schemas0 schemas1 m (pq schemas1 schemas2 m y)

225+ -> pq schemas0 schemas2 m y

220226 pqJoin pq = pq & pqBind id

221227

222228 -- | indexed analog of `=<<`

223229 pqBind

224230 :: Monad m

225− => (x -> pq schema1 schema2 m y)

226− -> pq schema0 schema1 m x

227− -> pq schema0 schema2 m y

231+ => (x -> pq schemas1 schemas2 m y)

232+ -> pq schemas0 schemas1 m x

233+ -> pq schemas0 schemas2 m y

228234

229235 -- | indexed analog of flipped `>>`

230236 pqThen

231237 :: Monad m

232− => pq schema1 schema2 m y

233− -> pq schema0 schema1 m x

234− -> pq schema0 schema2 m y

238+ => pq schemas1 schemas2 m y

239+ -> pq schemas0 schemas1 m x

240+ -> pq schemas0 schemas2 m y

235241 pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)

236242

237243 -- | indexed analog of `<=<`

238244 pqAndThen

239245 :: Monad m

240− => (y -> pq schema1 schema2 m z)

241− -> (x -> pq schema0 schema1 m y)

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

243249 pqAndThen g f x = pqBind g (f x)

244250

245− -- | Safely embed a computation in a larger schema.

246− pqEmbed

247− :: Monad m

248− => pq schema0 schema1 m x

249− -> pq (table ': schema0) (table : schema1) m x

250−

251− -- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law

251+ -- | Run a `Definition` with `LibPQ.exec`.

252+ --

253+ -- It should be functorial in effect.

252254 --

253− -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@

255+ -- @define id = return ()@

256+ -- @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@

254257 define

255− :: MonadBase IO io

256− => Definition schema0 schema1

257− -> pq schema0 schema1 io (K LibPQ.Result '[])

258+ :: MonadIO io

259+ => Definition schemas0 schemas1

260+ -> pq schemas0 schemas1 io ()

258261

259262instance IndexedMonadTransPQ PQ where

260263

@@ -267,26 +270,26 @@ instance IndexedMonadTransPQ PQ where

267270 K x' <- x conn

268271 unPQ (f x') (K (unK conn))

269272

270− pqEmbed (PQ pq) = PQ $ \ (K conn) -> do

271− K x <- pq (K conn)

272− return $ K x

273−

274273 define (UnsafeDefinition q) = PQ $ \ (K conn) -> do

275− resultMaybe <- liftBase $ LibPQ.exec conn q

274+ resultMaybe <- liftIO $ LibPQ.exec conn q

276275 case resultMaybe of

277− Nothing -> error

276+ Nothing -> throw $ ResultException

278277 "define: LibPQ.exec returned no results"

279− Just result -> return $ K (K result)

278+ Just result -> K <$> okResult_ result

280279

281−{- | `MonadPQ` is an `mtl` style constraint, similar to

282−`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

283282

284283* `manipulateParams` runs a `Manipulation` with params from a type

285284 with a `ToParams` constraint. It calls `LibPQ.execParams` and

286285 doesn't afraid of anything.

287286

287+* `manipulateParams_` is like `manipulateParams` for a returning-free statement.

288+

288289* `manipulate` is like `manipulateParams` for a parameter-free statement.

289290

291+* `manipulate_` is like `manipulate` for a returning-free statement.

292+

290293* `runQueryParams` is like `manipulateParams` for query statements.

291294

292295* `runQuery` is like `runQueryParams` for a parameter-free statement.

@@ -300,11 +303,11 @@ instance IndexedMonadTransPQ PQ where

300303* `forPrepared` is a flipped `traversePrepared`

301304

302305* `traversePrepared_` is like `traversePrepared` but works on `Foldable`

303− containers and returns unit.

306+ containers for a returning-free statement.

304307

305308* `forPrepared_` is a flipped `traversePrepared_`.

306309

307−* `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

308311 into your monad.

309312

310313To define an instance, you can minimally define only `manipulateParams`,

@@ -312,304 +315,398 @@ To define an instance, you can minimally define only `manipulateParams`,

312315a default instance.

313316

314317-}

315−class Monad pq => MonadPQ schema pq | pq -> schema where

318+class Monad pq => MonadPQ schemas pq | pq -> schemas where

316319 manipulateParams

317− :: ToParams x params

318− => Manipulation schema params ys

319− -- ^ `insertRows`, `update` or `deleteFrom`

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

321+ => Manipulation '[] schemas params ys

322+ -- ^ `insertInto`, `update` or `deleteFrom`

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

321324 default manipulateParams

322− :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

323− => ToParams x params

324− => Manipulation schema params ys

325− -- ^ `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`

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

327330 manipulateParams manipulation params = lift $

328331 manipulateParams manipulation params

329332

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

331341 manipulate statement = manipulateParams statement ()

332342

343+ manipulate_ :: Manipulation '[] schemas '[] '[] -> pq ()

344+ manipulate_ = void . manipulate

345+

333346 runQueryParams

334− :: ToParams x params

335− => Query schema params ys

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

348+ => Query '[] '[] schemas params ys

336349 -- ^ `select` and friends

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

338351 runQueryParams = manipulateParams . queryStatement

339352

340353 runQuery

341− :: Query schema '[] ys

354+ :: Query '[] '[] schemas '[] ys

342355 -- ^ `select` and friends

343356 -> pq (K LibPQ.Result ys)

344357 runQuery q = runQueryParams q ()

345358

346359 traversePrepared

347− :: (ToParams x params, Traversable list)

348− => Manipulation schema params ys

349− -- ^ `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

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

351364 default traversePrepared

352− :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

353− => (ToParams x params, Traversable list)

354− => Manipulation schema params ys -> list x -> pq (list (K LibPQ.Result ys))

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

355368 traversePrepared manipulation params = lift $

356369 traversePrepared manipulation params

357370

358371 forPrepared

359− :: (ToParams x params, Traversable list)

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

360373 => list x

361− -> Manipulation schema params ys

362− -- ^ `insertRows`, `update` or `deleteFrom`

374+ -> Manipulation '[] schemas params ys

375+ -- ^ `insertInto`, `update` or `deleteFrom`

363376 -> pq (list (K LibPQ.Result ys))

364377 forPrepared = flip traversePrepared

365378

366379 traversePrepared_

367− :: (ToParams x params, Foldable list)

368− => Manipulation schema params '[]

369− -- ^ `insertRows`, `update` or `deleteFrom`

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

381+ => Manipulation '[] schemas params '[]

382+ -- ^ `insertInto`, `update` or `deleteFrom`

370383 -> list x -> pq ()

371384 default traversePrepared_

372− :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

373− => (ToParams x params, Foldable list)

374− => Manipulation schema params '[]

375− -- ^ `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`

376389 -> list x -> pq ()

377390 traversePrepared_ manipulation params = lift $

378391 traversePrepared_ manipulation params

379392

380393 forPrepared_

381− :: (ToParams x params, Foldable list)

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

382395 => list x

383− -> Manipulation schema params '[]

384− -- ^ `insertRows`, `update` or `deleteFrom`

396+ -> Manipulation '[] schemas params '[]

397+ -- ^ `insertInto`, `update` or `deleteFrom`

385398 -> pq ()

386399 forPrepared_ = flip traversePrepared_

387400

388401 liftPQ :: (LibPQ.Connection -> IO a) -> pq a

389402 default liftPQ

390− :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

403+ :: (MonadTrans t, MonadPQ schemas pq1, pq ~ t pq1)

391404 => (LibPQ.Connection -> IO a) -> pq a

392405 liftPQ = lift . liftPQ

393406

394−instance (MonadBase IO io, schema0 ~ schema, schema1 ~ schema)

395− => MonadPQ schema (PQ schema0 schema1 io) where

407+instance (MonadIO io, schemas0 ~ schemas, schemas1 ~ schemas)

408+ => MonadPQ schemas (PQ schemas0 schemas1 io) where

396409

397410 manipulateParams

398− (UnsafeManipulation q :: Manipulation schema ps ys) (params :: x) =

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

399412 PQ $ \ (K conn) -> do

400413 let

401− toParam' bytes = (LibPQ.invalidOid,bytes,LibPQ.Binary)

402− params' = fmap (fmap toParam') (hcollapse (toParams @x @ps params))

403− resultMaybe <- liftBase $ LibPQ.execParams conn q params' LibPQ.Binary

414+ paramSet

415+ :: forall param. OidOfParam param

416+ => K (Maybe Encoding.Encoding) param

417+ -> K (Maybe (LibPQ.Oid, ByteString, LibPQ.Format)) param

418+ paramSet (K maybeEncoding) = K $

419+ maybeEncoding <&> \encoding ->

420+ (oidOfParam @param, encodingBytes encoding, LibPQ.Binary)

421+ params'

422+ = hcollapse

423+ . hcmap (Proxy @OidOfParam) paramSet

424+ $ toParams @x @ps params

425+ q' = q <> ";"

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

404427 case resultMaybe of

405− Nothing -> error

428+ Nothing -> throw $ ResultException

406429 "manipulateParams: LibPQ.execParams returned no results"

407− Just result -> return $ K (K result)

430+ Just result -> do

431+ okResult_ result

432+ return $ K (K result)

408433

409434 traversePrepared

410− (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

411− PQ $ \ (K conn) -> liftBase $ do

412− let temp = "temporary_statement"

413− prepResultMaybe <- LibPQ.prepare conn temp q Nothing

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

414446 case prepResultMaybe of

415− Nothing -> error

447+ Nothing -> throw $ ResultException

416448 "traversePrepared: LibPQ.prepare returned no results"

417− Just prepResult -> do

418− status <- LibPQ.resultStatus prepResult

419− unless (status == LibPQ.CommandOk) . error $

420− "traversePrepared: LibPQ.prepare status " <> show status

449+ Just prepResult -> okResult_ prepResult

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

422451 let

423− toParam' bytes = (bytes,LibPQ.Binary)

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

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

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

426455 case resultMaybe of

427− Nothing -> error

456+ Nothing -> throw $ ResultException

428457 "traversePrepared: LibPQ.execParams returned no results"

429− Just result -> return $ K result

458+ Just result -> do

459+ okResult_ result

460+ return $ K result

430461 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

431462 case deallocResultMaybe of

432− Nothing -> error

463+ Nothing -> throw $ ResultException

433464 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

434− Just deallocResult -> do

435− status <- LibPQ.resultStatus deallocResult

436− unless (status == LibPQ.CommandOk) . error $

437− "traversePrepared: DEALLOCATE status " <> show status

465+ Just deallocResult -> okResult_ deallocResult

438466 return (K results)

439467

440468 traversePrepared_

441− (UnsafeManipulation q :: Manipulation schema xs '[]) (list :: list x) =

442− PQ $ \ (K conn) -> liftBase $ do

443− let temp = "temporary_statement"

444− prepResultMaybe <- LibPQ.prepare conn temp q Nothing

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

445480 case prepResultMaybe of

446− Nothing -> error

481+ Nothing -> throw $ ResultException

447482 "traversePrepared_: LibPQ.prepare returned no results"

448− Just prepResult -> do

449− status <- LibPQ.resultStatus prepResult

450− unless (status == LibPQ.CommandOk) . error $

451− "traversePrepared: LibPQ.prepare status " <> show status

483+ Just prepResult -> okResult_ prepResult

452484 for_ list $ \ params -> do

453485 let

454− toParam' bytes = (bytes,LibPQ.Binary)

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

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

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

457489 case resultMaybe of

458− Nothing -> error

490+ Nothing -> throw $ ResultException

459491 "traversePrepared_: LibPQ.execParams returned no results"

460− Just _result -> return ()

492+ Just result -> okResult_ result

461493 deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

462494 case deallocResultMaybe of

463− Nothing -> error

495+ Nothing -> throw $ ResultException

464496 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

465− Just deallocResult -> do

466− status <- LibPQ.resultStatus deallocResult

467− unless (status == LibPQ.CommandOk) . error $

468− "traversePrepared: DEALLOCATE status " <> show status

497+ Just deallocResult -> okResult_ deallocResult

469498 return (K ())

470499

471500 liftPQ pq = PQ $ \ (K conn) -> do

472− y <- liftBase $ pq conn

501+ y <- liftIO $ pq conn

473502 return (K y)

474503

475−instance MonadPQ schema m => MonadPQ schema (IdentityT m)

476−instance MonadPQ schema m => MonadPQ schema (ReaderT r m)

477−instance MonadPQ schema m => MonadPQ schema (Strict.StateT s m)

478−instance MonadPQ schema m => MonadPQ schema (Lazy.StateT s m)

479−instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Strict.WriterT w m)

480−instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Lazy.WriterT w m)

481−instance MonadPQ schema m => MonadPQ schema (MaybeT m)

482−instance MonadPQ schema m => MonadPQ schema (ExceptT e m)

483−instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Strict.RWST r w s m)

484−instance (Monoid w, MonadPQ schema m) => MonadPQ schema (Lazy.RWST r w s m)

485−instance MonadPQ schema m => MonadPQ schema (ContT r m)

486−instance MonadPQ schema m => MonadPQ schema (ListT m)

487−

488−instance (Monad m, schema0 ~ schema1)

489− => Applicative (PQ schema0 schema1 m) where

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

490518 pure x = PQ $ \ _conn -> pure (K x)

491519 (<*>) = pqAp

492520

493−instance (Monad m, schema0 ~ schema1)

494− => Monad (PQ schema0 schema1 m) where

521+instance (Monad m, schemas0 ~ schemas1)

522+ => Monad (PQ schemas0 schemas1 m) where

495523 return = pure

496524 (>>=) = flip pqBind

497525

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

499531 hoist f (PQ pq) = PQ (f . pq)

500532

501−instance schema0 ~ schema1 => MonadTrans (PQ schema0 schema1) where

533+instance schemas0 ~ schemas1 => MonadTrans (PQ schemas0 schemas1) where

502534 lift m = PQ $ \ _conn -> do

503535 x <- m

504536 return (K x)

505537

506−instance schema0 ~ schema1 => MMonad (PQ schema0 schema1) where

538+instance schemas0 ~ schemas1 => MMonad (PQ schemas0 schemas1) where

507539 embed f (PQ pq) = PQ $ \ conn -> do

508540 evalPQ (f (pq conn)) conn

509541

510−instance (MonadBase b m, schema0 ~ schema1)

511− => MonadBase b (PQ schema0 schema1 m) where

512− liftBase = lift . liftBase

542+instance (MonadIO m, schema0 ~ schema1)

543+ => MonadIO (PQ schema0 schema1 m) where

544+ liftIO = lift . liftIO

513545

514−-- | A snapshot of the state of a `PQ` computation.

515−type PQRun schema =

516− forall m x. Monad m => PQ schema schema m x -> m (K x schema)

517−

518−-- | Helper function in defining `MonadBaseControl` instance for `PQ`.

519−pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a

520−pqliftWith f = PQ $ \ conn ->

521− fmap K (f $ \ pq -> unPQ pq conn)

522−

523−instance (MonadBaseControl b m, schema0 ~ schema1)

524− => MonadBaseControl b (PQ schema0 schema1 m) where

525− type StM (PQ schema0 schema1 m) x = StM m (K x schema0)

526− liftBaseWith f =

527− pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run

528− restoreM = PQ . const . restoreM

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)

529554

530555-- | Get a row corresponding to a given row number from a `LibPQ.Result`,

531556-- throwing an exception if the row number is out of bounds.

532557getRow

533− :: (FromRow columns y, MonadBase IO io)

558+ :: (FromRow columns y, MonadIO io)

534559 => LibPQ.Row

535560 -- ^ row number

536561 -> K LibPQ.Result columns

537562 -- ^ result

538563 -> io y

539−getRow r (K result :: K LibPQ.Result columns) = liftBase $ do

564+getRow r (K result :: K LibPQ.Result columns) = liftIO $ do

540565 numRows <- LibPQ.ntuples result

541− when (numRows < r) $ error $

542− "getRow: expected at least " <> show r <> "rows but only saw "

543− <> show numRows

566+ when (numRows < r) $ throw $ ResultException $

567+ "getRow: expected at least " <> pack (show r) <> "rows but only saw "

568+ <> pack (show numRows)

544569 let len = fromIntegral (lengthSList (Proxy @columns))

545570 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

546571 case fromList row' of

547− Nothing -> error "getRow: found unexpected length"

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

549576

550577-- | Intended to be used for unfolding in streaming libraries, `nextRow`

551578-- takes a total number of rows (which can be found with `ntuples`)

552579-- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`,

553580-- otherwise returning the row along with the next row number.

554581nextRow

555− :: (FromRow columns y, MonadBase IO io)

582+ :: (FromRow columns y, MonadIO io)

556583 => LibPQ.Row -- ^ total number of rows

557584 -> K LibPQ.Result columns -- ^ result

558585 -> LibPQ.Row -- ^ row number

559586 -> io (Maybe (LibPQ.Row,y))

560587nextRow total (K result :: K LibPQ.Result columns) r

561− = liftBase $ if r >= total then return Nothing else do

588+ = liftIO $ if r >= total then return Nothing else do

562589 let len = fromIntegral (lengthSList (Proxy @columns))

563590 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

564591 case fromList row' of

565− Nothing -> error "nextRow: found unexpected length"

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

567596

568597-- | Get all rows from a `LibPQ.Result`.

569598getRows

570− :: (FromRow columns y, MonadBase IO io)

599+ :: (FromRow columns y, MonadIO io)

571600 => K LibPQ.Result columns -- ^ result

572601 -> io [y]

573−getRows (K result :: K LibPQ.Result columns) = liftBase $ do

602+getRows (K result :: K LibPQ.Result columns) = liftIO $ do

574603 let len = fromIntegral (lengthSList (Proxy @columns))

575604 numRows <- LibPQ.ntuples result

576605 for [0 .. numRows - 1] $ \ r -> do

577606 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

578607 case fromList row' of

579− Nothing -> error "getRows: found unexpected length"

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

581612

582613-- | Get the first row if possible from a `LibPQ.Result`.

583614firstRow

584− :: (FromRow columns y, MonadBase IO io)

615+ :: (FromRow columns y, MonadIO io)

585616 => K LibPQ.Result columns -- ^ result

586617 -> io (Maybe y)

587−firstRow (K result :: K LibPQ.Result columns) = liftBase $ do

618+firstRow (K result :: K LibPQ.Result columns) = liftIO $ do

588619 numRows <- LibPQ.ntuples result

589620 if numRows <= 0 then return Nothing else do

590621 let len = fromIntegral (lengthSList (Proxy @columns))

591622 row' <- traverse (LibPQ.getvalue result 0) [0 .. len - 1]

592623 case fromList row' of

593− Nothing -> error "firstRow: found unexpected length"

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

595628

596629-- | Lifts actions on results from @LibPQ@.

597630liftResult

598− :: MonadBase IO io

631+ :: MonadIO io

599632 => (LibPQ.Result -> IO x)

600633 -> K LibPQ.Result results -> io x

601−liftResult f (K result) = liftBase $ f result

634+liftResult f (K result) = liftIO $ f result

602635

603636-- | Returns the number of rows (tuples) in the query result.

604−ntuples :: MonadBase IO io => K LibPQ.Result columns -> io LibPQ.Row

637+ntuples :: MonadIO io => K LibPQ.Result columns -> io LibPQ.Row

605638ntuples = liftResult LibPQ.ntuples

606639

607640-- | Returns the result status of the command.

608−resultStatus :: MonadBase IO io => K LibPQ.Result results -> io LibPQ.ExecStatus

641+resultStatus :: MonadIO io => K LibPQ.Result results -> io LibPQ.ExecStatus

609642resultStatus = liftResult LibPQ.resultStatus

610643

611644-- | Returns the error message most recently generated by an operation

612645-- on the connection.

613646resultErrorMessage

614− :: MonadBase IO io => K LibPQ.Result results -> io (Maybe ByteString)

647+ :: MonadIO io => K LibPQ.Result results -> io (Maybe ByteString)

615648resultErrorMessage = 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+70−81

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

12− DataKinds

13− , DeriveFunctor

34+ DeriveFunctor

1435 , FlexibleContexts

1536 , FlexibleInstances

37+ , InstanceSigs

1638 , MultiParamTypeClasses

1739 , RankNTypes

1840 , ScopedTypeVariables

@@ -23,34 +45,24 @@ A `MonadPQ` for pooled connections.

2345

2446module Squeal.PostgreSQL.Pool

2547 ( -- * Pools

26− PoolPQ (..)

48+ Pool

2749 , createConnectionPool

28− , Pool

29− , destroyAllResources

30− , PoolPQRun

31− , poolpqliftWith

50+ , usingConnectionPool

51+ , destroyConnectionPool

3252 ) where

3353

34−import Control.Monad.Base

35−import Control.Monad.Trans

36−import Control.Monad.Trans.Control

3754import Data.ByteString

38−import Data.Pool

3955import Data.Time

40−import Generics.SOP (K(..))

56+import Generics.SOP (K(..), unK)

57+import UnliftIO (MonadUnliftIO (..))

58+import UnliftIO.Pool (Pool, createPool, destroyAllResources, withResource)

4159

4260import Squeal.PostgreSQL.PQ

43−import Squeal.PostgreSQL.Schema

44−

45−-- | `PoolPQ` @schema@ should be a drop-in replacement for `PQ` @schema schema@.

46−newtype PoolPQ (schema :: SchemaType) m x =

47− PoolPQ { runPoolPQ :: Pool (K Connection schema) -> m x }

48− deriving Functor

4961

5062-- | Create a striped pool of connections.

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

5264createConnectionPool

53− :: MonadBase IO io

65+ :: MonadUnliftIO io

5466 => ByteString

5567 -- ^ The passed string can be empty to use all default parameters, or it can

5668 -- contain one or more parameter settings separated by whitespace.

@@ -66,68 +78,45 @@ createConnectionPool

6678 -> Int

6779 -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1.

6880 -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.

69− -> io (Pool (K Connection schema))

70−createConnectionPool conninfo stripes idle maxResrc = liftBase $

81+ -> io (Pool (K Connection schemas))

82+createConnectionPool conninfo stripes idle maxResrc =

7183 createPool (connectdb conninfo) finish stripes idle maxResrc

7284

73−-- | `Applicative` instance for `PoolPQ`.

74−instance Monad m => Applicative (PoolPQ schema m) where

75− pure x = PoolPQ $ \ _ -> pure x

76− PoolPQ f <*> PoolPQ x = PoolPQ $ \ pool -> do

77− f' <- f pool

78− x' <- x pool

79− return $ f' x'

80−

81−-- | `Monad` instance for `PoolPQ`.

82−instance Monad m => Monad (PoolPQ schema m) where

83− return = pure

84− PoolPQ x >>= f = PoolPQ $ \ pool -> do

85− x' <- x pool

86− runPoolPQ (f x') pool

87−

88−-- | `MonadTrans` instance for `PoolPQ`.

89−instance MonadTrans (PoolPQ schema) where

90− lift m = PoolPQ $ \ _pool -> m

91−

92−-- | `MonadBase` instance for `PoolPQ`.

93−instance MonadBase b m => MonadBase b (PoolPQ schema m) where

94− 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.

9588

96−-- | `MonadPQ` instance for `PoolPQ`.

97−instance MonadBaseControl IO io => MonadPQ schema (PoolPQ schema io) where

98− manipulateParams manipulation params = PoolPQ $ \ pool -> do

99− withResource pool $ \ conn -> do

100− (K result :: K (K Result ys) schema) <- flip unPQ conn $

101− manipulateParams manipulation params

102− return result

103− traversePrepared manipulation params = PoolPQ $ \ pool ->

104− withResource pool $ \ conn -> do

105− (K result :: K (list (K Result ys)) schema) <- flip unPQ conn $

106− traversePrepared manipulation params

107− return result

108− traversePrepared_ manipulation params = PoolPQ $ \ pool -> do

109− withResource pool $ \ conn -> do

110− (_ :: K () schema) <- flip unPQ conn $

111− traversePrepared_ manipulation params

112− return ()

113− liftPQ m = PoolPQ $ \ pool ->

114− withResource pool $ \ conn -> do

115− (K result :: K result schema) <- flip unPQ conn $

116− liftPQ m

117− return result

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

118101

119−-- | A snapshot of the state of a `PoolPQ` computation.

120−type PoolPQRun schema =

121− forall m x. Monad m => PoolPQ schema m x -> m x

102+{- |

103+Destroy all connections in all stripes in the pool.

104+Note that this will ignore any exceptions in the destroy function.

122105

123−-- | Helper function in defining `MonadBaseControl` instance for `PoolPQ`.

124−poolpqliftWith :: Functor m => (PoolPQRun schema -> m a) -> PoolPQ schema m a

125−poolpqliftWith f = PoolPQ $ \ pool ->

126− (f $ \ pq -> runPoolPQ pq pool)

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.

127112

128−-- | `MonadBaseControl` instance for `PoolPQ`.

129−instance MonadBaseControl b m => MonadBaseControl b (PoolPQ schema m) where

130− type StM (PoolPQ schema m) x = StM m x

131− liftBaseWith f =

132− poolpqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run

133− restoreM = PoolPQ . const . restoreM

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+722−445

@@ -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,76 +9,81 @@ Squeal queries.

99-}

1010

1111{-# LANGUAGE

12− DataKinds

13− , DeriveDataTypeable

12+ ConstraintKinds

1413 , DeriveGeneric

1514 , FlexibleContexts

1615 , FlexibleInstances

1716 , GADTs

1817 , GeneralizedNewtypeDeriving

19− , KindSignatures

2018 , LambdaCase

2119 , MultiParamTypeClasses

20+ , OverloadedLabels

2221 , OverloadedStrings

22+ , QuantifiedConstraints

2323 , ScopedTypeVariables

2424 , StandaloneDeriving

2525 , TypeApplications

26+ , TypeFamilies

2627 , TypeInType

2728 , TypeOperators

29+ , RankNTypes

2830 , UndecidableInstances

29−#-}

31+ #-}

3032

3133module Squeal.PostgreSQL.Query

3234 ( -- * Queries

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

3449 , union

3550 , unionAll

3651 , intersect

3752 , intersectAll

3853 , except

3954 , exceptAll

40− -- * Select

41− , select

42− , selectDistinct

43− , selectStar

44− , selectDistinctStar

45− , selectDotStar

46− , selectDistinctDotStar

55+ -- ** With

56+ , With (..)

57+ , CommonTableExpression (..)

58+ , withRecursive

4759 -- * Table Expressions

4860 , TableExpression (..)

49− , renderTableExpression

5061 , from

5162 , where_

52− , group

63+ , groupBy

5364 , having

54− , orderBy

5565 , limit

5666 , offset

57− -- * From

67+ -- * From Clauses

5868 , FromClause (..)

5969 , table

6070 , subquery

6171 , view

72+ , common

6273 , crossJoin

6374 , innerJoin

6475 , leftOuterJoin

6576 , rightOuterJoin

6677 , fullOuterJoin

6778 -- * Grouping

68− , By (By, By2)

69− , renderBy

70− , GroupByClause (NoGroups, Group)

71− , renderGroupByClause

72− , HavingClause (NoHaving, Having)

73− , renderHavingClause

74− -- * Sorting

75− , SortExpression (..)

76− , renderSortExpression

79+ , By (..)

80+ , GroupByClause (..)

81+ , HavingClause (..)

7782 ) where

7883

7984import Control.DeepSeq

8085import Data.ByteString (ByteString)

81−import Data.Monoid hiding (All)

86+import Data.Kind (Type)

8287import Data.String

8388import Data.Word

8489import Generics.SOP hiding (from)

@@ -86,352 +91,577 @@ import GHC.TypeLits

8691

8792import qualified GHC.Generics as GHC

8893

94+import Squeal.PostgreSQL.Alias

8995import 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

90101import Squeal.PostgreSQL.Render

91102import Squeal.PostgreSQL.Schema

92103

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+

93111{- |

94−The process of retrieving or the command to retrieve data from a database

95−is called a `Query`. The `select`, `selectStar`, `selectDotStar`,

96−`selectDistinct`, `selectDistinctStar` and `selectDistinctDotStar` commands

97−are used to specify queries.

112+The process of retrieving or the command to retrieve data from

113+a database is called a `Query`.

114+

115+The general `Query` type is parameterized by

116+

117+* @outer :: FromType@ - outer scope for a correlated subquery,

118+* @commons :: FromType@ - scope for all `common` table expressions,

119+* @schemas :: SchemasType@ - scope for all `table`s and `view`s,

120+* @params :: [NullityType]@ - scope for all `Squeal.Expression.Parameter.parameter`s,

121+* @row :: RowType@ - return type of the `Query`.

122+-}

123+newtype Query

124+ (outer :: FromType)

125+ (commons :: FromType)

126+ (schemas :: SchemasType)

127+ (params :: [NullityType])

128+ (row :: RowType)

129+ = UnsafeQuery { renderQuery :: ByteString }

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

131+instance RenderSQL (Query outer commons schemas params row) where renderSQL = renderQuery

132+

133+{- |

134+The top level `Query_` type is parameterized by a @schemas@ `SchemasType`,

135+against which the query is type-checked, an input @parameters@ Haskell `Type`,

136+and an ouput row Haskell `Type`.

137+

138+A top-level query can be run

139+using `Squeal.PostgreSQL.PQ.runQueryParams`, or if @parameters = ()@

140+using `Squeal.PostgreSQL.PQ.runQuery`.

141+

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

143+may be referenced using positional

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

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

146+

147+Let's see some examples of queries.

148+

149+>>> :set -XDeriveAnyClass -XDerivingStrategies

150+>>> :{

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

152+ deriving stock (GHC.Generic)

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

154+:}

98155

99156simple query:

100157

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

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

101160>>> :{

102161let

103− query :: Query

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

105− '[]

106− '["col" ::: 'Null 'PGint4]

107− query = selectStar (from (table (#tab `As` #t)))

108−in renderQuery query

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

163+ query = select Star (from (table #tab))

164+in printSQL query

109165:}

110−"SELECT * FROM \"tab\" AS \"t\""

166+SELECT * FROM "tab" AS "tab"

111167

112168restricted query:

113169

114170>>> :{

115171let

116− query :: Query

117− '[ "tab" ::: '[] :=>

118− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

119− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]

120− '[]

121− '[ "sum" ::: 'NotNull 'PGint4

122− , "col1" ::: 'NotNull 'PGint4 ]

123− query =

124− select

125− ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)

126− ( from (table (#tab `As` #t))

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

173+ query =

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

175+ ( from (table #tab)

127176 & where_ (#col1 .> #col2)

128177 & where_ (#col2 .> 0) )

129−in renderQuery query

178+in printSQL query

130179:}

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

132181

133182subquery:

134183

135184>>> :{

136185let

137− query :: Query

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

139− '[]

140− '["col" ::: 'Null 'PGint4]

141− query =

142− selectStar

143− (from (subquery (selectStar (from (table (#tab `As` #t))) `As` #sub)))

144−in renderQuery query

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

145189:}

146−"SELECT * FROM (SELECT * FROM \"tab\" AS \"t\") AS \"sub\""

190+SELECT * FROM (SELECT * FROM "tab" AS "tab") AS "sub"

147191

148192limits and offsets:

149193

150194>>> :{

151195let

152− query :: Query

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

154− '[]

155− '["col" ::: 'Null 'PGint4]

156− query = selectStar

157− (from (table (#tab `As` #t)) & limit 100 & offset 2 & limit 50 & offset 2)

158−in renderQuery query

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

159199:}

160−"SELECT * FROM \"tab\" AS \"t\" LIMIT 50 OFFSET 4"

200+SELECT * FROM "tab" AS "tab" LIMIT 50 OFFSET 4

161201

162202parameterized query:

163203

164204>>> :{

165205let

166− query :: Query

167− '["tab" ::: '[] :=> '["col" ::: 'NoDef :=> 'NotNull 'PGfloat8]]

168− '[ 'NotNull 'PGfloat8]

169− '["col" ::: 'NotNull 'PGfloat8]

170− query = selectStar

171− (from (table (#tab `As` #t)) & where_ (#col .> param @1))

172−in renderQuery query

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

173209:}

174−"SELECT * FROM \"tab\" AS \"t\" WHERE (\"col\" > ($1 :: float8))"

210+SELECT * FROM "tab" AS "tab" WHERE ("col1" > ($1 :: int4))

175211

176212aggregation query:

177213

178214>>> :{

179215let

180− query :: Query

181− '[ "tab" ::: '[] :=>

182− '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

183− , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ]]

184− '[]

185− '[ "sum" ::: 'NotNull 'PGint4

186− , "col1" ::: 'NotNull 'PGint4 ]

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

187217 query =

188− select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil)

189− ( from (table (#tab `As` #table1))

190− & group (By #col1 :* Nil)

191− & having (#col1 + sum_ #col2 .> 1) )

192−in renderQuery query

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

193223:}

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

195225

196226sorted query:

197227

198228>>> :{

199229let

200− query :: Query

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

202− '[]

203− '["col" ::: 'Null 'PGint4]

204− query = selectStar

205− (from (table (#tab `As` #t)) & orderBy [#col & AscNullsFirst])

206−in renderQuery query

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

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

232+in printSQL query

207233:}

208−"SELECT * FROM \"tab\" AS \"t\" ORDER BY \"col\" ASC NULLS FIRST"

234+SELECT * FROM "tab" AS "tab" ORDER BY "col1" ASC

209235

210236joins:

211237

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

213273>>> :{

214274let

215− query :: Query

216− '[ "orders" :::

217− '["pk_orders" ::: PrimaryKey '["id"]

218− ,"fk_customers" ::: ForeignKey '["customer_id"] "customers" '["id"]

219− ,"fk_shippers" ::: ForeignKey '["shipper_id"] "shippers" '["id"]] :=>

220− '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

221− , "price" ::: 'NoDef :=> 'NotNull 'PGfloat4

222− , "customer_id" ::: 'NoDef :=> 'NotNull 'PGint4

223− , "shipper_id" ::: 'NoDef :=> 'NotNull 'PGint4

224− ]

225− , "customers" :::

226− '["pk_customers" ::: PrimaryKey '["id"]] :=>

227− '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

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

229− ]

230− , "shippers" :::

231− '["pk_shippers" ::: PrimaryKey '["id"]] :=>

232− '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4

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

234− ]

235− ]

236− '[]

237− '[ "order_price" ::: 'NotNull 'PGfloat4

238− , "customer_name" ::: 'NotNull 'PGtext

239− , "shipper_name" ::: 'NotNull 'PGtext

240− ]

241− query = select

242− ( #o ! #price `As` #order_price :*

243− #c ! #name `As` #customer_name :*

244− #s ! #name `As` #shipper_name :* Nil )

245− ( from (table (#orders `As` #o)

246− & innerJoin (table (#customers `As` #c))

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

247282 (#o ! #customer_id .== #c ! #id)

248− & innerJoin (table (#shippers `As` #s))

283+ & innerJoin (table (#shippers `as` #s))

249284 (#o ! #shipper_id .== #s ! #id)) )

250−in renderQuery query

285+in printSQL query

251286:}

252−"SELECT \"o\".\"price\" AS \"order_price\", \"c\".\"name\" AS \"customer_name\", \"s\".\"name\" AS \"shipper_name\" FROM \"orders\" AS \"o\" INNER JOIN \"customers\" AS \"c\" ON (\"o\".\"customer_id\" = \"c\".\"id\") INNER JOIN \"shippers\" AS \"s\" ON (\"o\".\"shipper_id\" = \"s\".\"id\")"

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

253288

254289self-join:

255290

256291>>> :{

257292let

258− query :: Query

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

260− '[]

261− '["col" ::: 'Null 'PGint4]

262− query = selectDotStar #t1

263− (from (table (#tab `As` #t1) & crossJoin (table (#tab `As` #t2))))

264−in renderQuery query

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

265298:}

266−"SELECT \"t1\".* FROM \"tab\" AS \"t1\" CROSS JOIN \"tab\" AS \"t2\""

299+SELECT "t1".* FROM "tab" AS "t1" CROSS JOIN "tab" AS "t2"

300+

301+value queries:

302+

303+>>> :{

304+let

305+ query :: Query_ schemas () (Row String Bool)

306+ query = values

307+ ("true" `as` #col1 :* true `as` #col2)

308+ ["false" `as` #col1 :* false `as` #col2]

309+in printSQL query

310+:}

311+SELECT * FROM (VALUES (E'true', TRUE), (E'false', FALSE)) AS t ("col1", "col2")

267312

268313set operations:

269314

270315>>> :{

271316let

272− query :: Query

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

274− '[]

275− '["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)

276353 query =

277− selectStar (from (table (#tab `As` #t)))

278− `unionAll`

279− selectStar (from (table (#tab `As` #t)))

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

281359:}

282−"(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+

283362-}

284−newtype Query

285− (schema :: SchemaType)

286− (params :: [NullityType])

287− (columns :: RelationType)

288− = UnsafeQuery { renderQuery :: ByteString }

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

290369

291370-- | The results of two queries can be combined using the set operation

292−-- `union`. Duplicate rows are eliminated.

371+-- `union`. Duplicate rows are eliminated.

293372union

294− :: Query schema params columns

295− -> Query schema params columns

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

297376q1 `union` q2 = UnsafeQuery $

298− parenthesized (renderQuery q1)

377+ parenthesized (renderSQL q1)

299378 <+> "UNION"

300− <+> parenthesized (renderQuery q2)

379+ <+> parenthesized (renderSQL q2)

301380

302381-- | The results of two queries can be combined using the set operation

303382-- `unionAll`, the disjoint union. Duplicate rows are retained.

304383unionAll

305− :: Query schema params columns

306− -> Query schema params columns

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

308387q1 `unionAll` q2 = UnsafeQuery $

309− parenthesized (renderQuery q1)

388+ parenthesized (renderSQL q1)

310389 <+> "UNION" <+> "ALL"

311− <+> parenthesized (renderQuery q2)

390+ <+> parenthesized (renderSQL q2)

312391

313392-- | The results of two queries can be combined using the set operation

314393-- `intersect`, the intersection. Duplicate rows are eliminated.

315394intersect

316− :: Query schema params columns

317− -> Query schema params columns

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

319398q1 `intersect` q2 = UnsafeQuery $

320− parenthesized (renderQuery q1)

399+ parenthesized (renderSQL q1)

321400 <+> "INTERSECT"

322− <+> parenthesized (renderQuery q2)

401+ <+> parenthesized (renderSQL q2)

323402

324403-- | The results of two queries can be combined using the set operation

325404-- `intersectAll`, the intersection. Duplicate rows are retained.

326405intersectAll

327− :: Query schema params columns

328− -> Query schema params columns

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

330409q1 `intersectAll` q2 = UnsafeQuery $

331− parenthesized (renderQuery q1)

410+ parenthesized (renderSQL q1)

332411 <+> "INTERSECT" <+> "ALL"

333− <+> parenthesized (renderQuery q2)

412+ <+> parenthesized (renderSQL q2)

334413

335414-- | The results of two queries can be combined using the set operation

336415-- `except`, the set difference. Duplicate rows are eliminated.

337416except

338− :: Query schema params columns

339− -> Query schema params columns

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

341420q1 `except` q2 = UnsafeQuery $

342− parenthesized (renderQuery q1)

421+ parenthesized (renderSQL q1)

343422 <+> "EXCEPT"

344− <+> parenthesized (renderQuery q2)

423+ <+> parenthesized (renderSQL q2)

345424

346425-- | The results of two queries can be combined using the set operation

347426-- `exceptAll`, the set difference. Duplicate rows are retained.

348427exceptAll

349− :: Query schema params columns

350− -> Query schema params columns

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

352431q1 `exceptAll` q2 = UnsafeQuery $

353− parenthesized (renderQuery q1)

432+ parenthesized (renderSQL q1)

354433 <+> "EXCEPT" <+> "ALL"

355− <+> parenthesized (renderQuery q2)

434+ <+> parenthesized (renderSQL q2)

356435

357436{-----------------------------------------

358437SELECT queries

359438-----------------------------------------}

360439

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+

361525-- | the `TableExpression` in the `select` command constructs an intermediate

362526-- virtual table by possibly combining tables, views, eliminating rows,

363527-- grouping, etc. This table is finally passed on to processing by

364−-- the select list. The select list determines which columns of

528+-- the select list. The `Selection` determines which columns of

365529-- the intermediate table are actually output.

366530select

367− :: SListI columns

368− => NP (Aliased (Expression relations grouping params)) (column ': columns)

369− -- ^ select list

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

371535 -- ^ intermediate virtual table

372− -> Query schema params (column ': columns)

373−select list rels = UnsafeQuery $

536+ -> Query outer commons schemas params row

537+select selection tabexpr = UnsafeQuery $

374538 "SELECT"

375− <+> renderCommaSeparated (renderAliasedAs renderExpression) list

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

377552

378553-- | After the select list has been processed, the result table can

379554-- be subject to the elimination of duplicate rows using `selectDistinct`.

380555selectDistinct

381− :: SListI columns

382− => NP (Aliased (Expression relations 'Ungrouped params)) (column ': columns)

383− -- ^ select list

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

385560 -- ^ intermediate virtual table

386− -> Query schema params (column ': columns)

387−selectDistinct list rels = UnsafeQuery $

561+ -> Query outer commons schemas params columns

562+selectDistinct selection tabexpr = UnsafeQuery $

388563 "SELECT DISTINCT"

389− <+> renderCommaSeparated (renderAliasedAs renderExpression) list

390− <+> renderTableExpression rels

391−

392−-- | The simplest kind of query is `selectStar` which emits all columns

393−-- that the table expression produces.

394−selectStar

395− :: HasUnique relation relations columns

396− => TableExpression schema params relations 'Ungrouped

397− -- ^ intermediate virtual table

398− -> Query schema params columns

399−selectStar rels = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression rels

400−

401−-- | A `selectDistinctStar` emits all columns that the table expression

402−-- produces and eliminates duplicate rows.

403−selectDistinctStar

404− :: HasUnique relation relations columns

405− => TableExpression schema params relations 'Ungrouped

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

406574 -- ^ intermediate virtual table

407− -> Query schema params columns

408−selectDistinctStar rels = UnsafeQuery $

409− "SELECT DISTINCT" <+> "*" <+> renderTableExpression rels

410−

411−-- | When working with multiple tables, it can also be useful to ask

412−-- for all the columns of a particular table, using `selectDotStar`.

413−selectDotStar

414− :: Has relation relations columns

415− => Alias relation

416− -- ^ particular virtual subtable

417− -> TableExpression schema params relations 'Ungrouped

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

418598 -- ^ intermediate virtual table

419− -> Query schema params columns

420−selectDotStar rel relations = UnsafeQuery $

421− "SELECT" <+> renderAlias rel <> ".*" <+> renderTableExpression relations

422−

423−-- | A `selectDistinctDotStar` asks for all the columns of a particular table,

424−-- and eliminates duplicate rows.

425−selectDistinctDotStar

426− :: Has relation relations columns

427− => Alias relation

428− -- ^ particular virtual table

429− -> TableExpression schema params relations 'Ungrouped

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

430623 -- ^ intermediate virtual table

431− -> Query schema params columns

432−selectDistinctDotStar rel relations = UnsafeQuery $

433− "SELECT DISTINCT" <+> renderAlias rel <> ".*"

434− <+> renderTableExpression relations

624+ -> Query outer commons schemas params columns

625+selectDistinctOn_ distincts = selectDistinctOn distincts . List

626+

627+-- | `values` computes a row value or set of row values

628+-- specified by value expressions. It is most commonly used

629+-- to generate a “constant table” within a larger command,

630+-- but it can be used on its own.

631+--

632+-- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]

633+-- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query outer commons schemas '[] Row

634+-- >>> printSQL query

635+-- SELECT * FROM (VALUES (1, E'one')) AS t ("a", "b")

636+values

637+ :: SListI cols

638+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols

639+ -> [NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols]

640+ -- ^ When more than one row is specified, all the rows must

641+ -- must have the same number of elements

642+ -> Query outer commons schemas params cols

643+values rw rws = UnsafeQuery $ "SELECT * FROM"

644+ <+> parenthesized (

645+ "VALUES"

646+ <+> commaSeparated

647+ ( parenthesized

648+ . renderCommaSeparated renderValuePart <$> rw:rws )

649+ ) <+> "AS t"

650+ <+> parenthesized (renderCommaSeparated renderAliasPart rw)

651+ where

652+ renderAliasPart, renderValuePart

653+ :: Aliased (Expression outer commons 'Ungrouped schemas params '[] ) ty -> ByteString

654+ renderAliasPart (_ `As` name) = renderSQL name

655+ renderValuePart (value `As` _) = renderSQL value

656+

657+-- | `values_` computes a row value or set of row values

658+-- specified by value expressions.

659+values_

660+ :: SListI cols

661+ => NP (Aliased (Expression outer commons 'Ungrouped schemas params '[] )) cols

662+ -- ^ one row of values

663+ -> Query outer commons schemas params cols

664+values_ rw = values rw []

435665

436666{-----------------------------------------

437667Table Expressions

@@ -444,15 +674,17 @@ Table Expressions

444674-- to a table on disk, a so-called base table, but more complex expressions

445675-- can be used to modify or combine base tables in various ways.

446676data TableExpression

447− (schema :: SchemaType)

677+ (outer :: FromType)

678+ (commons :: FromType)

679+ (grp :: Grouping)

680+ (schemas :: SchemasType)

448681 (params :: [NullityType])

449− (relations :: RelationsType)

450− (grouping :: Grouping)

682+ (from :: FromType)

451683 = TableExpression

452− { fromClause :: FromClause schema params relations

684+ { fromClause :: FromClause outer commons schemas params from

453685 -- ^ A table reference that can be a table name, or a derived table such

454686 -- as a subquery, a @JOIN@ construct, or complex combinations of these.

455− , whereClause :: [Condition relations 'Ungrouped params]

687+ , whereClause :: [Condition outer commons 'Ungrouped schemas params from]

456688 -- ^ optional search coditions, combined with `.&&`. After the processing

457689 -- of the `fromClause` is done, each row of the derived virtual table

458690 -- is checked against the search condition. If the result of the

@@ -461,20 +693,20 @@ data TableExpression

461693 -- at least one column of the table generated in the `fromClause`;

462694 -- this is not required, but otherwise the WHERE clause will

463695 -- be fairly useless.

464− , groupByClause :: GroupByClause relations grouping

696+ , groupByClause :: GroupByClause grp from

465697 -- ^ The `groupByClause` is used to group together those rows in a table

466698 -- that have the same values in all the columns listed. The order in which

467699 -- the columns are listed does not matter. The effect is to combine each

468700 -- set of rows having common values into one group row that represents all

469701 -- rows in the group. This is done to eliminate redundancy in the output

470702 -- and/or compute aggregates that apply to these groups.

471− , havingClause :: HavingClause relations grouping params

703+ , havingClause :: HavingClause outer commons grp schemas params from

472704 -- ^ If a table has been grouped using `groupBy`, but only certain groups

473705 -- are of interest, the `havingClause` can be used, much like a

474706 -- `whereClause`, to eliminate groups from the result. Expressions in the

475707 -- `havingClause` can refer both to grouped expressions and to ungrouped

476708 -- expressions (which necessarily involve an aggregate function).

477− , orderByClause :: [SortExpression relations grouping params]

709+ , orderByClause :: [SortExpression outer commons grp schemas params from]

478710 -- ^ The `orderByClause` is for optional sorting. When more than one

479711 -- `SortExpression` is specified, the later (right) values are used to sort

480712 -- rows that are equal according to the earlier (left) values.

@@ -484,72 +716,69 @@ data TableExpression

484716 -- will be returned (but possibly fewer, if the query itself yields

485717 -- fewer rows).

486718 , offsetClause :: [Word64]

487− -- ^ The `offsetClause` is combined with `+` to give an offset count

719+ -- ^ The `offsetClause` is combined with `Prelude.+` to give an offset count

488720 -- if nonempty. The offset count says to skip that many rows before

489721 -- beginning to return rows. The rows are skipped before the limit count

490722 -- is applied.

491− }

723+ } deriving (GHC.Generic)

492724

493725-- | Render a `TableExpression`

494−renderTableExpression

495− :: TableExpression schema params relations grouping

496− -> ByteString

497−renderTableExpression

498− (TableExpression frm' whs' grps' hvs' srts' lims' offs') = mconcat

499− [ "FROM ", renderFromClause frm'

500− , renderWheres whs'

501− , renderGroupByClause grps'

502− , renderHavingClause hvs'

503− , renderOrderByClause srts'

504− , renderLimits lims'

505− , renderOffsets offs'

506− ]

507− where

508− renderWheres = \case

509− [] -> ""

510− wh:[] -> " WHERE" <+> renderExpression wh

511− wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)

512− renderOrderByClause = \case

513− [] -> ""

514− srts -> " ORDER BY"

515− <+> commaSeparated (renderSortExpression <$> srts)

516− renderLimits = \case

517− [] -> ""

518− lims -> " LIMIT" <+> fromString (show (minimum lims))

519− renderOffsets = \case

520− [] -> ""

521− offs -> " OFFSET" <+> fromString (show (sum offs))

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

522751

523752-- | A `from` generates a `TableExpression` from a table reference that can be

524753-- a table name, or a derived table such as a subquery, a JOIN construct,

525754-- or complex combinations of these. A `from` may be transformed by `where_`,

526−-- `group`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator

755+-- `groupBy`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator

527756-- to match the left-to-right sequencing of their placement in SQL.

528757from

529− :: FromClause schema params relations -- ^ table reference

530− -> TableExpression schema params relations 'Ungrouped

531−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 [] [] []

532761

533762-- | A `where_` is an endomorphism of `TableExpression`s which adds a

534763-- search condition to the `whereClause`.

535764where_

536− :: Condition relations 'Ungrouped params -- ^ filtering condition

537− -> TableExpression schema params relations grouping

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

539768where_ wh rels = rels {whereClause = wh : whereClause rels}

540769

541−-- | A `group` is a transformation of `TableExpression`s which switches

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

543772-- a "grand total" aggregation query.

544−group

773+groupBy

545774 :: SListI bys

546− => NP (By relations) bys -- ^ grouped columns

547− -> TableExpression schema params relations 'Ungrouped

548− -> TableExpression schema params relations ('Grouped bys)

549−group bys rels = TableExpression

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

550779 { fromClause = fromClause rels

551780 , whereClause = whereClause rels

552− , groupByClause = Group bys

781+ , groupByClause = group bys

553782 , havingClause = Having []

554783 , orderByClause = []

555784 , limitClause = limitClause rels

@@ -559,34 +788,29 @@ group bys rels = TableExpression

559788-- | A `having` is an endomorphism of `TableExpression`s which adds a

560789-- search condition to the `havingClause`.

561790having

562− :: Condition relations ('Grouped bys) params -- ^ having condition

563− -> TableExpression schema params relations ('Grouped bys)

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

565794having hv rels = rels

566795 { havingClause = case havingClause rels of Having hvs -> Having (hv:hvs) }

567796

568−-- | An `orderBy` is an endomorphism of `TableExpression`s which appends an

569−-- ordering to the right of the `orderByClause`.

570−orderBy

571− :: [SortExpression relations grouping params] -- ^ sort expressions

572− -> TableExpression schema params relations grouping

573− -> TableExpression schema params relations grouping

574−orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}

797+instance OrderBy TableExpression where

798+ orderBy srts rels = rels {orderByClause = orderByClause rels ++ srts}

575799

576800-- | A `limit` is an endomorphism of `TableExpression`s which adds to the

577801-- `limitClause`.

578802limit

579803 :: Word64 -- ^ limit parameter

580− -> TableExpression schema params relations grouping

581− -> TableExpression schema params relations grouping

804+ -> TableExpression outer commons grp schemas params from

805+ -> TableExpression outer commons grp schemas params from

582806limit lim rels = rels {limitClause = lim : limitClause rels}

583807

584808-- | An `offset` is an endomorphism of `TableExpression`s which adds to the

585809-- `offsetClause`.

586810offset

587811 :: Word64 -- ^ offset parameter

588− -> TableExpression schema params relations grouping

589− -> TableExpression schema params relations grouping

812+ -> TableExpression outer commons grp schemas params from

813+ -> TableExpression outer commons grp schemas params from

590814offset off rels = rels {offsetClause = off : offsetClause rels}

591815

592816{-----------------------------------------

@@ -597,57 +821,76 @@ FROM clauses

597821A `FromClause` can be a table name, or a derived table such

598822as a subquery, a @JOIN@ construct, or complex combinations of these.

599823-}

600−newtype FromClause schema params relations

824+newtype FromClause outer commons schemas params from

601825 = UnsafeFromClause { renderFromClause :: ByteString }

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

827+instance RenderSQL (FromClause outer commons schemas params from) where

828+ renderSQL = renderFromClause

603829

604−-- | A real `table` is a table from the schema.

830+-- | A real `table` is a table from the database.

605831table

606− :: Aliased (Table schema) table

607− -> FromClause schema params '[table]

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

609837

610838-- | `subquery` derives a table from a `Query`.

611839subquery

612− :: Aliased (Query schema params) table

613− -> FromClause schema params '[table]

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

615843

616844-- | `view` derives a table from a `View`.

617845view

618− :: Aliased (View schema) table

619− -> FromClause schema params '[table]

620−view = UnsafeFromClause . renderAliasedAs renderView

621−

622−{- | @left & crossJoin right@. For every possible combination of rows from

623− @left@ and @right@ (i.e., a Cartesian product), the joined table will contain

624− a row consisting of all columns in @left@ followed by all columns in @right@.

625− If the tables have @n@ and @m@ rows respectively, the joined table will

626− have @n * m@ rows.

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.

627870-}

628871crossJoin

629− :: FromClause schema params right

872+ :: FromClause outer commons schemas params right

630873 -- ^ right

631− -> FromClause schema params left

874+ -> FromClause outer commons schemas params left

632875 -- ^ left

633− -> FromClause schema params (Join left right)

876+ -> FromClause outer commons schemas params (Join left right)

634877crossJoin right left = UnsafeFromClause $

635− renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right

878+ renderSQL left <+> "CROSS JOIN" <+> renderSQL right

636879

637880{- | @left & innerJoin right on@. The joined table is filtered by

638881the @on@ condition.

639882-}

640883innerJoin

641− :: FromClause schema params right

884+ :: FromClause outer commons schemas params right

642885 -- ^ right

643− -> Condition (Join left right) 'Ungrouped params

886+ -> Condition outer commons 'Ungrouped schemas params (Join left right)

644887 -- ^ @on@ condition

645− -> FromClause schema params left

888+ -> FromClause outer commons schemas params left

646889 -- ^ left

647− -> FromClause schema params (Join left right)

890+ -> FromClause outer commons schemas params (Join left right)

648891innerJoin right on left = UnsafeFromClause $

649− renderFromClause left <+> "INNER JOIN" <+> renderFromClause right

650− <+> "ON" <+> renderExpression on

892+ renderSQL left <+> "INNER JOIN" <+> renderSQL right

893+ <+> "ON" <+> renderSQL on

651894

652895{- | @left & leftOuterJoin right on@. First, an inner join is performed.

653896 Then, for each row in @left@ that does not satisfy the @on@ condition with

@@ -655,16 +898,16 @@ innerJoin right on left = UnsafeFromClause $

655898 Thus, the joined table always has at least one row for each row in @left@.

656899-}

657900leftOuterJoin

658− :: FromClause schema params right

901+ :: FromClause outer commons schemas params right

659902 -- ^ right

660− -> Condition (Join left right) 'Ungrouped params

903+ -> Condition outer commons 'Ungrouped schemas params (Join left right)

661904 -- ^ @on@ condition

662− -> FromClause schema params left

905+ -> FromClause outer commons schemas params left

663906 -- ^ left

664− -> FromClause schema params (Join left (NullifyRelations right))

907+ -> FromClause outer commons schemas params (Join left (NullifyFrom right))

665908leftOuterJoin right on left = UnsafeFromClause $

666− renderFromClause left <+> "LEFT OUTER JOIN" <+> renderFromClause right

667− <+> "ON" <+> renderExpression on

909+ renderSQL left <+> "LEFT OUTER JOIN" <+> renderSQL right

910+ <+> "ON" <+> renderSQL on

668911

669912{- | @left & rightOuterJoin right on@. First, an inner join is performed.

670913 Then, for each row in @right@ that does not satisfy the @on@ condition with

@@ -673,16 +916,16 @@ leftOuterJoin right on left = UnsafeFromClause $

673916 have a row for each row in @right@.

674917-}

675918rightOuterJoin

676− :: FromClause schema params right

919+ :: FromClause outer commons schemas params right

677920 -- ^ right

678− -> Condition (Join left right) 'Ungrouped params

921+ -> Condition outer commons 'Ungrouped schemas params (Join left right)

679922 -- ^ @on@ condition

680− -> FromClause schema params left

923+ -> FromClause outer commons schemas params left

681924 -- ^ left

682− -> FromClause schema params (Join (NullifyRelations left) right)

925+ -> FromClause outer commons schemas params (Join (NullifyFrom left) right)

683926rightOuterJoin right on left = UnsafeFromClause $

684− renderFromClause left <+> "RIGHT OUTER JOIN" <+> renderFromClause right

685− <+> "ON" <+> renderExpression on

927+ renderSQL left <+> "RIGHT OUTER JOIN" <+> renderSQL right

928+ <+> "ON" <+> renderSQL on

686929

687930{- | @left & fullOuterJoin right on@. First, an inner join is performed.

688931 Then, for each row in @left@ that does not satisfy the @on@ condition with

@@ -692,47 +935,56 @@ rightOuterJoin right on left = UnsafeFromClause $

692935 is added.

693936-}

694937fullOuterJoin

695− :: FromClause schema params right

938+ :: FromClause outer commons schemas params right

696939 -- ^ right

697− -> Condition (Join left right) 'Ungrouped params

940+ -> Condition outer commons 'Ungrouped schemas params (Join left right)

698941 -- ^ @on@ condition

699− -> FromClause schema params left

942+ -> FromClause outer commons schemas params left

700943 -- ^ left

701− -> FromClause schema params

702− (Join (NullifyRelations left) (NullifyRelations right))

944+ -> FromClause outer commons schemas params

945+ (Join (NullifyFrom left) (NullifyFrom right))

703946fullOuterJoin right on left = UnsafeFromClause $

704− renderFromClause left <+> "FULL OUTER JOIN" <+> renderFromClause right

705− <+> "ON" <+> renderExpression on

947+ renderSQL left <+> "FULL OUTER JOIN" <+> renderSQL right

948+ <+> "ON" <+> renderSQL on

706949

707950{-----------------------------------------

708951Grouping

709952-----------------------------------------}

710953

711−-- | `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

712955-- used to group together those rows in a table that have the same values

713956-- in all the columns listed. @By \#col@ will reference an unambiguous

714957-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table

715958-- qualified column @tab.col@.

716959data By

717− (relations :: RelationsType)

960+ (from :: FromType)

718961 (by :: (Symbol,Symbol)) where

719− By

720− :: (HasUnique relation relations columns, Has column columns ty)

962+ By1

963+ :: (HasUnique table from columns, Has column columns ty)

721964 => Alias column

722− -> By relations '(relation, column)

965+ -> By from '(table, column)

723966 By2

724− :: (Has relation relations columns, Has column columns ty)

725− => (Alias relation, Alias column)

726− -> By relations '(relation, column)

727−deriving instance Show (By relations by)

728−deriving instance Eq (By relations by)

729−deriving instance Ord (By relations by)

730−

731−-- | Renders a `By`.

732−renderBy :: By relations by -> ByteString

733−renderBy = \case

734− By column -> renderAlias column

735− By2 (rel, column) -> renderAlias rel <> "." <> renderAlias column

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

736988

737989-- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.

738990-- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`.

@@ -740,82 +992,107 @@ renderBy = \case

740992-- done on @NoGroups@ while all output `Expression`s must be aggregated

741993-- in @Group Nil@. In general, all output `Expression`s in the

742994-- complement of @bys@ must be aggregated in @Group bys@.

743−data GroupByClause relations grouping where

744− NoGroups :: GroupByClause relations 'Ungrouped

745− Group

746− :: SListI bys

747− => NP (By relations) bys

748− -> GroupByClause relations ('Grouped bys)

749−

750−-- | Renders a `GroupByClause`.

751−renderGroupByClause :: GroupByClause relations grouping -> ByteString

752−renderGroupByClause = \case

753− NoGroups -> ""

754− Group Nil -> ""

755− Group bys -> " GROUP BY" <+> renderCommaSeparated renderBy bys

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'

7561009

7571010-- | A `HavingClause` is used to eliminate groups that are not of interest.

7581011-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`

7591012-- `TableExpression` must use `Having` whose conditions are combined with

7601013-- `.&&`.

761−data HavingClause relations grouping params where

762− NoHaving :: HavingClause relations 'Ungrouped params

1014+data HavingClause outer commons grp schemas params from where

1015+ NoHaving :: HavingClause outer commons 'Ungrouped schemas params from

7631016 Having

764− :: [Condition relations ('Grouped bys) params]

765− -> HavingClause relations ('Grouped bys) params

766−deriving instance Show (HavingClause relations grouping params)

767−deriving instance Eq (HavingClause relations grouping params)

768−deriving instance Ord (HavingClause relations grouping params)

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)

7691022

7701023-- | Render a `HavingClause`.

771−renderHavingClause :: HavingClause relations grouping params -> ByteString

772−renderHavingClause = \case

773− NoHaving -> ""

774− Having [] -> ""

775− Having conditions ->

776− " HAVING" <+> commaSeparated (renderExpression <$> conditions)

777−

778−{-----------------------------------------

779−Sorting

780−-----------------------------------------}

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

7811074

782−-- | `SortExpression`s are used by `sortBy` to optionally sort the results

783−-- of a `Query`. `Asc` or `Desc` set the sort direction of a `NotNull` result

784−-- column to ascending or descending. Ascending order puts smaller values

785−-- first, where "smaller" is defined in terms of the `.<` operator. Similarly,

786−-- descending order is determined with the `.>` operator. `AscNullsFirst`,

787−-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to

788−-- determine whether nulls appear before or after non-null values in the sort

789−-- ordering of a `Null` result column.

790−data SortExpression relations grouping params where

791− Asc

792− :: Expression relations grouping params ('NotNull ty)

793− -> SortExpression relations grouping params

794− Desc

795− :: Expression relations grouping params ('NotNull ty)

796− -> SortExpression relations grouping params

797− AscNullsFirst

798− :: Expression relations grouping params ('Null ty)

799− -> SortExpression relations grouping params

800− AscNullsLast

801− :: Expression relations grouping params ('Null ty)

802− -> SortExpression relations grouping params

803− DescNullsFirst

804− :: Expression relations grouping params ('Null ty)

805− -> SortExpression relations grouping params

806− DescNullsLast

807− :: Expression relations grouping params ('Null ty)

808− -> SortExpression relations grouping params

809−deriving instance Show (SortExpression relations grouping params)

810−

811−-- | Render a `SortExpression`.

812−renderSortExpression :: SortExpression relations grouping params -> ByteString

813−renderSortExpression = \case

814− Asc expression -> renderExpression expression <+> "ASC"

815− Desc expression -> renderExpression expression <+> "DESC"

816− AscNullsFirst expression -> renderExpression expression

817− <+> "ASC NULLS FIRST"

818− DescNullsFirst expression -> renderExpression expression

819− <+> "DESC NULLS FIRST"

820− AscNullsLast expression -> renderExpression expression <+> "ASC NULLS LAST"

821− DescNullsLast expression -> renderExpression expression <+> "DESC NULLS LAST"

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+71−6

@@ -9,7 +9,11 @@ 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

@@ -19,30 +23,48 @@ Rendering helper functions.

1923

2024module Squeal.PostgreSQL.Render

2125 ( -- * Render

22− parenthesized

26+ RenderSQL (..)

27+ , printSQL

28+ , escape

29+ , parenthesized

30+ , bracketed

2331 , (<+>)

2432 , commaSeparated

2533 , doubleQuoted

34+ , singleQuotedText

35+ , singleQuotedUtf8

2636 , renderCommaSeparated

37+ , renderCommaSeparatedConstraint

2738 , renderCommaSeparatedMaybe

2839 , renderNat

40+ , renderSymbol

2941 ) where

3042

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

3144import Data.ByteString (ByteString)

32−import Data.Maybe

45+import Data.Maybe (catMaybes)

3346import Data.Monoid ((<>))

47+import Data.Text (Text)

3448import Generics.SOP

3549import GHC.Exts

36−import GHC.TypeLits

50+import GHC.TypeLits hiding (Text)

3751

52+import qualified Data.Text as Text

53+import qualified Data.Text.Encoding as Text

3854import qualified Data.ByteString as ByteString

55+import qualified Data.ByteString.Char8 as Char8

3956

4057-- | Parenthesize a `ByteString`.

4158parenthesized :: ByteString -> ByteString

4259parenthesized str = "(" <> str <> ")"

4360

61+-- | Square bracket a `ByteString`

62+bracketed :: ByteString -> ByteString

63+bracketed str = "[" <> str <> "]"

64+

4465-- | Concatenate two `ByteString`s with a space between.

4566(<+>) :: ByteString -> ByteString -> ByteString

67+infixr 7 <+>

4668str1 <+> str2 = str1 <> " " <> str2

4769

4870-- | Comma separate a list of `ByteString`s.

@@ -53,6 +75,15 @@ commaSeparated = ByteString.intercalate ", "

5375doubleQuoted :: ByteString -> ByteString

5476doubleQuoted str = "\"" <> str <> "\""

5577

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+

5687-- | Comma separate the renderings of a heterogeneous list.

5788renderCommaSeparated

5889 :: SListI xs

@@ -63,6 +94,16 @@ renderCommaSeparated render

6394 . hcollapse

6495 . hmap (K . render)

6596

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+

66107-- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping

67108-- `Nothing`s.

68109renderCommaSeparatedMaybe

@@ -76,5 +117,29 @@ renderCommaSeparatedMaybe render

76117 . hmap (K . render)

77118

78119-- | Render a promoted `Nat`.

79−renderNat :: KnownNat n => proxy n -> ByteString

80−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+346−395

@@ -1,33 +1,32 @@

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

14− , DataKinds

1516 , DeriveAnyClass

16− , DeriveDataTypeable

1717 , DeriveGeneric

1818 , FlexibleContexts

1919 , FlexibleInstances

2020 , FunctionalDependencies

2121 , GADTs

22− , MagicHash

23− , MultiParamTypeClasses

22+ , LambdaCase

2423 , OverloadedStrings

25− , PolyKinds

24+ , QuantifiedConstraints

2625 , RankNTypes

2726 , ScopedTypeVariables

2827 , StandaloneDeriving

2928 , TypeApplications

30− , TypeFamilies

29+ , TypeFamilyDependencies

3130 , TypeInType

3231 , TypeOperators

3332 , UndecidableInstances

@@ -35,97 +34,85 @@ A type-level DSL for kinds of PostgreSQL types, constraints, and aliases.

3534#-}

3635

3736module Squeal.PostgreSQL.Schema

38− ( -- * Types

37+ ( -- * Postgres Types

3938 PGType (..)

40− , HasOid (..)

4139 , NullityType (..)

40+ , RowType

41+ , FromType

42+ -- * Schema Types

4243 , ColumnType

4344 , ColumnsType

44− , RelationType

45− , NilRelation

46− , RelationsType

4745 , TableType

48− , TablesType

49− , NilTables

50− -- * Grouping

51− , Grouping (..)

52− , GroupedBy

46+ , SchemumType (..)

47+ , IndexType (..)

48+ , FunctionType

49+ , OperatorType (..)

50+ , ReturnsType (..)

51+ , SchemaType

52+ , SchemasType

53+ , Public

5354 -- * Constraints

5455 , (:=>)

5556 , ColumnConstraint (..)

5657 , TableConstraint (..)

5758 , TableConstraints

58− , NilTableConstraints

5959 , Uniquely

60− -- * Aliases

61− , (:::)

62− , Alias (Alias)

63− , renderAlias

64− , renderAliases

65− , Aliased (As)

66− , renderAliasedAs

67− , AliasesOf

68− , Has

69− , HasUnique

70− , HasAll

71− , IsLabel (..)

72− , IsQualified (..)

73− -- * Type Families

74− , Join

60+ -- * Enumerated Labels

61+ , IsPGlabel (..)

62+ , PGlabel (..)

63+ -- * Data Definitions

7564 , Create

65+ , CreateIfNotExists

66+ , CreateOrReplace

7667 , Drop

68+ , DropSchemum

69+ , DropIfExists

70+ , DropSchemumIfExists

7771 , Alter

72+ , AlterIfExists

7873 , Rename

79− , Elem

80− , In

74+ , RenameIfExists

75+ , ConstraintInvolves

76+ , DropIfConstraintsInvolve

77+ , IsNotElem

78+ , AllUnique

79+ -- * Type Classifications

8180 , PGNum

8281 , PGIntegral

8382 , PGFloating

8483 , PGTypeOf

85− , SameTypes

84+ , PGJsonType

85+ , PGJsonKey

8686 , SamePGType

8787 , AllNotNull

8888 , NotAllNull

89+ -- * Nullifications

8990 , NullifyType

90− , NullifyRelation

91− , NullifyRelations

92− , ColumnsToRelation

93− , RelationToColumns

91+ , NullifyRow

92+ , NullifyFrom

93+ -- * Table Conversions

9494 , TableToColumns

95− , TablesToRelations

96− , RelationsToTables

97− , ConstraintInvolves

98− , DropIfConstraintsInvolve

99− -- * Generics

100− , SameField

101− , SameFields

102− -- * Schema

103− , SchemumType (..)

104− , SchemaType

105− , TablesOf

106− , ViewsOf

107− , With

95+ , ColumnsToRow

96+ , TableToRow

10897 ) where

10998

110−import Control.DeepSeq

111−import Data.ByteString

99+import Control.Category

100+import Data.Kind

112101import Data.Monoid hiding (All)

113−import Data.String

114−import Data.Word

115102import Data.Type.Bool

116−import GHC.Exts

117−import GHC.OverloadedLabels

103+import Generics.SOP

118104import GHC.TypeLits

105+import Prelude hiding (id, (.))

119106

120−import qualified GHC.Generics as GHC

121−import qualified Generics.SOP as SOP

122−import qualified Generics.SOP.Type.Metadata as Type

123−

107+import Squeal.PostgreSQL.Alias

108+import Squeal.PostgreSQL.List

124109import Squeal.PostgreSQL.Render

125110

111+-- $setup

112+-- >>> import Squeal.PostgreSQL

113+

126114-- | `PGType` is the promoted datakind of PostgreSQL types.

127115--

128−-- >>> import Squeal.PostgreSQL.Schema

129116-- >>> :kind 'PGbool

130117-- 'PGbool :: PGType

131118data PGType

@@ -136,6 +123,7 @@ data PGType

136123 | PGnumeric -- ^ arbitrary precision numeric type

137124 | PGfloat4 -- ^ single precision floating-point number (4 bytes)

138125 | PGfloat8 -- ^ double precision floating-point number (8 bytes)

126+ | PGmoney -- ^ currency amount

139127 | PGchar Nat -- ^ fixed-length character string

140128 | PGvarchar Nat -- ^ variable-length character string

141129 | PGtext -- ^ variable-length character string

@@ -150,38 +138,16 @@ data PGType

150138 | PGinet -- ^ IPv4 or IPv6 host address

151139 | PGjson -- ^ textual JSON data

152140 | PGjsonb -- ^ binary JSON data, decomposed

153− | PGvararray PGType -- ^ variable length array

154− | PGfixarray Nat PGType -- ^ fixed length array

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

155149 | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types

156150

157−-- | The object identifier of a `PGType`.

158−--

159−-- >>> :set -XTypeApplications

160−-- >>> oid @'PGbool

161−-- 16

162−class HasOid (ty :: PGType) where oid :: Word32

163−instance HasOid 'PGbool where oid = 16

164−instance HasOid 'PGint2 where oid = 21

165−instance HasOid 'PGint4 where oid = 23

166−instance HasOid 'PGint8 where oid = 20

167−instance HasOid 'PGnumeric where oid = 1700

168−instance HasOid 'PGfloat4 where oid = 700

169−instance HasOid 'PGfloat8 where oid = 701

170−instance HasOid ('PGchar n) where oid = 18

171−instance HasOid ('PGvarchar n) where oid = 1043

172−instance HasOid 'PGtext where oid = 25

173−instance HasOid 'PGbytea where oid = 17

174−instance HasOid 'PGtimestamp where oid = 1114

175−instance HasOid 'PGtimestamptz where oid = 1184

176−instance HasOid 'PGdate where oid = 1082

177−instance HasOid 'PGtime where oid = 1083

178−instance HasOid 'PGtimetz where oid = 1266

179−instance HasOid 'PGinterval where oid = 1186

180−instance HasOid 'PGuuid where oid = 2950

181−instance HasOid 'PGinet where oid = 869

182−instance HasOid 'PGjson where oid = 114

183−instance HasOid 'PGjsonb where oid = 3802

184−

185151-- | `NullityType` encodes the potential presence or definite absence of a

186152-- @NULL@ allowing operations which are sensitive to such to be well typed.

187153--

@@ -200,14 +166,6 @@ data NullityType

200166type (:=>) constraint ty = '(constraint,ty)

201167infixr 7 :=>

202168

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

204−-- a type level pair between

205−-- an alias and some type, like a column alias and either a `ColumnType` or

206−-- `NullityType` or a table alias and either a `TableType` or a `RelationType`

207−-- or a constraint alias and a `TableConstraint`.

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

209−infixr 6 :::

210−

211169-- | `ColumnConstraint` encodes the availability of @DEFAULT@ for inserts and updates.

212170-- A column can be assigned a default value.

213171-- A data `Squeal.PostgreSQL.Manipulations.Manipulation` command can also

@@ -249,11 +207,14 @@ data TableConstraint

249207 | PrimaryKey [Symbol]

250208 | ForeignKey [Symbol] Symbol [Symbol]

251209

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

253217type TableConstraints = [(Symbol,TableConstraint)]

254−-- | A monokinded empty `TableConstraints`.

255−type family NilTableConstraints :: TableConstraints where

256− NilTableConstraints = '[]

257218

258219-- | A `ForeignKey` must reference columns that either are

259220-- a `PrimaryKey` or form a `Unique` constraint.

@@ -277,227 +238,65 @@ type family Uniquely

277238-- :}

278239type TableType = (TableConstraints,ColumnsType)

279240

280−-- | `TablesType` is a row of `TableType`s, thought of as a union.

281−--

282−-- >>> :{

283−-- type family Schema :: TablesType where

284−-- Schema =

285−-- '[ "users" :::

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

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

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

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

290−-- ]

291−-- , "emails" :::

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

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

294−-- ] :=>

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

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

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

298−-- ]

299−-- ]

300−-- :}

301−type TablesType = [(Symbol,TableType)]

302−-- | A monokinded empty `TablesType`.

303−type family NilTables :: TablesType where NilTables = '[]

304−

305−-- | `RelationType` is a row of `NullityType`

306−--

307−-- >>> :{

308−-- type family PersonRelation :: RelationType where

309−-- PersonRelation =

310−-- '[ "name" ::: 'NotNull 'PGtext

311−-- , "age" ::: 'NotNull 'PGint4

312−-- , "dateOfBirth" ::: 'Null 'PGdate

313−-- ]

314−-- :}

315−type RelationType = [(Symbol,NullityType)]

316−-- | A monokinded empty `RelationType`.

317−type family NilRelation :: RelationType where NilRelation = '[]

318−

319−-- | `RelationsType` is a row of `RelationType`s, thought of as a product.

320−type RelationsType = [(Symbol,RelationType)]

321−

322−-- | `ColumnsToRelation` removes column constraints.

323−type family ColumnsToRelation (columns :: ColumnsType) :: RelationType where

324− ColumnsToRelation '[] = '[]

325− ColumnsToRelation (column ::: constraint :=> ty ': columns) =

326− column ::: ty ': ColumnsToRelation columns

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

327254

328−-- | `RelationToColumns` adds `'NoDef` column constraints.

329−type family RelationToColumns (relation :: RelationType) :: ColumnsType where

330− RelationToColumns '[] = '[]

331− RelationToColumns (column ::: ty ': columns) =

332− column ::: 'NoDef :=> ty ': RelationToColumns 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 '[] = '[]

333276

334277-- | `TableToColumns` removes table constraints.

335278type family TableToColumns (table :: TableType) :: ColumnsType where

336279 TableToColumns (constraints :=> columns) = columns

337280

338−-- | `TablesToRelations` removes both table and column constraints.

339−type family TablesToRelations (tables :: TablesType) :: RelationsType where

340− TablesToRelations '[] = '[]

341− TablesToRelations (alias ::: constraint :=> columns ': tables) =

342− alias ::: ColumnsToRelation columns ': TablesToRelations tables

343−

344−-- | `RelationsToTables` adds both trivial table and column constraints.

345−type family RelationsToTables (tables :: RelationsType) :: TablesType where

346− RelationsToTables '[] = '[]

347− RelationsToTables (alias ::: columns ': relations) =

348− alias ::: '[] :=> RelationToColumns columns ': RelationsToTables relations

349−

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

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

352−-- for typesafe aggregation

353−data Grouping

354− = Ungrouped -- ^ no aggregation permitted

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

356−

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

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

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

360−-}

361−class (KnownSymbol relation, KnownSymbol column)

362− => GroupedBy relation column bys where

363−instance {-# OVERLAPPING #-} (KnownSymbol relation, KnownSymbol column)

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

365−instance {-# OVERLAPPABLE #-}

366− ( KnownSymbol relation

367− , KnownSymbol column

368− , GroupedBy relation column bys

369− ) => GroupedBy relation column (tabcol ': bys)

370−

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

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

373−--

374−-- >>> :set -XOverloadedLabels

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

376−-- Alias

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

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

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

380− fromLabel = Alias

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

382− fromLabel = fromLabel SOP.:* SOP.Nil

383−

384−-- | >>> renderAlias #jimbob

385−-- "\"jimbob\""

386−renderAlias :: KnownSymbol alias => Alias alias -> ByteString

387−renderAlias = doubleQuoted . fromString . symbolVal

388−

389−-- | >>> import Generics.SOP (NP(..))

390−-- >>> renderAliases (#jimbob :* #kandi :* Nil)

391−-- ["\"jimbob\"","\"kandi\""]

392−renderAliases

393− :: SOP.All KnownSymbol aliases => SOP.NP Alias aliases -> [ByteString]

394−renderAliases = SOP.hcollapse

395− . SOP.hcmap (SOP.Proxy @KnownSymbol) (SOP.K . renderAlias)

396−

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

398−-- version of `:::`.

399−--

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

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

402−data Aliased expression aliased where

403− As

404− :: KnownSymbol alias

405− => expression ty

406− -> Alias alias

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

408−deriving instance Show (expression ty)

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

410−deriving instance Eq (expression ty)

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

412−deriving instance Ord (expression ty)

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

414−

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

416−-- >>> renderAliasedAs renderMaybe (Just (3::Int) `As` #an_int)

417−-- "Just AS \"an_int\""

418−renderAliasedAs

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

420− -> Aliased expression aliased

421− -> ByteString

422−renderAliasedAs render (expression `As` alias) =

423− render expression <> " AS " <> renderAlias alias

424−

425−-- | `AliasesOf` retains the AliasesOf in a row.

426−type family AliasesOf aliaseds where

427− AliasesOf '[] = '[]

428− AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys

429−

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

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

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

433−

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

435−-- @fields@ has a field of @alias ::: field@.

436−class KnownSymbol alias =>

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

438− | alias fields -> field where

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

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

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

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

443−

444−class

445− ( SOP.All KnownSymbol aliases

446− ) => HasAll

447− (aliases :: [Symbol])

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

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

450− | aliases fields -> subfields where

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

452−instance {-# OVERLAPPABLE #-}

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

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

455−

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

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

458−-- by a table alias.

459−class IsQualified table column expression where

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

461− infixl 9 !

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

463−

464−-- | @Elem@ is a promoted `Data.List.elem`.

465−type family Elem x xs where

466− Elem x '[] = 'False

467− Elem x (x ': xs) = 'True

468− Elem x (_ ': xs) = Elem x xs

469−

470−-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.

471−type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True

472−

473−-- | `PGNum` is a constraint on `PGType` whose

474−-- `Squeal.PostgreSQL.Expression.Expression`s have a `Num` constraint.

475−type PGNum ty =

476− In ty '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]

477−

478−-- | `PGFloating` is a constraint on `PGType` whose

479−-- `Squeal.PostgreSQL.Expression.Expression`s

480−-- have `Fractional` and `Floating` constraints.

481−type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]

482−

483−-- | `PGIntegral` is a constraint on `PGType` whose

484−-- `Squeal.PostgreSQL.Expression.Expression`s

485−-- have `Squeal.PostgreSQL.Expression.div_` and

486−-- `Squeal.PostgreSQL.Expression.mod_` functions.

487−type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]

281+-- | Convert a table to a row type.

282+type family TableToRow (table :: TableType) :: RowType where

283+ TableToRow tab = ColumnsToRow (TableToColumns tab)

284+

285+-- | Numeric Postgres types.

286+type PGNum =

287+ '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]

288+

289+-- | Floating Postgres types.

290+type PGFloating = '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]

291+

292+-- | Integral Postgres types.

293+type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8]

488294

489295-- | `PGTypeOf` forgets about @NULL@ and any column constraints.

490296type family PGTypeOf (ty :: NullityType) :: PGType where

491297 PGTypeOf (nullity pg) = pg

492298

493−-- | `SameTypes` is a constraint that proves two `ColumnsType`s have the same

494−-- length and the same `ColumnType`s.

495−type family SameTypes (columns0 :: ColumnsType) (columns1 :: ColumnsType)

496− :: Constraint where

497− SameTypes '[] '[] = ()

498− SameTypes (column0 ::: def0 :=> ty0 ': columns0) (column1 ::: def1 :=> ty1 ': columns1)

499− = (ty0 ~ ty1, SameTypes columns0 columns1)

500−

299+-- | Equality constraint on the underlying `PGType` of two columns.

501300class SamePGType

502301 (ty0 :: (Symbol,ColumnType)) (ty1 :: (Symbol,ColumnType)) where

503302instance ty0 ~ ty1 => SamePGType

@@ -506,101 +305,166 @@ instance ty0 ~ ty1 => SamePGType

506305

507306-- | `AllNotNull` is a constraint that proves a `ColumnsType` has no @NULL@s.

508307type 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

509314 AllNotNull '[] = ()

510− AllNotNull (column ::: def :=> 'NotNull ty ': columns) = AllNotNull columns

511315

512316-- | `NotAllNull` is a constraint that proves a `ColumnsType` has some

513317-- @NOT NULL@.

514318type family NotAllNull (columns :: ColumnsType) :: Constraint where

515− NotAllNull (column ::: def :=> 'NotNull ty ': columns) = ()

516− NotAllNull (column ::: def :=> 'Null ty ': columns) = NotAllNull columns

517−

518−-- | `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`.

519328type family NullifyType (ty :: NullityType) :: NullityType where

520329 NullifyType ('Null ty) = 'Null ty

521330 NullifyType ('NotNull ty) = 'Null ty

522331

523−-- | `NullifyRelation` is an idempotent that nullifies a `ColumnsType`.

524−type family NullifyRelation (columns :: RelationType) :: RelationType where

525− NullifyRelation '[] = '[]

526− NullifyRelation (column ::: ty ': columns) =

527− column ::: NullifyType ty ': NullifyRelation columns

528−

529−-- | `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`

530349-- used to nullify the left or right hand side of an outer join

531350-- in a `Squeal.PostgreSQL.Query.FromClause`.

532−type family NullifyRelations (tables :: RelationsType) :: RelationsType where

533− NullifyRelations '[] = '[]

534− NullifyRelations (table ::: columns ': tables) =

535− table ::: NullifyRelation columns ': NullifyRelations tables

536−

537−-- | `Join` is simply promoted `++` and is used in @JOIN@s in

538−-- `Squeal.PostgreSQL.Query.FromClause`s.

539−type family Join xs ys where

540− Join '[] ys = ys

541− 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 '[] = '[]

542365

543366-- | @Create alias x xs@ adds @alias ::: x@ to the end of @xs@ and is used in

544367-- `Squeal.PostgreSQL.Definition.createTable` statements and in @ALTER TABLE@

545368-- `Squeal.PostgreSQL.Definition.addColumn`.

546369type family Create alias x xs where

547370 Create alias x '[] = '[alias ::: x]

371+ Create alias x (alias ::: y ': xs) = TypeError

372+ ('Text "Create: alias "

373+ ':<>: 'ShowType alias

374+ ':<>: 'Text "already exists")

548375 Create alias y (x ': xs) = x ': Create alias y xs

549376

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+

550394-- | @Drop alias xs@ removes the type associated with @alias@ in @xs@

551395-- and is used in `Squeal.PostgreSQL.Definition.dropTable` statements

552396-- and in @ALTER TABLE@ `Squeal.PostgreSQL.Definition.dropColumn` statements.

553397type family Drop alias xs where

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

555403 Drop alias (x ': xs) = x ': Drop alias xs

556404

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+

557437-- | @Alter alias x xs@ replaces the type associated with an @alias@ in @xs@

558−-- 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`

559439-- and `Squeal.PostgreSQL.Definition.alterColumn`.

560440type family Alter alias x xs where

441+ Alter alias x '[] = TypeError

442+ ('Text "Alter: alias "

443+ ':<>: 'ShowType alias

444+ ':<>: 'Text " does not exist" )

561445 Alter alias x1 (alias ::: x0 ': xs) = alias ::: x1 ': xs

562446 Alter alias x1 (x0 ': xs) = x0 ': Alter alias x1 xs

563447

564−-- type family AddConstraint constraint ty where

565−-- AddConstraint constraint (constraints :=> ty)

566−-- = AsSet (constraint ': constraints) :=> ty

567−

568−-- type family DeleteFromList (e :: elem) (list :: [elem]) where

569−-- DeleteFromList elem '[] = '[]

570−-- DeleteFromList elem (x ': xs) =

571−-- If (Cmp elem x == 'EQ) xs (x ': DeleteFromList elem xs)

572−

573−-- type family DropConstraint constraint ty where

574−-- DropConstraint constraint (constraints :=> ty)

575−-- = (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

576452

577453-- | @Rename alias0 alias1 xs@ replaces the alias @alias0@ by @alias1@ in @xs@

578454-- and is used in `Squeal.PostgreSQL.Definition.alterTableRename` and

579455-- `Squeal.PostgreSQL.Definition.renameColumn`.

580456type family Rename alias0 alias1 xs where

457+ Rename alias0 alias1 '[] = TypeError

458+ ('Text "Rename: alias "

459+ ':<>: 'ShowType alias0

460+ ':<>: 'Text " does not exist" )

581461 Rename alias0 alias1 ((alias0 ::: x0) ': xs) = (alias1 ::: x0) ': xs

582462 Rename alias0 alias1 (x ': xs) = x ': Rename alias0 alias1 xs

583463

584−-- | A `SameField` constraint is an equality constraint on a

585−-- `Generics.SOP.Type.Metadata.FieldInfo` and the column alias in a `:::` pair.

586−class SameField

587− (fieldInfo :: Type.FieldInfo) (fieldty :: (Symbol,NullityType)) where

588−instance field ~ column => SameField ('Type.FieldInfo field) (column ::: ty)

589−

590−-- | A `SameFields` constraint proves that a

591−-- `Generics.SOP.Type.Metadata.DatatypeInfo` of a record type has the same

592−-- field names as the column AliasesOf of a `ColumnsType`.

593−type family SameFields

594− (datatypeInfo :: Type.DatatypeInfo) (columns :: RelationType)

595− :: Constraint where

596− SameFields

597− ('Type.ADT _module _datatype '[ 'Type.Record _constructor fields])

598− columns

599− = SOP.AllZip SameField fields columns

600− SameFields

601− ('Type.Newtype _module _datatype ('Type.Record _constructor fields))

602− columns

603− = SOP.AllZip SameField fields columns

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

604468

605469-- | Check if a `TableConstraint` involves a column

606470type family ConstraintInvolves column constraint where

@@ -618,28 +482,115 @@ type family DropIfConstraintsInvolve column constraints where

618482 (DropIfConstraintsInvolve column constraints)

619483 (alias ::: constraint ': DropIfConstraintsInvolve column constraints)

620484

485+-- | A `SchemumType` is a user-defined type, either a `Table`,

486+-- `View` or `Typedef`.

621487data SchemumType

622488 = Table TableType

623− | View RelationType

624−

489+ | View RowType

490+ | Typedef PGType

491+ | Index IndexType

492+ | Function FunctionType

493+ | Operator OperatorType

494+ | UnsafeSchemum Symbol

495+

496+type FunctionType = ([NullityType], ReturnsType)

497+

498+data IndexType

499+ = Btree

500+ | Hash

501+ | Gist

502+ | Spgist

503+ | Gin

504+ | Brin

505+

506+data ReturnsType

507+ = Returns NullityType

508+ | ReturnsTable RowType

509+

510+data OperatorType

511+ = BinaryOp NullityType NullityType NullityType

512+ | LeftOp NullityType NullityType

513+ | RightOp NullityType NullityType

514+

515+{- | The schema of a database consists of a list of aliased,

516+user-defined `SchemumType`s.

517+

518+>>> :{

519+type family Schema :: SchemaType where

520+ Schema =

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

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

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

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

525+ ])

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

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

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

529+ ] :=>

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

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

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

533+ ])

534+ ]

535+:}

536+-}

625537type SchemaType = [(Symbol,SchemumType)]

626538

627−type family TablesOf (schema :: SchemaType) :: TablesType where

628− TablesOf '[] = '[]

629− TablesOf (alias ::: 'Table table ': schema) =

630− alias ::: table ': TablesOf schema

631− TablesOf (_ ': schema) = TablesOf schema

632−

633−type family ViewsOf (schema :: SchemaType) :: RelationsType where

634− ViewsOf '[] = '[]

635− ViewsOf (alias ::: 'View view ': schema) =

636− alias ::: view ': ViewsOf schema

637− ViewsOf (_ ': schema) = ViewsOf schema

638−

639−type family With

640− (relations :: RelationsType)

641− (schema :: SchemaType)

642− :: SchemaType where

643− With '[] schema = schema

644− With (alias ::: rel ': rels) schema =

645− alias ::: 'Table ('[] :=> RelationToColumns 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]

559+

560+-- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas

561+-- the overloaded label, `fromLabel` is used for column references,

562+-- `label`s are used for enum terms. A `label` is called with

563+-- type application like `label @"beef"`.

564+class IsPGlabel (label :: Symbol) expr where label :: expr

565+instance label ~ label1

566+ => IsPGlabel label (PGlabel label1) where label = PGlabel

567+instance labels ~ '[label]

568+ => IsPGlabel label (NP PGlabel labels) where label = PGlabel :* Nil

569+-- | A `PGlabel` unit type with an `IsPGlabel` instance

570+data PGlabel (label :: Symbol) = PGlabel

571+instance KnownSymbol label => RenderSQL (PGlabel label) where

572+ renderSQL _ = "\'" <> renderSymbol @label <> "\'"

573+instance All KnownSymbol labels => RenderSQL (NP PGlabel labels) where

574+ renderSQL

575+ = commaSeparated

576+ . hcollapse

577+ . hcmap (Proxy @KnownSymbol) (K . renderSQL)

578+

579+-- | Is a type a valid JSON key?

580+type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]

581+

582+-- | Is a type a valid JSON type?

583+type PGJsonType = '[ 'PGjson, 'PGjsonb ]

584+

585+-- | Utility class for `AllUnique` to provide nicer error messages.

586+class IsNotElem x isElem where

587+instance IsNotElem x 'False where

588+instance (TypeError ( 'Text "Cannot assign to "

589+ ':<>: 'ShowType alias

590+ ':<>: 'Text " more than once"))

591+ => IsNotElem '(alias, a) 'True where

592+

593+-- | No elem of @xs@ appears more than once, in the context of assignment.

594+class AllUnique (xs :: [(Symbol, a)]) where

595+instance AllUnique '[] where

596+instance (IsNotElem x (Elem x xs), AllUnique xs) => AllUnique (x ': xs) where

squeal-postgresql/src/Squeal/PostgreSQL/Transaction.hs+102−82

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

@@ -10,14 +10,9 @@ Squeal transaction control language.

1010

1111{-# LANGUAGE

1212 DataKinds

13− , EmptyCase

1413 , FlexibleContexts

15− , FlexibleInstances

1614 , LambdaCase

1715 , OverloadedStrings

18− , MultiParamTypeClasses

19− , ScopedTypeVariables

20− , TypeFamilies

2116 , TypeInType

2217#-}

2318

@@ -25,89 +20,114 @@ module Squeal.PostgreSQL.Transaction

2520 ( -- * Transaction

2621 transactionally

2722 , transactionally_

23+ , transactionallyRetry

24+ , ephemerally

25+ , ephemerally_

2826 , begin

2927 , commit

3028 , rollback

31− , transactionallySchema

32− , transactionallySchema_

3329 -- * Transaction Mode

3430 , TransactionMode (..)

3531 , defaultMode

3632 , longRunningMode

3733 , IsolationLevel (..)

38− , renderIsolationLevel

3934 , AccessMode (..)

40− , renderAccessMode

4135 , DeferrableMode (..)

42− , renderDeferrableMode

4336 ) where

4437

45−import Control.Exception.Lifted

46−import Control.Monad.Base

47−import Control.Monad.Trans.Control

48−import Data.ByteString

49−import Data.Monoid

50−import Generics.SOP

51−

52−import qualified Database.PostgreSQL.LibPQ as LibPQ

38+import UnliftIO

5339

5440import Squeal.PostgreSQL.Manipulation

5541import Squeal.PostgreSQL.Render

5642import Squeal.PostgreSQL.PQ

57−import Squeal.PostgreSQL.Schema

5843

59−-- | 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+-}

6050transactionally

61− :: (MonadBaseControl IO tx, MonadPQ schema tx)

51+ :: (MonadUnliftIO tx, MonadPQ schemas tx)

6252 => TransactionMode

6353 -> tx x -- ^ run inside a transaction

6454 -> tx x

6555transactionally mode tx = mask $ \restore -> do

66− _ <- begin mode

67− result <- restore tx `onException` rollback

68− _ <- commit

56+ manipulate_ $ begin mode

57+ result <- restore tx `onException` (manipulate_ rollback)

58+ manipulate_ commit

6959 return result

7060

71−-- | Run a schema invariant computation `transactionally_` in `defaultMode`.

61+-- | Run a computation `transactionally_`, in `defaultMode`.

7262transactionally_

73− :: (MonadBaseControl IO tx, MonadPQ schema tx)

63+ :: (MonadUnliftIO tx, MonadPQ schemas tx)

7464 => tx x -- ^ run inside a transaction

7565 -> tx x

7666transactionally_ = transactionally defaultMode

7767

78−-- | @BEGIN@ a transaction.

79−begin :: MonadPQ schema tx => TransactionMode -> tx (K Result NilRelation)

80−begin mode = manipulate . UnsafeManipulation $

81− "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

82112

83−-- | @COMMIT@ a schema invariant transaction.

84−commit :: MonadPQ schema tx => tx (K Result NilRelation)

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

86123

87−-- | @ROLLBACK@ a schema invariant transaction.

88−rollback :: MonadPQ schema tx => tx (K Result NilRelation)

89−rollback = manipulate $ UnsafeManipulation "ROLLBACK;"

124+-- | @COMMIT@ a transaction.

125+commit :: Manipulation_ schemas () ()

126+commit = UnsafeManipulation "COMMIT"

90127

91−-- | Run a schema changing computation `transactionallySchema`.

92−transactionallySchema

93− :: MonadBaseControl IO io

94− => TransactionMode

95− -> PQ schema0 schema1 io x

96− -> PQ schema0 schema1 io x

97−transactionallySchema mode u = PQ $ \ conn -> mask $ \ restore -> do

98− _ <- liftBase . LibPQ.exec (unK conn) $

99− "BEGIN" <+> renderTransactionMode mode <> ";"

100− x <- restore (unPQ u conn)

101− `onException` (liftBase (LibPQ.exec (unK conn) "ROLLBACK"))

102− _ <- liftBase $ LibPQ.exec (unK conn) "COMMIT"

103− return x

104−

105−-- | Run a schema changing computation `transactionallySchema_` in `DefaultMode`.

106−transactionallySchema_

107− :: MonadBaseControl IO io

108− => PQ schema0 schema1 io x

109− -> PQ schema0 schema1 io x

110−transactionallySchema_ = transactionallySchema defaultMode

128+-- | @ROLLBACK@ a transaction.

129+rollback :: Manipulation_ schemas () ()

130+rollback = UnsafeManipulation "ROLLBACK"

111131

112132-- | The available transaction characteristics are the transaction `IsolationLevel`,

113133-- the transaction `AccessMode` (`ReadWrite` or `ReadOnly`), and the `DeferrableMode`.

@@ -120,7 +140,7 @@ data TransactionMode = TransactionMode

120140-- | `TransactionMode` with a `Serializable` `IsolationLevel`,

121141-- `ReadWrite` `AccessMode` and `NotDeferrable` `DeferrableMode`.

122142defaultMode :: TransactionMode

123−defaultMode = TransactionMode Serializable ReadWrite NotDeferrable

143+defaultMode = TransactionMode ReadCommitted ReadWrite NotDeferrable

124144

125145-- | `TransactionMode` with a `Serializable` `IsolationLevel`,

126146-- `ReadOnly` `AccessMode` and `Deferrable` `DeferrableMode`.

@@ -129,12 +149,12 @@ longRunningMode :: TransactionMode

129149longRunningMode = TransactionMode Serializable ReadOnly Deferrable

130150

131151-- | Render a `TransactionMode`.

132−renderTransactionMode :: TransactionMode -> ByteString

133−renderTransactionMode mode =

134− "ISOLATION LEVEL"

135− <+> renderIsolationLevel (isolationLevel mode)

136− <+> renderAccessMode (accessMode mode)

137− <+> 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)

138158

139159-- | The SQL standard defines four levels of transaction isolation.

140160-- The most strict is `Serializable`, which is defined by the standard in a paragraph

@@ -165,32 +185,32 @@ data IsolationLevel

165185 = Serializable

166186 -- ^ Dirty read is not possible.

167187 -- Nonrepeatable read is not possible.

168− -- Phantom read is not possible.

188+ -- Phantom read is not possible.

169189 -- Serialization anomaly is not possible.

170190 | RepeatableRead

171191 -- ^ Dirty read is not possible.

172192 -- Nonrepeatable read is not possible.

173− -- Phantom read is not possible.

193+ -- Phantom read is not possible.

174194 -- Serialization anomaly is possible.

175195 | ReadCommitted

176196 -- ^ Dirty read is not possible.

177197 -- Nonrepeatable read is possible.

178− -- Phantom read is possible.

198+ -- Phantom read is possible.

179199 -- Serialization anomaly is possible.

180200 | ReadUncommitted

181201 -- ^ Dirty read is not possible.

182202 -- Nonrepeatable read is possible.

183− -- Phantom read is possible.

203+ -- Phantom read is possible.

184204 -- Serialization anomaly is possible.

185205 deriving (Show, Eq)

186206

187207-- | Render an `IsolationLevel`.

188−renderIsolationLevel :: IsolationLevel -> ByteString

189−renderIsolationLevel = \case

190− Serializable -> "SERIALIZABLE"

191− ReadCommitted -> "READ COMMITTED"

192− ReadUncommitted -> "READ UNCOMMITTED"

193− 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"

194214

195215-- | The transaction access mode determines whether the transaction is `ReadWrite` or `ReadOnly`.

196216-- `ReadWrite` is the default. When a transaction is `ReadOnly`,

@@ -207,10 +227,10 @@ data AccessMode

207227 deriving (Show, Eq)

208228

209229-- | Render an `AccessMode`.

210−renderAccessMode :: AccessMode -> ByteString

211−renderAccessMode = \case

212− ReadWrite -> "READ WRITE"

213− ReadOnly -> "READ ONLY"

230+instance RenderSQL AccessMode where

231+ renderSQL = \case

232+ ReadWrite -> "READ WRITE"

233+ ReadOnly -> "READ ONLY"

214234

215235-- | The `Deferrable` transaction property has no effect

216236-- unless the transaction is also `Serializable` and `ReadOnly`.

@@ -226,7 +246,7 @@ data DeferrableMode

226246 deriving (Show, Eq)

227247

228248-- | Render a `DeferrableMode`.

229−renderDeferrableMode :: DeferrableMode -> ByteString

230−renderDeferrableMode = \case

231− Deferrable -> "DEFERRABLE"

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