0f8936c · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

Require update values to be ordered subset of row, remove Same

0f8936cRhys8 years ago

squeal-postgresql/src/Squeal/PostgreSQL/Manipulation.hs+43−18

compare with dev

unifiedsplit

@@ -11,13 +11,18 @@ Squeal data manipulation language.

11{-# LANGUAGE

12 DeriveGeneric

13 , FlexibleContexts

14+ , FlexibleInstances

14 , GADTs

15 , GADTs

15 , GeneralizedNewtypeDeriving

16 , GeneralizedNewtypeDeriving

16 , LambdaCase

17 , LambdaCase

18+ , MultiParamTypeClasses

17 , OverloadedStrings

19 , OverloadedStrings

18 , RankNTypes

20 , RankNTypes

21+ , TypeFamilies

19 , TypeInType

22 , TypeInType

20 , TypeOperators

23 , TypeOperators

24+ , UndecidableInstances

25+ , UndecidableSuperClasses

21#-}

26#-}

23module Squeal.PostgreSQL.Manipulation

28module Squeal.PostgreSQL.Manipulation

@@ -47,7 +52,8 @@ module Squeal.PostgreSQL.Manipulation

48import Control.DeepSeq

53import Control.DeepSeq

49import Data.ByteString hiding (foldr)

54import Data.ByteString hiding (foldr)

55+import Data.Kind (Constraint)

50−import GHC.TypeLits (KnownSymbol)

56+import GHC.TypeLits (ErrorMessage (..), KnownSymbol, Symbol, TypeError)

52import qualified Generics.SOP as SOP

58import qualified Generics.SOP as SOP

53import qualified GHC.Generics as GHC

59import qualified GHC.Generics as GHC

@@ -123,7 +129,7 @@ let

123 [Set 6 `as` #col1 :* Set 8 `as` #col2]

129 [Set 6 `as` #col1 :* Set 8 `as` #col2]

124 (OnConflictDoUpdate

130 (OnConflictDoUpdate

125 (UniqueIndexOn #col1)

131 (UniqueIndexOn #col1)

126− (Set 2 `as` #col1 :* Same `as` #col2)

132+ (Set 2 `as` #col1)

127 [#existing ! #col1 .== #excluded ! #col2])

133 [#existing ! #col1 .== #excluded ! #col2])

128 (Returning $ (#col1 + #col2) `as` #sum)

134 (Returning $ (#col1 + #col2) `as` #sum)

129in printSQL manipulation

135in printSQL manipulation

@@ -160,7 +166,7 @@ let

160 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

166 '[ "col1" ::: 'NoDef :=> 'NotNull 'PGint4

161 , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[]

167 , "col2" ::: 'NoDef :=> 'NotNull 'PGint4 ])] '[] '[]

162 manipulation =

168 manipulation =

163− update_ #tab (Set 2 `as` #col1 :* Same `as` #col2)

169+ update_ #tab (Set 2 `as` #col1)

164 (#col1 ./= #col2)

170 (#col1 ./= #col2)

165in printSQL manipulation

171in printSQL manipulation

166:}

172:}

@@ -330,7 +336,6 @@ insertQuery_ tab query =

330 insertQuery tab query OnConflictDoRaise (Returning Nil)

336 insertQuery tab query OnConflictDoRaise (Returning Nil)

331

337

332-- | `ColumnValue`s are values to insert or update in a row.

338-- | `ColumnValue`s are values to insert or update in a row.

333−-- `Same` updates with the same value.

334-- `Default` inserts or updates with the @DEFAULT@ value.

339-- `Default` inserts or updates with the @DEFAULT@ value.

335-- `Set` sets a value to be an `Expression`, which can refer to

340-- `Set` sets a value to be an `Expression`, which can refer to

336-- existing value in the row for an update.

341-- existing value in the row for an update.

@@ -340,7 +345,6 @@ data ColumnValue

340 (params :: [NullityType])

345 (params :: [NullityType])

341 (ty :: ColumnType)

346 (ty :: ColumnType)

342 where

347 where

343− Same :: ColumnValue schema (table ': tables) params ty

344 Default :: ColumnValue schema tables params ('Def :=> ty)

348 Default :: ColumnValue schema tables params ('Def :=> ty)

345 Set

349 Set

346 :: Expression schema tables 'Ungrouped params ty

350 :: Expression schema tables 'Ungrouped params ty

@@ -391,7 +395,8 @@ data ConflictClause

391 OnConflictDoRaise :: ConflictClause schema table params

395 OnConflictDoRaise :: ConflictClause schema table params

392 OnConflictDoNothing :: ConflictClause schema table params

396 OnConflictDoNothing :: ConflictClause schema table params

393 OnConflictDoUpdate

397 OnConflictDoUpdate

394− :: (row ~ TableToRow table, columns ~ TableToColumns table)

398+ :: ( row ~ TableToRow table, SOP.SListI columns, columns ~ (col0 ': cols)

399+ , OrderedSubsetOf (TableToColumns table) columns )

395 => ConflictTarget table

400 => ConflictTarget table

396 -> NP (Aliased (ColumnValue schema '["existing" ::: row, "excluded" ::: row] params)) columns

401 -> NP (Aliased (ColumnValue schema '["existing" ::: row, "excluded" ::: row] params)) columns

397 -> [Condition schema '["existing" ::: row, "excluded" ::: row] 'Ungrouped params]

402 -> [Condition schema '["existing" ::: row, "excluded" ::: row] 'Ungrouped params]

@@ -430,19 +435,18 @@ renderConflictClause = \case

430 -> " ON CONFLICT"

435 -> " ON CONFLICT"

431 <+> renderTarget target

436 <+> renderTarget target

432 <+> "DO UPDATE SET"

437 <+> "DO UPDATE SET"

433− <+> renderCommaSeparatedMaybe renderUpdate updates

438+ <+> renderCommaSeparated renderUpdate updates

434 <> case whs' of

439 <> case whs' of

435 [] -> ""

440 [] -> ""

436 wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)

441 wh:whs -> " WHERE" <+> renderExpression (foldr (.&&) wh whs)

437 where

442 where

438 renderUpdate

443 renderUpdate

439 :: Aliased (ColumnValue schema columns params) column

444 :: Aliased (ColumnValue schema columns params) column

440− -> Maybe ByteString

445+ -> ByteString

441 renderUpdate = \case

446 renderUpdate = \case

442− Same `As` _ -> Nothing

443− Default `As` column -> Just $

447+ Default `As` column ->

444 renderAlias column <+> "=" <+> "DEFAULT"

448 renderAlias column <+> "=" <+> "DEFAULT"

445− Set expression `As` column -> Just $

449+ Set expression `As` column ->

446 renderAlias column <+> "=" <+> renderExpression expression

450 renderAlias column <+> "=" <+> renderExpression expression

447 renderTarget

451 renderTarget

448 :: ConflictTarget table

452 :: ConflictTarget table

@@ -457,6 +461,26 @@ renderConflictClause = \case

457UPDATE statements

461UPDATE statements

458-----------------------------------------}

462-----------------------------------------}

459

463

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+

460-- | An `update` command changes the values of the specified columns

484-- | An `update` command changes the values of the specified columns

461-- in all rows that satisfy the condition.

485-- in all rows that satisfy the condition.

462update

486update

@@ -464,7 +488,8 @@ update

464 , SOP.SListI results

488 , SOP.SListI results

465 , Has tab schema ('Table table)

489 , Has tab schema ('Table table)

466 , row ~ TableToRow table

490 , row ~ TableToRow table

491+ , columns ~ (col0 ': cols)

467− , columns ~ TableToColumns table )

492+ , OrderedSubsetOf (TableToColumns table) columns )

468 => Alias tab -- ^ table to update

493 => Alias tab -- ^ table to update

469 -> (forall t. NP (Aliased (ColumnValue schema '[t ::: row] params)) columns)

494 -> (forall t. NP (Aliased (ColumnValue schema '[t ::: row] params)) columns)

470 -- ^ modified values to replace old values

495 -- ^ modified values to replace old values

@@ -476,18 +501,17 @@ update tab columns wh returning = UnsafeManipulation $

476 "UPDATE"

501 "UPDATE"

477 <+> renderAlias tab

502 <+> renderAlias tab

478 <+> "SET"

503 <+> "SET"

479− <+> renderCommaSeparatedMaybe renderUpdate columns

504+ <+> renderCommaSeparated renderUpdate columns

480 <+> "WHERE" <+> renderExpression wh

505 <+> "WHERE" <+> renderExpression wh

481 <> renderReturningClause returning

506 <> renderReturningClause returning

482 where

507 where

483 renderUpdate

508 renderUpdate

484 :: Aliased (ColumnValue schema columns params) column

509 :: Aliased (ColumnValue schema columns params) column

485− -> Maybe ByteString

510+ -> ByteString

486 renderUpdate = \case

511 renderUpdate = \case

487− Same `As` _ -> Nothing

488− Default `As` column -> Just $

512+ Default `As` column ->

489 renderAlias column <+> "=" <+> "DEFAULT"

513 renderAlias column <+> "=" <+> "DEFAULT"

490− Set expression `As` column -> Just $

514+ Set expression `As` column ->

491 renderAlias column <+> "=" <+> renderExpression expression

515 renderAlias column <+> "=" <+> renderExpression expression

492

516

493-- | Update a row returning `Nil`.

517-- | Update a row returning `Nil`.

@@ -495,7 +519,8 @@ update_

495 :: ( SOP.SListI columns

519 :: ( SOP.SListI columns

496 , Has tab schema ('Table table)

520 , Has tab schema ('Table table)

497 , row ~ TableToRow table

521 , row ~ TableToRow table

522+ , columns ~ (col0 ': cols)

498− , columns ~ TableToColumns table )

523+ , OrderedSubsetOf (TableToColumns table) columns )

499 => Alias tab -- ^ table to update

524 => Alias tab -- ^ table to update

500 -> (forall t. NP (Aliased (ColumnValue schema '[t ::: row] params)) columns)

525 -> (forall t. NP (Aliased (ColumnValue schema '[t ::: row] params)) columns)

501 -- ^ modified values to replace old values

526 -- ^ modified values to replace old values

squeal-postgresql/src/Squeal/PostgreSQL/Render.hs−15

@@ -16,7 +16,6 @@ Rendering helper functions.

16 , PolyKinds

17 , RankNTypes

18 , ScopedTypeVariables

19− , TypeApplications

20#-}

19#-}

22module Squeal.PostgreSQL.Render

21module Squeal.PostgreSQL.Render

@@ -28,7 +27,6 @@ module Squeal.PostgreSQL.Render

28 , singleQuotedText

27 , singleQuotedText

29 , singleQuotedUtf8

28 , singleQuotedUtf8

30 , renderCommaSeparated

29 , renderCommaSeparated

31− , renderCommaSeparatedMaybe

32 , renderNat

30 , renderNat

33 , renderSymbol

31 , renderSymbol

34 , RenderSQL (..)

32 , RenderSQL (..)

@@ -37,7 +35,6 @@ module Squeal.PostgreSQL.Render

38import Control.Monad.Base

36import Control.Monad.Base

39import Data.ByteString (ByteString)

37import Data.ByteString (ByteString)

40−import Data.Maybe

41import Data.Monoid ((<>))

38import Data.Monoid ((<>))

42import Data.Text (Text)

39import Data.Text (Text)

43import Generics.SOP

40import Generics.SOP

@@ -83,18 +80,6 @@ renderCommaSeparated render

83 . hcollapse

80 . hcollapse

84 . hmap (K . render)

81 . hmap (K . render)

86−-- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping

87−-- `Nothing`s.

88−renderCommaSeparatedMaybe

89− :: SListI xs

90− => (forall x. expression x -> Maybe ByteString)

91− -> NP expression xs -> ByteString

92−renderCommaSeparatedMaybe render

93− = commaSeparated

94− . catMaybes

95− . hcollapse

96− . hmap (K . render)

97−

98-- | Render a promoted `Nat`.

83-- | Render a promoted `Nat`.

99renderNat :: forall n. KnownNat n => ByteString

84renderNat :: forall n. KnownNat n => ByteString

100renderNat = fromString (show (natVal' (proxy# :: Proxy# n)))

85renderNat = fromString (show (natVal' (proxy# :: Proxy# n)))