43ad645 · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

schema work

43ad645Eitan Chatav8 years ago

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

compare with dev

unifiedsplit

@@ -555,7 +555,7 @@ unsafeVariadicFunction

555unsafeVariadicFunction fun x = UnsafeExpression $

556 fun <> parenthesized (commaSeparated (hcollapse (hmap (K . renderExpression) x)))

557

558−instance PGNum ty

558+instance ty `In` PGNum

559 => Num (Expression schema from grouping params (nullity ty)) where

560 (+) = unsafeBinaryOp "+"

561 (-) = unsafeBinaryOp "-"

@@ -567,12 +567,12 @@ instance PGNum ty

567 . fromString

568 . show

569

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

570+instance (ty `In` PGNum, ty `In` PGFloating) => Fractional

571 (Expression schema from grouping params (nullity ty)) where

572 (/) = unsafeBinaryOp "/"

573 fromRational x = fromInteger (numerator x) / fromInteger (denominator x)

574

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

575+instance (ty `In` PGNum, ty `In` PGFloating) => Floating

576 (Expression schema from grouping params (nullity ty)) where

577 pi = UnsafeExpression "pi()"

578 exp = unsafeFunction "exp"

@@ -602,7 +602,7 @@ instance (PGNum ty, PGFloating ty) => Floating

602-- :}

603-- atan2(pi(), 2)

604atan2_

605− :: PGFloating float

605+ :: float `In` PGFloating

606 => Expression schema from grouping params (nullity float)

607 -- ^ numerator

608 -> Expression schema from grouping params (nullity float)

@@ -636,7 +636,7 @@ cast ty x = UnsafeExpression $ parenthesized $

636-- :}

637-- (5 / 2)

638quot_

639− :: PGIntegral int

639+ :: int `In` PGIntegral

640 => Expression schema from grouping params (nullity int)

641 -- ^ numerator

642 -> Expression schema from grouping params (nullity int)

@@ -654,7 +654,7 @@ quot_ = unsafeBinaryOp "/"

654-- :}

655-- (5 % 2)

656rem_

657− :: PGIntegral int

657+ :: int `In` PGIntegral

658 => Expression schema from grouping params (nullity int)

659 -- ^ numerator

660 -> Expression schema from grouping params (nullity int)

@@ -670,7 +670,7 @@ rem_ = unsafeBinaryOp "%"

670-- :}

671-- trunc(pi())

672trunc

673− :: PGFloating frac

673+ :: frac `In` PGFloating

674 => Expression schema from grouping params (nullity frac)

675 -- ^ fractional number

676 -> Expression schema from grouping params (nullity frac)

@@ -684,7 +684,7 @@ trunc = unsafeFunction "trunc"

684-- :}

685-- round(pi())

686round_

687− :: PGFloating frac

687+ :: frac `In` PGFloating

688 => Expression schema from grouping params (nullity frac)

689 -- ^ fractional number

690 -> Expression schema from grouping params (nullity frac)

@@ -698,7 +698,7 @@ round_ = unsafeFunction "round"

698-- :}

699-- ceiling(pi())

700ceiling_

701− :: PGFloating frac

701+ :: frac `In` PGFloating

702 => Expression schema from grouping params (nullity frac)

703 -- ^ fractional number

704 -> Expression schema from grouping params (nullity frac)

@@ -955,7 +955,7 @@ Table 9.44: json and jsonb operators

955

956-- | Get JSON value (object field or array element) at a key.

957(.->)

958− :: (PGjson_ json, PGjsonKey key)

958+ :: (json `In` PGJsonType, key `In` PGJsonKey)

959 => Expression schema from grouping params (nullity json)

960 -> Expression schema from grouping params (nullity key)

961 -> Expression schema from grouping params ('Null json)

@@ -964,7 +964,7 @@ infixl 8 .->

964

965-- | Get JSON value (object field or array element) at a key, as text.

966(.->>)

967− :: (PGjson_ json, PGjsonKey key)

967+ :: (json `In` PGJsonType, key `In` PGJsonKey)

968 => Expression schema from grouping params (nullity json)

969 -> Expression schema from grouping params (nullity key)

970 -> Expression schema from grouping params ('Null 'PGtext)

@@ -973,7 +973,7 @@ infixl 8 .->>

973

974-- | Get JSON value at a specified path.

975(.#>)

976− :: (PGjson_ json, PGtextArray "(.#>)" path)

976+ :: (json `In` PGJsonType, PGTextArray "(.#>)" path)

977 => Expression schema from grouping params (nullity json)

978 -> Expression schema from grouping params (nullity path)

979 -> Expression schema from grouping params ('Null json)

@@ -982,7 +982,7 @@ infixl 8 .#>

982

983-- | Get JSON value at a specified path as text.

984(.#>>)

985− :: (PGjson_ json, PGtextArray "(.#>>)" path)

985+ :: (json `In` PGJsonType, PGTextArray "(.#>>)" path)

986 => Expression schema from grouping params (nullity json)

987 -> Expression schema from grouping params (nullity path)

988 -> Expression schema from grouping params ('Null 'PGtext)

@@ -1061,7 +1061,7 @@ infixl 6 .-.

1061-- | Delete the field or element with specified path (for JSON arrays, negative

1062-- integers count from the end)

1063(#-.)

1064− :: PGtextArray "(#-.)" arrayty

1064+ :: PGTextArray "(#-.)" arrayty

1065 => Expression schema from grouping params (nullity 'PGjsonb)

1066 -> Expression schema from grouping params (nullity arrayty)

1067 -> Expression schema from grouping params (nullity 'PGjsonb)

@@ -1111,7 +1111,7 @@ toJsonb = unsafeFunction "to_jsonb"

1111-- | Returns the array as a JSON array. A PostgreSQL multidimensional array

1112-- becomes a JSON array of arrays.

1113arrayToJson

1114− :: PGarray "arrayToJson" arr

1114+ :: PGArray "arrayToJson" arr

1115 => Expression schema from grouping params (nullity arr)

1116 -> Expression schema from grouping params (nullity 'PGjson)

1117arrayToJson = unsafeFunction "array_to_json"

@@ -1178,7 +1178,7 @@ jsonbBuildObject

1178-- taken as alternating key/value pairs, or two dimensions such that each inner

1179-- array has exactly two elements, which are taken as a key/value pair.

1180jsonObject

1181− :: PGarrayOf "jsonObject" arr ('NotNull 'PGtext)

1181+ :: PGArrayOf "jsonObject" arr ('NotNull 'PGtext)

1182 => Expression schema from grouping params (nullity arr)

1183 -> Expression schema from grouping params (nullity 'PGjson)

1184jsonObject = unsafeFunction "json_object"

@@ -1188,7 +1188,7 @@ jsonObject = unsafeFunction "json_object"

1188-- taken as alternating key/value pairs, or two dimensions such that each inner

1189-- array has exactly two elements, which are taken as a key/value pair.

1190jsonbObject

1191− :: PGarrayOf "jsonbObject" arr ('NotNull 'PGtext)

1191+ :: PGArrayOf "jsonbObject" arr ('NotNull 'PGtext)

1192 => Expression schema from grouping params (nullity arr)

1193 -> Expression schema from grouping params (nullity 'PGjsonb)

1194jsonbObject = unsafeFunction "jsonb_object"

@@ -1196,8 +1196,8 @@ jsonbObject = unsafeFunction "jsonb_object"

1196-- | This is an alternate form of 'jsonObject' that takes two arrays; one for

1197-- keys and one for values, that are zipped pairwise to create a JSON object.

1198jsonZipObject

1199− :: ( PGarrayOf "jsonZipObject" keysArray ('NotNull 'PGtext)

1199+ :: ( PGArrayOf "jsonZipObject" keysArray ('NotNull 'PGtext)

1200− , PGarrayOf "jsonZipObject" valuesArray ('NotNull 'PGtext))

1200+ , PGArrayOf "jsonZipObject" valuesArray ('NotNull 'PGtext))

1201 => Expression schema from grouping params (nullity keysArray)

1202 -> Expression schema from grouping params (nullity valuesArray)

1203 -> Expression schema from grouping params (nullity 'PGjson)

@@ -1208,8 +1208,8 @@ jsonZipObject ks vs =

1208-- keys and one for values, that are zipped pairwise to create a binary JSON

1209-- object.

1210jsonbZipObject

1211− :: ( PGarrayOf "jsonbZipObject" keysArray ('NotNull 'PGtext)

1211+ :: ( PGArrayOf "jsonbZipObject" keysArray ('NotNull 'PGtext)

1212− , PGarrayOf "jsonbZipObject" valuesArray ('NotNull 'PGtext))

1212+ , PGArrayOf "jsonbZipObject" valuesArray ('NotNull 'PGtext))

1213 => Expression schema from grouping params (nullity keysArray)

1214 -> Expression schema from grouping params (nullity valuesArray)

1215 -> Expression schema from grouping params (nullity 'PGjsonb)

@@ -1320,7 +1320,7 @@ jsonbStripNulls = unsafeFunction "jsonb_strip_nulls"

1320-- operators, negative integers that appear in path count from the end of JSON

1321-- arrays.

1322jsonbSet

1323− :: PGtextArray "jsonbSet" arr

1323+ :: PGTextArray "jsonbSet" arr

1324 => Expression schema from grouping params (nullity 'PGjsonb)

1325 -> Expression schema from grouping params (nullity arr)

1326 -> Expression schema from grouping params (nullity 'PGjsonb)

@@ -1339,7 +1339,7 @@ jsonbSet tgt path val createMissing = case createMissing of

1339-- exist. As with the path orientated operators, negative integers that appear

1340-- in path count from the end of JSON arrays.

1341jsonbInsert

1342− :: PGtextArray "jsonbInsert" arr

1342+ :: PGTextArray "jsonbInsert" arr

1343 => Expression schema from grouping params (nullity 'PGjsonb)

1344 -> Expression schema from grouping params (nullity arr)

1345 -> Expression schema from grouping params (nullity 'PGjsonb)

@@ -1383,7 +1383,7 @@ unsafeAggregateDistinct fun x = UnsafeExpression $ mconcat

1383-- :}

1384-- sum("col")

1385sum_

1386− :: PGNum ty

1386+ :: ty `In` PGNum

1387 => Expression schema from 'Ungrouped params (nullity ty)

1388 -- ^ what to sum

1389 -> Expression schema from ('Grouped bys) params (nullity ty)

@@ -1397,7 +1397,7 @@ sum_ = unsafeAggregate "sum"

1397-- :}

1398-- sum(DISTINCT "col")

1399sumDistinct

1400− :: PGNum ty

1400+ :: ty `In` PGNum

1401 => Expression schema from 'Ungrouped params (nullity ty)

1402 -- ^ what to sum

1403 -> Expression schema from ('Grouped bys) params (nullity ty)

@@ -1428,7 +1428,7 @@ instance PGAvg 'PGinterval 'PGinterval

1428-- :}

1429-- bit_and("col")

1430bitAnd

1431− :: PGIntegral int

1431+ :: int `In` PGIntegral

1432 => Expression schema from 'Ungrouped params (nullity int)

1433 -- ^ what to aggregate

1434 -> Expression schema from ('Grouped bys) params (nullity int)

@@ -1442,7 +1442,7 @@ bitAnd = unsafeAggregate "bit_and"

1442-- :}

1443-- bit_or("col")

1444bitOr

1445− :: PGIntegral int

1445+ :: int `In` PGIntegral

1446 => Expression schema from 'Ungrouped params (nullity int)

1447 -- ^ what to aggregate

1448 -> Expression schema from ('Grouped bys) params (nullity int)

@@ -1456,7 +1456,7 @@ bitOr = unsafeAggregate "bit_or"

1456-- :}

1457-- bit_and(DISTINCT "col")

1458bitAndDistinct

1459− :: PGIntegral int

1459+ :: int `In` PGIntegral

1460 => Expression schema from 'Ungrouped params (nullity int)

1461 -- ^ what to aggregate

1462 -> Expression schema from ('Grouped bys) params (nullity int)

@@ -1470,7 +1470,7 @@ bitAndDistinct = unsafeAggregateDistinct "bit_and"

1470-- :}

1471-- bit_or(DISTINCT "col")

1472bitOrDistinct

1473− :: PGIntegral int

1473+ :: int `In` PGIntegral

1474 => Expression schema from 'Ungrouped params (nullity int)

1475 -- ^ what to aggregate

1476 -> Expression schema from ('Grouped bys) params (nullity int)

squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+41−32

@@ -232,13 +232,14 @@ insertRows

232 :: ( SOP.SListI columns

233 , SOP.SListI results

234 , Has tab schema ('Table table)

235+ , row ~ TableToRow table

235 , columns ~ TableToColumns table )

236 , columns ~ TableToColumns table )

236 => Alias tab -- ^ table to insert into

237 => Alias tab -- ^ table to insert into

237 -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert

238 -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert

238 -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert

239 -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert

239− -> ConflictClause schema columns params

240+ -> ConflictClause schema table params

240 -- ^ what to do in case of constraint conflict

241 -- ^ what to do in case of constraint conflict

241− -> ReturningClause schema columns params results -- ^ results to return

242+ -> ReturningClause schema params row results -- ^ results to return

242 -> Manipulation schema params results

243 -> Manipulation schema params results

243insertRows tab rw rws conflict returning = UnsafeManipulation $

244insertRows tab rw rws conflict returning = UnsafeManipulation $

244 "INSERT" <+> "INTO" <+> renderAlias tab

245 "INSERT" <+> "INTO" <+> renderAlias tab

@@ -262,12 +263,13 @@ insertRow

262 :: ( SOP.SListI columns

263 :: ( SOP.SListI columns

263 , SOP.SListI results

264 , SOP.SListI results

264 , Has tab schema ('Table table)

265 , Has tab schema ('Table table)

266+ , row ~ TableToRow table

265 , columns ~ TableToColumns table )

267 , columns ~ TableToColumns table )

266 => Alias tab -- ^ table to insert into

268 => Alias tab -- ^ table to insert into

267 -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert

269 -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert

268− -> ConflictClause schema columns params

270+ -> ConflictClause schema table params

269 -- ^ what to do in case of constraint conflict

271 -- ^ what to do in case of constraint conflict

270− -> ReturningClause schema columns params results -- ^ results to return

272+ -> ReturningClause schema params row results -- ^ results to return

271 -> Manipulation schema params results

273 -> Manipulation schema params results

272insertRow tab rw = insertRows tab rw []

274insertRow tab rw = insertRows tab rw []

273

275

@@ -298,12 +300,13 @@ insertQuery

298 :: ( SOP.SListI columns

300 :: ( SOP.SListI columns

299 , SOP.SListI results

301 , SOP.SListI results

300 , Has tab schema ('Table table)

302 , Has tab schema ('Table table)

303+ , row ~ TableToRow table

301 , columns ~ TableToColumns table )

304 , columns ~ TableToColumns table )

302 => Alias tab -- ^ table to insert into

305 => Alias tab -- ^ table to insert into

303− -> Query schema params (ColumnsToRow columns)

306+ -> Query schema params (TableToRow table)

304− -> ConflictClause schema columns params

307+ -> ConflictClause schema table params

305 -- ^ what to do in case of constraint conflict

308 -- ^ what to do in case of constraint conflict

306− -> ReturningClause schema columns params results -- ^ results to return

309+ -> ReturningClause schema params row results -- ^ results to return

307 -> Manipulation schema params results

310 -> Manipulation schema params results

308insertQuery tab query conflict returning = UnsafeManipulation $

311insertQuery tab query conflict returning = UnsafeManipulation $

309 "INSERT" <+> "INTO" <+> renderAlias tab

312 "INSERT" <+> "INTO" <+> renderAlias tab

@@ -317,7 +320,7 @@ insertQuery_

317 , Has tab schema ('Table table)

320 , Has tab schema ('Table table)

318 , columns ~ TableToColumns table )

321 , columns ~ TableToColumns table )

319 => Alias tab -- ^ table to insert into

322 => Alias tab -- ^ table to insert into

320− -> Query schema params (ColumnsToRow columns)

323+ -> Query schema params (TableToRow table)

321 -> Manipulation schema params '[]

324 -> Manipulation schema params '[]

322insertQuery_ tab query =

325insertQuery_ tab query =

323 insertQuery tab query OnConflictDoRaise (Returning Nil)

326 insertQuery tab query OnConflictDoRaise (Returning Nil)

@@ -351,17 +354,15 @@ data ColumnValue

351-- values are desired.

354-- values are desired.

352data ReturningClause

355data ReturningClause

353 (schema :: SchemaType)

356 (schema :: SchemaType)

354− (columns :: ColumnsType)

355 (params :: [NullityType])

357 (params :: [NullityType])

358+ (row0 :: RowType)

356− (results :: RowType)

359+ (row1 :: RowType)

357 where

360 where

358 ReturningStar

361 ReturningStar

359− :: results ~ ColumnsToRow columns

360− => ReturningClause schema columns params results

362+ :: ReturningClause schema params row row

361 Returning

363 Returning

362− :: rel ~ ColumnsToRow columns

363− => NP (Aliased (Expression schema '[table ::: rel] 'Ungrouped params)) results

364+ :: NP (Aliased (Expression schema '[table ::: row0] 'Ungrouped params)) row1

364− -> ReturningClause schema columns params results

365+ -> ReturningClause schema params row0 row1

365

366

366-- | Render a `ReturningClause`.

367-- | Render a `ReturningClause`.

367renderReturningClause

368renderReturningClause

@@ -379,18 +380,22 @@ renderReturningClause = \case

379-- `OnConflictDoNothing` simply avoids inserting a row.

380-- `OnConflictDoNothing` simply avoids inserting a row.

380-- `OnConflictDoUpdate` updates the existing row that conflicts with the row

381-- `OnConflictDoUpdate` updates the existing row that conflicts with the row

381-- proposed for insertion.

382-- proposed for insertion.

382−data ConflictClause (schema :: SchemaType) (columns :: ColumnsType) params where

383+data ConflictClause

384+ (schema :: SchemaType)

385+ (table :: TableType)

386+ (params :: [NullityType]) where

383− OnConflictDoRaise :: ConflictClause schema columns params

387+ OnConflictDoRaise :: ConflictClause schema table params

384− OnConflictDoNothing :: ConflictClause schema columns params

388+ OnConflictDoNothing :: ConflictClause schema table params

385− OnConflictDoUpdate

389+ OnConflictDoUpdate

390+ :: (row ~ TableToRow table, columns ~ TableToColumns table)

386− :: NP (Aliased (ColumnValue schema (ColumnsToRow columns) params)) columns

391+ => NP (Aliased (ColumnValue schema row params)) columns

387− -> [Condition schema '[table ::: ColumnsToRow columns] 'Ungrouped params]

392+ -> [Condition schema '[t ::: row] 'Ungrouped params]

388− -> ConflictClause schema columns params

393+ -> ConflictClause schema table params

389

394

390-- | Render a `ConflictClause`.

395-- | Render a `ConflictClause`.

391renderConflictClause

396renderConflictClause

392− :: SOP.SListI columns

397+ :: SOP.SListI (TableToColumns table)

393− => ConflictClause schema columns params

398+ => ConflictClause schema table params

394 -> ByteString

399 -> ByteString

395renderConflictClause = \case

400renderConflictClause = \case

396 OnConflictDoRaise -> ""

401 OnConflictDoRaise -> ""

@@ -422,13 +427,14 @@ update

422 :: ( SOP.SListI columns

427 :: ( SOP.SListI columns

423 , SOP.SListI results

428 , SOP.SListI results

424 , Has tab schema ('Table table)

429 , Has tab schema ('Table table)

430+ , row ~ TableToRow table

425 , columns ~ TableToColumns table )

431 , columns ~ TableToColumns table )

426 => Alias tab -- ^ table to update

432 => Alias tab -- ^ table to update

427− -> NP (Aliased (ColumnValue schema (ColumnsToRow columns) params)) columns

433+ -> NP (Aliased (ColumnValue schema row params)) columns

428 -- ^ modified values to replace old values

434 -- ^ modified values to replace old values

429− -> Condition schema '[tab ::: ColumnsToRow columns] 'Ungrouped params

435+ -> (forall t. Condition schema '[t ::: row] 'Ungrouped params)

430 -- ^ condition under which to perform update on a row

436 -- ^ condition under which to perform update on a row

431− -> ReturningClause schema columns params results -- ^ results to return

437+ -> ReturningClause schema params row results -- ^ results to return

432 -> Manipulation schema params results

438 -> Manipulation schema params results

433update tab columns wh returning = UnsafeManipulation $

439update tab columns wh returning = UnsafeManipulation $

434 "UPDATE"

440 "UPDATE"

@@ -452,11 +458,12 @@ update tab columns wh returning = UnsafeManipulation $

452update_

458update_

453 :: ( SOP.SListI columns

459 :: ( SOP.SListI columns

454 , Has tab schema ('Table table)

460 , Has tab schema ('Table table)

461+ , row ~ TableToRow table

455 , columns ~ TableToColumns table )

462 , columns ~ TableToColumns table )

456 => Alias tab -- ^ table to update

463 => Alias tab -- ^ table to update

457− -> NP (Aliased (ColumnValue schema (ColumnsToRow columns) params)) columns

464+ -> NP (Aliased (ColumnValue schema row params)) columns

458 -- ^ modified values to replace old values

465 -- ^ modified values to replace old values

459− -> Condition schema '[tab ::: ColumnsToRow columns] 'Ungrouped params

466+ -> (forall t. Condition schema '[t ::: row] 'Ungrouped params)

460 -- ^ condition under which to perform update on a row

467 -- ^ condition under which to perform update on a row

461 -> Manipulation schema params '[]

468 -> Manipulation schema params '[]

462update_ tab columns wh = update tab columns wh (Returning Nil)

469update_ tab columns wh = update tab columns wh (Returning Nil)

@@ -469,11 +476,12 @@ DELETE statements

469deleteFrom

476deleteFrom

470 :: ( SOP.SListI results

477 :: ( SOP.SListI results

471 , Has tab schema ('Table table)

478 , Has tab schema ('Table table)

479+ , row ~ TableToRow table

472 , columns ~ TableToColumns table )

480 , columns ~ TableToColumns table )

473 => Alias tab -- ^ table to delete from

481 => Alias tab -- ^ table to delete from

474− -> Condition schema '[tab ::: ColumnsToRow columns] 'Ungrouped params

482+ -> Condition schema '[tab ::: row] 'Ungrouped params

475 -- ^ condition under which to delete a row

483 -- ^ condition under which to delete a row

476− -> ReturningClause schema columns params results -- ^ results to return

484+ -> ReturningClause schema params row results -- ^ results to return

477 -> Manipulation schema params results

485 -> Manipulation schema params results

478deleteFrom tab wh returning = UnsafeManipulation $

486deleteFrom tab wh returning = UnsafeManipulation $

479 "DELETE FROM" <+> renderAlias tab

487 "DELETE FROM" <+> renderAlias tab

@@ -483,9 +491,10 @@ deleteFrom tab wh returning = UnsafeManipulation $

483-- | Delete rows returning `Nil`.

491-- | Delete rows returning `Nil`.

484deleteFrom_

492deleteFrom_

485 :: ( Has tab schema ('Table table)

493 :: ( Has tab schema ('Table table)

494+ , row ~ TableToRow table

486 , columns ~ TableToColumns table )

495 , columns ~ TableToColumns table )

487 => Alias tab -- ^ table to delete from

496 => Alias tab -- ^ table to delete from

488− -> Condition schema '[tab ::: ColumnsToRow columns] 'Ungrouped params

497+ -> (forall t. Condition schema '[t ::: row] 'Ungrouped params)

489 -- ^ condition under which to delete a row

498 -- ^ condition under which to delete a row

490 -> Manipulation schema params '[]

499 -> Manipulation schema params '[]

491deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil)

500deleteFrom_ tab wh = deleteFrom tab wh (Returning Nil)

squeal-postgresql/src/Squeal/PostgreSQL/Schema.hs+154−95

@@ -34,17 +34,24 @@ it defines an embedding of Haskell types into Postgres types.

34#-}

36module Squeal.PostgreSQL.Schema

37− ( -- * Types

37+ ( -- * Postgres Types

38 PGType (..)

39− , HasOid (..)

40 , NullityType (..)

39 , NullityType (..)

41− , ColumnType

42− -- * Tables

43− , ColumnsType

44 , RowType

40 , RowType

45 , FromType

41 , FromType

42+ -- * Haskell to Postgres Types

43+ , PG

44+ , NullPG

45+ , TuplePG

46+ , RowPG

47+ , Json (..)

48+ , Jsonb (..)

49+ , Composite (..)

50+ , Enumerated (..)

51+ -- * Schema Types

52+ , ColumnType

53+ , ColumnsType

46 , TableType

54 , TableType

47− -- * Schema

48 , SchemumType (..)

55 , SchemumType (..)

49 , SchemaType

56 , SchemaType

50 -- * Constraints

57 -- * Constraints

@@ -61,7 +68,6 @@ module Squeal.PostgreSQL.Schema

61 , Aliased (As)

68 , Aliased (As)

62 , Aliasable (as)

69 , Aliasable (as)

63 , renderAliasedAs

70 , renderAliasedAs

64− , AliasesOf

65 , Has

71 , Has

66 , HasUnique

72 , HasUnique

67 , HasAll

73 , HasAll

@@ -73,57 +79,45 @@ module Squeal.PostgreSQL.Schema

73 , PGlabel (..)

79 , PGlabel (..)

74 , renderLabel

80 , renderLabel

75 , renderLabels

81 , renderLabels

82+ , LabelsPG

76 -- * Grouping

83 -- * Grouping

77 , Grouping (..)

84 , Grouping (..)

78 , GroupedBy

85 , GroupedBy

79− -- * Type Families

86+ -- * Aligned lists

80− , Join

87+ , AlignedList (..)

88+ , single

89+ -- * Data Definitions

81 , Create

90 , Create

82 , Drop

91 , Drop

83 , Alter

92 , Alter

84 , Rename

93 , Rename

94+ , DropIfConstraintsInvolve

95+ -- * Lists

96+ , Join

85 , Elem

97 , Elem

86 , In

98 , In

87 , Length

99 , Length

100+ -- * Type Classifications

101+ , HasOid (..)

88 , PGNum

102 , PGNum

89 , PGIntegral

103 , PGIntegral

90 , PGFloating

104 , PGFloating

91 , PGTypeOf

105 , PGTypeOf

92− , PGarrayOf

106+ , PGArrayOf

93− , PGarray

107+ , PGArray

94− , PGtextArray

108+ , PGTextArray

109+ , PGJsonType

110+ , PGJsonKey

95 , SamePGType

111 , SamePGType

96 , AllNotNull

112 , AllNotNull

97 , NotAllNull

113 , NotAllNull

114+ -- * Nullifications

98 , NullifyType

115 , NullifyType

99 , NullifyRow

116 , NullifyRow

100 , NullifyFrom

117 , NullifyFrom

101− , ColumnsToRow

118+ -- * Table Conversions

102 , TableToColumns

119 , TableToColumns

103 , TableToRow

120 , TableToRow

104− , ConstraintInvolves

105− , DropIfConstraintsInvolve

106− -- ** JSON support

107− , PGjson_

108− , PGjsonKey

109− -- * Immersion

110− , PG

111− , Json (..)

112− , Jsonb (..)

113− , Composite (..)

114− , Enumerated (..)

115− , NullPG

116− , TuplePG

117− , LabelsPG

118− , RowPG

119− , RowOf

120− , FieldPG

121− , ConstructorsOf

122− , ConstructorNameOf

123− , ConstructorNamesOf

124− -- * Aligned lists

125− , AlignedList (..)

126− , single

127 ) where

121 ) where

128

122

129import Control.Category

123import Control.Category

@@ -305,19 +299,24 @@ type family Uniquely

305-- :}

299-- :}

306type TableType = (TableConstraints,ColumnsType)

300type TableType = (TableConstraints,ColumnsType)

307

301

308−-- | `RowType` is a row of `NullityType`

302+{- | A `RowType` is a row of `NullityType`. They correspond to Haskell

309−--

303+record types by means of `RowPG` and are used in many places.

304+

310−-- >>> :{

305+>>> :{

311−-- type family PersonRelation :: RowType where

306+type family PersonRow :: RowType where

312−-- PersonRelation =

307+ PersonRow =

313−-- '[ "name" ::: 'NotNull 'PGtext

308+ '[ "name" ::: 'NotNull 'PGtext

314−-- , "age" ::: 'NotNull 'PGint4

309+ , "age" ::: 'NotNull 'PGint4

315−-- , "dateOfBirth" ::: 'Null 'PGdate

310+ , "dateOfBirth" ::: 'Null 'PGdate

316−-- ]

311+ ]

317−-- :}

312+:}

313+-}

318type RowType = [(Symbol,NullityType)]

314type RowType = [(Symbol,NullityType)]

319

315

320−-- | `FromType` is a row of `RowType`s, thought of as a product.

316+{- | `FromType` is a row of `RowType`s. It can be thought of as

317+a product, or horizontal gluing and is used in `Squeal.PostgreSQL.Query.FromClause`s

318+and `Squeal.PostgreSQL.Query.TableExpression`s.

319+-}

321type FromType = [(Symbol,RowType)]

320type FromType = [(Symbol,RowType)]

322

321

323-- | `ColumnsToRow` removes column constraints.

322-- | `ColumnsToRow` removes column constraints.

@@ -435,11 +434,6 @@ renderAliasedAs

435renderAliasedAs render (expression `As` alias) =

434renderAliasedAs render (expression `As` alias) =

436 render expression <> " AS " <> renderAlias alias

435 render expression <> " AS " <> renderAlias alias

437

436

438−-- | `AliasesOf` retains the AliasesOf in a row.

439−type family AliasesOf aliaseds where

440− AliasesOf '[] = '[]

441− AliasesOf (alias ::: ty ': tys) = alias ': AliasesOf tys

442−

443-- | @HasUnique alias fields field@ is a constraint that proves that

437-- | @HasUnique alias fields field@ is a constraint that proves that

444-- @fields@ is a singleton of @alias ::: field@.

438-- @fields@ is a singleton of @alias ::: field@.

445type HasUnique alias fields field = fields ~ '[alias ::: field]

439type HasUnique alias fields field = fields ~ '[alias ::: field]

@@ -486,21 +480,15 @@ type family Elem x xs where

486-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.

480-- | @In x xs@ is a constraint that proves that @x@ is in @xs@.

487type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True

481type family In x xs :: Constraint where In x xs = Elem x xs ~ 'True

488

482

489−-- | `PGNum` is a constraint on `PGType` whose

483+-- | Numeric Postgres types.

490−-- `Squeal.PostgreSQL.Expression.Expression`s have a `Num` constraint.

491−type PGNum ty =

484+type PGNum =

492− In ty '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]

485+ '[ 'PGint2, 'PGint4, 'PGint8, 'PGnumeric, 'PGfloat4, 'PGfloat8]

493

486

494−-- | `PGFloating` is a constraint on `PGType` whose

487+-- | Floating Postgres types.

495−-- `Squeal.PostgreSQL.Expression.Expression`s

496−-- have `Fractional` and `Floating` constraints.

497−type PGFloating ty = In ty '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]

488+type PGFloating = '[ 'PGfloat4, 'PGfloat8, 'PGnumeric]

498

489

499−-- | `PGIntegral` is a constraint on `PGType` whose

490+-- | Integral Postgres types.

500−-- `Squeal.PostgreSQL.Expression.Expression`s

501−-- have `Squeal.PostgreSQL.Expression.div_` and

502−-- `Squeal.PostgreSQL.Expression.mod_` functions.

503−type PGIntegral ty = In ty '[ 'PGint2, 'PGint4, 'PGint8]

491+type PGIntegral = '[ 'PGint2, 'PGint4, 'PGint8]

504

492

505-- | Error message helper for displaying unavailable\/unknown\/placeholder type

493-- | Error message helper for displaying unavailable\/unknown\/placeholder type

506-- variables whose kind is known.

494-- variables whose kind is known.

@@ -511,27 +499,27 @@ type ErrPGfixarrayOf t = ErrArrayOf ('ShowType 'PGfixarray :<>: 'Text " " :<>: P

511type ErrPGvararrayOf t = ErrArrayOf ('ShowType 'PGvararray) t

499type ErrPGvararrayOf t = ErrArrayOf ('ShowType 'PGvararray) t

512

500

513-- | Ensure a type is a valid array type.

501-- | Ensure a type is a valid array type.

514−type family PGarray name arr :: Constraint where

502+type family PGArray name arr :: Constraint where

515− PGarray name ('PGvararray x) = ()

503+ PGArray name ('PGvararray x) = ()

516− PGarray name ('PGfixarray n x) = ()

504+ PGArray name ('PGfixarray n x) = ()

517− PGarray name val = TypeError

505+ PGArray name val = TypeError

518− ('Text name :<>: 'Text ": Unsatisfied PGarray constraint. Expected either: "

506+ ('Text name :<>: 'Text ": Unsatisfied PGArray constraint. Expected either: "

519 :$$: 'Text " • " :<>: ErrPGvararrayOf (Placeholder PGType)

507 :$$: 'Text " • " :<>: ErrPGvararrayOf (Placeholder PGType)

520 :$$: 'Text " • " :<>: ErrPGfixarrayOf (Placeholder PGType)

508 :$$: 'Text " • " :<>: ErrPGfixarrayOf (Placeholder PGType)

521 :$$: 'Text "But got: " :<>: 'ShowType val)

509 :$$: 'Text "But got: " :<>: 'ShowType val)

522

510

523-- | Ensure a type is a valid array type with a specific element type.

511-- | Ensure a type is a valid array type with a specific element type.

524−type family PGarrayOf name arr ty :: Constraint where

512+type family PGArrayOf name arr ty :: Constraint where

525− PGarrayOf name ('PGvararray x) ty = x ~ ty

513+ PGArrayOf name ('PGvararray x) ty = x ~ ty

526− PGarrayOf name ('PGfixarray n x) ty = x ~ ty

514+ PGArrayOf name ('PGfixarray n x) ty = x ~ ty

527− PGarrayOf name val ty = TypeError

515+ PGArrayOf name val ty = TypeError

528− ( 'Text name :<>: 'Text "Unsatisfied PGarrayOf constraint. Expected either: "

516+ ( 'Text name :<>: 'Text "Unsatisfied PGArrayOf constraint. Expected either: "

529 :$$: 'Text " • " :<>: ErrPGvararrayOf ( 'ShowType ty )

517 :$$: 'Text " • " :<>: ErrPGvararrayOf ( 'ShowType ty )

530 :$$: 'Text " • " :<>: ErrPGfixarrayOf ( 'ShowType ty )

518 :$$: 'Text " • " :<>: ErrPGfixarrayOf ( 'ShowType ty )

531 :$$: 'Text "But got: " :<>: 'ShowType val)

519 :$$: 'Text "But got: " :<>: 'ShowType val)

532

520

533-- | Ensure a type is a valid array type whose elements are text.

521-- | Ensure a type is a valid array type whose elements are text.

534−type PGtextArray name arr = PGarrayOf name arr ('NotNull 'PGtext)

522+type PGTextArray name arr = PGArrayOf name arr ('NotNull 'PGtext)

535

523

536-- | `PGTypeOf` forgets about @NULL@ and any column constraints.

524-- | `PGTypeOf` forgets about @NULL@ and any column constraints.

537type family PGTypeOf (ty :: NullityType) :: PGType where

525type family PGTypeOf (ty :: NullityType) :: PGType where

@@ -628,6 +616,12 @@ type family DropIfConstraintsInvolve column constraints where

628 (DropIfConstraintsInvolve column constraints)

616 (DropIfConstraintsInvolve column constraints)

629 (alias ::: constraint ': DropIfConstraintsInvolve column constraints)

617 (alias ::: constraint ': DropIfConstraintsInvolve column constraints)

630

618

619+{- | Calculate the `Length` of a type level list

620+

621+>>> :kind! Length '[Char,String,Bool,Double]

622+Length '[Char,String,Bool,Double] :: Nat

623+= 4

624+-}

631type family Length (xs :: [k]) :: Nat where

625type family Length (xs :: [k]) :: Nat where

632 Length (x : xs) = 1 + Length xs

626 Length (x : xs) = 1 + Length xs

633 Length '[] = 0

627 Length '[] = 0

@@ -639,8 +633,28 @@ data SchemumType

639 | View RowType

633 | View RowType

640 | Typedef PGType

634 | Typedef PGType

641

635

642−-- | The schema of a database consists of a list of aliased,

636+{- | The schema of a database consists of a list of aliased,

643−-- user-defined `SchemumType`s.

637+user-defined `SchemumType`s.

638+

639+>>> :{

640+type family Schema :: SchemaType where

641+ Schema =

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

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

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

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

646+ ])

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

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

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

650+ ] :=>

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

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

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

654+ ])

655+ ]

656+:}

657+-}

644type SchemaType = [(Symbol,SchemumType)]

658type SchemaType = [(Symbol,SchemumType)]

645

659

646-- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas

660-- | `IsPGlabel` looks very much like the `IsLabel` class. Whereas

@@ -664,12 +678,16 @@ renderLabels

664renderLabels = hcollapse

678renderLabels = hcollapse

665 . hcmap (Proxy @KnownSymbol) (K . renderLabel)

679 . hcmap (Proxy @KnownSymbol) (K . renderLabel)

666

680

667−-- | The `PG` type family embeds a subset of Haskell types

681+{- | The `PG` type family embeds a subset of Haskell types

668−-- as Postgres basic types.

682+as Postgres types. As an open type family, `PG` is extensible.

669−--

683+

670−-- >>> :kind! PG LocalTime

684+>>> :kind! PG LocalTime

671−-- PG LocalTime :: PGType

685+PG LocalTime :: PGType

672−-- = 'PGtimestamp

686+= 'PGtimestamp

687+

688+>>> newtype MyDouble = My Double

689+>>> type instance PG MyDouble = 'PGfloat8

690+-}

673type family PG (hask :: Type) :: PGType

691type family PG (hask :: Type) :: PGType

674type instance PG Bool = 'PGbool

692type instance PG Bool = 'PGbool

675type instance PG Int16 = 'PGint2

693type instance PG Int16 = 'PGint2

@@ -716,28 +734,53 @@ type instance PG (hask, hask, hask, hask, hask, hask, hask, hask, hask, hask)

716type instance PG (Composite hask) = 'PGcomposite (RowPG hask)

734type instance PG (Composite hask) = 'PGcomposite (RowPG hask)

717type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)

735type instance PG (Enumerated hask) = 'PGenum (LabelsPG hask)

718

736

737+{- | The `Json` newtype is an indication that the Haskell

738+type it's applied to should be stored as `PGjson`.

739+-}

719newtype Json hask = Json {getJson :: hask}

740newtype Json hask = Json {getJson :: hask}

720 deriving (Eq, Ord, Show, Read, GHC.Generic)

741 deriving (Eq, Ord, Show, Read, GHC.Generic)

742+

743+{- | The `Jsonb` newtype is an indication that the Haskell

744+type it's applied to should be stored as `PGjsonb`.

745+-}

721newtype Jsonb hask = Jsonb {getJsonb :: hask}

746newtype Jsonb hask = Jsonb {getJsonb :: hask}

722 deriving (Eq, Ord, Show, Read, GHC.Generic)

747 deriving (Eq, Ord, Show, Read, GHC.Generic)

748+

749+{- | The `Composite` newtype is an indication that the Haskell

750+type it's applied to should be stored as a `PGcomposite`.

751+-}

723newtype Composite record = Composite {getComposite :: record}

752newtype Composite record = Composite {getComposite :: record}

724 deriving (Eq, Ord, Show, Read, GHC.Generic)

753 deriving (Eq, Ord, Show, Read, GHC.Generic)

754+

755+{- | The `Enumerated` newtype is an indication that the Haskell

756+type it's applied to should be stored as `PGenum`.

757+-}

725newtype Enumerated enum = Enumerated {getEnumerated :: enum}

758newtype Enumerated enum = Enumerated {getEnumerated :: enum}

726 deriving (Eq, Ord, Show, Read, GHC.Generic)

759 deriving (Eq, Ord, Show, Read, GHC.Generic)

727

760

728−-- | The `LabelsPG` type family calculates the constructors of a

761+{-| The `LabelsPG` type family calculates the constructors of a

729−-- Haskell enum type.

762+Haskell enum type.

730−--

763+

731−-- >>> data Schwarma = Beef | Lamb | Chicken deriving GHC.Generic

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

732−-- >>> instance Generic Schwarma

765+>>> instance Generic Schwarma

733−-- >>> instance HasDatatypeInfo Schwarma

766+>>> instance HasDatatypeInfo Schwarma

734−-- >>> :kind! LabelsPG Schwarma

767+>>> :kind! LabelsPG Schwarma

735−-- LabelsPG Schwarma :: [Type.ConstructorName]

768+LabelsPG Schwarma :: [Type.ConstructorName]

736−-- = '["Beef", "Lamb", "Chicken"]

769+= '["Beef", "Lamb", "Chicken"]

770+-}

737type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where

771type family LabelsPG (hask :: Type) :: [Type.ConstructorName] where

738 LabelsPG hask =

772 LabelsPG hask =

739 ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask))

773 ConstructorNamesOf (ConstructorsOf (DatatypeInfoOf hask))

740

774

775+{- | `RowPG` turns a Haskell record type into a `RowType`.

776+

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

778+>>> instance Generic Person

779+>>> instance HasDatatypeInfo Person

780+>>> :kind! RowPG Person

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

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

783+-}

741type family RowPG (hask :: Type) :: RowType where

784type family RowPG (hask :: Type) :: RowType where

742 RowPG hask = RowOf (RecordCodeOf hask)

785 RowPG hask = RowOf (RecordCodeOf hask)

743

786

@@ -748,10 +791,26 @@ type family RowOf (fields :: [(Symbol, Type)]) :: RowType where

748type family FieldPG (field :: (Symbol, Type)) :: (Symbol, NullityType) where

791type family FieldPG (field :: (Symbol, Type)) :: (Symbol, NullityType) where

749 FieldPG (field ::: hask) = field ::: NullPG hask

792 FieldPG (field ::: hask) = field ::: NullPG hask

750

793

794+{- | `NullPG` turns a Haskell type into a `NullityType`.

795+

796+>>> :kind! NullPG Double

797+NullPG Double :: NullityType

798+= 'NotNull 'PGfloat8

799+>>> :kind! NullPG (Maybe Double)

800+NullPG (Maybe Double) :: NullityType

801+= 'Null 'PGfloat8

802+-}

751type family NullPG (hask :: Type) :: NullityType where

803type family NullPG (hask :: Type) :: NullityType where

752 NullPG (Maybe hask) = 'Null (PG hask)

804 NullPG (Maybe hask) = 'Null (PG hask)

753 NullPG hask = 'NotNull (PG hask)

805 NullPG hask = 'NotNull (PG hask)

754

806

807+{- | `TuplePG` turns a Haskell tuple type (including record types) into

808+the corresponding list of `NullityType`s.

809+

810+>>> :kind! TuplePG (Double, Maybe Char)

811+TuplePG (Double, Maybe Char) :: [NullityType]

812+= '['NotNull 'PGfloat8, 'Null ('PGchar 1)]

813+-}

755type family TuplePG (hask :: Type) :: [NullityType] where

814type family TuplePG (hask :: Type) :: [NullityType] where

756 TuplePG hask = TupleOf (TupleCodeOf hask (Code hask))

815 TuplePG hask = TupleOf (TupleCodeOf hask (Code hask))

757

816

@@ -800,10 +859,10 @@ type family ConstructorNamesOf (constructors :: [Type.ConstructorInfo])

800 ConstructorNameOf constructor ': ConstructorNamesOf constructors

859 ConstructorNameOf constructor ': ConstructorNamesOf constructors

801

860

802-- | Is a type a valid JSON key?

861-- | Is a type a valid JSON key?

803−type PGjsonKey key = key `In` '[ 'PGint2, 'PGint4, 'PGtext ]

862+type PGJsonKey = '[ 'PGint2, 'PGint4, 'PGtext ]

804

863

805-- | Is a type a valid JSON type?

864-- | Is a type a valid JSON type?

806−type PGjson_ json = json `In` '[ 'PGjson, 'PGjsonb ]

865+type PGJsonType = '[ 'PGjson, 'PGjsonb ]

807

866

808-- | An `AlignedList` is a type-aligned list or free category.

867-- | An `AlignedList` is a type-aligned list or free category.

809data AlignedList p x0 x1 where

868data AlignedList p x0 x1 where