diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,86 @@ +# 0.8.0.0 + +## Common table expressions + +Beam now supports common table expressions on some backends, using the +`With` monad. Currently, only `SELECT` statements are supported. + +## Changes to field name modification + +`EntityModification` is now a `Monoid`. + +Instead of taking the beam-determined name, the `renamingFields` +function instead takes a `Data.List.NonEmpty` value containing the +names of each Haskell record selector that led to this field. + +For example, in the following + +```haskell +data Embedded f = + Embedded { _field1 :: Columnar f Text + , _field2 :: Columnar f Int } + +data Table1 f = + Table1 { _tbl1FieldA :: Columnar f Text + , _tbl1Embedded :: Embedded f } + +db = defaultDbSettings `withDbModification` + dbModification { table1 = renamingFields f } +``` + +`f` would be called with `["_tbl1FieldA"]`, `["_tbl1Embedded", "_field1"]` +and `["_tbl1Embedded", "_field2"]`. + + +## Simplified types + +Every beam SQL backend is now an instance of `BeamSqlBackend` and has an +associated syntax via an associated type family. This means types are much simpler. + +Another benefit is that `MonadBeam` now has a simpler type and can be used with +monad transformers. For example, writing a computation that may call out to a +postgres database is as simple as + +```haskell +dbComputation :: MonadBeam Postgres m => m result +``` + +versus before + +```haskell +dbComputation :: MonadBeam PgCommandSyntax Postgres Pg.Connection m => m result +``` + +Things become simpler if you want to write database agnostic computations. You can now do + +```haskell +dbComputation :: (BeamSqlBackend be, MonadBeam be m) => m result +``` + +versus before + +```haskell +dbComputation :: ( Sql92SanityCheck syntax, MonadBeam syntax be hdl m ) => m result +``` + +## Removal of `HasDefaultSqlDataTypeConstraints` + +The changes above make a separate `HasDefaultSqlDataTypeConstraints` +class unnecessary. The `defaultSqlDataTypeConstraints` method is now +included within the `HasDefaultSqlDataType` class. + +## Changes to parseOneField and peekField + +Formerly, the `peekField` function would attemt to parse a field +without advancing the column pointer, regardless of whether a field +was successfully parsed. In order to support more efficient parsing, +this has been changed. When `peekField` returns a `Just` value, then +the column pointer is advanced to the next pointer. This means you do +not need to call `parseOneField` again to advance the pointer. + +You can still chain `peekField` calls together by using the new +`Alternative` instance for `FromBackendRowM`. + # 0.7.2.0 Add compatibility with GHC 8.4 and stack nightly diff --git a/Database/Beam.hs b/Database/Beam.hs --- a/Database/Beam.hs +++ b/Database/Beam.hs @@ -6,12 +6,10 @@ -- -- This is mainly reference documentation. Most users will want to consult the -- [manual](https://tathougies.github.io/beam). --- --- The API has mostly stayed the same, but not all the examples given there compile. module Database.Beam ( module Database.Beam.Query , module Database.Beam.Schema - , MonadBeam(withDatabase, withDatabaseDebug) + , MonadBeam(..) , FromBackendRow(..) -- * Re-exports diff --git a/Database/Beam/Backend.hs b/Database/Beam/Backend.hs --- a/Database/Beam/Backend.hs +++ b/Database/Beam/Backend.hs @@ -1,6 +1,7 @@ module Database.Beam.Backend ( module Database.Beam.Backend.Types - , MonadBeam(..) ) where + , module Database.Beam.Backend.SQL + ) where import Database.Beam.Backend.Types import Database.Beam.Backend.SQL diff --git a/Database/Beam/Backend/SQL.hs b/Database/Beam/Backend/SQL.hs --- a/Database/Beam/Backend/SQL.hs +++ b/Database/Beam/Backend/SQL.hs @@ -1,50 +1,101 @@ +{-# LANGUAGE UndecidableInstances #-} module Database.Beam.Backend.SQL - ( module Database.Beam.Backend.SQL.SQL2003 + ( module Database.Beam.Backend.SQL.Row + , module Database.Beam.Backend.SQL.SQL2003 , module Database.Beam.Backend.SQL.Types - , module Database.Beam.Backend.Types - , MonadBeam(..) ) where + , 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.IO.Class -import Control.Monad.Fail (MonadFail) +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 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.Strict as Strict +import Data.Tagged (Tagged) +import Data.Text (Text) + -- * MonadBeam class --- | A class that ties together a Sql syntax, backend, handle, and monad type. --- --- Intuitively, this allows you to write code that performs database commands --- without having to know the underlying API. As long as you have an --- appropriate handle from a database library that Beam can use, you can use --- the 'MonadBeam' methods to execute the query. +-- | A class that ties together a monad with a particular backend -- --- Provided here is a low-level interface. Most often, you'll only need the --- 'withDatabase' and 'withDatabaseDebug' function. The 'run*' functions are --- wrapped by the appropriate functions in "Database.Beam.Query". +-- 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, MonadIO m, MonadFail m, Sql92SanityCheck syntax) => - MonadBeam syntax be handle m | m -> syntax be handle where - - {-# MINIMAL withDatabaseDebug, runReturningMany #-} - - -- | Run a database action, and log debugging information about statements - -- executed using the specified 'IO' action. - withDatabaseDebug :: (String -> IO ()) -- ^ Database statement logging function - -> handle -- ^ The database connection handle against which to execute the action - -> m a -- ^ The database action - -> IO a - withDatabase :: handle -> m a -> IO a - - -- | Run a database action, but don't report any debug information - withDatabase = withDatabaseDebug (\_ -> pure ()) +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 -- be called to consume the results from the database (if any). The action @@ -52,20 +103,23 @@ -- 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 - => syntax -- ^ The query to run - -> (m (Maybe x) -> m a) -- ^ Reader action that will be called with a function to fetch the next row + => 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 -- | Run the given command and don't consume any results. Useful for DML -- statements like INSERT, UPDATE, and DELETE, or DDL statements. - runNoReturn :: syntax -> m () + runNoReturn :: BeamSqlBackendSyntax be -> m () runNoReturn cmd = 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 => syntax -> m (Maybe x) + runReturningOne :: FromBackendRow be x => BeamSqlBackendSyntax be -> m (Maybe x) runReturningOne cmd = runReturningMany cmd $ \next -> do a <- next @@ -80,7 +134,7 @@ -- | 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 => syntax -> m [x] + runReturningList :: FromBackendRow be x => BeamSqlBackendSyntax be -> m [x] runReturningList cmd = runReturningMany cmd $ \next -> let collectM acc = do @@ -89,3 +143,176 @@ 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 + +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 + +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 + +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 + +-- * 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 + +type family BeamSqlBackendSyntax be :: * + +-- | Fake backend that cannot deserialize anything, but is useful for testing +data MockSqlBackend syntax + +class Trivial a +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) +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 (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) ) +type BeamSql99AggregationBackend be = IsSql99AggregationExpressionSyntax (BeamSqlBackendExpressionSyntax be) +type BeamSql2003ExpressionBackend be = ( IsSql2003ExpressionSyntax (BeamSqlBackendExpressionSyntax be) + , Sql2003SanityCheck (BeamSqlBackendSyntax be) ) + +type BeamSqlBackendSupportsOuterJoin be = IsSql92FromOuterJoinSyntax (BeamSqlBackendFromSyntax be) + +type BeamSqlT021Backend be = IsSql2003BinaryAndVarBinaryDataTypeSyntax (BeamSqlBackendCastTargetSyntax be) +type BeamSqlT071Backend be = IsSql2008BigIntDataTypeSyntax (BeamSqlBackendCastTargetSyntax be) +type BeamSqlT611Backend be = IsSql2003ExpressionElementaryOLAPOperationsSyntax (BeamSqlBackendExpressionSyntax be) +type BeamSqlT612Backend be = IsSql2003ExpressionAdvancedOLAPOperationsSyntax (BeamSqlBackendExpressionSyntax be) +type BeamSqlT614Backend be = IsSql2003NtileExpressionSyntax (BeamSqlBackendExpressionSyntax be) +type BeamSqlT615Backend be = IsSql2003LeadAndLagExpressionSyntax (BeamSqlBackendExpressionSyntax be) +type BeamSqlT616Backend be = IsSql2003FirstValueAndLastValueExpressionSyntax (BeamSqlBackendExpressionSyntax be) +type BeamSqlT618Backend be = IsSql2003NthValueExpressionSyntax (BeamSqlBackendExpressionSyntax be) +type BeamSqlT621Backend be = + ( IsSql2003EnhancedNumericFunctionsExpressionSyntax (BeamSqlBackendExpressionSyntax be) + , IsSql2003EnhancedNumericFunctionsAggregationExpressionSyntax (BeamSqlBackendExpressionSyntax be) ) + +type BeamSql99DataTypeBackend be = + ( BeamSqlBackend be + , IsSql99DataTypeSyntax (BeamSqlBackendCastTargetSyntax be) ) + +type BeamSqlBackendSelectSyntax be = Sql92SelectSyntax (BeamSqlBackendSyntax be) +type BeamSqlBackendInsertSyntax be = Sql92InsertSyntax (BeamSqlBackendSyntax be) +type BeamSqlBackendInsertValuesSyntax be = Sql92InsertValuesSyntax (BeamSqlBackendInsertSyntax be) +type BeamSqlBackendExpressionSyntax be = Sql92ExpressionSyntax (BeamSqlBackendSyntax be) +type BeamSqlBackendDataTypeSyntax be = Sql92ExpressionCastTargetSyntax (BeamSqlBackendExpressionSyntax be) +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 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 BeamSqlBackendOrderingSyntax be = Sql92SelectOrderingSyntax (BeamSqlBackendSelectSyntax be) +type BeamSqlBackendGroupingSyntax be = Sql92SelectTableGroupingSyntax (BeamSqlBackendSelectTableSyntax be) + +type BeamSqlBackendWindowFrameSyntax be = Sql2003ExpressionWindowFrameSyntax (BeamSqlBackendExpressionSyntax be) +type BeamSqlBackendWindowFrameBoundsSyntax be = Sql2003WindowFrameBoundsSyntax (BeamSqlBackendWindowFrameSyntax be) +type BeamSqlBackendWindowFrameBoundSyntax be = Sql2003WindowFrameBoundsBoundSyntax (BeamSqlBackendWindowFrameBoundsSyntax be) + +type BeamSql99BackendCTESyntax be = Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be) + +type BeamSqlBackendCanSerialize be = HasSqlValueSyntax (BeamSqlBackendValueSyntax be) +type BeamSqlBackendCanDeserialize be = FromBackendRow be +type BeamSqlBackendSupportsDataType be x = + ( BeamSqlBackendCanDeserialize be x + , BeamSqlBackendCanSerialize be x ) diff --git a/Database/Beam/Backend/SQL/AST.hs b/Database/Beam/Backend/SQL/AST.hs --- a/Database/Beam/Backend/SQL/AST.hs +++ b/Database/Beam/Backend/SQL/AST.hs @@ -77,13 +77,14 @@ data Insert = Insert - { insertTable :: Text + { insertTable :: TableName , insertFields :: [ Text ] , insertValues :: InsertValues } deriving (Show, Eq) instance IsSql92InsertSyntax Insert where type Sql92InsertValuesSyntax Insert = InsertValues + type Sql92InsertTableNameSyntax Insert = TableName insertStmt = Insert @@ -103,12 +104,13 @@ data Update = Update - { updateTable :: Text + { updateTable :: TableName , updateFields :: [ (FieldName, Expression) ] , updateWhere :: Maybe Expression } deriving (Show, Eq) instance IsSql92UpdateSyntax Update where + type Sql92UpdateTableNameSyntax Update = TableName type Sql92UpdateFieldNameSyntax Update = FieldName type Sql92UpdateExpressionSyntax Update = Expression @@ -116,12 +118,13 @@ data Delete = Delete - { deleteTable :: Text + { deleteTable :: TableName , deleteAlias :: Maybe Text , deleteWhere :: Maybe Expression } deriving (Show, Eq) instance IsSql92DeleteSyntax Delete where + type Sql92DeleteTableNameSyntax Delete = TableName type Sql92DeleteExpressionSyntax Delete = Expression deleteStmt = Delete @@ -157,11 +160,6 @@ | ExtractFieldDateTimeSecond deriving (Show, Eq) -data CastTarget - = CastTargetDataType DataType - | CastTargetDomainName Text - deriving (Show, Eq) - data DataType = DataTypeChar Bool {- Varying -} (Maybe Word) (Maybe Text) | DataTypeNationalChar Bool (Maybe Word) @@ -256,7 +254,7 @@ | ExpressionUnOp Text Expression | ExpressionPosition Expression Expression - | ExpressionCast Expression CastTarget + | ExpressionCast Expression DataType | ExpressionExtract ExtractField Expression | ExpressionCharLength Expression | ExpressionOctetLength Expression @@ -266,6 +264,7 @@ | ExpressionUpper Expression | ExpressionTrim Expression + | ExpressionNamedFunction Text | ExpressionFunctionCall Expression [ Expression ] | ExpressionInstanceField Expression Text | ExpressionRefField Expression Text @@ -284,14 +283,20 @@ | ExpressionCurrentTimestamp deriving (Show, Eq) -instance IsSqlExpressionSyntaxStringType Expression Text +instance IsSql92ExtractFieldSyntax ExtractField where + secondsField = ExtractFieldDateTimeSecond + minutesField = ExtractFieldDateTimeMinute + hourField = ExtractFieldDateTimeHour + dayField = ExtractFieldDateTimeDay + monthField = ExtractFieldDateTimeMonth + yearField = ExtractFieldDateTimeYear instance IsSql92ExpressionSyntax Expression where type Sql92ExpressionQuantifierSyntax Expression = ComparatorQuantifier type Sql92ExpressionValueSyntax Expression = Value type Sql92ExpressionSelectSyntax Expression = Select type Sql92ExpressionFieldNameSyntax Expression = FieldName - type Sql92ExpressionCastTargetSyntax Expression = CastTarget + type Sql92ExpressionCastTargetSyntax Expression = DataType type Sql92ExpressionExtractFieldSyntax Expression = ExtractField valueE = ExpressionValue @@ -353,10 +358,13 @@ defaultE = ExpressionDefault inE = ExpressionIn +instance IsSql99FunctionExpressionSyntax Expression where + functionNameE = ExpressionNamedFunction + functionCallE = ExpressionFunctionCall + instance IsSql99ExpressionSyntax Expression where distinctE = ExpressionDistinct similarToE = ExpressionBinOp "SIMILAR TO" - functionCallE = ExpressionFunctionCall instanceFieldE = ExpressionInstanceField refFieldE = ExpressionRefField @@ -423,6 +431,7 @@ type Sql2003ExpressionWindowFrameSyntax Expression = WindowFrame overE = ExpressionOver + rowNumberE = ExpressionAgg "ROW_NUMBER" Nothing [] newtype Projection = ProjExprs [ (Expression, Maybe Text ) ] @@ -451,19 +460,29 @@ groupByExpressions = Grouping +data TableName = TableName (Maybe Text) Text + deriving (Show, Eq, Ord) + +instance IsSql92TableNameSyntax TableName where + tableName = TableName + data TableSource - = TableNamed Text + = TableNamed TableName | TableFromSubSelect Select + | TableFromValues [ [ Expression ] ] deriving (Show, Eq) instance IsSql92TableSourceSyntax TableSource where type Sql92TableSourceSelectSyntax TableSource = Select + type Sql92TableSourceExpressionSyntax TableSource = Expression + type Sql92TableSourceTableNameSyntax TableSource = TableName tableNamed = TableNamed tableFromSubSelect = TableFromSubSelect + tableFromValues = TableFromValues data From - = FromTable TableSource (Maybe Text) + = FromTable TableSource (Maybe (Text, Maybe [Text])) | InnerJoin From From (Maybe Expression) | LeftJoin From From (Maybe Expression) | RightJoin From From (Maybe Expression) diff --git a/Database/Beam/Backend/SQL/BeamExtensions.hs b/Database/Beam/Backend/SQL/BeamExtensions.hs --- a/Database/Beam/Backend/SQL/BeamExtensions.hs +++ b/Database/Beam/Backend/SQL/BeamExtensions.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances #-} -- | Some functionality is useful enough to be provided across backends, but is -- not standardized. For example, many RDBMS systems provide ways of fetching -- auto-incrementing or defaulting fields on INSERT or UPDATE. @@ -14,50 +15,121 @@ ) where import Database.Beam.Backend -import Database.Beam.Backend.SQL import Database.Beam.Query -import Database.Beam.Query.Internal import Database.Beam.Schema import Control.Monad.Identity +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 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.Strict as Strict --import GHC.Generics -- | 'MonadBeam's that support returning the newly created rows of an @INSERT@ statement. -- Useful for discovering the real value of a defaulted value. -class MonadBeam syntax be handle m => - MonadBeamInsertReturning syntax be handle m | m -> syntax be handle, be -> m, handle -> m where +class MonadBeam be m => + MonadBeamInsertReturning be m | m -> be where runInsertReturningList :: ( Beamable table - , Projectible (Sql92ExpressionSyntax syntax) (table (QExpr (Sql92ExpressionSyntax syntax) ())) + , Projectible be (table (QExpr be ())) , FromBackendRow be (table Identity) ) - => DatabaseEntity be db (TableEntity table) - -> SqlInsertValues (Sql92InsertValuesSyntax (Sql92InsertSyntax syntax)) - (table (QExpr (Sql92InsertExpressionSyntax (Sql92InsertSyntax syntax)) s)) + => SqlInsert be table -> m [table Identity] +instance MonadBeamInsertReturning be m => MonadBeamInsertReturning be (ExceptT e m) where + runInsertReturningList = lift . runInsertReturningList +instance MonadBeamInsertReturning be m => MonadBeamInsertReturning be (ContT r m) where + runInsertReturningList = lift . runInsertReturningList +instance MonadBeamInsertReturning be m => MonadBeamInsertReturning be (ReaderT r m) where + runInsertReturningList = lift . runInsertReturningList +instance MonadBeamInsertReturning be m => MonadBeamInsertReturning be (Lazy.StateT r m) where + runInsertReturningList = lift . runInsertReturningList +instance MonadBeamInsertReturning be m => MonadBeamInsertReturning be (Strict.StateT r m) where + runInsertReturningList = lift . runInsertReturningList +instance (MonadBeamInsertReturning be m, Monoid r) + => MonadBeamInsertReturning be (Lazy.WriterT r m) where + runInsertReturningList = lift . runInsertReturningList +instance (MonadBeamInsertReturning be m, Monoid r) + => MonadBeamInsertReturning be (Strict.WriterT r m) where + runInsertReturningList = lift . runInsertReturningList +instance (MonadBeamInsertReturning be m, Monoid w) + => MonadBeamInsertReturning be (Lazy.RWST r w s m) where + runInsertReturningList = lift . runInsertReturningList +instance (MonadBeamInsertReturning be m, Monoid w) + => MonadBeamInsertReturning be (Strict.RWST r w s m) where + runInsertReturningList = lift . runInsertReturningList + -- | 'MonadBeam's that support returning the updated rows of an @UPDATE@ statement. -- Useful for discovering the new values of the updated rows. -class MonadBeam syntax be handle m => - MonadBeamUpdateReturning syntax be handle m | m -> syntax be handle, be -> m, handle -> m where +class MonadBeam be m => + MonadBeamUpdateReturning be m | m -> be where runUpdateReturningList :: ( Beamable table - , Projectible (Sql92ExpressionSyntax syntax) (table (QExpr (Sql92ExpressionSyntax syntax) ())) + , Projectible be (table (QExpr be ())) , FromBackendRow be (table Identity) ) - => DatabaseEntity be db (TableEntity table) - -> (forall s. table (QField s) -> [ QAssignment (Sql92UpdateFieldNameSyntax (Sql92UpdateSyntax syntax)) (Sql92UpdateExpressionSyntax (Sql92UpdateSyntax syntax)) s ]) - -> (forall s. table (QExpr (Sql92UpdateExpressionSyntax (Sql92UpdateSyntax syntax)) s) -> QExpr (Sql92UpdateExpressionSyntax (Sql92UpdateSyntax syntax)) s Bool) + => SqlUpdate be table -> m [table Identity] +instance MonadBeamUpdateReturning be m => MonadBeamUpdateReturning be (ExceptT e m) where + runUpdateReturningList = lift . runUpdateReturningList +instance MonadBeamUpdateReturning be m => MonadBeamUpdateReturning be (ContT r m) where + runUpdateReturningList = lift . runUpdateReturningList +instance MonadBeamUpdateReturning be m => MonadBeamUpdateReturning be (ReaderT r m) where + runUpdateReturningList = lift . runUpdateReturningList +instance MonadBeamUpdateReturning be m => MonadBeamUpdateReturning be (Lazy.StateT r m) where + runUpdateReturningList = lift . runUpdateReturningList +instance MonadBeamUpdateReturning be m => MonadBeamUpdateReturning be (Strict.StateT r m) where + runUpdateReturningList = lift . runUpdateReturningList +instance (MonadBeamUpdateReturning be m, Monoid r) + => MonadBeamUpdateReturning be (Lazy.WriterT r m) where + runUpdateReturningList = lift . runUpdateReturningList +instance (MonadBeamUpdateReturning be m, Monoid r) + => MonadBeamUpdateReturning be (Strict.WriterT r m) where + runUpdateReturningList = lift . runUpdateReturningList +instance (MonadBeamUpdateReturning be m, Monoid w) + => MonadBeamUpdateReturning be (Lazy.RWST r w s m) where + runUpdateReturningList = lift . runUpdateReturningList +instance (MonadBeamUpdateReturning be m, Monoid w) + => MonadBeamUpdateReturning be (Strict.RWST r w s m) where + runUpdateReturningList = lift . runUpdateReturningList + -- | 'MonadBeam's that suppert returning rows that will be deleted by the given -- @DELETE@ statement. Useful for deallocating resources based on the value of -- deleted rows. -class MonadBeam syntax be handle m => - MonadBeamDeleteReturning syntax be handle m | m -> syntax be handle, be -> m, handle -> m where +class MonadBeam be m => + MonadBeamDeleteReturning be m | m -> be where runDeleteReturningList :: ( Beamable table - , Projectible (Sql92ExpressionSyntax syntax) (table (QExpr (Sql92ExpressionSyntax syntax) ())) + , Projectible be (table (QExpr be ())) , FromBackendRow be (table Identity) ) - => DatabaseEntity be db (TableEntity table) - -> (forall s. table (QExpr (Sql92UpdateExpressionSyntax (Sql92UpdateSyntax syntax)) s) -> QExpr (Sql92UpdateExpressionSyntax (Sql92UpdateSyntax syntax)) s Bool) + => SqlDelete be table -> m [table Identity] + +instance MonadBeamDeleteReturning be m => MonadBeamDeleteReturning be (ExceptT e m) where + runDeleteReturningList = lift . runDeleteReturningList +instance MonadBeamDeleteReturning be m => MonadBeamDeleteReturning be (ContT r m) where + runDeleteReturningList = lift . runDeleteReturningList +instance MonadBeamDeleteReturning be m => MonadBeamDeleteReturning be (ReaderT r m) where + runDeleteReturningList = lift . runDeleteReturningList +instance MonadBeamDeleteReturning be m => MonadBeamDeleteReturning be (Lazy.StateT r m) where + runDeleteReturningList = lift . runDeleteReturningList +instance MonadBeamDeleteReturning be m => MonadBeamDeleteReturning be (Strict.StateT r m) where + runDeleteReturningList = lift . runDeleteReturningList +instance (MonadBeamDeleteReturning be m, Monoid r) + => MonadBeamDeleteReturning be (Lazy.WriterT r m) where + runDeleteReturningList = lift . runDeleteReturningList +instance (MonadBeamDeleteReturning be m, Monoid r) + => MonadBeamDeleteReturning be (Strict.WriterT r m) where + runDeleteReturningList = lift . runDeleteReturningList +instance (MonadBeamDeleteReturning be m, Monoid w) + => MonadBeamDeleteReturning be (Lazy.RWST r w s m) where + runDeleteReturningList = lift . runDeleteReturningList +instance (MonadBeamDeleteReturning be m, Monoid w) + => MonadBeamDeleteReturning be (Strict.RWST r w s m) where + runDeleteReturningList = lift . runDeleteReturningList diff --git a/Database/Beam/Backend/SQL/Builder.hs b/Database/Beam/Backend/SQL/Builder.hs --- a/Database/Beam/Backend/SQL/Builder.hs +++ b/Database/Beam/Backend/SQL/Builder.hs @@ -13,12 +13,13 @@ -- Always use the provided backends to submit queries and data manipulation -- commands to the database. module Database.Beam.Backend.SQL.Builder - ( SqlSyntaxBuilder(..), SqlSyntaxBackend + ( SqlSyntaxBuilder(..) --, SqlSyntaxBackend , buildSepBy , quoteSql , renderSql ) where import Database.Beam.Backend.SQL +--import Database.Beam.Backend.Types import Control.Monad.IO.Class @@ -126,10 +127,11 @@ instance IsSql92InsertSyntax SqlSyntaxBuilder where type Sql92InsertValuesSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92InsertTableNameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder - insertStmt table fields values = + insertStmt tblNm fields values = SqlSyntaxBuilder $ - byteString "INSERT INTO " <> quoteSql table <> + byteString "INSERT INTO " <> buildSql tblNm <> byteString "(" <> buildSepBy (byteString ", ") (map quoteSql fields) <> byteString ") " <> buildSql values @@ -151,10 +153,11 @@ instance IsSql92UpdateSyntax SqlSyntaxBuilder where type Sql92UpdateFieldNameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder type Sql92UpdateExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92UpdateTableNameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder - updateStmt table set where_ = + updateStmt tblNm set where_ = SqlSyntaxBuilder $ - byteString "UPDATE " <> quoteSql table <> + byteString "UPDATE " <> buildSql tblNm <> (case set of [] -> mempty es -> byteString " SET " <> buildSepBy (byteString ", ") (map (\(field, expr) -> buildSql field <> byteString "=" <> buildSql expr) es)) <> @@ -162,10 +165,11 @@ instance IsSql92DeleteSyntax SqlSyntaxBuilder where type Sql92DeleteExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92DeleteTableNameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder - deleteStmt tbl alias where_ = + deleteStmt tblNm alias where_ = SqlSyntaxBuilder $ - byteString "DELETE FROM " <> quoteSql tbl <> + byteString "DELETE FROM " <> buildSql tblNm <> maybe mempty (\alias_ -> byteString " AS " <> quoteSql alias_) alias <> maybe mempty (\where_ -> byteString " WHERE " <> buildSql where_) where_ @@ -180,12 +184,18 @@ SqlSyntaxBuilder $ byteString "`" <> stringUtf8 (T.unpack a) <> byteString "`" -instance IsSqlExpressionSyntaxStringType SqlSyntaxBuilder Text - instance IsSql92QuantifierSyntax SqlSyntaxBuilder where quantifyOverAll = SqlSyntaxBuilder "ALL" quantifyOverAny = SqlSyntaxBuilder "ANY" +instance IsSql92ExtractFieldSyntax SqlSyntaxBuilder where + secondsField = SqlSyntaxBuilder (byteString "SECOND") + minutesField = SqlSyntaxBuilder (byteString "MINUTE") + hourField = SqlSyntaxBuilder (byteString "HOUR") + dayField = SqlSyntaxBuilder (byteString "DAY") + monthField = SqlSyntaxBuilder (byteString "MONTH") + yearField = SqlSyntaxBuilder (byteString "YEAR") + instance IsSql92ExpressionSyntax SqlSyntaxBuilder where type Sql92ExpressionValueSyntax SqlSyntaxBuilder = SqlSyntaxBuilder type Sql92ExpressionSelectSyntax SqlSyntaxBuilder = SqlSyntaxBuilder @@ -221,7 +231,7 @@ positionE needle haystack = SqlSyntaxBuilder $ byteString "POSITION(" <> buildSql needle <> byteString ") IN (" <> buildSql haystack <> byteString ")" extractE what from = - SqlSyntaxBuilder $ buildSql what <> byteString " FROM (" <> buildSql from <> byteString ")" + SqlSyntaxBuilder $ byteString "EXTRACT(" <> buildSql what <> byteString " FROM (" <> buildSql from <> byteString "))" absE = sqlFuncOp "ABS" charLengthE = sqlFuncOp "CHAR_LENGTH" bitLengthE = sqlFuncOp "BIT_LENGTH" @@ -266,10 +276,8 @@ inE a es = SqlSyntaxBuilder (byteString "(" <> buildSql a <> byteString ") IN (" <> buildSepBy (byteString ", ") (map buildSql es)) -instance IsSql99ExpressionSyntax SqlSyntaxBuilder where - distinctE = sqlUnOp "DISTINCT" - similarToE = sqlBinOp "SIMILAR TO" - +instance IsSql99FunctionExpressionSyntax SqlSyntaxBuilder where + functionNameE fn = SqlSyntaxBuilder (byteString (TE.encodeUtf8 fn)) functionCallE function args = SqlSyntaxBuilder $ buildSql function <> @@ -277,6 +285,10 @@ buildSepBy (byteString ", ") (map buildSql args) <> byteString ")" +instance IsSql99ExpressionSyntax SqlSyntaxBuilder where + distinctE = sqlUnOp "DISTINCT" + similarToE = sqlBinOp "SIMILAR TO" + instanceFieldE e fieldNm = SqlSyntaxBuilder $ byteString "(" <> buildSql e <> byteString ")." <> byteString (TE.encodeUtf8 fieldNm) @@ -290,6 +302,7 @@ overE expr frame = SqlSyntaxBuilder $ buildSql expr <> buildSql frame + rowNumberE = SqlSyntaxBuilder (byteString "ROW_NUMBER()") instance IsSql2003WindowFrameSyntax SqlSyntaxBuilder where type Sql2003WindowFrameExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder @@ -378,16 +391,32 @@ descOrdering expr = SqlSyntaxBuilder (buildSql expr <> byteString " DESC") instance IsSql92TableSourceSyntax SqlSyntaxBuilder where + type Sql92TableSourceTableNameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder type Sql92TableSourceSelectSyntax SqlSyntaxBuilder = SqlSyntaxBuilder - tableNamed t = SqlSyntaxBuilder (quoteSql t) + type Sql92TableSourceExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + tableNamed = id tableFromSubSelect query = SqlSyntaxBuilder (byteString "(" <> buildSql query <> byteString ")") + tableFromValues vss = + SqlSyntaxBuilder $ + byteString "VALUES " <> + buildSepBy (byteString ", ") + (map (\vs -> byteString "(" <> + buildSepBy (byteString ", ") (map buildSql vs) <> + byteString ")") vss) +instance IsSql92TableNameSyntax SqlSyntaxBuilder where + tableName Nothing t = SqlSyntaxBuilder $ quoteSql t + tableName (Just s) t = SqlSyntaxBuilder $ quoteSql s <> byteString "." <> quoteSql t + instance IsSql92FromSyntax SqlSyntaxBuilder where type Sql92FromTableSourceSyntax SqlSyntaxBuilder = SqlSyntaxBuilder type Sql92FromExpressionSyntax SqlSyntaxBuilder = SqlSyntaxBuilder fromTable t Nothing = t - fromTable t (Just nm) = SqlSyntaxBuilder (buildSql t <> byteString " AS " <> quoteSql nm) + fromTable t (Just (nm, colNms)) = + SqlSyntaxBuilder (buildSql t <> byteString " AS " <> quoteSql nm <> + maybe mempty (\colNms' -> byteString "(" <> buildSepBy (byteString ", ") (map quoteSql colNms') <> byteString ")") colNms) innerJoin = join "INNER JOIN" leftJoin = join "LEFT JOIN" @@ -497,21 +526,13 @@ SqlSyntaxBuilder $ byteString fun <> byteString "(" <> buildSql a <> byteString")" --- * Fake 'MonadBeam' instance (for using 'SqlSyntaxBuilder' with migrations mainly) -data SqlSyntaxBackend +-- * Fake 'MonadBeam' instance (for using 'SqlSyntaxBuilder' with migrations mainly) -class Trivial a -instance Trivial a +-- data SqlSyntaxBackend -instance BeamBackend SqlSyntaxBackend where - type BackendFromField SqlSyntaxBackend = Trivial +-- class Trivial a +-- instance Trivial a newtype SqlSyntaxM a = SqlSyntaxM (IO a) deriving (Applicative, Functor, Monad, MonadIO, Fail.MonadFail) - -instance MonadBeam SqlSyntaxBuilder SqlSyntaxBackend SqlSyntaxBackend SqlSyntaxM where - withDatabaseDebug _ _ _ = Fail.fail "absurd" - runReturningMany _ _ = Fail.fail "absurd" - - diff --git a/Database/Beam/Backend/SQL/Row.hs b/Database/Beam/Backend/SQL/Row.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Backend/SQL/Row.hs @@ -0,0 +1,200 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ConstraintKinds #-} + +module Database.Beam.Backend.SQL.Row + ( FromBackendRowF(..), FromBackendRowM(..) + , parseOneField, peekField + + , ColumnParseError(..), BeamRowReadError(..) + + , FromBackendRow(..) + ) where + +import Database.Beam.Backend.SQL.Types +import Database.Beam.Backend.Types + +import Control.Applicative +import Control.Exception (Exception) +import Control.Monad.Free.Church +import Control.Monad.Identity +import Data.Tagged +import Data.Typeable +import Data.Vector.Sized (Vector) +import qualified Data.Vector.Sized as Vector + +#if !MIN_VERSION_base(4, 12, 0) +import Data.Proxy +#endif + +import GHC.Generics +import GHC.TypeLits + +-- | The exact error encountered +data ColumnParseError + = ColumnUnexpectedNull + | ColumnNotEnoughColumns !Int + | ColumnTypeMismatch + { ctmHaskellType :: String + , ctmSQLType :: String + , ctmMessage :: String + } + | ColumnErrorInternal String + deriving (Show, Eq, Ord) + +-- | An error that may occur when parsing a row. Contains an optional +-- annotation of which column was being parsed (if available). +data BeamRowReadError + = BeamRowReadError + { brreColumn :: !(Maybe Int) + , brreError :: !ColumnParseError + } deriving (Show, Eq, Ord) +instance Exception BeamRowReadError + +data FromBackendRowF be f where + ParseOneField :: (BackendFromField be a, Typeable a) => (a -> f) -> FromBackendRowF be f + Alt :: FromBackendRowM be a -> FromBackendRowM be a -> (a -> f) -> FromBackendRowF be f + FailParseWith :: BeamRowReadError -> FromBackendRowF be f +deriving instance Functor (FromBackendRowF be) +newtype FromBackendRowM be a = FromBackendRowM (F (FromBackendRowF be) a) + deriving (Functor, Applicative) + +instance Monad (FromBackendRowM be) where + return = pure + FromBackendRowM a >>= b = + FromBackendRowM $ + a >>= (\x -> let FromBackendRowM b' = b x in b') + + fail = FromBackendRowM . liftF . FailParseWith . + BeamRowReadError Nothing . ColumnErrorInternal + +instance Alternative (FromBackendRowM be) where + empty = fail "empty" + a <|> b = + FromBackendRowM (liftF (Alt a b id)) + +parseOneField :: (BackendFromField be a, Typeable a) => FromBackendRowM be a +parseOneField = do + x <- FromBackendRowM (liftF (ParseOneField id)) + pure x + +peekField :: (Typeable a, BackendFromField be a) => FromBackendRowM be (Maybe a) +peekField = fmap Just (FromBackendRowM (liftF (ParseOneField id))) <|> pure Nothing + +-- BeamBackend instead of BeamSqlBackend to prevent circular super class +class BeamBackend be => FromBackendRow be a where + -- | Parses a beam row. This should not fail, except in the case of + -- an internal bug in beam deserialization code. If it does fail, + -- this should throw a 'BeamRowParseError'. + fromBackendRow :: FromBackendRowM be a + default fromBackendRow :: (Typeable a, BackendFromField be a) => FromBackendRowM be a + fromBackendRow = parseOneField + + valuesNeeded :: Proxy be -> Proxy a -> Int + valuesNeeded _ _ = 1 + +class GFromBackendRow be (exposed :: * -> *) rep where + gFromBackendRow :: Proxy exposed -> FromBackendRowM be (rep ()) + gValuesNeeded :: Proxy be -> Proxy exposed -> Proxy rep -> Int +instance GFromBackendRow be e p => GFromBackendRow be (M1 t f e) (M1 t f p) where + gFromBackendRow _ = M1 <$> gFromBackendRow (Proxy @e) + gValuesNeeded be _ _ = gValuesNeeded be (Proxy @e) (Proxy @p) +instance GFromBackendRow be e U1 where + gFromBackendRow _ = pure U1 + gValuesNeeded _ _ _ = 0 +instance (GFromBackendRow be aExp a, GFromBackendRow be bExp b) => GFromBackendRow be (aExp :*: bExp) (a :*: b) where + gFromBackendRow _ = (:*:) <$> gFromBackendRow (Proxy @aExp) <*> gFromBackendRow (Proxy @bExp) + gValuesNeeded be _ _ = gValuesNeeded be (Proxy @aExp) (Proxy @a) + gValuesNeeded be (Proxy @bExp) (Proxy @b) +instance FromBackendRow be x => GFromBackendRow be (K1 R (Exposed x)) (K1 R x) where + gFromBackendRow _ = K1 <$> fromBackendRow + gValuesNeeded be _ _ = valuesNeeded be (Proxy @x) +instance FromBackendRow be (t Identity) => GFromBackendRow be (K1 R (t Exposed)) (K1 R (t Identity)) where + gFromBackendRow _ = K1 <$> fromBackendRow + gValuesNeeded be _ _ = valuesNeeded be (Proxy @(t Identity)) +instance FromBackendRow be (t (Nullable Identity)) => GFromBackendRow be (K1 R (t (Nullable Exposed))) (K1 R (t (Nullable Identity))) where + gFromBackendRow _ = K1 <$> fromBackendRow + gValuesNeeded be _ _ = valuesNeeded be (Proxy @(t (Nullable Identity))) +instance BeamBackend be => FromBackendRow be () where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep ())) + valuesNeeded _ _ = 0 + +instance ( BeamBackend be, KnownNat n, FromBackendRow be a ) => FromBackendRow be (Vector n a) where + fromBackendRow = Vector.replicateM fromBackendRow + valuesNeeded _ _ = fromIntegral (natVal (Proxy @n)) + +instance ( BeamBackend be, FromBackendRow be a, FromBackendRow be b ) => + FromBackendRow be (a, b) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b))) + valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) +instance ( BeamBackend be, FromBackendRow be a, FromBackendRow be b, FromBackendRow be c ) => + FromBackendRow be (a, b, c) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c))) + valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) +instance ( BeamBackend be + , FromBackendRow be a, FromBackendRow be b, FromBackendRow be c + , FromBackendRow be d ) => + FromBackendRow be (a, b, c, d) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c, Exposed d))) + valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) + valuesNeeded be (Proxy @d) +instance ( BeamBackend be + , FromBackendRow be a, FromBackendRow be b, FromBackendRow be c + , FromBackendRow be d, FromBackendRow be e ) => + FromBackendRow be (a, b, c, d, e) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c, Exposed d, Exposed e))) + valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) + valuesNeeded be (Proxy @d) + + valuesNeeded be (Proxy @e) +instance ( BeamBackend be + , FromBackendRow be a, FromBackendRow be b, FromBackendRow be c + , FromBackendRow be d, FromBackendRow be e, FromBackendRow be f ) => + FromBackendRow be (a, b, c, d, e, f) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c, Exposed d, Exposed e, Exposed f))) + valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) + valuesNeeded be (Proxy @d) + + valuesNeeded be (Proxy @e) + valuesNeeded be (Proxy @f) +instance ( BeamBackend be + , FromBackendRow be a, FromBackendRow be b, FromBackendRow be c + , FromBackendRow be d, FromBackendRow be e, FromBackendRow be f + , FromBackendRow be g ) => + FromBackendRow be (a, b, c, d, e, f, g) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c, Exposed d, Exposed e, Exposed f, Exposed g))) + valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) + valuesNeeded be (Proxy @d) + + valuesNeeded be (Proxy @e) + valuesNeeded be (Proxy @f) + valuesNeeded be (Proxy @g) +instance ( BeamBackend be + , FromBackendRow be a, FromBackendRow be b, FromBackendRow be c + , FromBackendRow be d, FromBackendRow be e, FromBackendRow be f + , FromBackendRow be g, FromBackendRow be h ) => + FromBackendRow be (a, b, c, d, e, f, g, h) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c, Exposed d, Exposed e, Exposed f, Exposed g, Exposed h))) + valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) + valuesNeeded be (Proxy @d) + + valuesNeeded be (Proxy @e) + valuesNeeded be (Proxy @f) + valuesNeeded be (Proxy @g) + valuesNeeded be (Proxy @h) + +instance ( BeamBackend be, Generic (tbl Identity), Generic (tbl Exposed) + , GFromBackendRow be (Rep (tbl Exposed)) (Rep (tbl Identity))) => + + FromBackendRow be (tbl Identity) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (tbl Exposed))) + valuesNeeded be _ = gValuesNeeded be (Proxy @(Rep (tbl Exposed))) (Proxy @(Rep (tbl Identity))) +instance ( BeamBackend be, Generic (tbl (Nullable Identity)), Generic (tbl (Nullable Exposed)) + , GFromBackendRow be (Rep (tbl (Nullable Exposed))) (Rep (tbl (Nullable Identity)))) => + + FromBackendRow be (tbl (Nullable Identity)) where + fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (tbl (Nullable Exposed)))) + valuesNeeded be _ = gValuesNeeded be (Proxy @(Rep (tbl (Nullable Exposed)))) (Proxy @(Rep (tbl (Nullable Identity)))) + +instance (FromBackendRow be x, FromBackendRow be SqlNull) => FromBackendRow be (Maybe x) where + fromBackendRow = + (Just <$> fromBackendRow) <|> + (Nothing <$ + replicateM_ (valuesNeeded (Proxy @be) (Proxy @(Maybe x))) + (do SqlNull <- fromBackendRow + pure ())) + valuesNeeded be _ = valuesNeeded be (Proxy @x) + +deriving instance Generic (a, b, c, d, e, f, g, h) + +instance (BeamBackend be, FromBackendRow be t) => FromBackendRow be (Tagged tag t) where + fromBackendRow = Tagged <$> fromBackendRow + +instance FromBackendRow be x => FromBackendRow be (SqlSerial x) where + fromBackendRow = SqlSerial <$> fromBackendRow diff --git a/Database/Beam/Backend/SQL/SQL2003.hs b/Database/Beam/Backend/SQL/SQL2003.hs --- a/Database/Beam/Backend/SQL/SQL2003.hs +++ b/Database/Beam/Backend/SQL/SQL2003.hs @@ -20,15 +20,18 @@ , IsSql2003LeadAndLagExpressionSyntax(..) , IsSql2008BigIntDataTypeSyntax(..) - , Sql2003ExpressionSanityCheck + , Sql2003SanityCheck ) where import Database.Beam.Backend.SQL.SQL99 import Data.Text (Text) -type Sql2003ExpressionSanityCheck syntax = - ( syntax ~ Sql2003WindowFrameExpressionSyntax (Sql2003ExpressionWindowFrameSyntax syntax) ) +type Sql2003SanityCheck syntax = + ( Sql92ExpressionSyntax syntax ~ Sql2003WindowFrameExpressionSyntax (Sql2003ExpressionWindowFrameSyntax (Sql92ExpressionSyntax syntax)) + , Sql92SelectOrderingSyntax (Sql92SelectSyntax syntax) ~ + Sql2003WindowFrameOrderingSyntax (Sql2003ExpressionWindowFrameSyntax (Sql92ExpressionSyntax syntax)) + ) class IsSql92FromSyntax from => IsSql2003FromSyntax from where @@ -56,6 +59,7 @@ overE :: expr -> Sql2003ExpressionWindowFrameSyntax expr -> expr + rowNumberE :: expr -- | Optional SQL2003 "Advanced OLAP operations" T612 support class IsSql2003ExpressionSyntax expr => diff --git a/Database/Beam/Backend/SQL/SQL92.hs b/Database/Beam/Backend/SQL/SQL92.hs --- a/Database/Beam/Backend/SQL/SQL92.hs +++ b/Database/Beam/Backend/SQL/SQL92.hs @@ -4,7 +4,7 @@ module Database.Beam.Backend.SQL.SQL92 where import Database.Beam.Backend.SQL.Types -import Database.Beam.Backend.Types +import Database.Beam.Backend.SQL.Row import Data.Int import Data.Tagged @@ -12,14 +12,10 @@ import Data.Time (LocalTime) import Data.Typeable -class ( BeamSqlBackend be ) => - BeamSql92Backend be where - -- * Finally tagless style class HasSqlValueSyntax expr ty where sqlValueSyntax :: ty -> expr -class IsSqlExpressionSyntaxStringType expr ty autoSqlValueSyntax :: (HasSqlValueSyntax expr String, Show a) => a -> expr autoSqlValueSyntax = sqlValueSyntax . show @@ -29,9 +25,11 @@ type Sql92SelectGroupingSyntax select = Sql92SelectTableGroupingSyntax (Sql92SelectSelectTableSyntax select) type Sql92SelectFromSyntax select = Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select) type Sql92InsertExpressionSyntax select = Sql92InsertValuesExpressionSyntax (Sql92InsertValuesSyntax select) +type Sql92TableNameSyntax select = Sql92TableSourceTableNameSyntax (Sql92FromTableSourceSyntax (Sql92SelectFromSyntax select)) type Sql92ValueSyntax cmdSyntax = Sql92ExpressionValueSyntax (Sql92ExpressionSyntax cmdSyntax) type Sql92ExpressionSyntax cmdSyntax = Sql92SelectExpressionSyntax (Sql92SelectSyntax cmdSyntax) +type Sql92ExtractFieldSyntax cmdSyntax = Sql92ExpressionExtractFieldSyntax (Sql92ExpressionSyntax cmdSyntax) type Sql92HasValueSyntax cmdSyntax = HasSqlValueSyntax (Sql92ValueSyntax cmdSyntax) -- Putting these in the head constraint can cause infinite recursion that would @@ -44,14 +42,34 @@ , Sql92ProjectionExpressionSyntax (Sql92SelectTableProjectionSyntax (Sql92SelectSelectTableSyntax select)) ~ Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select) , Sql92OrderingExpressionSyntax (Sql92SelectOrderingSyntax select) ~ + Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select) + , Sql92TableSourceExpressionSyntax (Sql92FromTableSourceSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select))) ~ Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) -type Sql92SanityCheck cmd = ( Sql92SelectSanityCheck (Sql92SelectSyntax cmd) - , Sql92ExpressionValueSyntax (Sql92InsertValuesExpressionSyntax (Sql92InsertValuesSyntax (Sql92InsertSyntax cmd))) ~ Sql92ValueSyntax cmd - , Sql92ExpressionValueSyntax (Sql92UpdateExpressionSyntax (Sql92UpdateSyntax cmd)) ~ Sql92ValueSyntax cmd - , Sql92ExpressionValueSyntax (Sql92DeleteExpressionSyntax (Sql92DeleteSyntax cmd)) ~ Sql92ValueSyntax cmd - , Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax (Sql92SelectSyntax cmd)) ~ - Sql92InsertValuesExpressionSyntax (Sql92InsertValuesSyntax (Sql92InsertSyntax cmd)) ) +type Sql92SanityCheck cmd = + ( Sql92SelectSanityCheck (Sql92SelectSyntax cmd) + , Sql92ExpressionValueSyntax (Sql92InsertValuesExpressionSyntax (Sql92InsertValuesSyntax (Sql92InsertSyntax cmd))) ~ Sql92ValueSyntax cmd + , Sql92ExpressionValueSyntax (Sql92UpdateExpressionSyntax (Sql92UpdateSyntax cmd)) ~ Sql92ValueSyntax cmd + , Sql92ExpressionValueSyntax (Sql92DeleteExpressionSyntax (Sql92DeleteSyntax cmd)) ~ Sql92ValueSyntax cmd + , Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax (Sql92SelectSyntax cmd)) ~ + Sql92InsertValuesExpressionSyntax (Sql92InsertValuesSyntax (Sql92InsertSyntax cmd)) + + , Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax (Sql92SelectSyntax cmd)) ~ + Sql92UpdateExpressionSyntax (Sql92UpdateSyntax cmd) + + , Sql92DeleteExpressionSyntax (Sql92DeleteSyntax cmd) ~ + Sql92UpdateExpressionSyntax (Sql92UpdateSyntax cmd) + + , Sql92ExpressionSelectSyntax (Sql92InsertExpressionSyntax (Sql92InsertSyntax cmd)) ~ + Sql92SelectSyntax cmd + + , Sql92InsertValuesSelectSyntax (Sql92InsertValuesSyntax (Sql92InsertSyntax cmd)) ~ + Sql92SelectSyntax cmd + + , Sql92UpdateFieldNameSyntax (Sql92UpdateSyntax cmd) ~ + Sql92ExpressionFieldNameSyntax (Sql92InsertValuesExpressionSyntax (Sql92InsertValuesSyntax (Sql92InsertSyntax cmd))) + ) + type Sql92ReasonableMarshaller be = ( FromBackendRow be Int, FromBackendRow be SqlNull , FromBackendRow be Text, FromBackendRow be Bool @@ -59,6 +77,13 @@ , FromBackendRow be Int16, FromBackendRow be Int32, FromBackendRow be Int64 , FromBackendRow be LocalTime ) +-- | Type classes for syntaxes which can be displayed +class Sql92DisplaySyntax syntax where + + -- | Render the syntax as a 'String', representing the SQL expression it + -- stands for + displaySyntax :: syntax -> String + class ( IsSql92SelectSyntax (Sql92SelectSyntax cmd) , IsSql92InsertSyntax (Sql92InsertSyntax cmd) , IsSql92UpdateSyntax (Sql92UpdateSyntax cmd) @@ -117,12 +142,16 @@ unionTables, intersectTables, exceptTable :: Bool -> select -> select -> select -class IsSql92InsertValuesSyntax (Sql92InsertValuesSyntax insert) => +class ( IsSql92InsertValuesSyntax (Sql92InsertValuesSyntax insert) + , IsSql92TableNameSyntax (Sql92InsertTableNameSyntax insert) ) => IsSql92InsertSyntax insert where type Sql92InsertValuesSyntax insert :: * - insertStmt :: Text + type Sql92InsertTableNameSyntax insert :: * + + insertStmt :: Sql92InsertTableNameSyntax insert -> [ Text ] + -- ^ Fields -> Sql92InsertValuesSyntax insert -> insert @@ -137,21 +166,26 @@ -> insertValues class ( IsSql92ExpressionSyntax (Sql92UpdateExpressionSyntax update) - , IsSql92FieldNameSyntax (Sql92UpdateFieldNameSyntax update)) => + , IsSql92FieldNameSyntax (Sql92UpdateFieldNameSyntax update) + , IsSql92TableNameSyntax (Sql92UpdateTableNameSyntax update) ) => IsSql92UpdateSyntax update where + + type Sql92UpdateTableNameSyntax update :: * type Sql92UpdateFieldNameSyntax update :: * type Sql92UpdateExpressionSyntax update :: * - updateStmt :: Text + updateStmt :: Sql92UpdateTableNameSyntax update -> [(Sql92UpdateFieldNameSyntax update, Sql92UpdateExpressionSyntax update)] -> Maybe (Sql92UpdateExpressionSyntax update) {-^ WHERE -} -> update -class IsSql92ExpressionSyntax (Sql92DeleteExpressionSyntax delete) => +class ( IsSql92TableNameSyntax (Sql92DeleteTableNameSyntax delete) + , IsSql92ExpressionSyntax (Sql92DeleteExpressionSyntax delete) ) => IsSql92DeleteSyntax delete where + type Sql92DeleteTableNameSyntax delete :: * type Sql92DeleteExpressionSyntax delete :: * - deleteStmt :: Text -> Maybe Text + deleteStmt :: Sql92DeleteTableNameSyntax delete -> Maybe Text -> Maybe (Sql92DeleteExpressionSyntax delete) -> delete @@ -166,6 +200,14 @@ class IsSql92QuantifierSyntax quantifier where quantifyOverAll, quantifyOverAny :: quantifier +class IsSql92ExtractFieldSyntax extractField where + secondsField :: extractField + minutesField :: extractField + hourField :: extractField + dayField :: extractField + monthField :: extractField + yearField :: extractField + class IsSql92DataTypeSyntax dataType where domainType :: Text -> dataType charType :: Maybe Word -> Maybe Text -> dataType @@ -191,6 +233,8 @@ , HasSqlValueSyntax (Sql92ExpressionValueSyntax expr) Bool , IsSql92FieldNameSyntax (Sql92ExpressionFieldNameSyntax expr) , IsSql92QuantifierSyntax (Sql92ExpressionQuantifierSyntax expr) + , IsSql92DataTypeSyntax (Sql92ExpressionCastTargetSyntax expr) + , IsSql92ExtractFieldSyntax (Sql92ExpressionExtractFieldSyntax expr) , Typeable expr ) => IsSql92ExpressionSyntax expr where type Sql92ExpressionQuantifierSyntax expr :: * @@ -210,6 +254,8 @@ fieldE :: Sql92ExpressionFieldNameSyntax expr -> expr betweenE :: expr -> expr -> expr -> expr + betweenE a lower upper = + (gtE Nothing a lower) `andE` (ltE Nothing a upper) andE, orE, addE, subE, mulE, divE, likeE, modE, overlapsE, nullIfE, positionE @@ -295,10 +341,22 @@ ascOrdering, descOrdering :: Sql92OrderingExpressionSyntax ord -> ord -class IsSql92TableSourceSyntax tblSource where +class IsSql92TableNameSyntax tblName where + tableName :: Maybe Text {-^ Schema -} + -> Text {-^ Table name -} + -> tblName + +class IsSql92TableNameSyntax (Sql92TableSourceTableNameSyntax tblSource) => + IsSql92TableSourceSyntax tblSource where + type Sql92TableSourceSelectSyntax tblSource :: * - tableNamed :: Text -> tblSource + type Sql92TableSourceExpressionSyntax tblSource :: * + type Sql92TableSourceTableNameSyntax tblSource :: * + + tableNamed :: Sql92TableSourceTableNameSyntax tblSource + -> tblSource tableFromSubSelect :: Sql92TableSourceSelectSyntax tblSource -> tblSource + tableFromValues :: [ [ Sql92TableSourceExpressionSyntax tblSource ] ] -> tblSource class IsSql92GroupingSyntax grouping where type Sql92GroupingExpressionSyntax grouping :: * @@ -312,7 +370,7 @@ type Sql92FromExpressionSyntax from :: * fromTable :: Sql92FromTableSourceSyntax from - -> Maybe Text + -> Maybe (Text, Maybe [Text]) -> from innerJoin, leftJoin, rightJoin @@ -330,4 +388,3 @@ instance HasSqlValueSyntax vs t => HasSqlValueSyntax vs (Tagged tag t) where sqlValueSyntax = sqlValueSyntax . untag -instance IsSqlExpressionSyntaxStringType e t => IsSqlExpressionSyntaxStringType e (Tagged tag t) diff --git a/Database/Beam/Backend/SQL/SQL99.hs b/Database/Beam/Backend/SQL/SQL99.hs --- a/Database/Beam/Backend/SQL/SQL99.hs +++ b/Database/Beam/Backend/SQL/SQL99.hs @@ -3,9 +3,13 @@ -- | Finally tagless extension of SQL92 syntaxes for SQL99 module Database.Beam.Backend.SQL.SQL99 ( module Database.Beam.Backend.SQL.SQL92 + , IsSql99FunctionExpressionSyntax(..) , IsSql99ExpressionSyntax(..) , IsSql99ConcatExpressionSyntax(..) , IsSql99AggregationExpressionSyntax(..) + , IsSql99CommonTableExpressionSelectSyntax(..) + , IsSql99CommonTableExpressionSyntax(..) + , IsSql99RecursiveCommonTableExpressionSelectSyntax(..) , IsSql99SelectSyntax(..) , IsSql99DataTypeSyntax(..) ) where @@ -17,13 +21,17 @@ IsSql99SelectSyntax select class IsSql92ExpressionSyntax expr => + IsSql99FunctionExpressionSyntax expr where + + functionCallE :: expr -> [ expr ] -> expr + functionNameE :: Text -> expr + +class IsSql99FunctionExpressionSyntax expr => IsSql99ExpressionSyntax expr where distinctE :: Sql92ExpressionSelectSyntax expr -> expr similarToE :: expr -> expr -> expr - functionCallE :: expr -> [ expr ] -> expr - instanceFieldE :: expr -> Text -> expr refFieldE :: expr -> Text -> expr @@ -42,3 +50,19 @@ booleanType :: dataType arrayType :: dataType -> Int -> dataType rowType :: [ (Text, dataType) ] -> dataType + +class IsSql92SelectSyntax syntax => + IsSql99CommonTableExpressionSelectSyntax syntax where + type Sql99SelectCTESyntax syntax :: * + + withSyntax :: [ Sql99SelectCTESyntax syntax ] -> syntax -> syntax + +class IsSql99CommonTableExpressionSelectSyntax syntax + => IsSql99RecursiveCommonTableExpressionSelectSyntax syntax where + + withRecursiveSyntax :: [ Sql99SelectCTESyntax syntax ] -> syntax -> syntax + +class IsSql99CommonTableExpressionSyntax syntax where + type Sql99CTESelectSyntax syntax :: * + + cteSubquerySyntax :: Text -> [Text] -> Sql99CTESelectSyntax syntax -> syntax diff --git a/Database/Beam/Backend/SQL/Types.hs b/Database/Beam/Backend/SQL/Types.hs --- a/Database/Beam/Backend/SQL/Types.hs +++ b/Database/Beam/Backend/SQL/Types.hs @@ -1,14 +1,9 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Database.Beam.Backend.SQL.Types where -import Database.Beam.Backend.Types - import qualified Data.Aeson as Json import Data.Bits -class ( BeamBackend be ) => - BeamSqlBackend be where - data SqlNull = SqlNull deriving (Show, Eq, Ord, Bounded, Enum) newtype SqlBitString = SqlBitString Integer @@ -16,8 +11,7 @@ newtype SqlSerial a = SqlSerial { unSerial :: a } deriving (Show, Read, Eq, Ord, Num, Integral, Real, Enum) -instance FromBackendRow be x => FromBackendRow be (SqlSerial x) where - fromBackendRow = SqlSerial <$> fromBackendRow + instance Json.FromJSON a => Json.FromJSON (SqlSerial a) where parseJSON a = SqlSerial <$> Json.parseJSON a instance Json.ToJSON a => Json.ToJSON (SqlSerial a) where diff --git a/Database/Beam/Backend/Types.hs b/Database/Beam/Backend/Types.hs --- a/Database/Beam/Backend/Types.hs +++ b/Database/Beam/Backend/Types.hs @@ -1,59 +1,19 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ConstraintKinds #-} module Database.Beam.Backend.Types ( BeamBackend(..) - , FromBackendRowF(..), FromBackendRowM - , parseOneField, peekField, checkNextNNull - - , FromBackendRow(..) - - , Exposed, Nullable ) where - -import Control.Monad.Free.Church -import Control.Monad.Identity -import Data.Tagged -import Data.Vector.Sized (Vector) -import qualified Data.Vector.Sized as Vector + , Exposed, Nullable -import Data.Proxy + ) where -import GHC.Generics -import GHC.TypeLits -import GHC.Types +import GHC.Types --- | Class for all beam backends +-- | Class for all Beam backends class BeamBackend be where -- | Requirements to marshal a certain type from a database of a particular backend type BackendFromField be :: * -> Constraint -data FromBackendRowF be f where - ParseOneField :: BackendFromField be a => (a -> f) -> FromBackendRowF be f - PeekField :: BackendFromField be a => (Maybe a -> f) -> FromBackendRowF be f - CheckNextNNull :: Int -> (Bool -> f) -> FromBackendRowF be f -deriving instance Functor (FromBackendRowF be) -type FromBackendRowM be = F (FromBackendRowF be) - -parseOneField :: BackendFromField be a => FromBackendRowM be a -parseOneField = liftF (ParseOneField id) - -peekField :: BackendFromField be a => FromBackendRowM be (Maybe a) -peekField = liftF (PeekField id) - -checkNextNNull :: Int -> FromBackendRowM be Bool -checkNextNNull n = liftF (CheckNextNNull n id) - -class BeamBackend be => FromBackendRow be a where - fromBackendRow :: FromBackendRowM be a - default fromBackendRow :: BackendFromField be a => FromBackendRowM be a - fromBackendRow = parseOneField - - valuesNeeded :: Proxy be -> Proxy a -> Int - valuesNeeded _ _ = 1 - -- | newtype mainly used to inspect the tag structure of a particular -- 'Beamable'. Prevents overlapping instances in some case. Usually not used -- in end-user code. @@ -68,103 +28,3 @@ -- -- See 'Columnar' for more information. data Nullable (c :: * -> *) x - -class GFromBackendRow be (exposed :: * -> *) rep where - gFromBackendRow :: Proxy exposed -> FromBackendRowM be (rep ()) - gValuesNeeded :: Proxy be -> Proxy exposed -> Proxy rep -> Int -instance GFromBackendRow be e p => GFromBackendRow be (M1 t f e) (M1 t f p) where - gFromBackendRow _ = M1 <$> gFromBackendRow (Proxy @e) - gValuesNeeded be _ _ = gValuesNeeded be (Proxy @e) (Proxy @p) -instance GFromBackendRow be e U1 where - gFromBackendRow _ = pure U1 - gValuesNeeded _ _ _ = 0 -instance (GFromBackendRow be aExp a, GFromBackendRow be bExp b) => GFromBackendRow be (aExp :*: bExp) (a :*: b) where - gFromBackendRow _ = (:*:) <$> gFromBackendRow (Proxy @aExp) <*> gFromBackendRow (Proxy @bExp) - gValuesNeeded be _ _ = gValuesNeeded be (Proxy @aExp) (Proxy @a) + gValuesNeeded be (Proxy @bExp) (Proxy @b) -instance FromBackendRow be x => GFromBackendRow be (K1 R (Exposed x)) (K1 R x) where - gFromBackendRow _ = K1 <$> fromBackendRow - gValuesNeeded be _ _ = valuesNeeded be (Proxy @x) -instance FromBackendRow be (t Identity) => GFromBackendRow be (K1 R (t Exposed)) (K1 R (t Identity)) where - gFromBackendRow _ = K1 <$> fromBackendRow - gValuesNeeded be _ _ = valuesNeeded be (Proxy @(t Identity)) -instance FromBackendRow be (t (Nullable Identity)) => GFromBackendRow be (K1 R (t (Nullable Exposed))) (K1 R (t (Nullable Identity))) where - gFromBackendRow _ = K1 <$> fromBackendRow - gValuesNeeded be _ _ = valuesNeeded be (Proxy @(t (Nullable Identity))) -instance BeamBackend be => FromBackendRow be () where - fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep ())) - valuesNeeded _ _ = 0 - -instance ( BeamBackend be, KnownNat n, FromBackendRow be a ) => FromBackendRow be (Vector n a) where - fromBackendRow = Vector.replicateM fromBackendRow - valuesNeeded _ _ = fromIntegral (natVal (Proxy @n)) - -instance ( BeamBackend be, FromBackendRow be a, FromBackendRow be b ) => - FromBackendRow be (a, b) where - fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b))) - valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) -instance ( BeamBackend be, FromBackendRow be a, FromBackendRow be b, FromBackendRow be c ) => - FromBackendRow be (a, b, c) where - fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c))) - valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) -instance ( BeamBackend be - , FromBackendRow be a, FromBackendRow be b, FromBackendRow be c - , FromBackendRow be d ) => - FromBackendRow be (a, b, c, d) where - fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c, Exposed d))) - valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) + valuesNeeded be (Proxy @d) -instance ( BeamBackend be - , FromBackendRow be a, FromBackendRow be b, FromBackendRow be c - , FromBackendRow be d, FromBackendRow be e ) => - FromBackendRow be (a, b, c, d, e) where - fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c, Exposed d, Exposed e))) - valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) + valuesNeeded be (Proxy @d) + - valuesNeeded be (Proxy @e) -instance ( BeamBackend be - , FromBackendRow be a, FromBackendRow be b, FromBackendRow be c - , FromBackendRow be d, FromBackendRow be e, FromBackendRow be f ) => - FromBackendRow be (a, b, c, d, e, f) where - fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c, Exposed d, Exposed e, Exposed f))) - valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) + valuesNeeded be (Proxy @d) + - valuesNeeded be (Proxy @e) + valuesNeeded be (Proxy @f) -instance ( BeamBackend be - , FromBackendRow be a, FromBackendRow be b, FromBackendRow be c - , FromBackendRow be d, FromBackendRow be e, FromBackendRow be f - , FromBackendRow be g ) => - FromBackendRow be (a, b, c, d, e, f, g) where - fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c, Exposed d, Exposed e, Exposed f, Exposed g))) - valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) + valuesNeeded be (Proxy @d) + - valuesNeeded be (Proxy @e) + valuesNeeded be (Proxy @f) + valuesNeeded be (Proxy @g) -instance ( BeamBackend be - , FromBackendRow be a, FromBackendRow be b, FromBackendRow be c - , FromBackendRow be d, FromBackendRow be e, FromBackendRow be f - , FromBackendRow be g, FromBackendRow be h ) => - FromBackendRow be (a, b, c, d, e, f, g, h) where - fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (Exposed a, Exposed b, Exposed c, Exposed d, Exposed e, Exposed f, Exposed g, Exposed h))) - valuesNeeded be _ = valuesNeeded be (Proxy @a) + valuesNeeded be (Proxy @b) + valuesNeeded be (Proxy @c) + valuesNeeded be (Proxy @d) + - valuesNeeded be (Proxy @e) + valuesNeeded be (Proxy @f) + valuesNeeded be (Proxy @g) + valuesNeeded be (Proxy @h) - -instance ( BeamBackend be, Generic (tbl Identity), Generic (tbl Exposed) - , GFromBackendRow be (Rep (tbl Exposed)) (Rep (tbl Identity))) => - - FromBackendRow be (tbl Identity) where - fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (tbl Exposed))) - valuesNeeded be _ = gValuesNeeded be (Proxy @(Rep (tbl Exposed))) (Proxy @(Rep (tbl Identity))) -instance ( BeamBackend be, Generic (tbl (Nullable Identity)), Generic (tbl (Nullable Exposed)) - , GFromBackendRow be (Rep (tbl (Nullable Exposed))) (Rep (tbl (Nullable Identity)))) => - - FromBackendRow be (tbl (Nullable Identity)) where - fromBackendRow = to <$> gFromBackendRow (Proxy @(Rep (tbl (Nullable Exposed)))) - valuesNeeded be _ = gValuesNeeded be (Proxy @(Rep (tbl (Nullable Exposed)))) (Proxy @(Rep (tbl (Nullable Identity)))) - -instance FromBackendRow be x => FromBackendRow be (Maybe x) where - fromBackendRow = - do isNull <- checkNextNNull (valuesNeeded (Proxy @be) (Proxy @(Maybe x))) - if isNull then pure Nothing else Just <$> fromBackendRow - valuesNeeded be _ = valuesNeeded be (Proxy @x) - -deriving instance Generic (a, b, c, d, e, f, g, h) - --- Tagged - -instance (BeamBackend be, FromBackendRow be t) => FromBackendRow be (Tagged tag t) where - fromBackendRow = Tagged <$> fromBackendRow diff --git a/Database/Beam/Backend/URI.hs b/Database/Beam/Backend/URI.hs --- a/Database/Beam/Backend/URI.hs +++ b/Database/Beam/Backend/URI.hs @@ -3,8 +3,6 @@ -- | Convenience methods for constructing backend-agnostic applications module Database.Beam.Backend.URI where -import Database.Beam.Backend.SQL - import Control.Exception import qualified Data.Map as M @@ -24,8 +22,8 @@ instance Exception BeamOpenURIUnsupportedScheme data BeamURIOpener c where - BeamURIOpener :: MonadBeam syntax be hdl m - => c syntax be hdl m + BeamURIOpener :: c be hdl m + -> (forall a. hdl -> m a -> IO a) -> (URI -> IO (hdl, IO ())) -> BeamURIOpener c newtype BeamURIOpeners c where @@ -41,45 +39,45 @@ data OpenedBeamConnection c where OpenedBeamConnection - :: MonadBeam syntax be hdl m - => { openedBeamDatabase :: c syntax be hdl m - , openedBeamHandle :: hdl + :: { beamRunner :: (forall a. hdl -> m a -> IO a) + , openedBeamDatabase :: c be hdl m + , openedBeamHandle :: hdl , closeBeamConnection :: IO () } -> OpenedBeamConnection c -mkUriOpener :: MonadBeam syntax be hdl m - => String +mkUriOpener :: (forall a. hdl -> m a -> IO a) + -> String -> (URI -> IO (hdl, IO ())) - -> c syntax be hdl m + -> c be hdl m -> BeamURIOpeners c -mkUriOpener schemeNm opener c = BeamURIOpeners (M.singleton schemeNm (BeamURIOpener c opener)) +mkUriOpener runner schemeNm opener c = BeamURIOpeners (M.singleton schemeNm (BeamURIOpener c runner opener)) withDbFromUri :: forall c a . BeamURIOpeners c -> String - -> (forall syntax be hdl m. MonadBeam syntax be hdl m => c syntax be hdl m -> m a) + -> (forall be hdl m. (forall r. hdl -> m r -> IO r) -> c be hdl m -> m a) -> IO a withDbFromUri protos uri actionWithDb = - withDbConnection protos uri (\c hdl -> withDatabase hdl (actionWithDb c)) + withDbConnection protos uri (\runner c hdl -> runner hdl (actionWithDb runner c)) withDbConnection :: forall c a . BeamURIOpeners c -> String - -> (forall syntax be hdl m. MonadBeam syntax be hdl m => - c syntax be hdl m -> hdl -> IO a) + -> (forall be hdl m. (forall r. hdl -> m r -> IO r) -> + c be hdl m -> hdl -> IO a) -> IO a withDbConnection protos uri actionWithDb = bracket (openDbConnection protos uri) closeBeamConnection $ - \(OpenedBeamConnection c hdl _) -> actionWithDb c hdl + \(OpenedBeamConnection runner c hdl _) -> actionWithDb runner c hdl openDbConnection :: forall c . BeamURIOpeners c -> String -> IO (OpenedBeamConnection c) openDbConnection protos uri = do - (parsedUri, BeamURIOpener c openURI) <- findURIOpener protos uri + (parsedUri, BeamURIOpener c runner openURI) <- findURIOpener protos uri (hdl, closeHdl) <- openURI parsedUri - pure (OpenedBeamConnection c hdl closeHdl) + pure (OpenedBeamConnection runner c hdl closeHdl) findURIOpener :: BeamURIOpeners c -> String -> IO (URI, BeamURIOpener c) findURIOpener (BeamURIOpeners protos) uri = diff --git a/Database/Beam/Query.hs b/Database/Beam/Query.hs --- a/Database/Beam/Query.hs +++ b/Database/Beam/Query.hs @@ -13,15 +13,21 @@ , QAggregateContext, QGroupingContext, QValueContext , QWindowingContext, QWindowFrameContext - , QueryableSqlSyntax - , QGenExprTable, QExprTable + , QAssignment, QField, QFieldAssignment + + , QBaseScope + , module Database.Beam.Query.Combinators , module Database.Beam.Query.Extensions , module Database.Beam.Query.Relationships + , module Database.Beam.Query.CTE + + , module Database.Beam.Query.Extract + -- * Operators , module Database.Beam.Query.Operator @@ -31,6 +37,8 @@ , isFalse_, isNotFalse_ , isUnknown_, isNotUnknown_ , unknownAs_, sqlBool_ + , possiblyNullBool_ + , fromPossiblyNullBool_ -- ** Unquantified comparison operators , HasSqlEqualityCheck(..), HasSqlQuantifiedEqualityCheck(..) @@ -47,10 +55,12 @@ , module Database.Beam.Query.CustomSQL + , module Database.Beam.Query.DataTypes + -- * SQL Command construction and execution -- ** @SELECT@ , SqlSelect(..) - , select, lookup_ + , select, selectWith, lookup_ , runSelectReturningList , runSelectReturningOne , dumpSqlSelect @@ -69,6 +79,10 @@ -- ** @UPDATE@ , SqlUpdate(..) , update, save + , updateTable, set, setFieldsTo + , toNewValue, toOldValue, toUpdatedValue + , toUpdatedValueMaybe + , updateRow, updateTableRow , runUpdate -- ** @DELETE@ @@ -80,8 +94,12 @@ import Database.Beam.Query.Aggregate import Database.Beam.Query.Combinators +import Database.Beam.Query.CTE ( With, ReusableQ, selecting, reuse ) +import qualified Database.Beam.Query.CTE as CTE import Database.Beam.Query.CustomSQL +import Database.Beam.Query.DataTypes import Database.Beam.Query.Extensions +import Database.Beam.Query.Extract import Database.Beam.Query.Internal import Database.Beam.Query.Operator hiding (SqlBool) import qualified Database.Beam.Query.Operator as Beam @@ -90,63 +108,68 @@ import Database.Beam.Query.Types (QGenExpr) -- hide QGenExpr constructor import Database.Beam.Query.Types hiding (QGenExpr) -import Database.Beam.Backend.Types import Database.Beam.Backend.SQL import Database.Beam.Backend.SQL.Builder import Database.Beam.Schema.Tables import Control.Monad.Identity import Control.Monad.Writer +import Control.Monad.State.Strict +import Data.Functor.Const (Const(..)) import Data.Text (Text) import Data.Proxy +import Lens.Micro ((^.)) + -- * Query -data QueryInaccessible +data QBaseScope -- | A version of the table where each field is a 'QGenExpr' -type QGenExprTable ctxt syntax s tbl = tbl (QGenExpr ctxt syntax s) +type QGenExprTable ctxt be s tbl = tbl (QGenExpr ctxt be s) -type QExprTable syntax s tbl = QGenExprTable QValueContext syntax s tbl +type QExprTable be s tbl = QGenExprTable QValueContext be s tbl -- * SELECT --- | Represents a select statement over the syntax 'select' that will return --- rows of type 'a'. -newtype SqlSelect select a - = SqlSelect select - -type QueryableSqlSyntax cmd = - ( IsSql92Syntax cmd - , Sql92SanityCheck cmd - , HasQBuilder (Sql92SelectSyntax cmd) ) +-- | Represents a select statement in the given backend, returning +-- rows of type 'a'. +newtype SqlSelect be a + = SqlSelect (BeamSqlBackendSelectSyntax be) -- | Build a 'SqlSelect' for the given 'Q'. -select :: forall syntax db res. - ( ProjectibleInSelectSyntax syntax res - , IsSql92SelectSyntax syntax - , HasQBuilder syntax ) => - Q syntax db QueryInaccessible res -> SqlSelect syntax (QExprToIdentity res) +select :: forall be db res + . ( BeamSqlBackend be, HasQBuilder be, Projectible be res ) + => Q be db QBaseScope res -> SqlSelect be (QExprToIdentity res) select q = SqlSelect (buildSqlQuery "t" q) +-- | Create a 'SqlSelect' for a query which may have common table +-- expressions. See the documentation of 'With' for more details. +selectWith :: forall be db res + . ( BeamSqlBackend be, BeamSql99CommonTableExpressionBackend be + , HasQBuilder be, Projectible be res ) + => With be db (Q be db QBaseScope res) -> SqlSelect be (QExprToIdentity res) +selectWith (CTE.With mkQ) = + let (q, (recursiveness, ctes)) = evalState (runWriterT mkQ) 0 + in case recursiveness of + CTE.Nonrecursive -> SqlSelect (withSyntax ctes + (buildSqlQuery "t" q)) + CTE.Recursive -> SqlSelect (withRecursiveSyntax ctes + (buildSqlQuery "t" q)) + -- | Convenience function to generate a 'SqlSelect' that looks up a table row -- given a primary key. -lookup_ :: ( HasQBuilder syntax - , Sql92SelectSanityCheck syntax - - , SqlValableTable (PrimaryKey table) (Sql92SelectExpressionSyntax syntax) - , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectExpressionSyntax syntax)) Bool - - , HasTableEquality (Sql92SelectExpressionSyntax syntax) (PrimaryKey table) - - , Beamable table, Table table +lookup_ :: ( Database be db, Table table - , Database be db ) + , BeamSqlBackend be, HasQBuilder be + , SqlValableTable be (PrimaryKey table) + , HasTableEquality be (PrimaryKey table) + ) => DatabaseEntity be db (TableEntity table) -> PrimaryKey table Identity - -> SqlSelect syntax (table Identity) + -> SqlSelect be (table Identity) lookup_ tbl tblKey = select $ filter_ (\t -> pk t ==. val_ tblKey) $ @@ -154,8 +177,8 @@ -- | Run a 'SqlSelect' in a 'MonadBeam' and get the results as a list runSelectReturningList :: - (IsSql92Syntax cmd, MonadBeam cmd be hdl m, FromBackendRow be a) => - SqlSelect (Sql92SelectSyntax cmd) a -> m [ a ] + (MonadBeam be m, BeamSqlBackend be, FromBackendRow be a) => + SqlSelect be a -> m [ a ] runSelectReturningList (SqlSelect s) = runReturningList (selectCmd s) @@ -163,15 +186,15 @@ -- one. Both no results as well as more than one result cause this to return -- 'Nothing'. runSelectReturningOne :: - (IsSql92Syntax cmd, MonadBeam cmd be hdl m, FromBackendRow be a) => - SqlSelect (Sql92SelectSyntax cmd) a -> m (Maybe a) + (MonadBeam be m, BeamSqlBackend be, FromBackendRow be a) => + SqlSelect be a -> m (Maybe a) runSelectReturningOne (SqlSelect s) = runReturningOne (selectCmd s) -- | Use a special debug syntax to print out an ANSI Standard @SELECT@ statement -- that may be generated for a given 'Q'. -dumpSqlSelect :: ProjectibleInSelectSyntax SqlSyntaxBuilder res => - Q SqlSyntaxBuilder db QueryInaccessible res -> IO () +dumpSqlSelect :: Projectible (MockSqlBackend SqlSyntaxBuilder) res + => Q (MockSqlBackend SqlSyntaxBuilder) db QBaseScope res -> IO () dumpSqlSelect q = let SqlSelect s = select q in putStrLn (renderSql s) @@ -179,54 +202,54 @@ -- * INSERT -- | Represents a SQL @INSERT@ command that has not yet been run -data SqlInsert syntax - = SqlInsert syntax +data SqlInsert be (table :: (* -> *) -> *) + = SqlInsert !(TableSettings table) !(BeamSqlBackendInsertSyntax be) | SqlInsertNoRows -- | Generate a 'SqlInsert' over only certain fields of a table -insertOnly :: ( IsSql92InsertSyntax syntax, Projectible Text (QExprToField r) ) +insertOnly :: ( BeamSqlBackend be, ProjectibleWithPredicate AnyType () Text (QExprToField r) ) => DatabaseEntity be db (TableEntity table) -- ^ Table to insert into -> (table (QField s) -> QExprToField r) - -> SqlInsertValues (Sql92InsertValuesSyntax syntax) r + -> SqlInsertValues be r -- ^ Values to insert. See 'insertValues', 'insertExpressions', 'insertData', and 'insertFrom' for possibilities. - -> SqlInsert syntax + -> SqlInsert be table insertOnly _ _ SqlInsertValuesEmpty = SqlInsertNoRows -insertOnly (DatabaseEntity (DatabaseTable tblNm tblSettings)) mkProj (SqlInsertValues vs) = - SqlInsert (insertStmt tblNm proj vs) +insertOnly (DatabaseEntity dt@(DatabaseTable {})) mkProj (SqlInsertValues vs) = + SqlInsert (dbTableSettings dt) (insertStmt (tableNameFromEntity dt) proj vs) where - tblFields = changeBeamRep (\(Columnar' (TableField name)) -> Columnar' (QField False tblNm name)) tblSettings - proj = execWriter (project' (Proxy @AnyType) (\_ f -> tell [f ""] >> pure f) + tblFields = changeBeamRep (\(Columnar' fd) -> Columnar' (QField False (dbTableCurrentName dt) (fd ^. fieldName))) + (dbTableSettings dt) + proj = execWriter (project' (Proxy @AnyType) (Proxy @((), Text)) + (\_ _ f -> tell [f] >> pure f) (mkProj tblFields)) -- | Generate a 'SqlInsert' given a table and a source of values. -insert :: ( IsSql92InsertSyntax syntax, Projectible Text (table (QField s)) ) +insert :: ( BeamSqlBackend be, ProjectibleWithPredicate AnyType () Text (table (QField s)) ) => DatabaseEntity be db (TableEntity table) -- ^ Table to insert into - -> SqlInsertValues (Sql92InsertValuesSyntax syntax) (table (QExpr (Sql92InsertExpressionSyntax syntax) s)) + -> SqlInsertValues be (table (QExpr be s)) -- ^ Values to insert. See 'insertValues', 'insertExpressions', and 'insertFrom' for possibilities. - -> SqlInsert syntax + -> SqlInsert be table insert tbl values = insertOnly tbl id values -- | Run a 'SqlInsert' in a 'MonadBeam' -runInsert :: (IsSql92Syntax cmd, MonadBeam cmd be hdl m) - => SqlInsert (Sql92InsertSyntax cmd) -> m () +runInsert :: (BeamSqlBackend be, MonadBeam be m) + => SqlInsert be table -> m () runInsert SqlInsertNoRows = pure () -runInsert (SqlInsert i) = runNoReturn (insertCmd i) +runInsert (SqlInsert _ i) = runNoReturn (insertCmd i) -- | Represents a source of values that can be inserted into a table shaped like -- 'tbl'. -data SqlInsertValues insertValues proj --(tbl :: (* -> *) -> *) - = SqlInsertValues insertValues +data SqlInsertValues be proj --(tbl :: (* -> *) -> *) + = SqlInsertValues (BeamSqlBackendInsertValuesSyntax be) | SqlInsertValuesEmpty -- | Build a 'SqlInsertValues' from series of expressions in tables -insertExpressions :: - forall syntax table s. - ( Beamable table - , IsSql92InsertValuesSyntax syntax ) => - (forall s'. [ table (QExpr (Sql92InsertValuesExpressionSyntax syntax) s') ]) -> - SqlInsertValues syntax (table (QExpr (Sql92InsertValuesExpressionSyntax syntax) s)) +insertExpressions :: forall be table s + . ( BeamSqlBackend be, Beamable table ) + => (forall s'. [ table (QExpr be s') ]) + -> SqlInsertValues be (table (QExpr be s)) insertExpressions tbls = case sqlExprs of [] -> SqlInsertValuesEmpty @@ -234,45 +257,38 @@ where sqlExprs = map mkSqlExprs tbls - mkSqlExprs :: forall s'. table (QExpr (Sql92InsertValuesExpressionSyntax syntax) s') -> [Sql92InsertValuesExpressionSyntax syntax] + mkSqlExprs :: forall s'. table (QExpr be s') -> [ BeamSqlBackendExpressionSyntax be ] mkSqlExprs = allBeamValues (\(Columnar' (QExpr x)) -> x "t") -- | Build a 'SqlInsertValues' from concrete table values -insertValues :: - forall table syntax s. - ( Beamable table - , IsSql92InsertValuesSyntax syntax - , FieldsFulfillConstraint (HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92InsertValuesExpressionSyntax syntax))) table) => - [ table Identity ] -> SqlInsertValues syntax (table (QExpr (Sql92InsertValuesExpressionSyntax syntax) s)) -insertValues x = insertExpressions (map val_ x :: forall s'. [table (QExpr (Sql92InsertValuesExpressionSyntax syntax) s') ]) +insertValues :: forall be table s + . ( BeamSqlBackend be, Beamable table + , FieldsFulfillConstraint (BeamSqlBackendCanSerialize be) table ) + => [ table Identity ] + -> SqlInsertValues be (table (QExpr be s)) +insertValues x = insertExpressions (map val_ x :: forall s'. [table (QExpr be s') ]) -- | Build a 'SqlInsertValues' from arbitrarily shaped data containing expressions -insertData :: forall syntax r - . ( Projectible (Sql92InsertValuesExpressionSyntax syntax) r - , IsSql92InsertValuesSyntax syntax ) - => [ r ] -> SqlInsertValues syntax r +insertData :: forall be r + . ( Projectible be r, BeamSqlBackend be ) + => [ r ] -> SqlInsertValues be r insertData rows = case rows of [] -> SqlInsertValuesEmpty - _ -> SqlInsertValues (insertSqlExpressions (map mkSqlExprs rows)) - where - mkSqlExprs :: r -> [Sql92InsertValuesExpressionSyntax syntax] - mkSqlExprs r = execWriter (project' (Proxy @AnyType) (\_ s -> tell [ s "t" ] >> pure s) r) + _ -> SqlInsertValues (insertSqlExpressions (map (\row -> project (Proxy @be) row "t") rows)) -- | Build a 'SqlInsertValues' from a 'SqlSelect' that returns the same table -insertFrom - :: ( IsSql92InsertValuesSyntax syntax - , HasQBuilder (Sql92InsertValuesSelectSyntax syntax) - , Projectible (Sql92SelectExpressionSyntax (Sql92InsertValuesSelectSyntax syntax)) r ) - => Q (Sql92InsertValuesSelectSyntax syntax) db QueryInaccessible r - -> SqlInsertValues syntax r +insertFrom :: ( BeamSqlBackend be, HasQBuilder be + , Projectible be r ) + => Q be db QBaseScope r + -> SqlInsertValues be r insertFrom s = SqlInsertValues (insertFromSql (buildSqlQuery "t" s)) -- * UPDATE -- | Represents a SQL @UPDATE@ statement for the given @table@. -data SqlUpdate syntax (table :: (* -> *) -> *) - = SqlUpdate syntax +data SqlUpdate be (table :: (* -> *) -> *) + = SqlUpdate !(TableSettings table) !(BeamSqlBackendUpdateSyntax be) | SqlIdentityUpdate -- An update with no assignments -- | Build a 'SqlUpdate' given a table, a list of assignments, and a way to @@ -283,94 +299,188 @@ -- represents the left hand side of assignments. Sometimes, you'd like to also -- get the current value of a particular column. You can use the 'current_' -- function to convert a 'QField' to a 'QExpr'. -update :: ( Beamable table - , IsSql92UpdateSyntax syntax) => - DatabaseEntity be db (TableEntity table) +update :: ( BeamSqlBackend be, Beamable table ) + => DatabaseEntity be db (TableEntity table) -- ^ The table to insert into - -> (forall s. table (QField s) -> [ QAssignment (Sql92UpdateFieldNameSyntax syntax) (Sql92UpdateExpressionSyntax syntax) s ]) + -> (forall s. table (QField s) -> QAssignment be s) -- ^ A sequence of assignments to make. - -> (forall s. table (QExpr (Sql92UpdateExpressionSyntax syntax) s) -> QExpr (Sql92UpdateExpressionSyntax syntax) s Bool) + -> (forall s. table (QExpr be s) -> QExpr be s Bool) -- ^ Build a @WHERE@ clause given a table containing expressions - -> SqlUpdate syntax table -update (DatabaseEntity (DatabaseTable tblNm tblSettings)) mkAssignments mkWhere = + -> SqlUpdate be table +update (DatabaseEntity dt@(DatabaseTable {})) mkAssignments mkWhere = case assignments of [] -> SqlIdentityUpdate - _ -> SqlUpdate (updateStmt tblNm assignments (Just (where_ "t"))) + _ -> SqlUpdate (dbTableSettings dt) + (updateStmt (tableNameFromEntity dt) + assignments (Just (where_ "t"))) where - assignments = concatMap (\(QAssignment as) -> as) (mkAssignments tblFields) + QAssignment assignments = mkAssignments tblFields QExpr where_ = mkWhere tblFieldExprs - tblFields = changeBeamRep (\(Columnar' (TableField name)) -> Columnar' (QField False tblNm name)) tblSettings + tblFields = changeBeamRep (\(Columnar' fd) -> Columnar' (QField False (dbTableCurrentName dt) (fd ^. fieldName))) + (dbTableSettings dt) tblFieldExprs = changeBeamRep (\(Columnar' (QField _ _ nm)) -> Columnar' (QExpr (pure (fieldE (unqualifiedField nm))))) tblFields --- | Generate a 'SqlUpdate' that will update the given table with the given value. +-- | A specialization of 'update' that matches the given (already existing) row +updateRow :: ( BeamSqlBackend be, Table table + , HasTableEquality be (PrimaryKey table) + , SqlValableTable be (PrimaryKey table) ) + => DatabaseEntity be db (TableEntity table) + -- ^ The table to insert into + -> table Identity + -- ^ The row to update + -> (forall s. table (QField s) -> QAssignment be s) + -- ^ A sequence of assignments to make. + -> SqlUpdate be table +updateRow tbl row update' = + update tbl update' (references_ (val_ (pk row))) + +-- | A specialization of 'update' that is more convenient for normal tables. +updateTable :: forall table db be + . ( BeamSqlBackend be, Beamable table ) + => DatabaseEntity be db (TableEntity table) + -- ^ The table to update + -> table (QFieldAssignment be table) + -- ^ Updates to be made (use 'set' to construct an empty field) + -> (forall s. table (QExpr be s) -> QExpr be s Bool) + -> SqlUpdate be table +updateTable tblEntity assignments mkWhere = + let mkAssignments :: forall s. table (QField s) -> QAssignment be s + mkAssignments tblFields = + let tblExprs = changeBeamRep (\(Columnar' fd) -> Columnar' (current_ fd)) tblFields + in execWriter $ + zipBeamFieldsM + (\(Columnar' field :: Columnar' (QField s) a) + c@(Columnar' (QFieldAssignment mkAssignment)) -> + case mkAssignment tblExprs of + Nothing -> pure c + Just newValue -> do + tell (field <-. newValue) + pure c) + tblFields assignments + + in update tblEntity mkAssignments mkWhere + +-- | Convenience form of 'updateTable' that generates a @WHERE@ clause +-- that matches only the already existing entity +updateTableRow :: ( BeamSqlBackend be, Table table + , HasTableEquality be (PrimaryKey table) + , SqlValableTable be (PrimaryKey table) ) + => DatabaseEntity be db (TableEntity table) + -- ^ The table to update + -> table Identity + -- ^ The row to update + -> table (QFieldAssignment be table) + -- ^ Updates to be made (use 'set' to construct an empty field) + -> SqlUpdate be table +updateTableRow tbl row update' = + updateTable tbl update' (references_ (val_ (pk row))) + +set :: forall table be table'. Beamable table => table (QFieldAssignment be table') +set = changeBeamRep (\_ -> Columnar' (QFieldAssignment (\_ -> Nothing))) (tblSkeleton :: TableSkeleton table) + +setFieldsTo :: forall table be table' + . Table table => (forall s. table (QExpr be s)) -> table (QFieldAssignment be table') +setFieldsTo tbl = + + runIdentity $ + zipBeamFieldsM (\(Columnar' (Const columnIx)) + (Columnar' (QExpr newValue)) -> + if columnIx `elem` primaryKeyIndices + then pure $ Columnar' toOldValue + else pure $ Columnar' (toNewValue (QExpr newValue))) + indexedTable tbl + + where + indexedTable :: table (Const Int) + indexedTable = + flip evalState 0 $ + zipBeamFieldsM (\_ _ -> do + n <- get + put (n + 1) + return (Columnar' (Const n))) + (tblSkeleton :: TableSkeleton table) (tblSkeleton :: TableSkeleton table) + + primaryKeyIndices :: [ Int ] + primaryKeyIndices = allBeamValues (\(Columnar' (Const ix)) -> ix) (primaryKey indexedTable) + +-- | Use with 'set' to set a field to an explicit new value that does +-- not depend on any other value +toNewValue :: (forall s. QExpr be s a) -> QFieldAssignment be table a +toNewValue newVal = toUpdatedValue (\_ -> newVal) + +-- | Use with 'set' to not modify the field +toOldValue :: QFieldAssignment be table a +toOldValue = toUpdatedValueMaybe (\_ -> Nothing) + +-- | Use with 'set' to set a field to a new value that is calculated +-- based on one or more fields from the existing row +toUpdatedValue :: (forall s. table (QExpr be s) -> QExpr be s a) -> QFieldAssignment be table a +toUpdatedValue mkNewVal = toUpdatedValueMaybe (Just <$> mkNewVal) + +-- | Use with 'set' to optionally set a fiield to a new value, +-- calculated based on one or more fields from the existing row +toUpdatedValueMaybe :: (forall s. table (QExpr be s) -> Maybe (QExpr be s a)) -> QFieldAssignment be table a +toUpdatedValueMaybe = QFieldAssignment + +-- | Generate a 'SqlUpdate' that will update the given table row with the given value. -- -- The SQL @UPDATE@ that is generated will set every non-primary key field for -- the row where each primary key field is exactly what is given. -- -- Note: This is a pure SQL @UPDATE@ command. This does not upsert or merge values. -save :: forall table syntax be db. +save :: forall table be db. ( Table table - , IsSql92UpdateSyntax syntax - - , SqlValableTable (PrimaryKey table) (Sql92UpdateExpressionSyntax syntax) - , SqlValableTable table (Sql92UpdateExpressionSyntax syntax) + , BeamSqlBackend be - , HasTableEquality (Sql92UpdateExpressionSyntax syntax) (PrimaryKey table) + , SqlValableTable be (PrimaryKey table) + , SqlValableTable be table - , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92UpdateExpressionSyntax syntax)) Bool + , HasTableEquality be (PrimaryKey table) ) => DatabaseEntity be db (TableEntity table) -- ^ Table to update -> table Identity -- ^ Value to set to - -> SqlUpdate syntax table -save tbl@(DatabaseEntity (DatabaseTable _ tblSettings)) v = - update tbl (\(tblField :: table (QField s)) -> - execWriter $ - zipBeamFieldsM - (\(Columnar' field) c@(Columnar' value) -> - do when (qFieldName field `notElem` primaryKeyFieldNames) $ - tell [ field <-. value ] - pure c) - tblField (val_ v :: table (QExpr (Sql92UpdateExpressionSyntax syntax) s))) - (\tblE -> primaryKey tblE ==. val_ (primaryKey v)) - - where - primaryKeyFieldNames = - allBeamValues (\(Columnar' (TableField fieldNm)) -> fieldNm) (primaryKey tblSettings) + -> SqlUpdate be table +save tbl v = + updateTableRow tbl v + (setFieldsTo (val_ v)) -- | Run a 'SqlUpdate' in a 'MonadBeam'. -runUpdate :: (IsSql92Syntax cmd, MonadBeam cmd be hdl m) - => SqlUpdate (Sql92UpdateSyntax cmd) tbl -> m () -runUpdate (SqlUpdate u) = runNoReturn (updateCmd u) +runUpdate :: (BeamSqlBackend be, MonadBeam be m) + => SqlUpdate be tbl -> m () +runUpdate (SqlUpdate _ u) = runNoReturn (updateCmd u) runUpdate SqlIdentityUpdate = pure () -- * DELETE -- | Represents a SQL @DELETE@ statement for the given @table@ -newtype SqlDelete syntax (table :: (* -> *) -> *) = SqlDelete syntax +data SqlDelete be (table :: (* -> *) -> *) + = SqlDelete !(TableSettings table) !(BeamSqlBackendDeleteSyntax be) -- | Build a 'SqlDelete' from a table and a way to build a @WHERE@ clause -delete :: forall be db delete table - . IsSql92DeleteSyntax delete +delete :: forall be db table + . BeamSqlBackend be => DatabaseEntity be db (TableEntity table) -- ^ Table to delete from - -> (forall s. (forall s'. table (QExpr (Sql92DeleteExpressionSyntax delete) s')) -> QExpr (Sql92DeleteExpressionSyntax delete) s Bool) + -> (forall s. (forall s'. table (QExpr be s')) -> QExpr be s Bool) -- ^ Build a @WHERE@ clause given a table containing expressions - -> SqlDelete delete table -delete (DatabaseEntity (DatabaseTable tblNm tblSettings)) mkWhere = - SqlDelete (deleteStmt tblNm alias (Just (where_ "t"))) + -> SqlDelete be table +delete (DatabaseEntity dt@(DatabaseTable {})) mkWhere = + SqlDelete (dbTableSettings dt) + (deleteStmt (tableNameFromEntity dt) alias (Just (where_ "t"))) where - supportsAlias = deleteSupportsAlias (Proxy @delete) + supportsAlias = deleteSupportsAlias (Proxy @(BeamSqlBackendDeleteSyntax be)) tgtName = "delete_target" alias = if supportsAlias then Just tgtName else Nothing mkField = if supportsAlias then qualifiedField tgtName else unqualifiedField - QExpr where_ = mkWhere (changeBeamRep (\(Columnar' (TableField name)) -> Columnar' (QExpr (pure (fieldE (mkField name))))) tblSettings) + QExpr where_ = mkWhere (changeBeamRep (\(Columnar' fd) -> Columnar' (QExpr (pure (fieldE (mkField (fd ^. fieldName)))))) + (dbTableSettings dt)) -- | Run a 'SqlDelete' in a 'MonadBeam' -runDelete :: (IsSql92Syntax cmd, MonadBeam cmd be hdl m) - => SqlDelete (Sql92DeleteSyntax cmd) table -> m () -runDelete (SqlDelete d) = runNoReturn (deleteCmd d) +runDelete :: (BeamSqlBackend be, MonadBeam be m) + => SqlDelete be table -> m () +runDelete (SqlDelete _ d) = runNoReturn (deleteCmd d) diff --git a/Database/Beam/Query/Aggregate.hs b/Database/Beam/Query/Aggregate.hs --- a/Database/Beam/Query/Aggregate.hs +++ b/Database/Beam/Query/Aggregate.hs @@ -12,6 +12,7 @@ -- ** General-purpose aggregate functions #gp-agg-funcs# , sum_, avg_, min_, max_, count_, countAll_ , rank_, cumeDist_, percentRank_, denseRank_ + , rowNumber_ , every_, any_, some_ @@ -40,6 +41,9 @@ import Data.Typeable +type Aggregable be a = + ProjectibleWithPredicate AggregateContext be (WithExprContext (BeamSqlBackendExpressionSyntax' be)) a + -- | Compute an aggregate over a query. -- -- The supplied aggregate projection should return an aggregate expression (an @@ -58,27 +62,27 @@ -- -- For usage examples, see -- . -aggregate_ :: forall select a r db s. - ( ProjectibleWithPredicate AggregateContext (Sql92SelectExpressionSyntax select) a - , Projectible (Sql92SelectExpressionSyntax select) r - , Projectible (Sql92SelectExpressionSyntax select) a +aggregate_ :: forall be a r db s. + ( BeamSqlBackend be + , Aggregable be a, Projectible be r, Projectible be a , ContextRewritable a , ThreadRewritable (QNested s) (WithRewrittenContext a QValueContext) - - , IsSql92SelectSyntax select ) + ) => (r -> a) -- ^ Aggregate projection - -> Q select db (QNested s) r -- ^ Query to aggregate over - -> Q select db s (WithRewrittenThread (QNested s) s (WithRewrittenContext a QValueContext)) + -> Q be db (QNested s) r -- ^ Query to aggregate over + -> Q be db s (WithRewrittenThread (QNested s) s (WithRewrittenContext a QValueContext)) aggregate_ mkAggregation (Q aggregating) = Q (liftF (QAggregate mkAggregation' aggregating (rewriteThread (Proxy @s) . rewriteContext (Proxy @QValueContext)))) where mkAggregation' x tblPfx = let agg = mkAggregation x - doProject :: AggregateContext c => Proxy c -> WithExprContext (Sql92SelectExpressionSyntax select) - -> Writer [WithExprContext (Sql92SelectExpressionSyntax select)] - (WithExprContext (Sql92SelectExpressionSyntax select)) - doProject p expr = + doProject :: AggregateContext c + => Proxy c -> Proxy be + -> WithExprContext (BeamSqlBackendExpressionSyntax' be) + -> Writer [WithExprContext (BeamSqlBackendExpressionSyntax' be)] + (WithExprContext (BeamSqlBackendExpressionSyntax' be)) + doProject p _ expr = case cast p of Just (Proxy :: Proxy QGroupingContext) -> tell [ expr ] >> pure expr @@ -88,7 +92,9 @@ pure expr Nothing -> error "aggregate_: impossible" - groupingExprs = execWriter (project' (Proxy @AggregateContext) doProject agg) + groupingExprs = + fmap (fmap fromBeamSqlBackendExpressionSyntax) $ + execWriter (project' (Proxy @AggregateContext) (Proxy @(be, WithExprContext (BeamSqlBackendExpressionSyntax' be))) doProject agg) in case groupingExprs of [] -> (Nothing, agg) _ -> (Just (groupByExpressions (sequenceA groupingExprs tblPfx)), agg) @@ -101,16 +107,23 @@ group_ :: expr -> grouped -- | 'group_' for simple value expressions. -instance QGroupable (QExpr expr s a) (QGroupExpr expr s a) where +instance QGroupable (QExpr be s a) (QGroupExpr be s a) where group_ (QExpr a) = QExpr a -- | 'group_' for any 'Beamable' type. Adds every field in the type to the -- grouping key. This is the equivalent of including the grouping expression -- of each field in the type as part of the aggregate projection instance Beamable tbl => - QGroupable (tbl (QExpr expr s)) (tbl (QGroupExpr expr s)) where + QGroupable (tbl (QExpr be s)) (tbl (QGroupExpr be s)) where group_ = changeBeamRep (\(Columnar' (QExpr x)) -> Columnar' (QExpr x)) +-- | 'group_' for any 'Beamable' type. Adds every field in the type to the +-- grouping key. This is the equivalent of including the grouping expression +-- of each field in the type as part of the aggregate projection +instance Beamable tbl => + QGroupable (tbl (Nullable (QExpr be s))) (tbl (Nullable (QGroupExpr be s))) where + group_ = changeBeamRep (\(Columnar' (QExpr x)) -> Columnar' (QExpr x)) + -- | Compute an aggregate over all values in a group. Corresponds semantically -- to the @AGG(ALL ..)@ syntax, but doesn't produce an explicit @ALL@. To -- produce @ALL@ expicitly, see 'allInGroupExplicitly_'. @@ -132,7 +145,7 @@ -- 'allInGroup_' has the same semantic meaning, but does not produce an -- explicit @ALL@. allInGroupExplicitly_ :: IsSql92AggregationSetQuantifierSyntax s - => Maybe s + => Maybe s allInGroupExplicitly_ = Just setQuantifierAll -- ** Aggregations @@ -141,110 +154,114 @@ -- `countAll_`) because empty aggregates return SQL @NULL@ values. -- | SQL @MIN(ALL ..)@ function (but without the explicit ALL) -min_ :: IsSql92AggregationExpressionSyntax expr - => QExpr expr s a -> QAgg expr s (Maybe a) +min_ :: BeamSqlBackend be + => QExpr be s a -> QAgg be s (Maybe a) min_ = minOver_ allInGroup_ -- | SQL @MAX(ALL ..)@ function (but without the explicit ALL) -max_ :: IsSql92AggregationExpressionSyntax expr - => QExpr expr s a -> QAgg expr s (Maybe a) +max_ :: BeamSqlBackend be + => QExpr be s a -> QAgg be s (Maybe a) max_ = maxOver_ allInGroup_ -- | SQL @AVG(ALL ..)@ function (but without the explicit ALL) -avg_ :: ( IsSql92AggregationExpressionSyntax expr, Num a ) - => QExpr expr s a -> QAgg expr s (Maybe a) +avg_ :: ( BeamSqlBackend be, Num a ) + => QExpr be s a -> QAgg be s (Maybe a) avg_ = avgOver_ allInGroup_ -- | SQL @SUM(ALL ..)@ function (but without the explicit ALL) -sum_ :: ( IsSql92AggregationExpressionSyntax expr, Num a ) - => QExpr expr s a -> QAgg expr s (Maybe a) +sum_ :: ( BeamSqlBackend be, Num a ) + => QExpr be s a -> QAgg be s (Maybe a) sum_ = sumOver_ allInGroup_ -- | SQL @COUNT(*)@ function -countAll_ :: IsSql92AggregationExpressionSyntax expr => QAgg expr s Int +countAll_ :: BeamSqlBackend be => QAgg be s Int countAll_ = QExpr (pure countAllE) -- | SQL @COUNT(ALL ..)@ function (but without the explicit ALL) -count_ :: ( IsSql92AggregationExpressionSyntax expr - , Integral b ) => QExpr expr s a -> QAgg expr s b +count_ :: ( BeamSqlBackend be, Integral b ) + => QExpr be s a -> QAgg be s b count_ (QExpr over) = QExpr (countE Nothing <$> over) -- | SQL2003 @CUME_DIST@ function (Requires T612 Advanced OLAP operations support) -cumeDist_ :: IsSql2003ExpressionAdvancedOLAPOperationsSyntax expr - => QAgg expr s Double +cumeDist_ :: BeamSqlT612Backend be + => QAgg be s Double cumeDist_ = QExpr (pure cumeDistAggE) -- | SQL2003 @PERCENT_RANK@ function (Requires T612 Advanced OLAP operations support) -percentRank_ :: IsSql2003ExpressionAdvancedOLAPOperationsSyntax expr - => QAgg expr s Double +percentRank_ :: BeamSqlT612Backend be + => QAgg be s Double percentRank_ = QExpr (pure percentRankAggE) -denseRank_ :: IsSql2003ExpressionAdvancedOLAPOperationsSyntax expr - => QAgg expr s Int +-- | SQL2003 @DENSE_RANK@ function (Requires T612 Advanced OLAP operations support) +denseRank_ :: BeamSqlT612Backend be + => QAgg be s Int denseRank_ = QExpr (pure denseRankAggE) +-- | SQL2003 @ROW_NUMBER@ function +rowNumber_ :: BeamSql2003ExpressionBackend be + => QAgg be s Int +rowNumber_ = QExpr (pure rowNumberE) + -- | SQL2003 @RANK@ function (Requires T611 Elementary OLAP operations support) -rank_ :: IsSql2003ExpressionElementaryOLAPOperationsSyntax expr - => QAgg expr s Int +rank_ :: BeamSqlT611Backend be + => QAgg be s Int rank_ = QExpr (pure rankAggE) minOver_, maxOver_ - :: IsSql92AggregationExpressionSyntax expr - => Maybe (Sql92AggregationSetQuantifierSyntax expr) - -> QExpr expr s a -> QAgg expr s (Maybe a) + :: BeamSqlBackend be + => Maybe (BeamSqlBackendAggregationQuantifierSyntax be) + -> QExpr be s a -> QAgg be s (Maybe a) minOver_ q (QExpr a) = QExpr (minE q <$> a) maxOver_ q (QExpr a) = QExpr (maxE q <$> a) avgOver_, sumOver_ - :: ( IsSql92AggregationExpressionSyntax expr - , Num a ) - => Maybe (Sql92AggregationSetQuantifierSyntax expr) - -> QExpr expr s a -> QAgg expr s (Maybe a) + :: ( BeamSqlBackend be, Num a ) + => Maybe (BeamSqlBackendAggregationQuantifierSyntax be) + -> QExpr be s a -> QAgg be s (Maybe a) avgOver_ q (QExpr a) = QExpr (avgE q <$> a) sumOver_ q (QExpr a) = QExpr (sumE q <$> a) countOver_ - :: ( IsSql92AggregationExpressionSyntax expr - , Integral b ) - => Maybe (Sql92AggregationSetQuantifierSyntax expr) - -> QExpr expr s a -> QAgg expr s b + :: ( BeamSqlBackend be, Integral b ) + => Maybe (BeamSqlBackendAggregationQuantifierSyntax be) + -> QExpr be s a -> QAgg be s b countOver_ q (QExpr a) = QExpr (countE q <$> a) -- | SQL @EVERY@, @SOME@, and @ANY@ aggregates. Operates over -- 'SqlBool' only, as the result can be @NULL@, even if all inputs are -- known (no input rows). everyOver_, someOver_, anyOver_ - :: IsSql99AggregationExpressionSyntax expr - => Maybe (Sql92AggregationSetQuantifierSyntax expr) - -> QExpr expr s SqlBool -> QAgg expr s SqlBool + :: BeamSql99AggregationBackend be + => Maybe (BeamSqlBackendAggregationQuantifierSyntax be) + -> QExpr be s SqlBool -> QAgg be s SqlBool everyOver_ q (QExpr a) = QExpr (everyE q <$> a) someOver_ q (QExpr a) = QExpr (someE q <$> a) anyOver_ q (QExpr a) = QExpr (anyE q <$> a) -- | Support for FILTER (WHERE ...) syntax for aggregates. --- Part of SQL2003 Advanced OLAP operations feature (T612). +-- Part of SQL2003 Elementary OLAP operations feature (T611). -- -- See 'filterWhere_'' for a version that accepts 'SqlBool'. -filterWhere_ :: IsSql2003ExpressionElementaryOLAPOperationsSyntax expr - => QAgg expr s a -> QExpr expr s Bool -> QAgg expr s a +filterWhere_ :: BeamSqlT611Backend be + => QAgg be s a -> QExpr be s Bool -> QAgg be s a filterWhere_ agg cond = filterWhere_' agg (sqlBool_ cond) -- | Like 'filterWhere_' but accepting 'SqlBool'. -filterWhere_' :: IsSql2003ExpressionElementaryOLAPOperationsSyntax expr - => QAgg expr s a -> QExpr expr s SqlBool -> QAgg expr s a +filterWhere_' :: BeamSqlT611Backend be + => QAgg be s a -> QExpr be s SqlBool -> QAgg be s a filterWhere_' (QExpr agg) (QExpr cond) = QExpr (liftA2 filterAggE agg cond) -- | SQL99 @EVERY(ALL ..)@ function (but without the explicit ALL) -every_ :: IsSql99AggregationExpressionSyntax expr - => QExpr expr s SqlBool -> QAgg expr s SqlBool +every_ :: BeamSql99AggregationBackend be + => QExpr be s SqlBool -> QAgg be s SqlBool every_ = everyOver_ allInGroup_ -- | SQL99 @SOME(ALL ..)@ function (but without the explicit ALL) -some_ :: IsSql99AggregationExpressionSyntax expr - => QExpr expr s SqlBool -> QAgg expr s SqlBool +some_ :: BeamSql99AggregationBackend be + => QExpr be s SqlBool -> QAgg be s SqlBool some_ = someOver_ allInGroup_ -- | SQL99 @ANY(ALL ..)@ function (but without the explicit ALL) -any_ :: IsSql99AggregationExpressionSyntax expr - => QExpr expr s SqlBool -> QAgg expr s SqlBool +any_ :: BeamSql99AggregationBackend be + => QExpr be s SqlBool -> QAgg be s SqlBool any_ = anyOver_ allInGroup_ diff --git a/Database/Beam/Query/CTE.hs b/Database/Beam/Query/CTE.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Query/CTE.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} + +module Database.Beam.Query.CTE where + +import Database.Beam.Backend.SQL +import Database.Beam.Query.Internal +import Database.Beam.Query.Types + +import Control.Monad.Free.Church +import Control.Monad.Writer hiding ((<>)) +import Control.Monad.State.Strict + +import Data.Text (Text) +import Data.String +import Data.Proxy (Proxy(Proxy)) +#if !MIN_VERSION_base(4, 11, 0) +import Data.Semigroup +#endif + + +import Unsafe.Coerce + +data Recursiveness be where + Nonrecursive :: Recursiveness be + Recursive :: IsSql99RecursiveCommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be) + => Recursiveness be + +instance Monoid (Recursiveness be) where + mempty = Nonrecursive + mappend Recursive _ = Recursive + mappend _ Recursive = Recursive + mappend _ _ = Nonrecursive + +instance Semigroup (Recursiveness be) where + (<>) = mappend + +newtype With be (db :: (* -> *) -> *) a + = With { runWith :: WriterT (Recursiveness be, [ BeamSql99BackendCTESyntax be ]) + (State Int) a } + deriving (Monad, Applicative, Functor) + +instance IsSql99RecursiveCommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be) + => MonadFix (With be db) where + mfix f = With (tell (Recursive, mempty) >> mfix (runWith . f)) + +data QAnyScope + +data ReusableQ be db res where + ReusableQ :: Proxy res -> (forall s. Proxy s -> Q be db s (WithRewrittenThread QAnyScope s res)) -> ReusableQ be db res + +reusableForCTE :: forall be res db + . ( ThreadRewritable QAnyScope res + , Projectible be res + , BeamSqlBackend be ) + => Text -> ReusableQ be db res +reusableForCTE tblNm = + ReusableQ (Proxy @res) + (\proxyS -> + Q $ liftF (QAll (\_ -> fromTable (tableNamed (tableName Nothing tblNm)) . Just . (, Nothing)) + (\tblNm' -> fst $ mkFieldNames @be @res (qualifiedField tblNm')) + (\_ -> Nothing) + (rewriteThread @QAnyScope @res proxyS . snd))) + +selecting :: forall res be db + . ( BeamSql99CommonTableExpressionBackend be, HasQBuilder be + , Projectible be res + , ThreadRewritable QAnyScope res ) + => Q be db QAnyScope res -> With be db (ReusableQ be db res) +selecting q = + With $ do + cteId <- get + put (cteId + 1) + + let tblNm = fromString ("cte" ++ show cteId) + + (_ :: res, fieldNames) = mkFieldNames @be (qualifiedField tblNm) + tell (Nonrecursive, [ cteSubquerySyntax tblNm fieldNames (buildSqlQuery (tblNm <> "_") q) ]) + + pure (reusableForCTE tblNm) + +rescopeQ :: QM be db s res -> QM be db s' res +rescopeQ = unsafeCoerce + +reuse :: forall s be db res + . ReusableQ be db res -> Q be db s (WithRewrittenThread QAnyScope s res) +reuse (ReusableQ _ q) = q (Proxy @s) + diff --git a/Database/Beam/Query/Combinators.hs b/Database/Beam/Query/Combinators.hs --- a/Database/Beam/Query/Combinators.hs +++ b/Database/Beam/Query/Combinators.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} module Database.Beam.Query.Combinators ( -- * Various SQL functions and constructs @@ -23,7 +24,7 @@ -- * General query combinators - , all_ + , all_, values_ , allFromView_, join_, join_' , guard_, guard_', filter_, filter_' , related_, relatedBy_, relatedBy_' @@ -74,13 +75,15 @@ import Database.Beam.Schema.Tables -#if !MIN_VERSION_base(4, 11, 0) -import Control.Monad.Writer -#endif import Control.Monad.Identity import Control.Monad.Free import Control.Applicative +#if !MIN_VERSION_base(4, 11, 0) +import Control.Monad.Writer hiding ((<>)) +import Data.Semigroup +#endif + import Data.Maybe import Data.Proxy import Data.Time (LocalTime) @@ -88,79 +91,73 @@ import GHC.Generics -- | Introduce all entries of a table into the 'Q' monad -all_ :: forall be (db :: (* -> *) -> *) table select s. - ( Database be db - , IsSql92SelectSyntax select - - , IsSql92FromSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select)) - , IsSql92TableSourceSyntax (Sql92FromTableSourceSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select))) - , Sql92FromExpressionSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select)) ~ Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select) - - , Table table ) +all_ :: ( Database be db, BeamSqlBackend be ) => DatabaseEntity be db (TableEntity table) - -> Q select db s (table (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s)) -all_ (DatabaseEntity (DatabaseTable tblNm tblSettings)) = - Q $ liftF (QAll (\_ -> fromTable (tableNamed tblNm) . Just) tblSettings (\_ -> Nothing) snd) + -> Q be db s (table (QExpr be s)) +all_ (DatabaseEntity dt@(DatabaseTable {})) = + Q $ liftF (QAll (\_ -> fromTable (tableNamed (tableName (dbTableSchema dt) (dbTableCurrentName dt))) . Just . (,Nothing)) + (tableFieldsToExpressions (dbTableSettings dt)) + (\_ -> Nothing) snd) -- | Introduce all entries of a view into the 'Q' monad -allFromView_ :: forall be (db :: (* -> *) -> *) table select s. - ( Database be db - , IsSql92SelectSyntax select - - , IsSql92FromSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select)) - , IsSql92TableSourceSyntax (Sql92FromTableSourceSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select))) - , Sql92FromExpressionSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select)) ~ Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select) - , Beamable table ) +allFromView_ :: ( Database be db, Beamable table + , BeamSqlBackend be ) => DatabaseEntity be db (ViewEntity table) - -> Q select db s (table (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s)) -allFromView_ (DatabaseEntity (DatabaseView tblNm tblSettings)) = - Q $ liftF (QAll (\_ -> fromTable (tableNamed tblNm) . Just) tblSettings (\_ -> Nothing) snd) + -> Q be db s (table (QExpr be s)) +allFromView_ (DatabaseEntity vw) = + Q $ liftF (QAll (\_ -> fromTable (tableNamed (tableName (dbViewSchema vw) (dbViewCurrentName vw))) . Just . (,Nothing)) + (tableFieldsToExpressions (dbViewSettings vw)) + (\_ -> Nothing) snd) +values_ :: forall be db s a + . ( Projectible be a + , BeamSqlBackend be ) + => [ a ] -> Q be db s a +values_ rows = + Q $ liftF (QAll (\tblPfx -> fromTable (tableFromValues (map (\row -> project (Proxy @be) row tblPfx) rows)) . Just . (,Just fieldNames)) + (\tblNm' -> fst $ mkFieldNames (qualifiedField tblNm')) + (\_ -> Nothing) snd) + where + fieldNames = snd $ mkFieldNames @be @a unqualifiedField + -- | Introduce all entries of a table into the 'Q' monad based on the -- given QExpr. The join condition is expected to return a -- 'Bool'. For a version that takes 'SqlBool' (a possibly @UNKNOWN@ -- boolean, that maps more closely to the SQL standard), see -- 'join_''. -join_ :: ( Database be db, Table table - , IsSql92SelectSyntax select - , IsSql92FromSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select)) - , Sql92FromExpressionSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select)) ~ Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select) - , IsSql92TableSourceSyntax (Sql92FromTableSourceSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select))) ) => - DatabaseEntity be db (TableEntity table) - -> (table (QExpr (Sql92SelectExpressionSyntax select) s) -> QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s Bool) - -> Q select db s (table (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s)) +join_ :: ( Database be db, Table table, BeamSqlBackend be ) + => DatabaseEntity be db (TableEntity table) + -> (table (QExpr be s) -> QExpr be s Bool) + -> Q be db s (table (QExpr be s)) join_ tbl mkOn = join_' tbl (sqlBool_ . mkOn) -- | Like 'join_', but accepting an @ON@ condition that returns -- 'SqlBool' -join_' :: ( Database be db, Table table - , IsSql92SelectSyntax select - , IsSql92FromSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select)) - , Sql92FromExpressionSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select)) ~ Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select) - , IsSql92TableSourceSyntax (Sql92FromTableSourceSyntax (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select))) ) => - DatabaseEntity be db (TableEntity table) - -> (table (QExpr (Sql92SelectExpressionSyntax select) s) -> QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s SqlBool) - -> Q select db s (table (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s)) -join_' (DatabaseEntity (DatabaseTable tblNm tblSettings)) mkOn = - Q $ liftF (QAll (\_ -> fromTable (tableNamed tblNm) . Just) tblSettings (\tbl -> let QExpr on = mkOn tbl in Just on) snd) +join_' :: ( Database be db, Table table, BeamSqlBackend be ) + => DatabaseEntity be db (TableEntity table) + -> (table (QExpr be s) -> QExpr be s SqlBool) + -> Q be db s (table (QExpr be s)) +join_' (DatabaseEntity tbl@(DatabaseTable {})) mkOn = + Q $ liftF (QAll (\_ -> fromTable (tableNamed (tableName (dbTableSchema tbl) (dbTableCurrentName tbl))) . Just . (, Nothing)) + (tableFieldsToExpressions (dbTableSettings tbl)) + (\tbl' -> let QExpr on = mkOn tbl' in Just on) snd) -- | Introduce a table using a left join with no ON clause. Because this is not -- an inner join, the resulting table is made nullable. This means that each -- field that would normally have type 'QExpr x' will now have type 'QExpr -- (Maybe x)'. -perhaps_ :: forall s r select db. - ( Projectible (Sql92SelectExpressionSyntax select) r - , IsSql92SelectSyntax select +perhaps_ :: forall s r be db. + ( Projectible be r, BeamSqlBackend be , ThreadRewritable (QNested s) r - , Retaggable (QExpr (Sql92SelectExpressionSyntax select) s) (WithRewrittenThread (QNested s) s r) ) - => Q select db (QNested s) r - -> Q select db s (Retag Nullable (WithRewrittenThread (QNested s) s r)) + , Retaggable (QExpr be s) (WithRewrittenThread (QNested s) s r) ) + => Q be db (QNested s) r + -> Q be db s (Retag Nullable (WithRewrittenThread (QNested s) s r)) perhaps_ (Q sub) = Q $ liftF (QArbitraryJoin sub leftJoin (\_ -> Nothing) - (\r -> retag (\(Columnar' (QExpr e) :: Columnar' (QExpr (Sql92SelectExpressionSyntax select) s) a) -> - Columnar' (QExpr e) :: Columnar' (Nullable (QExpr (Sql92SelectExpressionSyntax select) s)) a) $ + (\r -> retag (\(Columnar' (QExpr e) :: Columnar' (QExpr be s) a) -> + Columnar' (QExpr e) :: Columnar' (Nullable (QExpr be s)) a) $ rewriteThread (Proxy @s) r)) -- | Outer join. every row of each table, returning @NULL@ for any row @@ -169,43 +166,45 @@ -- This expects a join expression returning 'Bool', for a version that -- accepts a 'SqlBool' (a possibly @UNKNOWN@ boolean, that maps more -- closely to the SQL standard), see 'outerJoin_'' -outerJoin_ :: forall s a b select db. - ( Projectible (Sql92SelectExpressionSyntax select) a, Projectible (Sql92SelectExpressionSyntax select) b +outerJoin_ :: forall s a b be db. + ( BeamSqlBackend be, BeamSqlBackendSupportsOuterJoin be + , Projectible be a, Projectible be b , ThreadRewritable (QNested s) a, ThreadRewritable (QNested s) b - , Retaggable (QExpr (Sql92SelectExpressionSyntax select) s) (WithRewrittenThread (QNested s) s a) - , Retaggable (QExpr (Sql92SelectExpressionSyntax select) s) (WithRewrittenThread (QNested s) s b) - , IsSql92FromOuterJoinSyntax (Sql92SelectFromSyntax select) ) - => Q select db (QNested s) a - -> Q select db (QNested s) b - -> ( (WithRewrittenThread (QNested s) s a, WithRewrittenThread (QNested s) s b) -> QExpr (Sql92SelectExpressionSyntax select) s Bool ) - -> Q select db s ( Retag Nullable (WithRewrittenThread (QNested s) s a) - , Retag Nullable (WithRewrittenThread (QNested s) s b) ) + , Retaggable (QExpr be s) (WithRewrittenThread (QNested s) s a) + , Retaggable (QExpr be s) (WithRewrittenThread (QNested s) s b) + ) + => Q be db (QNested s) a + -> Q be db (QNested s) b + -> ( (WithRewrittenThread (QNested s) s a, WithRewrittenThread (QNested s) s b) -> QExpr be s Bool ) + -> Q be db s ( Retag Nullable (WithRewrittenThread (QNested s) s a) + , Retag Nullable (WithRewrittenThread (QNested s) s b) ) outerJoin_ a b on_ = outerJoin_' a b (sqlBool_ . on_) -- | Like 'outerJoin_', but accepting 'SqlBool'. Pairs of rows for -- which the join condition is unknown are considered to be unrelated, -- by SQL compliant databases at least. -outerJoin_' :: forall s a b select db. - ( Projectible (Sql92SelectExpressionSyntax select) a, Projectible (Sql92SelectExpressionSyntax select) b +outerJoin_' :: forall s a b be db. + ( BeamSqlBackend be, BeamSqlBackendSupportsOuterJoin be + , Projectible be a, Projectible be b , ThreadRewritable (QNested s) a, ThreadRewritable (QNested s) b - , Retaggable (QExpr (Sql92SelectExpressionSyntax select) s) (WithRewrittenThread (QNested s) s a) - , Retaggable (QExpr (Sql92SelectExpressionSyntax select) s) (WithRewrittenThread (QNested s) s b) - , IsSql92FromOuterJoinSyntax (Sql92SelectFromSyntax select) ) - => Q select db (QNested s) a - -> Q select db (QNested s) b - -> ( (WithRewrittenThread (QNested s) s a, WithRewrittenThread (QNested s) s b) -> QExpr (Sql92SelectExpressionSyntax select) s SqlBool ) - -> Q select db s ( Retag Nullable (WithRewrittenThread (QNested s) s a) - , Retag Nullable (WithRewrittenThread (QNested s) s b) ) + , Retaggable (QExpr be s) (WithRewrittenThread (QNested s) s a) + , Retaggable (QExpr be s) (WithRewrittenThread (QNested s) s b) + ) + => Q be db (QNested s) a + -> Q be db (QNested s) b + -> ( (WithRewrittenThread (QNested s) s a, WithRewrittenThread (QNested s) s b) -> QExpr be s SqlBool ) + -> Q be db s ( Retag Nullable (WithRewrittenThread (QNested s) s a) + , Retag Nullable (WithRewrittenThread (QNested s) s b) ) outerJoin_' (Q a) (Q b) on_ = Q $ liftF (QTwoWayJoin a b outerJoin (\(a', b') -> let QExpr e = on_ (rewriteThread (Proxy @s) a', rewriteThread (Proxy @s) b') in Just e) (\(a', b') -> - let retag' :: (ThreadRewritable (QNested s) x, Retaggable (QExpr (Sql92SelectExpressionSyntax select) s) (WithRewrittenThread (QNested s) s x)) + let retag' :: (ThreadRewritable (QNested s) x, Retaggable (QExpr be s) (WithRewrittenThread (QNested s) s x)) => x -> Retag Nullable (WithRewrittenThread (QNested s) s x) - retag' = retag (\(Columnar' (QExpr e) :: Columnar' (QExpr (Sql92SelectExpressionSyntax select) s) x) -> - Columnar' (QExpr e) :: Columnar' (Nullable (QExpr (Sql92SelectExpressionSyntax select) s)) x) . + retag' = retag (\(Columnar' (QExpr e) :: Columnar' (QExpr be s) x) -> + Columnar' (QExpr e) :: Columnar' (Nullable (QExpr be s)) x) . rewriteThread (Proxy @s) in ( retag' a', retag' b' ))) @@ -216,47 +215,45 @@ -- -- The @ON@ condition given must return 'Bool'. For a version that -- accepts an @ON@ condition returning 'SqlBool', see 'leftJoin_''. -leftJoin_ :: forall s r select db. - ( Projectible (Sql92SelectExpressionSyntax select) r - , IsSql92SelectSyntax select +leftJoin_ :: forall s r be db. + ( BeamSqlBackend be, Projectible be r , ThreadRewritable (QNested s) r - , Retaggable (QExpr (Sql92SelectExpressionSyntax select) s) (WithRewrittenThread (QNested s) s r) ) - => Q select db (QNested s) r - -> (WithRewrittenThread (QNested s) s r -> QExpr (Sql92SelectExpressionSyntax select) s Bool) - -> Q select db s (Retag Nullable (WithRewrittenThread (QNested s) s r)) + , Retaggable (QExpr be s) (WithRewrittenThread (QNested s) s r) ) + => Q be db (QNested s) r + -> (WithRewrittenThread (QNested s) s r -> QExpr be s Bool) + -> Q be db s (Retag Nullable (WithRewrittenThread (QNested s) s r)) leftJoin_ sub on_ = leftJoin_' sub (sqlBool_ . on_) -- | Like 'leftJoin_', but accepts an @ON@ clause returning 'SqlBool'. -leftJoin_' :: forall s r select db. - ( Projectible (Sql92SelectExpressionSyntax select) r - , IsSql92SelectSyntax select +leftJoin_' :: forall s r be db. + ( BeamSqlBackend be, Projectible be r , ThreadRewritable (QNested s) r - , Retaggable (QExpr (Sql92SelectExpressionSyntax select) s) (WithRewrittenThread (QNested s) s r) ) - => Q select db (QNested s) r - -> (WithRewrittenThread (QNested s) s r -> QExpr (Sql92SelectExpressionSyntax select) s SqlBool) - -> Q select db s (Retag Nullable (WithRewrittenThread (QNested s) s r)) + , Retaggable (QExpr be s) (WithRewrittenThread (QNested s) s r) ) + => Q be db (QNested s) r + -> (WithRewrittenThread (QNested s) s r -> QExpr be s SqlBool) + -> Q be db s (Retag Nullable (WithRewrittenThread (QNested s) s r)) leftJoin_' (Q sub) on_ = Q $ liftF (QArbitraryJoin sub leftJoin (\r -> let QExpr e = on_ (rewriteThread (Proxy @s) r) in Just e) - (\r -> retag (\(Columnar' (QExpr e) :: Columnar' (QExpr (Sql92SelectExpressionSyntax select) s) a) -> - Columnar' (QExpr e) :: Columnar' (Nullable (QExpr (Sql92SelectExpressionSyntax select) s)) a) $ + (\r -> retag (\(Columnar' (QExpr e) :: Columnar' (QExpr be s) a) -> + Columnar' (QExpr e) :: Columnar' (Nullable (QExpr be s)) a) $ rewriteThread (Proxy @s) r)) -subselect_ :: forall s r select db. +subselect_ :: forall s r be db. ( ThreadRewritable (QNested s) r - , ProjectibleInSelectSyntax select r ) - => Q select db (QNested s) r - -> Q select db s (WithRewrittenThread (QNested s) s r) + , Projectible be r ) + => Q be db (QNested s) r + -> Q be db s (WithRewrittenThread (QNested s) s r) subselect_ (Q q') = Q (liftF (QSubSelect q' (rewriteThread (Proxy @s)))) -- | Only allow results for which the 'QExpr' yields 'True'. For a -- version that operates over possibly @NULL@ 'SqlBool's, see -- 'guard_''. -guard_ :: forall select db s. - ( IsSql92SelectSyntax select ) => - QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s Bool -> Q select db s () +guard_ :: forall be db s + . BeamSqlBackend be + => QExpr be s Bool -> Q be db s () guard_ = guard_' . sqlBool_ -- | Only allow results for which the 'QExpr' yields @TRUE@. @@ -265,179 +262,149 @@ -- 'Bool's, except for the special @UNKNOWN@ value that occurs when -- comparisons include @NULL@. For a version that operates over known -- non-@NULL@ booleans, see 'guard_'. -guard_' :: forall select db s - . IsSql92SelectSyntax select - => QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s SqlBool -> Q select db s () +guard_' :: forall be db s + . BeamSqlBackend be + => QExpr be s SqlBool -> Q be db s () guard_' (QExpr guardE') = Q (liftF (QGuard guardE' ())) -- | Synonym for @clause >>= \x -> guard_ (mkExpr x)>> pure x@. Use 'filter_'' for comparisons with 'SqlBool' -filter_ :: forall r select db s. - ( IsSql92SelectSyntax select ) - => (r -> QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s Bool) - -> Q select db s r -> Q select db s r +filter_ :: forall r be db s + . BeamSqlBackend be + => (r -> QExpr be s Bool) + -> Q be db s r -> Q be db s r filter_ mkExpr clause = clause >>= \x -> guard_ (mkExpr x) >> pure x -- | Synonym for @clause >>= \x -> guard_' (mkExpr x)>> pure x@. Use 'filter_' for comparisons with 'Bool' -filter_' :: forall r select db s. - ( IsSql92SelectSyntax select ) - => (r -> QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s SqlBool) - -> Q select db s r -> Q select db s r +filter_' :: forall r be db s + . BeamSqlBackend be + => (r -> QExpr be s SqlBool) + -> Q be db s r -> Q be db s r filter_' mkExpr clause = clause >>= \x -> guard_' (mkExpr x) >> pure x -- | Introduce all entries of the given table which are referenced by the given 'PrimaryKey' -related_ :: forall be db rel select s. - ( IsSql92SelectSyntax select - , HasTableEquality (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) (PrimaryKey rel) - , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select))) Bool - , Database be db, Table rel ) => - DatabaseEntity be db (TableEntity rel) - -> PrimaryKey rel (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s) - -> Q select db s (rel (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s)) +related_ :: forall be db rel s + . ( Database be db, Table rel, BeamSqlBackend be + , HasTableEquality be (PrimaryKey rel) + ) + => DatabaseEntity be db (TableEntity rel) + -> PrimaryKey rel (QExpr be s) + -> Q be db s (rel (QExpr be s)) related_ relTbl relKey = join_ relTbl (\rel -> relKey ==. primaryKey rel) -- | Introduce all entries of the given table which for which the expression (which can depend on the queried table returns true) -relatedBy_ :: forall be db rel select s. - ( Database be db, Table rel - , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select))) Bool - , IsSql92SelectSyntax select ) +relatedBy_ :: forall be db rel s + . ( Database be db, Table rel, BeamSqlBackend be ) => DatabaseEntity be db (TableEntity rel) - -> (rel (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s) -> - QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s Bool) - -> Q select db s (rel (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s)) + -> (rel (QExpr be s) -> QExpr be s Bool) + -> Q be db s (rel (QExpr be s)) relatedBy_ = join_ -- | Introduce all entries of the given table which for which the expression (which can depend on the queried table returns true) -relatedBy_' :: forall be db rel select s. - ( Database be db, Table rel - , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select))) Bool - , IsSql92SelectSyntax select ) +relatedBy_' :: forall be db rel s + . ( Database be db, Table rel, BeamSqlBackend be ) => DatabaseEntity be db (TableEntity rel) - -> (rel (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s) -> - QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s SqlBool) - -> Q select db s (rel (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s)) + -> (rel (QExpr be s) -> QExpr be s SqlBool) + -> Q be db s (rel (QExpr be s)) relatedBy_' = join_' -- | Generate an appropriate boolean 'QGenExpr' comparing the given foreign key -- to the given table. Useful for creating join conditions. -references_ :: ( IsSql92ExpressionSyntax expr - , HasTableEquality expr (PrimaryKey t) - , HasSqlValueSyntax (Sql92ExpressionValueSyntax expr) Bool - , Table t ) - => PrimaryKey t (QGenExpr ctxt expr s) -> t (QGenExpr ctxt expr s) -> QGenExpr ctxt expr s Bool +references_ :: ( Table t, BeamSqlBackend be + , HasTableEquality be (PrimaryKey t) ) + => PrimaryKey t (QGenExpr ctxt be s) -> t (QGenExpr ctxt be s) -> QGenExpr ctxt be s Bool references_ fk tbl = fk ==. pk tbl -- | Only return distinct values from a query -nub_ :: ( IsSql92SelectSyntax select - , Projectible (Sql92SelectExpressionSyntax select) r ) - => Q select db s r -> Q select db s r +nub_ :: ( BeamSqlBackend be, Projectible be r ) + => Q be db s r -> Q be db s r nub_ (Q sub) = Q $ liftF (QDistinct (\_ _ -> setQuantifierDistinct) sub id) -- | Limit the number of results returned by a query. -limit_ :: forall s a select db. - ( ProjectibleInSelectSyntax select a - , ThreadRewritable (QNested s) a ) => - Integer -> Q select db (QNested s) a -> Q select db s (WithRewrittenThread (QNested s) s a) +limit_ :: forall s a be db + . ( Projectible be a + , ThreadRewritable (QNested s) a ) + => Integer -> Q be db (QNested s) a -> Q be db s (WithRewrittenThread (QNested s) s a) limit_ limit' (Q q) = Q (liftF (QLimit limit' q (rewriteThread (Proxy @s)))) -- | Drop the first `offset'` results. -offset_ :: forall s a select db. - ( ProjectibleInSelectSyntax select a - , ThreadRewritable (QNested s) a ) => - Integer -> Q select db (QNested s) a -> Q select db s (WithRewrittenThread (QNested s) s a) +offset_ :: forall s a be db + . ( Projectible be a + , ThreadRewritable (QNested s) a ) + => Integer -> Q be db (QNested s) a -> Q be db s (WithRewrittenThread (QNested s) s a) offset_ offset' (Q q) = Q (liftF (QOffset offset' q (rewriteThread (Proxy @s)))) -- | Use the SQL @EXISTS@ operator to determine if the given query returns any results -exists_ :: ( IsSql92SelectSyntax select - , HasQBuilder select - , ProjectibleInSelectSyntax select a - , Sql92ExpressionSelectSyntax (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) ~ select) - => Q select db s a - -> QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s Bool +exists_ :: ( BeamSqlBackend be, HasQBuilder be, Projectible be a) + => Q be db s a -> QExpr be s Bool exists_ q = QExpr (\tbl -> existsE (buildSqlQuery tbl q)) -- | Use the SQL @UNIQUE@ operator to determine if the given query produces a unique result -unique_ :: ( IsSql92SelectSyntax select - , HasQBuilder select - , ProjectibleInSelectSyntax select a - , Sql92ExpressionSelectSyntax (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) ~ select) - => Q select db s a - -> QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s Bool +unique_ :: ( BeamSqlBackend be, HasQBuilder be, Projectible be a) + => Q be db s a -> QExpr be s Bool unique_ q = QExpr (\tbl -> uniqueE (buildSqlQuery tbl q)) -- | Use the SQL99 @DISTINCT@ operator to determine if the given query produces a distinct result -distinct_ :: ( IsSql99ExpressionSyntax (Sql92SelectExpressionSyntax select) - , HasQBuilder select - , ProjectibleInSelectSyntax select a - , Sql92ExpressionSelectSyntax (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) ~ select) => - Q select db s a - -> QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s Bool +distinct_ :: ( BeamSqlBackend be, BeamSql99ExpressionBackend be, HasQBuilder be, Projectible be a) + => Q be db s a -> QExpr be s Bool distinct_ q = QExpr (\tbl -> distinctE (buildSqlQuery tbl q)) -- | Project the (presumably) singular result of the given query as an expression -subquery_ :: - ( IsSql92SelectSyntax select - , HasQBuilder select - , ProjectibleInSelectSyntax select (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s a) - , Sql92ExpressionSelectSyntax (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) ~ select) => - Q select (db :: (* -> *) -> *) s (QExpr (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s a) - -> QGenExpr ctxt (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) s a +subquery_ :: ( BeamSqlBackend be, HasQBuilder be, Projectible be (QExpr be s a) ) + => Q be db s (QExpr be s a) + -> QGenExpr ctxt be s a subquery_ q = QExpr (\tbl -> subqueryE (buildSqlQuery tbl q)) -- | SQL @CHAR_LENGTH@ function -charLength_ :: ( IsSqlExpressionSyntaxStringType syntax text - , IsSql92ExpressionSyntax syntax ) - => QGenExpr context syntax s text -> QGenExpr context syntax s Int +charLength_ :: ( BeamSqlBackend be, BeamSqlBackendIsString be text ) + => QGenExpr context be s text -> QGenExpr context be s Int charLength_ (QExpr s) = QExpr (charLengthE <$> s) -- | SQL @OCTET_LENGTH@ function -octetLength_ :: ( IsSqlExpressionSyntaxStringType syntax text - , IsSql92ExpressionSyntax syntax ) - => QGenExpr context syntax s text -> QGenExpr context syntax s Int +octetLength_ :: ( BeamSqlBackend be, BeamSqlBackendIsString be text ) + => QGenExpr context be s text -> QGenExpr context be s Int octetLength_ (QExpr s) = QExpr (octetLengthE <$> s) -- | SQL @BIT_LENGTH@ function -bitLength_ :: - IsSql92ExpressionSyntax syntax => - QGenExpr context syntax s SqlBitString -> QGenExpr context syntax s Int +bitLength_ :: BeamSqlBackend be + => QGenExpr context be s SqlBitString -> QGenExpr context be s Int bitLength_ (QExpr x) = QExpr (bitLengthE <$> x) -- | SQL @CURRENT_TIMESTAMP@ function -currentTimestamp_ :: IsSql92ExpressionSyntax syntax => QGenExpr ctxt syntax s LocalTime +currentTimestamp_ :: BeamSqlBackend be => QGenExpr ctxt be s LocalTime currentTimestamp_ = QExpr (pure currentTimestampE) -- | SQL @POSITION(.. IN ..)@ function -position_ :: - ( IsSqlExpressionSyntaxStringType syntax text - , IsSql92ExpressionSyntax syntax, Integral b ) => - QExpr syntax s text -> QExpr syntax s text -> QExpr syntax s b +position_ :: ( BeamSqlBackendIsString be text + , BeamSqlBackend be, Integral b ) + => QExpr be s text -> QExpr be s text -> QExpr be s b position_ (QExpr needle) (QExpr haystack) = QExpr (liftA2 likeE needle haystack) -- | SQL @LOWER@ function -lower_ :: ( IsSqlExpressionSyntaxStringType syntax text - , IsSql92ExpressionSyntax syntax ) - => QGenExpr context syntax s text -> QGenExpr context syntax s text +lower_ :: ( BeamSqlBackendIsString be text + , BeamSqlBackend be ) + => QGenExpr context be s text -> QGenExpr context be s text lower_ (QExpr s) = QExpr (lowerE <$> s) -- | SQL @UPPER@ function -upper_ :: ( IsSqlExpressionSyntaxStringType syntax text - , IsSql92ExpressionSyntax syntax ) - => QGenExpr context syntax s text -> QGenExpr context syntax s text +upper_ :: ( BeamSqlBackendIsString be text + , BeamSqlBackend be ) + => QGenExpr context be s text -> QGenExpr context be s text upper_ (QExpr s) = QExpr (upperE <$> s) -- | SQL @TRIM@ function -trim_ :: ( IsSqlExpressionSyntaxStringType syntax text - , IsSql92ExpressionSyntax syntax ) - => QGenExpr context syntax s text -> QGenExpr context syntax s text +trim_ :: ( BeamSqlBackendIsString be text + , BeamSqlBackend be ) + => QGenExpr context be s text -> QGenExpr context be s text trim_ (QExpr s) = QExpr (trimE <$> s) -- | Combine all the given boolean value 'QGenExpr's with the '&&.' operator. -allE :: ( IsSql92ExpressionSyntax syntax, HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) Bool) => - [ QGenExpr context syntax s Bool ] -> QGenExpr context syntax s Bool +allE :: BeamSqlBackend be + => [ QGenExpr context be s Bool ] -> QGenExpr context be s Bool allE es = fromMaybe (QExpr (pure (valueE (sqlValueSyntax True)))) $ foldl (\expr x -> Just $ maybe x (\e -> e &&. x) expr) @@ -446,101 +413,90 @@ -- * UPDATE operators -- | Extract an expression representing the current (non-UPDATEd) value of a 'QField' -current_ :: IsSql92ExpressionSyntax expr - => QField s ty -> QExpr expr s ty +current_ :: BeamSqlBackend be => QField s ty -> QExpr be s ty current_ (QField False _ nm) = QExpr (pure (fieldE (unqualifiedField nm))) current_ (QField True tbl nm) = QExpr (pure (fieldE (qualifiedField tbl nm))) infix 4 <-. -class SqlUpdatable expr s lhs rhs | rhs -> expr, lhs -> s, rhs -> s, lhs s expr -> rhs, rhs -> lhs where +class BeamSqlBackend be => + SqlUpdatable be s lhs rhs | rhs -> be, lhs -> s + , rhs -> s, lhs s be -> rhs + , rhs -> lhs where + + -- | Update a 'QField' or 'Beamable' type containing 'QField's with the given -- 'QExpr' or 'Beamable' type containing 'QExpr' - (<-.) :: forall fieldName. - IsSql92FieldNameSyntax fieldName - => lhs + (<-.) :: lhs -> rhs - -> QAssignment fieldName expr s -instance SqlUpdatable expr s (QField s a) (QExpr expr s a) where + -> QAssignment be s + +instance BeamSqlBackend be => SqlUpdatable be s (QField s a) (QExpr be s a) where QField _ _ nm <-. QExpr expr = QAssignment [(unqualifiedField nm, expr "t")] -instance Beamable tbl => SqlUpdatable expr s (tbl (QField s)) (tbl (QExpr expr s)) where - (<-.) :: forall fieldName. - IsSql92FieldNameSyntax fieldName - => tbl (QField s) -> tbl (QExpr expr s) - -> QAssignment fieldName expr s + +instance (BeamSqlBackend be, Beamable tbl) => SqlUpdatable be s (tbl (QField s)) (tbl (QExpr be s)) where lhs <-. rhs = QAssignment $ allBeamValues (\(Columnar' (Const assignments)) -> assignments) $ runIdentity $ zipBeamFieldsM (\(Columnar' (QField _ _ f) :: Columnar' (QField s) t) (Columnar' (QExpr e)) -> - pure (Columnar' (Const (unqualifiedField f, e "t")) :: Columnar' (Const (fieldName,expr)) t)) lhs rhs -instance Beamable tbl => SqlUpdatable expr s (tbl (Nullable (QField s))) (tbl (Nullable (QExpr expr s))) where + pure (Columnar' (Const (unqualifiedField f, e "t")) :: Columnar' (Const (BeamSqlBackendFieldNameSyntax be, BeamSqlBackendExpressionSyntax be)) t)) lhs rhs + +instance (BeamSqlBackend be, Beamable tbl) => SqlUpdatable be s (tbl (Nullable (QField s))) (tbl (Nullable (QExpr be s))) where lhs <-. rhs = let lhs' = changeBeamRep (\(Columnar' (QField q tblName fieldName') :: Columnar' (Nullable (QField s)) a) -> Columnar' (QField q tblName fieldName') :: Columnar' (QField s) a) lhs - rhs' = changeBeamRep (\(Columnar' (QExpr e) :: Columnar' (Nullable (QExpr expr s)) a) -> - Columnar' (QExpr e) :: Columnar' (QExpr expr s) a) rhs + rhs' = changeBeamRep (\(Columnar' (QExpr e) :: Columnar' (Nullable (QExpr be s)) a) -> + Columnar' (QExpr e) :: Columnar' (QExpr be s) a) rhs in lhs' <-. rhs' -- | SQL @UNION@ operator -union_ :: forall select db s a. - ( IsSql92SelectSyntax select - , Projectible (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) a - , ProjectibleInSelectSyntax select a - , ThreadRewritable (QNested s) a) - => Q select db (QNested s) a -> Q select db (QNested s) a - -> Q select db s (WithRewrittenThread (QNested s) s a) -union_ (Q a) (Q b) = Q (liftF (QUnion False a b (rewriteThread (Proxy @s)))) +union_ :: forall be db s a + . ( BeamSqlBackend be, Projectible be a + , ThreadRewritable (QNested s) a ) + => Q be db (QNested s) a -> Q be db (QNested s) a + -> Q be db s (WithRewrittenThread (QNested s) s a) +union_ (Q a) (Q b) = Q (liftF (QSetOp (unionTables False) a b (rewriteThread (Proxy @s)))) -- | SQL @UNION ALL@ operator -unionAll_ :: forall select db s a. - ( IsSql92SelectSyntax select - , Projectible (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) a - , ProjectibleInSelectSyntax select a +unionAll_ :: forall be db s a. + ( BeamSqlBackend be, Projectible be a , ThreadRewritable (QNested s) a) - => Q select db (QNested s) a -> Q select db (QNested s) a - -> Q select db s (WithRewrittenThread (QNested s) s a) -unionAll_ (Q a) (Q b) = Q (liftF (QUnion True a b (rewriteThread (Proxy @s)))) + => Q be db (QNested s) a -> Q be db (QNested s) a + -> Q be db s (WithRewrittenThread (QNested s) s a) +unionAll_ (Q a) (Q b) = Q (liftF (QSetOp (unionTables True) a b (rewriteThread (Proxy @s)))) -- | SQL @INTERSECT@ operator -intersect_ :: forall select db s a. - ( IsSql92SelectSyntax select - , Projectible (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) a - , ProjectibleInSelectSyntax select a +intersect_ :: forall be db s a. + ( BeamSqlBackend be, Projectible be a , ThreadRewritable (QNested s) a) - => Q select db (QNested s) a -> Q select db (QNested s) a - -> Q select db s (WithRewrittenThread (QNested s) s a) -intersect_ (Q a) (Q b) = Q (liftF (QIntersect False a b (rewriteThread (Proxy @s)))) + => Q be db (QNested s) a -> Q be db (QNested s) a + -> Q be db s (WithRewrittenThread (QNested s) s a) +intersect_ (Q a) (Q b) = Q (liftF (QSetOp (intersectTables False) a b (rewriteThread (Proxy @s)))) -- | SQL @INTERSECT ALL@ operator -intersectAll_ :: forall select db s a. - ( IsSql92SelectSyntax select - , Projectible (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) a - , ProjectibleInSelectSyntax select a +intersectAll_ :: forall be db s a. + ( BeamSqlBackend be, Projectible be a , ThreadRewritable (QNested s) a) - => Q select db (QNested s) a -> Q select db (QNested s) a - -> Q select db s (WithRewrittenThread (QNested s) s a) -intersectAll_ (Q a) (Q b) = Q (liftF (QIntersect True a b (rewriteThread (Proxy @s)))) + => Q be db (QNested s) a -> Q be db (QNested s) a + -> Q be db s (WithRewrittenThread (QNested s) s a) +intersectAll_ (Q a) (Q b) = Q (liftF (QSetOp (intersectTables True) a b (rewriteThread (Proxy @s)))) -- | SQL @EXCEPT@ operator -except_ :: forall select db s a. - ( IsSql92SelectSyntax select - , Projectible (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) a - , ProjectibleInSelectSyntax select a +except_ :: forall be db s a. + ( BeamSqlBackend be, Projectible be a , ThreadRewritable (QNested s) a) - => Q select db (QNested s) a -> Q select db (QNested s) a - -> Q select db s (WithRewrittenThread (QNested s) s a) -except_ (Q a) (Q b) = Q (liftF (QExcept False a b (rewriteThread (Proxy @s)))) + => Q be db (QNested s) a -> Q be db (QNested s) a + -> Q be db s (WithRewrittenThread (QNested s) s a) +except_ (Q a) (Q b) = Q (liftF (QSetOp (exceptTable False) a b (rewriteThread (Proxy @s)))) -- | SQL @EXCEPT ALL@ operator -exceptAll_ :: forall select db s a. - ( IsSql92SelectSyntax select - , Projectible (Sql92SelectTableExpressionSyntax (Sql92SelectSelectTableSyntax select)) a - , ProjectibleInSelectSyntax select a +exceptAll_ :: forall be db s a. + ( BeamSqlBackend be, Projectible be a , ThreadRewritable (QNested s) a) - => Q select db (QNested s) a -> Q select db (QNested s) a - -> Q select db s (WithRewrittenThread (QNested s) s a) -exceptAll_ (Q a) (Q b) = Q (liftF (QExcept True a b (rewriteThread (Proxy @s)))) + => Q be db (QNested s) a -> Q be db (QNested s) a + -> Q be db s (WithRewrittenThread (QNested s) s a) +exceptAll_ (Q a) (Q b) = Q (liftF (QSetOp (exceptTable True) a b (rewriteThread (Proxy @s)))) -- | Convenience function that allows you to use type applications to specify -- the result of a 'QGenExpr'. @@ -558,120 +514,112 @@ -- -- > aggregate_ (\_ -> as_ @Int countAll_) .. -- -as_ :: forall a ctxt syntax s. QGenExpr ctxt syntax s a -> QGenExpr ctxt syntax s a +as_ :: forall a ctxt be s. QGenExpr ctxt be s a -> QGenExpr ctxt be s a as_ = id -- * Marshalling between Haskell literals and QExprs type family HaskellLiteralForQExpr x = a -type instance HaskellLiteralForQExpr (QGenExpr context syntax s a) = a -type instance HaskellLiteralForQExpr (table (QGenExpr context syntax s)) = table Identity +type instance HaskellLiteralForQExpr (QGenExpr context be s a) = a +type instance HaskellLiteralForQExpr (table (QGenExpr context be s)) = table Identity type instance HaskellLiteralForQExpr (table (Nullable f)) = HaskellLiteralForQExpr_AddNullable (HaskellLiteralForQExpr (table f)) type family HaskellLiteralForQExpr_AddNullable x = a type instance HaskellLiteralForQExpr_AddNullable (tbl f) = tbl (Nullable f) -type family QExprSyntax x where - QExprSyntax (QGenExpr ctxt syntax s a) = syntax - -type SqlValableTable table expr = +type SqlValableTable be table = ( Beamable table - , IsSql92ExpressionSyntax expr - , FieldsFulfillConstraint (HasSqlValueSyntax (Sql92ExpressionValueSyntax expr)) table ) + , FieldsFulfillConstraint (HasSqlValueSyntax (BeamSqlBackendValueSyntax be)) table ) class SqlValable a where val_ :: HaskellLiteralForQExpr a -> a -instance (HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) a, IsSql92ExpressionSyntax syntax) => - SqlValable (QGenExpr ctxt syntax s a) where +instance ( BeamSqlBackendCanSerialize be a, BeamSqlBackend be ) => + SqlValable (QGenExpr ctxt be s a) where val_ = QExpr . pure . valueE . sqlValueSyntax -instance ( Beamable table - , IsSql92ExpressionSyntax syntax - , FieldsFulfillConstraint (HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax)) table ) => - SqlValable (table (QGenExpr ctxt syntax s)) where +instance ( Beamable table, BeamSqlBackend be + , FieldsFulfillConstraint (BeamSqlBackendCanSerialize be) table ) => + SqlValable (table (QGenExpr ctxt be s)) where val_ tbl = - let fields :: table (WithConstraint (HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax))) - fields = to (gWithConstrainedFields (Proxy @(HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax))) + let fields :: table (WithConstraint (BeamSqlBackendCanSerialize be)) + fields = to (gWithConstrainedFields (Proxy @(BeamSqlBackendCanSerialize be)) (Proxy @(Rep (table Exposed))) (from tbl)) - in changeBeamRep (\(Columnar' (WithConstraint x :: WithConstraint (HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax)) x)) -> + in changeBeamRep (\(Columnar' (WithConstraint x :: WithConstraint (BeamSqlBackendCanSerialize be) x)) -> Columnar' (QExpr (pure (valueE (sqlValueSyntax x))))) fields -instance ( Beamable table - , IsSql92ExpressionSyntax syntax - - , FieldsFulfillConstraintNullable (HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax)) table ) => +instance ( Beamable table, BeamSqlBackend be + , FieldsFulfillConstraintNullable (BeamSqlBackendCanSerialize be) table ) => - SqlValable (table (Nullable (QGenExpr ctxt syntax s))) where + SqlValable (table (Nullable (QGenExpr ctxt be s))) where val_ tbl = - let fields :: table (Nullable (WithConstraint (HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax)))) - fields = to (gWithConstrainedFields (Proxy @(HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax))) + let fields :: table (Nullable (WithConstraint (BeamSqlBackendCanSerialize be))) + fields = to (gWithConstrainedFields (Proxy @(BeamSqlBackendCanSerialize be)) (Proxy @(Rep (table (Nullable Exposed)))) (from tbl)) - in changeBeamRep (\(Columnar' (WithConstraint x :: WithConstraint (HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax)) (Maybe x))) -> + in changeBeamRep (\(Columnar' (WithConstraint x :: WithConstraint (BeamSqlBackendCanSerialize be) (Maybe x))) -> Columnar' (QExpr (pure (valueE (sqlValueSyntax x))))) fields -default_ :: IsSql92ExpressionSyntax expr - => QGenExpr ctxt expr s a +default_ :: BeamSqlBackend be => QGenExpr ctxt be s a default_ = QExpr (pure defaultE) -- * Window functions -noBounds_ :: QFrameBounds syntax +noBounds_ :: QFrameBounds be noBounds_ = QFrameBounds Nothing -fromBound_ :: IsSql2003WindowFrameBoundsSyntax syntax - => QFrameBound (Sql2003WindowFrameBoundsBoundSyntax syntax) - -> QFrameBounds syntax +fromBound_ :: BeamSql2003ExpressionBackend be + => QFrameBound be -> QFrameBounds be fromBound_ start = bounds_ start Nothing -bounds_ :: IsSql2003WindowFrameBoundsSyntax syntax - => QFrameBound (Sql2003WindowFrameBoundsBoundSyntax syntax) - -> Maybe (QFrameBound (Sql2003WindowFrameBoundsBoundSyntax syntax)) - -> QFrameBounds syntax +bounds_ :: BeamSql2003ExpressionBackend be + => QFrameBound be + -> Maybe (QFrameBound be) + -> QFrameBounds be bounds_ (QFrameBound start) end = QFrameBounds . Just $ fromToBoundSyntax start (fmap (\(QFrameBound end') -> end') end) -unbounded_ :: IsSql2003WindowFrameBoundSyntax syntax - => QFrameBound syntax +unbounded_ :: BeamSql2003ExpressionBackend be => QFrameBound be unbounded_ = QFrameBound unboundedSyntax -nrows_ :: IsSql2003WindowFrameBoundSyntax syntax - => Int -> QFrameBound syntax +nrows_ :: BeamSql2003ExpressionBackend be + => Int -> QFrameBound be nrows_ x = QFrameBound (nrowsBoundSyntax x) -noPartition_, noOrder_ :: Maybe (QOrd syntax s Int) -noOrder_ = Nothing +noPartition_ :: Maybe (QExpr be s Int) noPartition_ = Nothing +noOrder_ :: Maybe (QOrd be s Int) +noOrder_ = Nothing + partitionBy_, orderPartitionBy_ :: partition -> Maybe partition partitionBy_ = Just orderPartitionBy_ = Just -- | Specify a window frame with all the options -frame_ :: ( IsSql2003ExpressionSyntax syntax - , SqlOrderable (Sql2003WindowFrameOrderingSyntax (Sql2003ExpressionWindowFrameSyntax syntax)) ordering - , Projectible syntax partition - , Sql2003ExpressionSanityCheck syntax ) - => Maybe partition {-^ PARTITION BY -} - -> Maybe ordering {-^ ORDER BY -} - -> QFrameBounds (Sql2003WindowFrameBoundsSyntax (Sql2003ExpressionWindowFrameSyntax syntax)) {-^ RANGE / ROWS -} - -> QWindow (Sql2003ExpressionWindowFrameSyntax syntax) s +frame_ :: forall be ordering partition s + . ( BeamSql2003ExpressionBackend be + , SqlOrderable be ordering + , Projectible be partition ) + => Maybe partition {-^ PARTITION BY -} + -> Maybe ordering {-^ ORDER BY -} + -> QFrameBounds be {-^ RANGE / ROWS -} + -> QWindow be s frame_ partition_ ordering_ (QFrameBounds bounds) = QWindow $ \tblPfx -> - frameSyntax (case maybe [] (flip project tblPfx) partition_ of + frameSyntax (case maybe [] (flip (project (Proxy @be)) tblPfx) partition_ of [] -> Nothing xs -> Just xs) - (case fmap makeSQLOrdering ordering_ of + (case fmap (makeSQLOrdering (Proxy @be)) ordering_ of Nothing -> Nothing Just [] -> Nothing Just xs -> Just (sequenceA xs tblPfx)) bounds -- | Produce a window expression given an aggregate function and a window. -over_ :: IsSql2003ExpressionSyntax syntax => - QAgg syntax s a -> QWindow (Sql2003ExpressionWindowFrameSyntax syntax) s -> QWindowExpr syntax s a +over_ :: BeamSql2003ExpressionBackend be + => QAgg be s a -> QWindow be s -> QWindowExpr be s a over_ (QExpr a) (QWindow frame) = QExpr (overE <$> a <*> frame) -- | Compute a query over windows. @@ -686,72 +634,63 @@ -- function, window expressions can be included in the output using the -- 'over_' function. -- -withWindow_ :: forall window a s r select db. - ( ProjectibleWithPredicate WindowFrameContext (Sql2003ExpressionWindowFrameSyntax (Sql92SelectExpressionSyntax select)) window - , Projectible (Sql92SelectExpressionSyntax select) r - , Projectible (Sql92SelectExpressionSyntax select) a +withWindow_ :: forall window a s r be db + . ( ProjectibleWithPredicate WindowFrameContext be (WithExprContext (BeamSqlBackendWindowFrameSyntax' be)) window + , Projectible be r, Projectible be a , ContextRewritable a - , ThreadRewritable (QNested s) (WithRewrittenContext a QValueContext) - , IsSql92SelectSyntax select) + , ThreadRewritable (QNested s) (WithRewrittenContext a QValueContext) ) => (r -> window) -- ^ Window builder function -> (r -> window -> a) -- ^ Projection builder function. Has access to the windows generated above - -> Q select db (QNested s) r -- ^ Query to window over - -> Q select db s (WithRewrittenThread (QNested s) s (WithRewrittenContext a QValueContext)) + -> Q be db (QNested s) r -- ^ Query to window over + -> Q be db s (WithRewrittenThread (QNested s) s (WithRewrittenContext a QValueContext)) withWindow_ mkWindow mkProjection (Q windowOver)= Q (liftF (QWindowOver mkWindow mkProjection windowOver (rewriteThread (Proxy @s) . rewriteContext (Proxy @QValueContext)))) -- * Order bys -class SqlOrderable syntax a | a -> syntax where - makeSQLOrdering :: a -> [ WithExprContext syntax ] -instance SqlOrderable syntax (QOrd syntax s a) where - makeSQLOrdering (QExpr x) = [x] -instance SqlOrderable syntax a => SqlOrderable syntax [a] where - makeSQLOrdering = concatMap makeSQLOrdering -instance ( SqlOrderable syntax a - , SqlOrderable syntax b ) => SqlOrderable syntax (a, b) where - makeSQLOrdering (a, b) = makeSQLOrdering a <> makeSQLOrdering b -instance ( SqlOrderable syntax a - , SqlOrderable syntax b - , SqlOrderable syntax c ) => SqlOrderable syntax (a, b, c) where - makeSQLOrdering (a, b, c) = makeSQLOrdering a <> makeSQLOrdering b <> makeSQLOrdering c -instance ( SqlOrderable syntax a - , SqlOrderable syntax b - , SqlOrderable syntax c - , SqlOrderable syntax d ) => SqlOrderable syntax (a, b, c, d) where - makeSQLOrdering (a, b, c, d) = makeSQLOrdering a <> makeSQLOrdering b <> makeSQLOrdering c <> makeSQLOrdering d -instance ( SqlOrderable syntax a - , SqlOrderable syntax b - , SqlOrderable syntax c - , SqlOrderable syntax d - , SqlOrderable syntax e ) => SqlOrderable syntax (a, b, c, d, e) where - makeSQLOrdering (a, b, c, d, e) = makeSQLOrdering a <> makeSQLOrdering b <> makeSQLOrdering c <> makeSQLOrdering d <> makeSQLOrdering e -instance ( SqlOrderable syntax a - , SqlOrderable syntax b - , SqlOrderable syntax c - , SqlOrderable syntax d - , SqlOrderable syntax e - , SqlOrderable syntax f ) => SqlOrderable syntax (a, b, c, d, e, f) where - makeSQLOrdering (a, b, c, d, e, f) = makeSQLOrdering a <> makeSQLOrdering b <> makeSQLOrdering c <> makeSQLOrdering d <> makeSQLOrdering e <> makeSQLOrdering f -instance ( SqlOrderable syntax a - , SqlOrderable syntax b - , SqlOrderable syntax c - , SqlOrderable syntax d - , SqlOrderable syntax e - , SqlOrderable syntax f - , SqlOrderable syntax g ) => SqlOrderable syntax (a, b, c, d, e, f, g) where - makeSQLOrdering (a, b, c, d, e, f, g) = makeSQLOrdering a <> makeSQLOrdering b <> makeSQLOrdering c <> makeSQLOrdering d <> - makeSQLOrdering e <> makeSQLOrdering f <> makeSQLOrdering g -instance ( SqlOrderable syntax a - , SqlOrderable syntax b - , SqlOrderable syntax c - , SqlOrderable syntax d - , SqlOrderable syntax e - , SqlOrderable syntax f - , SqlOrderable syntax g - , SqlOrderable syntax h) => SqlOrderable syntax (a, b, c, d, e, f, g, h) where - makeSQLOrdering (a, b, c, d, e, f, g, h) = makeSQLOrdering a <> makeSQLOrdering b <> makeSQLOrdering c <> makeSQLOrdering d <> - makeSQLOrdering e <> makeSQLOrdering f <> makeSQLOrdering g <> makeSQLOrdering h +class SqlOrderable be a | a -> be where + makeSQLOrdering :: Proxy be -> a -> [ WithExprContext (BeamSqlBackendOrderingSyntax be) ] +instance SqlOrderable be (QOrd be s a) where + makeSQLOrdering _ (QOrd x) = [x] +instance SqlOrderable be a => SqlOrderable be [a] where + makeSQLOrdering be = concatMap (makeSQLOrdering be) +instance ( SqlOrderable be a, SqlOrderable be b ) => SqlOrderable be (a, b) where + makeSQLOrdering be (a, b) = + makeSQLOrdering be a <> makeSQLOrdering be b +instance ( SqlOrderable be a, SqlOrderable be b + , SqlOrderable be c ) => SqlOrderable be (a, b, c) where + makeSQLOrdering be (a, b, c) = + makeSQLOrdering be a <> makeSQLOrdering be b <> makeSQLOrdering be c +instance ( SqlOrderable be a, SqlOrderable be b + , SqlOrderable be c, SqlOrderable be d ) => SqlOrderable be (a, b, c, d) where + makeSQLOrdering be (a, b, c, d) = + makeSQLOrdering be a <> makeSQLOrdering be b <> makeSQLOrdering be c <> makeSQLOrdering be d +instance ( SqlOrderable be a, SqlOrderable be b + , SqlOrderable be c, SqlOrderable be d + , SqlOrderable be e ) => SqlOrderable be (a, b, c, d, e) where + makeSQLOrdering be (a, b, c, d, e) = + makeSQLOrdering be a <> makeSQLOrdering be b <> makeSQLOrdering be c <> makeSQLOrdering be d <> + makeSQLOrdering be e +instance ( SqlOrderable be a, SqlOrderable be b + , SqlOrderable be c, SqlOrderable be d + , SqlOrderable be e, SqlOrderable be f ) => SqlOrderable be (a, b, c, d, e, f) where + makeSQLOrdering be (a, b, c, d, e, f) = + makeSQLOrdering be a <> makeSQLOrdering be b <> makeSQLOrdering be c <> makeSQLOrdering be d <> + makeSQLOrdering be e <> makeSQLOrdering be f +instance ( SqlOrderable be a, SqlOrderable be b + , SqlOrderable be c, SqlOrderable be d + , SqlOrderable be e, SqlOrderable be f + , SqlOrderable be g ) => SqlOrderable be (a, b, c, d, e, f, g) where + makeSQLOrdering be (a, b, c, d, e, f, g) = + makeSQLOrdering be a <> makeSQLOrdering be b <> makeSQLOrdering be c <> makeSQLOrdering be d <> + makeSQLOrdering be e <> makeSQLOrdering be f <> makeSQLOrdering be g +instance ( SqlOrderable be a, SqlOrderable be b + , SqlOrderable be c, SqlOrderable be d + , SqlOrderable be e, SqlOrderable be f + , SqlOrderable be g, SqlOrderable be h ) => SqlOrderable be (a, b, c, d, e, f, g, h) where + makeSQLOrdering be (a, b, c, d, e, f, g, h) = + makeSQLOrdering be a <> makeSQLOrdering be b <> makeSQLOrdering be c <> makeSQLOrdering be d <> + makeSQLOrdering be e <> makeSQLOrdering be f <> makeSQLOrdering be g <> makeSQLOrdering be h -- | Order by the given expressions. The return type of the ordering key should -- either be the result of 'asc_' or 'desc_' (or another ordering 'QOrd' @@ -760,35 +699,32 @@ -- -- The -- has more information. -orderBy_ :: forall s a ordering syntax db. - ( Projectible (Sql92SelectExpressionSyntax syntax) a - , SqlOrderable (Sql92SelectOrderingSyntax syntax) ordering - , ThreadRewritable (QNested s) a) => - (a -> ordering) -> Q syntax db (QNested s) a -> Q syntax db s (WithRewrittenThread (QNested s) s a) +orderBy_ :: forall s a ordering be db + . ( Projectible be a, SqlOrderable be ordering + , ThreadRewritable (QNested s) a ) + => (a -> ordering) -> Q be db (QNested s) a -> Q be db s (WithRewrittenThread (QNested s) s a) orderBy_ orderer (Q q) = - Q (liftF (QOrderBy (sequenceA . makeSQLOrdering . orderer) q (rewriteThread (Proxy @s)))) + Q (liftF (QOrderBy (sequenceA . makeSQLOrdering (Proxy @be) . orderer) q (rewriteThread (Proxy @s)))) -nullsFirst_ :: IsSql2003OrderingElementaryOLAPOperationsSyntax syntax - => QOrd syntax s a - -> QOrd syntax s a -nullsFirst_ (QExpr e) = QExpr (nullsFirstOrdering <$> e) +nullsFirst_ :: IsSql2003OrderingElementaryOLAPOperationsSyntax (BeamSqlBackendOrderingSyntax be) + => QOrd be s a -> QOrd be s a +nullsFirst_ (QOrd e) = QOrd (nullsFirstOrdering <$> e) -nullsLast_ :: IsSql2003OrderingElementaryOLAPOperationsSyntax syntax - => QOrd syntax s a - -> QOrd syntax s a -nullsLast_ (QExpr e) = QExpr (nullsLastOrdering <$> e) +nullsLast_ :: IsSql2003OrderingElementaryOLAPOperationsSyntax (BeamSqlBackendOrderingSyntax be) + => QOrd be s a -> QOrd be s a +nullsLast_ (QOrd e) = QOrd (nullsLastOrdering <$> e) -- | Produce a 'QOrd' corresponding to a SQL @ASC@ ordering -asc_ :: forall syntax s a. IsSql92OrderingSyntax syntax - => QExpr (Sql92OrderingExpressionSyntax syntax) s a - -> QOrd syntax s a -asc_ (QExpr e) = QExpr (ascOrdering <$> e) +asc_ :: forall be s a + . BeamSqlBackend be + => QExpr be s a -> QOrd be s a +asc_ (QExpr e) = QOrd (ascOrdering <$> e) -- | Produce a 'QOrd' corresponding to a SQL @DESC@ ordering -desc_ :: forall syntax s a. IsSql92OrderingSyntax syntax - => QExpr (Sql92OrderingExpressionSyntax syntax) s a - -> QOrd syntax s a -desc_ (QExpr e) = QExpr (descOrdering <$> e) +desc_ :: forall be s a + . BeamSqlBackend be + => QExpr be s a -> QOrd be s a +desc_ (QExpr e) = QOrd (descOrdering <$> e) -- * Subqueries @@ -808,24 +744,19 @@ -- 'PrimaryKey' filled with 'Nothing'. nothing_ :: b -instance ( IsSql92ExpressionSyntax syntax - , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) SqlNull) => - SqlJustable (QExpr syntax s a) (QExpr syntax s (Maybe a)) where +instance BeamSqlBackend be => + SqlJustable (QExpr be s a) (QExpr be s (Maybe a)) where just_ (QExpr e) = QExpr e nothing_ = QExpr (pure (valueE (sqlValueSyntax SqlNull))) -instance {-# OVERLAPPING #-} ( Table t - , IsSql92ExpressionSyntax syntax - , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) SqlNull ) => - SqlJustable (PrimaryKey t (QExpr syntax s)) (PrimaryKey t (Nullable (QExpr syntax s))) where +instance {-# OVERLAPPING #-} ( Table t, BeamSqlBackend be ) => + SqlJustable (PrimaryKey t (QExpr be s)) (PrimaryKey t (Nullable (QExpr be s))) where just_ = changeBeamRep (\(Columnar' q) -> Columnar' (just_ q)) nothing_ = changeBeamRep (\(Columnar' _) -> Columnar' nothing_) (primaryKey (tblSkeleton :: TableSkeleton t)) -instance {-# OVERLAPPING #-} ( Table t - , IsSql92ExpressionSyntax syntax - , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) SqlNull ) => - SqlJustable (t (QExpr syntax s)) (t (Nullable (QExpr syntax s))) where +instance {-# OVERLAPPING #-} ( Table t, BeamSqlBackend be ) => + SqlJustable (t (QExpr be s)) (t (Nullable (QExpr be s))) where just_ = changeBeamRep (\(Columnar' q) -> Columnar' (just_ q)) nothing_ = changeBeamRep (\(Columnar' _) -> Columnar' nothing_) (tblSkeleton :: TableSkeleton t) @@ -839,53 +770,53 @@ -- * Nullable checking -data QIfCond context expr s a = QIfCond (QGenExpr context expr s SqlBool) (QGenExpr context expr s a) -newtype QIfElse context expr s a = QIfElse (QGenExpr context expr s a) +data QIfCond context be s a = QIfCond (QGenExpr context be s SqlBool) (QGenExpr context be s a) +newtype QIfElse context be s a = QIfElse (QGenExpr context be s a) -then_ :: QGenExpr context expr s Bool -> QGenExpr context expr s a -> QIfCond context expr s a +then_ :: QGenExpr context be s Bool -> QGenExpr context be s a -> QIfCond context be s a then_ cond res = QIfCond (sqlBool_ cond) res -then_' :: QGenExpr context expr s SqlBool -> QGenExpr context expr s a -> QIfCond context expr s a +then_' :: QGenExpr context be s SqlBool -> QGenExpr context be s a -> QIfCond context be s a then_' cond res = QIfCond cond res -else_ :: QGenExpr context expr s a -> QIfElse context expr s a +else_ :: QGenExpr context be s a -> QIfElse context be s a else_ = QIfElse -if_ :: IsSql92ExpressionSyntax expr => - [ QIfCond context expr s a ] - -> QIfElse context expr s a - -> QGenExpr context expr s a +if_ :: BeamSqlBackend be + => [ QIfCond context be s a ] + -> QIfElse context be s a + -> QGenExpr context be s a if_ conds (QIfElse (QExpr elseExpr)) = QExpr (\tbl -> caseE (map (\(QIfCond (QExpr cond) (QExpr res)) -> (cond tbl, res tbl)) conds) (elseExpr tbl)) -- | SQL @COALESCE@ support -coalesce_ :: IsSql92ExpressionSyntax expr - => [ QGenExpr ctxt expr s (Maybe a) ] -> QGenExpr ctxt expr s a -> QGenExpr ctxt expr s a +coalesce_ :: BeamSqlBackend be + => [ QGenExpr ctxt be s (Maybe a) ] -> QGenExpr ctxt be s a -> QGenExpr ctxt be s a coalesce_ qs (QExpr onNull) = QExpr $ do onNull' <- onNull coalesceE . (<> [onNull']) <$> mapM (\(QExpr q) -> q) qs -- | Converta a 'Maybe' value to a concrete value, by suppling a default -fromMaybe_ :: IsSql92ExpressionSyntax expr - => QGenExpr ctxt expr s a -> QGenExpr ctxt expr s (Maybe a) -> QGenExpr ctxt expr s a +fromMaybe_ :: BeamSqlBackend be + => QGenExpr ctxt be s a -> QGenExpr ctxt be s (Maybe a) -> QGenExpr ctxt be s a fromMaybe_ onNull q = coalesce_ [q] onNull -- | Type class for anything which can be checked for null-ness. This includes 'QExpr (Maybe a)' as -- well as 'Table's or 'PrimaryKey's over 'Nullable QExpr'. -class IsSql92ExpressionSyntax syntax => SqlDeconstructMaybe syntax a nonNullA s | a s -> syntax, a -> nonNullA, a -> s, nonNullA -> s where +class BeamSqlBackend be => SqlDeconstructMaybe be a nonNullA s | a s -> be, a -> nonNullA, a -> s, nonNullA -> s where -- | Returns a 'QExpr' that evaluates to true when the first argument is not null - isJust_ :: a -> QGenExpr ctxt syntax s Bool + isJust_ :: a -> QGenExpr ctxt be s Bool -- | Returns a 'QExpr' that evaluates to true when the first argument is null - isNothing_ :: a -> QGenExpr ctxt syntax s Bool + isNothing_ :: a -> QGenExpr ctxt be s Bool -- | Given an object (third argument) which may or may not be null, return the default value if -- null (first argument), or transform the value that could be null to yield the result of the -- expression (second argument) - maybe_ :: QGenExpr ctxt syntax s y -> (nonNullA -> QGenExpr ctxt syntax s y) -> a -> QGenExpr ctxt syntax s y + maybe_ :: QGenExpr ctxt be s y -> (nonNullA -> QGenExpr ctxt be s y) -> a -> QGenExpr ctxt be s y -instance IsSql92ExpressionSyntax syntax => SqlDeconstructMaybe syntax (QGenExpr ctxt syntax s (Maybe x)) (QGenExpr ctxt syntax s x) s where +instance BeamSqlBackend be => SqlDeconstructMaybe be (QGenExpr ctxt be s (Maybe x)) (QGenExpr ctxt be s x) s where isJust_ (QExpr x) = QExpr (isNotNullE <$> x) isNothing_ (QExpr x) = QExpr (isNullE <$> x) @@ -893,10 +824,8 @@ let QExpr onJust' = onJust (QExpr e) in QExpr (\tbl -> caseE [(isNotNullE (e tbl), onJust' tbl)] (onNothing tbl)) -instance ( IsSql92ExpressionSyntax syntax - , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) Bool - , Beamable t ) - => SqlDeconstructMaybe syntax (t (Nullable (QGenExpr ctxt syntax s))) (t (QGenExpr ctxt syntax s)) s where +instance ( BeamSqlBackend be, Beamable t) + => SqlDeconstructMaybe be (t (Nullable (QGenExpr ctxt be s))) (t (QGenExpr ctxt be s)) s where isJust_ t = allE (allBeamValues (\(Columnar' e) -> isJust_ e) t) isNothing_ t = allE (allBeamValues (\(Columnar' e) -> isNothing_ e) t) maybe_ (QExpr onNothing) onJust tbl = diff --git a/Database/Beam/Query/CustomSQL.hs b/Database/Beam/Query/CustomSQL.hs --- a/Database/Beam/Query/CustomSQL.hs +++ b/Database/Beam/Query/CustomSQL.hs @@ -45,6 +45,7 @@ , IsCustomSqlSyntax(..) ) where import Database.Beam.Query.Internal +import Database.Beam.Backend.SQL import Database.Beam.Backend.SQL.Builder import Data.ByteString (ByteString) @@ -77,31 +78,35 @@ customExprSyntax (SqlSyntaxBuilderCustom bs) = SqlSyntaxBuilder (byteString bs) renderSyntax = SqlSyntaxBuilderCustom . toStrict . toLazyByteString . buildSql -newtype CustomSqlSnippet syntax = CustomSqlSnippet (T.Text -> CustomSqlSyntax syntax) -instance IsCustomSqlSyntax syntax => Semigroup (CustomSqlSnippet syntax) where +newtype CustomSqlSnippet be = CustomSqlSnippet (T.Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)) +instance IsCustomSqlSyntax (BeamSqlBackendExpressionSyntax be) => Semigroup (CustomSqlSnippet be) where (<>) = mappend -instance IsCustomSqlSyntax syntax => Monoid (CustomSqlSnippet syntax) where +instance IsCustomSqlSyntax (BeamSqlBackendExpressionSyntax be) => Monoid (CustomSqlSnippet be) where mempty = CustomSqlSnippet (pure mempty) mappend (CustomSqlSnippet a) (CustomSqlSnippet b) = CustomSqlSnippet $ \pfx -> a pfx <> b pfx -instance IsCustomSqlSyntax syntax => IsString (CustomSqlSnippet syntax) where +instance IsCustomSqlSyntax (BeamSqlBackendExpressionSyntax be) => IsString (CustomSqlSnippet be) where fromString s = CustomSqlSnippet $ \_ -> fromString s class IsCustomExprFn fn res | res -> fn where customExpr_ :: fn -> res -instance IsCustomSqlSyntax syntax => IsCustomExprFn (CustomSqlSnippet syntax) (QGenExpr ctxt syntax s res) where +type BeamSqlBackendHasCustomSyntax be = IsCustomSqlSyntax (BeamSqlBackendExpressionSyntax be) + +instance BeamSqlBackendHasCustomSyntax be => IsCustomExprFn (CustomSqlSnippet be) (QGenExpr ctxt be s res) where customExpr_ (CustomSqlSnippet mkSyntax) = QExpr (customExprSyntax . mkSyntax) -instance (IsCustomExprFn a res, IsCustomSqlSyntax syntax) => IsCustomExprFn (CustomSqlSnippet syntax -> a) (QGenExpr ctxt syntax s r -> res) where + +instance (IsCustomExprFn a res, BeamSqlBackendHasCustomSyntax be) => + IsCustomExprFn (CustomSqlSnippet be -> a) (QGenExpr ctxt be s r -> res) where customExpr_ fn (QExpr e) = customExpr_ $ fn (CustomSqlSnippet (renderSyntax . e)) -- | Force a 'QGenExpr' to be typed as a value expression (a 'QExpr'). Useful -- for getting around type-inference errors with supplying the entire type. -valueExpr_ :: QExpr syntax s a -> QExpr syntax s a +valueExpr_ :: QExpr be s a -> QExpr be s a valueExpr_ = id -- | Force a 'QGenExpr' to be typed as an aggregate. Useful for defining custom -- aggregates for use in 'aggregate_'. -agg_ :: QAgg syntax s a -> QAgg syntax s a +agg_ :: QAgg be s a -> QAgg be s a agg_ = id diff --git a/Database/Beam/Query/DataTypes.hs b/Database/Beam/Query/DataTypes.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Query/DataTypes.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE UndecidableInstances #-} +module Database.Beam.Query.DataTypes where + +import Database.Beam.Backend.SQL +import Database.Beam.Query.Internal + +import Data.Text (Text) +import Data.Time (LocalTime, Day, TimeOfDay) +import Data.Scientific (Scientific) +import Data.Typeable (Typeable) +import Data.Vector (Vector) + +-- | A data type in a given 'IsSql92DataTypeSyntax' which describes a SQL type +-- mapping to the Haskell type @a@ +newtype DataType be a = DataType (BeamSqlBackendCastTargetSyntax be) + +instance Sql92DisplaySyntax (BeamSqlBackendCastTargetSyntax be) => Show (DataType be a) where + show (DataType syntax) = "DataType (" ++ displaySyntax syntax ++ ")" +deriving instance Eq (BeamSqlBackendCastTargetSyntax be) => Eq (DataType be a) + +-- | Cast a value to a specific data type, specified using 'DataType'. +-- +-- Note: this may fail at run-time if the cast is invalid for a particular value +cast_ :: BeamSqlBackend be => QGenExpr ctxt be s a -> DataType be b -> QGenExpr ctxt be s b +cast_ (QExpr e) (DataType dt) = QExpr (castE <$> e <*> pure dt) + +-- ** Data types + +-- | SQL92 @INTEGER@ data type +int :: (BeamSqlBackend be, Integral a) => DataType be a +int = DataType intType + +-- | SQL92 @SMALLINT@ data type +smallint :: (BeamSqlBackend be, Integral a) => DataType be a +smallint = DataType smallIntType + +-- | SQL2008 Optional @BIGINT@ data type +bigint :: ( BeamSqlBackend be, BeamSqlT071Backend be, Integral a ) + => DataType be a +bigint = DataType bigIntType + +-- TODO is Integer the right type to use here? +-- | SQL2003 Optional @BINARY@ data type +binary :: ( BeamSqlBackend be, BeamSqlT021Backend be ) + => Maybe Word -> DataType be Integer +binary prec = DataType (binaryType prec) + +-- | SQL2003 Optional @VARBINARY@ data type +varbinary :: ( BeamSqlBackend be, BeamSqlT021Backend be ) + => Maybe Word -> DataType be Integer +varbinary prec = DataType (varBinaryType prec) + +-- TODO should this be Day or something? +-- | SQL92 @DATE@ data type +date :: BeamSqlBackend be => DataType be Day +date = DataType dateType + +-- | SQL92 @CHAR@ data type +char :: BeamSqlBackend be => Maybe Word -> DataType be Text +char prec = DataType (charType prec Nothing) + +-- | SQL92 @VARCHAR@ data type +varchar :: BeamSqlBackend be => Maybe Word -> DataType be Text +varchar prec = DataType (varCharType prec Nothing) + +-- | SQL92 @NATIONAL CHARACTER VARYING@ data type +nationalVarchar :: BeamSqlBackend be => Maybe Word -> DataType be Text +nationalVarchar prec = DataType (nationalVarCharType prec) + +-- | SQL92 @NATIONAL CHARACTER@ data type +nationalChar :: BeamSqlBackend be => Maybe Word -> DataType be Text +nationalChar prec = DataType (nationalCharType prec) + +-- | SQL92 @DOUBLE@ data type +double :: BeamSqlBackend be => DataType be Double +double = DataType doubleType + +-- | SQL92 @NUMERIC@ data type +numeric :: BeamSqlBackend be => Maybe (Word, Maybe Word) -> DataType be Scientific +numeric x = DataType (numericType x) + +-- | SQL92 @TIMESTAMP WITH TIME ZONE@ data type +timestamptz :: BeamSqlBackend be => DataType be LocalTime +timestamptz = DataType (timestampType Nothing True) + +-- | SQL92 @TIMESTAMP WITHOUT TIME ZONE@ data type +timestamp :: BeamSqlBackend be => DataType be LocalTime +timestamp = DataType (timestampType Nothing False) + +-- | SQL92 @TIME@ data type +time :: BeamSqlBackend be => Maybe Word -> DataType be TimeOfDay +time prec = DataType (timeType prec False) + +-- | SQL99 @BOOLEAN@ data type +boolean :: BeamSql99DataTypeBackend be => DataType be Bool +boolean = DataType booleanType + +-- | SQL99 @CLOB@ data type +characterLargeObject :: BeamSql99DataTypeBackend be => DataType be Text +characterLargeObject = DataType characterLargeObjectType + +-- | SQL99 @BLOB@ data type +binaryLargeObject :: BeamSql99DataTypeBackend be => DataType be Text +binaryLargeObject = DataType binaryLargeObjectType + +-- | SQL99 array data types +array :: (Typeable a, BeamSql99DataTypeBackend be) + => DataType be a -> Int + -> DataType be (Vector a) +array (DataType ty) sz = DataType (arrayType ty sz) + +-- | Haskell requires 'DataType's to match exactly. Use this function to convert +-- a 'DataType' that expects a concrete value to one expecting a 'Maybe' +maybeType :: DataType be a -> DataType be (Maybe a) +maybeType (DataType sqlTy) = DataType sqlTy diff --git a/Database/Beam/Query/Extensions.hs b/Database/Beam/Query/Extensions.hs --- a/Database/Beam/Query/Extensions.hs +++ b/Database/Beam/Query/Extensions.hs @@ -41,68 +41,74 @@ import Database.Beam.Backend.SQL -ntile_ :: (Integral a, IsSql2003NtileExpressionSyntax syntax) - => QExpr syntax s Int -> QAgg syntax s a +ntile_ :: (BeamSqlBackend be, BeamSqlT614Backend be) + => QExpr be s Int -> QAgg be s a ntile_ (QExpr a) = QExpr (ntileE <$> a) -lead1_, lag1_ :: IsSql2003LeadAndLagExpressionSyntax syntax - => QExpr syntax s a -> QAgg syntax s a +lead1_, lag1_ + :: (BeamSqlBackend be, BeamSqlT615Backend be) + => QExpr be s a -> QAgg be s a lead1_ (QExpr a) = QExpr (leadE <$> a <*> pure Nothing <*> pure Nothing) lag1_ (QExpr a) = QExpr (lagE <$> a <*> pure Nothing <*> pure Nothing) -lead_, lag_ :: IsSql2003LeadAndLagExpressionSyntax syntax - => QExpr syntax s a -> QExpr syntax s Int -> QAgg syntax s a +lead_, lag_ + :: (BeamSqlBackend be, BeamSqlT615Backend be) + => QExpr be s a -> QExpr be s Int -> QAgg be s a lead_ (QExpr a) (QExpr n) = QExpr (leadE <$> a <*> (Just <$> n) <*> pure Nothing) lag_ (QExpr a) (QExpr n) = QExpr (lagE <$> a <*> (Just <$> n) <*> pure Nothing) leadWithDefault_, lagWithDefault_ - :: IsSql2003LeadAndLagExpressionSyntax syntax - => QExpr syntax s a -> QExpr syntax s Int -> QExpr syntax s a - -> QAgg syntax s a + :: (BeamSqlBackend be, BeamSqlT615Backend be) + => QExpr be s a -> QExpr be s Int -> QExpr be s a + -> QAgg be s a leadWithDefault_ (QExpr a) (QExpr n) (QExpr def) = QExpr (leadE <$> a <*> fmap Just n <*> fmap Just def) lagWithDefault_ (QExpr a) (QExpr n) (QExpr def) = QExpr (lagE <$> a <*> fmap Just n <*> fmap Just def) -- TODO the first 'a' should be nullable, and the second one not -firstValue_, lastValue_ :: IsSql2003FirstValueAndLastValueExpressionSyntax syntax - => QExpr syntax s a -> QAgg syntax s a +firstValue_, lastValue_ + :: (BeamSqlBackend be, BeamSqlT616Backend be) + => QExpr be s a -> QAgg be s a firstValue_ (QExpr a) = QExpr (firstValueE <$> a) lastValue_ (QExpr a) = QExpr (lastValueE <$> a) -- TODO see comment for 'firstValue_' and 'lastValue_' -nthValue_ :: IsSql2003NthValueExpressionSyntax syntax - => QExpr syntax s a -> QExpr syntax s Int -> QAgg syntax s a +nthValue_ + :: (BeamSqlBackend be, BeamSqlT618Backend be) + => QExpr be s a -> QExpr be s Int -> QAgg be s a nthValue_ (QExpr a) (QExpr n) = QExpr (nthValueE <$> a <*> n) -ln_, exp_, sqrt_ :: (Floating a, IsSql2003EnhancedNumericFunctionsExpressionSyntax syntax) - => QGenExpr ctxt syntax s a -> QGenExpr ctxt syntax s a +ln_, exp_, sqrt_ + :: (Floating a, BeamSqlBackend be, BeamSqlT621Backend be) + => QGenExpr ctxt be s a -> QGenExpr ctxt be s a ln_ (QExpr a) = QExpr (lnE <$> a) exp_ (QExpr a) = QExpr (expE <$> a) sqrt_ (QExpr a) = QExpr (sqrtE <$> a) -ceiling_, floor_ :: (RealFrac a, Integral b, IsSql2003EnhancedNumericFunctionsExpressionSyntax syntax) - => QGenExpr ctxt syntax s a -> QGenExpr ctxt syntax s b +ceiling_, floor_ + :: (RealFrac a, Integral b, BeamSqlBackend be, BeamSqlT621Backend be) + => QGenExpr ctxt be s a -> QGenExpr ctxt be s b ceiling_ (QExpr a) = QExpr (ceilE <$> a) floor_ (QExpr a) = QExpr (floorE <$> a) infixr 8 **. -(**.) :: (Floating a, IsSql2003EnhancedNumericFunctionsExpressionSyntax syntax) - => QGenExpr ctxt syntax s a -> QGenExpr ctxt syntax s a -> QGenExpr ctxt syntax s a +(**.) :: (Floating a, BeamSqlBackend be, BeamSqlT621Backend be) + => QGenExpr ctxt be s a -> QGenExpr ctxt be s a -> QGenExpr ctxt be s a QExpr a **. QExpr b = QExpr (powerE <$> a <*> b) stddevPopOver_, stddevSampOver_, varPopOver_, varSampOver_ - :: (Num a, Floating b, IsSql2003EnhancedNumericFunctionsAggregationExpressionSyntax syntax) - => Maybe (Sql92AggregationSetQuantifierSyntax syntax) -> QExpr syntax s a - -> QAgg syntax s b + :: (Num a, Floating b, BeamSqlBackend be, BeamSqlT621Backend be) + => Maybe (BeamSqlBackendAggregationQuantifierSyntax be) -> QExpr be s a + -> QAgg be s b stddevPopOver_ q (QExpr x) = QExpr (stddevPopE q <$> x) stddevSampOver_ q (QExpr x) = QExpr (stddevSampE q <$> x) varPopOver_ q (QExpr x) = QExpr (varPopE q <$> x) varSampOver_ q (QExpr x) = QExpr (varSampE q <$> x) stddevPop_, stddevSamp_, varPop_, varSamp_ - :: (Num a, Floating b, IsSql2003EnhancedNumericFunctionsAggregationExpressionSyntax syntax) - => QExpr syntax s a -> QAgg syntax s b + :: (Num a, Floating b, BeamSqlBackend be, BeamSqlT621Backend be) + => QExpr be s a -> QAgg be s b stddevPop_ = stddevPopOver_ allInGroup_ stddevSamp_ = stddevSampOver_ allInGroup_ varPop_ = varPopOver_ allInGroup_ @@ -111,9 +117,9 @@ covarPopOver_, covarSampOver_, corrOver_, regrSlopeOver_, regrInterceptOver_, regrCountOver_, regrRSquaredOver_, regrAvgYOver_, regrAvgXOver_, regrSXXOver_, regrSXYOver_, regrSYYOver_ - :: (Num a, Floating b, IsSql2003EnhancedNumericFunctionsAggregationExpressionSyntax syntax) - => Maybe (Sql92AggregationSetQuantifierSyntax syntax) -> QExpr syntax s a -> QExpr syntax s a - -> QExpr syntax s b + :: (Num a, Floating b, BeamSqlBackend be, BeamSqlT621Backend be) + => Maybe (BeamSqlBackendAggregationQuantifierSyntax be) -> QExpr be s a -> QExpr be s a + -> QExpr be s b covarPopOver_ q (QExpr x) (QExpr y) = QExpr (covarPopE q <$> x <*> y) covarSampOver_ q (QExpr x) (QExpr y) = QExpr (covarSampE q <$> x <*> y) corrOver_ q (QExpr x) (QExpr y) = QExpr (corrE q <$> x <*> y) @@ -129,8 +135,8 @@ covarPop_, covarSamp_, corr_, regrSlope_, regrIntercept_, regrCount_, regrRSquared_, regrAvgY_, regrAvgX_, regrSXX_, regrSXY_, regrSYY_ - :: (Num a, Floating b, IsSql2003EnhancedNumericFunctionsAggregationExpressionSyntax syntax) - => QExpr syntax s a -> QExpr syntax s a -> QExpr syntax s b + :: (Num a, Floating b, BeamSqlBackend be, BeamSqlT621Backend be) + => QExpr be s a -> QExpr be s a -> QExpr be s b covarPop_ = covarPopOver_ allInGroup_ covarSamp_ = covarSampOver_ allInGroup_ corr_ = corrOver_ allInGroup_ diff --git a/Database/Beam/Query/Extract.hs b/Database/Beam/Query/Extract.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Query/Extract.hs @@ -0,0 +1,61 @@ +module Database.Beam.Query.Extract + ( -- * SQL @EXTRACT@ support + + ExtractField(..), + + extract_, + + -- ** SQL92 fields + hour_, minutes_, seconds_, + year_, month_, day_, + + HasSqlTime, HasSqlDate + ) where + +import Database.Beam.Query.Internal ( QGenExpr(..) ) + +import Database.Beam.Backend.SQL ( BeamSqlBackend, BeamSqlBackendSyntax ) +import Database.Beam.Backend.SQL.SQL92 ( Sql92ExtractFieldSyntax + , IsSql92ExpressionSyntax(..) + , IsSql92ExtractFieldSyntax(..) ) + +import Data.Time (LocalTime, UTCTime, TimeOfDay, Day) + +-- | A field that can be extracted from SQL expressions of type 'tgt' +-- that results in a type 'a', in backend 'be'. +newtype ExtractField be tgt a + = ExtractField (Sql92ExtractFieldSyntax (BeamSqlBackendSyntax be)) + +-- | Extracts the given field from the target expression +extract_ :: BeamSqlBackend be + => ExtractField be tgt a -> QGenExpr ctxt be s tgt -> QGenExpr cxt be s a +extract_ (ExtractField field) (QExpr expr) = + QExpr (extractE field <$> expr) + +-- | Type-class for types that contain a time component +class HasSqlTime tgt +instance HasSqlTime LocalTime +instance HasSqlTime UTCTime +instance HasSqlTime TimeOfDay + +-- | Extracts the hours, minutes, or seconds from any timestamp or +-- time field +hour_, minutes_, seconds_ + :: ( BeamSqlBackend be, HasSqlTime tgt ) + => ExtractField be tgt Double +hour_ = ExtractField hourField +minutes_ = ExtractField minutesField +seconds_ = ExtractField secondsField + +-- | Type-class for types that contain a date component +class HasSqlDate tgt +instance HasSqlDate LocalTime +instance HasSqlDate UTCTime +instance HasSqlDate Day + +year_, month_, day_ + :: ( BeamSqlBackend be, HasSqlDate tgt ) + => ExtractField be tgt Double +year_ = ExtractField yearField +month_ = ExtractField monthField +day_ = ExtractField dayField diff --git a/Database/Beam/Query/Internal.hs b/Database/Beam/Query/Internal.hs --- a/Database/Beam/Query/Internal.hs +++ b/Database/Beam/Query/Internal.hs @@ -8,11 +8,13 @@ import Database.Beam.Backend.SQL import Database.Beam.Schema.Tables +import qualified Data.DList as DList +import Data.Functor.Const import Data.String import qualified Data.Text as T -import qualified Data.DList as DList import Data.Typeable import Data.Vector.Sized (Vector) +import qualified Data.Vector.Sized as VS #if !MIN_VERSION_base(4, 11, 0) import Data.Semigroup #endif @@ -24,89 +26,92 @@ import GHC.TypeLits import GHC.Types -type ProjectibleInSelectSyntax syntax a = - ( IsSql92SelectSyntax syntax - , Eq (Sql92SelectExpressionSyntax syntax) - , Sql92ProjectionExpressionSyntax (Sql92SelectProjectionSyntax syntax) ~ Sql92SelectExpressionSyntax syntax - , Sql92TableSourceSelectSyntax (Sql92FromTableSourceSyntax (Sql92SelectFromSyntax syntax)) ~ syntax - , Projectible (Sql92ProjectionExpressionSyntax (Sql92SelectTableProjectionSyntax (Sql92SelectSelectTableSyntax syntax))) a - , ProjectibleValue (Sql92ProjectionExpressionSyntax (Sql92SelectTableProjectionSyntax (Sql92SelectSelectTableSyntax syntax))) a) +type ProjectibleInBackend be a = + ( -- Eq (Sql92SelectExpressionSyntax syntax) + Projectible be a + , ProjectibleValue be a ) type TablePrefix = T.Text -data QF select (db :: (* -> *) -> *) s next where - QDistinct :: Projectible (Sql92SelectExpressionSyntax select) r - => (r -> WithExprContext (Sql92SelectTableSetQuantifierSyntax (Sql92SelectSelectTableSyntax select))) - -> QM select db s r - -> (r -> next) - -> QF select db s next +data QF be (db :: (* -> *) -> *) s next where + QDistinct :: Projectible be r + => (r -> WithExprContext (BeamSqlBackendSetQuantifierSyntax be)) + -> QM be db s r -> (r -> next) -> QF be db s next - QAll :: Beamable table - => (TablePrefix -> T.Text -> Sql92SelectFromSyntax select) -> TableSettings table - -> (table (QExpr (Sql92SelectExpressionSyntax select) s) -> Maybe (WithExprContext (Sql92SelectExpressionSyntax select))) - -> ((T.Text, table (QExpr (Sql92SelectExpressionSyntax select) s)) -> next) -> QF select db s next + QAll :: Projectible be r + => (TablePrefix -> T.Text -> BeamSqlBackendFromSyntax be) + -> (T.Text -> r) + -> (r -> Maybe (WithExprContext (BeamSqlBackendExpressionSyntax be))) + -> ((T.Text, r) -> next) -> QF be db s next - QArbitraryJoin :: Projectible (Sql92SelectExpressionSyntax select) r - => QM select db (QNested s) r - -> (Sql92SelectFromSyntax select -> Sql92SelectFromSyntax select -> - Maybe (Sql92FromExpressionSyntax (Sql92SelectFromSyntax select)) -> - Sql92SelectFromSyntax select) - -> (r -> Maybe (WithExprContext (Sql92SelectExpressionSyntax select))) + QArbitraryJoin :: Projectible be r + => QM be db (QNested s) r + -> (BeamSqlBackendFromSyntax be -> BeamSqlBackendFromSyntax be -> + Maybe (BeamSqlBackendExpressionSyntax be) -> + BeamSqlBackendFromSyntax be) + -> (r -> Maybe (WithExprContext (BeamSqlBackendExpressionSyntax be))) -> (r -> next) - -> QF select db s next - QTwoWayJoin :: ( Projectible (Sql92SelectExpressionSyntax select) a - , Projectible (Sql92SelectExpressionSyntax select) b ) - => QM select db (QNested s) a - -> QM select db (QNested s) b - -> (Sql92SelectFromSyntax select -> Sql92SelectFromSyntax select -> - Maybe (Sql92FromExpressionSyntax (Sql92SelectFromSyntax select)) -> - Sql92SelectFromSyntax select) - -> ((a, b) -> Maybe (WithExprContext (Sql92SelectExpressionSyntax select))) + -> QF be db s next + QTwoWayJoin :: ( Projectible be a + , Projectible be b ) + => QM be db (QNested s) a + -> QM be db (QNested s) b + -> (BeamSqlBackendFromSyntax be -> BeamSqlBackendFromSyntax be -> + Maybe (BeamSqlBackendExpressionSyntax be) -> + BeamSqlBackendFromSyntax be) + -> ((a, b) -> Maybe (WithExprContext (BeamSqlBackendExpressionSyntax be))) -> ((a, b) -> next) - -> QF select db s next + -> QF be db s next - QSubSelect :: Projectible (Sql92SelectExpressionSyntax select) r => - QM select db (QNested s) r -> (r -> next) -> QF select db s next - QGuard :: WithExprContext (Sql92SelectExpressionSyntax select) -> next -> QF select db s next + QSubSelect :: Projectible be r + => QM be db (QNested s) r -> (r -> next) + -> QF be db s next - QLimit :: Projectible (Sql92SelectExpressionSyntax select) r => Integer -> QM select db (QNested s) r -> (r -> next) -> QF select db s next - QOffset :: Projectible (Sql92SelectExpressionSyntax select) r => Integer -> QM select db (QNested s) r -> (r -> next) -> QF select db s next + QGuard :: WithExprContext (BeamSqlBackendExpressionSyntax be) -> next -> QF be db s next - QUnion ::Projectible (Sql92SelectExpressionSyntax select) r => Bool -> QM select db (QNested s) r -> QM select db (QNested s) r -> (r -> next) -> QF select db s next - QIntersect :: Projectible (Sql92SelectExpressionSyntax select) r => Bool -> QM select db (QNested s) r -> QM select db (QNested s) r -> (r -> next) -> QF select db s next - QExcept :: Projectible (Sql92SelectExpressionSyntax select) r => Bool -> QM select db (QNested s) r -> QM select db (QNested s) r -> (r -> next) -> QF select db s next - QOrderBy :: Projectible (Sql92SelectExpressionSyntax select) r => - (r -> WithExprContext [ Sql92SelectOrderingSyntax select ]) - -> QM select db (QNested s) r -> (r -> next) -> QF select db s next + QLimit :: Projectible be r => Integer -> QM be db (QNested s) r -> (r -> next) -> QF be db s next + QOffset :: Projectible be r => Integer -> QM be db (QNested s) r -> (r -> next) -> QF be db s next - QWindowOver :: ( ProjectibleWithPredicate WindowFrameContext (Sql2003ExpressionWindowFrameSyntax (Sql92SelectExpressionSyntax select)) window - , Projectible (Sql92SelectExpressionSyntax select) r - , Projectible (Sql92SelectExpressionSyntax select) a ) + QSetOp :: Projectible be r + => (BeamSqlBackendSelectTableSyntax be -> BeamSqlBackendSelectTableSyntax be -> BeamSqlBackendSelectTableSyntax be) + -> QM be db (QNested s) r + -> QM be db (QNested s) r -> (r -> next) + -> QF be db s next + + QOrderBy :: Projectible be r + => (r -> WithExprContext [ BeamSqlBackendOrderingSyntax be ]) + -> QM be db (QNested s) r -> (r -> next) -> QF be db s next + + QWindowOver :: ( ProjectibleWithPredicate WindowFrameContext be (WithExprContext (BeamSqlBackendWindowFrameSyntax' be)) window + , Projectible be r + , Projectible be a ) => (r -> window) -> (r -> window -> a) - -> QM select db (QNested s) r -> (a -> next) -> QF select db s next - QAggregate :: ( Projectible (Sql92SelectExpressionSyntax select) grouping - , Projectible (Sql92SelectExpressionSyntax select) a ) => - (a -> TablePrefix -> (Maybe (Sql92SelectGroupingSyntax select), grouping)) -> - QM select db (QNested s) a -> - (grouping -> next) -> QF select db s next + -> QM be db (QNested s) r -> (a -> next) -> QF be db s next + QAggregate :: ( Projectible be grouping + , Projectible be a ) + => (a -> TablePrefix -> (Maybe (BeamSqlBackendGroupingSyntax be), grouping)) + -> QM be db (QNested s) a + -> (grouping -> next) + -> QF be db s next + -- Force the building of a select statement, using the given builder - QForceSelect :: Projectible (Sql92SelectExpressionSyntax select) r - => (r -> Sql92SelectSelectTableSyntax select -> [ Sql92SelectOrderingSyntax select ] -> - Maybe Integer -> Maybe Integer -> select) - -> QM select db (QNested s) r + QForceSelect :: Projectible be r + => (r -> BeamSqlBackendSelectTableSyntax be -> [ BeamSqlBackendOrderingSyntax be ] -> + Maybe Integer -> Maybe Integer -> BeamSqlBackendSelectSyntax be) + -> QM be db (QNested s) r -> (r -> next) - -> QF select db s next + -> QF be db s next -deriving instance Functor (QF select db s) +deriving instance Functor (QF be db s) -type QM select db s = F (QF select db s) +type QM be db s = F (QF be db s) -- | The type of queries over the database `db` returning results of type `a`. -- The `s` argument is a threading argument meant to restrict cross-usage of -- `QExpr`s. 'syntax' represents the SQL syntax that this query is building. -newtype Q syntax (db :: (* -> *) -> *) s a - = Q { runQ :: QM syntax db s a } +newtype Q be (db :: (* -> *) -> *) s a + = Q { runQ :: QM be db s a } deriving (Monad, Applicative, Functor) data QInternal @@ -114,21 +119,23 @@ data QField s ty = QField - { qFieldShouldQualify :: Bool - , qFieldTblName :: T.Text - , qFieldName :: T.Text } + { qFieldShouldQualify :: !Bool + , qFieldTblName :: !T.Text + , qFieldName :: !T.Text } deriving (Show, Eq, Ord) -newtype QAssignment fieldName expr s - = QAssignment [(fieldName, expr)] - deriving (Show, Eq, Ord, Monoid, Semigroup) +newtype QAssignment be s + = QAssignment [(BeamSqlBackendFieldNameSyntax be, BeamSqlBackendExpressionSyntax be)] + deriving (Monoid, Semigroup) +newtype QFieldAssignment be tbl a + = QFieldAssignment (forall s. tbl (QExpr be s) -> Maybe (QExpr be s a)) + -- * QGenExpr type data QAggregateContext data QGroupingContext data QValueContext -data QOrderingContext data QWindowingContext data QWindowFrameContext @@ -145,18 +152,18 @@ -- 's' is a state threading parameter that prevents 'QExpr's from incompatible -- sources to be combined. For example, this is used to prevent monadic joins -- from depending on the result of previous joins (so-called @LATERAL@ joins). -newtype QGenExpr context syntax s t = QExpr (TablePrefix -> syntax) +newtype QGenExpr context be s t = QExpr (TablePrefix -> BeamSqlBackendExpressionSyntax be) +newtype QOrd be s t = QOrd (TablePrefix -> BeamSqlBackendOrderingSyntax be) + type WithExprContext a = TablePrefix -> a -- | 'QExpr's represent expressions not containing aggregates. type QExpr = QGenExpr QValueContext type QAgg = QGenExpr QAggregateContext -type QOrd = QGenExpr QOrderingContext type QWindowExpr = QGenExpr QWindowingContext -type QWindowFrame = QGenExpr QWindowFrameContext type QGroupExpr = QGenExpr QGroupingContext --deriving instance Show syntax => Show (QGenExpr context syntax s t) -instance Eq syntax => Eq (QGenExpr context syntax s t) where +instance BeamSqlBackend be => Eq (QGenExpr context be s t) where QExpr a == QExpr b = a "" == b "" instance Retaggable (QGenExpr ctxt expr s) (QGenExpr ctxt expr s t) where @@ -164,28 +171,27 @@ retag f e = case f (Columnar' e) of Columnar' a -> a -newtype QWindow syntax s = QWindow (WithExprContext syntax) -newtype QFrameBounds syntax = QFrameBounds (Maybe syntax) -newtype QFrameBound syntax = QFrameBound syntax +newtype QWindow be s = QWindow (WithExprContext (BeamSqlBackendWindowFrameSyntax be)) +newtype QFrameBounds be = QFrameBounds (Maybe (BeamSqlBackendWindowFrameBoundsSyntax be)) +newtype QFrameBound be = QFrameBound (BeamSqlBackendWindowFrameBoundSyntax be) -qBinOpE :: forall syntax context s a b c. IsSql92ExpressionSyntax syntax => - (syntax -> syntax -> syntax) - -> QGenExpr context syntax s a -> QGenExpr context syntax s b - -> QGenExpr context syntax s c +qBinOpE :: BeamSqlBackend be + => (BeamSqlBackendExpressionSyntax be -> + BeamSqlBackendExpressionSyntax be -> + BeamSqlBackendExpressionSyntax be) + -> QGenExpr context be s a -> QGenExpr context be s b + -> QGenExpr context be s c qBinOpE mkOpE (QExpr a) (QExpr b) = QExpr (mkOpE <$> a <*> b) -unsafeRetype :: QGenExpr ctxt syntax s a -> QGenExpr ctxt syntax s a' +unsafeRetype :: QGenExpr ctxt be s a -> QGenExpr ctxt be s a' unsafeRetype (QExpr v) = QExpr v -instance ( IsSql92ExpressionSyntax syntax - , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) [Char] ) => - IsString (QGenExpr context syntax s T.Text) where +instance ( BeamSqlBackend backend, BeamSqlBackendCanSerialize backend [Char] ) => + IsString (QGenExpr context backend s T.Text) where fromString = QExpr . pure . valueE . sqlValueSyntax -instance (Num a - , IsSql92ExpressionSyntax syntax - , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) a) => - Num (QGenExpr context syntax s a) where - fromInteger x = let res :: QGenExpr context syntax s a +instance ( Num a, BeamSqlBackend be, BeamSqlBackendCanSerialize be a ) => + Num (QGenExpr context be s a) where + fromInteger x = let res :: QGenExpr context be s a res = QExpr (pure (valueE (sqlValueSyntax (fromIntegral x :: a)))) in res QExpr a + QExpr b = QExpr (addE <$> a <*> b) @@ -195,22 +201,14 @@ abs (QExpr x) = QExpr (absE <$> x) signum _ = error "signum: not defined for QExpr. Use CASE...WHEN" -instance ( Fractional a - , IsSql92ExpressionSyntax syntax - , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) a ) => - Fractional (QGenExpr context syntax s a) where +instance ( Fractional a, BeamSqlBackend be, BeamSqlBackendCanSerialize be a ) => + Fractional (QGenExpr context be s a) where QExpr a / QExpr b = QExpr (divE <$> a <*> b) recip = (1.0 /) fromRational = QExpr . pure . valueE . sqlValueSyntax . (id :: a -> a) . fromRational --- * Aggregations - -data Aggregation syntax s a - = GroupAgg syntax --(Sql92ExpressionSyntax syntax) - | ProjectAgg syntax --(Sql92ExpressionSyntax syntax) - -- * Sql Projections -- @@ -225,7 +223,6 @@ type instance ContextName QValueContext = "a value" type instance ContextName QWindowingContext = "a window expression" type instance ContextName QWindowFrameContext = "a window frame" -type instance ContextName QOrderingContext = "an ordering expression" type instance ContextName QAggregateContext = "an aggregate" type instance ContextName QGroupingContext = "an aggregate grouping" @@ -239,7 +236,6 @@ type family AggregateContextSuggestion a :: ErrorMessage where AggregateContextSuggestion QValueContext = 'Text "Perhaps you forgot to wrap a value expression with 'group_'" AggregateContextSuggestion QWindowingContext = 'Text "Perhaps you meant to use 'window_' instead of 'aggregate_'" - AggregateContextSuggestion QOrderingContext = 'Text "You cannot use an ordering in an aggregate" AggregateContextSuggestion b = 'Text "" class Typeable context => ValueContext context @@ -265,14 +261,13 @@ type family ValueContextSuggestion a :: ErrorMessage where ValueContextSuggestion QWindowingContext = 'Text "Use 'window_' to projecct aggregate expressions to the value level" - ValueContextSuggestion QOrderingContext = 'Text "An ordering context cannot be used in a projection. Try removing the 'asc_' or 'desc_', or use 'orderBy_' to sort the result set" ValueContextSuggestion QAggregateContext = ('Text "Aggregate functions and groupings cannot be contained in value expressions." :$$: 'Text "Use 'aggregate_' to compute aggregations at the value level.") ValueContextSuggestion QGroupingContext = ValueContextSuggestion QAggregateContext ValueContextSuggestion _ = 'Text "" -type Projectible = ProjectibleWithPredicate AnyType -type ProjectibleValue = ProjectibleWithPredicate ValueContext +type Projectible be = ProjectibleWithPredicate AnyType be (WithExprContext (BeamSqlBackendExpressionSyntax' be)) +type ProjectibleValue be = ProjectibleWithPredicate ValueContext be (WithExprContext (BeamSqlBackendExpressionSyntax' be)) class ThreadRewritable (s :: *) (a :: *) | a -> s where type WithRewrittenThread s (s' :: *) a :: * @@ -420,89 +415,253 @@ , rewriteContext p d, rewriteContext p e, rewriteContext p f , rewriteContext p g, rewriteContext p h ) -class ProjectibleWithPredicate (contextPredicate :: * -> Constraint) syntax a | a -> syntax where - project' :: Monad m => Proxy contextPredicate - -> (forall context. contextPredicate context => Proxy context -> WithExprContext syntax -> m (WithExprContext syntax)) +newtype BeamSqlBackendExpressionSyntax' be + = BeamSqlBackendExpressionSyntax' + { fromBeamSqlBackendExpressionSyntax :: BeamSqlBackendExpressionSyntax be + } + +newtype BeamSqlBackendWindowFrameSyntax' be + = BeamSqlBackendWindowFrameSyntax' + { fromBeamSqlBackendWindowFrameSyntax :: BeamSqlBackendWindowFrameSyntax be + } + +class ProjectibleWithPredicate (contextPredicate :: * -> Constraint) be res a | a -> be where + project' :: Monad m => Proxy contextPredicate -> Proxy (be, res) + -> (forall context. contextPredicate context => + Proxy context -> Proxy be -> res -> m res) -> a -> m a -instance (Beamable t, contextPredicate context) => ProjectibleWithPredicate contextPredicate syntax (t (QGenExpr context syntax s)) where - project' _ mutateM a = + + projectSkeleton' :: Monad m => Proxy contextPredicate -> Proxy (be, res) + -> (forall context. contextPredicate context => + Proxy context -> Proxy be -> m res) + -> m a + +instance (Beamable t, contextPredicate context) => ProjectibleWithPredicate contextPredicate be (WithExprContext (BeamSqlBackendExpressionSyntax' be)) (t (QGenExpr context be s)) where + project' _ _ mutateM a = zipBeamFieldsM (\(Columnar' (QExpr e)) _ -> - Columnar' . QExpr <$> mutateM (Proxy @context) e) a a -instance (Beamable t, contextPredicate context) => ProjectibleWithPredicate contextPredicate syntax (t (Nullable (QGenExpr context syntax s))) where - project' _ mutateM a = + Columnar' . QExpr . fmap fromBeamSqlBackendExpressionSyntax <$> mutateM (Proxy @context) (Proxy @be) (BeamSqlBackendExpressionSyntax' . e)) a a + + projectSkeleton' _ _ mkM = + zipBeamFieldsM (\_ _ -> Columnar' . QExpr . fmap fromBeamSqlBackendExpressionSyntax <$> mkM (Proxy @context)(Proxy @be)) + (tblSkeleton :: TableSkeleton t) + (tblSkeleton :: TableSkeleton t) + +instance (Beamable t, contextPredicate context) => ProjectibleWithPredicate contextPredicate be (WithExprContext (BeamSqlBackendExpressionSyntax' be)) (t (Nullable (QGenExpr context be s))) where + project' _ _ mutateM a = zipBeamFieldsM (\(Columnar' (QExpr e)) _ -> - Columnar' . QExpr <$> mutateM (Proxy @context) e) a a -instance ProjectibleWithPredicate WindowFrameContext syntax (QWindow syntax s) where - project' _ mutateM (QWindow a) = - QWindow <$> mutateM (Proxy @QWindowFrameContext) a -instance contextPredicate context => ProjectibleWithPredicate contextPredicate syntax (QGenExpr context syntax s a) where - project' _ mkE (QExpr a) = QExpr <$> mkE (Proxy @context) a -instance ProjectibleWithPredicate contextPredicate syntax a => ProjectibleWithPredicate contextPredicate syntax [a] where - project' p mkE as = traverse (project' p mkE) as -instance (ProjectibleWithPredicate contextPredicate syntax a, KnownNat n) => ProjectibleWithPredicate contextPredicate syntax (Vector n a) where - project' p mkE as = traverse (project' p mkE) as -instance ( ProjectibleWithPredicate contextPredicate syntax a, ProjectibleWithPredicate contextPredicate syntax b ) => - ProjectibleWithPredicate contextPredicate syntax (a, b) where + Columnar' . QExpr . fmap fromBeamSqlBackendExpressionSyntax <$> mutateM (Proxy @context) (Proxy @be) (BeamSqlBackendExpressionSyntax' . e)) a a - project' p mkE (a, b) = (,) <$> project' p mkE a <*> project' p mkE b -instance ( ProjectibleWithPredicate contextPredicate syntax a, ProjectibleWithPredicate contextPredicate syntax b, ProjectibleWithPredicate contextPredicate syntax c ) => - ProjectibleWithPredicate contextPredicate syntax (a, b, c) where + projectSkeleton' _ _ mkM = + zipBeamFieldsM (\_ _ -> Columnar' . QExpr . fmap fromBeamSqlBackendExpressionSyntax <$> mkM (Proxy @context)(Proxy @be)) + (tblSkeleton :: TableSkeleton t) + (tblSkeleton :: TableSkeleton t) - project' p mkE (a, b, c) = (,,) <$> project' p mkE a <*> project' p mkE b <*> project' p mkE c -instance ( ProjectibleWithPredicate contextPredicate syntax a, ProjectibleWithPredicate contextPredicate syntax b, ProjectibleWithPredicate contextPredicate syntax c - , ProjectibleWithPredicate contextPredicate syntax d ) => - ProjectibleWithPredicate contextPredicate syntax (a, b, c, d) where +-- instance ProjectibleWithPredicate WindowFrameContext be (QWindow be s) where +-- project' _ be mutateM (QWindow a) = +-- QWindow <$> mutateM (Proxy @QWindowFrameContext) be a - project' p mkE (a, b, c, d) = (,,,) <$> project' p mkE a <*> project' p mkE b <*> project' p mkE c - <*> project' p mkE d -instance ( ProjectibleWithPredicate contextPredicate syntax a, ProjectibleWithPredicate contextPredicate syntax b, ProjectibleWithPredicate contextPredicate syntax c - , ProjectibleWithPredicate contextPredicate syntax d, ProjectibleWithPredicate contextPredicate syntax e ) => - ProjectibleWithPredicate contextPredicate syntax (a, b, c, d, e) where +instance contextPredicate context => ProjectibleWithPredicate contextPredicate be (WithExprContext (BeamSqlBackendExpressionSyntax' be)) (QGenExpr context be s a) where + project' _ _ mkE (QExpr a) = QExpr . fmap fromBeamSqlBackendExpressionSyntax <$> mkE (Proxy @context) (Proxy @be) (BeamSqlBackendExpressionSyntax' . a) + projectSkeleton' _ _ mkM = QExpr . fmap fromBeamSqlBackendExpressionSyntax <$> mkM (Proxy @context) (Proxy @be) - project' p mkE (a, b, c, d, e) = (,,,,) <$> project' p mkE a <*> project' p mkE b <*> project' p mkE c - <*> project' p mkE d <*> project' p mkE e -instance ( ProjectibleWithPredicate contextPredicate syntax a, ProjectibleWithPredicate contextPredicate syntax b, ProjectibleWithPredicate contextPredicate syntax c - , ProjectibleWithPredicate contextPredicate syntax d, ProjectibleWithPredicate contextPredicate syntax e, ProjectibleWithPredicate contextPredicate syntax f ) => - ProjectibleWithPredicate contextPredicate syntax (a, b, c, d, e, f) where +instance contextPredicate QWindowFrameContext => ProjectibleWithPredicate contextPredicate be (WithExprContext (BeamSqlBackendWindowFrameSyntax' be)) (QWindow be s) where + project' _ _ mkW (QWindow w) = QWindow . fmap fromBeamSqlBackendWindowFrameSyntax <$> mkW (Proxy @QWindowFrameContext) (Proxy @be) (BeamSqlBackendWindowFrameSyntax' . w) + projectSkeleton' _ _ mkM = QWindow . fmap fromBeamSqlBackendWindowFrameSyntax <$> mkM (Proxy @QWindowFrameContext) (Proxy @be) - project' p mkE (a, b, c, d, e, f) = (,,,,,) <$> project' p mkE a <*> project' p mkE b <*> project' p mkE c - <*> project' p mkE d <*> project' p mkE e <*> project' p mkE f -instance ( ProjectibleWithPredicate contextPredicate syntax a, ProjectibleWithPredicate contextPredicate syntax b, ProjectibleWithPredicate contextPredicate syntax c - , ProjectibleWithPredicate contextPredicate syntax d, ProjectibleWithPredicate contextPredicate syntax e, ProjectibleWithPredicate contextPredicate syntax f - , ProjectibleWithPredicate contextPredicate syntax g ) => - ProjectibleWithPredicate contextPredicate syntax (a, b, c, d, e, f, g) where +-- instance ProjectibleWithPredicate contextPredicate be res a => ProjectibleWithPredicate contextPredicate be res [a] where +-- project' context be mkE as = traverse (project' context be mkE) as - project' p mkE (a, b, c, d, e, f, g) = - (,,,,,,) <$> project' p mkE a <*> project' p mkE b <*> project' p mkE c - <*> project' p mkE d <*> project' p mkE e <*> project' p mkE f - <*> project' p mkE g -instance ( ProjectibleWithPredicate contextPredicate syntax a, ProjectibleWithPredicate contextPredicate syntax b, ProjectibleWithPredicate contextPredicate syntax c - , ProjectibleWithPredicate contextPredicate syntax d, ProjectibleWithPredicate contextPredicate syntax e, ProjectibleWithPredicate contextPredicate syntax f - , ProjectibleWithPredicate contextPredicate syntax g, ProjectibleWithPredicate contextPredicate syntax h ) => - ProjectibleWithPredicate contextPredicate syntax (a, b, c, d, e, f, g, h) where +instance (ProjectibleWithPredicate contextPredicate be res a, KnownNat n) => ProjectibleWithPredicate contextPredicate be res (Vector n a) where + project' context be mkE as = traverse (project' context be mkE) as + projectSkeleton' context be mkM = VS.replicateM (projectSkeleton' context be mkM) - project' p mkE (a, b, c, d, e, f, g, h) = - (,,,,,,,) <$> project' p mkE a <*> project' p mkE b <*> project' p mkE c - <*> project' p mkE d <*> project' p mkE e <*> project' p mkE f - <*> project' p mkE g <*> project' p mkE h +instance ( ProjectibleWithPredicate contextPredicate be res a, ProjectibleWithPredicate contextPredicate be res b ) => + ProjectibleWithPredicate contextPredicate be res (a, b) where -instance Beamable t => ProjectibleWithPredicate AnyType T.Text (t (QField s)) where - project' _ mutateM a = + project' context be mkE (a, b) = + (,) <$> project' context be mkE a <*> project' context be mkE b + projectSkeleton' context be mkM = + (,) <$> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + +instance ( ProjectibleWithPredicate contextPredicate be res a, ProjectibleWithPredicate contextPredicate be res b, ProjectibleWithPredicate contextPredicate be res c ) => + ProjectibleWithPredicate contextPredicate be res (a, b, c) where + + project' context be mkE (a, b, c) = + (,,) <$> project' context be mkE a <*> project' context be mkE b <*> project' context be mkE c + projectSkeleton' context be mkM = + (,,) <$> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + +instance ( ProjectibleWithPredicate contextPredicate be res a, ProjectibleWithPredicate contextPredicate be res b, ProjectibleWithPredicate contextPredicate be res c + , ProjectibleWithPredicate contextPredicate be res d ) => + ProjectibleWithPredicate contextPredicate be res (a, b, c, d) where + + project' context be mkE (a, b, c, d) = + (,,,) <$> project' context be mkE a <*> project' context be mkE b <*> project' context be mkE c + <*> project' context be mkE d + projectSkeleton' context be mkM = + (,,,) <$> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + +instance ( ProjectibleWithPredicate contextPredicate be res a, ProjectibleWithPredicate contextPredicate be res b, ProjectibleWithPredicate contextPredicate be res c + , ProjectibleWithPredicate contextPredicate be res d, ProjectibleWithPredicate contextPredicate be res e ) => + ProjectibleWithPredicate contextPredicate be res (a, b, c, d, e) where + + project' context be mkE (a, b, c, d, e) = + (,,,,) <$> project' context be mkE a <*> project' context be mkE b <*> project' context be mkE c + <*> project' context be mkE d <*> project' context be mkE e + projectSkeleton' context be mkM = + (,,,,) <$> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + +instance ( ProjectibleWithPredicate contextPredicate be res a, ProjectibleWithPredicate contextPredicate be res b, ProjectibleWithPredicate contextPredicate be res c + , ProjectibleWithPredicate contextPredicate be res d, ProjectibleWithPredicate contextPredicate be res e, ProjectibleWithPredicate contextPredicate be res f ) => + ProjectibleWithPredicate contextPredicate be res (a, b, c, d, e, f) where + + project' context be mkE (a, b, c, d, e, f) = + (,,,,,) <$> project' context be mkE a <*> project' context be mkE b <*> project' context be mkE c + <*> project' context be mkE d <*> project' context be mkE e <*> project' context be mkE f + projectSkeleton' context be mkM = + (,,,,,) <$> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + +instance ( ProjectibleWithPredicate contextPredicate be res a, ProjectibleWithPredicate contextPredicate be res b, ProjectibleWithPredicate contextPredicate be res c + , ProjectibleWithPredicate contextPredicate be res d, ProjectibleWithPredicate contextPredicate be res e, ProjectibleWithPredicate contextPredicate be res f + , ProjectibleWithPredicate contextPredicate be res g ) => + ProjectibleWithPredicate contextPredicate be res (a, b, c, d, e, f, g) where + + project' context be mkE (a, b, c, d, e, f, g) = + (,,,,,,) <$> project' context be mkE a <*> project' context be mkE b <*> project' context be mkE c + <*> project' context be mkE d <*> project' context be mkE e <*> project' context be mkE f + <*> project' context be mkE g + projectSkeleton' context be mkM = + (,,,,,,) <$> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + +instance ( ProjectibleWithPredicate contextPredicate be res a, ProjectibleWithPredicate contextPredicate be res b, ProjectibleWithPredicate contextPredicate be res c + , ProjectibleWithPredicate contextPredicate be res d, ProjectibleWithPredicate contextPredicate be res e, ProjectibleWithPredicate contextPredicate be res f + , ProjectibleWithPredicate contextPredicate be res g, ProjectibleWithPredicate contextPredicate be res h ) => + ProjectibleWithPredicate contextPredicate be res (a, b, c, d, e, f, g, h) where + + project' context be mkE (a, b, c, d, e, f, g, h) = + (,,,,,,,) <$> project' context be mkE a <*> project' context be mkE b <*> project' context be mkE c + <*> project' context be mkE d <*> project' context be mkE e <*> project' context be mkE f + <*> project' context be mkE g <*> project' context be mkE h + projectSkeleton' context be mkM = + (,,,,,,,) <$> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + <*> projectSkeleton' context be mkM + +-- TODO add projectSkeleton' +instance Beamable t => ProjectibleWithPredicate AnyType () T.Text (t (QField s)) where + project' _ be mutateM a = zipBeamFieldsM (\(Columnar' f) _ -> - Columnar' <$> project' (Proxy @AnyType) mutateM f) a a -instance Beamable t => ProjectibleWithPredicate AnyType T.Text (t (Nullable (QField s))) where - project' _ mutateM a = + Columnar' <$> project' (Proxy @AnyType) be mutateM f) a a + + projectSkeleton' _ _ mkM = + zipBeamFieldsM (\_ _ -> Columnar' . QField False "" <$> (mkM (Proxy @()) (Proxy @()))) + (tblSkeleton :: TableSkeleton t) (tblSkeleton :: TableSkeleton t) + +instance Beamable t => ProjectibleWithPredicate AnyType () T.Text (t (Nullable (QField s))) where + project' _ be mutateM a = zipBeamFieldsM (\(Columnar' f) _ -> - Columnar' <$> project' (Proxy @AnyType) mutateM f) a a -instance ProjectibleWithPredicate AnyType T.Text (QField s a) where - project' _ mutateM (QField q tbl f) = - fmap (\f' -> QField q tbl (f' "")) - (mutateM (Proxy @(QField s a)) (\_ -> f)) -- This is kind of a hack + Columnar' <$> project' (Proxy @AnyType) be mutateM f) a a -project :: Projectible syntax a => a -> WithExprContext [ syntax ] -project = sequenceA . DList.toList . execWriter . project' (Proxy @AnyType) (\_ e -> tell (DList.singleton e) >> pure e) + projectSkeleton' _ _ mkM = + zipBeamFieldsM (\_ _ -> Columnar' . QField False "" <$> mkM (Proxy @()) (Proxy @())) + (tblSkeleton :: TableSkeleton t) (tblSkeleton :: TableSkeleton t) -reproject :: (IsSql92ExpressionSyntax syntax, Projectible syntax a) => - (Int -> syntax) -> a -> a -reproject mkField a = - evalState (project' (Proxy @AnyType) (\_ _ -> state (\i -> (i, i + 1)) >>= pure . pure . mkField) a) 0 +instance Beamable t => ProjectibleWithPredicate AnyType () T.Text (t (Const T.Text)) where + project' _ be mutateM a = + zipBeamFieldsM (\(Columnar' f) _ -> + Columnar' <$> project' (Proxy @AnyType) be mutateM f) a a + + projectSkeleton' _ _ mkM = + zipBeamFieldsM (\_ _ -> Columnar' . Const <$> mkM (Proxy @()) (Proxy @())) + (tblSkeleton :: TableSkeleton t) (tblSkeleton :: TableSkeleton t) + +instance Beamable t => ProjectibleWithPredicate AnyType () T.Text (t (Nullable (Const T.Text))) where + project' _ be mutateM a = + zipBeamFieldsM (\(Columnar' f) _ -> + Columnar' <$> project' (Proxy @AnyType) be mutateM f) a a + + projectSkeleton' _ _ mkM = + zipBeamFieldsM (\_ _ -> Columnar' . Const <$> mkM (Proxy @()) (Proxy @())) + (tblSkeleton :: TableSkeleton t) (tblSkeleton :: TableSkeleton t) + +instance ProjectibleWithPredicate AnyType () T.Text (Const T.Text a) where + project' _ _ mutateM (Const a) = Const <$> mutateM (Proxy @()) (Proxy @()) a + + projectSkeleton' _ _ mkM = + Const <$> mkM (Proxy @()) (Proxy @()) + +instance ProjectibleWithPredicate AnyType () T.Text (QField s a) where + project' _ _ mutateM (QField q tbl f) = + fmap (QField q tbl) + (mutateM (Proxy @(QField s a)) (Proxy @()) f) + + projectSkeleton' _ _ mkM = + QField False "" <$> mkM (Proxy @()) (Proxy @()) + +project :: forall be a + . Projectible be a => Proxy be -> a -> WithExprContext [ BeamSqlBackendExpressionSyntax be ] +project _ = fmap (fmap fromBeamSqlBackendExpressionSyntax) . sequenceA . DList.toList . execWriter . + project' (Proxy @AnyType) (Proxy @(be, WithExprContext (BeamSqlBackendExpressionSyntax' be))) (\_ _ e -> tell (DList.singleton e) >> pure e) + +reproject :: forall be a + . (BeamSqlBackend be, Projectible be a) + => Proxy be -> (Int -> BeamSqlBackendExpressionSyntax be) -> a -> a +reproject _ mkField a = + evalState (project' (Proxy @AnyType) (Proxy @(be, WithExprContext (BeamSqlBackendExpressionSyntax' be))) (\_ _ _ -> state (\i -> (i, i + 1)) >>= pure . pure . BeamSqlBackendExpressionSyntax' . mkField) a) 0 + +-- | suitable as argument to 'QAll' in the case of a table result +tableFieldsToExpressions :: ( BeamSqlBackend be, Beamable table ) + => TableSettings table -> T.Text -> table (QGenExpr ctxt be s) +tableFieldsToExpressions tblSettings newTblNm = + changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (\_ -> fieldE (qualifiedField newTblNm (_fieldName f))))) tblSettings + +mkFieldsSkeleton :: forall be res m + . (Projectible be res, MonadState Int m) + => (Int -> m (WithExprContext (BeamSqlBackendExpressionSyntax' be))) -> m res +mkFieldsSkeleton go = + projectSkeleton' (Proxy @AnyType) (Proxy @(be, WithExprContext (BeamSqlBackendExpressionSyntax' be))) $ \_ _ -> + do i <- get + put (i + 1) + go i + +mkFieldNames :: forall be res + . ( BeamSqlBackend be, Projectible be res ) + => (T.Text -> BeamSqlBackendFieldNameSyntax be) -> (res, [ T.Text ]) +mkFieldNames mkField = + runWriter . flip evalStateT 0 $ + mkFieldsSkeleton @be @res $ \i -> do + let fieldName' = fromString ("res" ++ show i) + tell [ fieldName' ] + pure (\_ -> BeamSqlBackendExpressionSyntax' (fieldE (mkField fieldName'))) + +tableNameFromEntity :: IsSql92TableNameSyntax name + => DatabaseEntityDescriptor be (TableEntity tbl) + -> name + +tableNameFromEntity = tableName <$> dbTableSchema <*> dbTableCurrentName diff --git a/Database/Beam/Query/Operator.hs b/Database/Beam/Query/Operator.hs --- a/Database/Beam/Query/Operator.hs +++ b/Database/Beam/Query/Operator.hs @@ -27,83 +27,82 @@ data SqlBool -- | SQL @AND@ operator -(&&.) :: IsSql92ExpressionSyntax syntax - => QGenExpr context syntax s Bool - -> QGenExpr context syntax s Bool - -> QGenExpr context syntax s Bool +(&&.) :: BeamSqlBackend be + => QGenExpr context be s Bool + -> QGenExpr context be s Bool + -> QGenExpr context be s Bool (&&.) = qBinOpE andE -- | SQL @OR@ operator -(||.) :: IsSql92ExpressionSyntax syntax - => QGenExpr context syntax s Bool - -> QGenExpr context syntax s Bool - -> QGenExpr context syntax s Bool +(||.) :: BeamSqlBackend be + => QGenExpr context be s Bool + -> QGenExpr context be s Bool + -> QGenExpr context be + s Bool (||.) = qBinOpE orE -- | SQL @AND@ operator for 'SqlBool' -(&&?.) :: IsSql92ExpressionSyntax syntax - => QGenExpr context syntax s SqlBool - -> QGenExpr context syntax s SqlBool - -> QGenExpr context syntax s SqlBool +(&&?.) :: BeamSqlBackend be + => QGenExpr context be s SqlBool + -> QGenExpr context be s SqlBool + -> QGenExpr context be s SqlBool (&&?.) = qBinOpE andE -- | SQL @OR@ operator -(||?.) :: IsSql92ExpressionSyntax syntax - => QGenExpr context syntax s SqlBool - -> QGenExpr context syntax s SqlBool - -> QGenExpr context syntax s SqlBool +(||?.) :: BeamSqlBackend be + => QGenExpr context be s SqlBool + -> QGenExpr context be s SqlBool + -> QGenExpr context be s SqlBool (||?.) = qBinOpE orE infixr 3 &&., &&?. infixr 2 ||., ||?. -- | SQL @LIKE@ operator -like_ :: - ( IsSqlExpressionSyntaxStringType syntax text - , IsSql92ExpressionSyntax syntax ) => - QExpr syntax s text -> QExpr syntax s text -> QExpr syntax s Bool +like_ :: ( BeamSqlBackendIsString be text + , BeamSqlBackend be ) + => QGenExpr ctxt be s text -> QGenExpr ctxt be s text -> QGenExpr ctxt be s Bool like_ (QExpr scrutinee) (QExpr search) = QExpr (liftA2 likeE scrutinee search) -- | SQL99 @SIMILAR TO@ operator -similarTo_ :: - ( IsSqlExpressionSyntaxStringType syntax text - , IsSql99ExpressionSyntax syntax ) => - QExpr syntax s text -> QExpr syntax s text -> QExpr syntax s text +similarTo_ :: ( BeamSqlBackendIsString be text + , BeamSql99ExpressionBackend be ) + => QGenExpr ctxt be s text -> QGenExpr ctxt be s text -> QGenExpr ctxt be s text similarTo_ (QExpr scrutinee) (QExpr search) = QExpr (liftA2 similarToE scrutinee search) infix 4 `like_`, `similarTo_` -- | SQL @NOT@ operator -not_ :: forall syntax context s. - IsSql92ExpressionSyntax syntax - => QGenExpr context syntax s Bool - -> QGenExpr context syntax s Bool +not_ :: forall be context s + . BeamSqlBackend be + => QGenExpr context be s Bool + -> QGenExpr context be s Bool not_ (QExpr a) = QExpr (fmap notE a) -- | SQL @NOT@ operator, but operating on 'SqlBool' instead -sqlNot_ :: forall syntax context s. - IsSql92ExpressionSyntax syntax - => QGenExpr context syntax s SqlBool - -> QGenExpr context syntax s SqlBool +sqlNot_ :: forall be context s + . BeamSqlBackend be + => QGenExpr context be s SqlBool + -> QGenExpr context be s SqlBool sqlNot_ (QExpr a) = QExpr (fmap notE a) -- | SQL @/@ operator -div_ :: (Integral a, IsSql92ExpressionSyntax syntax) - => QGenExpr context syntax s a -> QGenExpr context syntax s a - -> QGenExpr context syntax s a +div_ :: (Integral a, BeamSqlBackend be) + => QGenExpr context be s a -> QGenExpr context be s a + -> QGenExpr context be s a div_ = qBinOpE divE infixl 7 `div_`, `mod_` -- | SQL @%@ operator -mod_ :: (Integral a, IsSql92ExpressionSyntax syntax) - => QGenExpr context syntax s a -> QGenExpr context syntax s a - -> QGenExpr context syntax s a +mod_ :: (Integral a, BeamSqlBackend be) + => QGenExpr context be s a -> QGenExpr context be s a + -> QGenExpr context be s a mod_ = qBinOpE modE -- | SQL @CONCAT@ function -concat_ :: IsSql99ConcatExpressionSyntax syntax - => [ QGenExpr context syntax s T.Text ] -> QGenExpr context syntax s T.Text +concat_ :: BeamSql99ConcatExpressionBackend be + => [ QGenExpr context be s T.Text ] -> QGenExpr context be s T.Text concat_ es = QExpr (concatE <$> mapM (\(QExpr e) -> e) es) diff --git a/Database/Beam/Query/Ord.hs b/Database/Beam/Query/Ord.hs --- a/Database/Beam/Query/Ord.hs +++ b/Database/Beam/Query/Ord.hs @@ -32,6 +32,7 @@ , isUnknown_, isNotUnknown_ , unknownAs_, sqlBool_ , possiblyNullBool_ + , fromPossiblyNullBool_ , anyOf_, anyIn_ , allOf_, allIn_ @@ -46,8 +47,8 @@ import Database.Beam.Schema.Tables import Database.Beam.Backend.SQL -import Database.Beam.Backend.SQL.AST (Expression) -import Database.Beam.Backend.SQL.Builder (SqlSyntaxBuilder) +-- import Database.Beam.Backend.SQL.AST (Expression) +--import Database.Beam.Backend.SQL.Builder (SqlSyntaxBackend) import Control.Applicative import Control.Monad.State @@ -64,47 +65,47 @@ import GHC.TypeLits -- | A data structure representing the set to quantify a comparison operator over. -data QQuantified expr s r - = QQuantified (Sql92ExpressionQuantifierSyntax expr) (WithExprContext expr) +data QQuantified be s r + = QQuantified (BeamSqlBackendExpressionQuantifierSyntax be) (WithExprContext (BeamSqlBackendExpressionSyntax be)) -- | Convert a /known not null/ bool to a 'SqlBool'. See 'unknownAs_' for the inverse sqlBool_ :: QGenExpr context syntax s Bool -> QGenExpr context syntax s SqlBool sqlBool_ (QExpr s) = QExpr s -- | SQL @IS TRUE@ operator -isTrue_ :: IsSql92ExpressionSyntax syntax - => QGenExpr context syntax s SqlBool -> QGenExpr context syntax s Bool +isTrue_ :: BeamSqlBackend be + => QGenExpr context be s SqlBool -> QGenExpr context be s Bool isTrue_ (QExpr s) = QExpr (fmap isTrueE s) -- | SQL @IS NOT TRUE@ operator -isNotTrue_ :: IsSql92ExpressionSyntax syntax - => QGenExpr context syntax s SqlBool -> QGenExpr context syntax s Bool +isNotTrue_ :: BeamSqlBackend be + => QGenExpr context be s SqlBool -> QGenExpr context be s Bool isNotTrue_ (QExpr s) = QExpr (fmap isNotTrueE s) -- | SQL @IS FALSE@ operator -isFalse_ :: IsSql92ExpressionSyntax syntax - => QGenExpr context syntax s SqlBool -> QGenExpr context syntax s Bool +isFalse_ :: BeamSqlBackend be + => QGenExpr context be s SqlBool -> QGenExpr context be s Bool isFalse_ (QExpr s) = QExpr (fmap isFalseE s) -- | SQL @IS NOT FALSE@ operator -isNotFalse_ :: IsSql92ExpressionSyntax syntax - => QGenExpr context syntax s SqlBool -> QGenExpr context syntax s Bool +isNotFalse_ :: BeamSqlBackend be + => QGenExpr context be s SqlBool -> QGenExpr context be s Bool isNotFalse_ (QExpr s) = QExpr (fmap isNotFalseE s) -- | SQL @IS UNKNOWN@ operator -isUnknown_ :: IsSql92ExpressionSyntax syntax - => QGenExpr context syntax s SqlBool -> QGenExpr context syntax s Bool +isUnknown_ :: BeamSqlBackend be + => QGenExpr context be s SqlBool -> QGenExpr context be s Bool isUnknown_ (QExpr s) = QExpr (fmap isUnknownE s) -- | SQL @IS NOT UNKNOWN@ operator -isNotUnknown_ :: IsSql92ExpressionSyntax syntax - => QGenExpr context syntax s SqlBool -> QGenExpr context syntax s Bool +isNotUnknown_ :: BeamSqlBackend be + => QGenExpr context be s SqlBool -> QGenExpr context be s Bool isNotUnknown_ (QExpr s) = QExpr (fmap isNotUnknownE s) -- | Return the first argument if the expression has the unknown SQL value -- See 'sqlBool_' for the inverse -unknownAs_ :: IsSql92ExpressionSyntax syntax - => Bool -> QGenExpr context syntax s SqlBool -> QGenExpr context syntax s Bool +unknownAs_ :: BeamSqlBackend be + => Bool -> QGenExpr context be s SqlBool -> QGenExpr context be s Bool unknownAs_ False = isTrue_ -- If unknown is being treated as false, then return true only if the expression is true unknownAs_ True = isNotFalse_ -- If unknown is being treated as true, then return true only if the expression is not false @@ -112,21 +113,22 @@ -- is useful if you want to get the value of a SQL boolean expression -- directly, without having to specify what to do on @UNKNOWN@. Note -- that both @NULL@ and @UNKNOWN@ will be returned as 'Nothing'. -possiblyNullBool_ :: QGenExpr context syntax s SqlBool -> QGenExpr context syntax s (Maybe Bool) +possiblyNullBool_ :: QGenExpr context be s SqlBool -> QGenExpr context be s (Maybe Bool) possiblyNullBool_ (QExpr e) = QExpr e +-- | Convert a possibly @NULL@ 'Bool' to a 'SqlBool'. +fromPossiblyNullBool_ :: QGenExpr context be s (Maybe Bool) -> QGenExpr context be s SqlBool +fromPossiblyNullBool_ (QExpr e) = QExpr e + -- | A 'QQuantified' representing a SQL @ALL(..)@ for use with a -- <#quantified-comparison-operator quantified comparison operator> -- -- Accepts a subquery. Use 'allIn_' for an explicit list allOf_ - :: forall s a select expr db. - ( IsSql92SelectSyntax select - , IsSql92ExpressionSyntax expr - , HasQBuilder select - , Sql92ExpressionSelectSyntax expr ~ select ) - => Q select db (QNested s) (QExpr (Sql92SelectExpressionSyntax select) (QNested s) a) - -> QQuantified expr s a + :: forall s a be db + . ( BeamSqlBackend be, HasQBuilder be ) + => Q be db (QNested s) (QExpr be (QNested s) a) + -> QQuantified be s a allOf_ s = QQuantified quantifyOverAll (\tblPfx -> subqueryE (buildSqlQuery tblPfx s)) -- | A 'QQuantified' representing a SQL @ALL(..)@ for use with a @@ -135,10 +137,10 @@ -- Accepts an explicit list of typed expressions. Use 'allOf_' for -- a subquery allIn_ - :: forall s a expr - . ( IsSql92ExpressionSyntax expr ) - => [QExpr expr s a] - -> QQuantified expr s a + :: forall s a be + . BeamSqlBackend be + => [QExpr be s a] + -> QQuantified be s a allIn_ es = QQuantified quantifyOverAll (quantifierListE <$> mapM (\(QExpr e) -> e) es) -- | A 'QQuantified' representing a SQL @ANY(..)@ for use with a @@ -146,13 +148,10 @@ -- -- Accepts a subquery. Use 'anyIn_' for an explicit list anyOf_ - :: forall s a select expr db. - ( IsSql92SelectSyntax select - , IsSql92ExpressionSyntax expr - , HasQBuilder select - , Sql92ExpressionSelectSyntax expr ~ select ) - => Q select db (QNested s) (QExpr (Sql92SelectExpressionSyntax select) (QNested s) a) - -> QQuantified expr s a + :: forall s a be db + . ( BeamSqlBackend be, HasQBuilder be ) + => Q be db (QNested s) (QExpr be (QNested s) a) + -> QQuantified be s a anyOf_ s = QQuantified quantifyOverAny (\tblPfx -> subqueryE (buildSqlQuery tblPfx s)) -- | A 'QQuantified' representing a SQL @ANY(..)@ for use with a @@ -161,25 +160,24 @@ -- Accepts an explicit list of typed expressions. Use 'anyOf_' for -- a subquery anyIn_ - :: forall s a expr - . ( IsSql92ExpressionSyntax expr ) - => [QExpr expr s a] - -> QQuantified expr s a + :: forall s a be + . BeamSqlBackend be + => [QExpr be s a] + -> QQuantified be s a anyIn_ es = QQuantified quantifyOverAny (quantifierListE <$> mapM (\(QExpr e) -> e) es) -- | SQL @BETWEEN@ clause -between_ :: IsSql92ExpressionSyntax syntax - => QGenExpr context syntax s a -> QGenExpr context syntax s a - -> QGenExpr context syntax s a -> QGenExpr context syntax s Bool +between_ :: BeamSqlBackend be + => QGenExpr context be s a -> QGenExpr context be s a + -> QGenExpr context be s a -> QGenExpr context be s Bool between_ (QExpr a) (QExpr min_) (QExpr max_) = QExpr (liftA3 betweenE a min_ max_) -- | SQL @IN@ predicate -in_ :: ( IsSql92ExpressionSyntax syntax - , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) Bool ) - => QGenExpr context syntax s a - -> [ QGenExpr context syntax s a ] - -> QGenExpr context syntax s Bool +in_ :: BeamSqlBackend be + => QGenExpr context be s a + -> [ QGenExpr context be s a ] + -> QGenExpr context be s Bool in_ _ [] = QExpr (pure (valueE (sqlValueSyntax False))) in_ (QExpr row) options = QExpr (inE <$> row <*> mapM (\(QExpr o) -> o) options) @@ -213,18 +211,23 @@ infix 4 <., >., <=., >=. infix 4 <*., >*., <=*., >=*. --- | Class for Haskell types that can be compared for equality in the given expression syntax -class (IsSql92ExpressionSyntax syntax, HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) Bool) => - HasSqlEqualityCheck syntax a where +-- | Class for Haskell types that can be compared for equality in the given backend +class BeamSqlBackend be => HasSqlEqualityCheck be a where - sqlEqE, sqlNeqE :: Proxy a -> syntax -> syntax -> syntax - sqlEqE _ = eqE Nothing - sqlNeqE _ = neqE Nothing + sqlEqE, sqlNeqE :: Proxy a -> Proxy be + -> BeamSqlBackendExpressionSyntax be + -> BeamSqlBackendExpressionSyntax be + -> BeamSqlBackendExpressionSyntax be + sqlEqE _ _ = eqE Nothing + sqlNeqE _ _ = neqE Nothing -- | Tri-state equality - sqlEqTriE, sqlNeqTriE :: Proxy a -> syntax -> syntax -> syntax - sqlEqTriE _ = eqE Nothing - sqlNeqTriE _ = neqE Nothing + sqlEqTriE, sqlNeqTriE :: Proxy a -> Proxy be + -> BeamSqlBackendExpressionSyntax be + -> BeamSqlBackendExpressionSyntax be + -> BeamSqlBackendExpressionSyntax be + sqlEqTriE _ _ = eqE Nothing + sqlNeqTriE _ _ = neqE Nothing type family CanCheckMaybeEquality a :: Constraint where CanCheckMaybeEquality (Maybe a) = @@ -232,23 +235,26 @@ 'Text "Beam can only reasonably check equality of a single nesting of Maybe.") CanCheckMaybeEquality a = () -instance (HasSqlEqualityCheck syntax a, CanCheckMaybeEquality a) => HasSqlEqualityCheck syntax (Maybe a) where - sqlEqE _ a b = eqMaybeE a b (sqlEqE (Proxy @a) a b) - sqlNeqE _ a b = neqMaybeE a b (sqlNeqE (Proxy @a) a b) +instance (HasSqlEqualityCheck be a, CanCheckMaybeEquality a) => HasSqlEqualityCheck be (Maybe a) where + sqlEqE _ _ a b = eqMaybeE a b (sqlEqE (Proxy @a) (Proxy @be) a b) + sqlNeqE _ _ a b = neqMaybeE a b (sqlNeqE (Proxy @a) (Proxy @be) a b) -instance HasSqlEqualityCheck syntax a => HasSqlEqualityCheck syntax (SqlSerial a) where +instance HasSqlEqualityCheck be a => HasSqlEqualityCheck be (SqlSerial a) where sqlEqE _ = sqlEqE (Proxy @a) sqlNeqE _ = sqlNeqE (Proxy @a) sqlEqTriE _ = sqlEqTriE (Proxy @a) sqlNeqTriE _ = sqlNeqTriE (Proxy @a) --- | Class for Haskell types that can be compared for quantified equality in the given expression syntax -class HasSqlEqualityCheck syntax a => HasSqlQuantifiedEqualityCheck syntax a where - sqlQEqE, sqlQNeqE :: Proxy a -> Maybe (Sql92ExpressionQuantifierSyntax syntax) - -> syntax -> syntax -> syntax - sqlQEqE _ = eqE - sqlQNeqE _ = neqE +-- | Class for Haskell types that can be compared for quantified equality in the given backend +class HasSqlEqualityCheck be a => HasSqlQuantifiedEqualityCheck be a where + sqlQEqE, sqlQNeqE :: Proxy a -> Proxy be + -> Maybe (BeamSqlBackendExpressionQuantifierSyntax be) + -> BeamSqlBackendExpressionSyntax be + -> BeamSqlBackendExpressionSyntax be + -> BeamSqlBackendExpressionSyntax be + sqlQEqE _ _ = eqE + sqlQNeqE _ _ = neqE instance (HasSqlQuantifiedEqualityCheck syntax a, CanCheckMaybeEquality a) => HasSqlQuantifiedEqualityCheck syntax (Maybe a) where sqlQEqE _ = sqlQEqE (Proxy @a) @@ -259,33 +265,32 @@ sqlQNeqE _ = sqlQNeqE (Proxy @a) -- | Compare two arbitrary expressions (of the same type) for equality -instance ( IsSql92ExpressionSyntax syntax, HasSqlEqualityCheck syntax a ) => - SqlEq (QGenExpr context syntax s) (QGenExpr context syntax s a) where +instance ( BeamSqlBackend be, HasSqlEqualityCheck be a ) => + SqlEq (QGenExpr context be s) (QGenExpr context be s a) where - (==.) = qBinOpE (sqlEqE (Proxy @a)) - (/=.) = qBinOpE (sqlNeqE (Proxy @a)) + (==.) = qBinOpE (sqlEqE (Proxy @a) (Proxy @be)) + (/=.) = qBinOpE (sqlNeqE (Proxy @a) (Proxy @be)) - (==?.) = qBinOpE (sqlEqTriE (Proxy @a)) - (/=?.) = qBinOpE (sqlNeqTriE (Proxy @a)) + (==?.) = qBinOpE (sqlEqTriE (Proxy @a) (Proxy @be)) + (/=?.) = qBinOpE (sqlNeqTriE (Proxy @a) (Proxy @be)) -- | Two arbitrary expressions can be quantifiably compared for equality. -instance ( IsSql92ExpressionSyntax syntax, HasSqlQuantifiedEqualityCheck syntax a ) => - SqlEqQuantified (QGenExpr context syntax s) (QQuantified syntax s a) (QGenExpr context syntax s a) where +instance ( BeamSqlBackend be, HasSqlQuantifiedEqualityCheck be a ) => + SqlEqQuantified (QGenExpr context be s) (QQuantified be s a) (QGenExpr context be s a) where - a ==*. QQuantified q b = qBinOpE (sqlQEqE (Proxy @a) (Just q)) a (QExpr b) - a /=*. QQuantified q b = qBinOpE (sqlQNeqE (Proxy @a) (Just q)) a (QExpr b) + a ==*. QQuantified q b = qBinOpE (sqlQEqE (Proxy @a) (Proxy @be) (Just q)) a (QExpr b) + a /=*. QQuantified q b = qBinOpE (sqlQNeqE (Proxy @a) (Proxy @be) (Just q)) a (QExpr b) -- | Constraint synonym to check if two tables can be compared for equality -type HasTableEquality expr tbl = - (FieldsFulfillConstraint (HasSqlEqualityCheck expr) tbl, Beamable tbl) -type HasTableEqualityNullable expr tbl = - (FieldsFulfillConstraintNullable (HasSqlEqualityCheck expr) tbl, Beamable tbl) +type HasTableEquality be tbl = + (FieldsFulfillConstraint (HasSqlEqualityCheck be) tbl, Beamable tbl) +type HasTableEqualityNullable be tbl = + (FieldsFulfillConstraintNullable (HasSqlEqualityCheck be) tbl, Beamable tbl) -- | Compare two arbitrary 'Beamable' types containing 'QGenExpr's for equality. -instance ( IsSql92ExpressionSyntax syntax, FieldsFulfillConstraint (HasSqlEqualityCheck syntax) tbl - , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) Bool - , Beamable tbl ) => - SqlEq (QGenExpr context syntax s) (tbl (QGenExpr context syntax s)) where +instance ( BeamSqlBackend be, Beamable tbl + , FieldsFulfillConstraint (HasSqlEqualityCheck be) tbl ) => + SqlEq (QGenExpr context be s) (tbl (QGenExpr context be s)) where a ==. b = let (_, e) = runState (zipBeamFieldsM (\x'@(Columnar' (Columnar' (WithConstraint _) :*: Columnar' x)) (Columnar' y) -> @@ -293,7 +298,7 @@ case expr of Nothing -> Just $ x ==. y Just expr' -> Just $ expr' &&. x ==. y) - return x') (withConstraints @(HasSqlEqualityCheck syntax) `alongsideTable` a) b) Nothing + return x') (withConstraints @(HasSqlEqualityCheck be) `alongsideTable` a) b) Nothing in fromMaybe (QExpr (\_ -> valueE (sqlValueSyntax True))) e a /=. b = not_ (a ==. b) @@ -303,15 +308,13 @@ case expr of Nothing -> Just $ x ==?. y Just expr' -> Just $ expr' &&?. x ==?. y) - return x') (withConstraints @(HasSqlEqualityCheck syntax) `alongsideTable` a) b) Nothing + return x') (withConstraints @(HasSqlEqualityCheck be) `alongsideTable` a) b) Nothing in fromMaybe (QExpr (\_ -> valueE (sqlValueSyntax True))) e a /=?. b = sqlNot_ (a ==?. b) -instance ( IsSql92ExpressionSyntax syntax - , FieldsFulfillConstraintNullable (HasSqlEqualityCheck syntax) tbl - , HasSqlValueSyntax (Sql92ExpressionValueSyntax syntax) Bool - , Beamable tbl) - => SqlEq (QGenExpr context syntax s) (tbl (Nullable (QGenExpr context syntax s))) where +instance ( BeamSqlBackend be, Beamable tbl + , FieldsFulfillConstraintNullable (HasSqlEqualityCheck be) tbl ) + => SqlEq (QGenExpr context be s) (tbl (Nullable (QGenExpr context be s))) where a ==. b = let (_, e) = runState (zipBeamFieldsM (\x'@(Columnar' (Columnar' (WithConstraint _) :*: Columnar' x)) (Columnar' y) -> do @@ -320,7 +323,7 @@ Nothing -> Just $ x ==. y Just expr' -> Just $ expr' &&. x ==. y) return x') - (withNullableConstraints @(HasSqlEqualityCheck syntax) `alongsideTable` a) b) Nothing + (withNullableConstraints @(HasSqlEqualityCheck be) `alongsideTable` a) b) Nothing in fromMaybe (QExpr (\_ -> valueE (sqlValueSyntax True))) e a /=. b = not_ (a ==. b) @@ -330,7 +333,7 @@ case expr of Nothing -> Just $ x ==?. y Just expr' -> Just $ expr' &&?. x ==?. y) - return x') (withNullableConstraints @(HasSqlEqualityCheck syntax) `alongsideTable` a) b) Nothing + return x') (withNullableConstraints @(HasSqlEqualityCheck be) `alongsideTable` a) b) Nothing in fromMaybe (QExpr (\_ -> valueE (sqlValueSyntax True))) e a /=?. b = sqlNot_ (a ==?. b) @@ -353,105 +356,64 @@ (<*.), (>*.), (<=*.), (>=*.) :: e -> quantified -> expr Bool -instance IsSql92ExpressionSyntax syntax => - SqlOrd (QGenExpr context syntax s) (QGenExpr context syntax s a) where +instance BeamSqlBackend be => + SqlOrd (QGenExpr context be s) (QGenExpr context be s a) where (<.) = qBinOpE (ltE Nothing) (>.) = qBinOpE (gtE Nothing) (<=.) = qBinOpE (leE Nothing) (>=.) = qBinOpE (geE Nothing) -instance IsSql92ExpressionSyntax syntax => - SqlOrdQuantified (QGenExpr context syntax s) (QQuantified syntax s a) (QGenExpr context syntax s a) where +instance BeamSqlBackend be => + SqlOrdQuantified (QGenExpr context be s) (QQuantified be s a) (QGenExpr context be s a) where a <*. QQuantified q b = qBinOpE (ltE (Just q)) a (QExpr b) a <=*. QQuantified q b = qBinOpE (leE (Just q)) a (QExpr b) a >*. QQuantified q b = qBinOpE (gtE (Just q)) a (QExpr b) a >=*. QQuantified q b = qBinOpE (geE (Just q)) a (QExpr b) -instance HasSqlEqualityCheck Expression Text -instance HasSqlEqualityCheck Expression Integer -instance HasSqlEqualityCheck Expression Int -instance HasSqlEqualityCheck Expression Int8 -instance HasSqlEqualityCheck Expression Int16 -instance HasSqlEqualityCheck Expression Int32 -instance HasSqlEqualityCheck Expression Int64 -instance HasSqlEqualityCheck Expression Word -instance HasSqlEqualityCheck Expression Word8 -instance HasSqlEqualityCheck Expression Word16 -instance HasSqlEqualityCheck Expression Word32 -instance HasSqlEqualityCheck Expression Word64 -instance HasSqlEqualityCheck Expression Double -instance HasSqlEqualityCheck Expression Float -instance HasSqlEqualityCheck Expression Bool -instance HasSqlEqualityCheck Expression UTCTime -instance HasSqlEqualityCheck Expression LocalTime -instance HasSqlEqualityCheck Expression Day -instance HasSqlEqualityCheck Expression TimeOfDay -instance HasSqlEqualityCheck Expression a => - HasSqlEqualityCheck Expression (Tagged t a) - -instance HasSqlQuantifiedEqualityCheck Expression Text -instance HasSqlQuantifiedEqualityCheck Expression Integer -instance HasSqlQuantifiedEqualityCheck Expression Int -instance HasSqlQuantifiedEqualityCheck Expression Int8 -instance HasSqlQuantifiedEqualityCheck Expression Int16 -instance HasSqlQuantifiedEqualityCheck Expression Int32 -instance HasSqlQuantifiedEqualityCheck Expression Int64 -instance HasSqlQuantifiedEqualityCheck Expression Word -instance HasSqlQuantifiedEqualityCheck Expression Word8 -instance HasSqlQuantifiedEqualityCheck Expression Word16 -instance HasSqlQuantifiedEqualityCheck Expression Word32 -instance HasSqlQuantifiedEqualityCheck Expression Word64 -instance HasSqlQuantifiedEqualityCheck Expression Double -instance HasSqlQuantifiedEqualityCheck Expression Float -instance HasSqlQuantifiedEqualityCheck Expression Bool -instance HasSqlQuantifiedEqualityCheck Expression UTCTime -instance HasSqlQuantifiedEqualityCheck Expression LocalTime -instance HasSqlQuantifiedEqualityCheck Expression Day -instance HasSqlQuantifiedEqualityCheck Expression TimeOfDay -instance HasSqlQuantifiedEqualityCheck Expression a => - HasSqlQuantifiedEqualityCheck Expression (Tagged t a) +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) Text +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) Integer +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) Int +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) Int8 +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) Int16 +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) Int32 +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) Int64 +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) Word +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) Word8 +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) Word16 +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) Word32 +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) Word64 +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) Double +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) Float +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) Bool +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) UTCTime +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) LocalTime +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) Day +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlEqualityCheck (MockSqlBackend cmd) TimeOfDay +instance ( BeamSqlBackend (MockSqlBackend cmd) + , HasSqlEqualityCheck (MockSqlBackend cmd) a + ) => HasSqlEqualityCheck (MockSqlBackend cmd) (Tagged t a) -instance HasSqlEqualityCheck SqlSyntaxBuilder Text -instance HasSqlEqualityCheck SqlSyntaxBuilder Integer -instance HasSqlEqualityCheck SqlSyntaxBuilder Int -instance HasSqlEqualityCheck SqlSyntaxBuilder Int8 -instance HasSqlEqualityCheck SqlSyntaxBuilder Int16 -instance HasSqlEqualityCheck SqlSyntaxBuilder Int32 -instance HasSqlEqualityCheck SqlSyntaxBuilder Int64 -instance HasSqlEqualityCheck SqlSyntaxBuilder Word -instance HasSqlEqualityCheck SqlSyntaxBuilder Word8 -instance HasSqlEqualityCheck SqlSyntaxBuilder Word16 -instance HasSqlEqualityCheck SqlSyntaxBuilder Word32 -instance HasSqlEqualityCheck SqlSyntaxBuilder Word64 -instance HasSqlEqualityCheck SqlSyntaxBuilder Double -instance HasSqlEqualityCheck SqlSyntaxBuilder Float -instance HasSqlEqualityCheck SqlSyntaxBuilder Bool -instance HasSqlEqualityCheck SqlSyntaxBuilder UTCTime -instance HasSqlEqualityCheck SqlSyntaxBuilder LocalTime -instance HasSqlEqualityCheck SqlSyntaxBuilder Day -instance HasSqlEqualityCheck SqlSyntaxBuilder TimeOfDay -instance HasSqlEqualityCheck SqlSyntaxBuilder a => - HasSqlEqualityCheck SqlSyntaxBuilder (Tagged t a) +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) Text +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) Integer +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) Int +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) Int8 +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) Int16 +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) Int32 +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) Int64 +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) Word +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) Word8 +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) Word16 +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) Word32 +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) Word64 +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) Double +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) Float +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) Bool +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) UTCTime +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) LocalTime +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) Day +instance BeamSqlBackend (MockSqlBackend cmd) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) TimeOfDay +instance ( BeamSqlBackend (MockSqlBackend cmd) + , HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) a + ) => HasSqlQuantifiedEqualityCheck (MockSqlBackend cmd) (Tagged t a) -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder Text -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder Integer -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder Int -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder Int8 -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder Int16 -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder Int32 -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder Int64 -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder Word -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder Word8 -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder Word16 -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder Word32 -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder Word64 -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder Double -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder Float -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder Bool -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder UTCTime -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder LocalTime -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder Day -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder TimeOfDay -instance HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder a => - HasSqlQuantifiedEqualityCheck SqlSyntaxBuilder (Tagged t a) diff --git a/Database/Beam/Query/Relationships.hs b/Database/Beam/Query/Relationships.hs --- a/Database/Beam/Query/Relationships.hs +++ b/Database/Beam/Query/Relationships.hs @@ -29,49 +29,41 @@ -- | Synonym of 'OneToMany'. Useful for giving more meaningful types, when the -- relationship is meant to be one-to-one. -type OneToOne db s one many = OneToMany db s one many +type OneToOne be db s one many = OneToMany be db s one many -- | Convenience type to declare one-to-many relationships. See the manual -- section on -- -- for more information -type OneToMany db s one many = - forall syntax. - ( IsSql92SelectSyntax syntax, HasTableEquality (Sql92SelectExpressionSyntax syntax) (PrimaryKey one) - , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectExpressionSyntax syntax)) Bool ) => - one (QExpr (Sql92SelectExpressionSyntax syntax) s) -> - Q syntax db s (many (QExpr (Sql92SelectExpressionSyntax syntax) s)) +type OneToMany be db s one many = + ( BeamSqlBackend be, BeamSqlBackendCanSerialize be Bool ) => + one (QExpr be s) -> Q be db s (many (QExpr be s)) -- | Synonym of 'OneToManyOptional'. Useful for giving more meaningful types, -- when the relationship is meant to be one-to-one. -type OneToMaybe db s tbl rel = OneToManyOptional db s tbl rel +type OneToMaybe be db s tbl rel = OneToManyOptional be db s tbl rel -- | Convenience type to declare one-to-many relationships with a nullable -- foreign key. See the manual section on -- -- for more information -type OneToManyOptional db s tbl rel = - forall syntax. - ( IsSql92SelectSyntax syntax, HasTableEqualityNullable (Sql92SelectExpressionSyntax syntax) (PrimaryKey tbl) - , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectExpressionSyntax syntax)) Bool - , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectExpressionSyntax syntax)) SqlNull ) => - tbl (QExpr (Sql92SelectExpressionSyntax syntax) s) -> - Q syntax db s (rel (Nullable (QExpr (Sql92SelectExpressionSyntax syntax) s))) +type OneToManyOptional be db s tbl rel = + ( BeamSqlBackend be, BeamSqlBackendCanSerialize be Bool + , BeamSqlBackendCanSerialize be SqlNull ) => + tbl (QExpr be s) -> Q be db s (rel (Nullable (QExpr be s))) -- | Used to define one-to-many (or one-to-one) relationships. Takes the table -- to fetch, a way to extract the foreign key from that table, and the table to -- relate to. oneToMany_, oneToOne_ - :: ( IsSql92SelectSyntax syntax - , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectExpressionSyntax syntax)) Bool - , Database be db - , HasTableEquality (Sql92SelectExpressionSyntax syntax) (PrimaryKey tbl) + :: ( Database be db, BeamSqlBackend be + , HasTableEquality be (PrimaryKey tbl) , Table tbl, Table rel ) => DatabaseEntity be db (TableEntity rel) {-^ Table to fetch (many) -} - -> (rel (QExpr (Sql92SelectExpressionSyntax syntax) s) -> PrimaryKey tbl (QExpr (Sql92SelectExpressionSyntax syntax) s)) + -> (rel (QExpr be s) -> PrimaryKey tbl (QExpr be s)) {-^ Foreign key -} - -> tbl (QExpr (Sql92SelectExpressionSyntax syntax) s) - -> Q syntax db s (rel (QExpr (Sql92SelectExpressionSyntax syntax) s)) + -> tbl (QExpr be s) + -> Q be db s (rel (QExpr be s)) oneToMany_ rel getKey tbl = join_ rel (\rel' -> getKey rel' ==. pk tbl) oneToOne_ = oneToMany_ @@ -80,17 +72,14 @@ -- foreign key. Takes the table to fetch, a way to extract the foreign key -- from that table, and the table to relate to. oneToManyOptional_, oneToMaybe_ - :: ( IsSql92SelectSyntax syntax - , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectExpressionSyntax syntax)) Bool - , HasSqlValueSyntax (Sql92ExpressionValueSyntax (Sql92SelectExpressionSyntax syntax)) SqlNull - , HasTableEqualityNullable (Sql92SelectExpressionSyntax syntax) (PrimaryKey tbl) - , Database be db - , Table tbl, Table rel ) + :: ( BeamSqlBackend be, Database be db + , Table tbl, Table rel + , HasTableEqualityNullable be (PrimaryKey tbl) ) => DatabaseEntity be db (TableEntity rel) {-^ Table to fetch -} - -> (rel (QExpr (Sql92SelectExpressionSyntax syntax) s) -> PrimaryKey tbl (Nullable (QExpr (Sql92SelectExpressionSyntax syntax) s))) + -> (rel (QExpr be s) -> PrimaryKey tbl (Nullable (QExpr be s))) {-^ Foreign key -} - -> tbl (QExpr (Sql92SelectExpressionSyntax syntax) s) - -> Q syntax db s (rel (Nullable (QExpr (Sql92SelectExpressionSyntax syntax) s))) + -> tbl (QExpr be s) + -> Q be db s (rel (Nullable (QExpr be s))) oneToManyOptional_ rel getKey tbl = leftJoin_ (all_ rel) (\rel' -> getKey rel' ==. just_ (pk tbl)) oneToMaybe_ = oneToManyOptional_ @@ -101,29 +90,27 @@ -- section on -- -- for more information -type ManyToMany db left right = - forall syntax s. - ( Sql92SelectSanityCheck syntax, IsSql92SelectSyntax syntax +type ManyToMany be db left right = + forall s. + ( BeamSqlBackend be - , SqlEq (QExpr (Sql92SelectExpressionSyntax syntax) s) (PrimaryKey left (QExpr (Sql92SelectExpressionSyntax syntax) s)) - , SqlEq (QExpr (Sql92SelectExpressionSyntax syntax) s) (PrimaryKey right (QExpr (Sql92SelectExpressionSyntax syntax) s)) ) => - Q syntax db s (left (QExpr (Sql92SelectExpressionSyntax syntax) s)) -> Q syntax db s (right (QExpr (Sql92SelectExpressionSyntax syntax) s)) -> - Q syntax db s (left (QExpr (Sql92SelectExpressionSyntax syntax) s), right (QExpr (Sql92SelectExpressionSyntax syntax) s)) + , SqlEq (QExpr be s) (PrimaryKey left (QExpr be s)) + , SqlEq (QExpr be s) (PrimaryKey right (QExpr be s)) ) => + Q be db s (left (QExpr be s)) -> Q be db s (right (QExpr be s)) -> + Q be db s (left (QExpr be s), right (QExpr be s)) -- | Convenience type to declare many-to-many relationships with additional -- data. See the manual section on -- -- for more information -type ManyToManyThrough db through left right = - forall syntax s. - ( Sql92SelectSanityCheck syntax, IsSql92SelectSyntax syntax +type ManyToManyThrough be db through left right = + forall s. + ( BeamSqlBackend be - , SqlEq (QExpr (Sql92SelectExpressionSyntax syntax) s) (PrimaryKey left (QExpr (Sql92SelectExpressionSyntax syntax) s)) - , SqlEq (QExpr (Sql92SelectExpressionSyntax syntax) s) (PrimaryKey right (QExpr (Sql92SelectExpressionSyntax syntax) s)) ) => - Q syntax db s (left (QExpr (Sql92SelectExpressionSyntax syntax) s)) -> Q syntax db s (right (QExpr (Sql92SelectExpressionSyntax syntax) s)) -> - Q syntax db s ( through (QExpr (Sql92SelectExpressionSyntax syntax) s) - , left (QExpr (Sql92SelectExpressionSyntax syntax) s) - , right (QExpr (Sql92SelectExpressionSyntax syntax) s)) + , SqlEq (QExpr be s) (PrimaryKey left (QExpr be s)) + , SqlEq (QExpr be s) (PrimaryKey right (QExpr be s)) ) => + Q be db s (left (QExpr be s)) -> Q be db s (right (QExpr be s)) -> + Q be db s ( through (QExpr be s), left (QExpr be s), right (QExpr be s) ) -- | Used to define many-to-many relationships without any additional data. -- Takes the join table and two key extraction functions from that table to the @@ -132,18 +119,17 @@ -- See -- for more indformation. manyToMany_ - :: ( Database be db, Table joinThrough - , Table left, Table right - , Sql92SelectSanityCheck syntax - , IsSql92SelectSyntax syntax + :: ( Database be db + , Table joinThrough, Table left, Table right + , BeamSqlBackend be - , SqlEq (QExpr (Sql92SelectExpressionSyntax syntax) s) (PrimaryKey left (QExpr (Sql92SelectExpressionSyntax syntax) s)) - , SqlEq (QExpr (Sql92SelectExpressionSyntax syntax) s) (PrimaryKey right (QExpr (Sql92SelectExpressionSyntax syntax) s)) ) + , SqlEq (QExpr be s) (PrimaryKey left (QExpr be s)) + , SqlEq (QExpr be s) (PrimaryKey right (QExpr be s)) ) => DatabaseEntity be db (TableEntity joinThrough) - -> (joinThrough (QExpr (Sql92SelectExpressionSyntax syntax) s) -> PrimaryKey left (QExpr (Sql92SelectExpressionSyntax syntax) s)) - -> (joinThrough (QExpr (Sql92SelectExpressionSyntax syntax) s) -> PrimaryKey right (QExpr (Sql92SelectExpressionSyntax syntax) s)) - -> Q syntax db s (left (QExpr (Sql92SelectExpressionSyntax syntax) s)) -> Q syntax db s (right (QExpr (Sql92SelectExpressionSyntax syntax) s)) - -> Q syntax db s (left (QExpr (Sql92SelectExpressionSyntax syntax) s), right (QExpr (Sql92SelectExpressionSyntax syntax) s)) + -> (joinThrough (QExpr be s) -> PrimaryKey left (QExpr be s)) + -> (joinThrough (QExpr be s) -> PrimaryKey right (QExpr be s)) + -> Q be db s (left (QExpr be s)) -> Q be db s (right (QExpr be s)) + -> Q be db s (left (QExpr be s), right (QExpr be s)) manyToMany_ joinTbl leftKey rightKey left right = fmap (\(_, l, r) -> (l, r)) $ manyToManyPassthrough_ joinTbl leftKey rightKey left right @@ -154,21 +140,21 @@ -- See -- for more indformation. manyToManyPassthrough_ - :: ( Database be db, Table joinThrough - , Table left, Table right - , Sql92SelectSanityCheck syntax - , IsSql92SelectSyntax syntax + :: ( Database be db + , Table joinThrough, Table left, Table right - , SqlEq (QExpr (Sql92SelectExpressionSyntax syntax) s) (PrimaryKey left (QExpr (Sql92SelectExpressionSyntax syntax) s)) - , SqlEq (QExpr (Sql92SelectExpressionSyntax syntax) s) (PrimaryKey right (QExpr (Sql92SelectExpressionSyntax syntax) s)) ) + , BeamSqlBackend be + + , SqlEq (QExpr be s) (PrimaryKey left (QExpr be s)) + , SqlEq (QExpr be s) (PrimaryKey right (QExpr be s)) ) => DatabaseEntity be db (TableEntity joinThrough) - -> (joinThrough (QExpr (Sql92SelectExpressionSyntax syntax) s) -> PrimaryKey left (QExpr (Sql92SelectExpressionSyntax syntax) s)) - -> (joinThrough (QExpr (Sql92SelectExpressionSyntax syntax) s) -> PrimaryKey right (QExpr (Sql92SelectExpressionSyntax syntax) s)) - -> Q syntax db s (left (QExpr (Sql92SelectExpressionSyntax syntax) s)) - -> Q syntax db s (right (QExpr (Sql92SelectExpressionSyntax syntax) s)) - -> Q syntax db s ( joinThrough (QExpr (Sql92SelectExpressionSyntax syntax) s) - , left (QExpr (Sql92SelectExpressionSyntax syntax) s) - , right (QExpr (Sql92SelectExpressionSyntax syntax) s)) + -> (joinThrough (QExpr be s) -> PrimaryKey left (QExpr be s)) + -> (joinThrough (QExpr be s) -> PrimaryKey right (QExpr be s)) + -> Q be db s (left (QExpr be s)) + -> Q be db s (right (QExpr be s)) + -> Q be db s ( joinThrough (QExpr be s) + , left (QExpr be s) + , right (QExpr be s)) manyToManyPassthrough_ joinTbl leftKey rightKey left right = do left_ <- left right_ <- right diff --git a/Database/Beam/Query/SQL92.hs b/Database/Beam/Query/SQL92.hs --- a/Database/Beam/Query/SQL92.hs +++ b/Database/Beam/Query/SQL92.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} module Database.Beam.Query.SQL92 @@ -8,15 +9,16 @@ import Database.Beam.Query.Internal import Database.Beam.Backend.SQL -import Database.Beam.Schema.Tables - import Control.Monad.Free.Church import Control.Monad.Free + #if !MIN_VERSION_base(4, 11, 0) -import Control.Monad.Writer +import Control.Monad.Writer hiding ((<>)) +import Data.Semigroup #endif import Data.Maybe +import Data.Proxy (Proxy(Proxy)) import Data.String import qualified Data.Text as T @@ -30,45 +32,48 @@ andE' (Just x) (Just y) = Just (andE x y) newtype PreserveLeft a b = PreserveLeft { unPreserveLeft :: (a, b) } -instance ProjectibleWithPredicate c syntax b => ProjectibleWithPredicate c syntax (PreserveLeft a b) where - project' p f (PreserveLeft (a, b)) = - PreserveLeft . (a,) <$> project' p f b +instance (Monoid a, ProjectibleWithPredicate c syntax res b) => ProjectibleWithPredicate c syntax res (PreserveLeft a b) where + project' context be f (PreserveLeft (a, b)) = + PreserveLeft . (a,) <$> project' context be f b -type SelectStmtFn select - = Sql92SelectSelectTableSyntax select - -> [Sql92SelectOrderingSyntax select] + projectSkeleton' ctxt be mkM = + PreserveLeft . (mempty,) <$> projectSkeleton' ctxt be mkM + +type SelectStmtFn be + = BeamSqlBackendSelectTableSyntax be + -> [BeamSqlBackendOrderingSyntax be] -> Maybe Integer {-^ LIMIT -} -> Maybe Integer {-^ OFFSET -} - -> select + -> BeamSqlBackendSelectSyntax be -data QueryBuilder select +data QueryBuilder be = QueryBuilder { qbNextTblRef :: Int - , qbFrom :: Maybe (Sql92SelectTableFromSyntax (Sql92SelectSelectTableSyntax select)) - , qbWhere :: Maybe (Sql92SelectExpressionSyntax select) } + , qbFrom :: Maybe (BeamSqlBackendFromSyntax be) + , qbWhere :: Maybe (BeamSqlBackendExpressionSyntax be) } -data SelectBuilder syntax (db :: (* -> *) -> *) a where - SelectBuilderQ :: ( IsSql92SelectSyntax syntax - , Projectible (Sql92ProjectionExpressionSyntax (Sql92SelectTableProjectionSyntax (Sql92SelectSelectTableSyntax syntax))) a ) => - a -> QueryBuilder syntax -> SelectBuilder syntax db a +data SelectBuilder be (db :: (* -> *) -> *) a where + SelectBuilderQ :: ( BeamSqlBackend be + , Projectible be a ) + => a -> QueryBuilder be -> SelectBuilder be db a SelectBuilderGrouping - :: ( IsSql92SelectSyntax syntax - , Projectible (Sql92ProjectionExpressionSyntax (Sql92SelectTableProjectionSyntax (Sql92SelectSelectTableSyntax syntax))) a ) - => a -> QueryBuilder syntax - -> Maybe (Sql92SelectGroupingSyntax syntax) - -> Maybe (Sql92SelectExpressionSyntax syntax) - -> Maybe (Sql92SelectTableSetQuantifierSyntax (Sql92SelectSelectTableSyntax syntax)) - -> SelectBuilder syntax db a + :: ( BeamSqlBackend be + , Projectible be a ) + => a -> QueryBuilder be + -> Maybe (BeamSqlBackendGroupingSyntax be) + -> Maybe (BeamSqlBackendExpressionSyntax be) + -> Maybe (BeamSqlBackendSetQuantifierSyntax be) + -> SelectBuilder be db a SelectBuilderSelectSyntax :: Bool {- Whether or not this contains UNION, INTERSECT, EXCEPT, etc -} - -> a -> Sql92SelectSelectTableSyntax syntax - -> SelectBuilder syntax db a + -> a -> BeamSqlBackendSelectTableSyntax be + -> SelectBuilder be db a SelectBuilderTopLevel :: { sbLimit, sbOffset :: Maybe Integer - , sbOrdering :: [ Sql92SelectOrderingSyntax syntax ] - , sbTable :: SelectBuilder syntax db a - , sbSelectFn :: Maybe (SelectStmtFn syntax) + , sbOrdering :: [ BeamSqlBackendOrderingSyntax be ] + , sbTable :: SelectBuilder be db a + , sbSelectFn :: Maybe (SelectStmtFn be) -- ^ Which 'SelectStmtFn' to use to build this select. If 'Nothing', use the default - } -> SelectBuilder syntax db a + } -> SelectBuilder be db a sbContainsSetOperation :: SelectBuilder syntax db a -> Bool sbContainsSetOperation (SelectBuilderSelectSyntax contains _ _) = contains @@ -83,45 +88,43 @@ nextTblPfx :: TablePrefix -> TablePrefix nextTblPfx = ("sub_" <>) -defaultProjection :: Projectible expr x => - TablePrefix -> x -> [ ( expr, Maybe T.Text ) ] -defaultProjection pfx = +defaultProjection :: Projectible be x + => Proxy be -> TablePrefix -> x -> [ ( BeamSqlBackendExpressionSyntax be , Maybe T.Text ) ] +defaultProjection be pfx = zipWith (\i e -> (e, Just (fromString "res" <> fromString (show (i :: Integer))))) - [0..] . flip project (nextTblPfx pfx) + [0..] . flip (project be) (nextTblPfx pfx) -buildSelect :: ( IsSql92SelectSyntax syntax - , Projectible (Sql92ProjectionExpressionSyntax (Sql92SelectProjectionSyntax syntax)) a ) => - TablePrefix -> SelectBuilder syntax db a -> syntax +buildSelect :: forall be db a + . ( BeamSqlBackend be, Projectible be a ) + => TablePrefix -> SelectBuilder be db a -> BeamSqlBackendSelectSyntax be buildSelect _ (SelectBuilderTopLevel limit offset ordering (SelectBuilderSelectSyntax _ _ table) selectStmt') = (fromMaybe selectStmt selectStmt') table ordering limit offset buildSelect pfx (SelectBuilderTopLevel limit offset ordering (SelectBuilderQ proj (QueryBuilder _ from where_)) selectStmt') = - (fromMaybe selectStmt selectStmt') (selectTableStmt Nothing (projExprs (defaultProjection pfx proj)) from where_ Nothing Nothing) ordering limit offset + (fromMaybe selectStmt selectStmt') (selectTableStmt Nothing (projExprs (defaultProjection (Proxy @be) pfx proj)) from where_ Nothing Nothing) ordering limit offset buildSelect pfx (SelectBuilderTopLevel limit offset ordering (SelectBuilderGrouping proj (QueryBuilder _ from where_) grouping having distinct) selectStmt') = - (fromMaybe selectStmt selectStmt') (selectTableStmt distinct (projExprs (defaultProjection pfx proj)) from where_ grouping having) ordering limit offset + (fromMaybe selectStmt selectStmt') (selectTableStmt distinct (projExprs (defaultProjection (Proxy @be) pfx proj)) from where_ grouping having) ordering limit offset buildSelect pfx x = buildSelect pfx (SelectBuilderTopLevel Nothing Nothing [] x Nothing) -selectBuilderToTableSource :: ( Sql92TableSourceSelectSyntax (Sql92FromTableSourceSyntax (Sql92SelectFromSyntax syntax)) ~ syntax - , IsSql92SelectSyntax syntax - , Projectible (Sql92ProjectionExpressionSyntax (Sql92SelectProjectionSyntax syntax)) a ) => - TablePrefix -> SelectBuilder syntax db a -> Sql92SelectSelectTableSyntax syntax +selectBuilderToTableSource :: forall be db a + . ( BeamSqlBackend be, Projectible be a ) + => TablePrefix -> SelectBuilder be db a -> BeamSqlBackendSelectTableSyntax be selectBuilderToTableSource _ (SelectBuilderSelectSyntax _ _ x) = x selectBuilderToTableSource pfx (SelectBuilderQ x (QueryBuilder _ from where_)) = - selectTableStmt Nothing (projExprs (defaultProjection pfx x)) from where_ Nothing Nothing + selectTableStmt Nothing (projExprs (defaultProjection (Proxy @be) pfx x)) from where_ Nothing Nothing selectBuilderToTableSource pfx (SelectBuilderGrouping x (QueryBuilder _ from where_) grouping having distinct) = - selectTableStmt distinct (projExprs (defaultProjection pfx x)) from where_ grouping having + selectTableStmt distinct (projExprs (defaultProjection (Proxy @be) pfx x)) from where_ grouping having selectBuilderToTableSource pfx sb = let (x, QueryBuilder _ from where_) = selectBuilderToQueryBuilder pfx sb - in selectTableStmt Nothing (projExprs (defaultProjection pfx x)) from where_ Nothing Nothing + in selectTableStmt Nothing (projExprs (defaultProjection (Proxy @be) pfx x)) from where_ Nothing Nothing -selectBuilderToQueryBuilder :: ( Sql92TableSourceSelectSyntax (Sql92FromTableSourceSyntax (Sql92SelectFromSyntax syntax)) ~ syntax - , IsSql92SelectSyntax syntax - , Projectible (Sql92ProjectionExpressionSyntax (Sql92SelectProjectionSyntax syntax)) a ) => - TablePrefix -> SelectBuilder syntax db a -> (a, QueryBuilder syntax) +selectBuilderToQueryBuilder :: forall be db a + . ( BeamSqlBackend be, Projectible be a) + => TablePrefix -> SelectBuilder be db a -> (a, QueryBuilder be) selectBuilderToQueryBuilder pfx sb = let select = buildSelect pfx sb - x' = reproject (fieldNameFunc (qualifiedField t0)) (sbProj sb) + x' = reproject (Proxy @be) (fieldNameFunc (qualifiedField t0)) (sbProj sb) t0 = pfx <> "0" - in (x', QueryBuilder 1 (Just (fromTable (tableFromSubSelect select) (Just t0))) Nothing) + in (x', QueryBuilder 1 (Just (fromTable (tableFromSubSelect select) (Just (t0, Nothing)))) Nothing) emptyQb :: QueryBuilder select emptyQb = QueryBuilder 0 Nothing Nothing @@ -132,8 +135,8 @@ sbProj (SelectBuilderSelectSyntax _ proj _) = proj sbProj (SelectBuilderTopLevel _ _ _ sb _) = sbProj sb -setSelectBuilderProjection :: Projectible (Sql92ProjectionExpressionSyntax (Sql92SelectProjectionSyntax syntax)) b => - SelectBuilder syntax db a -> b -> SelectBuilder syntax db b +setSelectBuilderProjection :: Projectible be b + => SelectBuilder be db a -> b -> SelectBuilder be db b setSelectBuilderProjection (SelectBuilderQ _ q) proj = SelectBuilderQ proj q setSelectBuilderProjection (SelectBuilderGrouping _ q grouping having d) proj = SelectBuilderGrouping proj q grouping having d setSelectBuilderProjection (SelectBuilderSelectSyntax containsSetOp _ q) proj = SelectBuilderSelectSyntax containsSetOp proj q @@ -155,29 +158,29 @@ exprWithContext pfx = ($ nextTblPfx pfx) buildJoinTableSourceQuery - :: ( IsSql92SelectSyntax select - , Projectible (Sql92SelectExpressionSyntax select) x - , Sql92TableSourceSelectSyntax (Sql92FromTableSourceSyntax (Sql92SelectFromSyntax select)) ~ select ) - => TablePrefix -> select - -> x -> QueryBuilder select - -> (x, QueryBuilder select) + :: forall be x + . ( BeamSqlBackend be, Projectible be x ) + => TablePrefix -> BeamSqlBackendSelectSyntax be + -> x -> QueryBuilder be + -> (x, QueryBuilder be) buildJoinTableSourceQuery tblPfx tblSource x qb = let qb' = QueryBuilder (tblRef + 1) from' (qbWhere qb) !tblRef = qbNextTblRef qb from' = case qbFrom qb of Nothing -> Just newSource Just oldFrom -> Just (innerJoin oldFrom newSource Nothing) - newSource = fromTable (tableFromSubSelect tblSource) (Just newTblNm) + newSource = fromTable (tableFromSubSelect tblSource) (Just (newTblNm, Nothing)) newTblNm = tblPfx <> fromString (show tblRef) - in (reproject (fieldNameFunc (qualifiedField newTblNm)) x, qb') + in (reproject (Proxy @be) (fieldNameFunc (qualifiedField newTblNm)) x, qb') buildInnerJoinQuery - :: forall select s table - . (Beamable table, IsSql92SelectSyntax select) - => TablePrefix -> (TablePrefix -> T.Text -> Sql92SelectFromSyntax select) -> TableSettings table - -> (table (QExpr (Sql92SelectExpressionSyntax select) s) -> Maybe (WithExprContext (Sql92SelectExpressionSyntax select))) - -> QueryBuilder select -> (T.Text, table (QExpr (Sql92SelectExpressionSyntax select) s), QueryBuilder select) -buildInnerJoinQuery tblPfx mkFrom tblSettings mkOn qb = + :: forall be r + . BeamSqlBackend be + => TablePrefix -> (TablePrefix -> T.Text -> BeamSqlBackendFromSyntax be) + -> (T.Text -> r) + -> (r-> Maybe (WithExprContext (BeamSqlBackendExpressionSyntax be))) + -> QueryBuilder be -> (T.Text, r, QueryBuilder be) +buildInnerJoinQuery tblPfx mkFrom mkTbl mkOn qb = let qb' = QueryBuilder (tblRef + 1) from' where' tblRef = qbNextTblRef qb newTblNm = tblPfx <> fromString (show tblRef) @@ -187,48 +190,42 @@ Nothing -> (Just newSource, andE' (qbWhere qb) (exprWithContext tblPfx <$> mkOn newTbl)) Just oldFrom -> (Just (innerJoin oldFrom newSource (exprWithContext tblPfx <$> mkOn newTbl)), qbWhere qb) - newTbl = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (\_ -> fieldE (qualifiedField newTblNm (_fieldName f))))) tblSettings + newTbl = mkTbl newTblNm in (newTblNm, newTbl, qb') -nextTbl :: (IsSql92SelectSyntax select, Beamable table) - => QueryBuilder select - -> TablePrefix -> TableSettings table - -> ( table (QExpr (Sql92SelectExpressionSyntax select) s) - , T.Text - , QueryBuilder select ) -nextTbl qb tblPfx tblSettings = +nextTbl :: BeamSqlBackend be + => QueryBuilder be -> TablePrefix + -> (T.Text -> r) + -> ( r, T.Text, QueryBuilder be ) +nextTbl qb tblPfx mkTbl = let tblRef = qbNextTblRef qb newTblNm = tblPfx <> fromString (show tblRef) - newTbl = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (\_ -> fieldE (qualifiedField newTblNm (_fieldName f))))) tblSettings + newTbl = mkTbl newTblNm in (newTbl, newTblNm, qb { qbNextTblRef = qbNextTblRef qb + 1}) -projOrder :: Projectible expr x => - x -> WithExprContext [ expr ] +projOrder :: Projectible be x + => Proxy be -> x -> WithExprContext [ BeamSqlBackendExpressionSyntax be ] projOrder = project -- (Proxy @AnyType) (\_ x -> tell [x] >> pure x) -- | Convenience functions to construct an arbitrary SQL92 select syntax type -- from a 'Q'. Used by most backends as the default implementation of -- 'buildSqlQuery' in 'HasQBuilder'. -buildSql92Query' :: - forall select projSyntax db s a. - ( IsSql92SelectSyntax select - , Eq (Sql92SelectExpressionSyntax select) - , projSyntax ~ Sql92SelectTableProjectionSyntax (Sql92SelectSelectTableSyntax select) - , Sql92TableSourceSelectSyntax (Sql92FromTableSourceSyntax (Sql92SelectFromSyntax select)) ~ select - - , Sql92ProjectionExpressionSyntax projSyntax ~ Sql92SelectExpressionSyntax select - , Projectible (Sql92ProjectionExpressionSyntax projSyntax) a ) => - Bool {-^ Whether this backend supports arbitrary nested UNION, INTERSECT, EXCEPT -} -> - T.Text {-^ Table prefix -} -> - Q select db s a -> - select +buildSql92Query' :: forall be db s a + . ( BeamSqlBackend be, Projectible be a) + => Bool {-^ Whether this backend supports arbitrary nested UNION, INTERSECT, EXCEPT -} + -> T.Text {-^ Table prefix -} + -> Q be db s a + -> BeamSqlBackendSelectSyntax be buildSql92Query' arbitrarilyNestedCombinations tblPfx (Q q) = buildSelect tblPfx (buildQuery (fromF q)) where - buildQuery :: forall s x. - Projectible (Sql92ProjectionExpressionSyntax projSyntax) x => - Free (QF select db s) x - -> SelectBuilder select db x + be :: Proxy be + be = Proxy + + buildQuery :: forall s x + . Projectible be x + => Free (QF be db s) x + -> SelectBuilder be db x buildQuery (Pure x) = SelectBuilderQ x emptyQb buildQuery (Free (QGuard _ next)) = buildQuery next buildQuery f@(Free QAll {}) = buildJoinedQuery f emptyQb @@ -364,12 +361,8 @@ _ -> let (x', qb) = selectBuilderToQueryBuilder tblPfx sb in buildJoinedQuery (next x') qb - buildQuery (Free (QUnion all_ left right next)) = - buildTableCombination (unionTables all_) left right next - buildQuery (Free (QIntersect all_ left right next)) = - buildTableCombination (intersectTables all_) left right next - buildQuery (Free (QExcept all_ left right next)) = - buildTableCombination (exceptTable all_) left right next + buildQuery (Free (QSetOp combine left right next)) = + buildTableCombination combine left right next buildQuery (Free (QForceSelect selectStmt' over next)) = let sb = buildQuery (fromF over) @@ -388,35 +381,34 @@ _ -> let (x', qb) = selectBuilderToQueryBuilder tblPfx sb' in buildJoinedQuery (next x') qb - tryBuildGuardsOnly :: forall s x. - Free (QF select db s) x - -> Maybe (Sql92SelectExpressionSyntax select) - -> Maybe (x, Maybe (Sql92SelectExpressionSyntax select)) + tryBuildGuardsOnly :: forall s x + . Free (QF be db s) x + -> Maybe (BeamSqlBackendExpressionSyntax be) + -> Maybe (x, Maybe (BeamSqlBackendExpressionSyntax be)) tryBuildGuardsOnly next having = case tryCollectHaving next having of (Pure x, having') -> Just (x, having') _ -> Nothing tryCollectHaving :: forall s x. - Free (QF select db s) x - -> Maybe (Sql92SelectExpressionSyntax select) - -> (Free (QF select db s) x, Maybe (Sql92SelectExpressionSyntax select)) + Free (QF be db s) x + -> Maybe (BeamSqlBackendExpressionSyntax be) + -> (Free (QF be db s) x, Maybe (BeamSqlBackendExpressionSyntax be)) tryCollectHaving (Free (QGuard cond next)) having = tryCollectHaving next (andE' having (Just (exprWithContext tblPfx cond))) tryCollectHaving next having = (next, having) - buildTableCombination :: - forall s x r. - ( Projectible (Sql92ProjectionExpressionSyntax projSyntax) r - , Projectible (Sql92ProjectionExpressionSyntax projSyntax) x ) => - (Sql92SelectSelectTableSyntax select -> Sql92SelectSelectTableSyntax select -> Sql92SelectSelectTableSyntax select) -> - QM select db (QNested s) x -> QM select db (QNested s) x -> (x -> Free (QF select db s) r) -> SelectBuilder select db r + buildTableCombination + :: forall s x r + . ( Projectible be r, Projectible be x ) + => (BeamSqlBackendSelectTableSyntax be -> BeamSqlBackendSelectTableSyntax be -> BeamSqlBackendSelectTableSyntax be) + -> QM be db (QNested s) x -> QM be db (QNested s) x -> (x -> Free (QF be db s) r) -> SelectBuilder be db r buildTableCombination combineTables left right next = let leftSb = buildQuery (fromF left) leftTb = selectBuilderToTableSource tblPfx leftSb rightSb = buildQuery (fromF right) rightTb = selectBuilderToTableSource tblPfx rightSb - proj = reproject (fieldNameFunc unqualifiedField) (sbProj leftSb) + proj = reproject be (fieldNameFunc unqualifiedField) (sbProj leftSb) leftTb' | arbitrarilyNestedCombinations = leftTb | sbContainsSetOperation leftSb = @@ -432,22 +424,22 @@ sb = SelectBuilderSelectSyntax True proj (combineTables leftTb' rightTb') in case next proj of Pure proj' - | projOrder proj (nextTblPfx tblPfx) == projOrder proj' (nextTblPfx tblPfx) -> + | projOrder be proj (nextTblPfx tblPfx) == projOrder be proj' (nextTblPfx tblPfx) -> setSelectBuilderProjection sb proj' _ -> let (x', qb) = selectBuilderToQueryBuilder tblPfx sb in buildJoinedQuery (next x') qb buildJoinedQuery :: forall s x. - Projectible (Sql92ProjectionExpressionSyntax projSyntax) x => - Free (QF select db s) x -> QueryBuilder select -> SelectBuilder select db x + Projectible be x => + Free (QF be db s) x -> QueryBuilder be -> SelectBuilder be db x buildJoinedQuery (Pure x) qb = SelectBuilderQ x qb - buildJoinedQuery (Free (QAll mkFrom tblSettings on next)) qb = - let (newTblNm, newTbl, qb') = buildInnerJoinQuery tblPfx mkFrom tblSettings on qb + buildJoinedQuery (Free (QAll mkFrom mkTbl on next)) qb = + let (newTblNm, newTbl, qb') = buildInnerJoinQuery tblPfx mkFrom mkTbl on qb in buildJoinedQuery (next (newTblNm, newTbl)) qb' buildJoinedQuery (Free (QArbitraryJoin q mkJoin on next)) qb = case fromF q of - Free (QAll mkDbFrom dbTblSettings on' next') - | (newTbl, newTblNm, qb') <- nextTbl qb tblPfx dbTblSettings, + Free (QAll mkDbFrom dbMkTbl on' next') + | (newTbl, newTblNm, qb') <- nextTbl qb tblPfx dbMkTbl, Nothing <- exprWithContext tblPfx <$> on' newTbl, Pure proj <- next' (newTblNm, newTbl) -> let newSource = mkDbFrom (nextTblPfx tblPfx) newTblNm @@ -462,9 +454,9 @@ tblSource = buildSelect tblPfx sb newTblNm = tblPfx <> fromString (show (qbNextTblRef qb)) - newSource = fromTable (tableFromSubSelect tblSource) (Just newTblNm) + newSource = fromTable (tableFromSubSelect tblSource) (Just (newTblNm, Nothing)) - proj' = reproject (fieldNameFunc (qualifiedField newTblNm)) (sbProj sb) + proj' = reproject be (fieldNameFunc (qualifiedField newTblNm)) (sbProj sb) on' = exprWithContext tblPfx <$> on proj' (from', where') = @@ -477,8 +469,8 @@ buildJoinedQuery (Free (QTwoWayJoin a b mkJoin on next)) qb = let (aProj, aSource, qb') = case fromF a of - Free (QAll mkDbFrom dbTblSettings on' next') - | (newTbl, newTblNm, qb') <- nextTbl qb tblPfx dbTblSettings, + Free (QAll mkDbFrom dbMkTbl on' next') + | (newTbl, newTblNm, qb') <- nextTbl qb tblPfx dbMkTbl, Nothing <- on' newTbl, Pure proj <- next' (newTblNm, newTbl) -> (proj, mkDbFrom (nextTblPfx tblPfx) newTblNm, qb') @@ -487,13 +479,13 @@ newTblNm = tblPfx <> fromString (show (qbNextTblRef qb)) - proj' = reproject (fieldNameFunc (qualifiedField newTblNm)) (sbProj sb) - in (proj', fromTable (tableFromSubSelect tblSource) (Just newTblNm), qb { qbNextTblRef = qbNextTblRef qb + 1 }) + proj' = reproject be (fieldNameFunc (qualifiedField newTblNm)) (sbProj sb) + in (proj', fromTable (tableFromSubSelect tblSource) (Just (newTblNm, Nothing)), qb { qbNextTblRef = qbNextTblRef qb + 1 }) (bProj, bSource, qb'') = case fromF b of - Free (QAll mkDbFrom dbTblSettings on' next') - | (newTbl, newTblNm, qb'') <- nextTbl qb' tblPfx dbTblSettings, + Free (QAll mkDbFrom dbMkTbl on' next') + | (newTbl, newTblNm, qb'') <- nextTbl qb' tblPfx dbMkTbl, Nothing <- on' newTbl, Pure proj <- next' (newTblNm, newTbl) -> (proj, mkDbFrom (nextTblPfx tblPfx) newTblNm, qb'') @@ -502,8 +494,8 @@ newTblNm = tblPfx <> fromString (show (qbNextTblRef qb)) - proj' = reproject (fieldNameFunc (qualifiedField newTblNm)) (sbProj sb) - in (proj', fromTable (tableFromSubSelect tblSource) (Just newTblNm), qb { qbNextTblRef = qbNextTblRef qb + 1 }) + proj' = reproject be (fieldNameFunc (qualifiedField newTblNm)) (sbProj sb) + in (proj', fromTable (tableFromSubSelect tblSource) (Just (newTblNm, Nothing)), qb { qbNextTblRef = qbNextTblRef qb + 1 }) abSource = mkJoin aSource bSource (exprWithContext tblPfx <$> on (aProj, bProj)) @@ -524,11 +516,12 @@ in buildJoinedQuery (next x') qb') onlyQ :: forall s x. - Free (QF select db s) x - -> (forall a'. Projectible (Sql92SelectExpressionSyntax select) a' => Free (QF select db s) a' -> (a' -> Free (QF select db s) x) -> SelectBuilder select db x) - -> SelectBuilder select db x - onlyQ (Free (QAll entityNm entitySettings mkOn next)) f = - f (Free (QAll entityNm entitySettings mkOn (Pure . PreserveLeft))) (next . unPreserveLeft) + Free (QF be db s) x + -> (forall a'. Projectible be a' => Free (QF be db s) a' -> (a' -> Free (QF be db s) x) -> SelectBuilder be db x) + -> SelectBuilder be db x + onlyQ (Free (QAll entityNm mkTbl mkOn next)) f = + f (Free (QAll entityNm mkTbl mkOn (Pure . PreserveLeft))) (next . unPreserveLeft) +-- f (Free (QAll entityNm mkTbl mkOn (Pure . PreserveLeft))) (next . unPreserveLeft) onlyQ (Free (QArbitraryJoin entity mkJoin mkOn next)) f = f (Free (QArbitraryJoin entity mkJoin mkOn Pure)) next onlyQ (Free (QTwoWayJoin a b mkJoin mkOn next)) f = @@ -539,12 +532,8 @@ f (Free (QLimit limit q' Pure)) next onlyQ (Free (QOffset offset q' next)) f = f (Free (QOffset offset q' Pure)) next - onlyQ (Free (QUnion all_ a b next)) f = - f (Free (QUnion all_ a b Pure)) next - onlyQ (Free (QIntersect all_ a b next)) f = - f (Free (QIntersect all_ a b Pure)) next - onlyQ (Free (QExcept all_ a b next)) f = - f (Free (QExcept all_ a b Pure)) next + onlyQ (Free (QSetOp combine a b next)) f = + f (Free (QSetOp combine a b Pure)) next onlyQ (Free (QOrderBy mkOrdering q' next)) f = f (Free (QOrderBy mkOrdering q' Pure)) next onlyQ (Free (QWindowOver mkWindow mkProj q' next)) f = diff --git a/Database/Beam/Query/Types.hs b/Database/Beam/Query/Types.hs --- a/Database/Beam/Query/Types.hs +++ b/Database/Beam/Query/Types.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE UndecidableInstances #-} module Database.Beam.Query.Types - ( Q, QExpr, QGenExpr(..), QExprToIdentity, QExprToField, QWindow, QWindowFrame + ( Q, QExpr, QGenExpr(..), QExprToIdentity, QExprToField, QWindow - , Projectible, Aggregation + , Projectible , HasQBuilder(..) ) where @@ -10,9 +11,9 @@ import Database.Beam.Schema.Tables -import Database.Beam.Backend.SQL.Builder -import Database.Beam.Backend.SQL.AST -import Database.Beam.Backend.SQL.SQL92 +import Database.Beam.Backend.SQL +-- import Database.Beam.Backend.SQL.Builder +-- import Database.Beam.Backend.SQL.AST import Control.Monad.Identity import Data.Vector.Sized (Vector) @@ -56,10 +57,10 @@ , QExprToField e, QExprToField f, QExprToField g, QExprToField h) type instance QExprToField (Vector n a) = Vector n (QExprToField a) -class IsSql92SelectSyntax selectSyntax => HasQBuilder selectSyntax where - buildSqlQuery :: Projectible (Sql92SelectExpressionSyntax selectSyntax) a => - TablePrefix -> Q selectSyntax db s a -> selectSyntax -instance HasQBuilder SqlSyntaxBuilder where - buildSqlQuery = buildSql92Query' True -instance HasQBuilder Select where +class BeamSqlBackend be => HasQBuilder be where + buildSqlQuery :: Projectible be a + => TablePrefix -> Q be db s a -> BeamSqlBackendSelectSyntax be +instance BeamSqlBackend (MockSqlBackend cmd) => HasQBuilder (MockSqlBackend cmd) where buildSqlQuery = buildSql92Query' True +-- instance HasQBuilder Select where +-- buildSqlQuery = buildSql92Query' True diff --git a/Database/Beam/Schema.hs b/Database/Beam/Schema.hs --- a/Database/Beam/Schema.hs +++ b/Database/Beam/Schema.hs @@ -34,6 +34,7 @@ , withDbModification, withTableModification , dbModification, tableModification , modifyTable, fieldNamed + , setEntityName , modifyEntityName, modifyTableFields -- * Types for lens generation , Lenses, LensFor(..) diff --git a/Database/Beam/Schema/Tables.hs b/Database/Beam/Schema/Tables.hs --- a/Database/Beam/Schema/Tables.hs +++ b/Database/Beam/Schema/Tables.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeApplications #-} @@ -21,7 +22,8 @@ , DatabaseModification, EntityModification(..) , FieldModification(..) , dbModification, tableModification, withDbModification - , withTableModification, modifyTable, fieldNamed + , withTableModification, modifyTable, modifyEntityName + , setEntityName, modifyTableFields, fieldNamed , defaultDbSettings , RenamableWithRule(..), RenamableField(..) @@ -34,7 +36,7 @@ , ComposeColumnar(..) , Nullable, TableField(..) , Exposed - , fieldName + , fieldName, fieldPath , TableSettings, HaskellTable , TableSkeleton, Ignored(..) @@ -52,18 +54,24 @@ , tableValuesNeeded , pk , allBeamValues, changeBeamRep - , alongsideTable ) + , alongsideTable + , defaultFieldName ) where import Database.Beam.Backend.Types import Control.Arrow (first) import Control.Monad.Identity -import Control.Monad.Writer +import Control.Monad.Writer hiding ((<>)) import Data.Char (isUpper, toLower) -import Data.Monoid ((<>)) +import Data.Foldable (fold) +import qualified Data.List.NonEmpty as NE +import Data.Monoid (Endo(..)) import Data.Proxy +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup +#endif import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as T @@ -138,7 +146,8 @@ -- | A newtype wrapper around 'f e -> f e' (i.e., an endomorphism between entity -- types in 'f'). You usually want to use 'modifyTable' or another function to -- contstruct these for you. -newtype EntityModification f be e = EntityModification (f e -> f e) +newtype EntityModification f be e = EntityModification (Endo (f e)) + deriving (Monoid, Semigroup) -- | A newtype wrapper around 'Columnar f a -> Columnar f ' (i.e., an -- endomorphism between 'Columnar's over 'f'). You usually want to use -- 'fieldNamed' or the 'IsString' instance to rename the field, when 'f ~ @@ -152,7 +161,7 @@ -- > dbModification { tbl1 = modifyTable (\oldNm -> "NewTableName") tableModification } dbModification :: forall f be db. Database be db => DatabaseModification f be db dbModification = runIdentity $ - zipTables (Proxy @be) (\_ _ -> pure (EntityModification id)) (undefined :: DatabaseModification f be db) (undefined :: DatabaseModification f be db) + zipTables (Proxy @be) (\_ _ -> pure mempty) (undefined :: DatabaseModification f be db) (undefined :: DatabaseModification f be db) -- | Return a table modification (for use with 'modifyTable') that does nothing. -- Useful if you only want to change the table name, or if you only want to @@ -185,7 +194,7 @@ -> DatabaseModification (entity be db) be db -> db (entity be db) withDbModification db mods = - runIdentity $ zipTables (Proxy @be) (\tbl (EntityModification entityFn) -> pure (entityFn tbl)) db mods + runIdentity $ zipTables (Proxy @be) (\tbl (EntityModification entityFn) -> pure (appEndo entityFn tbl)) db mods -- | Modify a table according to the given field modifications. Invoked by -- 'modifyTable' to apply the modification in the database. Not used as often in @@ -195,30 +204,43 @@ runIdentity $ zipBeamFieldsM (\(Columnar' field :: Columnar' f a) (Columnar' (FieldModification fieldFn :: FieldModification f a)) -> pure (Columnar' (fieldFn field))) tbl mods + -- | Provide an 'EntityModification' for 'TableEntity's. Allows you to modify -- the name of the table and provide a modification for each field in the -- table. See the examples for 'withDbModification' for more. -modifyTable :: (Text -> Text) +modifyTable :: (Beamable tbl, Table tbl) + => (Text -> Text) -> tbl (FieldModification (TableField tbl)) -> EntityModification (DatabaseEntity be db) be (TableEntity tbl) -modifyTable modTblNm modFields = - EntityModification (\(DatabaseEntity (DatabaseTable nm fields)) -> - (DatabaseEntity (DatabaseTable (modTblNm nm) (withTableModification modFields fields)))) +modifyTable modTblNm modFields = modifyEntityName modTblNm <> modifyTableFields modFields +{-# DEPRECATED modifyTable "Instead of 'modifyTable fTblNm fFields', use 'modifyEntityName _ <> modifyTableFields _'" #-} +-- | Construct an 'EntityModification' to rename any database entity +modifyEntityName :: IsDatabaseEntity be entity => (Text -> Text) -> EntityModification (DatabaseEntity be db) be entity +modifyEntityName modTblNm = EntityModification (Endo (\(DatabaseEntity tbl) -> DatabaseEntity (tbl & dbEntityName %~ modTblNm))) + +-- | Change the entity name without consulting the beam-assigned one +setEntityName :: IsDatabaseEntity be entity => Text -> EntityModification (DatabaseEntity be db) be entity +setEntityName nm = modifyEntityName (\_ -> nm) + +-- | Construct an 'EntityModification' to rename the fields of a 'TableEntity' +modifyTableFields :: tbl (FieldModification (TableField tbl)) -> EntityModification (DatabaseEntity be db) be (TableEntity tbl) +modifyTableFields modFields = EntityModification (Endo (\(DatabaseEntity tbl@(DatabaseTable {})) -> DatabaseEntity tbl { dbTableSettings = withTableModification modFields (dbTableSettings tbl) })) + -- | A field modification to rename the field. Also offered under the 'IsString' -- instance for 'FieldModification (TableField tbl) a' for convenience. fieldNamed :: Text -> FieldModification (TableField tbl) a -fieldNamed newName = FieldModification (\_ -> TableField newName) +fieldNamed newName = FieldModification (fieldName .~ newName) newtype FieldRenamer entity = FieldRenamer { withFieldRenamer :: entity -> entity } class RenamableField f where - renameField :: Proxy f -> Proxy a -> (Text -> Text) -> Columnar f a -> Columnar f a + renameField :: Proxy f -> Proxy a -> (NE.NonEmpty Text -> Text) -> Columnar f a -> Columnar f a instance RenamableField (TableField tbl) where - renameField _ _ f (TableField nm) = TableField (f nm) + renameField _ _ f (TableField path _) = TableField path (f path) class RenamableWithRule mod where - renamingFields :: (Text -> Text) -> mod + renamingFields :: (NE.NonEmpty Text -> Text) -> mod instance Database be db => RenamableWithRule (db (EntityModification (DatabaseEntity be db) be)) where renamingFields renamer = runIdentity $ @@ -227,7 +249,7 @@ (undefined :: DatabaseModification f be db) instance IsDatabaseEntity be entity => RenamableWithRule (EntityModification (DatabaseEntity be db) be entity) where renamingFields renamer = - EntityModification (\(DatabaseEntity tbl) -> DatabaseEntity (withFieldRenamer (renamingFields renamer) tbl)) + EntityModification (Endo (\(DatabaseEntity tbl) -> DatabaseEntity (withFieldRenamer (renamingFields renamer) tbl))) instance (Beamable tbl, RenamableField f) => RenamableWithRule (tbl (FieldModification f)) where renamingFields renamer = runIdentity $ @@ -259,62 +281,84 @@ type DatabaseEntityRegularRequirements be entityType :: Constraint dbEntityName :: Lens' (DatabaseEntityDescriptor be entityType) Text + dbEntitySchema :: Traversal' (DatabaseEntityDescriptor be entityType) (Maybe Text) + dbEntityAuto :: DatabaseEntityDefaultRequirements be entityType => Text -> DatabaseEntityDescriptor be entityType instance Beamable tbl => RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be (TableEntity tbl))) where renamingFields renamer = - FieldRenamer $ \(DatabaseTable tblName fields) -> - DatabaseTable tblName $ - changeBeamRep (\(Columnar' tblField :: Columnar' (TableField tbl) a) -> - Columnar' (renameField (Proxy @(TableField tbl)) (Proxy @a) renamer tblField) :: Columnar' (TableField tbl) a) $ - fields + FieldRenamer $ \tbl -> + tbl { dbTableSettings = + changeBeamRep (\(Columnar' tblField :: Columnar' (TableField tbl) a) -> + Columnar' (renameField (Proxy @(TableField tbl)) + (Proxy @a) + renamer tblField) + :: Columnar' (TableField tbl) a) $ + dbTableSettings tbl } instance Beamable tbl => IsDatabaseEntity be (TableEntity tbl) where data DatabaseEntityDescriptor be (TableEntity tbl) where - DatabaseTable :: Table tbl => Text -> TableSettings tbl -> DatabaseEntityDescriptor be (TableEntity tbl) + DatabaseTable + :: Table tbl => + { dbTableSchema :: Maybe Text + , dbTableOrigName :: Text + , dbTableCurrentName :: Text + , dbTableSettings :: TableSettings tbl } + -> DatabaseEntityDescriptor be (TableEntity tbl) type DatabaseEntityDefaultRequirements be (TableEntity tbl) = ( GDefaultTableFieldSettings (Rep (TableSettings tbl) ()) , Generic (TableSettings tbl), Table tbl, Beamable tbl ) type DatabaseEntityRegularRequirements be (TableEntity tbl) = ( Table tbl, Beamable tbl ) - dbEntityName f (DatabaseTable t s) = fmap (\t' -> DatabaseTable t' s) (f t) + dbEntityName f tbl = fmap (\t' -> tbl { dbTableCurrentName = t' }) (f (dbTableCurrentName tbl)) + dbEntitySchema f tbl = fmap (\s' -> tbl { dbTableSchema = s'}) (f (dbTableSchema tbl)) dbEntityAuto nm = - DatabaseTable (unCamelCaseSel nm) defTblFieldSettings + DatabaseTable Nothing nm (unCamelCaseSel nm) defTblFieldSettings instance Beamable tbl => RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be (ViewEntity tbl))) where renamingFields renamer = - FieldRenamer $ \(DatabaseView tblName fields) -> - DatabaseView tblName $ - changeBeamRep (\(Columnar' tblField :: Columnar' (TableField tbl) a) -> - Columnar' (renameField (Proxy @(TableField tbl)) (Proxy @a) renamer tblField) :: Columnar' (TableField tbl) a) $ - fields + FieldRenamer $ \vw -> + vw { dbViewSettings = + changeBeamRep (\(Columnar' tblField :: Columnar' (TableField tbl) a) -> + Columnar' (renameField (Proxy @(TableField tbl)) + (Proxy @a) + renamer tblField) + :: Columnar' (TableField tbl) a) $ + dbViewSettings vw } instance Beamable tbl => IsDatabaseEntity be (ViewEntity tbl) where data DatabaseEntityDescriptor be (ViewEntity tbl) where - DatabaseView :: Text -> TableSettings tbl -> DatabaseEntityDescriptor be (ViewEntity tbl) + DatabaseView + :: { dbViewSchema :: Maybe Text + , dbViewOrigName :: Text + , dbViewCurrentName :: Text + , dbViewSettings :: TableSettings tbl } + -> DatabaseEntityDescriptor be (ViewEntity tbl) type DatabaseEntityDefaultRequirements be (ViewEntity tbl) = ( GDefaultTableFieldSettings (Rep (TableSettings tbl) ()) , Generic (TableSettings tbl), Beamable tbl ) type DatabaseEntityRegularRequirements be (ViewEntity tbl) = ( Beamable tbl ) - dbEntityName f (DatabaseView t s) = fmap (\t' -> DatabaseView t' s) (f t) + dbEntityName f vw = fmap (\t' -> vw { dbViewCurrentName = t' }) (f (dbViewCurrentName vw)) + dbEntitySchema f vw = fmap (\s' -> vw { dbViewSchema = s' }) (f (dbViewSchema vw)) dbEntityAuto nm = - DatabaseView (unCamelCaseSel nm) defTblFieldSettings + DatabaseView Nothing nm (unCamelCaseSel nm) defTblFieldSettings instance RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be (DomainTypeEntity ty))) where renamingFields _ = FieldRenamer id instance IsDatabaseEntity be (DomainTypeEntity ty) where data DatabaseEntityDescriptor be (DomainTypeEntity ty) - = DatabaseDomainType !Text + = DatabaseDomainType !(Maybe Text) !Text type DatabaseEntityDefaultRequirements be (DomainTypeEntity ty) = () type DatabaseEntityRegularRequirements be (DomainTypeEntity ty) = () - dbEntityName f (DatabaseDomainType t) = DatabaseDomainType <$> f t - dbEntityAuto = DatabaseDomainType + dbEntityName f (DatabaseDomainType s t) = DatabaseDomainType s <$> f t + dbEntitySchema f (DatabaseDomainType s t) = DatabaseDomainType <$> f s <*> pure t + dbEntityAuto = DatabaseDomainType Nothing -- | Represents a meta-description of a particular entityType. Mostly, a wrapper -- around 'DatabaseEntityDescriptor be entityType', but carries around the @@ -446,17 +490,23 @@ -- -- Usually you use the 'defaultDbSettings' function to generate an appropriate -- naming convention for you, and then modify it with 'withDbModification' if --- necessary. Under this scheme, the field can be renamed using the 'IsString' +-- necessary. Under this scheme, the field n be renamed using the 'IsString' -- instance for 'TableField', or the 'fieldNamed' function. data TableField (table :: (* -> *) -> *) ty = TableField - { _fieldName :: Text -- ^ The field name + { _fieldPath :: NE.NonEmpty T.Text + -- ^ The path that led to this field. Each element is the haskell + -- name of the record field in which this table is stored. + , _fieldName :: Text -- ^ The field name } deriving (Show, Eq) -- | Van Laarhoven lens to retrieve or set the field name from a 'TableField'. fieldName :: Lens' (TableField table ty) Text -fieldName f (TableField name) = TableField <$> f name +fieldName f (TableField path name) = TableField path <$> f name +fieldPath :: Traversal' (TableField table ty) Text +fieldPath f (TableField orig name) = TableField <$> traverse f orig <*> pure name + -- | Represents a table that contains metadata on its fields. In particular, -- each field of type 'Columnar f a' is transformed into 'TableField table a'. -- You can get or update the name of each field by using the 'fieldName' lens. @@ -784,8 +834,9 @@ instance Selector f => GDefaultTableFieldSettings (S1 f (K1 Generic.R (TableField table field)) p) where gDefTblFieldSettings (_ :: Proxy (S1 f (K1 Generic.R (TableField table field)) p)) = M1 (K1 s) - where s = TableField name - name = unCamelCaseSel (T.pack (selName (undefined :: S1 f (K1 Generic.R (TableField table field)) ()))) + where s = TableField (pure rawSelName) name + name = unCamelCaseSel rawSelName + rawSelName = T.pack (selName (undefined :: S1 f (K1 Generic.R (TableField table field)) ())) instance ( TypeError ('Text "All Beamable types must be record types, so appropriate names can be given to columns")) => GDefaultTableFieldSettings (K1 r f p) where gDefTblFieldSettings _ = error "impossible" @@ -821,8 +872,8 @@ , GDefaultTableFieldSettings (Rep (rel (TableField rel)) ()) ) => SubTableStrategyImpl 'PrimaryKeyStrategy f (PrimaryKey rel) where namedSubTable _ = primaryKey tbl - where tbl = changeBeamRep (\(Columnar' (TableField nm) :: Columnar' (TableField rel) a) -> - let c = Columnar' (TableField nm) :: Columnar' (TableField tbl) a + where tbl = changeBeamRep (\(Columnar' (TableField path nm) :: Columnar' (TableField rel) a) -> + let c = Columnar' (TableField path nm) :: Columnar' (TableField tbl) a in runIdentity (reduceTag (\_ -> pure c) undefined)) $ to' $ gDefTblFieldSettings (Proxy @(Rep (rel (TableField rel)) ())) instance ( Generic (sub f) @@ -844,10 +895,11 @@ where tbl :: sub f tbl = namedSubTable (Proxy @strategy) - relName = unCamelCaseSel (T.pack (selName (undefined :: S1 f' (K1 Generic.R (sub f)) p))) + origSelName = T.pack (selName (undefined :: S1 f' (K1 Generic.R (sub f)) p)) + relName = unCamelCaseSel origSelName settings' :: sub f - settings' = changeBeamRep (reduceTag %~ \(Columnar' (TableField nm)) -> Columnar' (TableField (relName <> "__" <> nm))) tbl + settings' = changeBeamRep (reduceTag %~ \(Columnar' (TableField path nm)) -> Columnar' (TableField (pure origSelName <> path) (relName <> "__" <> nm))) tbl type family ReplaceBaseTag tag f where ReplaceBaseTag tag (Nullable f) = Nullable (ReplaceBaseTag tag f) @@ -859,9 +911,9 @@ (Columnar' f' a' -> m (Columnar' f' a')) -> Columnar' f a -> m (Columnar' f a) instance TagReducesTo (TableField tbl) (TableField tbl) where - reduceTag f ~(Columnar' (TableField nm)) = - (\(Columnar' (TableField nm')) -> Columnar' (TableField nm')) <$> - f (Columnar' (TableField nm)) + reduceTag f ~(Columnar' (TableField path nm)) = + (\(Columnar' (TableField path' nm')) -> Columnar' (TableField path' nm')) <$> + f (Columnar' (TableField path nm)) instance TagReducesTo f f' => TagReducesTo (Nullable f) f' where reduceTag fn ~(Columnar' x :: Columnar' (Nullable f) a) = (\(Columnar' x' :: Columnar' f (Maybe a')) -> Columnar' x') <$> @@ -933,3 +985,7 @@ [] -> symbolLeft [xs] -> xs _:xs -> T.intercalate "_" xs + +-- | Produce the beam default field name for the given path +defaultFieldName :: NE.NonEmpty Text -> Text +defaultFieldName comps = fold (NE.intersperse (T.pack "__") (unCamelCaseSel <$> comps)) diff --git a/beam-core.cabal b/beam-core.cabal --- a/beam-core.cabal +++ b/beam-core.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: beam-core -version: 0.7.2.3 +version: 0.8.0.0 synopsis: Type-safe, feature-complete SQL query and manipulation interface for Haskell description: Beam is a Haskell library for type-safe querying and manipulation of SQL databases. Beam is modular and supports various backends. In order to use beam, you will need to use @@ -27,6 +27,8 @@ Database.Beam.Query Database.Beam.Query.Internal Database.Beam.Query.CustomSQL + Database.Beam.Query.CTE + Database.Beam.Query.DataTypes Database.Beam.Query.SQL92 Database.Beam.Query.Types @@ -36,6 +38,7 @@ Database.Beam.Backend.Types Database.Beam.Backend.URI Database.Beam.Backend.SQL + Database.Beam.Backend.SQL.Row Database.Beam.Backend.SQL.Types Database.Beam.Backend.SQL.BeamExtensions Database.Beam.Backend.SQL.SQL92 @@ -46,6 +49,7 @@ other-modules: Database.Beam.Query.Aggregate Database.Beam.Query.Combinators Database.Beam.Query.Extensions + Database.Beam.Query.Extract Database.Beam.Query.Operator Database.Beam.Query.Ord Database.Beam.Query.Relationships @@ -64,6 +68,8 @@ hashable >=1.1 && <1.3, network-uri >=2.6 && <2.7, containers >=0.5 && <0.7, + scientific >=0.3 && <0.4, + vector >=0.11 && <0.13, vector-sized >=0.5 && <1.3, tagged >=0.8 && <0.9 Default-language: Haskell2010 @@ -71,7 +77,7 @@ GeneralizedNewtypeDeriving, RankNTypes, TupleSections, ConstraintKinds, StandaloneDeriving, TypeOperators, DefaultSignatures, KindSignatures, MultiParamTypeClasses, DeriveGeneric, DeriveFunctor, DeriveDataTypeable, TypeApplications, FunctionalDependencies, DataKinds, BangPatterns, InstanceSigs - ghc-options: -Wall + ghc-options: -Wall -O3 if flag(werror) ghc-options: -Werror diff --git a/test/Database/Beam/Test/SQL.hs b/test/Database/Beam/Test/SQL.hs --- a/test/Database/Beam/Test/SQL.hs +++ b/test/Database/Beam/Test/SQL.hs @@ -10,6 +10,8 @@ import Database.Beam.Test.Schema hiding (tests) import Database.Beam +import Database.Beam.Query.Internal +import Database.Beam.Backend.SQL (MockSqlBackend) import Database.Beam.Backend.SQL.AST import Data.Time.Clock @@ -51,13 +53,24 @@ ] ] +selectMock :: Projectible (MockSqlBackend Command) res + => Q (MockSqlBackend Command) db QBaseScope res -> SqlSelect (MockSqlBackend Command) (QExprToIdentity res) +selectMock = select + +updateMock :: Beamable table + => DatabaseEntity (MockSqlBackend Command) db (TableEntity table) + -> (forall s. table (QField s) -> QAssignment (MockSqlBackend Command) s) + -> (forall s. table (QExpr (MockSqlBackend Command) s) -> QExpr (MockSqlBackend Command) s Bool) + -> SqlUpdate (MockSqlBackend Command) table +updateMock = update + -- | Ensure simple select selects the right fields simpleSelect :: TestTree simpleSelect = testCase "All fields are present in a simple all_ query" $ do SqlSelect Select { selectTable = SelectTable { .. } - , .. } <- pure (select (all_ (_employees employeeDbSettings))) + , .. } <- pure (selectMock (all_ (_employees employeeDbSettings))) selectGrouping @?= Nothing selectOrdering @?= [] @@ -67,7 +80,7 @@ selectHaving @?= Nothing selectQuantifier @?= Nothing - Just (FromTable (TableNamed "employees") (Just tblName)) <- pure selectFrom + Just (FromTable (TableNamed (TableName Nothing "employees")) (Just (tblName, Nothing))) <- pure selectFrom selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField tblName "first_name"), Just "res0") , (ExpressionFieldName (QualifiedField tblName "last_name"), Just "res1") @@ -84,7 +97,7 @@ simpleWhere = testCase "guard_ clauses are successfully translated into WHERE statements" $ do SqlSelect Select { selectTable = SelectTable { .. } - , .. } <- pure $ select $ + , .. } <- pure $ selectMock $ do e <- all_ (_employees employeeDbSettings) guard_ (_employeeSalary e >. 120202 &&. _employeeAge e <. 30 &&. @@ -97,7 +110,7 @@ selectHaving @?= Nothing selectQuantifier @?= Nothing - Just (FromTable (TableNamed "employees") (Just employees)) <- pure selectFrom + Just (FromTable (TableNamed (TableName Nothing "employees")) (Just (employees, Nothing))) <- pure selectFrom let salaryCond = ExpressionCompOp ">" Nothing (ExpressionFieldName (QualifiedField employees "salary")) (ExpressionValue (Value (120202 :: Double))) ageCond = ExpressionCompOp "<" Nothing (ExpressionFieldName (QualifiedField employees "age")) (ExpressionValue (Value (30 :: Int))) @@ -111,7 +124,7 @@ simpleJoin = testCase "Introducing multiple tables results in an inner join" $ do SqlSelect Select { selectTable = SelectTable { .. } - , .. } <- pure $ select $ + , .. } <- pure $ selectMock $ do e <- all_ (_employees employeeDbSettings) r <- all_ (_roles employeeDbSettings) pure (_employeePhoneNumber e, _roleName r) @@ -124,8 +137,8 @@ selectHaving @?= Nothing selectQuantifier @?= Nothing - Just (InnerJoin (FromTable (TableNamed "employees") (Just employees)) - (FromTable (TableNamed "roles") (Just roles)) + Just (InnerJoin (FromTable (TableNamed (TableName Nothing "employees")) (Just (employees, Nothing))) + (FromTable (TableNamed (TableName Nothing "roles")) (Just (roles, Nothing))) Nothing) <- pure selectFrom selectProjection @?= ProjExprs [ ( ExpressionFieldName (QualifiedField employees "phone_number"), Just "res0" ) @@ -137,7 +150,7 @@ selfJoin = testCase "Table names are unique and properly used in self joins" $ do SqlSelect Select { selectTable = SelectTable { .. } - , .. } <- pure $ select $ + , .. } <- pure $ selectMock $ do e1 <- all_ (_employees employeeDbSettings) e2 <- relatedBy_ (_employees employeeDbSettings) (\e2 -> _employeeFirstName e1 ==. _employeeLastName e2) @@ -153,10 +166,10 @@ selectHaving @?= Nothing selectQuantifier @?= Nothing - Just (InnerJoin (InnerJoin (FromTable (TableNamed "employees") (Just e1)) - (FromTable (TableNamed "employees") (Just e2)) + Just (InnerJoin (InnerJoin (FromTable (TableNamed (TableName Nothing "employees")) (Just (e1, Nothing))) + (FromTable (TableNamed (TableName Nothing "employees")) (Just (e2, Nothing))) (Just joinCondition12)) - (FromTable (TableNamed "employees") (Just e3)) + (FromTable (TableNamed (TableName Nothing "employees")) (Just (e3, Nothing))) (Just joinCondition123)) <- pure selectFrom assertBool "Table names are not unique" (e1 /= e2 && e1 /= e3 && e2 /= e3) @@ -172,13 +185,13 @@ leftJoin = testCase "leftJoin_ generates the right join" $ do SqlSelect Select { selectTable = SelectTable { selectWhere = Nothing, selectFrom } } <- - pure $ select $ + pure $ selectMock $ do r <- all_ (_roles employeeDbSettings) e <- leftJoin_ (all_ (_employees employeeDbSettings)) (\e -> primaryKey e ==. _roleForEmployee r) pure (e, r) - Just (LeftJoin (FromTable (TableNamed "roles") (Just roles)) - (FromTable (TableNamed "employees") (Just employees)) + Just (LeftJoin (FromTable (TableNamed (TableName Nothing "roles")) (Just (roles, Nothing))) + (FromTable (TableNamed (TableName Nothing "employees")) (Just (employees, Nothing))) (Just cond)) <- pure selectFrom let andE = ExpressionBinOp "AND" @@ -201,15 +214,15 @@ leftJoinSingle = testCase "leftJoin_ generates the right join (single return value)" $ do SqlSelect Select { selectTable = SelectTable { selectWhere = Nothing, selectFrom } } <- - pure $ select $ + pure $ selectMock $ do r <- all_ (_roles employeeDbSettings) e <- leftJoin_ (do e <- all_ (_employees employeeDbSettings) pure (primaryKey e, _employeeAge e)) (\(key, _) -> key ==. _roleForEmployee r) pure (e, r) - Just (LeftJoin (FromTable (TableNamed "roles") (Just roles)) - (FromTable (TableNamed "employees") (Just employees)) + Just (LeftJoin (FromTable (TableNamed (TableName Nothing "roles")) (Just (roles, Nothing))) + (FromTable (TableNamed (TableName Nothing "employees")) (Just (employees, Nothing))) (Just cond)) <- pure selectFrom let andE = ExpressionBinOp "AND" @@ -243,12 +256,12 @@ do SqlSelect Select { selectTable = SelectTable { .. } , selectLimit = Nothing, selectOffset = Nothing , selectOrdering = [] } <- - pure $ select $ + pure $ selectMock $ aggregate_ (\e -> (group_ (_employeeAge e), max_ (charLength_ (_employeeFirstName e)))) $ do e <- all_ (_employees employeeDbSettings) pure e - Just (FromTable (TableNamed "employees") (Just t0)) <- pure selectFrom + Just (FromTable (TableNamed (TableName Nothing "employees")) (Just (t0, Nothing))) <- pure selectFrom selectProjection @?= ProjExprs [ ( ExpressionFieldName (QualifiedField t0 "age"), Just "res0" ) , ( ExpressionAgg "MAX" Nothing [ ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "first_name")) ], Just "res1") ] selectWhere @?= Nothing @@ -260,14 +273,14 @@ do SqlSelect Select { selectTable = SelectTable { .. } , selectLimit = Nothing, selectOffset = Nothing , selectOrdering = [] } <- - pure $ select $ + pure $ selectMock $ do (age, maxNameLength) <- aggregate_ (\e -> ( group_ (_employeeAge e) , fromMaybe_ 0 (max_ (charLength_ (_employeeFirstName e)))) ) $ all_ (_employees employeeDbSettings) guard_ (maxNameLength >. 42) pure (age, maxNameLength) - Just (FromTable (TableNamed "employees") (Just t0)) <- pure selectFrom + Just (FromTable (TableNamed (TableName Nothing "employees")) (Just (t0, Nothing))) <- pure selectFrom selectProjection @?= ProjExprs [ ( ExpressionFieldName (QualifiedField t0 "age"), Just "res0" ) , ( ExpressionCoalesce [ ExpressionAgg "MAX" Nothing [ ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "first_name")) ] , ExpressionValue (Value (0 :: Int)) ], Just "res1" ) ] @@ -283,14 +296,14 @@ do SqlSelect Select { selectTable = SelectTable { .. } , selectLimit = Nothing, selectOffset = Nothing , selectOrdering = [] } <- - pure $ select $ + pure $ selectMock $ do (age, maxFirstNameLength) <- aggregate_ (\e -> (group_ (_employeeAge e), max_ (charLength_ (_employeeFirstName e)))) $ all_ (_employees employeeDbSettings) role <- all_ (_roles employeeDbSettings) pure (age, maxFirstNameLength, _roleName role) - Just (InnerJoin (FromTable (TableFromSubSelect subselect) (Just t0)) - (FromTable (TableNamed "roles") (Just t1)) + Just (InnerJoin (FromTable (TableFromSubSelect subselect) (Just (t0, Nothing))) + (FromTable (TableNamed (TableName Nothing "roles")) (Just (t1, Nothing))) Nothing) <- pure selectFrom selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField t0 "res0"), Just "res0") , (ExpressionFieldName (QualifiedField t0 "res1"), Just "res1") @@ -302,7 +315,7 @@ Select { selectTable = SelectTable { .. } , selectLimit = Nothing, selectOffset = Nothing , selectOrdering = [] } <- pure subselect - Just (FromTable (TableNamed "employees") (Just t0)) <- pure selectFrom + Just (FromTable (TableNamed (TableName Nothing "employees")) (Just (t0, Nothing))) <- pure selectFrom selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField t0 "age"), Just "res0") , (ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "first_name"))], Just "res1") ] selectWhere @?= Nothing @@ -314,14 +327,14 @@ do SqlSelect Select { selectTable = SelectTable { .. } , selectLimit = Nothing, selectOffset = Nothing , selectOrdering = [] } <- - pure $ select $ + pure $ selectMock $ do role <- all_ (_roles employeeDbSettings) (age, maxFirstNameLength) <- aggregate_ (\e -> (group_ (_employeeAge e), max_ (charLength_ (_employeeFirstName e)))) $ all_ (_employees employeeDbSettings) pure (age, maxFirstNameLength, _roleName role) - Just (InnerJoin (FromTable (TableNamed "roles") (Just t0)) - (FromTable (TableFromSubSelect subselect) (Just t1)) + Just (InnerJoin (FromTable (TableNamed (TableName Nothing "roles")) (Just (t0, Nothing))) + (FromTable (TableFromSubSelect subselect) (Just (t1, Nothing))) Nothing) <- pure selectFrom selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField t1 "res0"), Just "res0") , (ExpressionFieldName (QualifiedField t1 "res1"), Just "res1") @@ -333,7 +346,7 @@ Select { selectTable = SelectTable { .. } , selectLimit = Nothing, selectOffset = Nothing , selectOrdering = [] } <- pure subselect - Just (FromTable (TableNamed "employees") (Just t0)) <- pure selectFrom + Just (FromTable (TableNamed (TableName Nothing "employees")) (Just (t0, Nothing))) <- pure selectFrom selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField t0 "age"), Just "res0") , (ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "first_name"))], Just "res1") ] selectWhere @?= Nothing @@ -345,11 +358,11 @@ do SqlSelect Select { selectTable = SelectTable { .. } , selectLimit = Nothing, selectOffset = Nothing , selectOrdering = [] } <- - pure $ select $ + pure $ selectMock $ aggregate_ (\e -> (group_ (_employeeAge e), max_ (charLength_ (_employeeFirstName e)))) $ limit_ 10 (all_ (_employees employeeDbSettings)) - Just (FromTable (TableFromSubSelect subselect) (Just t0)) <- pure selectFrom + Just (FromTable (TableFromSubSelect subselect) (Just (t0, Nothing))) <- pure selectFrom selectProjection @?= ProjExprs [(ExpressionFieldName (QualifiedField t0 "res3"),Just "res0"),(ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "res0"))], Just "res1")] selectWhere @?= Nothing @@ -360,7 +373,7 @@ selectOffset subselect @?= Nothing selectOrdering subselect @?= [] - SelectTable {selectFrom = Just (FromTable (TableNamed "employees") (Just t0')), .. } <- + SelectTable {selectFrom = Just (FromTable (TableNamed (TableName Nothing "employees")) (Just (t0', Nothing))), .. } <- pure $ selectTable subselect selectWhere @?= Nothing @@ -383,12 +396,12 @@ do SqlSelect Select { selectTable = SelectTable { .. } , selectLimit = Nothing, selectOffset = Nothing , selectOrdering = [] } <- - pure $ select $ + pure $ selectMock $ filter_ (\(_, l) -> l <. 10 ||. l >. 20) $ aggregate_ (\e -> ( group_ (_employeeAge e) , fromMaybe_ 0 (max_ (charLength_ (_employeeFirstName e)))) ) $ limit_ 10 (all_ (_employees employeeDbSettings)) - Just (FromTable (TableFromSubSelect subselect) (Just t0)) <- pure selectFrom + Just (FromTable (TableFromSubSelect subselect) (Just (t0, Nothing))) <- pure selectFrom selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField t0 "res3"),Just "res0") , (ExpressionCoalesce [ ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "res0"))] @@ -409,7 +422,7 @@ selectOffset subselect @?= Nothing selectOrdering subselect @?= [] - SelectTable {selectFrom = Just (FromTable (TableNamed "employees") (Just t0')), .. } <- + SelectTable {selectFrom = Just (FromTable (TableNamed (TableName Nothing "employees")) (Just (t0', Nothing))), .. } <- pure $ selectTable subselect selectWhere @?= Nothing @@ -430,7 +443,7 @@ do SqlSelect Select { selectTable = SelectTable { .. } , selectLimit = Nothing, selectOffset = Nothing , selectOrdering = [] } <- - pure $ select $ + pure $ selectMock $ do (lastName, firstNameLength) <- filter_ (\(_, charLength) -> fromMaybe_ 0 charLength >. 10) $ aggregate_ (\e -> (group_ (_employeeLastName e), max_ (charLength_ (_employeeFirstName e)))) $ @@ -438,8 +451,8 @@ role <- relatedBy_ (_roles employeeDbSettings) (\r -> _roleName r ==. lastName) pure (firstNameLength, role, lastName) - Just (InnerJoin (FromTable (TableFromSubSelect subselect) (Just t0)) - (FromTable (TableNamed "roles") (Just t1)) + Just (InnerJoin (FromTable (TableFromSubSelect subselect) (Just (t0, Nothing))) + (FromTable (TableNamed (TableName Nothing "roles")) (Just (t1, Nothing))) (Just joinCond) ) <- pure selectFrom @@ -458,7 +471,7 @@ Select { selectTable = SelectTable { .. }, selectLimit = Nothing , selectOffset = Nothing, selectOrdering = [] } <- pure subselect - Just (FromTable (TableFromSubSelect employeesSelect) (Just t0')) <- pure selectFrom + Just (FromTable (TableFromSubSelect employeesSelect) (Just (t0', Nothing))) <- pure selectFrom selectWhere @?= Nothing selectHaving @?= Just (ExpressionCompOp ">" Nothing (ExpressionCoalesce [ ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0' "res0"))] , ExpressionValue (Value (0 :: Int)) ]) @@ -470,7 +483,7 @@ Select { selectTable = SelectTable { .. }, selectLimit = Just 10 , selectOffset = Nothing, selectOrdering = [] } <- pure employeesSelect - Just (FromTable (TableNamed "employees") (Just t0'')) <- pure selectFrom + Just (FromTable (TableNamed (TableName Nothing "employees")) (Just (t0'', Nothing))) <- pure selectFrom selectWhere @?= Nothing selectHaving @?= Nothing @@ -489,7 +502,7 @@ do SqlSelect Select { selectTable = SelectTable { .. } , selectLimit = Nothing, selectOffset = Nothing , selectOrdering = [] } <- - pure $ select $ + pure $ selectMock $ do role <- all_ (_roles employeeDbSettings) (lastName, firstNameLength) <- filter_ (\(_, charLength) -> charLength >. 10) $ @@ -499,8 +512,8 @@ guard_ (_roleName role ==. lastName) pure (firstNameLength, role, lastName) - Just (InnerJoin (FromTable (TableNamed "roles") (Just t0)) - (FromTable (TableFromSubSelect subselect) (Just t1)) + Just (InnerJoin (FromTable (TableNamed (TableName Nothing "roles")) (Just (t0, Nothing))) + (FromTable (TableFromSubSelect subselect) (Just (t1, Nothing))) Nothing) <- pure selectFrom selectWhere @?= Just (ExpressionBinOp "AND" @@ -519,7 +532,7 @@ Select { selectTable = SelectTable { .. }, selectLimit = Nothing , selectOffset = Nothing, selectOrdering = [] } <- pure subselect - Just (FromTable (TableFromSubSelect employeesSelect) (Just t0')) <- pure selectFrom + Just (FromTable (TableFromSubSelect employeesSelect) (Just (t0', Nothing))) <- pure selectFrom selectWhere @?= Nothing selectHaving @?= Nothing selectGrouping @?= Just (Grouping [ (ExpressionFieldName (QualifiedField t0' "res1")) ]) @@ -531,7 +544,7 @@ Select { selectTable = SelectTable { .. }, selectLimit = Just 10 , selectOffset = Nothing, selectOrdering = [] } <- pure employeesSelect - Just (FromTable (TableNamed "employees") (Just t0'')) <- pure selectFrom + Just (FromTable (TableNamed (TableName Nothing "employees")) (Just (t0'', Nothing))) <- pure selectFrom selectWhere @?= Nothing selectHaving @?= Nothing @@ -561,7 +574,7 @@ do SqlSelect Select { selectTable = select , selectLimit = Just 100, selectOffset = Just 5 , selectOrdering = ordering } <- - pure $ select $ + pure $ selectMock $ limit_ 100 $ offset_ 5 $ orderBy_ (asc_ . _roleStarted) $ all_ (_roles employeeDbSettings) @@ -571,7 +584,7 @@ , ( ExpressionFieldName (QualifiedField "t0" "for_employee__created"), Just "res2" ) , ( ExpressionFieldName (QualifiedField "t0" "name"), Just "res3" ) , ( ExpressionFieldName (QualifiedField "t0" "started"), Just "res4" ) ] - , selectFrom = Just (FromTable (TableNamed "roles") (Just "t0")) + , selectFrom = Just (FromTable (TableNamed (TableName Nothing "roles")) (Just ("t0", Nothing))) , selectWhere = Nothing , selectGrouping = Nothing , selectHaving = Nothing @@ -582,7 +595,7 @@ do SqlSelect Select { selectTable = select , selectLimit = Nothing, selectOffset = Nothing , selectOrdering = ordering } <- - pure $ select $ + pure $ selectMock $ orderBy_ (asc_ . _roleStarted) $ (all_ (_roles employeeDbSettings) `unionAll_` all_ (_roles employeeDbSettings)) @@ -594,7 +607,7 @@ , ( ExpressionFieldName (QualifiedField "t0" "for_employee__created"), Just "res2" ) , ( ExpressionFieldName (QualifiedField "t0" "name"), Just "res3" ) , ( ExpressionFieldName (QualifiedField "t0" "started"), Just "res4" ) ] - , selectFrom = Just (FromTable (TableNamed "roles") (Just "t0")) + , selectFrom = Just (FromTable (TableNamed (TableName Nothing "roles")) (Just ("t0", Nothing))) , selectWhere = Nothing , selectGrouping = Nothing , selectHaving = Nothing @@ -607,7 +620,7 @@ do SqlSelect Select { selectTable = s , selectLimit = Nothing, selectOffset = Nothing , selectOrdering = ordering } <- - pure $ select $ + pure $ selectMock $ orderBy_ (asc_ . _roleStarted) $ limit_ 100 $ offset_ 5 $ all_ (_roles employeeDbSettings) @@ -619,7 +632,7 @@ , ( ExpressionFieldName (QualifiedField "t0" "for_employee__created"), Just "res2" ) , ( ExpressionFieldName (QualifiedField "t0" "name"), Just "res3" ) , ( ExpressionFieldName (QualifiedField "t0" "started"), Just "res4" ) ] - , selectFrom = Just (FromTable (TableNamed "roles") (Just "t0")) + , selectFrom = Just (FromTable (TableNamed (TableName Nothing "roles")) (Just ("t0", Nothing))) , selectWhere = Nothing , selectGrouping = Nothing , selectHaving = Nothing @@ -631,7 +644,7 @@ , ( ExpressionFieldName (QualifiedField "t0" "res3"), Just "res3" ) , ( ExpressionFieldName (QualifiedField "t0" "res4"), Just "res4" ) ] , selectFrom = Just (FromTable (TableFromSubSelect (Select { selectTable = rolesSelect, selectLimit = Just 100 - , selectOffset = Just 5, selectOrdering = [] })) (Just "t0")) + , selectOffset = Just 5, selectOrdering = [] })) (Just ("t0", Nothing))) , selectWhere = Nothing , selectGrouping = Nothing , selectHaving = Nothing @@ -643,7 +656,7 @@ do SqlSelect Select { selectTable = select , selectLimit = Nothing, selectOffset = Nothing , selectOrdering = [] } <- - pure $ select $ + pure $ selectMock $ do oldestEmployees <- limit_ 10 $ orderBy_ ((,) <$> (asc_ <$> _employeeAge) <*> (desc_ <$> (charLength_ <$> _employeeFirstName))) $ all_ (_employees employeeDbSettings) role <- relatedBy_ (_roles employeeDbSettings) (\r -> _roleForEmployee r ==. primaryKey oldestEmployees) @@ -665,7 +678,7 @@ , ( ExpressionFieldName (QualifiedField "t0" "hire_date"), Just "res5" ) , ( ExpressionFieldName (QualifiedField "t0" "leave_date"), Just "res6" ) , ( ExpressionFieldName (QualifiedField "t0" "created"), Just "res7" ) ] - , selectFrom = Just (FromTable (TableNamed "employees") (Just "t0")) + , selectFrom = Just (FromTable (TableNamed (TableName Nothing "employees")) (Just ("t0", Nothing))) , selectWhere = Nothing , selectGrouping = Nothing , selectHaving = Nothing @@ -676,7 +689,7 @@ (ExpressionFieldName (QualifiedField "t0" "res1")))) (ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField "t1" "for_employee__created")) (ExpressionFieldName (QualifiedField "t0" "res7"))) - selectFrom select @?= Just (InnerJoin (FromTable (TableFromSubSelect subselectExp) (Just "t0")) (FromTable (TableNamed "roles") (Just "t1")) + selectFrom select @?= Just (InnerJoin (FromTable (TableFromSubSelect subselectExp) (Just ("t0", Nothing))) (FromTable (TableNamed (TableName Nothing "roles")) (Just ("t1", Nothing))) (Just joinCondExp)) selectWhere select @?= Nothing selectGrouping select @?= Nothing @@ -687,7 +700,7 @@ do SqlSelect Select { selectTable = s , selectLimit = Nothing, selectOffset = Nothing , selectOrdering = [] } <- - pure $ select $ + pure $ selectMock $ do role <- all_ (_roles employeeDbSettings) oldestEmployees <- limit_ 10 $ orderBy_ ((,) <$> (asc_ <$> _employeeAge) <*> (desc_ <$> (charLength_ <$> _employeeFirstName))) $ all_ (_employees employeeDbSettings) @@ -721,13 +734,13 @@ , ( ExpressionFieldName (QualifiedField "t0" "hire_date"), Just "res5" ) , ( ExpressionFieldName (QualifiedField "t0" "leave_date"), Just "res6" ) , ( ExpressionFieldName (QualifiedField "t0" "created"), Just "res7" ) ] - , selectFrom = Just (FromTable (TableNamed "employees") (Just "t0")) + , selectFrom = Just (FromTable (TableNamed (TableName Nothing "employees")) (Just ("t0", Nothing))) , selectWhere = Nothing , selectGrouping = Nothing , selectHaving = Nothing , selectQuantifier = Nothing } - selectFrom s @?= Just (InnerJoin (FromTable (TableNamed "roles") (Just "t0")) - (FromTable (TableFromSubSelect subselect) (Just "t1")) + selectFrom s @?= Just (InnerJoin (FromTable (TableNamed (TableName Nothing "roles")) (Just ("t0", Nothing))) + (FromTable (TableFromSubSelect subselect) (Just ("t1", Nothing))) Nothing) -- | HAVING clause should not be floated out of a join @@ -738,7 +751,7 @@ do SqlSelect Select { selectTable = SelectTable { .. } , selectLimit = Nothing, selectOffset = Nothing , selectOrdering = [] } <- - pure $ select $ + pure $ selectMock $ do (age, maxFirstNameLength) <- filter_ (\(_, nameLength) -> fromMaybe_ 0 nameLength >=. 20) $ aggregate_ (\e -> (group_ (_employeeAge e), max_ (charLength_ (_employeeFirstName e)))) $ all_ (_employees employeeDbSettings) @@ -746,8 +759,8 @@ pure (age, maxFirstNameLength, _roleName role) Just (InnerJoin - (FromTable (TableFromSubSelect subselect) (Just t0)) - (FromTable (TableNamed "roles") (Just t1)) + (FromTable (TableFromSubSelect subselect) (Just (t0, Nothing))) + (FromTable (TableNamed (TableName Nothing "roles")) (Just (t1, Nothing))) Nothing) <- pure selectFrom selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField t0 "res0"), Just "res0") , (ExpressionFieldName (QualifiedField t0 "res1"), Just "res1") @@ -759,7 +772,7 @@ Select { selectTable = SelectTable { .. } , selectLimit = Nothing, selectOffset = Nothing , selectOrdering = [] } <- pure subselect - Just (FromTable (TableNamed "employees") (Just t0)) <- pure selectFrom + Just (FromTable (TableNamed (TableName Nothing "employees")) (Just (t0, Nothing))) <- pure selectFrom selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField t0 "age"), Just "res0") , (ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "first_name"))], Just "res1") ] selectWhere @?= Nothing @@ -774,12 +787,12 @@ maybeFieldTypes :: TestTree maybeFieldTypes = testCase "Simple maybe field types" $ - do SqlSelect Select { selectTable = SelectTable { selectWhere = Just selectWhere, selectFrom } } <- pure $ select $ do + do SqlSelect Select { selectTable = SelectTable { selectWhere = Just selectWhere, selectFrom } } <- pure $ selectMock $ do e <- all_ (_employees employeeDbSettings) guard_ (isNothing_ (_employeeLeaveDate e)) pure e - Just (FromTable (TableNamed "employees") (Just employees)) <- pure selectFrom + Just (FromTable (TableNamed (TableName Nothing "employees")) (Just (employees, Nothing))) <- pure selectFrom selectWhere @?= ExpressionIsNull (ExpressionFieldName (QualifiedField employees "leave_date")) -- | Ensure isJustE and isNothingE work correctly for table and composite types @@ -795,12 +808,12 @@ where tableExprToTableExpr = testCase "Equality comparison between two table expressions" $ - do SqlSelect Select { selectTable = SelectTable { selectWhere = Just selectWhere, selectFrom } } <- pure $ select $ do + do SqlSelect Select { selectTable = SelectTable { selectWhere = Just selectWhere, selectFrom } } <- pure $ selectMock $ do d <- all_ (_departments employeeDbSettings) guard_ (d ==. d) pure d - Just (FromTable (TableNamed "departments") (Just depts)) <- pure selectFrom + Just (FromTable (TableNamed (TableName Nothing "departments")) (Just (depts, Nothing))) <- pure selectFrom let andE = ExpressionBinOp "AND"; orE = ExpressionBinOp "OR" eqE = ExpressionCompOp "==" Nothing @@ -825,12 +838,12 @@ do now <- getCurrentTime let exp = DepartmentT "Sales" (EmployeeId (Just "Jane") (Just "Smith") (Just now)) - SqlSelect Select { selectTable = SelectTable { selectWhere = Just selectWhere, selectFrom } } <- pure $ select $ do + SqlSelect Select { selectTable = SelectTable { selectWhere = Just selectWhere, selectFrom } } <- pure $ selectMock $ do d <- all_ (_departments employeeDbSettings) guard_ (d ==. val_ exp) pure d - Just (FromTable (TableNamed "departments") (Just depts)) <- pure selectFrom + Just (FromTable (TableNamed (TableName Nothing "departments")) (Just (depts, Nothing))) <- pure selectFrom let andE = ExpressionBinOp "AND"; orE = ExpressionBinOp "OR" eqE = ExpressionCompOp "==" Nothing @@ -856,7 +869,7 @@ related = testCase "related_ generate the correct ON conditions" $ do SqlSelect Select { .. } <- - pure $ select $ + pure $ selectMock $ do r <- all_ (_roles employeeDbSettings) e <- related_ (_employees employeeDbSettings) (_roleForEmployee r) pure (e, r) @@ -878,41 +891,41 @@ where basicUnion = testCase "Basic UNION support" $ - do let leaveDates, hireDates :: Q _ _ s ( QExpr Expression s Text, QExpr Expression s (Maybe _) ) + do let -- leaveDates, hireDates :: Q _ _ s ( QExpr Expression s Text, QExpr Expression s (Maybe _) ) hireDates = do e <- all_ (_employees employeeDbSettings) pure (as_ @Text $ val_ "hire", just_ (_employeeHireDate e)) leaveDates = do e <- all_ (_employees employeeDbSettings) guard_ (isJust_ (_employeeLeaveDate e)) pure (as_ @Text $ val_ "leave", _employeeLeaveDate e) - SqlSelect Select { selectTable = UnionTables False a b } <- pure (select (union_ hireDates leaveDates)) + SqlSelect Select { selectTable = UnionTables False a b } <- pure (selectMock (union_ hireDates leaveDates)) a @?= SelectTable Nothing (ProjExprs [ (ExpressionValue (Value ("hire" :: Text)), Just "res0") , (ExpressionFieldName (QualifiedField "t0" "hire_date"), Just "res1") ]) - (Just (FromTable (TableNamed "employees") (Just "t0"))) + (Just (FromTable (TableNamed (TableName Nothing "employees")) (Just ("t0", Nothing)))) Nothing Nothing Nothing b @?= SelectTable Nothing (ProjExprs [ (ExpressionValue (Value ("leave" :: Text)), Just "res0") , (ExpressionFieldName (QualifiedField "t0" "leave_date"), Just "res1") ]) - (Just (FromTable (TableNamed "employees") (Just "t0"))) + (Just (FromTable (TableNamed (TableName Nothing "employees")) (Just ("t0", Nothing)))) (Just (ExpressionIsNotNull (ExpressionFieldName (QualifiedField "t0" "leave_date")))) Nothing Nothing pure () fieldNamesCapturedCorrectly = testCase "UNION field names are propagated correctly" $ - do let leaveDates, hireDates :: Q _ _ s ( QExpr Expression s Text, QExpr Expression s Int, QExpr Expression s (Maybe _) ) + do let -- leaveDates, hireDates :: Q _ _ s ( QExpr Expression s Text, QExpr Expression s Int, QExpr Expression s (Maybe _) ) hireDates = do e <- all_ (_employees employeeDbSettings) pure (as_ @Text $ val_ "hire", _employeeAge e, just_ (_employeeHireDate e)) leaveDates = do e <- all_ (_employees employeeDbSettings) guard_ (isJust_ (_employeeLeaveDate e)) pure (as_ @Text $ val_ "leave", _employeeAge e, _employeeLeaveDate e) SqlSelect Select { selectTable = SelectTable { .. }, selectLimit = Nothing, selectOffset = Nothing, selectOrdering = [] } <- - pure (select $ do + pure (selectMock $ do (type_, age, date) <- limit_ 10 (union_ hireDates leaveDates) guard_ (age <. 22) pure (type_, age + 23, date)) - Just (FromTable (TableFromSubSelect subselect) (Just subselectTbl)) <- pure selectFrom + Just (FromTable (TableFromSubSelect subselect) (Just (subselectTbl, Nothing))) <- pure selectFrom selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField subselectTbl "res0"), Just "res0") , (ExpressionBinOp "+" (ExpressionFieldName (QualifiedField subselectTbl "res1")) (ExpressionValue (Value (23 :: Int))), Just "res1") @@ -930,12 +943,12 @@ (ProjExprs [ ( ExpressionValue (Value ("hire" :: Text)), Just "res0" ) , ( ExpressionFieldName (QualifiedField "t0" "age"), Just "res1" ) , ( ExpressionFieldName (QualifiedField "t0" "hire_date"), Just "res2" ) ]) - (Just (FromTable (TableNamed "employees") (Just "t0"))) Nothing Nothing Nothing + (Just (FromTable (TableNamed (TableName Nothing "employees")) (Just ("t0", Nothing)))) Nothing Nothing Nothing leaveDatesQuery @?= SelectTable Nothing (ProjExprs [ ( ExpressionValue (Value ("leave" :: Text)), Just "res0" ) , ( ExpressionFieldName (QualifiedField "t0" "age"), Just "res1") , ( ExpressionFieldName (QualifiedField "t0" "leave_date"), Just "res2") ]) - (Just (FromTable (TableNamed "employees") (Just "t0"))) + (Just (FromTable (TableNamed (TableName Nothing "employees")) (Just ("t0", Nothing)))) (Just (ExpressionIsNotNull (ExpressionFieldName (QualifiedField "t0" "leave_date")))) Nothing Nothing @@ -948,7 +961,7 @@ leaveDates = do e <- all_ (_employees employeeDbSettings) guard_ (isJust_ (_employeeLeaveDate e)) pure (_employeeFirstName e, _employeeLastName e) - SqlSelect Select { selectTable = IntersectTables False _ _ } <- pure $ select $ intersect_ hireDates leaveDates + SqlSelect Select { selectTable = IntersectTables False _ _ } <- pure $ selectMock $ intersect_ hireDates leaveDates pure () basicExcept = @@ -958,26 +971,26 @@ leaveDates = do e <- all_ (_employees employeeDbSettings) guard_ (isJust_ (_employeeLeaveDate e)) pure (_employeeFirstName e, _employeeLastName e) - SqlSelect Select { selectTable = ExceptTable False _ _ } <- pure $ select $ except_ hireDates leaveDates + SqlSelect Select { selectTable = ExceptTable False _ _ } <- pure $ selectMock $ except_ hireDates leaveDates pure () equalProjectionsDontHaveSubSelects = testCase "Equal projections dont have sub-selects" $ - do let leaveDates, hireDates :: Q _ _ s ( QExpr Expression s Text, QExpr Expression s Text, QExpr Expression s Int ) + do let -- leaveDates, hireDates :: Q _ _ s ( QExpr Expression s Text, QExpr Expression s Text, QExpr Expression s Int ) hireDates = do e <- all_ (_employees employeeDbSettings) pure (_employeeFirstName e, _employeeLastName e, _employeeAge e) leaveDates = do e <- all_ (_employees employeeDbSettings) guard_ (isJust_ (_employeeLeaveDate e)) pure (_employeeFirstName e, _employeeLastName e, _employeeAge e) SqlSelect Select { selectTable = ExceptTable False _ _ } <- - pure $ select $ do + pure $ selectMock $ do (firstName, lastName, age) <- except_ hireDates leaveDates pure (firstName, (lastName, age)) pure () unionWithGuards = testCase "UNION with guards" $ - do let leaveDates, hireDates :: Q _ _ s ( QExpr Expression s Text, QExpr Expression s Int, QExpr Expression s (Maybe _) ) + do let -- leaveDates, hireDates :: Q _ _ s ( QExpr Expression s Text, QExpr Expression s Int, QExpr Expression s (Maybe _) ) hireDates = do e <- all_ (_employees employeeDbSettings) pure (as_ @Text $ val_ "hire", _employeeAge e, just_ (_employeeHireDate e)) leaveDates = do e <- all_ (_employees employeeDbSettings) @@ -985,25 +998,25 @@ pure (as_ @Text $ val_ "leave", _employeeAge e, _employeeLeaveDate e) SqlSelect Select { selectTable = SelectTable - { selectFrom = Just (FromTable (TableFromSubSelect (Select (UnionTables False a b) [] Nothing Nothing)) (Just t0)) + { selectFrom = Just (FromTable (TableFromSubSelect (Select (UnionTables False a b) [] Nothing Nothing)) (Just (t0, Nothing))) , selectProjection = proj , selectWhere = Just where_ , selectGrouping = Nothing , selectHaving = Nothing , selectQuantifier = Nothing } , selectLimit = Nothing, selectOffset = Nothing - , selectOrdering = [] } <- pure (select (filter_ (\(_, age, _) -> age <. 40) (union_ hireDates leaveDates))) + , selectOrdering = [] } <- pure (selectMock (filter_ (\(_, age, _) -> age <. 40) (union_ hireDates leaveDates))) a @?= SelectTable Nothing (ProjExprs [ (ExpressionValue (Value ("hire" :: Text)), Just "res0") , (ExpressionFieldName (QualifiedField "t0" "age"), Just "res1") , (ExpressionFieldName (QualifiedField "t0" "hire_date"), Just "res2") ]) - (Just (FromTable (TableNamed "employees") (Just "t0"))) + (Just (FromTable (TableNamed (TableName Nothing "employees")) (Just ("t0", Nothing)))) Nothing Nothing Nothing b @?= SelectTable Nothing (ProjExprs [ (ExpressionValue (Value ("leave" :: Text)), Just "res0") , (ExpressionFieldName (QualifiedField "t0" "age"), Just "res1") , (ExpressionFieldName (QualifiedField "t0" "leave_date"), Just "res2") ]) - (Just (FromTable (TableNamed "employees") (Just "t0"))) + (Just (FromTable (TableNamed (TableName Nothing "employees")) (Just ("t0", Nothing)))) (Just (ExpressionIsNotNull (ExpressionFieldName (QualifiedField "t0" "leave_date")))) Nothing Nothing @@ -1026,7 +1039,7 @@ limitSupport = testCase "Basic LIMIT support" $ do SqlSelect Select { selectLimit, selectOffset } <- - pure $ select $ limit_ 100 $ limit_ 20 (all_ (_employees employeeDbSettings)) + pure $ selectMock $ limit_ 100 $ limit_ 20 (all_ (_employees employeeDbSettings)) selectLimit @?= Just 20 selectOffset @?= Nothing @@ -1034,7 +1047,7 @@ offsetSupport = testCase "Basic OFFSET support" $ do SqlSelect Select { selectLimit, selectOffset } <- - pure $ select $ offset_ 2 $ offset_ 100 (all_ (_employees employeeDbSettings)) + pure $ selectMock $ offset_ 2 $ offset_ 100 (all_ (_employees employeeDbSettings)) selectLimit @?= Nothing selectOffset @?= Just 102 @@ -1042,7 +1055,7 @@ limitOffsetSupport = testCase "Basic LIMIT .. OFFSET .. support" $ do SqlSelect Select { selectLimit, selectOffset } <- - pure $ select $ offset_ 2 $ limit_ 100 (all_ (_roles employeeDbSettings)) + pure $ selectMock $ offset_ 2 $ limit_ 100 (all_ (_roles employeeDbSettings)) selectLimit @?= Just 98 selectOffset @?= Just 2 @@ -1052,7 +1065,7 @@ do SqlSelect Select { selectOffset = Nothing, selectLimit = Just 10 , selectOrdering = [] , selectTable = UnionTables False a b } <- - pure $ select $ limit_ 10 $ union_ (filter_ (\e -> _employeeAge e <. 40) (all_ (_employees employeeDbSettings))) + pure $ selectMock $ limit_ 10 $ union_ (filter_ (\e -> _employeeAge e <. 40) (all_ (_employees employeeDbSettings))) (filter_ (\e -> _employeeAge e >. 50) (do { e <- all_ (_employees employeeDbSettings); pure e { _employeeFirstName = _employeeLastName e, _employeeLastName = _employeeFirstName e} })) selectProjection a @?= ProjExprs [ (ExpressionFieldName (QualifiedField "t0" "first_name"), Just "res0") @@ -1063,7 +1076,7 @@ , (ExpressionFieldName (QualifiedField "t0" "hire_date"), Just "res5") , (ExpressionFieldName (QualifiedField "t0" "leave_date"), Just "res6") , (ExpressionFieldName (QualifiedField "t0" "created"), Just "res7") ] - selectFrom a @?= Just (FromTable (TableNamed "employees") (Just "t0")) + selectFrom a @?= Just (FromTable (TableNamed (TableName Nothing "employees")) (Just ("t0", Nothing))) selectWhere a @?= Just (ExpressionCompOp "<" Nothing (ExpressionFieldName (QualifiedField "t0" "age")) (ExpressionValue (Value (40 :: Int)))) selectGrouping a @?= Nothing selectHaving a @?= Nothing @@ -1076,7 +1089,7 @@ , (ExpressionFieldName (QualifiedField "t0" "hire_date"), Just "res5") , (ExpressionFieldName (QualifiedField "t0" "leave_date"), Just "res6") , (ExpressionFieldName (QualifiedField "t0" "created"), Just "res7") ] - selectFrom b @?= Just (FromTable (TableNamed "employees") (Just "t0")) + selectFrom b @?= Just (FromTable (TableNamed (TableName Nothing "employees")) (Just ("t0", Nothing))) selectWhere b @?= Just (ExpressionCompOp ">" Nothing (ExpressionFieldName (QualifiedField "t0" "age")) (ExpressionValue (Value (50 :: Int)))) selectGrouping b @?= Nothing selectHaving b @?= Nothing @@ -1093,7 +1106,7 @@ do SqlSelect Select { selectOffset = Nothing, selectLimit = Nothing , selectOrdering = [] , selectTable = SelectTable { .. } } <- - pure $ select $ do + pure $ selectMock $ do role <- all_ (_roles employeeDbSettings) guard_ (not_ (exists_ (do dept <- all_ (_departments employeeDbSettings) guard_ (_departmentName dept ==. _roleName role) @@ -1109,7 +1122,7 @@ , selectGrouping = Nothing , selectHaving = Nothing , selectWhere = Just joinExpr - , selectFrom = Just (FromTable (TableNamed "departments") (Just "sub_t0")) } } + , selectFrom = Just (FromTable (TableNamed (TableName Nothing "departments")) (Just ("sub_t0", Nothing))) } } joinExpr = ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField "sub_t0" "name")) (ExpressionFieldName (QualifiedField "t0" "name")) @@ -1117,19 +1130,19 @@ selectWhere @?= Just (ExpressionUnOp "NOT" (ExpressionExists existsQuery)) selectHaving @?= Nothing selectQuantifier @?= Nothing - selectFrom @?= Just (FromTable (TableNamed "roles") (Just "t0")) + selectFrom @?= Just (FromTable (TableNamed (TableName Nothing "roles")) (Just ("t0", Nothing))) -- | UPDATE can correctly get the current value updateCurrent :: TestTree updateCurrent = testCase "UPDATE can use current value" $ - do SqlUpdate Update { .. } <- - pure $ update (_employees employeeDbSettings) - (\employee -> [ _employeeAge employee <-. current_ (_employeeAge employee) + 1]) - (\employee -> _employeeFirstName employee ==. "Joe") + do SqlUpdate _ (Update { .. }) <- + pure $ updateMock (_employees employeeDbSettings) + (\employee -> _employeeAge employee <-. current_ (_employeeAge employee) + 1) + (\employee -> _employeeFirstName employee ==. "Joe") - updateTable @?= "employees" + updateTable @?= (TableName Nothing "employees") updateFields @?= [ (UnqualifiedField "age", ExpressionBinOp "+" (ExpressionFieldName (UnqualifiedField "age")) (ExpressionValue (Value (1 :: Int)))) ] updateWhere @?= Just (ExpressionCompOp "==" Nothing (ExpressionFieldName (UnqualifiedField "first_name")) (ExpressionValue (Value ("Joe" :: String)))) @@ -1141,12 +1154,12 @@ let employeeKey :: PrimaryKey EmployeeT (Nullable Identity) employeeKey = EmployeeId (Just "John") (Just "Smith") (Just curTime) - SqlUpdate Update { .. } <- - pure $ update (_departments employeeDbSettings) - (\department -> [ _departmentHead department <-. val_ employeeKey ]) - (\department -> _departmentName department ==. "Sales") + SqlUpdate _ (Update { .. }) <- + pure $ updateMock (_departments employeeDbSettings) + (\department -> _departmentHead department <-. val_ employeeKey) + (\department -> _departmentName department ==. "Sales") - updateTable @?= "departments" + updateTable @?= (TableName Nothing "departments") updateFields @?= [ (UnqualifiedField "head__first_name", ExpressionValue (Value ("John" :: Text))) , (UnqualifiedField "head__last_name", ExpressionValue (Value ("Smith" :: Text))) , (UnqualifiedField "head__created", ExpressionValue (Value curTime)) ] @@ -1160,7 +1173,7 @@ noEmptyIns = testCase "Empty INs are transformed to FALSE" $ do SqlSelect Select { selectTable = SelectTable {..} } <- - pure $ select $ do + pure $ selectMock $ do e <- all_ (_employees employeeDbSettings) guard_ (_employeeFirstName e `in_` []) pure e @@ -1203,7 +1216,7 @@ SqlSelect Select { selectTable = SelectTable { .. } , .. } <- - pure $ select richEmployeesAndRoles + pure $ selectMock richEmployeesAndRoles selectProjection @?= ProjExprs [ (ExpressionFieldName (QualifiedField roles "name") , Just "res0") @@ -1224,8 +1237,8 @@ selectWhere @?= Just (andE (andE firstNameCond lastNameCond) createdCond) - Just (InnerJoin (FromTable (TableFromSubSelect subselect) (Just "t0")) - (FromTable (TableNamed "roles") (Just "t1")) + Just (InnerJoin (FromTable (TableFromSubSelect subselect) (Just ("t0", Nothing))) + (FromTable (TableNamed (TableName Nothing "roles")) (Just ("t1", Nothing))) Nothing) <- pure selectFrom Select { selectTable = SelectTable { .. } @@ -1281,12 +1294,12 @@ , selectWhere = Nothing , .. } , selectLimit = Nothing, selectOffset = Nothing - , selectOrdering = selectOrdering }) (Just "t0")) - (FromTable (TableNamed "roles") (Just "t1")) + , selectOrdering = selectOrdering }) (Just ("t0", Nothing))) + (FromTable (TableNamed (TableName Nothing "roles")) (Just ("t1", Nothing))) Nothing) } , selectOrdering = [] , selectLimit = Nothing , selectOffset = Nothing } <- - pure $ select $ richEmployeeNamesAndRoles + pure $ selectMock $ richEmployeeNamesAndRoles selectWhere @?= firstNameCond selectOrdering @?= [ OrderingDesc (ExpressionFieldName (QualifiedField "t0" "first_name")) ] @@ -1308,7 +1321,7 @@ topLevelOffs0 = do SqlSelect actual <- - pure $ select $ do + pure $ selectMock $ do e <- orderBy_ (\e -> desc_ (_employeeAge e)) $ offset_ 0 $ filter_ (\e -> _employeeSalary e >=. val_ 100000) $ all_ (_employees employeeDbSettings) @@ -1343,11 +1356,11 @@ , selectWhere = Just (ExpressionCompOp ">=" Nothing (ExpressionFieldName (QualifiedField "t0" "salary")) (ExpressionValue (Value (100000 :: Double)))) - , selectFrom = Just (FromTable (TableNamed "employees") (Just "t0")) + , selectFrom = Just (FromTable (TableNamed (TableName Nothing "employees")) (Just ("t0", Nothing))) , selectGrouping = Nothing, selectHaving = Nothing } , selectLimit = Nothing, selectOffset = Just 0 - , selectOrdering = [ OrderingDesc (ExpressionFieldName (QualifiedField "t0" "age"))] }) (Just "t0")) - (FromTable (TableNamed "roles") (Just "t1")) + , selectOrdering = [ OrderingDesc (ExpressionFieldName (QualifiedField "t0" "age"))] }) (Just ("t0", Nothing))) + (FromTable (TableNamed (TableName Nothing "roles")) (Just ("t1", Nothing))) Nothing) } , selectOrdering = [] , selectLimit = Nothing , selectOffset = Nothing } diff --git a/test/Database/Beam/Test/Schema.hs b/test/Database/Beam/Test/Schema.hs --- a/test/Database/Beam/Test/Schema.hs +++ b/test/Database/Beam/Test/Schema.hs @@ -18,6 +18,7 @@ import Database.Beam.Backend import Database.Beam.Backend.SQL.AST +import Data.List.NonEmpty ( NonEmpty((:|)) ) import Data.Monoid import Data.Proxy import Data.Text (Text) @@ -77,14 +78,14 @@ expectedEmployeeTableSchema :: TableSettings EmployeeT expectedEmployeeTableSchema = - EmployeeT { _employeeFirstName = TableField "first_name" - , _employeeLastName = TableField "last_name" - , _employeePhoneNumber = TableField "phone_number" - , _employeeAge = TableField "age" - , _employeeSalary = TableField "salary" - , _employeeHireDate = TableField "hire_date" - , _employeeLeaveDate = TableField "leave_date" - , _employeeCreated = TableField "created" + EmployeeT { _employeeFirstName = TableField (pure "_employeeFirstName") "first_name" + , _employeeLastName = TableField (pure "_employeeLastName") "last_name" + , _employeePhoneNumber = TableField (pure "_employeePhoneNumber") "phone_number" + , _employeeAge = TableField (pure "_employeeAge") "age" + , _employeeSalary = TableField (pure "_employeeSalary") "salary" + , _employeeHireDate = TableField (pure "_employeeHireDate") "hire_date" + , _employeeLeaveDate = TableField (pure "_employeeLeaveDate") "leave_date" + , _employeeCreated = TableField (pure "_employeeCreated") "created" } basicSchemaGeneration :: TestTree @@ -168,55 +169,58 @@ underscoresAreHandledGracefully :: TestTree underscoresAreHandledGracefully = testCase "Underscores in field names are handled gracefully" $ - do let fieldNames = allBeamValues (\(Columnar' f) -> _fieldName f) funnyTableSchema - fieldNames @?= [ "funny_field1" - , "funny_field_2" - , "funny_first_name" - , "funny_lastName" - , "funny_middle_Name" - , "___" ] + do let fieldNames = allBeamValues (\(Columnar' f) -> (_fieldPath f, _fieldName f)) funnyTableSchema + fieldNames @?= [ ( pure "funny_field1", "funny_field1") + , ( pure "funny_field_2", "funny_field_2") + , ( pure "funny_first_name", "funny_first_name") + , ( pure "_funny_lastName", "funny_lastName") + , ( pure "_funny_middle_Name", "funny_middle_Name") + , ( pure "___", "___") ] ruleBasedRenaming :: TestTree ruleBasedRenaming = testCase "Rule based renaming works correctly" $ - do let (DatabaseEntity (DatabaseTable _ funny)) = _funny employeeDbSettingsRuleMods - (DatabaseEntity (DatabaseTable _ departments)) = _departments employeeDbSettingsRuleMods + do let (DatabaseEntity (DatabaseTable { dbTableSettings = funny })) = _funny employeeDbSettingsRuleMods + (DatabaseEntity (DatabaseTable { dbTableSettings = departments })) = _departments employeeDbSettingsRuleMods - funnyFieldNames = allBeamValues (\(Columnar' f) -> _fieldName f) funny - deptFieldNames = allBeamValues (\(Columnar' f) -> _fieldName f) departments + funnyFieldNames = allBeamValues (\(Columnar' f) -> (_fieldPath f, _fieldName f)) funny + deptFieldNames = allBeamValues (\(Columnar' f) -> (_fieldPath f, _fieldName f)) departments - funnyFieldNames @?= [ "pfx_funny_field1" - , "pfx_funny_field_2" - , "pfx_funny_first_name" - , "pfx_funny_lastName" - , "pfx_funny_middle_Name" - , "___" ] + funnyFieldNames @?= [ ( pure "funny_field1", "pfx_funny_field1") + , ( pure "funny_field_2", "pfx_funny_field_2") + , ( pure "funny_first_name", "pfx_funny_first_name") + , ( pure "_funny_lastName", "pfx_funny_lastName") + , ( pure "_funny_middle_Name", "pfx_funny_middle_Name") + , ( pure "___", "___") ] - deptFieldNames @?= [ "name", "head__first_name", "head__last_name", "head__created" ] + deptFieldNames @?= [ (pure "_departmentName", "name") + , ( "_departmentHead" :| [ "_employeeFirstName" ], "head__first_name") + , ( "_departmentHead" :| [ "_employeeLastName" ], "head__last_name") + , ( "_departmentHead" :| [ "_employeeCreated" ], "head__created") ] -- * Ensure it is possible to use nested paremetric beams parametricBeamSchemaGeneration :: TestTree parametricBeamSchemaGeneration = testCase "Parametric schema generation" $ - do let (DatabaseEntity (DatabaseTable _ deptVehiculesA)) = _departmentVehiculesA employeeDbSettings - deptVehiculesFieldNamesA = allBeamValues (\(Columnar' f) -> _fieldName f) deptVehiculesA + do let (DatabaseEntity (DatabaseTable { dbTableSettings = deptVehiculesA })) = _departmentVehiculesA employeeDbSettings + deptVehiculesFieldNamesA = allBeamValues (\(Columnar' f) -> (_fieldPath f, _fieldName f)) deptVehiculesA - deptVehiculesFieldNamesA @?= [ "departament__name" - , "relates_to__id" - , "relates_to__type" - , "relates_to__of_wheels" - , "meta_info__price" + deptVehiculesFieldNamesA @?= [ ( "_aDepartament" :| [ "_departmentName" ] , "departament__name") + , ( "_aRelatesTo" :| [ "_vehiculeId" ], "relates_to__id") + , ( "_aRelatesTo" :| [ "_vehiculeType" ], "relates_to__type") + , ( "_aRelatesTo" :| [ "_numberOfWheels" ], "relates_to__of_wheels") + , ( "_aMetaInfo" :| [ "_price" ], "meta_info__price") ] -- * Ensure it doesn't matter whether we abstract over a beam's parameters, or if we them fixed. parametricAndFixedNestedBeamsAreEquivalent :: TestTree parametricAndFixedNestedBeamsAreEquivalent = testCase "Parametric and fixed nested beams are equivalent" $ - do let (DatabaseEntity (DatabaseTable _ deptVehiculesA)) = _departmentVehiculesA employeeDbSettings - (DatabaseEntity (DatabaseTable _ deptVehiculesB)) = _departmentVehiculesB employeeDbSettings + do let (DatabaseEntity (DatabaseTable { dbTableSettings = deptVehiculesA })) = _departmentVehiculesA employeeDbSettings + (DatabaseEntity (DatabaseTable { dbTableSettings = deptVehiculesB })) = _departmentVehiculesB employeeDbSettings deptVehiculesFieldNamesA = allBeamValues (\(Columnar' f) -> _fieldName f) deptVehiculesA deptVehiculesFieldNamesB = allBeamValues (\(Columnar' f) -> _fieldName f) deptVehiculesB - + deptVehiculesFieldNamesB @?= deptVehiculesFieldNamesA @@ -316,9 +320,10 @@ employeeDbSettingsRuleMods :: DatabaseSettings be EmployeeDb employeeDbSettingsRuleMods = defaultDbSettings `withDbModification` renamingFields (\field -> - case T.stripPrefix "funny" field of - Nothing -> field - Just fieldNm -> "pfx_" <> field) + let defName = defaultFieldName field + in case T.stripPrefix "funny" defName of + Nothing -> defName + Just fieldNm -> "pfx_" <> defName) -- employeeDbSettingsModified :: DatabaseSettings EmployeeDb -- employeeDbSettingsModified =