@@ -17,6 +17,7 @@ Squeal data manipulation language.
1717 , LambdaCase
1818 , MultiParamTypeClasses
1919 , OverloadedStrings
20+ , PatternSynonyms
2021 , RankNTypes
2122 , TypeFamilies
2223 , TypeInType
@@ -27,22 +28,24 @@ Squeal data manipulation language.
2728
2829module Squeal.PostgreSQL.Manipulation
2930 ( -- * Manipulation
30− Manipulation (UnsafeManipulation, renderManipulation)
31+ Manipulation (..)
3132 , queryStatement
32− , ColumnValue (..)
33− , ReturningClause (ReturningStar, Returning)
34− , ConflictClause (OnConflictDoRaise, OnConflictDoNothing, OnConflictDoUpdate)
33+ , QueryClause (..)
34+ , pattern Values_
35+ , DefaultAliasable (..)
36+ , ColumnExpression (..)
37+ , ReturningClause (..)
38+ , ConflictClause (..)
39+ , ConflictTarget (..)
40+ , ConflictAction (..)
3541 , UsingClause (..)
36− , ConflictTarget (OnConstraint, UniqueIndexOn)
3742 -- * Insert
38− , insertRows
39− , insertRow
40− , insertRows_
41− , insertRow_
42− , insertQuery
43− , insertQuery_
43+ , insertInto
44+ , insertInto_
4445 , renderReturningClause
4546 , renderConflictClause
47+ , renderConflictTarget
48+ , renderConflictAction
4649 -- * Update
4750 , update
4851 , update_
@@ -258,126 +261,125 @@ queryStatement q = UnsafeManipulation $ renderQuery q
258261INSERT statements
259262-----------------------------------------}
260263
261−-- | Insert multiple rows.
262−--
263−-- When a table is created, it contains no data. The first thing to do
264−-- before a database can be of much use is to insert data. Data is
265−-- conceptually inserted one row at a time. Of course you can also insert
266−-- more than one row, but there is no way to insert less than one row.
267−-- Even if you know only some column values, a complete row must be created.
268−insertRows
269− :: ( SOP.SListI columns
270− , SOP.SListI results
271− , Has tab schema ('Table table)
264+{- |
265+When a table is created, it contains no data. The first thing to do
266+before a database can be of much use is to insert data. Data is
267+conceptually inserted one row at a time. Of course you can also insert
268+more than one row, but there is no way to insert less than one row.
269+Even if you know only some column values, a complete row must be created.
270+-}
271+insertInto
272+ :: ( Has tab schema ('Table table)
273+ , columns ~ TableToColumns table
272274 , row ~ TableToRow table
273− , columns ~ TableToColumns table )
274− => Alias tab -- ^ table to insert into
275− -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert
276− -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert
277− -> ConflictClause schema table params
278− -- ^ what to do in case of constraint conflict
279− -> ReturningClause schema params row results -- ^ results to return
280− -> Manipulation schema params results
281−insertRows tab rw rws conflict returning = UnsafeManipulation $
275+ , SOP.SListI columns
276+ , SOP.SListI result )
277+ => Alias tab
278+ -> QueryClause schema params columns
279+ -> ConflictClause schema params table
280+ -> ReturningClause schema params row result
281+ -> Manipulation schema params result
282+insertInto tab qry conflict ret = UnsafeManipulation $
282283 "INSERT" <+> "INTO" <+> renderAlias tab
283− <> renderConflictAlias conflict
284− <+> parenthesized (renderCommaSeparated renderAliasPart rw)
285− <+> "VALUES"
286− <+> commaSeparated
287− ( parenthesized
288− . renderCommaSeparated renderColumnValuePart <$> rw:rws )
289− <> renderConflictClause conflict
290− <> renderReturningClause returning
291− where
292− renderAliasPart, renderColumnValuePart
293− :: Aliased (ColumnValue schema '[] params) ty -> ByteString
294− renderAliasPart (_ `As` name) = renderAlias name
295− renderColumnValuePart (value `As` _) = case value of
296− Default -> "DEFAULT"
297− Set expression -> renderExpression expression
298−
299−-- | Insert a single row.
300−insertRow
301− :: ( SOP.SListI columns
302− , SOP.SListI results
303− , Has tab schema ('Table table)
304− , row ~ TableToRow table
305− , columns ~ TableToColumns table )
306− => Alias tab -- ^ table to insert into
307− -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert
308− -> ConflictClause schema table params
309− -- ^ what to do in case of constraint conflict
310− -> ReturningClause schema params row results -- ^ results to return
311− -> Manipulation schema params results
312−insertRow tab rw = insertRows tab rw []
284+ <+> renderQueryClause qry
285+ <> renderConflictClause conflict
286+ <> renderReturningClause ret
313287
314−-- | Insert multiple rows returning `Nil` and raising an error on conflicts.
315−insertRows_
316− :: ( SOP.SListI columns
317− , Has tab schema ('Table table)
318− , columns ~ TableToColumns table )
319− => Alias tab -- ^ table to insert into
320− -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert
321− -> [NP (Aliased (ColumnValue schema '[] params)) columns] -- ^ more rows to insert
322− -> Manipulation schema params '[]
323−insertRows_ tab rw rws =
324− insertRows tab rw rws OnConflictDoRaise (Returning Nil)
325−
326−-- | Insert a single row returning `Nil` and raising an error on conflicts.
327−insertRow_
328− :: ( SOP.SListI columns
329− , Has tab schema ('Table table)
330− , columns ~ TableToColumns table )
331− => Alias tab -- ^ table to insert into
332− -> NP (Aliased (ColumnValue schema '[] params)) columns -- ^ row to insert
333− -> Manipulation schema params '[]
334−insertRow_ tab rw = insertRow tab rw OnConflictDoRaise (Returning Nil)
335−
336−-- | Insert a `Query`.
337−insertQuery
338− :: ( SOP.SListI columns
339− , SOP.SListI results
340− , Has tab schema ('Table table)
288+insertInto_
289+ :: ( Has tab schema ('Table table)
290+ , columns ~ TableToColumns table
341291 , row ~ TableToRow table
342− , columns ~ TableToColumns table )
343− => Alias tab -- ^ table to insert into
344− -> Query schema params (TableToRow table)
345− -> ConflictClause schema table params
346− -- ^ what to do in case of constraint conflict
347− -> ReturningClause schema params row results -- ^ results to return
348− -> Manipulation schema params results
349−insertQuery tab query conflict returning = UnsafeManipulation $
350− "INSERT" <+> "INTO" <+> renderAlias tab
351− <> renderConflictAlias conflict
352− <+> renderQuery query
353− <> renderConflictClause conflict
354− <> renderReturningClause returning
355−
356−-- | Insert a `Query` returning `Nil` and raising an error on conflicts.
357−insertQuery_
358− :: ( SOP.SListI columns
359− , Has tab schema ('Table table)
360− , columns ~ TableToColumns table )
361− => Alias tab -- ^ table to insert into
362− -> Query schema params (TableToRow table)
292+ , SOP.SListI columns )
293+ => Alias tab
294+ -> QueryClause schema params columns
363295 -> Manipulation schema params '[]
364−insertQuery_ tab query =
365− insertQuery tab query OnConflictDoRaise (Returning Nil)
366−
367−-- | `ColumnValue`s are values to insert or update in a row.
368−-- `Default` inserts or updates with the @DEFAULT@ value.
369−-- `Set` sets a value to be an `Expression`, which can refer to
370−-- existing value in the row for an update.
371−data ColumnValue
372− (schema :: SchemaType)
373− (tables :: FromType)
374− (params :: [NullityType])
375− (ty :: ColumnType)
296+insertInto_ tab qry =
297+ insertInto tab qry OnConflictDoRaise (Returning Nil)
298+
299+data QueryClause schema params columns where
300+ Values
301+ :: SOP.SListI columns
302+ => NP (ColumnExpression schema '[] 'Ungrouped params) columns
303+ -> [NP (ColumnExpression schema '[] 'Ungrouped params) columns]
304+ -> QueryClause schema params columns
305+ Select
306+ :: SOP.SListI columns
307+ => NP (ColumnExpression schema from grp params) columns
308+ -> TableExpression schema params from grp
309+ -> QueryClause schema params columns
310+ Subquery
311+ :: ColumnsToRow columns ~ row
312+ => Query schema params row
313+ -> QueryClause schema params columns
314+
315+renderQueryClause
316+ :: QueryClause schema params columns
317+ -> ByteString
318+renderQueryClause = \case
319+ Values row0 rows ->
320+ parenthesized (renderCommaSeparated renderAliasPart row0)
321+ <+> "VALUES"
322+ <+> commaSeparated
323+ ( parenthesized
324+ . renderCommaSeparated renderValuePart <$> row0 : rows )
325+ Select row0 tab ->
326+ parenthesized (renderCommaSeparated renderAliasPart row0)
327+ <+> "SELECT"
328+ <+> renderCommaSeparated renderValuePart row0
329+ <+> renderTableExpression tab
330+ Subquery qry -> renderQuery qry
376331 where
377− Default :: ColumnValue schema tables params ('Def :=> ty)
378− Set
379− :: Expression schema tables 'Ungrouped params ty
380− -> ColumnValue schema tables params (constraint :=> ty)
332+ renderAliasPart, renderValuePart
333+ :: ColumnExpression schema from grp params column -> ByteString
334+ renderAliasPart = \case
335+ DefaultAs name -> renderAlias name
336+ Specific (_ `As` name) -> renderAlias name
337+ renderValuePart = \case
338+ DefaultAs _ -> "DEFAULT"
339+ Specific (value `As` _) -> renderExpression value
340+
341+pattern Values_
342+ :: SOP.SListI columns
343+ => NP (ColumnExpression schema '[] 'Ungrouped params) columns
344+ -> QueryClause schema params columns
345+pattern Values_ vals = Values vals []
346+
347+data ColumnExpression schema from grp params column where
348+ DefaultAs
349+ :: KnownSymbol col
350+ => Alias col
351+ -> ColumnExpression schema from grp params (col ::: 'Def :=> ty)
352+ Specific
353+ :: Aliased (Expression schema from grp params) (col ::: ty)
354+ -> ColumnExpression schema from grp params (col ::: defness :=> ty)
355+
356+instance (KnownSymbol alias, column ~ (alias ::: defness :=> ty))
357+ => Aliasable alias
358+ (Expression schema from grp params ty)
359+ (ColumnExpression schema from grp params column)
360+ where
361+ expression `as` alias = Specific (expression `As` alias)
362+instance (KnownSymbol alias, columns ~ '[alias ::: defness :=> ty])
363+ => Aliasable alias
364+ (Expression schema from grp params ty)
365+ (NP (ColumnExpression schema from grp params) columns)
366+ where
367+ expression `as` alias = expression `as` alias :* Nil
368+instance (KnownSymbol col, column ~ (col ::: 'Def :=> ty))
369+ => DefaultAliasable col (ColumnExpression schema from grp params column) where
370+ defaultAs = DefaultAs
371+instance (KnownSymbol col, columns ~ '[col ::: 'Def :=> ty])
372+ => DefaultAliasable col (NP (ColumnExpression schema from grp params) columns) where
373+ defaultAs col = defaultAs col :* Nil
374+
375+renderColumnExpression
376+ :: ColumnExpression schema from grp params column
377+ -> ByteString
378+renderColumnExpression = \case
379+ DefaultAs col ->
380+ renderAlias col <+> "=" <+> "DEFAULT"
381+ Specific (expression `As` col) ->
382+ renderAlias col <+> "=" <+> renderExpression expression
381383
382384-- | A `ReturningClause` computes and return value(s) based
383385-- on each row actually inserted, updated or deleted. This is primarily
@@ -417,74 +419,61 @@ renderReturningClause = \case
417419-- `OnConflictDoNothing` simply avoids inserting a row.
418420-- `OnConflictDoUpdate` updates the existing row that conflicts with the row
419421-- proposed for insertion.
420−data ConflictClause
421− (schema :: SchemaType)
422− (table :: TableType)
423− (params :: [NullityType]) where
424− OnConflictDoRaise :: ConflictClause schema table params
425− OnConflictDoNothing :: ConflictClause schema table params
426− OnConflictDoUpdate
427− :: ( row ~ TableToRow table, SOP.SListI columns, columns ~ (col0 ': cols)
428− , OrderedSubsetOf (TableToColumns table) columns )
429− => ConflictTarget table
430− -> NP (Aliased (ColumnValue schema '["existing" ::: row, "excluded" ::: row] params)) columns
431− -> [Condition schema '["existing" ::: row, "excluded" ::: row] 'Ungrouped params]
432− -> ConflictClause schema table params
433−
434−-- | A `ConflictTarget` specifies the constraint violation that triggers an
435−-- `OnConflictDoUpdate`.
436−data ConflictTarget (table :: TableType) where
437− -- | An explicitly named constraint.
438− OnConstraint
439− :: (Has constraintName constraints constraint)
440− => Alias constraintName
441− -> ConflictTarget '(constraints, columns)
442− -- | Match each unique index with precisely the following columns.
443− UniqueIndexOn
444− :: ( HasAll columnNames columns columnTypes
445− , SOP.All KnownSymbol columnNames )
446− => NP Alias columnNames
447− -> ConflictTarget '(constraints, columns)
448−
449−-- | Render any table alias required for a `ConflictClause`.
450−renderConflictAlias :: ConflictClause schema table params -> ByteString
451−renderConflictAlias = \case
452− OnConflictDoUpdate _ _ _ -> " AS existing"
453− _ -> ""
422+data ConflictClause schema params table where
423+ OnConflictDoRaise :: ConflictClause schema params table
424+ OnConflict
425+ :: ConflictTarget constraints
426+ -> ConflictAction schema params columns
427+ -> ConflictClause schema params (constraints :=> columns)
454428
455429-- | Render a `ConflictClause`.
456430renderConflictClause
457431 :: SOP.SListI (TableToColumns table)
458− => ConflictClause schema table params
432+ => ConflictClause schema params table
459433 -> ByteString
460434renderConflictClause = \case
461435 OnConflictDoRaise -> ""
462− OnConflictDoNothing -> " ON CONFLICT DO NOTHING"
463− OnConflictDoUpdate target updates whs'
464− -> " ON CONFLICT"
465− <+> renderTarget target
466− <+> "DO UPDATE SET"
467− <+> renderCommaSeparated renderUpdate updates
436+ OnConflict target action -> " ON CONFLICT"
437+ <+> renderConflictTarget target <+> renderConflictAction action
438+
439+data ConflictAction schema params columns where
440+ DoNothing :: ConflictAction schema params columns
441+ DoUpdate
442+ :: ( row ~ ColumnsToRow columns
443+ , SOP.SListI columns
444+ , columns ~ (col0 ': cols)
445+ , SOP.All (HasIn columns) subcolumns
446+ , AllUnique subcolumns )
447+ => NP (ColumnExpression schema '[t ::: row] 'Ungrouped params) subcolumns
448+ -> [Condition schema '[t ::: row] 'Ungrouped params]
449+ -> ConflictAction schema params columns
450+
451+renderConflictAction
452+ :: ConflictAction schema params columns
453+ -> ByteString
454+renderConflictAction = \case
455+ DoNothing -> "DO NOTHING"
456+ DoUpdate updates whs'
457+ -> "DO UPDATE SET"
458+ <+> renderCommaSeparated renderColumnExpression updates
468459 <> case whs' of
469460 [] -> ""
470461 wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)
471− where
472− renderUpdate
473− :: Aliased (ColumnValue schema columns params) column
474− -> ByteString
475− renderUpdate = \case
476− Default `As` column ->
477− renderAlias column <+> "=" <+> "DEFAULT"
478− Set expression `As` column ->
479− renderAlias column <+> "=" <+> renderExpression expression
480− renderTarget
481− :: ConflictTarget table
482− -> ByteString
483− renderTarget = \case
484− OnConstraint name ->
485− "ON CONSTRAINT" <+> renderAlias name
486− UniqueIndexOn columns ->
487− parenthesized (commaSeparated (renderAliases columns))
462+
463+-- | A `ConflictTarget` specifies the constraint violation that triggers a
464+-- `ConflictAction`.
465+data ConflictTarget constraints where
466+ OnConstraint
467+ :: Has con constraints constraint
468+ => Alias con
469+ -> ConflictTarget constraints
470+
471+-- | Render a `ConflictTarget`
472+renderConflictTarget
473+ :: ConflictTarget constraints
474+ -> ByteString
475+renderConflictTarget (OnConstraint con) =
476+ "ON" <+> "CONSTRAINT" <+> renderAlias con
488477
489478{-----------------------------------------
490479UPDATE statements
@@ -517,12 +506,13 @@ update
517506 , SOP.SListI results
518507 , Has tab schema ('Table table)
519508 , row ~ TableToRow table
520− , columns ~ (col0 ': cols)
521− , OrderedSubsetOf (TableToColumns table) columns )
509+ , columns ~ TableToColumns table
510+ , SOP.All (HasIn columns) subcolumns
511+ , AllUnique subcolumns )
522512 => Alias tab -- ^ table to update
523− -> (forall t. NP (Aliased (ColumnValue schema '[t ::: row] params)) columns)
513+ -> NP (ColumnExpression schema '[tab ::: row] 'Ungrouped params) subcolumns
524514 -- ^ modified values to replace old values
525− -> (forall t. Condition schema '[t ::: row] 'Ungrouped params)
515+ -> Condition schema '[tab ::: row] 'Ungrouped params
526516 -- ^ condition under which to perform update on a row
527517 -> ReturningClause schema params row results -- ^ results to return
528518 -> Manipulation schema params results
@@ -530,30 +520,22 @@ update tab columns wh returning = UnsafeManipulation $
530520 "UPDATE"
531521 <+> renderAlias tab
532522 <+> "SET"
533− <+> renderCommaSeparated renderUpdate columns
523+ <+> renderCommaSeparated renderColumnExpression columns
534524 <+> "WHERE" <+> renderExpression wh
535525 <> renderReturningClause returning
536− where
537− renderUpdate
538− :: Aliased (ColumnValue schema columns params) column
539− -> ByteString
540− renderUpdate = \case
541− Default `As` column ->
542− renderAlias column <+> "=" <+> "DEFAULT"
543− Set expression `As` column ->
544− renderAlias column <+> "=" <+> renderExpression expression
545526
546527-- | Update a row returning `Nil`.
547528update_
548529 :: ( SOP.SListI columns
549530 , Has tab schema ('Table table)
550531 , row ~ TableToRow table
551− , columns ~ (col0 ': cols)
552− , OrderedSubsetOf (TableToColumns table) columns )
532+ , columns ~ TableToColumns table
533+ , SOP.All (HasIn columns) subcolumns
534+ , AllUnique subcolumns )
553535 => Alias tab -- ^ table to update
554− -> (forall t. NP (Aliased (ColumnValue schema '[t ::: row] params)) columns)
536+ -> NP (ColumnExpression schema '[tab ::: row] 'Ungrouped params) subcolumns
555537 -- ^ modified values to replace old values
556− -> (forall t. Condition schema '[t ::: row] 'Ungrouped params)
538+ -> Condition schema '[tab ::: row] 'Ungrouped params
557539 -- ^ condition under which to perform update on a row
558540 -> Manipulation schema params '[]
559541update_ tab columns wh = update tab columns wh (Returning Nil)