c31bdbe · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

Merge pull request #45 from echatav/docs

c31bdbeEitan Chatav9 years ago

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

compare with dev

unifiedsplit

@@ -59,12 +59,12 @@ main = do

59 ( Values

60 (param @1 `As` #col1 :* param @2 `As` #col2 :* Nil)

61 [param @3 `As` #col1 :* param @4 `As` #col2 :* Nil]

62− ) Conflict (Returning Nil)

62+ ) OnConflictDoNothing (Returning Nil)

63 liftBase $ Char8.putStrLn "manipulating"

64 _insertResult <- manipulateParams insert

65 (1::Int32,2::Int32,3::Int32,4::Int32)

66 liftBase $ Char8.putStrLn "querying"

67− result <- query $

67+ result <- runQuery $

68 selectStar (from (Table (#table1 `As` #table1)))

69 value00 <- getValue (RowNumber 0) (columnNumber @0) result

70 value01 <- getValue (RowNumber 0) (columnNumber @1) result

squeal-postgresql/src/Squeal/PostgreSQL.hs+10

@@ -1,3 +1,13 @@

1+{-|

2+Module: Squeal.PostgreSQL

3+Description: Squeel export module

4+Copyright: (c) Eitan Chatav, 2017

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+`Squeal.PostgreSQL` re-exports @squeel-postgresql@'s main modules.

9+-}

10+

1module Squeal.PostgreSQL

11module Squeal.PostgreSQL

2 ( module Squeal.PostgreSQL.Binary

12 ( module Squeal.PostgreSQL.Binary

3 , module Squeal.PostgreSQL.Definition

13 , module Squeal.PostgreSQL.Definition

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

@@ -249,10 +249,10 @@ instance

249-- >>> toParams @(Only (Maybe Text)) @'[ 'Required ('Null 'PGtext)] (Only (Just "foo"))

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

251--

252−-- >>> type PGShortRow = '["only" ::: 'Required ('Null 'PGtext)]

252+-- >>> type PGShortRow = '["fromOnly" ::: 'Required ('Null 'PGtext)]

253-- >>> fromRow @PGShortRow @(Only (Maybe Text)) (K (Just "bar") :* Nil)

254−-- Only {only = Just "bar"}

254+-- Only {fromOnly = Just "bar"}

255−newtype Only x = Only { only :: x }

255+newtype Only x = Only { fromOnly :: x }

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

257instance Generic (Only x)

258instance HasDatatypeInfo (Only x)

squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs+360−63

@@ -1,3 +1,13 @@

1+{-|

2+Module: Squeal.PostgreSQL.Definition

3+Description: Squeal data definition language

4+Copyright: (c) Eitan Chatav, 2017

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Squeal data definition language.

9+-}

10+

1{-# LANGUAGE

11{-# LANGUAGE

2 DataKinds

12 DataKinds

3 , DeriveDataTypeable

13 , DeriveDataTypeable

@@ -14,25 +24,30 @@

14#-}

24#-}

16module Squeal.PostgreSQL.Definition

26module Squeal.PostgreSQL.Definition

17− ( -- * Data Definition Language

27+ ( -- * Definition

18 Definition (UnsafeDefinition, renderDefinition)

28 Definition (UnsafeDefinition, renderDefinition)

29+ -- * Create

19 , createTable

30 , createTable

20 , TableConstraint (UnsafeTableConstraint, renderTableConstraint)

31 , TableConstraint (UnsafeTableConstraint, renderTableConstraint)

21 , check

32 , check

22 , unique

33 , unique

23 , primaryKey

34 , primaryKey

24 , foreignKey

35 , foreignKey

25− , OnDelete (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade)

36+ , OnDeleteClause (OnDeleteNoAction, OnDeleteRestrict, OnDeleteCascade)

26− , renderOnDelete

37+ , renderOnDeleteClause

27− , OnUpdate (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)

38+ , OnUpdateClause (OnUpdateNoAction, OnUpdateRestrict, OnUpdateCascade)

28− , renderOnUpdate

39+ , renderOnUpdateClause

40+ -- * Drop

29 , dropTable

41 , dropTable

42+ -- * Alter

30 , alterTable

43 , alterTable

31 , alterTableRename

44 , alterTableRename

32− , AlterTable (UnsafeAlterTable, renderAlterTable)

45+ , alterTableAddConstraint

46+ , AlterColumns (UnsafeAlterColumns, renderAlterColumns)

33 , addColumnDefault

47 , addColumnDefault

34 , addColumnNull

48 , addColumnNull

35 , dropColumn

49 , dropColumn

50+ , dropColumnCascade

36 , renameColumn

51 , renameColumn

37 , alterColumn

52 , alterColumn

38 , AlterColumn (UnsafeAlterColumn, renderAlterColumn)

53 , AlterColumn (UnsafeAlterColumn, renderAlterColumn)

@@ -47,10 +62,10 @@ import Control.Category

47import Control.DeepSeq

62import Control.DeepSeq

48import Data.ByteString

63import Data.ByteString

49import Data.Monoid

64import Data.Monoid

50−import Generics.SOP

51import GHC.TypeLits

65import GHC.TypeLits

52import Prelude hiding ((.), id)

66import Prelude hiding ((.), id)

68+import qualified Generics.SOP as SOP

54import qualified GHC.Generics as GHC

69import qualified GHC.Generics as GHC

56import Squeal.PostgreSQL.Expression

71import Squeal.PostgreSQL.Expression

@@ -61,6 +76,9 @@ import Squeal.PostgreSQL.Schema

61statements

76statements

62-----------------------------------------}

77-----------------------------------------}

79+-- | A `Definition` is a statement that changes the schema of the

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

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

64newtype Definition

82newtype Definition

65 (schema0 :: TablesType)

83 (schema0 :: TablesType)

66 (schema1 :: TablesType)

84 (schema1 :: TablesType)

@@ -76,11 +94,21 @@ instance Category Definition where

76CREATE statements

94CREATE statements

77-----------------------------------------}

95-----------------------------------------}

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

98+--

99+-- >>> :set -XOverloadedLabels

100+-- >>> :{

101+-- renderDefinition $

102+-- createTable #tab (int `As` #a :* real `As` #b :* Nil) []

103+-- :}

104+-- "CREATE TABLE tab (a int, b real);"

79createTable

105createTable

80− :: (KnownSymbol table, SListI columns)

106+ :: (KnownSymbol table, SOP.SListI columns)

81− => Alias table

107+ => Alias table -- ^ the name of the table to add

82 -> NP (Aliased TypeExpression) (column ': columns)

108 -> NP (Aliased TypeExpression) (column ': columns)

109+ -- ^ the names and datatype of each column

83 -> [TableConstraint schema (column ': columns)]

110 -> [TableConstraint schema (column ': columns)]

111+ -- ^ constraints that must hold for the table

84 -> Definition schema (Create table (column ': columns) schema)

112 -> Definition schema (Create table (column ': columns) schema)

85createTable table columns constraints = UnsafeDefinition $

113createTable table columns constraints = UnsafeDefinition $

86 "CREATE TABLE" <+> renderAlias table

114 "CREATE TABLE" <+> renderAlias table

@@ -97,74 +125,175 @@ createTable table columns constraints = UnsafeDefinition $

97 [] -> ""

125 [] -> ""

98 _ -> ", " <> commaSeparated (renderTableConstraint <$> constraints)

126 _ -> ", " <> commaSeparated (renderTableConstraint <$> constraints)

127

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

129+-- table. For many applications, however, the constraint they provide is

130+-- too coarse. For example, a column containing a product price should

131+-- probably only accept positive values. But there is no standard data type

132+-- that accepts only positive numbers. Another issue is that you might want

133+-- to constrain column data with respect to other columns or rows.

134+-- For example, in a table containing product information,

135+-- there should be only one row for each product number.

136+-- `TableConstraint`s give you as much control over the data in your tables

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

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

139+-- even if the value came from the default value definition.

100newtype TableConstraint

140newtype TableConstraint

101 (schema :: TablesType)

141 (schema :: TablesType)

102 (columns :: ColumnsType)

142 (columns :: ColumnsType)

103 = UnsafeTableConstraint { renderTableConstraint :: ByteString }

143 = UnsafeTableConstraint { renderTableConstraint :: ByteString }

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

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

105

145

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

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

148+-- a Boolean (truth-value) expression.

149+--

150+-- >>> :{

151+-- renderDefinition $

152+-- createTable #tab

153+-- ( (int & notNull) `As` #a :*

154+-- (int & notNull) `As` #b :* Nil )

155+-- [ check (#a .> #b) ]

156+-- :}

157+-- "CREATE TABLE tab (a int NOT NULL, b int NOT NULL, CHECK ((a > b)));"

106check

158check

107 :: Condition '[table ::: columns] 'Ungrouped '[]

159 :: Condition '[table ::: columns] 'Ungrouped '[]

160+ -- ^ condition to check

108 -> TableConstraint schema columns

161 -> TableConstraint schema columns

109check condition = UnsafeTableConstraint $

162check condition = UnsafeTableConstraint $

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

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

111

164

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

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

167+--

168+-- >>> :{

169+-- renderDefinition $

170+-- createTable #tab

171+-- ( int `As` #a :*

172+-- int `As` #b :* Nil )

173+-- [ unique (Column #a :* Column #b :* Nil) ]

174+-- :}

175+-- "CREATE TABLE tab (a int, b int, UNIQUE (a, b));"

112unique

176unique

113− :: SListI subcolumns

177+ :: SOP.SListI subcolumns

114 => NP (Column columns) subcolumns

178 => NP (Column columns) subcolumns

179+ -- ^ unique column or group of columns

115 -> TableConstraint schema columns

180 -> TableConstraint schema columns

116unique columns = UnsafeTableConstraint $

181unique columns = UnsafeTableConstraint $

117 "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)

182 "UNIQUE" <+> parenthesized (renderCommaSeparated renderColumn columns)

118

183

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

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

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

187+--

188+-- >>> :{

189+-- renderDefinition $

190+-- createTable #tab

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

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

193+-- [ primaryKey (Column #id :* Nil) ]

194+-- :}

195+-- "CREATE TABLE tab (id serial, name text NOT NULL, PRIMARY KEY (id));"

119primaryKey

196primaryKey

120− :: (SListI subcolumns, AllNotNull subcolumns)

197+ :: (SOP.SListI subcolumns, AllNotNull subcolumns)

121 => NP (Column columns) subcolumns

198 => NP (Column columns) subcolumns

199+ -- ^ identifying column or group of columns

122 -> TableConstraint schema columns

200 -> TableConstraint schema columns

123primaryKey columns = UnsafeTableConstraint $

201primaryKey columns = UnsafeTableConstraint $

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

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

125

203

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

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

206+-- another table. We say this maintains the referential integrity

207+-- between two related tables.

208+--

209+-- >>> :{

210+-- let

211+-- definition :: Definition '[]

212+-- '[ "users" :::

213+-- '[ "id" ::: 'Optional ('NotNull 'PGint4)

214+-- , "username" ::: 'Required ('NotNull 'PGtext)

215+-- ]

216+-- , "emails" :::

217+-- '[ "id" ::: 'Optional ('NotNull 'PGint4)

218+-- , "userid" ::: 'Required ('NotNull 'PGint4)

219+-- , "email" ::: 'Required ('NotNull 'PGtext)

220+-- ]

221+-- ]

222+-- definition =

223+-- createTable #users

224+-- (serial `As` #id :* (text & notNull) `As` #username :* Nil)

225+-- [primaryKey (Column #id :* Nil)] >>>

226+-- createTable #emails

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

228+-- (integer & notNull) `As` #userid :*

229+-- (text & notNull) `As` #email :* Nil )

230+-- [ primaryKey (Column #id :* Nil)

231+-- , foreignKey (Column #userid :* Nil) #users (Column #id :* Nil)

232+-- OnDeleteCascade OnUpdateRestrict

233+-- ]

234+-- in renderDefinition definition

235+-- :}

236+-- "CREATE TABLE users (id serial, username text NOT NULL, PRIMARY KEY (id)); CREATE TABLE emails (id serial, userid integer NOT NULL, email text NOT NULL, PRIMARY KEY (id), FOREIGN KEY (userid) REFERENCES users (id) ON DELETE CASCADE ON UPDATE RESTRICT);"

126foreignKey

237foreignKey

127 :: ( HasTable reftable schema refcolumns

238 :: ( HasTable reftable schema refcolumns

128 , SameTypes subcolumns refsubcolumns

239 , SameTypes subcolumns refsubcolumns

129 , NotAllNull subcolumns

240 , NotAllNull subcolumns

130− , SListI subcolumns

241+ , SOP.SListI subcolumns

131− , SListI refsubcolumns)

242+ , SOP.SListI refsubcolumns)

132 => NP (Column columns) subcolumns

243 => NP (Column columns) subcolumns

244+ -- ^ column or columns in the table

133 -> Alias reftable

245 -> Alias reftable

246+ -- ^ reference table

134 -> NP (Column refcolumns) refsubcolumns

247 -> NP (Column refcolumns) refsubcolumns

135− -> OnDelete

248+ -- ^ reference column or columns in the reference table

136− -> OnUpdate

249+ -> OnDeleteClause

250+ -- ^ what to do when reference is deleted

251+ -> OnUpdateClause

252+ -- ^ what to do when reference is updated

137 -> TableConstraint schema columns

253 -> TableConstraint schema columns

138foreignKey columns reftable refcolumns onDelete onUpdate =

254foreignKey columns reftable refcolumns onDelete onUpdate =

139 UnsafeTableConstraint $

255 UnsafeTableConstraint $

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

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

141 <+> "REFERENCES" <+> renderAlias reftable

257 <+> "REFERENCES" <+> renderAlias reftable

142 <+> parenthesized (renderCommaSeparated renderColumn refcolumns)

258 <+> parenthesized (renderCommaSeparated renderColumn refcolumns)

143− <+> renderOnDelete onDelete

259+ <+> renderOnDeleteClause onDelete

144− <+> renderOnUpdate onUpdate

260+ <+> renderOnUpdateClause onUpdate

145

261

146−data OnDelete

262+-- | `OnDelete` indicates what to do with rows that reference a deleted row.

263+data OnDeleteClause

147 = OnDeleteNoAction

264 = OnDeleteNoAction

265+ -- ^ if any referencing rows still exist when the constraint is checked,

266+ -- an error is raised

148− | OnDeleteRestrict

267+ | OnDeleteRestrict -- ^ prevents deletion of a referenced row

149 | OnDeleteCascade

268 | OnDeleteCascade

269+ -- ^ specifies that when a referenced row is deleted,

270+ -- row(s) referencing it should be automatically deleted as well

150 deriving (GHC.Generic,Show,Eq,Ord)

271 deriving (GHC.Generic,Show,Eq,Ord)

151−instance NFData OnDelete

272+instance NFData OnDeleteClause

152

273

153−renderOnDelete :: OnDelete -> ByteString

274+-- | Render `OnDeleteClause`.

154−renderOnDelete = \case

275+renderOnDeleteClause :: OnDeleteClause -> ByteString

276+renderOnDeleteClause = \case

155 OnDeleteNoAction -> "ON DELETE NO ACTION"

277 OnDeleteNoAction -> "ON DELETE NO ACTION"

156 OnDeleteRestrict -> "ON DELETE RESTRICT"

278 OnDeleteRestrict -> "ON DELETE RESTRICT"

157 OnDeleteCascade -> "ON DELETE CASCADE"

279 OnDeleteCascade -> "ON DELETE CASCADE"

158

280

159−data OnUpdate

281+-- | Analagous to `OnDelete` there is also `OnUpdate` which is invoked

282+-- when a referenced column is changed (updated).

283+data OnUpdateClause

160 = OnUpdateNoAction

284 = OnUpdateNoAction

285+ -- ^ if any referencing rows has not changed when the constraint is checked,

286+ -- an error is raised

161− | OnUpdateRestrict

287+ | OnUpdateRestrict -- ^ prevents update of a referenced row

162 | OnUpdateCascade

288 | OnUpdateCascade

289+ -- ^ the updated values of the referenced column(s) should be copied

290+ -- into the referencing row(s)

163 deriving (GHC.Generic,Show,Eq,Ord)

291 deriving (GHC.Generic,Show,Eq,Ord)

164−instance NFData OnUpdate

292+instance NFData OnUpdateClause

165

293

166−renderOnUpdate :: OnUpdate -> ByteString

294+-- | Render `OnUpdateClause`.

167−renderOnUpdate = \case

295+renderOnUpdateClause :: OnUpdateClause -> ByteString

296+renderOnUpdateClause = \case

168 OnUpdateNoAction -> "ON UPDATE NO ACTION"

297 OnUpdateNoAction -> "ON UPDATE NO ACTION"

169 OnUpdateRestrict -> "ON UPDATE RESTRICT"

298 OnUpdateRestrict -> "ON UPDATE RESTRICT"

170 OnUpdateCascade -> "ON UPDATE CASCADE"

299 OnUpdateCascade -> "ON UPDATE CASCADE"

@@ -173,9 +302,13 @@ renderOnUpdate = \case

173DROP statements

302DROP statements

174-----------------------------------------}

303-----------------------------------------}

175

304

305+-- | `dropTable` removes a table from the schema.

306+--

307+-- >>> renderDefinition $ dropTable #muh_table

308+-- "DROP TABLE muh_table;"

176dropTable

309dropTable

177 :: KnownSymbol table

310 :: KnownSymbol table

178− => Alias table

311+ => Alias table -- ^ table to remove

179 -> Definition schema (Drop table schema)

312 -> Definition schema (Drop table schema)

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

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

181

314

@@ -183,93 +316,257 @@ dropTable table = UnsafeDefinition $ "DROP TABLE" <+> renderAlias table <> ";"

183ALTER statements

316ALTER statements

184-----------------------------------------}

317-----------------------------------------}

185

318

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

186alterTable

320alterTable

187 :: HasTable table schema columns0

321 :: HasTable table schema columns0

188− => Alias table

322+ => Alias table -- ^ table to alter

189− -> AlterTable columns0 columns1

323+ -> AlterColumns columns0 columns1 -- ^ alteration to perform

190 -> Definition schema (Alter table schema columns1)

324 -> Definition schema (Alter table schema columns1)

191alterTable table alteration = UnsafeDefinition $

325alterTable table alteration = UnsafeDefinition $

192 "ALTER TABLE"

326 "ALTER TABLE"

193 <+> renderAlias table

327 <+> renderAlias table

194− <+> renderAlterTable alteration

328+ <+> renderAlterColumns alteration

195 <> ";"

329 <> ";"

196

330

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

332+--

333+-- >>> renderDefinition $ alterTableRename #foo #bar

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

197alterTableRename

335alterTableRename

198 :: (KnownSymbol table0, KnownSymbol table1)

336 :: (KnownSymbol table0, KnownSymbol table1)

199− => Alias table0

337+ => Alias table0 -- ^ table to rename

200− -> Alias table1

338+ -> Alias table1 -- ^ what to rename it

201 -> Definition schema (Rename table0 table1 schema)

339 -> Definition schema (Rename table0 table1 schema)

202alterTableRename table0 table1 = UnsafeDefinition $

340alterTableRename table0 table1 = UnsafeDefinition $

203 "ALTER TABLE" <+> renderAlias table0

341 "ALTER TABLE" <+> renderAlias table0

204 <+> "RENAME TO" <+> renderAlias table1 <> ";"

342 <+> "RENAME TO" <+> renderAlias table1 <> ";"

205

343

206−newtype AlterTable

344+-- | An `alterTableAddConstraint` adds a table constraint.

345+--

346+-- >>> :{

347+-- let

348+-- definition :: Definition

349+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]

350+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]

351+-- definition = alterTableAddConstraint #tab (check (#col .> 0))

352+-- in renderDefinition definition

353+-- :}

354+-- "ALTER TABLE tab ADD CHECK ((col > 0));"

355+alterTableAddConstraint

356+ :: HasTable table schema columns

357+ => Alias table -- ^ table to constrain

358+ -> TableConstraint schema columns -- ^ what constraint to add

359+ -> Definition schema schema

360+alterTableAddConstraint table constraint = UnsafeDefinition $

361+ "ALTER TABLE" <+> renderAlias table

362+ <+> "ADD" <+> renderTableConstraint constraint <> ";"

363+

364+-- | An `AlterColumns` describes the alteration to perform on the columns

365+-- of a table.

366+newtype AlterColumns

207 (columns0 :: ColumnsType)

367 (columns0 :: ColumnsType)

208 (columns1 :: ColumnsType) =

368 (columns1 :: ColumnsType) =

209− UnsafeAlterTable {renderAlterTable :: ByteString}

369+ UnsafeAlterColumns {renderAlterColumns :: ByteString}

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

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

211

371

372+-- | An `addColumnDefault` adds a new `Optional` column. The new column is

373+-- initially filled with whatever default value is given.

374+--

375+-- >>> :{

376+-- let

377+-- definition :: Definition

378+-- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]

379+-- '["tab" :::

380+-- '[ "col1" ::: 'Required ('Null 'PGint4)

381+-- , "col2" ::: 'Optional ('Null 'PGtext) ]]

382+-- definition = alterTable #tab

383+-- (addColumnDefault #col2 (text & default_ "foo"))

384+-- in renderDefinition definition

385+-- :}

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

212addColumnDefault

387addColumnDefault

213 :: KnownSymbol column

388 :: KnownSymbol column

214− => Alias column

389+ => Alias column -- ^ column to add

215− -> TypeExpression ('Optional ty)

390+ -> TypeExpression ('Optional ty) -- ^ type of the new column

216− -> AlterTable columns (Create column ('Optional ty) columns)

391+ -> AlterColumns columns (Create column ('Optional ty) columns)

217−addColumnDefault column ty = UnsafeAlterTable $

392+addColumnDefault column ty = UnsafeAlterColumns $

218 "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty

393 "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty

219

394

395+-- | An `addColumnDefault` adds a new `Null` column. The new column is

396+-- initially filled with %NULL%s.

397+--

398+-- >>> :{

399+-- let

400+-- definition :: Definition

401+-- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]

402+-- '["tab" :::

403+-- '[ "col1" ::: 'Required ('Null 'PGint4)

404+-- , "col2" ::: 'Required ('Null 'PGtext) ]]

405+-- definition = alterTable #tab (addColumnNull #col2 text)

406+-- in renderDefinition definition

407+-- :}

408+-- "ALTER TABLE tab ADD COLUMN col2 text;"

220addColumnNull

409addColumnNull

221 :: KnownSymbol column

410 :: KnownSymbol column

222− => Alias column

411+ => Alias column -- ^ column to add

223− -> TypeExpression ('Required ('Null ty))

412+ -> TypeExpression ('Required ('Null ty)) -- ^ type of the new column

224− -> AlterTable columns (Create column ('Required ('Null ty)) columns)

413+ -> AlterColumns columns (Create column ('Required ('Null ty)) columns)

225−addColumnNull column ty = UnsafeAlterTable $

414+addColumnNull column ty = UnsafeAlterColumns $

226 "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty

415 "ADD COLUMN" <+> renderAlias column <+> renderTypeExpression ty

227

416

417+-- | A `dropColumn` removes a column. Whatever data was in the column

418+-- disappears. Table constraints involving the column are dropped, too.

419+-- However, if the column is referenced by a foreign key constraint of

420+-- another table, PostgreSQL will not silently drop that constraint.

421+--

422+-- >>> :{

423+-- let

424+-- definition :: Definition

425+-- '["tab" :::

426+-- '[ "col1" ::: 'Required ('Null 'PGint4)

427+-- , "col2" ::: 'Required ('Null 'PGtext) ]]

428+-- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]

429+-- definition = alterTable #tab (dropColumn #col2)

430+-- in renderDefinition definition

431+-- :}

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

228dropColumn

433dropColumn

229 :: KnownSymbol column

434 :: KnownSymbol column

230− => Alias column

435+ => Alias column -- ^ column to remove

231− -> AlterTable columns (Drop column columns)

436+ -> AlterColumns columns (Drop column columns)

232−dropColumn column = UnsafeAlterTable $

437+dropColumn column = UnsafeAlterColumns $

233 "DROP COLUMN" <+> renderAlias column

438 "DROP COLUMN" <+> renderAlias column

234

439

440+-- | Like `dropColumn` but authorizes dropping everything that depends

441+-- on the column.

442+--

443+-- >>> :{

444+-- let

445+-- definition :: Definition

446+-- '["tab" :::

447+-- '[ "col1" ::: 'Required ('Null 'PGint4)

448+-- , "col2" ::: 'Required ('Null 'PGtext) ]]

449+-- '["tab" ::: '["col1" ::: 'Required ('Null 'PGint4)]]

450+-- definition = alterTable #tab (dropColumnCascade #col2)

451+-- in renderDefinition definition

452+-- :}

453+-- "ALTER TABLE tab DROP COLUMN col2 CASCADE;"

454+dropColumnCascade

455+ :: KnownSymbol column

456+ => Alias column -- ^ column to remove

457+ -> AlterColumns columns (Drop column columns)

458+dropColumnCascade column = UnsafeAlterColumns $

459+ "DROP COLUMN" <+> renderAlias column <+> "CASCADE"

460+

461+-- | A `renameColumn` renames a column.

462+--

463+-- >>> :{

464+-- let

465+-- definition :: Definition

466+-- '["tab" ::: '["foo" ::: 'Required ('Null 'PGint4)]]

467+-- '["tab" ::: '["bar" ::: 'Required ('Null 'PGint4)]]

468+-- definition = alterTable #tab (renameColumn #foo #bar)

469+-- in renderDefinition definition

470+-- :}

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

235renameColumn

472renameColumn

236 :: (KnownSymbol column0, KnownSymbol column1)

473 :: (KnownSymbol column0, KnownSymbol column1)

237 => Alias column0

474 => Alias column0

238 -> Alias column1

475 -> Alias column1

239− -> AlterTable columns (Rename column0 column1 columns)

476+ -> AlterColumns columns (Rename column0 column1 columns)

240−renameColumn column0 column1 = UnsafeAlterTable $

477+renameColumn column0 column1 = UnsafeAlterColumns $

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

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

242

479

480+-- | An `alterColumn` alters a single column.

243alterColumn

481alterColumn

244 :: (KnownSymbol column, HasColumn column columns ty0)

482 :: (KnownSymbol column, HasColumn column columns ty0)

245− => Alias column

483+ => Alias column -- ^ column to alter

246− -> AlterColumn ty0 ty1

484+ -> AlterColumn ty0 ty1 -- ^ alteration to perform

247− -> AlterTable columns (Alter column columns ty1)

485+ -> AlterColumns columns (Alter column columns ty1)

248−alterColumn column alteration = UnsafeAlterTable $

486+alterColumn column alteration = UnsafeAlterColumns $

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

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

250

488

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

251newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) =

490newtype AlterColumn (ty0 :: ColumnType) (ty1 :: ColumnType) =

252 UnsafeAlterColumn {renderAlterColumn :: ByteString}

491 UnsafeAlterColumn {renderAlterColumn :: ByteString}

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

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

254

493

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

495+-- affect any existing rows in the table, it just changes the default for

496+-- future `insertTable` and `updateTable` commands.

497+--

498+-- >>> :{

499+-- let

500+-- definition :: Definition

501+-- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]

502+-- '["tab" ::: '["col" ::: 'Optional ('Null 'PGint4)]]

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

504+-- in renderDefinition definition

505+-- :}

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

255setDefault

507setDefault

256− :: Expression '[] 'Ungrouped '[] ('Required ty)

508+ :: Expression '[] 'Ungrouped '[] ('Required ty) -- ^ default value to set

257− -> AlterColumn ('Required ty) ('Optional ty)

509+ -> AlterColumn (optionality ty) ('Optional ty)

258setDefault expression = UnsafeAlterColumn $

510setDefault expression = UnsafeAlterColumn $

259 "SET DEFAULT" <+> renderExpression expression

511 "SET DEFAULT" <+> renderExpression expression

260

512

261−dropDefault :: AlterColumn ('Optional ty) ('Required ty)

513+-- | A `dropDefault` removes any default value for a column.

514+--

515+-- >>> :{

516+-- let

517+-- definition :: Definition

518+-- '["tab" ::: '["col" ::: 'Optional ('Null 'PGint4)]]

519+-- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]

520+-- definition = alterTable #tab (alterColumn #col dropDefault)

521+-- in renderDefinition definition

522+-- :}

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

524+dropDefault :: AlterColumn (optionality ty) ('Required ty)

262dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"

525dropDefault = UnsafeAlterColumn $ "DROP DEFAULT"

263

526

264−setNotNull

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

528+-- The constraint will be checked immediately, so the table data must satisfy

529+-- the constraint before it can be added.

530+--

531+-- >>> :{

532+-- let

533+-- definition :: Definition

534+-- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]

535+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]

536+-- definition = alterTable #tab (alterColumn #col setNotNull)

537+-- in renderDefinition definition

538+-- :}

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

265− :: AlterColumn (optionality ('Null ty)) (optionality ('NotNull ty))

540+setNotNull :: AlterColumn (optionality ('Null ty)) (optionality ('NotNull ty))

266setNotNull = UnsafeAlterColumn $ "SET NOT NULL"

541setNotNull = UnsafeAlterColumn $ "SET NOT NULL"

267

542

268−dropNotNull

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

544+--

545+-- >>> :{

546+-- let

547+-- definition :: Definition

548+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]

549+-- '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]

550+-- definition = alterTable #tab (alterColumn #col dropNotNull)

551+-- in renderDefinition definition

552+-- :}

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

269− :: AlterColumn (optionality ('NotNull ty)) (optionality ('Null ty))

554+dropNotNull :: AlterColumn (optionality ('NotNull ty)) (optionality ('Null ty))

270dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"

555dropNotNull = UnsafeAlterColumn $ "DROP NOT NULL"

271

556

272−alterType

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

273− :: TypeExpression (optionality (nullity ty1))

558+-- This will succeed only if each existing entry in the column can be

274− -> AlterColumn (optionality (nullity ty0)) (optionality (nullity ty1))

559+-- converted to the new type by an implicit cast.

560+--

561+-- >>> :{

562+-- let

563+-- definition :: Definition

564+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGint4)]]

565+-- '["tab" ::: '["col" ::: 'Required ('NotNull 'PGnumeric)]]

566+-- definition =

567+-- alterTable #tab (alterColumn #col (alterType (numeric & notNull)))

568+-- in renderDefinition definition

569+-- :}

570+-- "ALTER TABLE tab ALTER COLUMN col TYPE numeric NOT NULL;"

571+alterType :: TypeExpression ty -> AlterColumn ty0 ty1

275−alterType ty = UnsafeAlterColumn $ "TYPE " <> renderTypeExpression ty

572+alterType ty = UnsafeAlterColumn $ "TYPE" <+> renderTypeExpression ty

squeal-postgresql/src/Squeal/PostgreSQL/Expression.hs+343−108

@@ -1,3 +1,13 @@

1+{-|

2+Module: Squeal.PostgreSQL.Query

3+Description: Squeal expressions

4+Copyright: (c) Eitan Chatav, 2017

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Squeal expressions are the atoms used to build statements.

9+-}

10+

1{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

11{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

2{-# LANGUAGE

12{-# LANGUAGE

3 AllowAmbiguousTypes

13 AllowAmbiguousTypes

@@ -24,7 +34,7 @@

24#-}

34#-}

26module Squeal.PostgreSQL.Expression

36module Squeal.PostgreSQL.Expression

27− ( -- * Column Expressions

37+ ( -- * Expression

28 Expression (UnsafeExpression, renderExpression)

38 Expression (UnsafeExpression, renderExpression)

29 , HasParameter (param)

39 , HasParameter (param)

30 , HasColumn (getColumn)

40 , HasColumn (getColumn)

@@ -49,8 +59,8 @@ module Squeal.PostgreSQL.Expression

49 , unsafeFunction

59 , unsafeFunction

50 , atan2_

60 , atan2_

51 , cast

61 , cast

52− , div_

62+ , quot_

53− , mod_

63+ , rem_

54 , trunc

64 , trunc

55 , round_

65 , round_

56 , ceiling_

66 , ceiling_

@@ -83,25 +93,15 @@ module Squeal.PostgreSQL.Expression

83 , charLength

93 , charLength

84 , like

94 , like

85 -- ** Aggregation

95 -- ** Aggregation

86− , unsafeAggregate

87− , unsafeAggregateDistinct

96+ , unsafeAggregate, unsafeAggregateDistinct

88− , sum_

89− , sumDistinct

97+ , sum_, sumDistinct

90 , PGAvg (avg, avgDistinct)

98 , PGAvg (avg, avgDistinct)

91− , bitAnd

92− , bitOr

93− , boolAnd

99+ , bitAnd, bitOr, boolAnd, boolOr

94− , boolOr

100+ , bitAndDistinct, bitOrDistinct, boolAndDistinct, boolOrDistinct

95 , countStar

101 , countStar

96− , countDistinctStar

97− , count

102+ , count, countDistinct

98− , every

103+ , every, everyDistinct

99− , jsonAgg

104+ , max_, maxDistinct, min_, minDistinct

100− , jsonbAgg

101− , jsonObjectAgg

102− , jsonbObjectAgg

103− , max_

104− , min_

105 -- * Tables

106 , Table (UnsafeTable, renderTable)

107 , HasTable (getTable)

@@ -140,6 +140,7 @@ module Squeal.PostgreSQL.Expression

140 , timeWithTimeZone

141 , interval

142 , uuid

143+ , inet

143 , json

144 , json

144 , jsonb

145 , jsonb

145 , notNull

146 , notNull

@@ -233,6 +234,10 @@ instance (HasTable table tables columns, HasColumn column columns ty)

233 table ! column = UnsafeExpression $

234 table ! column = UnsafeExpression $

234 renderAlias table <> "." <> renderAlias column

235 renderAlias table <> "." <> renderAlias column

235

236

237+-- | A `Column` is a witness to a `HasColumn` constraint. It's used

238+-- in `Squeel.PostgreSQL.Definition.unique` and other

239+-- `Squeel.PostgreSQL.Definition.TableConstraint`s to witness a

240+-- subcolumns relationship.

236data Column

241data Column

237 (columns :: ColumnsType)

242 (columns :: ColumnsType)

238 (columnty :: (Symbol,ColumnType))

243 (columnty :: (Symbol,ColumnType))

@@ -245,9 +250,14 @@ deriving instance Show (Column columns columnty)

245deriving instance Eq (Column columns columnty)

250deriving instance Eq (Column columns columnty)

246deriving instance Ord (Column columns columnty)

251deriving instance Ord (Column columns columnty)

247

252

253+-- | Render a `Column`.

248renderColumn :: Column columns columnty -> ByteString

254renderColumn :: Column columns columnty -> ByteString

249renderColumn (Column column) = renderAlias column

255renderColumn (Column column) = renderAlias column

250

256

257+{- | A `GroupedBy` constraint indicates that a table qualified column is

258+a member of the auxiliary namespace created by @GROUP BY@ clauses and thus,

259+may be called in an output `Expression` without aggregating.

260+-}

251class (KnownSymbol table, KnownSymbol column)

261class (KnownSymbol table, KnownSymbol column)

252 => GroupedBy table column bys where

262 => GroupedBy table column bys where

253 getGroup1

263 getGroup1

@@ -294,6 +304,7 @@ def = UnsafeExpression "DEFAULT"

294-- "FALSE"

304-- "FALSE"

295unDef

305unDef

296 :: Expression '[] 'Ungrouped params ('Required (nullity ty))

306 :: Expression '[] 'Ungrouped params ('Required (nullity ty))

307+ -- ^ not @DEFAULT@

297 -> Expression '[] 'Ungrouped params ('Optional (nullity ty))

308 -> Expression '[] 'Ungrouped params ('Optional (nullity ty))

298unDef = UnsafeExpression . renderExpression

309unDef = UnsafeExpression . renderExpression

299

310

@@ -310,6 +321,7 @@ null_ = UnsafeExpression "NULL"

310-- "TRUE"

321-- "TRUE"

311unNull

322unNull

312 :: Expression tables grouping params (optionality ('NotNull ty))

323 :: Expression tables grouping params (optionality ('NotNull ty))

324+ -- ^ not @NULL@

313 -> Expression tables grouping params (optionality ('Null ty))

325 -> Expression tables grouping params (optionality ('Null ty))

314unNull = UnsafeExpression . renderExpression

326unNull = UnsafeExpression . renderExpression

315

327

@@ -319,7 +331,9 @@ unNull = UnsafeExpression . renderExpression

319-- "COALESCE(NULL, TRUE, FALSE)"

331-- "COALESCE(NULL, TRUE, FALSE)"

320coalesce

332coalesce

321 :: [Expression tables grouping params ('Required ('Null ty))]

333 :: [Expression tables grouping params ('Required ('Null ty))]

334+ -- ^ @NULL@s may be present

322 -> Expression tables grouping params ('Required ('NotNull ty))

335 -> Expression tables grouping params ('Required ('NotNull ty))

336+ -- ^ @NULL@ is absent

323 -> Expression tables grouping params ('Required ('NotNull ty))

337 -> Expression tables grouping params ('Required ('NotNull ty))

324coalesce nullxs notNullx = UnsafeExpression $

338coalesce nullxs notNullx = UnsafeExpression $

325 "COALESCE" <> parenthesized (commaSeparated

339 "COALESCE" <> parenthesized (commaSeparated

@@ -331,6 +345,7 @@ coalesce nullxs notNullx = UnsafeExpression $

331-- "COALESCE(NULL, TRUE)"

345-- "COALESCE(NULL, TRUE)"

332fromNull

346fromNull

333 :: Expression tables grouping params ('Required ('NotNull ty))

347 :: Expression tables grouping params ('Required ('NotNull ty))

348+ -- ^ what to convert @NULL@ to

334 -> Expression tables grouping params ('Required ('Null ty))

349 -> Expression tables grouping params ('Required ('Null ty))

335 -> Expression tables grouping params ('Required ('NotNull ty))

350 -> Expression tables grouping params ('Required ('NotNull ty))

336fromNull notNullx nullx = coalesce [nullx] notNullx

351fromNull notNullx nullx = coalesce [nullx] notNullx

@@ -339,6 +354,7 @@ fromNull notNullx nullx = coalesce [nullx] notNullx

339-- "NULL IS NULL"

354-- "NULL IS NULL"

340isNull

355isNull

341 :: Expression tables grouping params ('Required ('Null ty))

356 :: Expression tables grouping params ('Required ('Null ty))

357+ -- ^ possibly @NULL@

342 -> Condition tables grouping params

358 -> Condition tables grouping params

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

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

344

360

@@ -346,6 +362,7 @@ isNull x = UnsafeExpression $ renderExpression x <+> "IS NULL"

346-- "NULL IS NOT NULL"

362-- "NULL IS NOT NULL"

347isn'tNull

363isn'tNull

348 :: Expression tables grouping params ('Required ('Null ty))

364 :: Expression tables grouping params ('Required ('Null ty))

365+ -- ^ possibly @NULL@

349 -> Condition tables grouping params

366 -> Condition tables grouping params

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

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

351

368

@@ -355,21 +372,26 @@ isn'tNull x = UnsafeExpression $ renderExpression x <+> "IS NOT NULL"

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

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

356matchNull

373matchNull

357 :: Expression tables grouping params ('Required nullty)

374 :: Expression tables grouping params ('Required nullty)

375+ -- ^ what to convert @NULL@ to

358 -> ( Expression tables grouping params ('Required ('NotNull ty))

376 -> ( Expression tables grouping params ('Required ('NotNull ty))

359 -> Expression tables grouping params ('Required nullty) )

377 -> Expression tables grouping params ('Required nullty) )

378+ -- ^ function to perform when @NULL@ is absent

360 -> Expression tables grouping params ('Required ('Null ty))

379 -> Expression tables grouping params ('Required ('Null ty))

361 -> Expression tables grouping params ('Required nullty)

380 -> Expression tables grouping params ('Required nullty)

362matchNull y f x = ifThenElse (isNull x) y

381matchNull y f x = ifThenElse (isNull x) y

363 (f (UnsafeExpression (renderExpression x)))

382 (f (UnsafeExpression (renderExpression x)))

364

383

365−-- | right inverse to `fromNull`

384+-- | right inverse to `fromNull`, if its arguments are equal then

385+-- `nullIf` gives @NULL@.

366--

386--

367-- >>> :set -XTypeApplications -XDataKinds

387-- >>> :set -XTypeApplications -XDataKinds

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

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

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

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

370nullIf

390nullIf

371 :: Expression tables grouping params ('Required ('NotNull ty))

391 :: Expression tables grouping params ('Required ('NotNull ty))

392+ -- ^ @NULL@ is absent

372 -> Expression tables grouping params ('Required ('NotNull ty))

393 -> Expression tables grouping params ('Required ('NotNull ty))

394+ -- ^ @NULL@ is absent

373 -> Expression tables grouping params ('Required ('Null ty))

395 -> Expression tables grouping params ('Required ('Null ty))

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

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

375 (renderExpression x <> ", " <> renderExpression y)

397 (renderExpression x <> ", " <> renderExpression y)

@@ -378,7 +400,9 @@ nullIf x y = UnsafeExpression $ "NULL IF" <+> parenthesized

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

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

379greatest

401greatest

380 :: Expression tables grouping params ('Required nullty)

402 :: Expression tables grouping params ('Required nullty)

403+ -- ^ needs at least 1 argument

381 -> [Expression tables grouping params ('Required nullty)]

404 -> [Expression tables grouping params ('Required nullty)]

405+ -- ^ or more

382 -> Expression tables grouping params ('Required nullty)

406 -> Expression tables grouping params ('Required nullty)

383greatest x xs = UnsafeExpression $ "GREATEST("

407greatest x xs = UnsafeExpression $ "GREATEST("

384 <> commaSeparated (renderExpression <$> (x:xs)) <> ")"

408 <> commaSeparated (renderExpression <$> (x:xs)) <> ")"

@@ -387,28 +411,39 @@ greatest x xs = UnsafeExpression $ "GREATEST("

387-- "LEAST(CURRENT_TIMESTAMP, NULL)"

411-- "LEAST(CURRENT_TIMESTAMP, NULL)"

388least

412least

389 :: Expression tables grouping params ('Required nullty)

413 :: Expression tables grouping params ('Required nullty)

414+ -- ^ needs at least 1 argument

390 -> [Expression tables grouping params ('Required nullty)]

415 -> [Expression tables grouping params ('Required nullty)]

416+ -- ^ or more

391 -> Expression tables grouping params ('Required nullty)

417 -> Expression tables grouping params ('Required nullty)

392least x xs = UnsafeExpression $ "LEAST("

418least x xs = UnsafeExpression $ "LEAST("

393 <> commaSeparated (renderExpression <$> (x:xs)) <> ")"

419 <> commaSeparated (renderExpression <$> (x:xs)) <> ")"

394

420

421+-- | >>> renderExpression $ unsafeBinaryOp "OR" true false

422+-- "(TRUE OR FALSE)"

395unsafeBinaryOp

423unsafeBinaryOp

396 :: ByteString

424 :: ByteString

425+ -- ^ operator

397 -> Expression tables grouping params ('Required ty0)

426 -> Expression tables grouping params ('Required ty0)

398 -> Expression tables grouping params ('Required ty1)

427 -> Expression tables grouping params ('Required ty1)

399 -> Expression tables grouping params ('Required ty2)

428 -> Expression tables grouping params ('Required ty2)

400unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $

429unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $

401 renderExpression x <+> op <+> renderExpression y

430 renderExpression x <+> op <+> renderExpression y

402

431

432+-- | >>> renderExpression $ unsafeUnaryOp "NOT" true

433+-- "(NOT TRUE)"

403unsafeUnaryOp

434unsafeUnaryOp

404 :: ByteString

435 :: ByteString

436+ -- ^ operator

405 -> Expression tables grouping params ('Required ty0)

437 -> Expression tables grouping params ('Required ty0)

406 -> Expression tables grouping params ('Required ty1)

438 -> Expression tables grouping params ('Required ty1)

407unsafeUnaryOp op x = UnsafeExpression $ parenthesized $

439unsafeUnaryOp op x = UnsafeExpression $ parenthesized $

408 op <+> renderExpression x

440 op <+> renderExpression x

409

441

442+-- | >>> renderExpression $ unsafeFunction "f" true

443+-- "f(TRUE)"

410unsafeFunction

444unsafeFunction

411 :: ByteString

445 :: ByteString

446+ -- ^ function

412 -> Expression tables grouping params ('Required xty)

447 -> Expression tables grouping params ('Required xty)

413 -> Expression tables grouping params ('Required yty)

448 -> Expression tables grouping params ('Required yty)

414unsafeFunction fun x = UnsafeExpression $

449unsafeFunction fun x = UnsafeExpression $

@@ -453,79 +488,128 @@ instance (PGNum ty, PGFloating ty) => Floating

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

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

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

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

455

490

491+-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ atan2_ pi 2

492+-- "atan2(pi(), 2)"

456atan2_

493atan2_

457 :: PGFloating float

494 :: PGFloating float

458 => Expression tables grouping params ('Required (nullity float))

495 => Expression tables grouping params ('Required (nullity float))

496+ -- ^ numerator

459 -> Expression tables grouping params ('Required (nullity float))

497 -> Expression tables grouping params ('Required (nullity float))

498+ -- ^ denominator

460 -> Expression tables grouping params ('Required (nullity float))

499 -> Expression tables grouping params ('Required (nullity float))

461atan2_ y x = UnsafeExpression $

500atan2_ y x = UnsafeExpression $

462 "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"

501 "atan2(" <> renderExpression y <> ", " <> renderExpression x <> ")"

463

502

503+-- When a `cast` is applied to an `Expression` of a known type, it

504+-- represents a run-time type conversion. The cast will succeed only if a

505+-- suitable type conversion operation has been defined.

506+--

507+-- | >>> renderExpression $ true & cast int4

508+-- "(TRUE :: int4)"

464cast

509cast

465 :: TypeExpression ('Required ('Null ty1))

510 :: TypeExpression ('Required ('Null ty1))

511+ -- ^ type to cast as

466 -> Expression tables grouping params ('Required (nullity ty0))

512 -> Expression tables grouping params ('Required (nullity ty0))

513+ -- ^ value to convert

467 -> Expression tables grouping params ('Required (nullity ty1))

514 -> Expression tables grouping params ('Required (nullity ty1))

468cast ty x = UnsafeExpression $ parenthesized $

515cast ty x = UnsafeExpression $ parenthesized $

469 renderExpression x <+> "::" <+> renderTypeExpression ty

516 renderExpression x <+> "::" <+> renderTypeExpression ty

470

517

471−div_

518+-- | integer division, truncates the result

519+--

520+-- >>> renderExpression @_ @_ @_ @(_(_ 'PGint2)) $ 5 `quot_` 2

521+-- "(5 / 2)"

522+quot_

472 :: PGIntegral int

523 :: PGIntegral int

473 => Expression tables grouping params ('Required (nullity int))

524 => Expression tables grouping params ('Required (nullity int))

525+ -- ^ numerator

474 -> Expression tables grouping params ('Required (nullity int))

526 -> Expression tables grouping params ('Required (nullity int))

527+ -- ^ denominator

475 -> Expression tables grouping params ('Required (nullity int))

528 -> Expression tables grouping params ('Required (nullity int))

476−div_ = unsafeBinaryOp "/"

529+quot_ = unsafeBinaryOp "/"

477

530

478−mod_

531+-- | remainder upon integer division

532+--

533+-- >>> renderExpression @_ @_ @_ @(_ (_ 'PGint2)) $ 5 `rem_` 2

534+-- "(5 % 2)"

535+rem_

479 :: PGIntegral int

536 :: PGIntegral int

480 => Expression tables grouping params ('Required (nullity int))

537 => Expression tables grouping params ('Required (nullity int))

538+ -- ^ numerator

481 -> Expression tables grouping params ('Required (nullity int))

539 -> Expression tables grouping params ('Required (nullity int))

540+ -- ^ denominator

482 -> Expression tables grouping params ('Required (nullity int))

541 -> Expression tables grouping params ('Required (nullity int))

483−mod_ = unsafeBinaryOp "%"

542+rem_ = unsafeBinaryOp "%"

484

543

544+-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ trunc pi

545+-- "trunc(pi())"

485trunc

546trunc

486 :: PGFloating frac

547 :: PGFloating frac

487 => Expression tables grouping params ('Required (nullity frac))

548 => Expression tables grouping params ('Required (nullity frac))

549+ -- ^ fractional number

488 -> Expression tables grouping params ('Required (nullity frac))

550 -> Expression tables grouping params ('Required (nullity frac))

489trunc = unsafeFunction "trunc"

551trunc = unsafeFunction "trunc"

490

552

553+-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ round_ pi

554+-- "round(pi())"

491round_

555round_

492 :: PGFloating frac

556 :: PGFloating frac

493 => Expression tables grouping params ('Required (nullity frac))

557 => Expression tables grouping params ('Required (nullity frac))

558+ -- ^ fractional number

494 -> Expression tables grouping params ('Required (nullity frac))

559 -> Expression tables grouping params ('Required (nullity frac))

495round_ = unsafeFunction "round"

560round_ = unsafeFunction "round"

496

561

562+-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGfloat4)) $ ceiling_ pi

563+-- "ceiling(pi())"

497ceiling_

564ceiling_

498 :: PGFloating frac

565 :: PGFloating frac

499 => Expression tables grouping params ('Required (nullity frac))

566 => Expression tables grouping params ('Required (nullity frac))

567+ -- ^ fractional number

500 -> Expression tables grouping params ('Required (nullity frac))

568 -> Expression tables grouping params ('Required (nullity frac))

501ceiling_ = unsafeFunction "ceiling"

569ceiling_ = unsafeFunction "ceiling"

502

570

571+-- | A `Condition` is a boolean valued `Expression`. While SQL allows

572+-- conditions to have @NULL@, squeal instead chooses to disallow @NULL@,

573+-- forcing one to handle the case of @NULL@ explicitly to produce

574+-- a `Condition`.

503type Condition tables grouping params =

575type Condition tables grouping params =

504 Expression tables grouping params ('Required ('NotNull 'PGbool))

576 Expression tables grouping params ('Required ('NotNull 'PGbool))

505

577

578+-- | >>> renderExpression true

579+-- "TRUE"

506true :: Condition tables grouping params

580true :: Condition tables grouping params

507true = UnsafeExpression "TRUE"

581true = UnsafeExpression "TRUE"

508

582

583+-- | >>> renderExpression false

584+-- "FALSE"

509false :: Condition tables grouping params

585false :: Condition tables grouping params

510false = UnsafeExpression "FALSE"

586false = UnsafeExpression "FALSE"

511

587

588+-- | >>> renderExpression $ not_ true

589+-- "(NOT TRUE)"

512not_

590not_

513 :: Condition tables grouping params

591 :: Condition tables grouping params

514 -> Condition tables grouping params

592 -> Condition tables grouping params

515not_ = unsafeUnaryOp "NOT"

593not_ = unsafeUnaryOp "NOT"

516

594

595+-- | >>> renderExpression $ true .&& false

596+-- "(TRUE AND FALSE)"

517(.&&)

597(.&&)

518 :: Condition tables grouping params

598 :: Condition tables grouping params

519 -> Condition tables grouping params

599 -> Condition tables grouping params

520 -> Condition tables grouping params

600 -> Condition tables grouping params

521(.&&) = unsafeBinaryOp "AND"

601(.&&) = unsafeBinaryOp "AND"

522

602

603+-- | >>> renderExpression $ true .|| false

604+-- "(TRUE OR FALSE)"

523(.||)

605(.||)

524 :: Condition tables grouping params

606 :: Condition tables grouping params

525 -> Condition tables grouping params

607 -> Condition tables grouping params

526 -> Condition tables grouping params

608 -> Condition tables grouping params

527(.||) = unsafeBinaryOp "OR"

609(.||) = unsafeBinaryOp "OR"

528

610

611+-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGint2)) $ caseWhenThenElse [(true, 1), (false, 2)] 3

612+-- "CASE WHEN TRUE THEN 1 WHEN FALSE THEN 2 ELSE 3 END"

529caseWhenThenElse

613caseWhenThenElse

530 :: [ ( Condition tables grouping params

614 :: [ ( Condition tables grouping params

531 , Expression tables grouping params ('Required ty)

615 , Expression tables grouping params ('Required ty)

@@ -545,6 +629,8 @@ caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat

545 , " END"

629 , " END"

546 ]

630 ]

547

631

632+-- | >>> renderExpression @_ @_ @_ @(_ (_ 'PGint2)) $ ifThenElse true 1 0

633+-- "CASE WHEN TRUE THEN 1 ELSE 0 END"

548ifThenElse

634ifThenElse

549 :: Condition tables grouping params

635 :: Condition tables grouping params

550 -> Expression tables grouping params ('Required ty)

636 -> Expression tables grouping params ('Required ty)

@@ -552,64 +638,89 @@ ifThenElse

552 -> Expression tables grouping params ('Required ty)

638 -> Expression tables grouping params ('Required ty)

553ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_

639ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_

554

640

641+-- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`

642+-- will produce @NULL@s if one of their arguments is @NULL@.

643+--

644+-- >>> renderExpression $ unNull true .== null_

645+-- "(TRUE = NULL)"

555(.==)

646(.==)

556− :: Expression tables grouping params ('Required (nullity ty))

647+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs

557− -> Expression tables grouping params ('Required (nullity ty))

648+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs

558 -> Expression tables grouping params ('Required (nullity 'PGbool))

649 -> Expression tables grouping params ('Required (nullity 'PGbool))

559(.==) = unsafeBinaryOp "="

650(.==) = unsafeBinaryOp "="

560infix 4 .==

651infix 4 .==

561

652

653+-- | >>> renderExpression $ unNull true ./= null_

654+-- "(TRUE <> NULL)"

562(./=)

655(./=)

563− :: Expression tables grouping params ('Required (nullity ty))

656+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs

564− -> Expression tables grouping params ('Required (nullity ty))

657+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs

565 -> Expression tables grouping params ('Required (nullity 'PGbool))

658 -> Expression tables grouping params ('Required (nullity 'PGbool))

566(./=) = unsafeBinaryOp "<>"

659(./=) = unsafeBinaryOp "<>"

567infix 4 ./=

660infix 4 ./=

568

661

662+-- | >>> renderExpression $ unNull true .>= null_

663+-- "(TRUE >= NULL)"

569(.>=)

664(.>=)

570− :: Expression tables grouping params ('Required (nullity ty))

665+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs

571− -> Expression tables grouping params ('Required (nullity ty))

666+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs

572 -> Expression tables grouping params ('Required (nullity 'PGbool))

667 -> Expression tables grouping params ('Required (nullity 'PGbool))

573(.>=) = unsafeBinaryOp ">="

668(.>=) = unsafeBinaryOp ">="

574infix 4 .>=

669infix 4 .>=

575

670

671+-- | >>> renderExpression $ unNull true .< null_

672+-- "(TRUE < NULL)"

576(.<)

673(.<)

577− :: Expression tables grouping params ('Required (nullity ty))

674+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs

578− -> Expression tables grouping params ('Required (nullity ty))

675+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs

579 -> Expression tables grouping params ('Required (nullity 'PGbool))

676 -> Expression tables grouping params ('Required (nullity 'PGbool))

580(.<) = unsafeBinaryOp "<"

677(.<) = unsafeBinaryOp "<"

581infix 4 .<

678infix 4 .<

582

679

680+-- | >>> renderExpression $ unNull true .<= null_

681+-- "(TRUE <= NULL)"

583(.<=)

682(.<=)

584− :: Expression tables grouping params ('Required (nullity ty))

683+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs

585− -> Expression tables grouping params ('Required (nullity ty))

684+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs

586 -> Expression tables grouping params ('Required (nullity 'PGbool))

685 -> Expression tables grouping params ('Required (nullity 'PGbool))

587(.<=) = unsafeBinaryOp "<="

686(.<=) = unsafeBinaryOp "<="

588infix 4 .<=

687infix 4 .<=

589

688

689+-- | >>> renderExpression $ unNull true .> null_

690+-- "(TRUE > NULL)"

590(.>)

691(.>)

591− :: Expression tables grouping params ('Required (nullity ty))

692+ :: Expression tables grouping params ('Required (nullity ty)) -- ^ lhs

592− -> Expression tables grouping params ('Required (nullity ty))

693+ -> Expression tables grouping params ('Required (nullity ty)) -- ^ rhs

593 -> Expression tables grouping params ('Required (nullity 'PGbool))

694 -> Expression tables grouping params ('Required (nullity 'PGbool))

594(.>) = unsafeBinaryOp ">"

695(.>) = unsafeBinaryOp ">"

595infix 4 .>

696infix 4 .>

596

697

698+-- | >>> renderExpression $ currentDate

699+-- "CURRENT_DATE"

597currentDate

700currentDate

598 :: Expression tables grouping params ('Required (nullity 'PGdate))

701 :: Expression tables grouping params ('Required (nullity 'PGdate))

599currentDate = UnsafeExpression "CURRENT_DATE"

702currentDate = UnsafeExpression "CURRENT_DATE"

600

703

704+-- | >>> renderExpression $ currentTime

705+-- "CURRENT_TIME"

601currentTime

706currentTime

602 :: Expression tables grouping params ('Required (nullity 'PGtimetz))

707 :: Expression tables grouping params ('Required (nullity 'PGtimetz))

603currentTime = UnsafeExpression "CURRENT_TIME"

708currentTime = UnsafeExpression "CURRENT_TIME"

604

709

710+-- | >>> renderExpression $ currentTimestamp

711+-- "CURRENT_TIMESTAMP"

605currentTimestamp

712currentTimestamp

606 :: Expression tables grouping params ('Required (nullity 'PGtimestamptz))

713 :: Expression tables grouping params ('Required (nullity 'PGtimestamptz))

607currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"

714currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"

608

715

716+-- | >>> renderExpression $ localTime

717+-- "LOCALTIME"

609localTime

718localTime

610 :: Expression tables grouping params ('Required (nullity 'PGtime))

719 :: Expression tables grouping params ('Required (nullity 'PGtime))

611localTime = UnsafeExpression "LOCALTIME"

720localTime = UnsafeExpression "LOCALTIME"

612

721

722+-- | >>> renderExpression $ localTimestamp

723+-- "LOCALTIMESTAMP"

613localTimestamp

724localTimestamp

614 :: Expression tables grouping params ('Required (nullity 'PGtimestamp))

725 :: Expression tables grouping params ('Required (nullity 'PGtimestamp))

615localTimestamp = UnsafeExpression "LOCALTIMESTAMP"

726localTimestamp = UnsafeExpression "LOCALTIMESTAMP"

@@ -639,24 +750,44 @@ instance Monoid

639 mempty = fromString ""

750 mempty = fromString ""

640 mappend = unsafeBinaryOp "||"

751 mappend = unsafeBinaryOp "||"

641

752

753+-- | >>> renderExpression $ lower "ARRRGGG"

754+-- "lower(E'ARRRGGG')"

642lower

755lower

643 :: Expression tables grouping params ('Required (nullity 'PGtext))

756 :: Expression tables grouping params ('Required (nullity 'PGtext))

757+ -- ^ string to lower case

644 -> Expression tables grouping params ('Required (nullity 'PGtext))

758 -> Expression tables grouping params ('Required (nullity 'PGtext))

645lower = unsafeFunction "lower"

759lower = unsafeFunction "lower"

646

760

761+-- | >>> renderExpression $ upper "eeee"

762+-- "upper(E'eeee')"

647upper

763upper

648 :: Expression tables grouping params ('Required (nullity 'PGtext))

764 :: Expression tables grouping params ('Required (nullity 'PGtext))

765+ -- ^ string to upper case

649 -> Expression tables grouping params ('Required (nullity 'PGtext))

766 -> Expression tables grouping params ('Required (nullity 'PGtext))

650upper = unsafeFunction "upper"

767upper = unsafeFunction "upper"

651

768

769+-- | >>> renderExpression $ charLength "four"

770+-- "char_length(E'four')"

652charLength

771charLength

653 :: Expression tables grouping params ('Required (nullity 'PGtext))

772 :: Expression tables grouping params ('Required (nullity 'PGtext))

773+ -- ^ string to measure

654 -> Expression tables grouping params ('Required (nullity 'PGint4))

774 -> Expression tables grouping params ('Required (nullity 'PGint4))

655charLength = unsafeFunction "char_length"

775charLength = unsafeFunction "char_length"

656

776

777+-- | The `like` expression returns true if the @string@ matches

778+-- the supplied @pattern@. If @pattern@ does not contain percent signs

779+-- or underscores, then the pattern only represents the string itself;

780+-- in that case `like` acts like the equals operator. An underscore (_)

781+-- in pattern stands for (matches) any single character; a percent sign (%)

782+-- matches any sequence of zero or more characters.

783+--

784+-- >>> renderExpression $ "abc" `like` "a%"

785+-- "(E'abc' LIKE E'a%')"

657like

786like

658 :: Expression tables grouping params ('Required (nullity 'PGtext))

787 :: Expression tables grouping params ('Required (nullity 'PGtext))

788+ -- ^ string

659 -> Expression tables grouping params ('Required (nullity 'PGtext))

789 -> Expression tables grouping params ('Required (nullity 'PGtext))

790+ -- ^ pattern

660 -> Expression tables grouping params ('Required (nullity 'PGbool))

791 -> Expression tables grouping params ('Required (nullity 'PGbool))

661like = unsafeBinaryOp "LIKE"

792like = unsafeBinaryOp "LIKE"

662

793

@@ -664,25 +795,46 @@ like = unsafeBinaryOp "LIKE"

664aggregation

795aggregation

665-----------------------------------------}

796-----------------------------------------}

666

797

798+-- | escape hatch to define aggregate functions

667−unsafeAggregate, unsafeAggregateDistinct

799+unsafeAggregate

668− :: ByteString

800+ :: ByteString -- ^ aggregate function

669 -> Expression tables 'Ungrouped params ('Required xty)

801 -> Expression tables 'Ungrouped params ('Required xty)

670 -> Expression tables ('Grouped bys) params ('Required yty)

802 -> Expression tables ('Grouped bys) params ('Required yty)

671unsafeAggregate fun x = UnsafeExpression $ mconcat

803unsafeAggregate fun x = UnsafeExpression $ mconcat

672 [fun, "(", renderExpression x, ")"]

804 [fun, "(", renderExpression x, ")"]

805+

806+-- | escape hatch to define aggregate functions over distinct values

807+unsafeAggregateDistinct

808+ :: ByteString -- ^ aggregate function

809+ -> Expression tables 'Ungrouped params ('Required xty)

810+ -> Expression tables ('Grouped bys) params ('Required yty)

673unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat

811unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat

674 [fun, "(DISTINCT ", renderExpression x, ")"]

812 [fun, "(DISTINCT ", renderExpression x, ")"]

675

813

676−sum_, sumDistinct

814+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGnumeric)]] $ sum_ #col

815+-- "sum(col)"

816+sum_

677 :: PGNum ty

817 :: PGNum ty

678 => Expression tables 'Ungrouped params ('Required (nullity ty))

818 => Expression tables 'Ungrouped params ('Required (nullity ty))

819+ -- ^ what to sum

679 -> Expression tables ('Grouped bys) params ('Required (nullity ty))

820 -> Expression tables ('Grouped bys) params ('Required (nullity ty))

680sum_ = unsafeAggregate "sum"

821sum_ = unsafeAggregate "sum"

822+

823+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGnumeric)]] $ sumDistinct #col

824+-- "sum(DISTINCT col)"

825+sumDistinct

826+ :: PGNum ty

827+ => Expression tables 'Ungrouped params ('Required (nullity ty))

828+ -- ^ what to sum

829+ -> Expression tables ('Grouped bys) params ('Required (nullity ty))

681sumDistinct = unsafeAggregateDistinct "sum"

830sumDistinct = unsafeAggregateDistinct "sum"

682

831

832+-- | A constraint for `PGType`s that you can take averages of and the resulting

833+-- `PGType`.

683class PGAvg ty avg | ty -> avg where

834class PGAvg ty avg | ty -> avg where

684 avg, avgDistinct

835 avg, avgDistinct

685 :: Expression tables 'Ungrouped params ('Required (nullity ty))

836 :: Expression tables 'Ungrouped params ('Required (nullity ty))

837+ -- ^ what to average

686 -> Expression tables ('Grouped bys) params ('Required (nullity avg))

838 -> Expression tables ('Grouped bys) params ('Required (nullity avg))

687 avg = unsafeAggregate "avg"

839 avg = unsafeAggregate "avg"

688 avgDistinct = unsafeAggregateDistinct "avg"

840 avgDistinct = unsafeAggregateDistinct "avg"

@@ -694,76 +846,141 @@ instance PGAvg 'PGfloat4 'PGfloat8

694instance PGAvg 'PGfloat8 'PGfloat8

846instance PGAvg 'PGfloat8 'PGfloat8

695instance PGAvg 'PGinterval 'PGinterval

847instance PGAvg 'PGinterval 'PGinterval

696

848

697−bitAnd, bitOr

849+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitAnd #col

850+-- "bit_and(col)"

851+bitAnd

698 :: PGIntegral int

852 :: PGIntegral int

699 => Expression tables 'Ungrouped params ('Required (nullity int))

853 => Expression tables 'Ungrouped params ('Required (nullity int))

854+ -- ^ what to aggregate

700 -> Expression tables ('Grouped bys) params ('Required (nullity int))

855 -> Expression tables ('Grouped bys) params ('Required (nullity int))

701bitAnd = unsafeAggregate "bit_and"

856bitAnd = unsafeAggregate "bit_and"

857+

858+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitOr #col

859+-- "bit_or(col)"

860+bitOr

861+ :: PGIntegral int

862+ => Expression tables 'Ungrouped params ('Required (nullity int))

863+ -- ^ what to aggregate

864+ -> Expression tables ('Grouped bys) params ('Required (nullity int))

702bitOr = unsafeAggregate "bit_or"

865bitOr = unsafeAggregate "bit_or"

703

866

704−boolAnd, boolOr

867+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitAndDistinct #col

868+-- "bit_and(DISTINCT col)"

869+bitAndDistinct

870+ :: PGIntegral int

871+ => Expression tables 'Ungrouped params ('Required (nullity int))

872+ -- ^ what to aggregate

873+ -> Expression tables ('Grouped bys) params ('Required (nullity int))

874+bitAndDistinct = unsafeAggregateDistinct "bit_and"

875+

876+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGint4)]] $ bitOrDistinct #col

877+-- "bit_or(DISTINCT col)"

878+bitOrDistinct

879+ :: PGIntegral int

880+ => Expression tables 'Ungrouped params ('Required (nullity int))

881+ -- ^ what to aggregate

882+ -> Expression tables ('Grouped bys) params ('Required (nullity int))

883+bitOrDistinct = unsafeAggregateDistinct "bit_or"

884+

885+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolAnd #col

886+-- "bool_and(col)"

887+boolAnd

705 :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))

888 :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))

889+ -- ^ what to aggregate

706 -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))

890 -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))

707boolAnd = unsafeAggregate "bool_and"

891boolAnd = unsafeAggregate "bool_and"

892+

893+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolOr #col

894+-- "bool_or(col)"

895+boolOr

896+ :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))

897+ -- ^ what to aggregate

898+ -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))

708boolOr = unsafeAggregate "bool_or"

899boolOr = unsafeAggregate "bool_or"

709

900

710−countStar, countDistinctStar

901+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolAndDistinct #col

902+-- "bool_and(DISTINCT col)"

903+boolAndDistinct

904+ :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))

905+ -- ^ what to aggregate

906+ -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))

907+boolAndDistinct = unsafeAggregateDistinct "bool_and"

908+

909+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ boolOrDistinct #col

910+-- "bool_or(DISTINCT col)"

911+boolOrDistinct

912+ :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))

913+ -- ^ what to aggregate

914+ -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))

915+boolOrDistinct = unsafeAggregateDistinct "bool_or"

916+

917+-- | A special aggregation that does not require an input

918+--

919+-- >>> renderExpression countStar

920+-- "count(*)"

921+countStar

711 :: Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))

922 :: Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))

712countStar = UnsafeExpression $ "count(*)"

923countStar = UnsafeExpression $ "count(*)"

713−countDistinctStar = UnsafeExpression $ "count(DISTINCT *)"

714

924

925+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Optional _]] $ count #col

926+-- "count(col)"

715count

927count

716 :: Expression tables 'Ungrouped params ('Required ty)

928 :: Expression tables 'Ungrouped params ('Required ty)

929+ -- ^ what to count

717 -> Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))

930 -> Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))

718count = unsafeAggregate "count"

931count = unsafeAggregate "count"

719−

932+

933+-- | >>> renderExpression @'[_ ::: '["col" ::: 'Required _]] $ countDistinct #col

934+-- "count(DISTINCT col)"

935+countDistinct

936+ :: Expression tables 'Ungrouped params ('Required ty)

937+ -- ^ what to count

938+ -> Expression tables ('Grouped bys) params ('Required ('NotNull 'PGint8))

939+countDistinct = unsafeAggregateDistinct "count"

940+

941+-- | synonym for `boolAnd`

942+--

943+-- >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ every #col

944+-- "every(col)"

720every

945every

721 :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))

946 :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))

947+ -- ^ what to aggregate

722 -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))

948 -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))

723every = unsafeAggregate "every"

949every = unsafeAggregate "every"

724

950

725−jsonAgg

951+-- | synonym for `boolAndDistinct`

952+--

953+-- >>> renderExpression @'[_ ::: '["col" ::: 'Required (_ 'PGbool)]] $ everyDistinct #col

954+-- "every(DISTINCT col)"

955+everyDistinct

726− :: Expression tables 'Ungrouped params ('Required ty)

956+ :: Expression tables 'Ungrouped params ('Required (nullity 'PGbool))

957+ -- ^ what to aggregate

727− -> Expression tables ('Grouped bys) params ('Required ('NotNull 'PGjson))

958+ -> Expression tables ('Grouped bys) params ('Required (nullity 'PGbool))

728−jsonAgg = unsafeAggregate "json_agg"

959+everyDistinct = unsafeAggregateDistinct "every"

729

960

730−jsonbAgg

961+-- | minimum and maximum aggregation

731− :: Expression tables 'Ungrouped params ('Required ty)

732− -> Expression tables ('Grouped bys) params ('Required ('NotNull 'PGjsonb))

733−jsonbAgg = unsafeAggregate "jsonb_agg"

734−

735−jsonObjectAgg

736− :: Expression tables 'Ungrouped params ('Required ('NotNull keyty))

737− -> Expression tables 'Ungrouped params ('Required valty)

738− -> Expression tables ('Grouped bys) params ('Required ('NotNull 'PGjson))

739−jsonObjectAgg k v = UnsafeExpression $

740− "json_object_agg(" <> renderExpression k

741− <> ", " <> renderExpression v <> ")"

742−

743−jsonbObjectAgg

744− :: Expression tables 'Ungrouped params ('Required ('NotNull keyty))

745− -> Expression tables 'Ungrouped params ('Required valty)

746− -> Expression tables ('Grouped bys) params ('Required ('NotNull 'PGjsonb))

747−jsonbObjectAgg k v = UnsafeExpression $

748− "jsonb_object_agg("

749− <> renderExpression k <> ", " <> renderExpression v <> ")"

750−

751−max_, min_

962+max_, min_, maxDistinct, minDistinct

752 :: Expression tables 'Ungrouped params ('Required (nullity ty))

963 :: Expression tables 'Ungrouped params ('Required (nullity ty))

964+ -- ^ what to aggregate

753 -> Expression tables ('Grouped bys) params ('Required (nullity ty))

965 -> Expression tables ('Grouped bys) params ('Required (nullity ty))

754max_ = unsafeAggregate "max"

966max_ = unsafeAggregate "max"

755min_ = unsafeAggregate "min"

967min_ = unsafeAggregate "min"

968+maxDistinct = unsafeAggregateDistinct "max"

969+minDistinct = unsafeAggregateDistinct "min"

756

970

757{-----------------------------------------

971{-----------------------------------------

758tables

972tables

759-----------------------------------------}

973-----------------------------------------}

760

974

975+-- | A `Table` from a schema without its alias with an `IsLabel` instance

976+-- to call a table reference by its alias.

761newtype Table

977newtype Table

762 (schema :: TablesType)

978 (schema :: TablesType)

763 (columns :: ColumnsType)

979 (columns :: ColumnsType)

764 = UnsafeTable { renderTable :: ByteString }

980 = UnsafeTable { renderTable :: ByteString }

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

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

766

982

983+-- | A `HasTable` constraint indicates a table reference.

767class KnownSymbol table => HasTable table tables columns

984class KnownSymbol table => HasTable table tables columns

768 | table tables -> columns where

985 | table tables -> columns where

769 getTable :: Alias table -> Table tables columns

986 getTable :: Alias table -> Table tables columns

@@ -782,96 +999,113 @@ instance HasTable table schema columns

782type expressions

999type expressions

783-----------------------------------------}

1000-----------------------------------------}

784

1001

1002+-- | `TypeExpression`s are used in `cast`s and `createTable` commands.

785newtype TypeExpression (ty :: ColumnType)

1003newtype TypeExpression (ty :: ColumnType)

786 = UnsafeTypeExpression { renderTypeExpression :: ByteString }

1004 = UnsafeTypeExpression { renderTypeExpression :: ByteString }

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

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

788

1006

1007+-- | logical Boolean (true/false)

789bool :: TypeExpression ('Required ('Null 'PGbool))

1008bool :: TypeExpression ('Required ('Null 'PGbool))

790bool = UnsafeTypeExpression "bool"

1009bool = UnsafeTypeExpression "bool"

1010+-- | signed two-byte integer

791−int2 :: TypeExpression ('Required ('Null 'PGint2))

1011+int2, smallint :: TypeExpression ('Required ('Null 'PGint2))

792int2 = UnsafeTypeExpression "int2"

1012int2 = UnsafeTypeExpression "int2"

793−smallint :: TypeExpression ('Required ('Null 'PGint2))

794smallint = UnsafeTypeExpression "smallint"

1013smallint = UnsafeTypeExpression "smallint"

1014+-- | signed four-byte integer

795−int4 :: TypeExpression ('Required ('Null 'PGint4))

1015+int4, int, integer :: TypeExpression ('Required ('Null 'PGint4))

796int4 = UnsafeTypeExpression "int4"

1016int4 = UnsafeTypeExpression "int4"

797−int :: TypeExpression ('Required ('Null 'PGint4))

798int = UnsafeTypeExpression "int"

1017int = UnsafeTypeExpression "int"

799−integer :: TypeExpression ('Required ('Null 'PGint4))

800integer = UnsafeTypeExpression "integer"

1018integer = UnsafeTypeExpression "integer"

1019+-- | signed eight-byte integer

801−int8 :: TypeExpression ('Required ('Null 'PGint8))

1020+int8, bigint :: TypeExpression ('Required ('Null 'PGint8))

802int8 = UnsafeTypeExpression "int8"

1021int8 = UnsafeTypeExpression "int8"

803−bigint :: TypeExpression ('Required ('Null 'PGint8))

804bigint = UnsafeTypeExpression "bigint"

1022bigint = UnsafeTypeExpression "bigint"

1023+-- | arbitrary precision numeric type

805numeric :: TypeExpression ('Required ('Null 'PGnumeric))

1024numeric :: TypeExpression ('Required ('Null 'PGnumeric))

806numeric = UnsafeTypeExpression "numeric"

1025numeric = UnsafeTypeExpression "numeric"

1026+-- | single precision floating-point number (4 bytes)

807−float4 :: TypeExpression ('Required ('Null 'PGfloat4))

1027+float4, real :: TypeExpression ('Required ('Null 'PGfloat4))

808float4 = UnsafeTypeExpression "float4"

1028float4 = UnsafeTypeExpression "float4"

809−real :: TypeExpression ('Required ('Null 'PGfloat4))

810real = UnsafeTypeExpression "real"

1029real = UnsafeTypeExpression "real"

1030+-- | double precision floating-point number (8 bytes)

811−float8 :: TypeExpression ('Required ('Null 'PGfloat8))

1031+float8, doublePrecision :: TypeExpression ('Required ('Null 'PGfloat8))

812float8 = UnsafeTypeExpression "float8"

1032float8 = UnsafeTypeExpression "float8"

813−doublePrecision :: TypeExpression ('Required ('Null 'PGfloat8))

814doublePrecision = UnsafeTypeExpression "double precision"

1033doublePrecision = UnsafeTypeExpression "double precision"

1034+-- | not a true type, but merely a notational convenience for creating

1035+-- unique identifier columns with type `'PGint2`

815−serial2 :: TypeExpression ('Optional ('NotNull 'PGint2))

1036+serial2, smallserial :: TypeExpression ('Optional ('NotNull 'PGint2))

816serial2 = UnsafeTypeExpression "serial2"

1037serial2 = UnsafeTypeExpression "serial2"

817−smallserial :: TypeExpression ('Optional ('NotNull 'PGint2))

818smallserial = UnsafeTypeExpression "smallserial"

1038smallserial = UnsafeTypeExpression "smallserial"

1039+-- | not a true type, but merely a notational convenience for creating

1040+-- unique identifier columns with type `'PGint4`

819−serial4 :: TypeExpression ('Optional ('NotNull 'PGint4))

1041+serial4, serial :: TypeExpression ('Optional ('NotNull 'PGint4))

820serial4 = UnsafeTypeExpression "serial4"

1042serial4 = UnsafeTypeExpression "serial4"

821−serial :: TypeExpression ('Optional ('NotNull 'PGint4))

822serial = UnsafeTypeExpression "serial"

1043serial = UnsafeTypeExpression "serial"

1044+-- | not a true type, but merely a notational convenience for creating

1045+-- unique identifier columns with type `'PGint8`

823−serial8 :: TypeExpression ('Optional ('NotNull 'PGint8))

1046+serial8, bigserial :: TypeExpression ('Optional ('NotNull 'PGint8))

824serial8 = UnsafeTypeExpression "serial8"

1047serial8 = UnsafeTypeExpression "serial8"

825−bigserial :: TypeExpression ('Optional ('NotNull 'PGint8))

826bigserial = UnsafeTypeExpression "bigserial"

1048bigserial = UnsafeTypeExpression "bigserial"

1049+-- | variable-length character string

827text :: TypeExpression ('Required ('Null 'PGtext))

1050text :: TypeExpression ('Required ('Null 'PGtext))

828text = UnsafeTypeExpression "text"

1051text = UnsafeTypeExpression "text"

1052+-- | fixed-length character string

829−char

1053+char, character

830 :: (KnownNat n, 1 <= n)

1054 :: (KnownNat n, 1 <= n)

831 => proxy n

1055 => proxy n

832 -> TypeExpression ('Required ('Null ('PGchar n)))

1056 -> TypeExpression ('Required ('Null ('PGchar n)))

833char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"

1057char p = UnsafeTypeExpression $ "char(" <> renderNat p <> ")"

834−character

835− :: (KnownNat n, 1 <= n)

836− => proxy n

837− -> TypeExpression ('Required ('Null ('PGchar n)))

838character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"

1058character p = UnsafeTypeExpression $ "character(" <> renderNat p <> ")"

1059+-- | variable-length character string

839−varchar

1060+varchar, characterVarying

840 :: (KnownNat n, 1 <= n)

1061 :: (KnownNat n, 1 <= n)

841 => proxy n

1062 => proxy n

842 -> TypeExpression ('Required ('Null ('PGvarchar n)))

1063 -> TypeExpression ('Required ('Null ('PGvarchar n)))

843varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"

1064varchar p = UnsafeTypeExpression $ "varchar(" <> renderNat p <> ")"

844−characterVarying

845− :: (KnownNat n, 1 <= n)

846− => proxy n

847− -> TypeExpression ('Required ('Null ('PGvarchar n)))

848characterVarying p = UnsafeTypeExpression $

1065characterVarying p = UnsafeTypeExpression $

849 "character varying(" <> renderNat p <> ")"

1066 "character varying(" <> renderNat p <> ")"

1067+-- | binary data ("byte array")

850−bytea :: TypeExpression ('Required ('Null ('PGbytea)))

1068+bytea :: TypeExpression ('Required ('Null 'PGbytea))

851bytea = UnsafeTypeExpression "bytea"

1069bytea = UnsafeTypeExpression "bytea"

1070+-- | date and time (no time zone)

852−timestamp :: TypeExpression ('Required ('Null ('PGtimestamp)))

1071+timestamp :: TypeExpression ('Required ('Null 'PGtimestamp))

853timestamp = UnsafeTypeExpression "timestamp"

1072timestamp = UnsafeTypeExpression "timestamp"

1073+-- | date and time, including time zone

854−timestampWithTimeZone :: TypeExpression ('Required ('Null ('PGtimestamptz)))

1074+timestampWithTimeZone :: TypeExpression ('Required ('Null 'PGtimestamptz))

855timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

1075timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"

1076+-- | calendar date (year, month, day)

856−date :: TypeExpression ('Required ('Null ('PGdate)))

1077+date :: TypeExpression ('Required ('Null 'PGdate))

857date = UnsafeTypeExpression "date"

1078date = UnsafeTypeExpression "date"

1079+-- | time of day (no time zone)

858−time :: TypeExpression ('Required ('Null ('PGtime)))

1080+time :: TypeExpression ('Required ('Null 'PGtime))

859time = UnsafeTypeExpression "time"

1081time = UnsafeTypeExpression "time"

1082+-- | time of day, including time zone

860−timeWithTimeZone :: TypeExpression ('Required ('Null ('PGtimetz)))

1083+timeWithTimeZone :: TypeExpression ('Required ('Null 'PGtimetz))

861timeWithTimeZone = UnsafeTypeExpression "time with time zone"

1084timeWithTimeZone = UnsafeTypeExpression "time with time zone"

1085+-- | time span

862−interval :: TypeExpression ('Required ('Null ('PGinterval)))

1086+interval :: TypeExpression ('Required ('Null 'PGinterval))

863interval = UnsafeTypeExpression "interval"

1087interval = UnsafeTypeExpression "interval"

1088+-- | universally unique identifier

864−uuid :: TypeExpression ('Required ('Null ('PGuuid)))

1089+uuid :: TypeExpression ('Required ('Null 'PGuuid))

865uuid = UnsafeTypeExpression "uuid"

1090uuid = UnsafeTypeExpression "uuid"

1091+-- | IPv4 or IPv6 host address

1092+inet :: TypeExpression ('Required ('Null 'PGinet))

1093+inet = UnsafeTypeExpression "inet"

1094+-- | textual JSON data

866−json :: TypeExpression ('Required ('Null ('PGjson)))

1095+json :: TypeExpression ('Required ('Null 'PGjson))

867json = UnsafeTypeExpression "json"

1096json = UnsafeTypeExpression "json"

1097+-- | binary JSON data, decomposed

868−jsonb :: TypeExpression ('Required ('Null ('PGjsonb)))

1098+jsonb :: TypeExpression ('Required ('Null 'PGjsonb))

869jsonb = UnsafeTypeExpression "jsonb"

1099jsonb = UnsafeTypeExpression "jsonb"

870

1100

1101+-- | used in `createTable` commands as a column constraint to ensure

1102+-- @NULL@ is not present

871notNull

1103notNull

872 :: TypeExpression (optionality ('Null ty))

1104 :: TypeExpression (optionality ('Null ty))

873 -> TypeExpression (optionality ('NotNull ty))

1105 -> TypeExpression (optionality ('NotNull ty))

874notNull ty = UnsafeTypeExpression $ renderTypeExpression ty <+> "NOT NULL"

1106notNull ty = UnsafeTypeExpression $ renderTypeExpression ty <+> "NOT NULL"

1107+

1108+-- | used in `createTable` commands as a column constraint to give a default

875default_

1109default_

876 :: Expression '[] 'Ungrouped '[] ('Required ty)

1110 :: Expression '[] 'Ungrouped '[] ('Required ty)

877 -> TypeExpression ('Required ty)

1111 -> TypeExpression ('Required ty)

@@ -879,6 +1113,7 @@ default_

879default_ x ty = UnsafeTypeExpression $

1113default_ x ty = UnsafeTypeExpression $

880 renderTypeExpression ty <+> "DEFAULT" <+> renderExpression x

1114 renderTypeExpression ty <+> "DEFAULT" <+> renderExpression x

881

1115

1116+-- | `pgtype` is a demoted version of a `PGType`

882class PGTyped (ty :: PGType) where

1117class PGTyped (ty :: PGType) where

883 pgtype :: TypeExpression ('Required ('Null ty))

1118 pgtype :: TypeExpression ('Required ('Null ty))

884instance PGTyped 'PGbool where pgtype = bool

1119instance PGTyped 'PGbool where pgtype = bool

squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+212−33

@@ -1,3 +1,13 @@

1+{-|

2+Module: Squeal.PostgreSQL.Manipulation

3+Description: Squeal data manipulation language

4+Copyright: (c) Eitan Chatav, 2017

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Squeal data manipulation language.

9+-}

10+

1{-# LANGUAGE

11{-# LANGUAGE

2 DataKinds

12 DataKinds

3 , DeriveDataTypeable

13 , DeriveDataTypeable

@@ -14,27 +24,29 @@

14#-}

24#-}

16module Squeal.PostgreSQL.Manipulation

26module Squeal.PostgreSQL.Manipulation

17− ( -- * Data Manipulation Language

27+ ( -- * Manipulation

18 Manipulation (UnsafeManipulation, renderManipulation)

28 Manipulation (UnsafeManipulation, renderManipulation)

19 , queryStatement

29 , queryStatement

30+ -- * Insert

20 , insertInto

31 , insertInto

21 , ValuesClause (Values, ValuesQuery)

32 , ValuesClause (Values, ValuesQuery)

22 , renderValuesClause

33 , renderValuesClause

23 , ReturningClause (ReturningStar, Returning)

34 , ReturningClause (ReturningStar, Returning)

24 , renderReturningClause

35 , renderReturningClause

25− , ConflictClause (Conflict, OnConflictDoNothing, OnConflictDoUpdate)

36+ , ConflictClause (OnConflictDoRaise, OnConflictDoNothing, OnConflictDoUpdate)

26 , renderConflictClause

37 , renderConflictClause

38+ -- * Update

39+ , update

27 , UpdateExpression (Same, Set)

40 , UpdateExpression (Same, Set)

28 , renderUpdateExpression

41 , renderUpdateExpression

29− , update

30 , deleteFrom

42 , deleteFrom

31 ) where

43 ) where

33import Control.DeepSeq

45import Control.DeepSeq

34import Data.ByteString

46import Data.ByteString

35import Data.Monoid

47import Data.Monoid

36−import Generics.SOP

49+import qualified Generics.SOP as SOP

38import qualified GHC.Generics as GHC

50import qualified GHC.Generics as GHC

40import Squeal.PostgreSQL.Expression

52import Squeal.PostgreSQL.Expression

@@ -42,6 +54,10 @@ import Squeal.PostgreSQL.Prettyprint

42import Squeal.PostgreSQL.Query

54import Squeal.PostgreSQL.Query

43import Squeal.PostgreSQL.Schema

55import Squeal.PostgreSQL.Schema

57+-- | A `Manipulation` is a statement which may modify data in the database,

58+-- but does not alter the schema. Examples are `insertInto`, `update` and

59+-- `deleteFrom`. A `Query` is also considered a `Manipulation` even though

60+-- it does not modify data.

45newtype Manipulation

61newtype Manipulation

46 (schema :: TablesType)

62 (schema :: TablesType)

47 (params :: [ColumnType])

63 (params :: [ColumnType])

@@ -49,6 +65,7 @@ newtype Manipulation

49 = UnsafeManipulation { renderManipulation :: ByteString }

65 = UnsafeManipulation { renderManipulation :: ByteString }

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

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

68+-- | Convert a `Query` into a `Manipulation`.

52queryStatement

69queryStatement

53 :: Query schema params columns

70 :: Query schema params columns

54 -> Manipulation schema params columns

71 -> Manipulation schema params columns

@@ -58,12 +75,114 @@ queryStatement q = UnsafeManipulation $ renderQuery q <> ";"

58INSERT statements

75INSERT statements

59-----------------------------------------}

76-----------------------------------------}

78+{- |

79+When a table is created, it contains no data. The first thing to do

80+before a database can be of much use is to insert data. Data is

81+conceptually inserted one row at a time. Of course you can also insert

82+more than one row, but there is no way to insert less than one row.

83+Even if you know only some column values, a complete row must be created.

84+

85+simple insert:

86+

87+>>> :{

88+let

89+ manipulation :: Manipulation

90+ '[ "tab" :::

91+ '[ "col1" ::: 'Required ('NotNull 'PGint4)

92+ , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[] '[]

93+ manipulation =

94+ insertInto #tab (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])

95+ OnConflictDoRaise (Returning Nil)

96+in renderManipulation manipulation

97+:}

98+"INSERT INTO tab (col1, col2) VALUES (2, 4);"

99+

100+parameterized insert:

101+

102+>>> :{

103+let

104+ manipulation :: Manipulation

105+ '[ "tab" :::

106+ '[ "col1" ::: 'Required ('NotNull 'PGint4)

107+ , "col2" ::: 'Required ('NotNull 'PGint4) ]]

108+ '[ 'Required ('NotNull 'PGint4)

109+ , 'Required ('NotNull 'PGint4) ] '[]

110+ manipulation =

111+ insertInto #tab

112+ (Values (param @1 `As` #col1 :* param @2 `As` #col2 :* Nil) [])

113+ OnConflictDoRaise (Returning Nil)

114+in renderManipulation manipulation

115+:}

116+"INSERT INTO tab (col1, col2) VALUES (($1 :: int4), ($2 :: int4));"

117+

118+returning insert:

119+

120+>>> :{

121+let

122+ manipulation :: Manipulation

123+ '[ "tab" :::

124+ '[ "col1" ::: 'Required ('NotNull 'PGint4)

125+ , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[]

126+ '["fromOnly" ::: 'Required ('NotNull 'PGint4)]

127+ manipulation =

128+ insertInto #tab (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])

129+ OnConflictDoRaise (Returning (#col1 `As` #fromOnly :* Nil))

130+in renderManipulation manipulation

131+:}

132+"INSERT INTO tab (col1, col2) VALUES (2, 4) RETURNING col1 AS fromOnly;"

133+

134+query insert:

135+

136+>>> :{

137+let

138+ manipulation :: Manipulation

139+ '[ "tab" :::

140+ '[ "col1" ::: 'Required ('NotNull 'PGint4)

141+ , "col2" ::: 'Required ('NotNull 'PGint4)

142+ ]

143+ , "other_tab" :::

144+ '[ "col1" ::: 'Required ('NotNull 'PGint4)

145+ , "col2" ::: 'Required ('NotNull 'PGint4)

146+ ]

147+ ] '[] '[]

148+ manipulation =

149+ insertInto #tab

150+ ( ValuesQuery $

151+ selectStar (from (Table (#other_tab `As` #t))) )

152+ OnConflictDoRaise (Returning Nil)

153+in renderManipulation manipulation

154+:}

155+"INSERT INTO tab SELECT * FROM other_tab AS t;"

156+

157+upsert:

158+

159+>>> :{

160+let

161+ manipulation :: Manipulation

162+ '[ "tab" :::

163+ '[ "col1" ::: 'Required ('NotNull 'PGint4)

164+ , "col2" ::: 'Required ('NotNull 'PGint4) ]]

165+ '[] '[ "sum" ::: 'Required ('NotNull 'PGint4)]

166+ manipulation =

167+ insertInto #tab

168+ (Values

169+ (2 `As` #col1 :* 4 `As` #col2 :* Nil)

170+ [6 `As` #col1 :* 8 `As` #col2 :* Nil])

171+ (OnConflictDoUpdate

172+ (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)

173+ (Just (#col1 .== #col2)))

174+ (Returning $ (#col1 + #col2) `As` #sum :* Nil)

175+in renderManipulation manipulation

176+:}

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

178+-}

61insertInto

179insertInto

62− :: (SListI columns, SListI results, HasTable table schema columns)

180+ :: (SOP.SListI columns, SOP.SListI results, HasTable table schema columns)

63− => Alias table

181+ => Alias table -- ^ table to insert into

64− -> ValuesClause schema params columns

182+ -> ValuesClause schema params columns -- ^ values to insert

65 -> ConflictClause columns params

183 -> ConflictClause columns params

184+ -- ^ what to do in case of constraint conflict

66− -> ReturningClause columns params results

185+ -> ReturningClause columns params results -- ^ results to return

67 -> Manipulation schema params results

186 -> Manipulation schema params results

68insertInto table insert conflict returning = UnsafeManipulation $

187insertInto table insert conflict returning = UnsafeManipulation $

69 "INSERT" <+> "INTO" <+> renderAlias table

188 "INSERT" <+> "INTO" <+> renderAlias table

@@ -71,6 +190,8 @@ insertInto table insert conflict returning = UnsafeManipulation $

71 <> renderConflictClause conflict

190 <> renderConflictClause conflict

72 <> renderReturningClause returning

191 <> renderReturningClause returning

192

193+-- | A `ValuesClause` lets you insert either values, free `Expression`s,

194+-- or the result of a `Query`.

74data ValuesClause

195data ValuesClause

75 (schema :: TablesType)

196 (schema :: TablesType)

76 (params :: [ColumnType])

197 (params :: [ColumnType])

@@ -78,10 +199,12 @@ data ValuesClause

78 = Values

199 = Values

79 (NP (Aliased (Expression '[] 'Ungrouped params)) columns)

200 (NP (Aliased (Expression '[] 'Ungrouped params)) columns)

80 [NP (Aliased (Expression '[] 'Ungrouped params)) columns]

201 [NP (Aliased (Expression '[] 'Ungrouped params)) columns]

202+ -- ^ at least one row of values

81 | ValuesQuery (Query schema params columns)

203 | ValuesQuery (Query schema params columns)

204

205+-- | Render a `ValuesClause`.

83renderValuesClause

206renderValuesClause

84− :: SListI columns

207+ :: SOP.SListI columns

85 => ValuesClause schema params columns

208 => ValuesClause schema params columns

86 -> ByteString

209 -> ByteString

87renderValuesClause = \case

210renderValuesClause = \case

@@ -97,6 +220,16 @@ renderValuesClause = \case

97 renderValuePart (value `As` _) = renderExpression value

220 renderValuePart (value `As` _) = renderExpression value

98 ValuesQuery q -> renderQuery q

221 ValuesQuery q -> renderQuery q

222

223+-- | A `ReturningClause` computes and return value(s) based

224+-- on each row actually inserted, updated or deleted. This is primarily

225+-- useful for obtaining values that were supplied by defaults, such as a

226+-- serial sequence number. However, any expression using the table's columns

227+-- is allowed. Only rows that were successfully inserted or updated or

228+-- deleted will be returned. For example, if a row was locked

229+-- but not updated because an `OnConflictDoUpdate` condition was not satisfied,

230+-- the row will not be returned. `ReturningStar` will return all columns

231+-- in the row. Use `Returning Nil` in the common case where no return

232+-- values are desired.

100data ReturningClause

233data ReturningClause

101 (columns :: ColumnsType)

234 (columns :: ColumnsType)

102 (params :: [ColumnType])

235 (params :: [ColumnType])

@@ -109,8 +242,9 @@ data ReturningClause

109 results

242 results

110 -> ReturningClause columns params results

243 -> ReturningClause columns params results

111

244

245+-- | Render a `ReturningClause`.

112renderReturningClause

246renderReturningClause

113− :: SListI results

247+ :: SOP.SListI results

114 => ReturningClause params columns results

248 => ReturningClause params columns results

115 -> ByteString

249 -> ByteString

116renderReturningClause = \case

250renderReturningClause = \case

@@ -119,20 +253,26 @@ renderReturningClause = \case

119 Returning results -> " RETURNING"

253 Returning results -> " RETURNING"

120 <+> renderCommaSeparated (renderAliased renderExpression) results <> ";"

254 <+> renderCommaSeparated (renderAliased renderExpression) results <> ";"

121

255

256+-- | A `ConflictClause` specifies an action to perform upon a constraint

257+-- violation. `OnConflictDoRaise` will raise an error.

258+-- `OnConflictDoNothing` simply avoids inserting a row.

259+-- `OnConflictDoUpdate` updates the existing row that conflicts with the row

260+-- proposed for insertion.

122data ConflictClause columns params where

261data ConflictClause columns params where

123− Conflict :: ConflictClause columns params

262+ OnConflictDoRaise :: ConflictClause columns params

124 OnConflictDoNothing :: ConflictClause columns params

263 OnConflictDoNothing :: ConflictClause columns params

125 OnConflictDoUpdate

264 OnConflictDoUpdate

126 :: NP (Aliased (UpdateExpression columns params)) columns

265 :: NP (Aliased (UpdateExpression columns params)) columns

127 -> Maybe (Condition '[table ::: columns] 'Ungrouped params)

266 -> Maybe (Condition '[table ::: columns] 'Ungrouped params)

128 -> ConflictClause columns params

267 -> ConflictClause columns params

129

268

269+-- | Render a `ConflictClause`.

130renderConflictClause

270renderConflictClause

131− :: SListI columns

271+ :: SOP.SListI columns

132 => ConflictClause columns params

272 => ConflictClause columns params

133 -> ByteString

273 -> ByteString

134renderConflictClause = \case

274renderConflictClause = \case

135− Conflict -> ""

275+ OnConflictDoRaise -> ""

136 OnConflictDoNothing -> " ON CONFLICT DO NOTHING"

276 OnConflictDoNothing -> " ON CONFLICT DO NOTHING"

137 OnConflictDoUpdate updates whMaybe

277 OnConflictDoUpdate updates whMaybe

138 -> " ON CONFLICT DO UPDATE SET"

278 -> " ON CONFLICT DO UPDATE SET"

@@ -145,13 +285,50 @@ renderConflictClause = \case

145UPDATE statements

285UPDATE statements

146-----------------------------------------}

286-----------------------------------------}

147

287

288+-- | An `update` command changes the values of the specified columns

289+-- in all rows that satisfy the condition.

290+--

291+-- >>> :{

292+-- let

293+-- manipulation :: Manipulation

294+-- '[ "tab" :::

295+-- '[ "col1" ::: 'Required ('NotNull 'PGint4)

296+-- , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[] '[]

297+-- manipulation =

298+-- update #tab (Set 2 `As` #col1 :* Same `As` #col2 :* Nil)

299+-- (#col1 ./= #col2) (Returning Nil)

300+-- in renderManipulation manipulation

301+-- :}

302+-- "UPDATE tab SET col1 = 2 WHERE (col1 <> col2);"

303+update

304+ :: (HasTable table schema columns, SOP.SListI columns, SOP.SListI results)

305+ => Alias table -- ^ table to update

306+ -> NP (Aliased (UpdateExpression columns params)) columns

307+ -- ^ modified values to replace old values

308+ -> Condition '[tab ::: columns] 'Ungrouped params

309+ -- ^ condition under which to perform update on a row

310+ -> ReturningClause columns params results -- ^ results to return

311+ -> Manipulation schema params results

312+update table columns wh returning = UnsafeManipulation $

313+ "UPDATE"

314+ <+> renderAlias table

315+ <+> "SET"

316+ <+> renderCommaSeparatedMaybe renderUpdateExpression columns

317+ <+> "WHERE" <+> renderExpression wh

318+ <> renderReturningClause returning

319+

320+-- | Columns to be updated are mentioned with `Set`; columns which are to

321+-- remain the same are mentioned with `Same`.

148data UpdateExpression columns params ty

322data UpdateExpression columns params ty

149 = Same

323 = Same

324+ -- ^ column to remain the same upon update

150 | Set (forall table. Expression '[table ::: columns] 'Ungrouped params ty)

325 | Set (forall table. Expression '[table ::: columns] 'Ungrouped params ty)

326+ -- ^ column to be updated

151deriving instance Show (UpdateExpression columns params ty)

327deriving instance Show (UpdateExpression columns params ty)

152deriving instance Eq (UpdateExpression columns params ty)

328deriving instance Eq (UpdateExpression columns params ty)

153deriving instance Ord (UpdateExpression columns params ty)

329deriving instance Ord (UpdateExpression columns params ty)

154

330

331+-- | Render an `UpdateExpression`.

155renderUpdateExpression

332renderUpdateExpression

156 :: Aliased (UpdateExpression params columns) column

333 :: Aliased (UpdateExpression params columns) column

157 -> Maybe ByteString

334 -> Maybe ByteString

@@ -160,30 +337,32 @@ renderUpdateExpression = \case

160 Set expression `As` column -> Just $

337 Set expression `As` column -> Just $

161 renderAlias column <+> "=" <+> renderExpression expression

338 renderAlias column <+> "=" <+> renderExpression expression

162

339

163−update

164− :: (HasTable table schema columns, SListI columns, SListI results)

165− => Alias table

166− -> NP (Aliased (UpdateExpression columns params)) columns

167− -> Condition '[tab ::: columns] 'Ungrouped params

168− -> ReturningClause columns params results

169− -> Manipulation schema params results

170−update table columns wh returning = UnsafeManipulation $

171− "UPDATE"

172− <+> renderAlias table

173− <+> "SET"

174− <+> renderCommaSeparatedMaybe renderUpdateExpression columns

175− <+> "WHERE" <+> renderExpression wh

176− <> renderReturningClause returning

177−

178{-----------------------------------------

340{-----------------------------------------

179DELETE statements

341DELETE statements

180-----------------------------------------}

342-----------------------------------------}

181

343

344+-- | Delete rows of a table.

345+--

346+-- >>> :{

347+-- let

348+-- manipulation :: Manipulation

349+-- '[ "tab" :::

350+-- '[ "col1" ::: 'Required ('NotNull 'PGint4)

351+-- , "col2" ::: 'Required ('NotNull 'PGint4) ]] '[]

352+-- '[ "col1" ::: 'Required ('NotNull 'PGint4)

353+-- , "col2" ::: 'Required ('NotNull 'PGint4) ]

354+-- manipulation = deleteFrom #tab (#col1 .== #col2) ReturningStar

355+-- in renderManipulation manipulation

356+-- :}

357+-- "DELETE FROM tab WHERE (col1 = col2) RETURNING *;"

182deleteFrom

358deleteFrom

183− :: HasTable table schema columns

359+ :: (SOP.SListI results, HasTable table schema columns)

184− => Alias table

360+ => Alias table -- ^ table to delete from

185 -> Condition '[table ::: columns] 'Ungrouped params

361 -> Condition '[table ::: columns] 'Ungrouped params

362+ -- ^ condition under which to delete a row

363+ -> ReturningClause columns params results -- ^ results to return

186− -> Manipulation schema params '[]

364+ -> Manipulation schema params results

187−deleteFrom table wh = UnsafeManipulation $

365+deleteFrom table wh returning = UnsafeManipulation $

188 "DELETE FROM" <+> renderAlias table

366 "DELETE FROM" <+> renderAlias table

189− <+> "WHERE" <+> renderExpression wh <> ";"

367+ <+> "WHERE" <+> renderExpression wh

368+ <> renderReturningClause returning

squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+227−90

@@ -1,3 +1,15 @@

1+{-|

2+Module: Squeal.PostgreSQL.PQ

3+Description: PQ monad

4+Copyright: (c) Eitan Chatav, 2017

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+`Squeal.PostgreSQL.PQ` is where Squeal statements come to actually get run by

9+`LibPQ`. It contains a `PQ` indexed monad transformer to run `Definition`s and

10+a `MonadPQ` constraint for running a `Manipulation` or `Query`.

11+-}

12+

1{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

13{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

2{-# LANGUAGE

14{-# LANGUAGE

3 DataKinds

15 DataKinds

@@ -19,7 +31,36 @@

19 , UndecidableInstances

31 , UndecidableInstances

20#-}

32#-}

22−module Squeal.PostgreSQL.PQ where

34+module Squeal.PostgreSQL.PQ

35+ ( -- * Connection

36+ Connection (unConnection)

37+ , connectdb

38+ , finish

39+ , withConnection

40+ -- * PQ

41+ , PQ (runPQ)

42+ , execPQ

43+ , pqAp

44+ , pqBind

45+ , pqThen

46+ , define

47+ , thenDefine

48+ -- * MonadPQ

49+ , MonadPQ (..)

50+ , PQRun

51+ , pqliftWith

52+ -- * Result

53+ , Result (Result, unResult)

54+ , RowNumber (RowNumber, unRowNumber)

55+ , ColumnNumber (UnsafeColumnNumber, getColumnNumber)

56+ , HasColumnNumber (columnNumber)

57+ , getValue

58+ , getRow

59+ , getRows

60+ , nextRow

61+ , firstRow

62+ , liftResult

63+ ) where

24import Control.Exception.Lifted

65import Control.Exception.Lifted

25import Control.Monad.Base

66import Control.Monad.Base

@@ -43,11 +84,52 @@ import Squeal.PostgreSQL.Manipulation

43import Squeal.PostgreSQL.Query

84import Squeal.PostgreSQL.Query

44import Squeal.PostgreSQL.Schema

85import Squeal.PostgreSQL.Schema

46−-- | A `Connection` consists of a `Database.PastgreSQL.LibPQ.Connection`

87+-- | A `Connection` consists of a `Database.PostgreSQL.LibPQ`

47−-- and a phantom `Squeal.PostgreSQL.TablesType`

88+-- `Database.PastgreSQL.LibPQ.Connection` and a phantom `TablesType`

48newtype Connection (schema :: TablesType) =

89newtype Connection (schema :: TablesType) =

49 Connection { unConnection :: LibPQ.Connection }

90 Connection { unConnection :: LibPQ.Connection }

92+{- | Makes a new connection to the database server.

93+

94+This function opens a new database connection using the parameters taken

95+from the string conninfo.

96+

97+The passed string can be empty to use all default parameters, or it can

98+contain one or more parameter settings separated by whitespace.

99+Each parameter setting is in the form keyword = value. Spaces around the equal

100+sign are optional. To write an empty value or a value containing spaces,

101+surround it with single quotes, e.g., keyword = 'a value'. Single quotes and

102+backslashes within the value must be escaped with a backslash, i.e., ' and \.

103+

104+To specify the schema you wish to connect with, use type application.

105+

106+>>> :set -XTypeApplication

107+>>> conn <- connectdb @MySchema "host=localhost port=5432 dbname=exampledb"

108+

109+Note that, for now, squeal doesn't offer any protection from connecting

110+with the wrong schema!

111+-}

112+connectdb

113+ :: forall schema io

114+ . MonadBase IO io

115+ => ByteString -- ^ conninfo

116+ -> io (Connection schema)

117+connectdb = fmap Connection . liftBase . LibPQ.connectdb

118+

119+-- | Closes the connection to the server.

120+finish :: MonadBase IO io => Connection schema -> io ()

121+finish = liftBase . LibPQ.finish . unConnection

122+

123+-- | Do `connectdb` and `finish` before and after a computation.

124+withConnection

125+ :: forall schema io x

126+ . MonadBaseControl IO io

127+ => ByteString

128+ -> (Connection schema -> io x)

129+ -> io x

130+withConnection connString = bracket (connectdb connString) finish

131+

132+

51-- | We keep track of the schema via an Atkey indexed state monad transformer,

133-- | We keep track of the schema via an Atkey indexed state monad transformer,

52-- `PQ`.

134-- `PQ`.

53newtype PQ

135newtype PQ

@@ -58,9 +140,7 @@ newtype PQ

58 PQ { runPQ :: Connection schema0 -> m (x, Connection schema1) }

140 PQ { runPQ :: Connection schema0 -> m (x, Connection schema1) }

59 deriving Functor

141 deriving Functor

142

61−evalPQ :: Functor m => PQ schema0 schema1 m x -> Connection schema0 -> m x

143+-- | Run a `PQ` and discard the result but keep the `Connection`.

62−evalPQ (PQ pq) = fmap fst . pq

63−

64execPQ

144execPQ

65 :: Functor m

145 :: Functor m

66 => PQ schema0 schema1 m x

146 => PQ schema0 schema1 m x

@@ -89,7 +169,7 @@ pqBind f (PQ x) = PQ $ \ conn -> do

89 (x', conn') <- x conn

169 (x', conn') <- x conn

90 runPQ (f x') conn'

170 runPQ (f x') conn'

171

92−-- | indexed analog of `>>`

172+-- | indexed analog of flipped `>>`

93pqThen

173pqThen

94 :: Monad m

174 :: Monad m

95 => PQ schema1 schema2 m y

175 => PQ schema1 schema2 m y

@@ -99,7 +179,7 @@ pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)

179

100-- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law

180-- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law

101--

181--

102−-- prop> then (define statement2) statement1 = define (statement2 . statement1)

182+-- prop> pqThen (define statement2) statement1 = define (statement2 . statement1)

103define

183define

104 :: MonadBase IO io

184 :: MonadBase IO io

105 => Definition schema0 schema1

185 => Definition schema0 schema1

@@ -111,41 +191,82 @@ define (UnsafeDefinition q) = PQ $ \ (Connection conn) -> do

111 "define: LibPQ.exec returned no results"

191 "define: LibPQ.exec returned no results"

112 Just result -> return (Result result, Connection conn)

192 Just result -> return (Result result, Connection conn)

113

193

114−pqThenDefine

194+-- | Chain together `define` actions.

195+thenDefine

115 :: MonadBase IO io

196 :: MonadBase IO io

116 => Definition schema1 schema2

197 => Definition schema1 schema2

117 -> PQ schema0 schema1 io x

198 -> PQ schema0 schema1 io x

118 -> PQ schema0 schema2 io (Result '[])

199 -> PQ schema0 schema2 io (Result '[])

119−pqThenDefine = pqThen . define

200+thenDefine = pqThen . define

201+

202+{- | `MonadPQ` is an `mtl` style constraint, similar to

203+`Control.Monad.State.Class.MonadState`, for using `LibPQ` to

204+

205+* `manipulateParams` runs a `Manipulation` with params from a type

206+ with a `ToParams` constraint. It calls `LibPQ.execParams` and

207+ doesn't afraid of anything.

208+

209+* `manipulate` is like `manipulateParams` for a parameter-free statement.

210+

211+* `runQueryParams` is like `manipulateParams` for query statements.

212+

213+* `traversePrepared` has the same type signature as a composition of

214+ `traverse` and `manipulateParams` but provides an optimization by

215+ preparing the statement with `LibPQ.prepare` and then traversing a

216+ `Traversable` container with `LibPQ.execPrepared`. The temporary prepared

217+ statement is then deallocated.

218+

219+* `forPrepared` is a flipped `traversePrepared`

120

220

121−-- | `MonadPQ` is an `mtl` style constraint, similar to `MonadState`.

221+* `traversePrepared_` is like `traversePrepared` but works on `Foldable`

222+ containers and returns unit.

223+

224+* `forPrepared_` is a flipped `traversePrepared_`.

225+

226+* `liftPQ` lets you lift actions from `LibPQ` that require a connection

227+ into your monad.

228+

229+To define an instance, you can minimally define only `manipulateParams`,

230+`traversePrepared`, `traversePrepared_` and `liftPQ`. Monad transformers get

231+a default instance.

232+

233+-}

122class Monad pq => MonadPQ schema pq | pq -> schema where

234class Monad pq => MonadPQ schema pq | pq -> schema where

123− -- | `manipulateParams` runs a `Manipulation` with params from a type

124− -- with a `ToParams` constraint

125 manipulateParams

235 manipulateParams

126 :: ToParams x params

236 :: ToParams x params

127− => Manipulation schema params ys -> x -> pq (Result ys)

237+ => Manipulation schema params ys

238+ -- ^ `insertInto`, `update` or `deleteFrom`

239+ -> x -> pq (Result ys)

128 default manipulateParams

240 default manipulateParams

129 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

241 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

130 => ToParams x params

242 => ToParams x params

131− => Manipulation schema params ys -> x -> pq (Result ys)

243+ => Manipulation schema params ys

244+ -- ^ `insertInto`, `update` or `deleteFrom`

245+ -> x -> pq (Result ys)

132 manipulateParams manipulation params = lift $

246 manipulateParams manipulation params = lift $

133 manipulateParams manipulation params

247 manipulateParams manipulation params

134

248

135 manipulate :: Manipulation schema '[] ys -> pq (Result ys)

249 manipulate :: Manipulation schema '[] ys -> pq (Result ys)

136 manipulate statement = manipulateParams statement ()

250 manipulate statement = manipulateParams statement ()

137

251

138− queryParams

252+ runQueryParams

139 :: ToParams x params

253 :: ToParams x params

140− => Query schema params ys -> x -> pq (Result ys)

254+ => Query schema params ys

255+ -- ^ `select` and friends

256+ -> x -> pq (Result ys)

141− queryParams = manipulateParams . queryStatement

257+ runQueryParams = manipulateParams . queryStatement

142

258

259+ runQuery

143− query :: Query schema '[] ys -> pq (Result ys)

260+ :: Query schema '[] ys

144− query q = queryParams q ()

261+ -- ^ `select` and friends

262+ -> pq (Result ys)

263+ runQuery q = runQueryParams q ()

145

264

146 traversePrepared

265 traversePrepared

147 :: (ToParams x params, Traversable list)

266 :: (ToParams x params, Traversable list)

148− => Manipulation schema params ys -> list x -> pq (list (Result ys))

267+ => Manipulation schema params ys

268+ -- ^ `insertInto`, `update` or `deleteFrom`

269+ -> list x -> pq (list (Result ys))

149 default traversePrepared

270 default traversePrepared

150 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

271 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

151 => (ToParams x params, Traversable list)

272 => (ToParams x params, Traversable list)

@@ -155,22 +276,32 @@ class Monad pq => MonadPQ schema pq | pq -> schema where

155

276

156 forPrepared

277 forPrepared

157 :: (ToParams x params, Traversable list)

278 :: (ToParams x params, Traversable list)

279+ => list x

158− => list x -> Manipulation schema params ys -> pq (list (Result ys))

280+ -> Manipulation schema params ys

281+ -- ^ `insertInto`, `update` or `deleteFrom`

282+ -> pq (list (Result ys))

159 forPrepared = flip traversePrepared

283 forPrepared = flip traversePrepared

160

284

161 traversePrepared_

285 traversePrepared_

162 :: (ToParams x params, Foldable list)

286 :: (ToParams x params, Foldable list)

163− => Manipulation schema params ys -> list x -> pq ()

287+ => Manipulation schema params ys

288+ -- ^ `insertInto`, `update` or `deleteFrom`

289+ -> list x -> pq ()

164 default traversePrepared_

290 default traversePrepared_

165 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

291 :: (MonadTrans t, MonadPQ schema pq1, pq ~ t pq1)

166 => (ToParams x params, Foldable list)

292 => (ToParams x params, Foldable list)

167− => Manipulation schema params ys -> list x -> pq ()

293+ => Manipulation schema params ys

294+ -- ^ `insertInto`, `update` or `deleteFrom`

295+ -> list x -> pq ()

168 traversePrepared_ manipulation params = lift $

296 traversePrepared_ manipulation params = lift $

169 traversePrepared_ manipulation params

297 traversePrepared_ manipulation params

170

298

171 forPrepared_

299 forPrepared_

172 :: (ToParams x params, Traversable list)

300 :: (ToParams x params, Traversable list)

301+ => list x

173− => list x -> Manipulation schema params ys -> pq ()

302+ -> Manipulation schema params ys

303+ -- ^ `insertInto`, `update` or `deleteFrom`

304+ -> pq ()

174 forPrepared_ = flip traversePrepared_

305 forPrepared_ = flip traversePrepared_

175

306

176 liftPQ :: (LibPQ.Connection -> IO a) -> pq a

307 liftPQ :: (LibPQ.Connection -> IO a) -> pq a

@@ -195,58 +326,64 @@ instance MonadBase IO io => MonadPQ schema (PQ schema schema io) where

195

326

196 traversePrepared

327 traversePrepared

197 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

328 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

198− PQ $ \ (Connection conn) -> do

329+ PQ $ \ (Connection conn) -> liftBase $ do

199 let temp = "temporary_statement"

330 let temp = "temporary_statement"

200− prepResultMaybe <- liftBase $ LibPQ.prepare conn temp q Nothing

331+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing

201 case prepResultMaybe of

332 case prepResultMaybe of

202 Nothing -> error

333 Nothing -> error

203 "traversePrepared: LibPQ.prepare returned no results"

334 "traversePrepared: LibPQ.prepare returned no results"

204− Just _prepResult -> return () -- todo: check status of prepResult

335+ Just prepResult -> do

336+ status <- LibPQ.resultStatus prepResult

337+ unless (status == LibPQ.CommandOk) . error $

338+ "traversePrepared: LibPQ.prepare status " <> show status

205 results <- for list $ \ params -> do

339 results <- for list $ \ params -> do

206 let

340 let

207 toParam' bytes = (bytes,LibPQ.Binary)

341 toParam' bytes = (bytes,LibPQ.Binary)

208 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

342 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

209− resultMaybe <- liftBase $

210− LibPQ.execPrepared conn temp params' LibPQ.Binary

343+ resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary

211 case resultMaybe of

344 case resultMaybe of

212 Nothing -> error

345 Nothing -> error

213 "traversePrepared: LibPQ.execParams returned no results"

346 "traversePrepared: LibPQ.execParams returned no results"

214 Just result -> return $ Result result

347 Just result -> return $ Result result

215− deallocResultMaybe <- liftBase $

216− LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

348+ deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

217 case deallocResultMaybe of

349 case deallocResultMaybe of

218 Nothing -> error

350 Nothing -> error

219 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

351 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

220− Just _deallocResult -> return ()

352+ Just deallocResult -> do

221− -- todo: check status of deallocResult

353+ status <- LibPQ.resultStatus deallocResult

354+ unless (status == LibPQ.CommandOk) . error $

355+ "traversePrepared: DEALLOCATE status " <> show status

222 return (results, Connection conn)

356 return (results, Connection conn)

223

357

224 traversePrepared_

358 traversePrepared_

225 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

359 (UnsafeManipulation q :: Manipulation schema xs ys) (list :: list x) =

226− PQ $ \ (Connection conn) -> do

360+ PQ $ \ (Connection conn) -> liftBase $ do

227 let temp = "temporary_statement"

361 let temp = "temporary_statement"

228− prepResultMaybe <- liftBase $ LibPQ.prepare conn temp q Nothing

362+ prepResultMaybe <- LibPQ.prepare conn temp q Nothing

229 case prepResultMaybe of

363 case prepResultMaybe of

230 Nothing -> error

364 Nothing -> error

231 "traversePrepared_: LibPQ.prepare returned no results"

365 "traversePrepared_: LibPQ.prepare returned no results"

232− Just _prepResult -> return () -- todo: check status of prepResult

366+ Just prepResult -> do

367+ status <- LibPQ.resultStatus prepResult

368+ unless (status == LibPQ.CommandOk) . error $

369+ "traversePrepared: LibPQ.prepare status " <> show status

233 for_ list $ \ params -> do

370 for_ list $ \ params -> do

234 let

371 let

235 toParam' bytes = (bytes,LibPQ.Binary)

372 toParam' bytes = (bytes,LibPQ.Binary)

236 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

373 params' = fmap (fmap toParam') (hcollapse (toParams @x @xs params))

237− resultMaybe <- liftBase $

238− LibPQ.execPrepared conn temp params' LibPQ.Binary

374+ resultMaybe <- LibPQ.execPrepared conn temp params' LibPQ.Binary

239 case resultMaybe of

375 case resultMaybe of

240 Nothing -> error

376 Nothing -> error

241 "traversePrepared_: LibPQ.execParams returned no results"

377 "traversePrepared_: LibPQ.execParams returned no results"

242 Just _result -> return ()

378 Just _result -> return ()

243− deallocResultMaybe <- liftBase $

244− LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

379+ deallocResultMaybe <- LibPQ.exec conn ("DEALLOCATE " <> temp <> ";")

245 case deallocResultMaybe of

380 case deallocResultMaybe of

246 Nothing -> error

381 Nothing -> error

247 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

382 "traversePrepared: LibPQ.exec DEALLOCATE returned no results"

248− Just _deallocResult -> return ()

383+ Just deallocResult -> do

249− -- todo: check status of deallocResult

384+ status <- LibPQ.resultStatus deallocResult

385+ unless (status == LibPQ.CommandOk) . error $

386+ "traversePrepared: DEALLOCATE status " <> show status

250 return ((), Connection conn)

387 return ((), Connection conn)

251

388

252 liftPQ pq = PQ $ \ (Connection conn) -> do

389 liftPQ pq = PQ $ \ (Connection conn) -> do

@@ -269,9 +406,11 @@ instance MonadTrans (PQ schema schema) where

269instance MonadBase b m => MonadBase b (PQ schema schema m) where

406instance MonadBase b m => MonadBase b (PQ schema schema m) where

270 liftBase = lift . liftBase

407 liftBase = lift . liftBase

271

408

409+-- | A snapshot of the state of a `PQ` computation.

272type PQRun schema =

410type PQRun schema =

273 forall m x. Monad m => PQ schema schema m x -> m (x, Connection schema)

411 forall m x. Monad m => PQ schema schema m x -> m (x, Connection schema)

274

412

413+-- | Helper function in defining `MonadBaseControl` instance for `PQ`.

275pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a

414pqliftWith :: Functor m => (PQRun schema -> m a) -> PQ schema schema m a

276pqliftWith f = PQ $ \ conn ->

415pqliftWith f = PQ $ \ conn ->

277 fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)

416 fmap (\ x -> (x, conn)) (f $ \ pq -> runPQ pq conn)

@@ -282,28 +421,22 @@ instance MonadBaseControl b m => MonadBaseControl b (PQ schema schema m) where

282 pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run

421 pqliftWith $ \ run -> liftBaseWith $ \ runInBase -> f $ runInBase . run

283 restoreM = PQ . const . restoreM

422 restoreM = PQ . const . restoreM

284

423

285−connectdb :: MonadBase IO io => ByteString -> io (Connection schema)

424+-- | Encapsulates the result of a squeal command run by @LibPQ@.

286−connectdb = fmap Connection . liftBase . LibPQ.connectdb

425+-- `Result`s are parameterized by a `ColumnsType` describing the column names

287−

426+-- and their types.

288−finish :: MonadBase IO io => Connection schema -> io ()

289−finish = liftBase . LibPQ.finish . unConnection

290−

291−withConnection

292− :: forall schema io x

293− . MonadBaseControl IO io

294− => ByteString

295− -> (Connection schema -> io x)

296− -> io x

297−withConnection connString = bracket (connectdb connString) finish

298−

299−newtype Result (xs :: ColumnsType)

427+newtype Result (columns :: ColumnsType)

300 = Result { unResult :: LibPQ.Result }

428 = Result { unResult :: LibPQ.Result }

301

429

430+-- | Just newtypes around a `CInt`

302newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }

431newtype RowNumber = RowNumber { unRowNumber :: LibPQ.Row }

303

432

433+-- | In addition to being newtypes around a `CInt`, a `ColumnNumber` is

434+-- parameterized by a `Nat`ural number and acts as an index into a row.

304−newtype ColumnNumber n cs c =

435+newtype ColumnNumber (n :: Nat) (cs :: [k]) (c :: k) =

305 UnsafeColumnNumber { getColumnNumber :: LibPQ.Column }

436 UnsafeColumnNumber { getColumnNumber :: LibPQ.Column }

306

437

438+-- | >>> getColumnNumber (columnNumber @5)

439+-- 5

307class KnownNat n => HasColumnNumber n columns column

440class KnownNat n => HasColumnNumber n columns column

308 | n columns -> column where

441 | n columns -> column where

309 columnNumber :: ColumnNumber n columns column

442 columnNumber :: ColumnNumber n columns column

@@ -314,11 +447,13 @@ instance {-# OVERLAPPABLE #-}

314 (KnownNat n, HasColumnNumber (n-1) columns column)

447 (KnownNat n, HasColumnNumber (n-1) columns column)

315 => HasColumnNumber n (column' : columns) column

448 => HasColumnNumber n (column' : columns) column

316

449

450+-- | Get a single value corresponding to a given row and column number

451+-- from a `Result`.

317getValue

452getValue

318 :: (FromColumnValue colty y, MonadBase IO io)

453 :: (FromColumnValue colty y, MonadBase IO io)

319− => RowNumber

454+ => RowNumber -- ^ row

320− -> ColumnNumber n columns colty

455+ -> ColumnNumber n columns colty -- ^ col

321− -> Result columns

456+ -> Result columns -- ^ result

322 -> io y

457 -> io y

323getValue

458getValue

324 (RowNumber r)

459 (RowNumber r)

@@ -331,47 +466,50 @@ getValue

331 <> show numRows

466 <> show numRows

332 LibPQ.getvalue result r c

467 LibPQ.getvalue result r c

333

468

469+-- | Get a row corresponding to a given row number from a `Result`.

334getRow

470getRow

335 :: (FromRow columns y, MonadBase IO io)

471 :: (FromRow columns y, MonadBase IO io)

472+ => RowNumber

473+ -- ^ row

336− => RowNumber -> Result columns -> io y

474+ -> Result columns

475+ -- ^ result

476+ -> io y

337getRow (RowNumber r) (Result result :: Result columns) = liftBase $do

477getRow (RowNumber r) (Result result :: Result columns) = liftBase $do

338 numRows <- LibPQ.ntuples result

478 numRows <- LibPQ.ntuples result

339 when (numRows < r) $ error $

479 when (numRows < r) $ error $

340 "getRow: expected at least " <> show r <> "rows but only saw "

480 "getRow: expected at least " <> show r <> "rows but only saw "

341 <> show numRows

481 <> show numRows

342 let len = fromIntegral (lengthSList (Proxy @columns))

482 let len = fromIntegral (lengthSList (Proxy @columns))

343− numCols <- LibPQ.nfields result

344− when (numCols /= len) $ error $

345− "getRow: expected at least " <> show len <> "columns but only saw "

346− <> show numCols

347 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

483 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

348 case fromList row' of

484 case fromList row' of

349 Nothing -> error "getRow: found unexpected length"

485 Nothing -> error "getRow: found unexpected length"

350 Just row -> return $ fromRow @columns row

486 Just row -> return $ fromRow @columns row

351

487

488+-- | Intended to be used for unfolding in streaming libraries, `nextRow`

489+-- takes a total number of rows (which can be found with `LibPQ.ntuples`)

490+-- and a `Result` and given a row number if it's too large returns `Nothing`,

491+-- otherwise returning the row along with the next row number.

352nextRow

492nextRow

353 :: (FromRow columns y, MonadBase IO io)

493 :: (FromRow columns y, MonadBase IO io)

494+ => RowNumber -- ^ total number of rows

495+ -> Result columns -- ^ result

496+ -> RowNumber -- ^ row number

354− => Result columns -> RowNumber -> io (Maybe (RowNumber,y))

497+ -> io (Maybe (RowNumber,y))

355−nextRow (Result result :: Result columns) (RowNumber r) = liftBase $ do

498+nextRow (RowNumber total) (Result result :: Result columns) (RowNumber r)

356− numRows <- LibPQ.ntuples result -- todo: cache this

357− if numRows < r then return Nothing else do

499+ = liftBase $ if r >= total then return Nothing else do

358 let len = fromIntegral (lengthSList (Proxy @columns))

500 let len = fromIntegral (lengthSList (Proxy @columns))

359− numCols <- LibPQ.nfields result -- todo: cache this

360− when (numCols /= len) $ error $

361− "nextRow: expected at least " <> show len <> "columns but only saw "

362− <> show numCols

363 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

501 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

364 case fromList row' of

502 case fromList row' of

365 Nothing -> error "nextRow: found unexpected length"

503 Nothing -> error "nextRow: found unexpected length"

366 Just row -> return $ Just (RowNumber (r+1), fromRow @columns row)

504 Just row -> return $ Just (RowNumber (r+1), fromRow @columns row)

367

505

506+-- | Get all rows from a `Result`.

507+getRows

368−getRows :: (FromRow columns y, MonadBase IO io) => Result columns -> io [y]

508+ :: (FromRow columns y, MonadBase IO io)

509+ => Result columns -- ^ result

510+ -> io [y]

369getRows (Result result :: Result columns) = liftBase $ do

511getRows (Result result :: Result columns) = liftBase $ do

370 let len = fromIntegral (lengthSList (Proxy @columns))

512 let len = fromIntegral (lengthSList (Proxy @columns))

371− numCols <- LibPQ.nfields result

372− when (numCols /= len) $ error $

373− "getRow: expected at least " <> show len <> "columns but only saw "

374− <> show numCols

375 numRows <- LibPQ.ntuples result

513 numRows <- LibPQ.ntuples result

376 for [0 .. numRows - 1] $ \ r -> do

514 for [0 .. numRows - 1] $ \ r -> do

377 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

515 row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

@@ -379,22 +517,21 @@ getRows (Result result :: Result columns) = liftBase $ do

379 Nothing -> error "getRows: found unexpected length"

517 Nothing -> error "getRows: found unexpected length"

380 Just row -> return $ fromRow @columns row

518 Just row -> return $ fromRow @columns row

381

519

382−getRowMaybe

520+-- | Get the first row if possible from a `Result`.

521+firstRow

383 :: (FromRow columns y, MonadBase IO io)

522 :: (FromRow columns y, MonadBase IO io)

384− => RowNumber -> Result columns -> io (Maybe y)

523+ => Result columns -- ^ result

524+ -> io (Maybe y)

385−getRowMaybe (RowNumber r) (Result result :: Result columns) = liftBase $do

525+firstRow (Result result :: Result columns) = liftBase $ do

386 numRows <- LibPQ.ntuples result

526 numRows <- LibPQ.ntuples result

387− if numRows < r then return Nothing else do

527+ if numRows <= 0 then return Nothing else do

388 let len = fromIntegral (lengthSList (Proxy @columns))

528 let len = fromIntegral (lengthSList (Proxy @columns))

389− numCols <- LibPQ.nfields result

390− when (numCols /= len) $ error $

391− "getRow: expected at least " <> show len <> "columns but only saw "

392− <> show numCols

393− row' <- traverse (LibPQ.getvalue result r) [0 .. len - 1]

529+ row' <- traverse (LibPQ.getvalue result 0) [0 .. len - 1]

394 case fromList row' of

530 case fromList row' of

395− Nothing -> error "getRow: found unexpected length"

531+ Nothing -> error "firstRow: found unexpected length"

396 Just row -> return . Just $ fromRow @columns row

532 Just row -> return . Just $ fromRow @columns row

397

533

534+-- | Lifts actions on results from `LibPQ`.

398liftResult

535liftResult

399 :: MonadBase IO io

536 :: MonadBase IO io

400 => (LibPQ.Result -> IO x)

537 => (LibPQ.Result -> IO x)

squeal-postgresql/src/Squeal/PostgreSQL/Prettyprint.hs+17

@@ -1,3 +1,13 @@

1+{-|

2+Module: Squeal.PostgreSQL.PrettyPrint

3+Description: Pretty print helper functions

4+Copyright: (c) Eitan Chatav, 2017

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Pretty print helper functions.

9+-}

10+

1{-# LANGUAGE

11{-# LANGUAGE

2 MagicHash

12 MagicHash

3 , OverloadedStrings

13 , OverloadedStrings

@@ -18,15 +28,19 @@ import GHC.TypeLits

19import qualified Data.ByteString as ByteString

29import qualified Data.ByteString as ByteString

31+-- | Parenthesize a `ByteString`.

21parenthesized :: ByteString -> ByteString

32parenthesized :: ByteString -> ByteString

22parenthesized str = "(" <> str <> ")"

33parenthesized str = "(" <> str <> ")"

35+-- | Concatenate two `ByteString`s with a space between.

24(<+>) :: ByteString -> ByteString -> ByteString

36(<+>) :: ByteString -> ByteString -> ByteString

25str1 <+> str2 = str1 <> " " <> str2

37str1 <+> str2 = str1 <> " " <> str2

39+-- | Comma separate a list of `ByteString`s.

27commaSeparated :: [ByteString] -> ByteString

40commaSeparated :: [ByteString] -> ByteString

28commaSeparated = ByteString.intercalate ", "

41commaSeparated = ByteString.intercalate ", "

43+-- | Comma separate the renderings of a heterogeneous list.

30renderCommaSeparated

44renderCommaSeparated

31 :: SListI xs

45 :: SListI xs

32 => (forall x. expression x -> ByteString)

46 => (forall x. expression x -> ByteString)

@@ -36,6 +50,8 @@ renderCommaSeparated render

36 . hcollapse

50 . hcollapse

37 . hmap (K . render)

51 . hmap (K . render)

53+-- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping

54+-- `Nothing`s.

39renderCommaSeparatedMaybe

55renderCommaSeparatedMaybe

40 :: SListI xs

56 :: SListI xs

41 => (forall x. expression x -> Maybe ByteString)

57 => (forall x. expression x -> Maybe ByteString)

@@ -46,5 +62,6 @@ renderCommaSeparatedMaybe render

46 . hcollapse

62 . hcollapse

47 . hmap (K . render)

63 . hmap (K . render)

65+-- | Render a promoted `Nat`.

49renderNat :: KnownNat n => proxy n -> ByteString

66renderNat :: KnownNat n => proxy n -> ByteString

50renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))

67renderNat (_ :: proxy n) = fromString (show (natVal' (proxy# :: Proxy# n)))

squeal-postgresql/src/Squeal/PostgreSQL/Query.hs+456−70

@@ -1,3 +1,13 @@

1+{-|

2+Module: Squeal.PostgreSQL.Query

3+Description: Squeal queries

4+Copyright: (c) Eitan Chatav, 2017

5+Maintainer: eitan@morphism.tech

6+Stability: experimental

8+Squeal queries.

9+-}

10+

1{-# LANGUAGE

11{-# LANGUAGE

2 DataKinds

12 DataKinds

3 , DeriveDataTypeable

13 , DeriveDataTypeable

@@ -26,16 +36,13 @@ module Squeal.PostgreSQL.Query

26 , intersectAll

36 , intersectAll

27 , except

37 , except

28 , exceptAll

38 , exceptAll

29− -- * SELECT queries

39+ -- * Select

30 , select

40 , select

31 , selectDistinct

41 , selectDistinct

32 , selectStar

42 , selectStar

33 , selectDistinctStar

43 , selectDistinctStar

34 , selectDotStar

44 , selectDotStar

35 , selectDistinctDotStar

45 , selectDistinctDotStar

36− -- * FROM clauses

37− , FromClause (..)

38− , renderFromClause

39 -- * Table Expressions

46 -- * Table Expressions

40 , TableExpression (..)

47 , TableExpression (..)

41 , renderTableExpression

48 , renderTableExpression

@@ -46,6 +53,9 @@ module Squeal.PostgreSQL.Query

46 , orderBy

53 , orderBy

47 , limit

54 , limit

48 , offset

55 , offset

56+ -- * From

57+ , FromClause (..)

58+ , renderFromClause

49 -- * Grouping

59 -- * Grouping

50 , By (By, By2)

60 , By (By, By2)

51 , renderBy

61 , renderBy

@@ -53,7 +63,6 @@ module Squeal.PostgreSQL.Query

53 , renderGroupByClause

63 , renderGroupByClause

54 , HavingClause (NoHaving, Having)

64 , HavingClause (NoHaving, Having)

55 , renderHavingClause

65 , renderHavingClause

56− , GroupedBy (getGroup1, getGroup2)

57 -- * Sorting

66 -- * Sorting

58 , SortExpression (..)

67 , SortExpression (..)

59 , renderSortExpression

68 , renderSortExpression

@@ -73,6 +82,184 @@ import Squeal.PostgreSQL.Expression

73import Squeal.PostgreSQL.Prettyprint

82import Squeal.PostgreSQL.Prettyprint

74import Squeal.PostgreSQL.Schema

83import Squeal.PostgreSQL.Schema

85+{- |

86+The process of retrieving or the command to retrieve data from a database

87+is called a `Query`. The `select`, `selectStar`, `selectDotStar`,

88+`selectDistinct`, `selectDistinctStar` and `selectDistinctDotStar` commands

89+are used to specify queries.

90+

91+simple query:

92+

93+>>> :{

94+let

95+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]

96+ '["col" ::: 'Required ('Null 'PGint4)]

97+ query = selectStar (from (Table (#tab `As` #t)))

98+in renderQuery query

99+:}

100+"SELECT * FROM tab AS t"

101+

102+restricted query:

103+

104+>>> :{

105+let

106+ query :: Query

107+ '[ "tab" :::

108+ '[ "col1" ::: 'Required ('NotNull 'PGint4)

109+ , "col2" ::: 'Required ('NotNull 'PGint4) ]]

110+ '[]

111+ '[ "sum" ::: 'Required ('NotNull 'PGint4)

112+ , "col1" ::: 'Required ('NotNull 'PGint4) ]

113+ query =

114+ select

115+ ((#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)

116+ ( from (Table (#tab `As` #t))

117+ & where_ (#col1 .> #col2)

118+ & where_ (#col2 .> 0) )

119+in renderQuery query

120+:}

121+"SELECT (col1 + col2) AS sum, col1 AS col1 FROM tab AS t WHERE ((col1 > col2) AND (col2 > 0))"

122+

123+subquery:

124+

125+>>> :{

126+let

127+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]

128+ '["col" ::: 'Required ('Null 'PGint4)]

129+ query =

130+ selectStar

131+ (from (Subquery (selectStar (from (Table (#tab `As` #t))) `As` #sub)))

132+in renderQuery query

133+:}

134+"SELECT * FROM (SELECT * FROM tab AS t) AS sub"

135+

136+limits and offsets:

137+

138+>>> :{

139+let

140+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]

141+ '["col" ::: 'Required ('Null 'PGint4)]

142+ query = selectStar

143+ ( from (Table (#tab `As` #t))

144+ & limit 100

145+ & offset 2

146+ & limit 50

147+ & offset 2 )

148+in renderQuery query

149+:}

150+"SELECT * FROM tab AS t LIMIT 50 OFFSET 4"

151+

152+parameterized query:

153+

154+>>> :{

155+let

156+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]]

157+ '[ 'Required ('NotNull 'PGbool)]

158+ '["col" ::: 'Required ('Null 'PGint4)]

159+ query = selectStar

160+ (from (Table (#tab `As` #t)) & where_ (param @1))

161+in renderQuery query

162+:}

163+"SELECT * FROM tab AS t WHERE ($1 :: bool)"

164+

165+aggregation query:

166+

167+>>> :{

168+let

169+ query :: Query

170+ '[ "tab" :::

171+ '[ "col1" ::: 'Required ('NotNull 'PGint4)

172+ , "col2" ::: 'Required ('NotNull 'PGint4) ]]

173+ '[]

174+ '[ "sum" ::: 'Required ('NotNull 'PGint4)

175+ , "col1" ::: 'Required ('NotNull 'PGint4) ]

176+ query =

177+ select (sum_ #col2 `As` #sum :* #col1 `As` #col1 :* Nil)

178+ ( from (Table (#tab `As` #table1))

179+ & group (By #col1 :* Nil)

180+ & having (#col1 + sum_ #col2 .> 1) )

181+in renderQuery query

182+:}

183+"SELECT sum(col2) AS sum, col1 AS col1 FROM tab AS table1 GROUP BY col1 HAVING ((col1 + sum(col2)) > 1)"

184+

185+sorted query:

186+

187+>>> :{

188+let

189+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]

190+ '["col" ::: 'Required ('Null 'PGint4)]

191+ query = selectStar

192+ (from (Table (#tab `As` #t)) & orderBy [#col & AscNullsFirst])

193+in renderQuery query

194+:}

195+"SELECT * FROM tab AS t ORDER BY col ASC NULLS FIRST"

196+

197+joins:

198+

199+>>> :set -XFlexibleContexts

200+>>> :{

201+let

202+ query :: Query

203+ '[ "orders" :::

204+ '[ "id" ::: 'Required ('NotNull 'PGint4)

205+ , "order_price" ::: 'Required ('NotNull 'PGfloat4)

206+ , "customer_id" ::: 'Required ('NotNull 'PGint4)

207+ , "shipper_id" ::: 'Required ('NotNull 'PGint4)

208+ ]

209+ , "customers" :::

210+ '[ "id" ::: 'Required ('NotNull 'PGint4)

211+ , "name" ::: 'Required ('NotNull 'PGtext)

212+ ]

213+ , "shippers" :::

214+ '[ "id" ::: 'Required ('NotNull 'PGint4)

215+ , "name" ::: 'Required ('NotNull 'PGtext)

216+ ]

217+ ]

218+ '[]

219+ '[ "order_price" ::: 'Required ('NotNull 'PGfloat4)

220+ , "customer_name" ::: 'Required ('NotNull 'PGtext)

221+ , "shipper_name" ::: 'Required ('NotNull 'PGtext)

222+ ]

223+ query = select

224+ ( #o ! #order_price `As` #order_price :*

225+ #c ! #name `As` #customer_name :*

226+ #s ! #name `As` #shipper_name :* Nil )

227+ ( from (Table (#orders `As` #o)

228+ & InnerJoin (Table (#customers `As` #c))

229+ (#o ! #customer_id .== #c ! #id)

230+ & InnerJoin (Table (#shippers `As` #s))

231+ (#o ! #shipper_id .== #s ! #id)) )

232+in renderQuery query

233+:}

234+"SELECT o.order_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)"

235+

236+self-join:

237+

238+>>> :{

239+let

240+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]

241+ '["col" ::: 'Required ('Null 'PGint4)]

242+ query = selectDotStar #t1

243+ (from (Table (#tab `As` #t1) & CrossJoin (Table (#tab `As` #t2))))

244+in renderQuery query

245+:}

246+"SELECT t1.* FROM tab AS t1 CROSS JOIN tab AS t2"

247+

248+set operations:

249+

250+>>> :{

251+let

252+ query :: Query '["tab" ::: '["col" ::: 'Required ('Null 'PGint4)]] '[]

253+ '["col" ::: 'Required ('Null 'PGint4)]

254+ query =

255+ selectStar (from (Table (#tab `As` #t)))

256+ `unionAll`

257+ selectStar (from (Table (#tab `As` #t)))

258+in renderQuery query

259+:}

260+"(SELECT * FROM tab AS t) UNION ALL (SELECT * FROM tab AS t)"

261+-}

262+

76newtype Query

263newtype Query

77 (schema :: TablesType)

264 (schema :: TablesType)

78 (params :: [ColumnType])

265 (params :: [ColumnType])

@@ -80,7 +267,9 @@ newtype Query

80 = UnsafeQuery { renderQuery :: ByteString }

267 = UnsafeQuery { renderQuery :: ByteString }

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

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

269

83−union, unionAll, intersect, intersectAll, except, exceptAll

270+-- | The results of two queries can be combined using the set operation

271+-- `union`. Duplicate rows are eliminated.

272+union

84 :: Query schema params columns

273 :: Query schema params columns

85 -> Query schema params columns

274 -> Query schema params columns

86 -> Query schema params columns

275 -> Query schema params columns

@@ -88,22 +277,57 @@ q1 `union` q2 = UnsafeQuery $

88 parenthesized (renderQuery q1)

277 parenthesized (renderQuery q1)

89 <+> "UNION"

278 <+> "UNION"

90 <+> parenthesized (renderQuery q2)

279 <+> parenthesized (renderQuery q2)

280+

281+-- | The results of two queries can be combined using the set operation

282+-- `unionAll`, the disjoint union. Duplicate rows are retained.

283+unionAll

284+ :: Query schema params columns

285+ -> Query schema params columns

286+ -> Query schema params columns

91q1 `unionAll` q2 = UnsafeQuery $

287q1 `unionAll` q2 = UnsafeQuery $

92 parenthesized (renderQuery q1)

288 parenthesized (renderQuery q1)

93 <+> "UNION" <+> "ALL"

289 <+> "UNION" <+> "ALL"

94 <+> parenthesized (renderQuery q2)

290 <+> parenthesized (renderQuery q2)

291+

292+-- | The results of two queries can be combined using the set operation

293+-- `intersect`, the intersection. Duplicate rows are eliminated.

294+intersect

295+ :: Query schema params columns

296+ -> Query schema params columns

297+ -> Query schema params columns

95q1 `intersect` q2 = UnsafeQuery $

298q1 `intersect` q2 = UnsafeQuery $

96 parenthesized (renderQuery q1)

299 parenthesized (renderQuery q1)

97 <+> "INTERSECT"

300 <+> "INTERSECT"

98 <+> parenthesized (renderQuery q2)

301 <+> parenthesized (renderQuery q2)

302+

303+-- | The results of two queries can be combined using the set operation

304+-- `intersectAll`, the intersection. Duplicate rows are retained.

305+intersectAll

306+ :: Query schema params columns

307+ -> Query schema params columns

308+ -> Query schema params columns

99q1 `intersectAll` q2 = UnsafeQuery $

309q1 `intersectAll` q2 = UnsafeQuery $

100 parenthesized (renderQuery q1)

310 parenthesized (renderQuery q1)

101 <+> "INTERSECT" <+> "ALL"

311 <+> "INTERSECT" <+> "ALL"

102 <+> parenthesized (renderQuery q2)

312 <+> parenthesized (renderQuery q2)

313+

314+-- | The results of two queries can be combined using the set operation

315+-- `except`, the set difference. Duplicate rows are eliminated.

316+except

317+ :: Query schema params columns

318+ -> Query schema params columns

319+ -> Query schema params columns

103q1 `except` q2 = UnsafeQuery $

320q1 `except` q2 = UnsafeQuery $

104 parenthesized (renderQuery q1)

321 parenthesized (renderQuery q1)

105 <+> "EXCEPT"

322 <+> "EXCEPT"

106 <+> parenthesized (renderQuery q2)

323 <+> parenthesized (renderQuery q2)

324+

325+-- | The results of two queries can be combined using the set operation

326+-- `exceptAll`, the set difference. Duplicate rows are retained.

327+exceptAll

328+ :: Query schema params columns

329+ -> Query schema params columns

330+ -> Query schema params columns

107q1 `exceptAll` q2 = UnsafeQuery $

331q1 `exceptAll` q2 = UnsafeQuery $

108 parenthesized (renderQuery q1)

332 parenthesized (renderQuery q1)

109 <+> "EXCEPT" <+> "ALL"

333 <+> "EXCEPT" <+> "ALL"

@@ -113,101 +337,91 @@ q1 `exceptAll` q2 = UnsafeQuery $

113SELECT queries

337SELECT queries

114-----------------------------------------}

338-----------------------------------------}

115

339

340+-- | the `TableExpression` in the `select` command constructs an intermediate

341+-- virtual table by possibly combining tables, views, eliminating rows,

342+-- grouping, etc. This table is finally passed on to processing by

343+-- the select list. The select list determines which columns of

344+-- the intermediate table are actually output.

116select

345select

117 :: SListI columns

346 :: SListI columns

118 => NP (Aliased (Expression tables grouping params)) (column ': columns)

347 => NP (Aliased (Expression tables grouping params)) (column ': columns)

348+ -- ^ select list

119 -> TableExpression schema params tables grouping

349 -> TableExpression schema params tables grouping

350+ -- ^ intermediate virtual table

120 -> Query schema params (column ': columns)

351 -> Query schema params (column ': columns)

121select list tabs = UnsafeQuery $

352select list tabs = UnsafeQuery $

122 "SELECT"

353 "SELECT"

123 <+> renderCommaSeparated (renderAliased renderExpression) list

354 <+> renderCommaSeparated (renderAliased renderExpression) list

124 <+> renderTableExpression tabs

355 <+> renderTableExpression tabs

125

356

357+-- | After the select list has been processed, the result table can

358+-- be subject to the elimination of duplicate rows using `selectDistinct`.

126selectDistinct

359selectDistinct

127 :: SListI columns

360 :: SListI columns

128 => NP (Aliased (Expression tables 'Ungrouped params)) (column ': columns)

361 => NP (Aliased (Expression tables 'Ungrouped params)) (column ': columns)

362+ -- ^ select list

129 -> TableExpression schema params tables 'Ungrouped

363 -> TableExpression schema params tables 'Ungrouped

364+ -- ^ intermediate virtual table

130 -> Query schema params (column ': columns)

365 -> Query schema params (column ': columns)

131selectDistinct list tabs = UnsafeQuery $

366selectDistinct list tabs = UnsafeQuery $

132 "SELECT DISTINCT"

367 "SELECT DISTINCT"

133 <+> renderCommaSeparated (renderAliased renderExpression) list

368 <+> renderCommaSeparated (renderAliased renderExpression) list

134 <+> renderTableExpression tabs

369 <+> renderTableExpression tabs

135

370

136−selectStar, selectDistinctStar

371+-- | The simplest kind of query is `selectStar` which emits all columns

372+-- that the table expression produces.

373+selectStar

137 :: HasUnique table tables columns

374 :: HasUnique table tables columns

138 => TableExpression schema params tables 'Ungrouped

375 => TableExpression schema params tables 'Ungrouped

376+ -- ^ intermediate virtual table

139 -> Query schema params columns

377 -> Query schema params columns

140selectStar tabs = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression tabs

378selectStar tabs = UnsafeQuery $ "SELECT" <+> "*" <+> renderTableExpression tabs

379+

380+-- | A `selectDistinctStar` emits all columns that the table expression

381+-- produces and eliminates duplicate rows.

382+selectDistinctStar

383+ :: HasUnique table tables columns

384+ => TableExpression schema params tables 'Ungrouped

385+ -- ^ intermediate virtual table

386+ -> Query schema params columns

141selectDistinctStar tabs = UnsafeQuery $

387selectDistinctStar tabs = UnsafeQuery $

142 "SELECT DISTINCT" <+> "*" <+> renderTableExpression tabs

388 "SELECT DISTINCT" <+> "*" <+> renderTableExpression tabs

143

389

144−selectDotStar, selectDistinctDotStar

390+-- | When working with multiple tables, it can also be useful to ask

391+-- for all the columns of a particular table, using `selectDotStar`.

392+selectDotStar

145 :: HasTable table tables columns

393 :: HasTable table tables columns

146 => Alias table

394 => Alias table

395+ -- ^ particular virtual subtable

147 -> TableExpression schema params tables 'Ungrouped

396 -> TableExpression schema params tables 'Ungrouped

397+ -- ^ intermediate virtual table

148 -> Query schema params columns

398 -> Query schema params columns

149selectDotStar table tables = UnsafeQuery $

399selectDotStar table tables = UnsafeQuery $

150 "SELECT" <+> renderAlias table <> ".*" <+> renderTableExpression tables

400 "SELECT" <+> renderAlias table <> ".*" <+> renderTableExpression tables

401+

402+-- | A `selectDistinctDotStar` asks for all the columns of a particular table,

403+-- and eliminates duplicate rows.

404+selectDistinctDotStar

405+ :: HasTable table tables columns

406+ => Alias table

407+ -- ^ particular virtual subtable

408+ -> TableExpression schema params tables 'Ungrouped

409+ -- ^ intermediate virtual table

410+ -> Query schema params columns

151selectDistinctDotStar table tables = UnsafeQuery $

411selectDistinctDotStar table tables = UnsafeQuery $

152 "SELECT DISTINCT" <+> renderAlias table <> ".*"

412 "SELECT DISTINCT" <+> renderAlias table <> ".*"

153 <+> renderTableExpression tables

413 <+> renderTableExpression tables

154

414

155−{-----------------------------------------

156−FROM clauses

157−-----------------------------------------}

158−

159−data FromClause schema params tables where

160− Table

161− :: Aliased (Table schema) table

162− -> FromClause schema params '[table]

163− Subquery

164− :: Aliased (Query schema params) table

165− -> FromClause schema params '[table]

166− CrossJoin

167− :: FromClause schema params right

168− -> FromClause schema params left

169− -> FromClause schema params (Join left right)

170− InnerJoin

171− :: FromClause schema params right

172− -> Condition (Join left right) 'Ungrouped params

173− -> FromClause schema params left

174− -> FromClause schema params (Join left right)

175− LeftOuterJoin

176− :: FromClause schema params right

177− -> Condition (Join left right) 'Ungrouped params

178− -> FromClause schema params left

179− -> FromClause schema params (Join left (NullifyTables right))

180− RightOuterJoin

181− :: FromClause schema params right

182− -> Condition (Join left right) 'Ungrouped params

183− -> FromClause schema params left

184− -> FromClause schema params (Join (NullifyTables left) right)

185− FullOuterJoin

186− :: FromClause schema params right

187− -> Condition (Join left right) 'Ungrouped params

188− -> FromClause schema params left

189− -> FromClause schema params

190− (Join (NullifyTables left) (NullifyTables right))

191−

192−renderFromClause :: FromClause schema params tables -> ByteString

193−renderFromClause = \case

194− Table table -> renderAliased renderTable table

195− Subquery selection -> renderAliased (parenthesized . renderQuery) selection

196− CrossJoin right left ->

197− renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right

198− InnerJoin right on left -> renderJoin "INNER JOIN" right on left

199− LeftOuterJoin right on left -> renderJoin "LEFT OUTER JOIN" right on left

200− RightOuterJoin right on left -> renderJoin "RIGHT OUTER JOIN" right on left

201− FullOuterJoin right on left -> renderJoin "FULL OUTER JOIN" right on left

202− where

203− renderJoin op right on left =

204− renderFromClause left <+> op <+> renderFromClause right

205− <+> "ON" <+> renderExpression on

206−

207{-----------------------------------------

415{-----------------------------------------

208Table Expressions

416Table Expressions

209-----------------------------------------}

417-----------------------------------------}

210

418

419+-- | A `TableExpression` computes a table. The table expression contains

420+-- a `fromClause` that is optionally followed by a `whereClause`,

421+-- `groupByClause`, `havingClause`, `orderByClause`, `limitClause`

422+-- and `offsetClause`s. Trivial table expressions simply refer

423+-- to a table on disk, a so-called base table, but more complex expressions

424+-- can be used to modify or combine base tables in various ways.

211data TableExpression

425data TableExpression

212 (schema :: TablesType)

426 (schema :: TablesType)

213 (params :: [ColumnType])

427 (params :: [ColumnType])

@@ -215,14 +429,47 @@ data TableExpression

215 (grouping :: Grouping)

429 (grouping :: Grouping)

216 = TableExpression

430 = TableExpression

217 { fromClause :: FromClause schema params tables

431 { fromClause :: FromClause schema params tables

432+ -- ^ A table reference that can be a table name, or a derived table such

433+ -- as a subquery, a @JOIN@ construct, or complex combinations of these.

218 , whereClause :: [Condition tables 'Ungrouped params]

434 , whereClause :: [Condition tables 'Ungrouped params]

435+ -- ^ optional search coditions, combined with `.&&`. After the processing

436+ -- of the `fromClause` is done, each row of the derived virtual table

437+ -- is checked against the search condition. If the result of the

438+ -- condition is true, the row is kept in the output table,

439+ -- otherwise it is discarded. The search condition typically references

440+ -- at least one column of the table generated in the `fromClause`;

441+ -- this is not required, but otherwise the WHERE clause will

442+ -- be fairly useless.

219 , groupByClause :: GroupByClause tables grouping

443 , groupByClause :: GroupByClause tables grouping

444+ -- ^ The `groupByClause` is used to group together those rows in a table

445+ -- that have the same values in all the columns listed. The order in which

446+ -- the columns are listed does not matter. The effect is to combine each

447+ -- set of rows having common values into one group row that represents all

448+ -- rows in the group. This is done to eliminate redundancy in the output

449+ -- and/or compute aggregates that apply to these groups.

220 , havingClause :: HavingClause tables grouping params

450 , havingClause :: HavingClause tables grouping params

451+ -- ^ If a table has been grouped using `groupBy`, but only certain groups

452+ -- are of interest, the `havingClause` can be used, much like a

453+ -- `whereClause`, to eliminate groups from the result. Expressions in the

454+ -- `havingClause` can refer both to grouped expressions and to ungrouped

455+ -- expressions (which necessarily involve an aggregate function).

221 , orderByClause :: [SortExpression tables grouping params]

456 , orderByClause :: [SortExpression tables grouping params]

457+ -- ^ The `orderByClause` is for optional sorting. When more than one

458+ -- `SortExpression` is specified, the later (right) values are used to sort

459+ -- rows that are equal according to the earlier (left) values.

222 , limitClause :: [Word64]

460 , limitClause :: [Word64]

461+ -- ^ The `limitClause` is combined with `min` to give a limit count

462+ -- if nonempty. If a limit count is given, no more than that many rows

463+ -- will be returned (but possibly fewer, if the query itself yields

464+ -- fewer rows).

223 , offsetClause :: [Word64]

465 , offsetClause :: [Word64]

466+ -- ^ The `offsetClause` is combined with `+` to give an offset count

467+ -- if nonempty. The offset count says to skip that many rows before

468+ -- beginning to return rows. The rows are skipped before the limit count

469+ -- is applied.

224 }

470 }

225

471

472+-- | Render a `TableExpression`

226renderTableExpression

473renderTableExpression

227 :: TableExpression schema params tables grouping

474 :: TableExpression schema params tables grouping

228 -> ByteString

475 -> ByteString

@@ -232,7 +479,7 @@ renderTableExpression

232 , renderWheres whs'

479 , renderWheres whs'

233 , renderGroupByClause grps'

480 , renderGroupByClause grps'

234 , renderHavingClause hvs'

481 , renderHavingClause hvs'

235− , renderSorts srts'

482+ , renderOrderByClause srts'

236 , renderLimits lims'

483 , renderLimits lims'

237 , renderOffsets offs'

484 , renderOffsets offs'

238 ]

485 ]

@@ -241,9 +488,9 @@ renderTableExpression

241 [] -> ""

488 [] -> ""

242 wh:[] -> " WHERE" <+> renderExpression wh

489 wh:[] -> " WHERE" <+> renderExpression wh

243 wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)

490 wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)

244− renderSorts = \case

491+ renderOrderByClause = \case

245 [] -> ""

492 [] -> ""

246− srts -> " SORT BY"

493+ srts -> " ORDER BY"

247 <+> commaSeparated (renderSortExpression <$> srts)

494 <+> commaSeparated (renderSortExpression <$> srts)

248 renderLimits = \case

495 renderLimits = \case

249 [] -> ""

496 [] -> ""

@@ -252,17 +499,27 @@ renderTableExpression

252 [] -> ""

499 [] -> ""

253 offs -> " OFFSET" <+> fromString (show (sum offs))

500 offs -> " OFFSET" <+> fromString (show (sum offs))

254

501

502+-- | A `from` generates a `TableExpression` from a table reference that can be

503+-- a table name, or a derived table such as a subquery, a JOIN construct,

504+-- or complex combinations of these. A `from` may be transformed by `where_`,

505+-- `group`, `having`, `orderBy`, `limit` and `offset`, using the `&` operator

506+-- to match the left-to-right sequencing of their placement in SQL.

255from

507from

256− :: FromClause schema params tables

508+ :: FromClause schema params tables -- ^ table reference

257 -> TableExpression schema params tables 'Ungrouped

509 -> TableExpression schema params tables 'Ungrouped

258from tables = TableExpression tables [] NoGroups NoHaving [] [] []

510from tables = TableExpression tables [] NoGroups NoHaving [] [] []

259

511

512+-- | A `where_` is an endomorphism of `TableExpression`s which adds a

513+-- search condition to the `whereClause`.

260where_

514where_

261 :: Condition tables 'Ungrouped params

515 :: Condition tables 'Ungrouped params

262 -> TableExpression schema params tables grouping

516 -> TableExpression schema params tables grouping

263 -> TableExpression schema params tables grouping

517 -> TableExpression schema params tables grouping

264where_ wh tables = tables {whereClause = wh : whereClause tables}

518where_ wh tables = tables {whereClause = wh : whereClause tables}

265

519

520+-- | A `group` is a transformation of `TableExpression`s which switches

521+-- its `Grouping` from `Ungrouped` to `Grouped`. Use @group Nil@ to perform

522+-- a "grand total" aggregation query.

266group

523group

267 :: SListI bys

524 :: SListI bys

268 => NP (By tables) bys

525 => NP (By tables) bys

@@ -278,6 +535,8 @@ group bys tables = TableExpression

278 , offsetClause = offsetClause tables

535 , offsetClause = offsetClause tables

279 }

536 }

280

537

538+-- | A `having` is an endomorphism of `TableExpression`s which adds a

539+-- search condition to the `havingClause`.

281having

540having

282 :: Condition tables ('Grouped bys) params

541 :: Condition tables ('Grouped bys) params

283 -> TableExpression schema params tables ('Grouped bys)

542 -> TableExpression schema params tables ('Grouped bys)

@@ -285,28 +544,134 @@ having

285having hv tables = tables

544having hv tables = tables

286 { havingClause = case havingClause tables of Having hvs -> Having (hv:hvs) }

545 { havingClause = case havingClause tables of Having hvs -> Having (hv:hvs) }

287

546

547+-- | An `orderBy` is an endomorphism of `TableExpression`s which appends an

548+-- ordering to the right of the `orderByClause`.

288orderBy

549orderBy

289 :: [SortExpression tables grouping params]

550 :: [SortExpression tables grouping params]

290 -> TableExpression schema params tables grouping

551 -> TableExpression schema params tables grouping

291 -> TableExpression schema params tables grouping

552 -> TableExpression schema params tables grouping

292orderBy srts tables = tables {orderByClause = orderByClause tables ++ srts}

553orderBy srts tables = tables {orderByClause = orderByClause tables ++ srts}

293

554

555+-- | A `limit` is an endomorphism of `TableExpression`s which adds to the

556+-- `limitClause`.

294limit

557limit

295 :: Word64

558 :: Word64

296 -> TableExpression schema params tables grouping

559 -> TableExpression schema params tables grouping

297 -> TableExpression schema params tables grouping

560 -> TableExpression schema params tables grouping

298limit lim tables = tables {limitClause = lim : limitClause tables}

561limit lim tables = tables {limitClause = lim : limitClause tables}

299

562

563+-- | An `offset` is an endomorphism of `TableExpression`s which adds to the

564+-- `offsetClause`.

300offset

565offset

301 :: Word64

566 :: Word64

302 -> TableExpression schema params tables grouping

567 -> TableExpression schema params tables grouping

303 -> TableExpression schema params tables grouping

568 -> TableExpression schema params tables grouping

304offset off tables = tables {offsetClause = off : offsetClause tables}

569offset off tables = tables {offsetClause = off : offsetClause tables}

305

570

571+{-----------------------------------------

572+FROM clauses

573+-----------------------------------------}

574+

575+{- |

576+A `FromClause` can be a table name, or a derived table such

577+as a subquery, a @JOIN@ construct, or complex combinations of these.

578+

579+* A real `Table` is a table from the schema.

580+

581+* `Subquery` derives a table from a `Query`.

582+

583+* A joined table is a table derived from two other (real or derived) tables

584+according to the rules of the particular join type. `CrossJoin`, `InnerJoin`,

585+`LeftOuterJoin`, `RightOuterJoin` and `FullOuterJoin` are available and can

586+be nested using the `&` operator to match the left-to-right sequencing of

587+their placement in SQL.

588+

589+ * @t1 & CrossJoin t2@. For every possible combination of rows from

590+ @t1@ and @t2@ (i.e., a Cartesian product), the joined table will contain

591+ a row consisting of all columns in @t1@ followed by all columns in @t2@.

592+ If the tables have @n@ and @m@ rows respectively, the joined table will

593+ have @n * m@ rows.

594+

595+ * @t1 & InnerJoin t2 on@. For each row @r1@ of @t1@, the joined

596+ table has a row for each row in @t2@ that satisfies the @on@ condition

597+ with @r1@

598+

599+ * @t1 & LeftOuterJoin t2 on@. First, an inner join is performed.

600+ Then, for each row in @t1@ that does not satisfy the @on@ condition with

601+ any row in @t2@, a joined row is added with null values in columns of @t2@.

602+ Thus, the joined table always has at least one row for each row in @t1@.

603+

604+ * @t1 & RightOuterJoin t2 on@. First, an inner join is performed.

605+ Then, for each row in @t2@ that does not satisfy the @on@ condition with

606+ any row in @t1@, a joined row is added with null values in columns of @t1@.

607+ This is the converse of a left join: the result table will always

608+ have a row for each row in @t2@.

609+

610+ * @t1 & FullOuterJoin t2 on@. First, an inner join is performed.

611+ Then, for each row in @t1@ that does not satisfy the @on@ condition with

612+ any row in @t2@, a joined row is added with null values in columns of @t2@.

613+ Also, for each row of @t2@ that does not satisfy the join condition

614+ with any row in @t1@, a joined row with null values in the columns of @t1@

615+ is added.

616+-}

617+data FromClause schema params tables where

618+ Table

619+ :: Aliased (Table schema) table

620+ -> FromClause schema params '[table]

621+ Subquery

622+ :: Aliased (Query schema params) table

623+ -> FromClause schema params '[table]

624+ CrossJoin

625+ :: FromClause schema params right

626+ -> FromClause schema params left

627+ -> FromClause schema params (Join left right)

628+ InnerJoin

629+ :: FromClause schema params right

630+ -> Condition (Join left right) 'Ungrouped params

631+ -> FromClause schema params left

632+ -> FromClause schema params (Join left right)

633+ LeftOuterJoin

634+ :: FromClause schema params right

635+ -> Condition (Join left right) 'Ungrouped params

636+ -> FromClause schema params left

637+ -> FromClause schema params (Join left (NullifyTables right))

638+ RightOuterJoin

639+ :: FromClause schema params right

640+ -> Condition (Join left right) 'Ungrouped params

641+ -> FromClause schema params left

642+ -> FromClause schema params (Join (NullifyTables left) right)

643+ FullOuterJoin

644+ :: FromClause schema params right

645+ -> Condition (Join left right) 'Ungrouped params

646+ -> FromClause schema params left

647+ -> FromClause schema params

648+ (Join (NullifyTables left) (NullifyTables right))

649+

650+-- | Renders a `FromClause`.

651+renderFromClause :: FromClause schema params tables -> ByteString

652+renderFromClause = \case

653+ Table table -> renderAliased renderTable table

654+ Subquery selection -> renderAliased (parenthesized . renderQuery) selection

655+ CrossJoin right left ->

656+ renderFromClause left <+> "CROSS JOIN" <+> renderFromClause right

657+ InnerJoin right on left -> renderJoin "INNER JOIN" right on left

658+ LeftOuterJoin right on left -> renderJoin "LEFT OUTER JOIN" right on left

659+ RightOuterJoin right on left -> renderJoin "RIGHT OUTER JOIN" right on left

660+ FullOuterJoin right on left -> renderJoin "FULL OUTER JOIN" right on left

661+ where

662+ renderJoin op right on left =

663+ renderFromClause left <+> op <+> renderFromClause right

664+ <+> "ON" <+> renderExpression on

665+

306{-----------------------------------------

666{-----------------------------------------

307Grouping

667Grouping

308-----------------------------------------}

668-----------------------------------------}

309

669

670+-- | `By`s are used in `group` to reference a list of columns which are then

671+-- used to group together those rows in a table that have the same values

672+-- in all the columns listed. @By \#col@ will reference an unambiguous

673+-- column @col@; otherwise @By2 (\#tab \! \#col)@ will reference a table

674+-- qualified column @tab.col@.

310data By

675data By

311 (tables :: TablesType)

676 (tables :: TablesType)

312 (by :: (Symbol,Symbol)) where

677 (by :: (Symbol,Symbol)) where

@@ -321,25 +686,36 @@ data By

321deriving instance Show (By tables by)

686deriving instance Show (By tables by)

322deriving instance Eq (By tables by)

687deriving instance Eq (By tables by)

323deriving instance Ord (By tables by)

688deriving instance Ord (By tables by)

324−

689+

690+-- | Renders a `By`.

325renderBy :: By tables tabcolty -> ByteString

691renderBy :: By tables tabcolty -> ByteString

326renderBy = \case

692renderBy = \case

327 By column -> renderAlias column

693 By column -> renderAlias column

328 By2 (table, column) -> renderAlias table <> "." <> renderAlias column

694 By2 (table, column) -> renderAlias table <> "." <> renderAlias column

329−

695+

696+-- | A `GroupByClause` indicates the `Grouping` of a `TableExpression`.

697+-- A `NoGroups` indicates `Ungrouped` while a `Group` indicates `Grouped`.

698+-- @NoGroups@ is distinguised from @Group Nil@ since no aggregation can be

699+-- done on @NoGroups@ while all output `Expression`s must be aggregated

700+-- in @Group Nil@.

330data GroupByClause tables grouping where

701data GroupByClause tables grouping where

331 NoGroups :: GroupByClause tables 'Ungrouped

702 NoGroups :: GroupByClause tables 'Ungrouped

332 Group

703 Group

333 :: SListI bys

704 :: SListI bys

334 => NP (By tables) bys

705 => NP (By tables) bys

335 -> GroupByClause tables ('Grouped bys)

706 -> GroupByClause tables ('Grouped bys)

336−

707+

708+-- | Renders a `GroupByClause`.

337renderGroupByClause :: GroupByClause tables grouping -> ByteString

709renderGroupByClause :: GroupByClause tables grouping -> ByteString

338renderGroupByClause = \case

710renderGroupByClause = \case

339 NoGroups -> ""

711 NoGroups -> ""

340 Group Nil -> ""

712 Group Nil -> ""

341 Group bys -> " GROUP BY" <+> renderCommaSeparated renderBy bys

713 Group bys -> " GROUP BY" <+> renderCommaSeparated renderBy bys

342−

714+

715+-- | A `HavingClause` is used to eliminate groups that are not of interest.

716+-- An `Ungrouped` `TableExpression` may only use `NoHaving` while a `Grouped`

717+-- `TableExpression` must use `Having` whose conditions are combined with

718+-- `.&&`.

343data HavingClause tables grouping params where

719data HavingClause tables grouping params where

344 NoHaving :: HavingClause tables 'Ungrouped params

720 NoHaving :: HavingClause tables 'Ungrouped params

345 Having

721 Having

@@ -348,7 +724,8 @@ data HavingClause tables grouping params where

348deriving instance Show (HavingClause tables grouping params)

724deriving instance Show (HavingClause tables grouping params)

349deriving instance Eq (HavingClause tables grouping params)

725deriving instance Eq (HavingClause tables grouping params)

350deriving instance Ord (HavingClause tables grouping params)

726deriving instance Ord (HavingClause tables grouping params)

351−

727+

728+-- | Render a `HavingClause`.

352renderHavingClause :: HavingClause tables grouping params -> ByteString

729renderHavingClause :: HavingClause tables grouping params -> ByteString

353renderHavingClause = \case

730renderHavingClause = \case

354 NoHaving -> ""

731 NoHaving -> ""

@@ -360,6 +737,14 @@ renderHavingClause = \case

360Sorting

737Sorting

361-----------------------------------------}

738-----------------------------------------}

362

739

740+-- | `SortExpression`s are used by `sortBy` to optionally sort the results

741+-- of a `Query`. `Asc` or `Desc` set the sort direction of a `NotNull` result

742+-- column to ascending or descending. Ascending order puts smaller values

743+-- first, where "smaller" is defined in terms of the `.<` operator. Similarly,

744+-- descending order is determined with the `.>` operator. `AscNullsFirst`,

745+-- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to

746+-- determine whether nulls appear before or after non-null values in the sort

747+-- ordering of a `Null` result column.

363data SortExpression tables grouping params where

748data SortExpression tables grouping params where

364 Asc

749 Asc

365 :: Expression tables grouping params ('Required ('NotNull ty))

750 :: Expression tables grouping params ('Required ('NotNull ty))

@@ -380,7 +765,8 @@ data SortExpression tables grouping params where

380 :: Expression tables grouping params ('Required ('Null ty))

765 :: Expression tables grouping params ('Required ('Null ty))

381 -> SortExpression tables grouping params

766 -> SortExpression tables grouping params

382deriving instance Show (SortExpression tables grouping params)

767deriving instance Show (SortExpression tables grouping params)

383−

768+

769+-- | Render a `SortExpression`.

384renderSortExpression :: SortExpression tables grouping params -> ByteString

770renderSortExpression :: SortExpression tables grouping params -> ByteString

385renderSortExpression = \case

771renderSortExpression = \case

386 Asc expression -> renderExpression expression <+> "ASC"

772 Asc expression -> renderExpression expression <+> "ASC"

squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+9−7

@@ -105,6 +105,7 @@ data PGType

105 | PGinet -- ^ IPv4 or IPv6 host address

106 | PGjson -- ^ textual JSON data

107 | PGjsonb -- ^ binary JSON data, decomposed

108+ | UnsafePGType Symbol -- ^ an escape hatch for unsupported PostgreSQL types

108

109

109-- | `NullityType` encodes the potential presence or definite absence of a

110-- | `NullityType` encodes the potential presence or definite absence of a

110-- @NULL@ allowing operations which are sensitive to such to be well typed.

111-- @NULL@ allowing operations which are sensitive to such to be well typed.

@@ -128,7 +129,8 @@ type ColumnsType = [(Symbol,ColumnType)]

128

129

129-- | `TablesType` is a kind synonym for a row of `ColumnsType`s.

130-- | `TablesType` is a kind synonym for a row of `ColumnsType`s.

130-- It is used as a kind for both a schema, a disjoint union of tables,

131-- It is used as a kind for both a schema, a disjoint union of tables,

131−-- and a joined table `Squeal.Query.FromClause`, a product of tables.

132+-- and a joined table `Squeal.PostgreSQL.Query.FromClause`,

133+-- a product of tables.

132type TablesType = [(Symbol,ColumnsType)]

134type TablesType = [(Symbol,ColumnsType)]

133

135

134-- | `Grouping` is an auxiliary namespace, created by

136-- | `Grouping` is an auxiliary namespace, created by

@@ -154,7 +156,7 @@ type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]

154-- `Squeal.PostgreSQL.Expression.mod_` functions.

156-- `Squeal.PostgreSQL.Expression.mod_` functions.

155type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]

157type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]

156

158

157−-- | `:::` is the promoted version of `As`, a type level pair between

159+-- | `:::` is like a promoted version of `As`, a type level pair between

158-- an alias and some type, usually a column alias and a `ColumnType` or

160-- an alias and some type, usually a column alias and a `ColumnType` or

159-- a table alias and a `ColumnsType`.

161-- a table alias and a `ColumnsType`.

160type (:::) (alias :: Symbol) (ty :: polykind) = '(alias,ty)

162type (:::) (alias :: Symbol) (ty :: polykind) = '(alias,ty)

@@ -175,7 +177,7 @@ instance alias1 ~ alias2 => IsLabel alias1 (Alias alias2) where

175renderAlias :: KnownSymbol alias => Alias alias -> ByteString

177renderAlias :: KnownSymbol alias => Alias alias -> ByteString

176renderAlias = fromString . symbolVal

178renderAlias = fromString . symbolVal

177

179

178−-- | The `As` operator is used to name an expression. `As` is the demoted

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

179-- version of `:::`.

181-- version of `:::`.

180--

182--

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

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

@@ -211,13 +213,13 @@ class IsTableColumn table column expression where

211 infixl 9 !

213 infixl 9 !

212instance IsTableColumn table column (Alias table, Alias column) where (!) = (,)

214instance IsTableColumn table column (Alias table, Alias column) where (!) = (,)

213

215

214−-- | `In x xs` is a constraint that proves that `x` is in `xs.

216+-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.

215type family In x xs :: Constraint where

217type family In x xs :: Constraint where

216 In x (x ': xs) = ()

218 In x (x ': xs) = ()

217 In x (y ': xs) = In x xs

219 In x (y ': xs) = In x xs

218

220

219−-- | `HasUnique alias xs x` is a constraint that proves that xs is a singleton

221+-- | @HasUnique alias xs x@ is a constraint that proves that @xs@ is a singleton

220−-- of `alias ::: x`.

222+-- of @alias ::: x@.

221type HasUnique alias xs x = xs ~ '[alias ::: x]

223type HasUnique alias xs x = xs ~ '[alias ::: x]

222

224

223-- | `BaseType` forgets about @NULL@ and @DEFAULT@

225-- | `BaseType` forgets about @NULL@ and @DEFAULT@

@@ -259,7 +261,7 @@ type family NullifyColumns (columns :: ColumnsType) :: ColumnsType where

259

261

260-- | `NullifyTables` is an idempotent that nullifies a `TablesType`

262-- | `NullifyTables` is an idempotent that nullifies a `TablesType`

261-- used to nullify the left or right hand side of an outer join

263-- used to nullify the left or right hand side of an outer join

262−-- in a `Squeal.PostgreSQL.Query.FromClause`

264+-- in a `Squeal.PostgreSQL.Query.FromClause`.

263type family NullifyTables (tables :: TablesType) :: TablesType where

265type family NullifyTables (tables :: TablesType) :: TablesType where

264 NullifyTables '[] = '[]

266 NullifyTables '[] = '[]

265 NullifyTables ((table ::: columns) ': tables) =

267 NullifyTables ((table ::: columns) ': tables) =

squeal-postgresql/test/Squeal/PostgreSQL/ManipulationSpec.hs+3−3

@@ -24,7 +24,7 @@ spec = do

24 statement :: Manipulation Tables '[] SumAndCol1

25 statement =

26 insertInto #table1 (Values (2 `As` #col1 :* 4 `As` #col2 :* Nil) [])

27− Conflict

27+ OnConflictDoRaise

28 (Returning $ (#col1 + #col2) `As` #sum :* #col1 `As` #col1 :* Nil)

29 statement `manipulationRenders`

30 "INSERT INTO table1 (col1, col2) VALUES (2, 4)\

@@ -79,7 +79,7 @@ spec = do

79 it "correctly renders DELETEs" $ do

80 let

81 statement :: Manipulation Tables '[] '[]

82− statement = deleteFrom #table1 (#col1 .== #col2)

82+ statement = deleteFrom #table1 (#col1 .== #col2) (Returning Nil)

83 statement `manipulationRenders`

84 "DELETE FROM table1 WHERE (col1 = col2);"

85 it "should be safe against SQL injection in literal text" $ do

@@ -87,7 +87,7 @@ spec = do

87 statement :: Manipulation StudentsTable '[] '[]

88 statement = insertInto #students

89 (Values ("Robert'); DROP TABLE students;" `As` #name :* Nil) [])

90− Conflict (Returning Nil)

90+ OnConflictDoRaise (Returning Nil)

91 statement `manipulationRenders`

92 "INSERT INTO students (name) VALUES (E'Robert''); DROP TABLE students;');"