@@ -11,13 +11,18 @@ Squeal data manipulation language.
1111{-# LANGUAGE
1212 DeriveGeneric
1313 , FlexibleContexts
14+ , FlexibleInstances
1415 , GADTs
1516 , GeneralizedNewtypeDeriving
1617 , LambdaCase
18+ , MultiParamTypeClasses
1719 , OverloadedStrings
1820 , RankNTypes
21+ , TypeFamilies
1922 , TypeInType
2023 , TypeOperators
24+ , UndecidableInstances
25+ , UndecidableSuperClasses
2126#-}
2227
2328module Squeal.PostgreSQL.Manipulation
@@ -47,7 +52,8 @@ module Squeal.PostgreSQL.Manipulation
4752
4853import Control.DeepSeq
4954import Data.ByteString hiding (foldr)
50−import GHC.TypeLits (KnownSymbol)
55+import Data.Kind (Constraint)
56+import GHC.TypeLits (ErrorMessage (..), KnownSymbol, Symbol, TypeError)
5157
5258import qualified Generics.SOP as SOP
5359import qualified GHC.Generics as GHC
@@ -123,7 +129,7 @@ let
123129 [Set 6 `as` #col1 :* Set 8 `as` #col2]
124130 (OnConflictDoUpdate
125131 (UniqueIndexOn #col1)
126− (Set 2 `as` #col1 :* Same `as` #col2)
132+ (Set 2 `as` #col1)
127133 [#existing ! #col1 .== #excluded ! #col2])
128134 (Returning $ (#col1 + #col2) `as` #sum)
129135in printSQL manipulation
@@ -160,7 +166,7 @@ let
160166 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4
161167 , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[]
162168 manipulation =
163− update_ #tab (Set 2 `as` #col1 :* Same `as` #col2)
169+ update_ #tab (Set 2 `as` #col1)
164170 (#col1 ./= #col2)
165171in printSQL manipulation
166172:}
@@ -330,7 +336,6 @@ insertQuery_ tab query =
330336 insertQuery tab query OnConflictDoRaise (Returning Nil)
331337
332338-- | `ColumnValue`s are values to insert or update in a row.
333−-- `Same` updates with the same value.
334339-- `Default` inserts or updates with the @DEFAULT@ value.
335340-- `Set` sets a value to be an `Expression`, which can refer to
336341-- existing value in the row for an update.
@@ -340,7 +345,6 @@ data ColumnValue
340345 (params :: [NullityType])
341346 (ty :: ColumnType)
342347 where
343− Same :: ColumnValue schema (table ': tables) params ty
344348 Default :: ColumnValue schema tables params ('Def :=> ty)
345349 Set
346350 :: Expression schema tables 'Ungrouped params ty
@@ -391,7 +395,8 @@ data ConflictClause
391395 OnConflictDoRaise :: ConflictClause schema table params
392396 OnConflictDoNothing :: ConflictClause schema table params
393397 OnConflictDoUpdate
394− :: (row ~ TableToRow table, columns ~ TableToColumns table)
398+ :: ( row ~ TableToRow table, SOP.SListI columns, columns ~ (col0 ': cols)
399+ , OrderedSubsetOf (TableToColumns table) columns )
395400 => ConflictTarget table
396401 -> NP (Aliased (ColumnValue schema '["existing" ::: row, "excluded" ::: row] params)) columns
397402 -> [Condition schema '["existing" ::: row, "excluded" ::: row] 'Ungrouped params]
@@ -430,19 +435,18 @@ renderConflictClause = \case
430435 -> " ON CONFLICT"
431436 <+> renderTarget target
432437 <+> "DO UPDATE SET"
433− <+> renderCommaSeparatedMaybe renderUpdate updates
438+ <+> renderCommaSeparated renderUpdate updates
434439 <> case whs' of
435440 [] -> ""
436441 wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)
437442 where
438443 renderUpdate
439444 :: Aliased (ColumnValue schema columns params) column
440− -> Maybe ByteString
445+ -> ByteString
441446 renderUpdate = \case
442− Same `As` _ -> Nothing
443− Default `As` column -> Just $
447+ Default `As` column ->
444448 renderAlias column <+> "=" <+> "DEFAULT"
445− Set expression `As` column -> Just $
449+ Set expression `As` column ->
446450 renderAlias column <+> "=" <+> renderExpression expression
447451 renderTarget
448452 :: ConflictTarget table
@@ -457,6 +461,26 @@ renderConflictClause = \case
457461UPDATE statements
458462-----------------------------------------}
459463
464+-- In order to guide type inference, also enforces that a key appearing in
465+-- the common subset prefix of both sup and sub maps to the same value (type).
466+type family OrderedSubsetOf'
467+ (origSup :: [(Symbol, a)]) (origSub :: [(Symbol, a)])
468+ (sup :: [(Symbol, a)]) (sub :: [(Symbol, a)])
469+ :: Constraint where
470+ OrderedSubsetOf' _ _ _ '[] = ()
471+ OrderedSubsetOf' sup sub ('(xk, xv) ': xs) ('(xk, yv) ': ys) =
472+ (xv ~ yv, OrderedSubsetOf' sup sub xs ys)
473+ OrderedSubsetOf' sup sub (x ': xs) (y ': ys) =
474+ OrderedSubsetOf' sup sub xs (y ': ys)
475+ OrderedSubsetOf' sup sub '[] _ = TypeError
476+ ( 'Text "The type"
477+ ':$$: 'ShowType sub
478+ ':$$: 'Text "is not an ordered subset of"
479+ ':$$: 'ShowType sup)
480+
481+class (OrderedSubsetOf' sup sub sup sub) => OrderedSubsetOf sup sub where
482+instance (OrderedSubsetOf' sup sub sup sub) => OrderedSubsetOf sup sub where
483+
460484-- | An `update` command changes the values of the specified columns
461485-- in all rows that satisfy the condition.
462486update
@@ -464,7 +488,8 @@ update
464488 , SOP.SListI results
465489 , Has tab schema ('Table table)
466490 , row ~ TableToRow table
467− , columns ~ TableToColumns table )
491+ , columns ~ (col0 ': cols)
492+ , OrderedSubsetOf (TableToColumns table) columns )
468493 => Alias tab -- ^ table to update
469494 -> (forall t. NP (Aliased (ColumnValue schema '[t ::: row] params)) columns)
470495 -- ^ modified values to replace old values
@@ -476,18 +501,17 @@ update tab columns wh returning = UnsafeManipulation $
476501 "UPDATE"
477502 <+> renderAlias tab
478503 <+> "SET"
479− <+> renderCommaSeparatedMaybe renderUpdate columns
504+ <+> renderCommaSeparated renderUpdate columns
480505 <+> "WHERE" <+> renderExpression wh
481506 <> renderReturningClause returning
482507 where
483508 renderUpdate
484509 :: Aliased (ColumnValue schema columns params) column
485− -> Maybe ByteString
510+ -> ByteString
486511 renderUpdate = \case
487− Same `As` _ -> Nothing
488− Default `As` column -> Just $
512+ Default `As` column ->
489513 renderAlias column <+> "=" <+> "DEFAULT"
490− Set expression `As` column -> Just $
514+ Set expression `As` column ->
491515 renderAlias column <+> "=" <+> renderExpression expression
492516
493517-- | Update a row returning `Nil`.
@@ -495,7 +519,8 @@ update_
495519 :: ( SOP.SListI columns
496520 , Has tab schema ('Table table)
497521 , row ~ TableToRow table
498− , columns ~ TableToColumns table )
522+ , columns ~ (col0 ': cols)
523+ , OrderedSubsetOf (TableToColumns table) columns )
499524 => Alias tab -- ^ table to update
500525 -> (forall t. NP (Aliased (ColumnValue schema '[t ::: row] params)) columns)
501526 -- ^ modified values to replace old values