diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,21 @@ +# 1.2.0.0 (2021-10-22) + +## New features + +* New `$*` and `$+` operators for projecting out of `ListTable` and `NonEmptyTable` respectively (analogous to the existing `$?` for `MaybeTable`). ([#125](https://github.com/circuithub/rel8/pull/125)) + +## Bug fixes + +* Fix `UPSERT` support (and add tests), which was broken due to a typo inside Rel8 that made it impossible to construct `Projection`s which are needed by `UPSERT`. ([#134](https://github.com/circuithub/rel8/pull/134)) + +* Remove `DBMin` and `DBMax` instances for `Bool`, which are invalid as far as Postgres is concerned. `and` and `or` can be used to achieve the same thing. ([#126](https://github.com/circuithub/rel8/pull/126)) + +* Fix `aggregateMaybeTable`, `aggregateEitherTable` and `aggregateTheseTable`, which generated invalid SQL previously. ([#127](https://github.com/circuithub/rel8/pull/127)) + +## Breaking changes + +* `rebind` now takes an additional argument for the "name" of the binding. ([#128](https://github.com/circuithub/rel8/pull/128)) + # 1.1.0.0 (2021-07-16) ## New features diff --git a/rel8.cabal b/rel8.cabal --- a/rel8.cabal +++ b/rel8.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: rel8 -version: 1.1.0.0 +version: 1.2.0.0 synopsis: Hey! Hey! Can u rel8? license: BSD3 license-file: LICENSE @@ -113,6 +113,7 @@ Rel8.Query.Null Rel8.Query.Opaleye Rel8.Query.Order + Rel8.Query.Rebind Rel8.Query.Set Rel8.Query.SQL Rel8.Query.These diff --git a/src/Rel8.hs b/src/Rel8.hs --- a/src/Rel8.hs +++ b/src/Rel8.hs @@ -90,7 +90,7 @@ -- ** @ListTable@ , ListTable - , listTable + , listTable, ($*) , nameListTable , many , manyExpr @@ -99,7 +99,7 @@ -- ** @NonEmptyTable@ , NonEmptyTable - , nonEmptyTable + , nonEmptyTable, ($+) , nameNonEmptyTable , some , someExpr @@ -331,6 +331,7 @@ import Rel8.Query.Maybe import Rel8.Query.Null import Rel8.Query.Order +import Rel8.Query.Rebind import Rel8.Query.SQL (showQuery) import Rel8.Query.Set import Rel8.Query.These diff --git a/src/Rel8/Aggregate.hs b/src/Rel8/Aggregate.hs --- a/src/Rel8/Aggregate.hs +++ b/src/Rel8/Aggregate.hs @@ -9,14 +9,14 @@ {-# language UndecidableInstances #-} module Rel8.Aggregate - ( Aggregate(..), foldInputs, mapInputs + ( Aggregate(..), zipOutputs , Aggregator(..), unsafeMakeAggregate , Aggregates ) where -- base -import Data.Functor.Const ( Const( Const ), getConst ) +import Control.Applicative ( liftA2 ) import Data.Functor.Identity ( Identity( Identity ) ) import Data.Kind ( Constraint, Type ) import Prelude @@ -40,11 +40,7 @@ import Rel8.Type ( DBType ) --- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can --- unpack an @Aggregate@ back to @a@ by running it with 'Rel8.aggregate'. As --- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure' --- operation. This means 'Aggregate' is an instance of 'Apply', and you can --- combine @Aggregate@s using the @<.>@ combinator. +-- | 'Aggregate' is a special context used by 'Rel8.aggregate'. type Aggregate :: K.Context newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a)) @@ -61,28 +57,16 @@ fromResult (HIdentity (Identity a)) = a --- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's --- for the columns in @b@. +-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate's +-- for the 'Expr' columns in @b@. type Aggregates :: Type -> Type -> Constraint class Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs instance Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs -foldInputs :: forall (a :: Type) (b :: Type). Monoid b - => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b -foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) = - getConst $ flip agg () $ \(aggregator, a) -> - Const $ f (detuplize <$> aggregator) a - where - detuplize (operation, ordering, distinction) = - Aggregator {operation, ordering, distinction} - - -mapInputs :: forall (a :: Type). () - => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a -mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) = - Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input -> - f (fmap transform input) +zipOutputs :: () + => (Expr a -> Expr b -> Expr c) -> Aggregate a -> Aggregate b -> Aggregate c +zipOutputs f (Aggregate a) (Aggregate b) = Aggregate (liftA2 f a b) type Aggregator :: Type diff --git a/src/Rel8/Aggregate.hs-boot b/src/Rel8/Aggregate.hs-boot deleted file mode 100644 --- a/src/Rel8/Aggregate.hs-boot +++ /dev/null @@ -1,11 +0,0 @@ -{-# language PolyKinds #-} -{-# language RoleAnnotations #-} -{-# language StandaloneKindSignatures #-} - -module Rel8.Aggregate where - -import Data.Kind - -type Aggregate :: k -> Type -type role Aggregate nominal -data Aggregate a diff --git a/src/Rel8/Query/Evaluate.hs b/src/Rel8/Query/Evaluate.hs --- a/src/Rel8/Query/Evaluate.hs +++ b/src/Rel8/Query/Evaluate.hs @@ -3,7 +3,6 @@ module Rel8.Query.Evaluate ( evaluate - , rebind ) where @@ -16,28 +15,23 @@ -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -import qualified Opaleye.Internal.PackMap as Opaleye -import qualified Opaleye.Internal.PrimQuery as Opaleye -import qualified Opaleye.Internal.QueryArr as Opaleye -import qualified Opaleye.Internal.Tag as Opaleye -import qualified Opaleye.Internal.Unpackspec as Opaleye -- rel8 import Rel8.Expr ( Expr ) import Rel8.Expr.Bool ( (&&.) ) import Rel8.Expr.Opaleye ( fromPrimExpr ) import Rel8.Query ( Query( Query ) ) +import Rel8.Query.Rebind ( rebind ) import Rel8.Table ( Table ) import Rel8.Table.Bool ( case_ ) -import Rel8.Table.Opaleye ( unpackspec ) -import Rel8.Table.Undefined +import Rel8.Table.Undefined ( undefined ) -- | 'evaluate' takes expressions that could potentially have side effects and -- \"runs\" them in the 'Query' monad. The returned expressions have no side -- effects and can safely be reused. evaluate :: Table Expr a => a -> Query a -evaluate = laterally >=> rebind +evaluate = laterally >=> rebind "eval" laterally :: Table Expr a => a -> Query a @@ -49,19 +43,6 @@ condition = foldl1' (&&.) (fmap go bindings') where go = fromPrimExpr . Opaleye.UnExpr Opaleye.OpIsNotNull - - --- | 'rebind' takes some expressions, and binds each of them to a new --- variable in the SQL. The @a@ returned consists only of these --- variables. It's essentially a @let@ binding for Postgres expressions. -rebind :: Table Expr a => a -> Query a -rebind a = Query $ \_ -> Opaleye.QueryArr $ \(_, tag) -> - let - tag' = Opaleye.next tag - (a', bindings) = Opaleye.run $ - Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "eval" tag) a - in - ((mempty, a'), \_ -> Opaleye.Rebind True bindings, tag') foldl1' :: (a -> a -> a) -> NonEmpty a -> a diff --git a/src/Rel8/Query/List.hs b/src/Rel8/Query/List.hs --- a/src/Rel8/Query/List.hs +++ b/src/Rel8/Query/List.hs @@ -24,8 +24,8 @@ import Rel8.Expr.Opaleye ( mapPrimExpr ) import Rel8.Query ( Query ) import Rel8.Query.Aggregate ( aggregate ) -import Rel8.Query.Evaluate ( rebind ) import Rel8.Query.Maybe ( optional ) +import Rel8.Query.Rebind ( rebind ) import Rel8.Schema.HTable.Vectorize ( hunvectorize ) import Rel8.Schema.Null ( Sql, Unnullify ) import Rel8.Schema.Spec ( Spec( Spec, info ) ) @@ -85,8 +85,9 @@ -- -- @catListTable@ is an inverse to 'many'. catListTable :: Table Expr a => ListTable Expr a -> Query a -catListTable (ListTable as) = rebind $ fromColumns $ runIdentity $ - hunvectorize (\Spec {info} -> pure . sunnest info) as +catListTable (ListTable as) = + rebind "unnest" $ fromColumns $ runIdentity $ + hunvectorize (\Spec {info} -> pure . sunnest info) as -- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an @@ -94,8 +95,9 @@ -- -- @catNonEmptyTable@ is an inverse to 'some'. catNonEmptyTable :: Table Expr a => NonEmptyTable Expr a -> Query a -catNonEmptyTable (NonEmptyTable as) = rebind $ fromColumns $ runIdentity $ - hunvectorize (\Spec {info} -> pure . sunnest info) as +catNonEmptyTable (NonEmptyTable as) = + rebind "unnest" $ fromColumns $ runIdentity $ + hunvectorize (\Spec {info} -> pure . sunnest info) as -- | Expand an expression that contains a list into a 'Query', where each row @@ -103,7 +105,7 @@ -- -- @catList@ is an inverse to 'manyExpr'. catList :: Sql DBType a => Expr [a] -> Query (Expr a) -catList = rebind . sunnest typeInformation +catList = rebind "unnest" . sunnest typeInformation -- | Expand an expression that contains a non-empty list into a 'Query', where @@ -111,7 +113,7 @@ -- -- @catNonEmpty@ is an inverse to 'someExpr'. catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a) -catNonEmpty = rebind . sunnest typeInformation +catNonEmpty = rebind "unnest" . sunnest typeInformation sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a diff --git a/src/Rel8/Query/Rebind.hs b/src/Rel8/Query/Rebind.hs new file mode 100644 --- /dev/null +++ b/src/Rel8/Query/Rebind.hs @@ -0,0 +1,35 @@ +{-# language FlexibleContexts #-} + +module Rel8.Query.Rebind + ( rebind + ) +where + +-- base +import Prelude + +-- opaleye +import qualified Opaleye.Internal.PackMap as Opaleye +import qualified Opaleye.Internal.PrimQuery as Opaleye +import qualified Opaleye.Internal.QueryArr as Opaleye +import qualified Opaleye.Internal.Tag as Opaleye +import qualified Opaleye.Internal.Unpackspec as Opaleye + +-- rel8 +import Rel8.Expr ( Expr ) +import Rel8.Query ( Query( Query ) ) +import Rel8.Table ( Table ) +import Rel8.Table.Opaleye ( unpackspec ) + + +-- | 'rebind' takes a variable name, some expressions, and binds each of them +-- to a new variable in the SQL. The @a@ returned consists only of these +-- variables. It's essentially a @let@ binding for Postgres expressions. +rebind :: Table Expr a => String -> a -> Query a +rebind prefix a = Query $ \_ -> Opaleye.QueryArr $ \(_, tag) -> + let + tag' = Opaleye.next tag + (a', bindings) = Opaleye.run $ + Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr prefix tag) a + in + ((mempty, a'), \_ -> Opaleye.Rebind True bindings, tag') diff --git a/src/Rel8/Schema/Context/Nullify.hs b/src/Rel8/Schema/Context/Nullify.hs --- a/src/Rel8/Schema/Context/Nullify.hs +++ b/src/Rel8/Schema/Context/Nullify.hs @@ -18,18 +18,17 @@ import Data.Bool ( bool ) import Data.Functor.Identity ( Identity( Identity ) ) import Data.Kind ( Constraint, Type ) -import Data.Monoid ( getFirst ) import Prelude hiding ( null ) -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye -- rel8 -import Rel8.Aggregate ( Aggregate( Aggregate ), foldInputs, mapInputs ) +import Rel8.Aggregate ( Aggregate(..), zipOutputs ) import Rel8.Expr ( Expr ) import Rel8.Expr.Bool ( boolExpr ) import Rel8.Expr.Null ( nullify, unsafeUnnullify ) -import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr ) +import Rel8.Expr.Opaleye ( fromPrimExpr ) import Rel8.Kind.Context ( SContext(..) ) import Rel8.Schema.Field ( Field ) import qualified Rel8.Schema.Kind as K @@ -95,17 +94,10 @@ -> context (Maybe a) -> context (Maybe a) guarder = \case - SAggregate -> \tag _ isNonNull (Aggregate a) -> - let - mtag = foldInputs (\_ -> pure . fromPrimExpr) tag - run = maybe id (sguard . isNonNull) (getFirst mtag) - in - mapInputs (toPrimExpr . run . fromPrimExpr) $ - Aggregate $ - run <$> a - SExpr -> \tag _ isNonNull a -> sguard (isNonNull tag) a - SField -> \_ _ _ field -> field - SName -> \_ _ _ name -> name + SAggregate -> \tag _ isNonNull -> zipOutputs (sguard . isNonNull) tag + SExpr -> \tag _ isNonNull -> sguard (isNonNull tag) + SField -> \_ _ _ -> id + SName -> \_ _ _ -> id SResult -> \(Identity tag) isNonNull _ (Identity a) -> Identity (bool Nothing a (isNonNull tag)) diff --git a/src/Rel8/Schema/HTable/Vectorize.hs b/src/Rel8/Schema/HTable/Vectorize.hs --- a/src/Rel8/Schema/HTable/Vectorize.hs +++ b/src/Rel8/Schema/HTable/Vectorize.hs @@ -22,6 +22,7 @@ , hvectorize, hunvectorize , happend, hempty , hproject + , hcolumn ) where @@ -36,9 +37,11 @@ import Rel8.Schema.Dict ( Dict( Dict ) ) import qualified Rel8.Schema.Kind as K import Rel8.Schema.HTable ( HTable, hfield, htabulate, htabulateA, hspecs ) +import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) ) import Rel8.Schema.HTable.MapTable - ( HMapTable, HMapTableField( HMapTableField ) + ( HMapTable( HMapTable ), HMapTableField( HMapTableField ) , MapSpec, mapInfo + , Precompose( Precompose ) ) import qualified Rel8.Schema.HTable.MapTable as HMapTable ( hproject ) import Rel8.Schema.Null ( Unnullify, NotNull, Nullity( NotNull ) ) @@ -133,3 +136,7 @@ => (forall ctx. t ctx -> t' ctx) -> HVectorize list t context -> HVectorize list t' context hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a) + + +hcolumn :: HVectorize list (HIdentity a) context -> context (list a) +hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a diff --git a/src/Rel8/Schema/Name.hs-boot b/src/Rel8/Schema/Name.hs-boot deleted file mode 100644 --- a/src/Rel8/Schema/Name.hs-boot +++ /dev/null @@ -1,11 +0,0 @@ -{-# language PolyKinds #-} -{-# language RoleAnnotations #-} -{-# language StandaloneKindSignatures #-} - -module Rel8.Schema.Name where - -import Data.Kind ( Type ) - -type Name :: k -> Type -type role Name nominal -data Name a diff --git a/src/Rel8/Table/List.hs b/src/Rel8/Table/List.hs --- a/src/Rel8/Table/List.hs +++ b/src/Rel8/Table/List.hs @@ -11,7 +11,9 @@ module Rel8.Table.List ( ListTable(..) - , listTable, nameListTable + , ($*) + , listTable + , nameListTable ) where @@ -28,7 +30,7 @@ import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize , happend, hempty - , hproject + , hproject, hcolumn ) import qualified Rel8.Schema.Kind as K import Rel8.Schema.Name ( Name( Name ) ) @@ -46,7 +48,9 @@ ) import Rel8.Table.Eq ( EqTable, eqTable ) import Rel8.Table.Ord ( OrdTable, ordTable ) -import Rel8.Table.Projection ( Projectable, project, apply ) +import Rel8.Table.Projection + ( Projectable, Projecting, Projection, project, apply + ) import Rel8.Table.Serialize ( ToExprs ) @@ -114,6 +118,13 @@ Monoid (ListTable context a) where mempty = ListTable $ hempty $ \Spec {info} -> sempty info + + +-- | Project a single expression out of a 'ListTable'. +($*) :: Projecting a (Expr b) + => Projection a (Expr b) -> ListTable Expr a -> Expr [b] +f $* ListTable a = hcolumn $ hproject (apply f) a +infixl 4 $* -- | Construct a @ListTable@ from a list of expressions. diff --git a/src/Rel8/Table/NonEmpty.hs b/src/Rel8/Table/NonEmpty.hs --- a/src/Rel8/Table/NonEmpty.hs +++ b/src/Rel8/Table/NonEmpty.hs @@ -11,7 +11,9 @@ module Rel8.Table.NonEmpty ( NonEmptyTable(..) - , nonEmptyTable, nameNonEmptyTable + , ($+) + , nonEmptyTable + , nameNonEmptyTable ) where @@ -29,7 +31,7 @@ import Rel8.Schema.HTable.Vectorize ( hvectorize, hunvectorize , happend - , hproject + , hproject, hcolumn ) import qualified Rel8.Schema.Kind as K import Rel8.Schema.Name ( Name( Name ) ) @@ -44,7 +46,9 @@ import Rel8.Table.Alternative ( AltTable, (<|>:) ) import Rel8.Table.Eq ( EqTable, eqTable ) import Rel8.Table.Ord ( OrdTable, ordTable ) -import Rel8.Table.Projection ( Projectable, project, apply ) +import Rel8.Table.Projection + ( Projectable, Projecting, Projection, project, apply + ) import Rel8.Table.Serialize ( ToExprs ) @@ -108,6 +112,13 @@ where NonEmptyTable as <> NonEmptyTable bs = NonEmptyTable $ happend (const sappend1) as bs + + +-- | Project a single expression out of a 'NonEmptyTable'. +($+) :: Projecting a (Expr b) + => Projection a (Expr b) -> NonEmptyTable Expr a -> Expr (NonEmpty b) +f $+ NonEmptyTable a = hcolumn $ hproject (apply f) a +infixl 4 $+ -- | Construct a @NonEmptyTable@ from a non-empty list of expressions. diff --git a/src/Rel8/Table/Projection.hs b/src/Rel8/Table/Projection.hs --- a/src/Rel8/Table/Projection.hs +++ b/src/Rel8/Table/Projection.hs @@ -35,7 +35,7 @@ => Projecting a b instance ( Transposes (Context a) (Field a) a (Transpose (Field a) a) - , Transposes (Context a) (Field a) b (Transpose (Field b) b) + , Transposes (Context a) (Field a) b (Transpose (Field a) b) ) => Projecting a b diff --git a/src/Rel8/Tabulate.hs b/src/Rel8/Tabulate.hs --- a/src/Rel8/Tabulate.hs +++ b/src/Rel8/Tabulate.hs @@ -179,7 +179,7 @@ -- stopping a 'Tabulation' from containing multiple rows with the same key, so -- technically @Map k (NonEmpty a)@ is more accurate. -- --- 'Tabulation's can be created from 'Query's with 'fromQuery' and 'littQuery' +-- 'Tabulation's can be created from 'Query's with 'fromQuery' and 'liftQuery' -- and converted back to 'Query's with 'lookup' and 'toQuery' (though note the -- caveats that come with the latter). type Tabulation :: Type -> Type -> Type diff --git a/src/Rel8/Type/Ord.hs b/src/Rel8/Type/Ord.hs --- a/src/Rel8/Type/Ord.hs +++ b/src/Rel8/Type/Ord.hs @@ -75,7 +75,6 @@ -- | The class of database types that support the @max@ aggregation function. type DBMax :: Type -> Constraint class DBOrd a => DBMax a -instance DBMax Bool instance DBMax Char instance DBMax Int16 instance DBMax Int32 @@ -101,7 +100,6 @@ -- | The class of database types that support the @min@ aggregation function. type DBMin :: Type -> Constraint class DBOrd a => DBMin a -instance DBMin Bool instance DBMin Char instance DBMin Int16 instance DBMin Int32 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,3 +1,4 @@ +{-# language BangPatterns #-} {-# language BlockArguments #-} {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-} @@ -5,6 +6,7 @@ {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language MonoLocalBinds #-} +{-# language NamedFieldPuns #-} {-# language OverloadedStrings #-} {-# language RecordWildCards #-} {-# language ScopedTypeVariables #-} @@ -36,6 +38,7 @@ import Data.CaseInsensitive ( mk ) -- containers +import Data.Containers.ListUtils ( nubOrdOn ) import qualified Data.Map.Strict as Map -- hasql @@ -113,11 +116,13 @@ , testCatMaybeTable getTestDatabase , testCatMaybe getTestDatabase , testMaybeTable getTestDatabase + , testAggregateMaybeTable getTestDatabase , testNestedTables getTestDatabase , testMaybeTableApplicative getTestDatabase , testLogicalFixities getTestDatabase , testUpdate getTestDatabase , testDelete getTestDatabase + , testUpsert getTestDatabase , testSelectNestedPairs getTestDatabase , testSelectArray getTestDatabase , testNestedMaybeTable getTestDatabase @@ -133,6 +138,7 @@ flip run conn do sql "CREATE EXTENSION citext" sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )" + sql "CREATE TABLE unique_table ( \"key\" text not null unique, \"value\" text not null )" sql "CREATE SEQUENCE test_seq" return db @@ -555,6 +561,28 @@ _ -> sort selected === sort rows +testAggregateMaybeTable :: IO TmpPostgres.DB -> TestTree +testAggregateMaybeTable = databasePropertyTest "aggregateMaybeTable" \transaction -> evalM do + rows <- forAll $ Gen.list (Range.linear 0 10) (Gen.maybe (Gen.int64 (Range.linear 0 10))) + + let + aggregate = go 0 False False + where + go !n nothing _ (Just a : as) = go (n + a) nothing True as + go n _ just (Nothing : as) = go n True just as + go _ False False [] = [] + go _ True False [] = [Nothing] + go n False True [] = [Just n] + go n True True [] = [Nothing, Just n] + + transaction do + selected <- lift do + statement () $ Rel8.select do + Rel8.aggregate $ Rel8.aggregateMaybeTable Rel8.sum <$> Rel8.values (Rel8.lit <$> rows) + + sort selected === aggregate rows + + data TwoTestTables f = TwoTestTables { testTable1 :: TestTable f @@ -683,6 +711,72 @@ pure (deleted, selected) sort (deleted <> selected) === sort rows + + +data UniqueTable f = UniqueTable + { uniqueTableKey :: Rel8.Column f Text + , uniqueTableValue :: Rel8.Column f Text + } + deriving stock Generic + deriving anyclass Rel8.Rel8able + + +deriving stock instance Eq (UniqueTable Result) +deriving stock instance Ord (UniqueTable Result) +deriving stock instance Show (UniqueTable Result) + + +uniqueTableSchema :: Rel8.TableSchema (UniqueTable Rel8.Name) +uniqueTableSchema = + Rel8.TableSchema + { name = "unique_table" + , schema = Nothing + , columns = UniqueTable + { uniqueTableKey = "key" + , uniqueTableValue = "value" + } + } + + +genUniqueTable :: Gen (UniqueTable Result) +genUniqueTable = do + uniqueTableKey <- Gen.text (Range.linear 0 5) Gen.alphaNum + uniqueTableValue <- Gen.text (Range.linear 0 5) Gen.alphaNum + pure UniqueTable {..} + + +testUpsert :: IO TmpPostgres.DB -> TestTree +testUpsert = databasePropertyTest "Can UPSERT UniqueTable" \transaction -> do + as <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable + bs <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable + + transaction do + selected <- lift do + statement () $ Rel8.insert Rel8.Insert + { into = uniqueTableSchema + , rows = Rel8.values $ Rel8.lit <$> as + , onConflict = Rel8.DoNothing + , returning = pure () + } + + statement () $ Rel8.insert Rel8.Insert + { into = uniqueTableSchema + , rows = Rel8.values $ Rel8.lit <$> bs + , onConflict = Rel8.DoUpdate Rel8.Upsert + { index = uniqueTableKey + , set = \UniqueTable {uniqueTableValue} old -> old {uniqueTableValue} + , updateWhere = \_ _ -> Rel8.true + } + , returning = pure () + } + + statement () $ Rel8.select do + Rel8.each uniqueTableSchema + + fromUniqueTables selected === fromUniqueTables bs <> fromUniqueTables as + where + unique = fmap (nubOrdOn uniqueTableKey) + fromUniqueTables = Map.fromList . map \(UniqueTable key value) -> (key, value) newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }