From ea5d862c80c568d789fffa8025e52d243480e00c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Laurent=20P=2E=20Ren=C3=A9=20de=20Cotret?= Date: Mon, 17 Mar 2025 21:05:57 -0400 Subject: [PATCH 1/2] Added a test case for a simpler version of #746 --- beam-core/test/Database/Beam/Test/SQL.hs | 60 +++++++++++++++++++++++- 1 file changed, 58 insertions(+), 2 deletions(-) diff --git a/beam-core/test/Database/Beam/Test/SQL.hs b/beam-core/test/Database/Beam/Test/SQL.hs index b8f3aaa3..c41ab0bf 100644 --- a/beam-core/test/Database/Beam/Test/SQL.hs +++ b/beam-core/test/Database/Beam/Test/SQL.hs @@ -31,6 +31,7 @@ tests = testGroup "SQL generation tests" , leftJoinSingle , aggregates , orderBy + , innerNub , joinHaving @@ -127,7 +128,7 @@ simpleWhereNoFrom :: TestTree simpleWhereNoFrom = testCase "WHERE clause not dropped if there is no FROM" $ do SqlSelect Select { selectTable = SelectTable { .. }, .. } <- pure $ selectMock simple - + selectGrouping @?= Nothing selectOrdering @?= [] selectLimit @?= Nothing @@ -137,7 +138,7 @@ simpleWhereNoFrom = -- Important point: no FROM clause, yet WHERE clause should still be here selectFrom @?= Nothing selectWhere @?= (Just (ExpressionValue (Value False))) - + where simple :: Q (MockSqlBackend Command) EmptyDb s (QExpr (MockSqlBackend Command) s Bool) simple = do @@ -770,6 +771,61 @@ orderBy = (FromTable (TableFromSubSelect subselect) (Just ("t1", Nothing))) Nothing) + +-- | Ensure that a SQL DISTINCT in a subquery does not propagate up (see issue #746) +innerNub :: TestTree +innerNub = + testCase "DISTINCT clause on inner SELECT" $ do + stmt@(SqlSelect Select{selectTable = SelectTable{..}, ..}) <- pure $ selectMock query + + selectGrouping @?= Nothing + selectOrdering @?= [] + selectLimit @?= Nothing + selectOffset @?= Nothing + selectHaving @?= Nothing + selectQuantifier @?= Nothing -- quantifier should be in the subquery + selectFrom + @?= Just + ( FromTable + ( TableFromSubSelect + ( Select + { selectTable = + SelectTable + { selectQuantifier = Just SetQuantifierDistinct + , selectProjection = ProjExprs [(ExpressionFieldName (QualifiedField "t0" "first_name"), Just "res0")] + , selectFrom = Just (FromTable (TableNamed (TableName Nothing "employees")) (Just ("t0", Nothing))) + , selectWhere = Nothing + , selectGrouping = Nothing + , selectHaving = Nothing + } + , selectOrdering = [] + , selectLimit = Nothing + , selectOffset = Nothing + } + ) + ) + (Just ("t0", Nothing)) + ) + selectWhere + @?= Just + ( ExpressionCompOp + "==" + Nothing + (ExpressionFieldName (QualifiedField "t0" "res0")) + (ExpressionValue (Value @Text "Alice")) + ) + where + query :: Q (MockSqlBackend Command) EmployeeDb s (QExpr (MockSqlBackend Command) s Text) + query = do + name <- subQuery + guard_ (name ==. val_ "Alice") + pure name + + -- This sub query contains a DISTINCT clause via `nub_` + subQuery :: Q (MockSqlBackend Command) EmployeeDb s (QExpr (MockSqlBackend Command) s Text) + subQuery = nub_ $ _employeeFirstName <$> (all_ (_employees employeeDbSettings)) + + -- | HAVING clause should not be floated out of a join joinHaving :: TestTree From b2479afc1dd3acf18acff32873e92679cdc4a741 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Laurent=20P=2E=20Ren=C3=A9=20de=20Cotret?= Date: Mon, 5 May 2025 20:48:23 -0400 Subject: [PATCH 2/2] wip --- beam-core/Database/Beam/Backend/SQL.hs | 425 +++++++++--------- beam-postgres/beam-postgres.cabal | 2 + .../Database/Beam/Postgres/Test/Select.hs | 2 +- .../Beam/Postgres/Test/Select/PgNubBy.hs | 87 ++++ beam-postgres/test/Main.hs | 22 +- 5 files changed, 317 insertions(+), 221 deletions(-) create mode 100644 beam-postgres/test/Database/Beam/Postgres/Test/Select/PgNubBy.hs diff --git a/beam-core/Database/Beam/Backend/SQL.hs b/beam-core/Database/Beam/Backend/SQL.hs index 017cfe6f..9b78bb68 100644 --- a/beam-core/Database/Beam/Backend/SQL.hs +++ b/beam-core/Database/Beam/Backend/SQL.hs @@ -1,102 +1,96 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE UndecidableInstances #-} -module Database.Beam.Backend.SQL - ( module Database.Beam.Backend.SQL.Row - , module Database.Beam.Backend.SQL.SQL2003 - , module Database.Beam.Backend.SQL.Types - - , MonadBeam(..) - - , BeamSqlBackend - , BeamSqlBackendSyntax - , MockSqlBackend - - , BeamSqlBackendIsString - - , BeamSql99ExpressionBackend - , BeamSql99AggregationBackend - , BeamSql99ConcatExpressionBackend - , BeamSql99CommonTableExpressionBackend - , BeamSql99RecursiveCTEBackend - , BeamSql2003ExpressionBackend - - , BeamSqlT021Backend - , BeamSqlT071Backend - , BeamSqlT611Backend - , BeamSqlT612Backend - , BeamSqlT614Backend - , BeamSqlT615Backend - , BeamSqlT616Backend - , BeamSqlT618Backend - , BeamSqlT621Backend - , BeamSql99DataTypeBackend - - , BeamSqlBackendSupportsOuterJoin - - , BeamSqlBackendSelectSyntax - , BeamSqlBackendInsertSyntax - , BeamSqlBackendInsertValuesSyntax - , BeamSqlBackendUpdateSyntax - , BeamSqlBackendDeleteSyntax - , BeamSqlBackendCastTargetSyntax - , BeamSqlBackendSelectTableSyntax - , BeamSqlBackendAggregationQuantifierSyntax - , BeamSqlBackendSetQuantifierSyntax - , BeamSqlBackendFromSyntax - , BeamSqlBackendTableNameSyntax - - , BeamSqlBackendExpressionSyntax - , BeamSqlBackendDataTypeSyntax - , BeamSqlBackendFieldNameSyntax - , BeamSqlBackendExpressionQuantifierSyntax - , BeamSqlBackendValueSyntax - , BeamSqlBackendOrderingSyntax - , BeamSqlBackendGroupingSyntax - - , BeamSqlBackendWindowFrameSyntax - , BeamSqlBackendWindowFrameBoundsSyntax - , BeamSqlBackendWindowFrameBoundSyntax - - , BeamSql99BackendCTESyntax - - , BeamSqlBackendCanSerialize - , BeamSqlBackendCanDeserialize - , BeamSqlBackendSupportsDataType - ) where - -import Database.Beam.Backend.SQL.SQL2003 -import Database.Beam.Backend.SQL.Row -import Database.Beam.Backend.SQL.Types -import Database.Beam.Backend.Types - -import Control.Monad.Cont -import Control.Monad.Except + +module Database.Beam.Backend.SQL ( + module Database.Beam.Backend.SQL.Row, + module Database.Beam.Backend.SQL.SQL2003, + module Database.Beam.Backend.SQL.Types, + MonadBeam (..), + BeamSqlBackend, + BeamSqlBackendSyntax, + MockSqlBackend, + BeamSqlBackendIsString, + BeamSql99ExpressionBackend, + BeamSql99AggregationBackend, + BeamSql99ConcatExpressionBackend, + BeamSql99CommonTableExpressionBackend, + BeamSql99RecursiveCTEBackend, + BeamSql2003ExpressionBackend, + BeamSqlT021Backend, + BeamSqlT071Backend, + BeamSqlT611Backend, + BeamSqlT612Backend, + BeamSqlT614Backend, + BeamSqlT615Backend, + BeamSqlT616Backend, + BeamSqlT618Backend, + BeamSqlT621Backend, + BeamSql99DataTypeBackend, + BeamSqlBackendSupportsOuterJoin, + BeamSqlBackendSelectSyntax, + BeamSqlBackendInsertSyntax, + BeamSqlBackendInsertValuesSyntax, + BeamSqlBackendUpdateSyntax, + BeamSqlBackendDeleteSyntax, + BeamSqlBackendCastTargetSyntax, + BeamSqlBackendSelectTableSyntax, + BeamSqlBackendAggregationQuantifierSyntax, + BeamSqlBackendSetQuantifierSyntax, + BeamSqlBackendFromSyntax, + BeamSqlBackendTableNameSyntax, + BeamSqlBackendExpressionSyntax, + BeamSqlBackendDataTypeSyntax, + BeamSqlBackendFieldNameSyntax, + BeamSqlBackendExpressionQuantifierSyntax, + BeamSqlBackendValueSyntax, + BeamSqlBackendOrderingSyntax, + BeamSqlBackendGroupingSyntax, + BeamSqlBackendWindowFrameSyntax, + BeamSqlBackendWindowFrameBoundsSyntax, + BeamSqlBackendWindowFrameBoundSyntax, + BeamSql99BackendCTESyntax, + BeamSqlBackendCanSerialize, + BeamSqlBackendCanDeserialize, + BeamSqlBackendSupportsDataType, +) where + +import Database.Beam.Backend.SQL.Row +import Database.Beam.Backend.SQL.SQL2003 +import Database.Beam.Backend.SQL.Types +import Database.Beam.Backend.Types + +import Control.Monad.Cont +import Control.Monad.Except import qualified Control.Monad.RWS.Lazy as Lazy import qualified Control.Monad.RWS.Strict as Strict -import Control.Monad.Reader +import Control.Monad.Reader import qualified Control.Monad.State.Lazy as Lazy -import qualified Control.Monad.Writer.Lazy as Lazy import qualified Control.Monad.State.Strict as Strict +import qualified Control.Monad.Writer.Lazy as Lazy import qualified Control.Monad.Writer.Strict as Strict -import Data.Kind (Type) -import Data.Tagged (Tagged) -import Data.Text (Text) +import Data.Kind (Type) +import Data.Tagged (Tagged) +import Data.Text (Text) -- * MonadBeam class --- | A class that ties together a monad with a particular backend --- --- Provided here is a low-level interface for executing commands. The 'run*' --- functions are wrapped by the appropriate functions in 'Database.Beam.Query'. --- --- This interface is very high-level and isn't meant to expose the full power --- of the underlying database. Namely, it only supports simple data retrieval --- strategies. More complicated strategies (for example, Postgres's @COPY@) --- are supported in individual backends. See the documentation of those --- backends for more details. -class (BeamBackend be, Monad m) => - MonadBeam be m | m -> be where +{- | A class that ties together a monad with a particular backend + + Provided here is a low-level interface for executing commands. The 'run*' + functions are wrapped by the appropriate functions in 'Database.Beam.Query'. + + This interface is very high-level and isn't meant to expose the full power + of the underlying database. Namely, it only supports simple data retrieval + strategies. More complicated strategies (for example, Postgres's @COPY@) + are supported in individual backends. See the documentation of those + backends for more details. +-} +class + (BeamBackend be, Monad m) => + MonadBeam be m + | m -> be + where {-# MINIMAL runReturningMany #-} -- | Run a query determined by the given syntax, providing an action that will @@ -104,133 +98,136 @@ class (BeamBackend be, Monad m) => -- will get a reader action that can be used to fetch the next row. When -- this reader action returns 'Nothing', there are no rows left to consume. -- When the reader action returns, the database result is freed. - runReturningMany :: FromBackendRow be x - => BeamSqlBackendSyntax be - -- ^ The query to run - -> (m (Maybe x) -> m a) - -- ^ Reader action that will be called with a function to - -- fetch the next row - -> m a + runReturningMany :: + (FromBackendRow be x) => + -- | The query to run + BeamSqlBackendSyntax be -> + -- | Reader action that will be called with a function to + -- fetch the next row + (m (Maybe x) -> m a) -> + m a -- | Run the given command and don't consume any results. Useful for DML -- statements like INSERT, UPDATE, and DELETE, or DDL statements. runNoReturn :: BeamSqlBackendSyntax be -> m () runNoReturn cmd = - runReturningMany cmd $ \(_ :: m (Maybe ())) -> pure () + runReturningMany cmd $ \(_ :: m (Maybe ())) -> pure () -- | Run the given command and fetch the unique result. The result is -- 'Nothing' if either no results are returned or more than one result is -- returned. - runReturningOne :: FromBackendRow be x => BeamSqlBackendSyntax be -> m (Maybe x) + runReturningOne :: (FromBackendRow be x) => BeamSqlBackendSyntax be -> m (Maybe x) runReturningOne cmd = - runReturningMany cmd $ \next -> - do a <- next - case a of - Nothing -> pure Nothing - Just x -> do - a' <- next - case a' of - Nothing -> pure (Just x) - Just _ -> pure Nothing + runReturningMany cmd $ \next -> + do + a <- next + case a of + Nothing -> pure Nothing + Just x -> do + a' <- next + case a' of + Nothing -> pure (Just x) + Just _ -> pure Nothing -- | Run the given command and fetch the first result. The result is -- 'Nothing' if no results are returned. -- This is not guaranteed to automatically limit the query to one result. - runReturningFirst :: FromBackendRow be x => BeamSqlBackendSyntax be -> m (Maybe x) + runReturningFirst :: (FromBackendRow be x) => BeamSqlBackendSyntax be -> m (Maybe x) runReturningFirst cmd = runReturningMany cmd id -- | Run the given command, collect all the results, and return them as a -- list. May be more convenient than 'runReturningMany', but reads the entire -- result set into memory. - runReturningList :: FromBackendRow be x => BeamSqlBackendSyntax be -> m [x] + runReturningList :: (FromBackendRow be x) => BeamSqlBackendSyntax be -> m [x] runReturningList cmd = - runReturningMany cmd $ \next -> - let collectM acc = do - a <- next - case a of - Nothing -> pure (acc []) - Just x -> collectM (acc . (x:)) - in collectM id - -instance MonadBeam be m => MonadBeam be (ExceptT e m) where - runReturningMany s a = ExceptT $ runReturningMany s (\nextRow -> runExceptT (a (lift nextRow))) - runNoReturn = lift . runNoReturn - runReturningOne = lift . runReturningOne - runReturningList = lift . runReturningList - -instance MonadBeam be m => MonadBeam be (ContT r m) where - runReturningMany s a = ContT $ \r -> - runReturningMany s (\nextRow -> runContT (a (lift nextRow)) r) - runNoReturn = lift . runNoReturn - runReturningOne = lift . runReturningOne - runReturningList = lift . runReturningList - -instance MonadBeam be m => MonadBeam be (ReaderT r m) where - runReturningMany s a = ReaderT $ \r -> - runReturningMany s (\nextRow -> runReaderT (a (lift nextRow)) r) - runNoReturn = lift . runNoReturn - runReturningOne = lift . runReturningOne - runReturningList = lift . runReturningList - -instance MonadBeam be m => MonadBeam be (Lazy.StateT s m) where - runReturningMany s a = Lazy.StateT $ \st -> - runReturningMany s (\nextRow -> Lazy.runStateT (a (lift nextRow)) st) - runNoReturn = lift . runNoReturn - runReturningOne = lift . runReturningOne - runReturningList = lift . runReturningList - -instance MonadBeam be m => MonadBeam be (Strict.StateT s m) where - runReturningMany s a = Strict.StateT $ \st -> - runReturningMany s (\nextRow -> Strict.runStateT (a (lift nextRow)) st) - runNoReturn = lift . runNoReturn - runReturningOne = lift . runReturningOne - runReturningList = lift . runReturningList + runReturningMany cmd $ \next -> + let collectM acc = do + a <- next + case a of + Nothing -> pure (acc []) + Just x -> collectM (acc . (x :)) + in collectM id + +instance (MonadBeam be m) => MonadBeam be (ExceptT e m) where + runReturningMany s a = ExceptT $ runReturningMany s (\nextRow -> runExceptT (a (lift nextRow))) + runNoReturn = lift . runNoReturn + runReturningOne = lift . runReturningOne + runReturningList = lift . runReturningList + +instance (MonadBeam be m) => MonadBeam be (ContT r m) where + runReturningMany s a = ContT $ \r -> + runReturningMany s (\nextRow -> runContT (a (lift nextRow)) r) + runNoReturn = lift . runNoReturn + runReturningOne = lift . runReturningOne + runReturningList = lift . runReturningList + +instance (MonadBeam be m) => MonadBeam be (ReaderT r m) where + runReturningMany s a = ReaderT $ \r -> + runReturningMany s (\nextRow -> runReaderT (a (lift nextRow)) r) + runNoReturn = lift . runNoReturn + runReturningOne = lift . runReturningOne + runReturningList = lift . runReturningList + +instance (MonadBeam be m) => MonadBeam be (Lazy.StateT s m) where + runReturningMany s a = Lazy.StateT $ \st -> + runReturningMany s (\nextRow -> Lazy.runStateT (a (lift nextRow)) st) + runNoReturn = lift . runNoReturn + runReturningOne = lift . runReturningOne + runReturningList = lift . runReturningList + +instance (MonadBeam be m) => MonadBeam be (Strict.StateT s m) where + runReturningMany s a = Strict.StateT $ \st -> + runReturningMany s (\nextRow -> Strict.runStateT (a (lift nextRow)) st) + runNoReturn = lift . runNoReturn + runReturningOne = lift . runReturningOne + runReturningList = lift . runReturningList instance (MonadBeam be m, Monoid s) => MonadBeam be (Lazy.WriterT s m) where - runReturningMany s a = Lazy.WriterT $ - runReturningMany s (\nextRow -> Lazy.runWriterT (a (lift nextRow))) - runNoReturn = lift . runNoReturn - runReturningOne = lift . runReturningOne - runReturningList = lift . runReturningList + runReturningMany s a = + Lazy.WriterT $ + runReturningMany s (\nextRow -> Lazy.runWriterT (a (lift nextRow))) + runNoReturn = lift . runNoReturn + runReturningOne = lift . runReturningOne + runReturningList = lift . runReturningList instance (MonadBeam be m, Monoid s) => MonadBeam be (Strict.WriterT s m) where - runReturningMany s a = Strict.WriterT $ - runReturningMany s (\nextRow -> Strict.runWriterT (a (lift nextRow))) - runNoReturn = lift . runNoReturn - runReturningOne = lift . runReturningOne - runReturningList = lift . runReturningList + runReturningMany s a = + Strict.WriterT $ + runReturningMany s (\nextRow -> Strict.runWriterT (a (lift nextRow))) + runNoReturn = lift . runNoReturn + runReturningOne = lift . runReturningOne + runReturningList = lift . runReturningList instance (MonadBeam be m, Monoid w) => MonadBeam be (Lazy.RWST r w s m) where - runReturningMany s a = Lazy.RWST $ \r st -> - runReturningMany s (\nextRow -> Lazy.runRWST (a (lift nextRow)) r st) - runNoReturn = lift . runNoReturn - runReturningOne = lift . runReturningOne - runReturningList = lift . runReturningList + runReturningMany s a = Lazy.RWST $ \r st -> + runReturningMany s (\nextRow -> Lazy.runRWST (a (lift nextRow)) r st) + runNoReturn = lift . runNoReturn + runReturningOne = lift . runReturningOne + runReturningList = lift . runReturningList instance (MonadBeam be m, Monoid w) => MonadBeam be (Strict.RWST r w s m) where - runReturningMany s a = Strict.RWST $ \r st -> - runReturningMany s (\nextRow -> Strict.runRWST (a (lift nextRow)) r st) - runNoReturn = lift . runNoReturn - runReturningOne = lift . runReturningOne - runReturningList = lift . runReturningList + runReturningMany s a = Strict.RWST $ \r st -> + runReturningMany s (\nextRow -> Strict.runRWST (a (lift nextRow)) r st) + runNoReturn = lift . runNoReturn + runReturningOne = lift . runReturningOne + runReturningList = lift . runReturningList -- * BeamSqlBackend -- | Class for all Beam SQL backends -class ( -- Every SQL backend must be a beam backend - BeamBackend be - - -- Every SQL backend must have a reasonable SQL92 semantics - , IsSql92Syntax (BeamSqlBackendSyntax be) - , Sql92SanityCheck (BeamSqlBackendSyntax be) - - -- Needed for several combinators - , HasSqlValueSyntax (BeamSqlBackendValueSyntax be) Bool - , HasSqlValueSyntax (BeamSqlBackendValueSyntax be) SqlNull - - -- Needed for the Eq instance on QGenExpr - , Eq (BeamSqlBackendExpressionSyntax be) - ) => BeamSqlBackend be +class + ( -- Every SQL backend must be a beam backend + BeamBackend be + , -- Every SQL backend must have a reasonable SQL92 semantics + IsSql92Syntax (BeamSqlBackendSyntax be) + , Sql92SanityCheck (BeamSqlBackendSyntax be) + , -- Needed for several combinators + HasSqlValueSyntax (BeamSqlBackendValueSyntax be) Bool + , HasSqlValueSyntax (BeamSqlBackendValueSyntax be) SqlNull + , -- Needed for the Eq instance on QGenExpr + Eq (BeamSqlBackendExpressionSyntax be) + ) => + BeamSqlBackend be type family BeamSqlBackendSyntax be :: Type @@ -243,37 +240,42 @@ instance Trivial a instance BeamBackend (MockSqlBackend syntax) where type BackendFromField (MockSqlBackend syntax) = Trivial -instance ( IsSql92Syntax syntax - , Sql92SanityCheck syntax - - -- Needed for several combinators - , HasSqlValueSyntax (Sql92ValueSyntax syntax) Bool - , HasSqlValueSyntax (Sql92ValueSyntax syntax) SqlNull - - -- Needed for the Eq instance on QGenExpr - , Eq (Sql92ExpressionSyntax syntax) - ) => BeamSqlBackend (MockSqlBackend syntax) +instance + ( IsSql92Syntax syntax + , Sql92SanityCheck syntax + , -- Needed for several combinators + HasSqlValueSyntax (Sql92ValueSyntax syntax) Bool + , HasSqlValueSyntax (Sql92ValueSyntax syntax) SqlNull + , -- Needed for the Eq instance on QGenExpr + Eq (Sql92ExpressionSyntax syntax) + ) => + BeamSqlBackend (MockSqlBackend syntax) type instance BeamSqlBackendSyntax (MockSqlBackend syntax) = syntax -- | Type class for things which are text-like in this backend class BeamSqlBackendIsString be text -instance BeamSqlBackendIsString be t => BeamSqlBackendIsString be (Tagged tag t) + +instance (BeamSqlBackendIsString be t) => BeamSqlBackendIsString be (Tagged tag t) instance BeamSqlBackendIsString (MockSqlBackend cmd) Text instance BeamSqlBackendIsString (MockSqlBackend cmd) [Char] type BeamSql99ExpressionBackend be = IsSql99ExpressionSyntax (BeamSqlBackendExpressionSyntax be) type BeamSql99ConcatExpressionBackend be = IsSql99ConcatExpressionSyntax (BeamSqlBackendExpressionSyntax be) type BeamSql99CommonTableExpressionBackend be = - ( BeamSqlBackend be - , IsSql99CommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be) - , IsSql99CommonTableExpressionSyntax (BeamSql99BackendCTESyntax be) - , Sql99CTESelectSyntax (BeamSql99BackendCTESyntax be) ~ BeamSqlBackendSelectSyntax be ) -type BeamSql99RecursiveCTEBackend be= - ( BeamSql99CommonTableExpressionBackend be - , IsSql99RecursiveCommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be) ) + ( BeamSqlBackend be + , IsSql99CommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be) + , IsSql99CommonTableExpressionSyntax (BeamSql99BackendCTESyntax be) + , Sql99CTESelectSyntax (BeamSql99BackendCTESyntax be) ~ BeamSqlBackendSelectSyntax be + ) +type BeamSql99RecursiveCTEBackend be = + ( BeamSql99CommonTableExpressionBackend be + , IsSql99RecursiveCommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be) + ) type BeamSql99AggregationBackend be = IsSql99AggregationExpressionSyntax (BeamSqlBackendExpressionSyntax be) -type BeamSql2003ExpressionBackend be = ( IsSql2003ExpressionSyntax (BeamSqlBackendExpressionSyntax be) - , Sql2003SanityCheck (BeamSqlBackendSyntax be) ) +type BeamSql2003ExpressionBackend be = + ( IsSql2003ExpressionSyntax (BeamSqlBackendExpressionSyntax be) + , Sql2003SanityCheck (BeamSqlBackendSyntax be) + ) type BeamSqlBackendSupportsOuterJoin be = IsSql92FromOuterJoinSyntax (BeamSqlBackendFromSyntax be) @@ -287,11 +289,13 @@ type BeamSqlT616Backend be = IsSql2003FirstValueAndLastValueExpressionSyntax (Be type BeamSqlT618Backend be = IsSql2003NthValueExpressionSyntax (BeamSqlBackendExpressionSyntax be) type BeamSqlT621Backend be = ( IsSql2003EnhancedNumericFunctionsExpressionSyntax (BeamSqlBackendExpressionSyntax be) - , IsSql2003EnhancedNumericFunctionsAggregationExpressionSyntax (BeamSqlBackendExpressionSyntax be) ) + , IsSql2003EnhancedNumericFunctionsAggregationExpressionSyntax (BeamSqlBackendExpressionSyntax be) + ) type BeamSql99DataTypeBackend be = - ( BeamSqlBackend be - , IsSql99DataTypeSyntax (BeamSqlBackendCastTargetSyntax be) ) + ( BeamSqlBackend be + , IsSql99DataTypeSyntax (BeamSqlBackendCastTargetSyntax be) + ) type BeamSqlBackendSelectSyntax be = Sql92SelectSyntax (BeamSqlBackendSyntax be) type BeamSqlBackendInsertSyntax be = Sql92InsertSyntax (BeamSqlBackendSyntax be) @@ -301,15 +305,15 @@ type BeamSqlBackendDataTypeSyntax be = Sql92ExpressionCastTargetSyntax (BeamSqlB type BeamSqlBackendFieldNameSyntax be = Sql92ExpressionFieldNameSyntax (BeamSqlBackendExpressionSyntax be) type BeamSqlBackendUpdateSyntax be = Sql92UpdateSyntax (BeamSqlBackendSyntax be) type BeamSqlBackendDeleteSyntax be = Sql92DeleteSyntax (BeamSqlBackendSyntax be) -type BeamSqlBackendCastTargetSyntax be - = Sql92ExpressionCastTargetSyntax (BeamSqlBackendExpressionSyntax be) +type BeamSqlBackendCastTargetSyntax be = + Sql92ExpressionCastTargetSyntax (BeamSqlBackendExpressionSyntax be) type BeamSqlBackendExpressionQuantifierSyntax be = Sql92ExpressionQuantifierSyntax (Sql92ExpressionSyntax (BeamSqlBackendSyntax be)) type BeamSqlBackendValueSyntax be = Sql92ValueSyntax (BeamSqlBackendSyntax be) type BeamSqlBackendSetQuantifierSyntax be = Sql92SelectTableSetQuantifierSyntax (BeamSqlBackendSelectTableSyntax be) type BeamSqlBackendAggregationQuantifierSyntax be = Sql92AggregationSetQuantifierSyntax (BeamSqlBackendExpressionSyntax be) type BeamSqlBackendSelectTableSyntax be = Sql92SelectSelectTableSyntax (BeamSqlBackendSelectSyntax be) type BeamSqlBackendFromSyntax be = Sql92SelectFromSyntax (BeamSqlBackendSelectSyntax be) -type BeamSqlBackendTableNameSyntax be = Sql92TableSourceTableNameSyntax (Sql92FromTableSourceSyntax (BeamSqlBackendFromSyntax be)) +type BeamSqlBackendTableNameSyntax be = Sql92TableSourceTableNameSyntax (Sql92FromTableSourceSyntax (BeamSqlBackendFromSyntax be)) type BeamSqlBackendOrderingSyntax be = Sql92SelectOrderingSyntax (BeamSqlBackendSelectSyntax be) type BeamSqlBackendGroupingSyntax be = Sql92SelectTableGroupingSyntax (BeamSqlBackendSelectTableSyntax be) @@ -323,4 +327,5 @@ type BeamSqlBackendCanSerialize be = HasSqlValueSyntax (BeamSqlBackendValueSynta type BeamSqlBackendCanDeserialize be = FromBackendRow be type BeamSqlBackendSupportsDataType be x = ( BeamSqlBackendCanDeserialize be x - , BeamSqlBackendCanSerialize be x ) + , BeamSqlBackendCanSerialize be x + ) diff --git a/beam-postgres/beam-postgres.cabal b/beam-postgres/beam-postgres.cabal index 54ef05a8..74a354f8 100644 --- a/beam-postgres/beam-postgres.cabal +++ b/beam-postgres/beam-postgres.cabal @@ -80,6 +80,7 @@ test-suite beam-postgres-tests other-modules: Database.Beam.Postgres.Test, Database.Beam.Postgres.Test.Marshal, Database.Beam.Postgres.Test.Select, + Database.Beam.Postgres.Test.Select.PgNubBy, Database.Beam.Postgres.Test.DataTypes, Database.Beam.Postgres.Test.Migrate build-depends: @@ -95,6 +96,7 @@ test-suite beam-postgres-tests tasty, text, testcontainers, + time, uuid, vector default-language: Haskell2010 diff --git a/beam-postgres/test/Database/Beam/Postgres/Test/Select.hs b/beam-postgres/test/Database/Beam/Postgres/Test/Select.hs index 797c3c63..310a789f 100644 --- a/beam-postgres/test/Database/Beam/Postgres/Test/Select.hs +++ b/beam-postgres/test/Database/Beam/Postgres/Test/Select.hs @@ -139,4 +139,4 @@ testPgUnnest getConn = testCase "pgUnnest works" $ result <- runBeamPostgres conn $ runSelectReturningList $ select $ pgUnnest $ pgJsonArrayElements $ val_ $ PgJSONB $ Array $ V.fromList values - assertEqual "result" (PgJSONB <$> values) $ pgJsonElement <$> result + assertEqual "result" (PgJSONB <$> values) $ pgJsonElement <$> result \ No newline at end of file diff --git a/beam-postgres/test/Database/Beam/Postgres/Test/Select/PgNubBy.hs b/beam-postgres/test/Database/Beam/Postgres/Test/Select/PgNubBy.hs new file mode 100644 index 00000000..39558b86 --- /dev/null +++ b/beam-postgres/test/Database/Beam/Postgres/Test/Select/PgNubBy.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Database.Beam.Postgres.Test.Select.PgNubBy (tests) where + +import Control.Monad (void) +import Data.ByteString (ByteString) +import Data.Coerce +import Data.Coerce (coerce) +import Data.Int (Int32) +import Data.Text (Text) +import Data.Time.Calendar (Day, fromGregorian) +import Database.Beam +import Database.Beam.Migrate ( defaultMigratableDbSettings ) +import Database.Beam.Migrate.Simple (autoMigrate) +import Database.Beam.Postgres +import Database.Beam.Postgres.Migrate (migrationBackend) +import Database.Beam.Postgres.Test (withTestPostgres) +import Database.PostgreSQL.Simple (Query, execute_) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: IO ByteString -> TestTree +tests getConn = + testGroup + "pgNubBy_" + [testIssue746 getConn] + +data PersonT f = Person + { name :: C f Text + , title :: C f Text + , index :: C f Int32 + } + deriving (Generic) + +type Person = PersonT Identity + +type PersonExpr s = PersonT (QExpr Postgres s) + +deriving instance Show Person +deriving instance Eq Person + +instance Beamable PersonT + +instance Table PersonT where + data PrimaryKey PersonT f = PersonKey (C f Text) + deriving stock (Generic) + deriving anyclass (Beamable) + + primaryKey Person{name} = PersonKey name + +data Db f = Db + { persons :: f (TableEntity PersonT) + } + deriving (Generic) + +instance Database Postgres Db + +db :: DatabaseSettings Postgres Db +db = defaultDbSettings + +testIssue746 :: IO ByteString -> TestTree +testIssue746 getConn = testCase "pgNubBy_ (issue 746)" $ withTestPostgres "issue_746" getConn $ \conn -> do + rs <- runBeamPostgresDebug print conn $ do + void $ autoMigrate migrationBackend (defaultMigratableDbSettings @Postgres @Db) + runInsert $ + insert (persons db) $ + insertValues + [ -- Commit 1 + Person "A" "Mechanic" 1 + , Person "B" "Consultant" 1 + , -- Commit 2 + Person "C" "Cleaner" 2 + , Person "D" "Assistant" 2 + , -- Commit 3 + Person "E" "CEO" 3 + , Person "F" "CFO" 3 + ] + + -- TODO: two layers of using nub_, to ensure that the second nub_ doesn't use + -- data from the first + runSelectReturningList $ select $ do + person <- pgNubBy_ index $ all_ $ persons db + pure (name person) + + assertEqual mempty ["A", "C", "E"] rs \ No newline at end of file diff --git a/beam-postgres/test/Main.hs b/beam-postgres/test/Main.hs index 239515ad..03c29345 100644 --- a/beam-postgres/test/Main.hs +++ b/beam-postgres/test/Main.hs @@ -8,6 +8,7 @@ import Test.Tasty import qualified TestContainers.Tasty as TC import qualified Database.Beam.Postgres.Test.Select as Select +import qualified Database.Beam.Postgres.Test.Select.PgNubBy as Select.PgNubBy import qualified Database.Beam.Postgres.Test.Marshal as Marshal import qualified Database.Beam.Postgres.Test.DataTypes as DataType import qualified Database.Beam.Postgres.Test.Migrate as Migrate @@ -15,14 +16,15 @@ import Database.PostgreSQL.Simple ( ConnectInfo(..), defaultConnectInfo ) import qualified Database.PostgreSQL.Simple as Postgres main :: IO () -main = defaultMain - $ TC.withContainers setupTempPostgresDB - $ \getConnStr -> +main = defaultMain + $ TC.withContainers setupTempPostgresDB + $ \getConnStr -> testGroup "beam-postgres tests" - [ Marshal.tests getConnStr - , Select.tests getConnStr - , DataType.tests getConnStr - , Migrate.tests getConnStr + [ --Marshal.tests getConnStr + -- , Select.tests getConnStr + Select.PgNubBy.tests getConnStr + -- , DataType.tests getConnStr + -- , Migrate.tests getConnStr ] @@ -39,10 +41,10 @@ setupTempPostgresDB = do , ("POSTGRES_DB", db) ] TC.& TC.setWaitingFor (TC.waitForLogLine TC.Stderr ("database system is ready to accept connections" `TL.isInfixOf`)) - - pure $ Postgres.postgreSQLConnectionString + + pure $ Postgres.postgreSQLConnectionString ( defaultConnectInfo { connectHost = "localhost" - , connectUser = unpack user + , connectUser = unpack user , connectPassword = unpack password , connectDatabase = unpack db , connectPort = fromIntegral $ TC.containerPort timescaleContainer 5432