beam-core 0.9.2.1 → 0.11.1.0
raw patch · 24 files changed
Files
- ChangeLog.md +113/−0
- Database/Beam/Backend/SQL.hs +6/−0
- Database/Beam/Backend/SQL/AST.hs +10/−0
- Database/Beam/Backend/SQL/BeamExtensions.hs +109/−46
- Database/Beam/Backend/SQL/BeamExtensions/Copy/File.hs +320/−0
- Database/Beam/Backend/SQL/BeamExtensions/Copy/Stream.hs +289/−0
- Database/Beam/Backend/SQL/Builder.hs +7/−1
- Database/Beam/Backend/SQL/Row.hs +9/−0
- Database/Beam/Backend/SQL/SQL92.hs +6/−0
- Database/Beam/Backend/SQL/Types.hs +4/−3
- Database/Beam/Backend/Types.hs +1/−1
- Database/Beam/Query.hs +11/−0
- Database/Beam/Query/CTE.hs +2/−1
- Database/Beam/Query/Combinators.hs +68/−23
- Database/Beam/Query/Extensions.hs +2/−2
- Database/Beam/Query/Extract.hs +3/−2
- Database/Beam/Query/Internal.hs +8/−6
- Database/Beam/Query/Ord.hs +7/−1
- Database/Beam/Query/SQL92.hs +95/−73
- Database/Beam/Schema/Lenses.hs +7/−1
- Database/Beam/Schema/Tables.hs +61/−10
- beam-core.cabal +23/−19
- test/Database/Beam/Test/SQL.hs +119/−2
- test/Database/Beam/Test/Schema.hs +36/−31
ChangeLog.md view
@@ -1,3 +1,116 @@+# 0.11.1.0++## New features++* Added a cross-backend abstraction for the `COPY` statement in+ `Database.Beam.Backend.SQL.BeamExtensions`:+ * file-mode `COPY ... TO 'file'` / `COPY ... FROM 'file'`. Defines+ `MonadBeamCopyTo` / `MonadBeamCopyFrom`, and the user-facing+ `copyTableTo` / `copySelectTo` / `copyTableFrom` builders.+ * streaming `COPY ... TO STDOUT` / `COPY ... FROM STDIN`. Mirrors the file-mode+ API: `MonadBeamCopyToStream` / `MonadBeamCopyFromStream`,+ and the `copyTableToStream` / `copySelectToStream` / `copyTableFromStream` builders.++## Bug fixes++* Fixed an issue where a window function applied over the result of `nub_` (or+ the Postgres-specific `pgNubBy_`) would emit `DISTINCT` and the window+ expression in the same `SELECT`, causing the window to evaluate against the+ pre-deduplicated rows. The inner select is now materialised as a subquery+ whenever it carries `DISTINCT`, `GROUP BY`, or `HAVING` (#756).++## Dependencies++* Removed dependency on `ghc-prim`.++# 0.11.0.0++## New features++* Add projection methods to `MonadBeamInsertReturning`/`MonadBeamUpdateReturning`/`MonadBeamDeleteReturning` (#801).+* Made `genericSerial` be generic over `Integral` rathern than only `Int` (#534).+* Added the `week_` combinator to extract the week of a timestamp (#599).++## Bug fixes++* Changed the type of `values_` to `NonEmpty` rather than a list, preventing runtime exceptions (#742).+* Fixed an issue where `lead1_`, `lag1_`, `lead_`, and `lag_` did not have the appropriate type, leading to runtime exceptions (#745).++# 0.10.5.0++## Updated dependencies++* Updated the upper bound on `time` to include `time-1.14`++## Query combinator API change++* The `Database be db` context has been removed from the query combinators `all_`,+ `allFromView_`, `join_`, `join'`, `related_`, `relatedBy_` and `relatedBy_'`.++ This constraint was not used by any of these functions.++# 0.10.4.0++## Added features++* Added a `Generic` instance to `SqlNull`, `SqlBitString`, and `SqlSerial` (#736).+* Added a note to `default_` to specify that it has more restrictions than its type may indicate (#744).+* Added `limitMaybe_` and `offsetMaybe_` (#633).+++## Updated dependencies++* Updated the upper bound to include `containers-0.8`.++# 0.10.3.1++## Updated dependencies++* Updated the upper bound to include `hashable-1.5`.++## Bug fixes++* The `Pagila` example in `beam-postgres` has been updated to compile using the most recent version of `beam` packages (#729).++## Packaging++* Remove the GHC flag `-O3`, which resulted in increased compilation time by default. This flag can still be activated using your build system of choice, as with every library.++# 0.10.3.0++## Added features++* Export generic classes (#585).++## Bug fixes++ * Fixed an issue where a WHERE clause would be dropped in the absence of a FROM (#695).++# 0.10.2.0++## Added features++ * Added support for creating database schemas and associated tables with `createDatabaseSchema`, `createTableWithSchema`, and `existingDatabaseSchema` (#716).+ * Added `FromBackendRow` instance for `Identity` (#717).++# 0.10.1.0++## Added features++ * Allow embedding database types+ * Loosen some version bounds++# 0.10.0.0++## Bug fixes++ * Make sure lateral join names do not overlap++## Addded features++ * Add `runSelectReturningFirst`+ * `IN (SELECT ...)` syntax via `inQuery_`+ # 0.9.2.1 ## Added features
Database/Beam/Backend/SQL.hs view
@@ -133,6 +133,12 @@ Nothing -> pure (Just x) Just _ -> pure Nothing + -- | Run the given command and fetch the first result. The result is+ -- 'Nothing' if no results are returned.+ -- This is not guaranteed to automatically limit the query to one result.+ runReturningFirst :: FromBackendRow be x => BeamSqlBackendSyntax be -> m (Maybe x)+ runReturningFirst cmd = runReturningMany cmd id+ -- | Run the given command, collect all the results, and return them as a -- list. May be more convenient than 'runReturningMany', but reads the entire -- result set into memory.
Database/Beam/Backend/SQL/AST.hs view
@@ -156,6 +156,7 @@ | ExtractFieldDateTimeYear | ExtractFieldDateTimeMonth+ | ExtractFieldDateTimeWeek | ExtractFieldDateTimeDay | ExtractFieldDateTimeHour | ExtractFieldDateTimeMinute@@ -234,6 +235,7 @@ | ExpressionRow [ Expression ] | ExpressionIn Expression [ Expression ]+ | ExpressionInSelect Expression Select | ExpressionIsNull Expression | ExpressionIsNotNull Expression@@ -290,6 +292,7 @@ minutesField = ExtractFieldDateTimeMinute hourField = ExtractFieldDateTimeHour dayField = ExtractFieldDateTimeDay+ weekField = ExtractFieldDateTimeWeek monthField = ExtractFieldDateTimeMonth yearField = ExtractFieldDateTimeYear @@ -359,6 +362,7 @@ defaultE = ExpressionDefault inE = ExpressionIn+ inSelectE = ExpressionInSelect instance IsSql99FunctionExpressionSyntax Expression where functionNameE = ExpressionNamedFunction@@ -461,6 +465,12 @@ type Sql92GroupingExpressionSyntax Grouping = Expression groupByExpressions = Grouping++data SchemaName = SchemaName Text+ deriving (Show, Eq, Ord)++instance IsSql92SchemaNameSyntax SchemaName where+ schemaName = SchemaName data TableName = TableName (Maybe Text) Text deriving (Show, Eq, Ord)
Database/Beam/Backend/SQL/BeamExtensions.hs view
@@ -9,10 +9,18 @@ -- emulated on others. module Database.Beam.Backend.SQL.BeamExtensions ( MonadBeamInsertReturning(..)+ , runInsertReturningList , MonadBeamUpdateReturning(..)+ , runUpdateReturningList , MonadBeamDeleteReturning(..)+ , runDeleteReturningList , BeamHasInsertOnConflict(..) + -- * Support for copying to external files+ , module Database.Beam.Backend.SQL.BeamExtensions.Copy.File+ -- * Support for streaming copy+ , module Database.Beam.Backend.SQL.BeamExtensions.Copy.Stream+ , SqlSerial(..) , onConflictUpdateInstead , onConflictUpdateAll@@ -38,111 +46,166 @@ import Data.Kind (Type) import Data.Proxy import Data.Semigroup+import Database.Beam.Backend.SQL.BeamExtensions.Copy.File hiding (projection) -- internal function+import Database.Beam.Backend.SQL.BeamExtensions.Copy.Stream --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.+-- | 'MonadBeam's that support returning data from the newly created rows of an+-- @INSERT@ statement. Useful for discovering the real value of a defaulted+-- field (such as a serial primary key). class MonadBeam be m => MonadBeamInsertReturning be m | m -> be where- runInsertReturningList+ -- | Execute an @INSERT@ statement and return a list of values projected from+ -- the inserted rows. The projection function selects which columns are+ -- returned: pass 'id' to return the full row, or supply a custom+ -- projection to return a subset.+ runInsertReturningListWith :: ( Beamable table- , Projectible be (table (QExpr be ()))- , FromBackendRow be (table Identity) )+ , Projectible be a+ , FromBackendRow be (QExprToIdentity a) ) => SqlInsert be table- -> m [table Identity]+ -> (table (QExpr be ()) -> a)+ -> m [QExprToIdentity a] +-- | Execute an @INSERT@ statement and return the inserted rows in full.+-- A convenience around 'runInsertReturningListWith' that uses 'id' as the+-- projection.+runInsertReturningList+ :: ( MonadBeamInsertReturning be m+ , Beamable table+ , Projectible be (table (QExpr be ()))+ , FromBackendRow be (table Identity) )+ => SqlInsert be table+ -> m [table Identity]+runInsertReturningList sql = runInsertReturningListWith sql id+ instance MonadBeamInsertReturning be m => MonadBeamInsertReturning be (ExceptT e m) where- runInsertReturningList = lift . runInsertReturningList+ runInsertReturningListWith sql proj = lift $ runInsertReturningListWith sql proj instance MonadBeamInsertReturning be m => MonadBeamInsertReturning be (ContT r m) where- runInsertReturningList = lift . runInsertReturningList+ runInsertReturningListWith sql proj = lift $ runInsertReturningListWith sql proj instance MonadBeamInsertReturning be m => MonadBeamInsertReturning be (ReaderT r m) where- runInsertReturningList = lift . runInsertReturningList+ runInsertReturningListWith sql proj = lift $ runInsertReturningListWith sql proj instance MonadBeamInsertReturning be m => MonadBeamInsertReturning be (Lazy.StateT r m) where- runInsertReturningList = lift . runInsertReturningList+ runInsertReturningListWith sql proj = lift $ runInsertReturningListWith sql proj instance MonadBeamInsertReturning be m => MonadBeamInsertReturning be (Strict.StateT r m) where- runInsertReturningList = lift . runInsertReturningList+ runInsertReturningListWith sql proj = lift $ runInsertReturningListWith sql proj instance (MonadBeamInsertReturning be m, Monoid r) => MonadBeamInsertReturning be (Lazy.WriterT r m) where- runInsertReturningList = lift . runInsertReturningList+ runInsertReturningListWith sql proj = lift $ runInsertReturningListWith sql proj instance (MonadBeamInsertReturning be m, Monoid r) => MonadBeamInsertReturning be (Strict.WriterT r m) where- runInsertReturningList = lift . runInsertReturningList+ runInsertReturningListWith sql proj = lift $ runInsertReturningListWith sql proj instance (MonadBeamInsertReturning be m, Monoid w) => MonadBeamInsertReturning be (Lazy.RWST r w s m) where- runInsertReturningList = lift . runInsertReturningList+ runInsertReturningListWith sql proj = lift $ runInsertReturningListWith sql proj instance (MonadBeamInsertReturning be m, Monoid w) => MonadBeamInsertReturning be (Strict.RWST r w s m) where- runInsertReturningList = lift . runInsertReturningList+ runInsertReturningListWith sql proj = lift $ runInsertReturningListWith sql proj --- | 'MonadBeam's that support returning the updated rows of an @UPDATE@ statement.--- Useful for discovering the new values of the updated rows.+-- | 'MonadBeam's that support returning data from the updated rows of an+-- @UPDATE@ statement. Useful for observing the post-update values of the+-- affected rows. class MonadBeam be m => MonadBeamUpdateReturning be m | m -> be where- runUpdateReturningList+ -- | Execute an @UPDATE@ statement and return a list of values projected from+ -- the updated rows. The projection function selects which columns are+ -- returned: pass 'id' to return the full row, or supply a custom+ -- projection to return a subset.+ runUpdateReturningListWith :: ( Beamable table- , Projectible be (table (QExpr be ()))- , FromBackendRow be (table Identity) )+ , Projectible be a+ , FromBackendRow be (QExprToIdentity a) ) => SqlUpdate be table- -> m [table Identity]+ -> (table (QExpr be ()) -> a)+ -> m [QExprToIdentity a] +-- | Execute an @UPDATE@ statement and return the updated rows in full.+-- A convenience around 'runUpdateReturningListWith' that uses 'id' as the+-- projection.+runUpdateReturningList+ :: ( MonadBeamUpdateReturning be m+ , Beamable table+ , Projectible be (table (QExpr be ()))+ , FromBackendRow be (table Identity) )+ => SqlUpdate be table+ -> m [table Identity]+runUpdateReturningList sql = runUpdateReturningListWith sql id+ instance MonadBeamUpdateReturning be m => MonadBeamUpdateReturning be (ExceptT e m) where- runUpdateReturningList = lift . runUpdateReturningList+ runUpdateReturningListWith sql proj = lift $ runUpdateReturningListWith sql proj instance MonadBeamUpdateReturning be m => MonadBeamUpdateReturning be (ContT r m) where- runUpdateReturningList = lift . runUpdateReturningList+ runUpdateReturningListWith sql proj = lift $ runUpdateReturningListWith sql proj instance MonadBeamUpdateReturning be m => MonadBeamUpdateReturning be (ReaderT r m) where- runUpdateReturningList = lift . runUpdateReturningList+ runUpdateReturningListWith sql proj = lift $ runUpdateReturningListWith sql proj instance MonadBeamUpdateReturning be m => MonadBeamUpdateReturning be (Lazy.StateT r m) where- runUpdateReturningList = lift . runUpdateReturningList+ runUpdateReturningListWith sql proj = lift $ runUpdateReturningListWith sql proj instance MonadBeamUpdateReturning be m => MonadBeamUpdateReturning be (Strict.StateT r m) where- runUpdateReturningList = lift . runUpdateReturningList+ runUpdateReturningListWith sql proj = lift $ runUpdateReturningListWith sql proj instance (MonadBeamUpdateReturning be m, Monoid r) => MonadBeamUpdateReturning be (Lazy.WriterT r m) where- runUpdateReturningList = lift . runUpdateReturningList+ runUpdateReturningListWith sql proj = lift $ runUpdateReturningListWith sql proj instance (MonadBeamUpdateReturning be m, Monoid r) => MonadBeamUpdateReturning be (Strict.WriterT r m) where- runUpdateReturningList = lift . runUpdateReturningList+ runUpdateReturningListWith sql proj = lift $ runUpdateReturningListWith sql proj instance (MonadBeamUpdateReturning be m, Monoid w) => MonadBeamUpdateReturning be (Lazy.RWST r w s m) where- runUpdateReturningList = lift . runUpdateReturningList+ runUpdateReturningListWith sql proj = lift $ runUpdateReturningListWith sql proj instance (MonadBeamUpdateReturning be m, Monoid w) => MonadBeamUpdateReturning be (Strict.RWST r w s m) where- runUpdateReturningList = lift . runUpdateReturningList+ runUpdateReturningListWith sql proj = lift $ runUpdateReturningListWith sql proj --- | '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.+-- | 'MonadBeam's that support returning data from rows that will be deleted by+-- the given @DELETE@ statement. Useful for deallocating resources based on+-- the value of deleted rows. class MonadBeam be m => MonadBeamDeleteReturning be m | m -> be where- runDeleteReturningList+ -- | Execute a @DELETE@ statement and return a list of values projected from+ -- the deleted rows. The projection function selects which columns are+ -- returned: pass 'id' to return the full row, or supply a custom+ -- projection to return a subset.+ runDeleteReturningListWith :: ( Beamable table- , Projectible be (table (QExpr be ()))- , FromBackendRow be (table Identity) )+ , Projectible be a+ , FromBackendRow be (QExprToIdentity a) ) => SqlDelete be table- -> m [table Identity]+ -> (table (QExpr be ()) -> a)+ -> m [QExprToIdentity a] +-- | Execute a @DELETE@ statement and return the deleted rows in full.+-- A convenience around 'runDeleteReturningListWith' that uses 'id' as the+-- projection.+runDeleteReturningList+ :: ( MonadBeamDeleteReturning be m+ , Beamable table+ , Projectible be (table (QExpr be ()))+ , FromBackendRow be (table Identity) )+ => SqlDelete be table+ -> m [table Identity]+runDeleteReturningList sql = runDeleteReturningListWith sql id+ instance MonadBeamDeleteReturning be m => MonadBeamDeleteReturning be (ExceptT e m) where- runDeleteReturningList = lift . runDeleteReturningList+ runDeleteReturningListWith sql proj = lift $ runDeleteReturningListWith sql proj instance MonadBeamDeleteReturning be m => MonadBeamDeleteReturning be (ContT r m) where- runDeleteReturningList = lift . runDeleteReturningList+ runDeleteReturningListWith sql proj = lift $ runDeleteReturningListWith sql proj instance MonadBeamDeleteReturning be m => MonadBeamDeleteReturning be (ReaderT r m) where- runDeleteReturningList = lift . runDeleteReturningList+ runDeleteReturningListWith sql proj = lift $ runDeleteReturningListWith sql proj instance MonadBeamDeleteReturning be m => MonadBeamDeleteReturning be (Lazy.StateT r m) where- runDeleteReturningList = lift . runDeleteReturningList+ runDeleteReturningListWith sql proj = lift $ runDeleteReturningListWith sql proj instance MonadBeamDeleteReturning be m => MonadBeamDeleteReturning be (Strict.StateT r m) where- runDeleteReturningList = lift . runDeleteReturningList+ runDeleteReturningListWith sql proj = lift $ runDeleteReturningListWith sql proj instance (MonadBeamDeleteReturning be m, Monoid r) => MonadBeamDeleteReturning be (Lazy.WriterT r m) where- runDeleteReturningList = lift . runDeleteReturningList+ runDeleteReturningListWith sql proj = lift $ runDeleteReturningListWith sql proj instance (MonadBeamDeleteReturning be m, Monoid r) => MonadBeamDeleteReturning be (Strict.WriterT r m) where- runDeleteReturningList = lift . runDeleteReturningList+ runDeleteReturningListWith sql proj = lift $ runDeleteReturningListWith sql proj instance (MonadBeamDeleteReturning be m, Monoid w) => MonadBeamDeleteReturning be (Lazy.RWST r w s m) where- runDeleteReturningList = lift . runDeleteReturningList+ runDeleteReturningListWith sql proj = lift $ runDeleteReturningListWith sql proj instance (MonadBeamDeleteReturning be m, Monoid w) => MonadBeamDeleteReturning be (Strict.RWST r w s m) where- runDeleteReturningList = lift . runDeleteReturningList+ runDeleteReturningListWith sql proj = lift $ runDeleteReturningListWith sql proj class BeamSqlBackend be => BeamHasInsertOnConflict be where -- | Specifies the kind of constraint that must be violated for the action to occur
+ Database/Beam/Backend/SQL/BeamExtensions/Copy/File.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE UndecidableInstances #-}++-- | File-mode @COPY@: the data lives on the database server's filesystem.+--+-- For the variant that streams data through the client connection instead, see+-- "Database.Beam.Backend.SQL.BeamExtensions.Copy.Stream".+module Database.Beam.Backend.SQL.BeamExtensions.Copy.File+ ( -- * Building a COPY statement+ copyTableTo,+ copySelectTo,+ SqlCopyTo (..),+ copyTableFrom,+ SqlCopyFrom (..),++ -- * Source-syntax classes (shared with streaming COPY)+ IsSqlCopyToSourceSyntax (..),+ IsSqlCopyFromSourceSyntax (..),++ -- * File-mode statement-level syntax classes+ IsSqlCopyToSyntax (..),+ IsSqlCopyFromSyntax (..),+ BeamSqlBackendCopyToSyntax,+ BeamSqlBackendCopyFromSyntax,++ -- * Runner classes+ MonadBeamCopyTo (..),+ MonadBeamCopyFrom (..),++ -- * Internal — exposed for use by sibling modules+ projection,+ )+where++import Control.Monad.Cont (ContT)+import Control.Monad.Except (ExceptT)+import qualified Control.Monad.RWS.Lazy as Lazy+import qualified Control.Monad.RWS.Strict as Strict+import Control.Monad.Reader (ReaderT)+import qualified Control.Monad.State.Lazy as Lazy+import qualified Control.Monad.State.Strict as Strict+import Control.Monad.Trans (lift)+import qualified Control.Monad.Writer.Lazy as Lazy+import qualified Control.Monad.Writer.Strict as Strict+import Data.Data (Proxy (..))+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty, nonEmpty)+import Data.Text (Text)+import Database.Beam.Backend.SQL (BeamSqlBackendSelectSyntax, MonadBeam (..))+import Database.Beam.Query (QField, SqlSelect (..))+import Database.Beam.Query.Internal (AnyType, ProjectibleWithPredicate, QField (..), project')+import Database.Beam.Schema (TableEntity)+import Database.Beam.Schema.Tables+ ( Beamable,+ Columnar' (..),+ DatabaseEntity (..),+ DatabaseEntityDescriptor (DatabaseTable, dbTableSettings),+ IsDatabaseEntity (dbEntityName, dbEntitySchema),+ changeBeamRep,+ fieldName,+ )+import Lens.Micro ((^.))++-- | This class allows to express the source of a `COPY ... TO` statement.+-- The options are either from a table (with a possible projection),+-- or from the result of a select query.+--+-- Reused by both file-mode and streaming COPY: the source shape (a table or+-- a @SELECT@) is the same regardless of where the data ends up.+class IsSqlCopyToSourceSyntax syntax where+ -- | Expected to be equal to `BeamSqlBackendSelectSyntax be`+ type SqlCopyToSourceSelectSyntax syntax :: Type++ -- Copy an entire table, perhaps with some column projections+ copyTableToSyntax ::+ Maybe Text -> -- schema (Nothing = default search path)+ Text -> -- table name+ Maybe (NonEmpty Text) -> -- column list; `Nothing` means "all columns"+ syntax++ -- Copy the result of a select statement+ copySelectToSyntax ::+ SqlCopyToSourceSelectSyntax syntax ->+ syntax++-- | This class allows to express the source of a `COPY ... FROM` statement.+-- Reused by both file-mode and streaming COPY.+class IsSqlCopyFromSourceSyntax syntax where+ -- Copy data into a table, perhaps with some column projections+ copyTableFromSyntax ::+ Maybe Text -> -- schema (Nothing = default search path)+ Text -> -- table name+ Maybe (NonEmpty Text) -> -- column list; `Nothing` means "all columns"+ syntax++-- | Statement-level syntax for backends that support @COPY ... TO@ file.+class (IsSqlCopyToSourceSyntax (SqlCopyToSourceSyntax cmd)) => IsSqlCopyToSyntax cmd where+ -- | The syntax for the source of the copy. For example, in Postgres,+ -- this can be either a table (and optional projection), or a select statement.+ type SqlCopyToSourceSyntax cmd :: Type++ -- | All backend-specific options which determine HOW the copy is performed,+ -- including the destination of the data (e.g. a filepath).+ type SqlCopyToParams cmd :: Type++ -- | Combine a source and a parameters value into a complete+ -- @COPY ... TO ...@ statement.+ copyToStmt ::+ SqlCopyToSourceSyntax cmd ->+ SqlCopyToParams cmd ->+ cmd++-- | Statement-level syntax for backends that support file-mode @COPY ... FROM@ file.+--+-- Symmetric to 'IsSqlCopyToSyntax', but the data flows in the opposite+-- direction: the params value supplies the source path and any+-- format-specific options.+class (IsSqlCopyFromSourceSyntax (SqlCopyFromSourceSyntax cmd)) => IsSqlCopyFromSyntax cmd where+ -- | The syntax for the destination table of the copy.+ type SqlCopyFromSourceSyntax cmd :: Type++ -- | All backend-specific options which determine HOW the copy is performed,+ -- including the source of the data (e.g. a filepath).+ type SqlCopyFromParams cmd :: Type++ -- | Combine a destination and a parameters value into a complete+ -- @COPY ... FROM ...@ statement.+ copyFromStmt ::+ SqlCopyFromSourceSyntax cmd ->+ SqlCopyFromParams cmd ->+ cmd++-- | Type-family selector for the backend's file-mode @COPY ... TO@ syntax.+-- A backend instance binds this to the concrete syntax type that implements+-- 'IsSqlCopyToSyntax'.+type family BeamSqlBackendCopyToSyntax be :: Type++-- | Type-family selector for the backend's file-mode @COPY ... FROM@ syntax.+-- See 'BeamSqlBackendCopyToSyntax'.+type family BeamSqlBackendCopyFromSyntax be :: Type++-- | A built file-mode @COPY ... TO@ statement, ready to be executed by+-- 'runCopyTo'. Construct via 'copyTableTo' or 'copySelectTo'; the @table@+-- and @proj@ phantom parameters track which table the statement applies to+-- and which columns it projects.+data SqlCopyTo be a+ = SqlCopyTo !(BeamSqlBackendCopyToSyntax be)+ | -- | A projection covering zero columns. 'runCopyTo' should treat this as a+ -- no-op rather than emit an empty @COPY tbl () TO ...@ statement.+ SqlCopyToNoColumns++-- | A built file-mode @COPY ... FROM@ statement, ready to be executed by+-- 'runCopyFrom'. Construct via 'copyTableFrom'.+data SqlCopyFrom be a+ = SqlCopyFrom !(BeamSqlBackendCopyFromSyntax be)+ | -- | A projection covering zero columns. 'runCopyFrom' should treat this as+ -- a no-op rather than emit an empty @COPY tbl () FROM ...@ statement.+ SqlCopyFromNoColumns++-- | Express the copy from a table, to a destination (typically a file).+--+-- To copy the result of a @SELECT@ query instead, see `copySelectTo`.+--+-- @since 0.11.1.0+copyTableTo ::+ ( IsSqlCopyToSyntax (BeamSqlBackendCopyToSyntax be),+ ProjectibleWithPredicate AnyType () Text proj+ ) =>+ DatabaseEntity be db (TableEntity table) ->+ -- | Projection from table to columns. If you want+ -- to copy the entire table, use 'id'.+ (table (QField s) -> proj) ->+ -- | Backend-specific options. The output is also determined by this value+ SqlCopyToParams (BeamSqlBackendCopyToSyntax be) ->+ SqlCopyTo be proj+copyTableTo (DatabaseEntity dt@(DatabaseTable {})) mkProj options =+ case nonEmpty (projection dt mkProj) of+ Nothing -> SqlCopyToNoColumns+ Just cols ->+ let source = copyTableToSyntax (dt ^. dbEntitySchema) (dt ^. dbEntityName) (Just cols)+ in SqlCopyTo+ (copyToStmt source options)++-- | Express the copy from the result of a @SELECT@ statement to a destination+-- (typically a file). Use this when the source rows are produced by a query+-- rather than read directly from a table.+--+-- To copy a table, or a subset of columns, see `copyTableTo`.+--+-- @since 0.11.1.0+copySelectTo ::+ ( IsSqlCopyToSyntax (BeamSqlBackendCopyToSyntax be),+ SqlCopyToSourceSelectSyntax (SqlCopyToSourceSyntax (BeamSqlBackendCopyToSyntax be))+ ~ BeamSqlBackendSelectSyntax be+ ) =>+ SqlSelect be a ->+ -- | Backend-specific options. The format is pinned by this value+ SqlCopyToParams (BeamSqlBackendCopyToSyntax be) ->+ SqlCopyTo be a+copySelectTo (SqlSelect selectSyntax) options =+ let source = copySelectToSyntax selectSyntax+ in SqlCopyTo (copyToStmt source options)++-- | Express the copy to a table, from an external source (typically a file).+--+-- @since 0.11.1.0+copyTableFrom ::+ ( IsSqlCopyFromSyntax (BeamSqlBackendCopyFromSyntax be),+ ProjectibleWithPredicate AnyType () Text proj+ ) =>+ DatabaseEntity be db (TableEntity table) ->+ -- | Projection from table to columns. If you want+ -- to copy into the entire table, use 'id'.+ (table (QField s) -> proj) ->+ -- | Backend-specific options. The format is pinned by this value+ SqlCopyFromParams (BeamSqlBackendCopyFromSyntax be) ->+ SqlCopyFrom be proj+copyTableFrom (DatabaseEntity dt@(DatabaseTable {})) mkProj options =+ case nonEmpty (projection dt mkProj) of+ Nothing -> SqlCopyFromNoColumns+ Just cols ->+ let source = copyTableFromSyntax (dt ^. dbEntitySchema) (dt ^. dbEntityName) (Just cols)+ in SqlCopyFrom+ (copyFromStmt source options)++-- | Walk a projection and collect the names of the columns it touches.+--+-- This is the building block 'copyTableTo' / 'copyTableFrom' (and their+-- streaming counterparts) use to derive the column list for the emitted+-- @COPY@ statement. Exposed here so that the streaming submodule can reuse+-- the same logic without duplication.+projection ::+ (ProjectibleWithPredicate AnyType () Text proj, Beamable table) =>+ DatabaseEntityDescriptor be (TableEntity table) ->+ (table (QField s) -> proj) ->+ [Text]+projection dt mkProj =+ Strict.execWriter+ ( project'+ (Proxy @AnyType)+ (Proxy @((), Text))+ (\_ _ f -> Strict.tell [f] >> pure f)+ (mkProj tblFields)+ )+ where+ tblFields =+ changeBeamRep+ (\(Columnar' fd) -> Columnar' (QField False (dt ^. dbEntityName) (fd ^. fieldName)))+ (dbTableSettings dt)++-- | 'MonadBeam's that support copying data out of a database, to some other location.+--+-- See 'MonadBeamCopyFrom' for the inverse operation.+--+-- @since 0.11.1.0+class (MonadBeam be m) => MonadBeamCopyTo be m | m -> be where+ -- | Execute a built @COPY ... TO@ file statement.+ runCopyTo :: SqlCopyTo be res -> m ()++instance (MonadBeamCopyTo be m) => MonadBeamCopyTo be (ExceptT e m) where+ runCopyTo = lift . runCopyTo++instance (MonadBeamCopyTo be m) => MonadBeamCopyTo be (ContT r m) where+ runCopyTo = lift . runCopyTo++instance (MonadBeamCopyTo be m) => MonadBeamCopyTo be (ReaderT r m) where+ runCopyTo = lift . runCopyTo++instance (MonadBeamCopyTo be m) => MonadBeamCopyTo be (Lazy.StateT r m) where+ runCopyTo = lift . runCopyTo++instance (MonadBeamCopyTo be m) => MonadBeamCopyTo be (Strict.StateT r m) where+ runCopyTo = lift . runCopyTo++instance (MonadBeamCopyTo be m, Monoid r) => MonadBeamCopyTo be (Lazy.WriterT r m) where+ runCopyTo = lift . runCopyTo++instance (MonadBeamCopyTo be m, Monoid r) => MonadBeamCopyTo be (Strict.WriterT r m) where+ runCopyTo = lift . runCopyTo++instance (MonadBeamCopyTo be m, Monoid w) => MonadBeamCopyTo be (Lazy.RWST r w s m) where+ runCopyTo = lift . runCopyTo++instance (MonadBeamCopyTo be m, Monoid w) => MonadBeamCopyTo be (Strict.RWST r w s m) where+ runCopyTo = lift . runCopyTo++-- | 'MonadBeam's that support copying data into database, from other location.+--+-- See 'MonadBeamCopyTo' for the inverse operation.+--+-- @since 0.11.1.0+class (MonadBeam be m) => MonadBeamCopyFrom be m | m -> be where+ -- | Execute a built @COPY ... FROM@ file statement.+ runCopyFrom :: SqlCopyFrom be proj -> m ()++instance (MonadBeamCopyFrom be m) => MonadBeamCopyFrom be (ExceptT e m) where+ runCopyFrom = lift . runCopyFrom++instance (MonadBeamCopyFrom be m) => MonadBeamCopyFrom be (ContT r m) where+ runCopyFrom = lift . runCopyFrom++instance (MonadBeamCopyFrom be m) => MonadBeamCopyFrom be (ReaderT r m) where+ runCopyFrom = lift . runCopyFrom++instance (MonadBeamCopyFrom be m) => MonadBeamCopyFrom be (Lazy.StateT r m) where+ runCopyFrom = lift . runCopyFrom++instance (MonadBeamCopyFrom be m) => MonadBeamCopyFrom be (Strict.StateT r m) where+ runCopyFrom = lift . runCopyFrom++instance (MonadBeamCopyFrom be m, Monoid r) => MonadBeamCopyFrom be (Lazy.WriterT r m) where+ runCopyFrom = lift . runCopyFrom++instance (MonadBeamCopyFrom be m, Monoid r) => MonadBeamCopyFrom be (Strict.WriterT r m) where+ runCopyFrom = lift . runCopyFrom++instance (MonadBeamCopyFrom be m, Monoid w) => MonadBeamCopyFrom be (Lazy.RWST r w s m) where+ runCopyFrom = lift . runCopyFrom++instance (MonadBeamCopyFrom be m, Monoid w) => MonadBeamCopyFrom be (Strict.RWST r w s m) where+ runCopyFrom = lift . runCopyFrom
+ Database/Beam/Backend/SQL/BeamExtensions/Copy/Stream.hs view
@@ -0,0 +1,289 @@+{-# LANGUAGE UndecidableInstances #-}++-- | Streaming-mode @COPY@: the data flows through the client connection+-- rather than to or from a file on the database server.+--+-- For the file-mode variant, see+-- "Database.Beam.Backend.SQL.BeamExtensions.Copy.File".+module Database.Beam.Backend.SQL.BeamExtensions.Copy.Stream+ ( -- * Building a streaming COPY statement+ copyTableToStream,+ copySelectToStream,+ SqlCopyToStream (..),+ copyTableFromStream,+ SqlCopyFromStream (..),++ -- * Streaming statement-level syntax classes+ IsSqlCopyToStreamSyntax (..),+ IsSqlCopyFromStreamSyntax (..),+ BeamSqlBackendCopyToStreamSyntax,+ BeamSqlBackendCopyFromStreamSyntax,++ -- * Runner classes+ MonadBeamCopyToStream (..),+ MonadBeamCopyFromStream (..),+ )+where++import Control.Monad.Cont (ContT)+import Control.Monad.Except (ExceptT)+import qualified Control.Monad.RWS.Lazy as Lazy+import qualified Control.Monad.RWS.Strict as Strict+import Control.Monad.Reader (ReaderT)+import qualified Control.Monad.State.Lazy as Lazy+import qualified Control.Monad.State.Strict as Strict+import Control.Monad.Trans (lift)+import qualified Control.Monad.Writer.Lazy as Lazy+import qualified Control.Monad.Writer.Strict as Strict+import Data.ByteString (ByteString)+import Data.Kind (Type)+import Data.List.NonEmpty (nonEmpty)+import Data.Text (Text)+import Database.Beam.Backend.SQL (BeamSqlBackendSelectSyntax, MonadBeam)+import Database.Beam.Backend.SQL.BeamExtensions.Copy.File+ ( IsSqlCopyFromSourceSyntax (..),+ IsSqlCopyToSourceSyntax (..),+ projection,+ )+import Database.Beam.Query (QField, SqlSelect (..))+import Database.Beam.Query.Internal (AnyType, ProjectibleWithPredicate)+import Database.Beam.Schema (TableEntity)+import Database.Beam.Schema.Tables+ ( DatabaseEntity (..),+ DatabaseEntityDescriptor (DatabaseTable),+ IsDatabaseEntity (dbEntityName, dbEntitySchema),+ )+import Lens.Micro ((^.))++-- | Statement-level syntax for backends that support streaming+-- @COPY ... TO@ (data leaving the database through the client connection).+--+-- Mirrors 'Database.Beam.Backend.SQL.BeamExtensions.Copy.File.IsSqlCopyToSyntax',+-- but the params value carries only format options — no destination path,+-- since chunks travel through the wire.+class (IsSqlCopyToSourceSyntax (SqlCopyToStreamSourceSyntax cmd)) => IsSqlCopyToStreamSyntax cmd where+ -- | The syntax for the source of the streaming copy. As with file-mode+ -- COPY, this can be a table (perhaps with a projection) or a @SELECT@+ -- query.+ type SqlCopyToStreamSourceSyntax cmd :: Type++ -- | All backend-specific options which determine HOW the streaming copy+ -- is performed (format, delimiter, etc.). Unlike the file-mode params,+ -- there is no destination — chunks flow through the connection.+ type SqlCopyToStreamParams cmd :: Type++ -- | Combine a source and a parameters value into a complete+ -- streaming @COPY ... TO@ stream statement.+ copyToStreamStmt ::+ SqlCopyToStreamSourceSyntax cmd ->+ SqlCopyToStreamParams cmd ->+ cmd++-- | Statement-level syntax for backends that support streaming+-- @COPY ... FROM@ (data entering the database through the client connection).+--+-- Mirrors 'Database.Beam.Backend.SQL.BeamExtensions.Copy.File.IsSqlCopyFromSyntax'.+class (IsSqlCopyFromSourceSyntax (SqlCopyFromStreamSourceSyntax cmd)) => IsSqlCopyFromStreamSyntax cmd where+ -- | The syntax for the destination table of the streaming copy.+ type SqlCopyFromStreamSourceSyntax cmd :: Type++ -- | All backend-specific options which determine HOW the streaming copy+ -- is performed. Unlike the file-mode params, there is no source path —+ -- chunks flow through the connection.+ type SqlCopyFromStreamParams cmd :: Type++ -- | Combine a destination and a parameters value into a complete+ -- streaming @COPY ... FROM@ stream statement.+ copyFromStreamStmt ::+ SqlCopyFromStreamSourceSyntax cmd ->+ SqlCopyFromStreamParams cmd ->+ cmd++-- | Type-family selector for the backend's streaming @COPY ... TO@ syntax.+-- A backend instance binds this to the concrete syntax type that+-- implements 'IsSqlCopyToStreamSyntax'.+type family BeamSqlBackendCopyToStreamSyntax be :: Type++-- | Type-family selector for the backend's streaming @COPY ... FROM@ syntax.+-- See 'BeamSqlBackendCopyToStreamSyntax'.+type family BeamSqlBackendCopyFromStreamSyntax be :: Type++-- | A built streaming-mode @COPY ... TO@ statement, ready to be executed by+-- 'runCopyToStream'.+data SqlCopyToStream be a+ = SqlCopyToStream !(BeamSqlBackendCopyToStreamSyntax be)+ | -- | A projection covering zero columns. 'runCopyToStream' should treat+ -- this as a no-op (it must still call the sink zero times) rather+ -- than emit an empty @COPY tbl () TO STDOUT@ statement.+ SqlCopyToStreamNoColumns++-- | A built streaming-mode @COPY ... FROM@ statement, ready to be executed+-- by 'runCopyFromStream'.+data SqlCopyFromStream be a+ = SqlCopyFromStream !(BeamSqlBackendCopyFromStreamSyntax be)+ | -- | A projection covering zero columns. 'runCopyFromStream' should+ -- treat this as a no-op (it should not pull from the source) rather+ -- than emit an empty @COPY tbl () FROM STDIN@ statement.+ SqlCopyFromStreamNoColumns++-- | Express a streaming copy from a table, the data flowing through the+-- client connection rather than to a server-side file.+--+-- To stream the result of a @SELECT@ query instead, see 'copySelectToStream'.+--+-- @since 0.11.1.0+copyTableToStream ::+ ( IsSqlCopyToStreamSyntax (BeamSqlBackendCopyToStreamSyntax be),+ ProjectibleWithPredicate AnyType () Text proj+ ) =>+ DatabaseEntity be db (TableEntity table) ->+ -- | Projection from table to columns. If you want+ -- to copy the entire table, use 'id'.+ (table (QField s) -> proj) ->+ -- | Backend-specific options.+ SqlCopyToStreamParams (BeamSqlBackendCopyToStreamSyntax be) ->+ SqlCopyToStream be proj+copyTableToStream (DatabaseEntity dt@(DatabaseTable {})) mkProj options =+ case nonEmpty (projection dt mkProj) of+ Nothing -> SqlCopyToStreamNoColumns+ Just cols ->+ let source = copyTableToSyntax (dt ^. dbEntitySchema) (dt ^. dbEntityName) (Just cols)+ in SqlCopyToStream+ (copyToStreamStmt source options)++-- | Express a streaming copy from the result of a @SELECT@ statement.+--+-- To stream a table, or a subset of columns, see 'copyTableToStream'.+--+-- @since 0.11.1.0+copySelectToStream ::+ ( IsSqlCopyToStreamSyntax (BeamSqlBackendCopyToStreamSyntax be),+ SqlCopyToSourceSelectSyntax (SqlCopyToStreamSourceSyntax (BeamSqlBackendCopyToStreamSyntax be))+ ~ BeamSqlBackendSelectSyntax be+ ) =>+ SqlSelect be a ->+ SqlCopyToStreamParams (BeamSqlBackendCopyToStreamSyntax be) ->+ SqlCopyToStream be a+copySelectToStream (SqlSelect selectSyntax) options =+ let source = copySelectToSyntax selectSyntax+ in SqlCopyToStream (copyToStreamStmt source options)++-- | Express a streaming copy into a table, the data flowing through the+-- client connection rather than from a server-side file.+--+-- @since 0.11.1.0+copyTableFromStream ::+ ( IsSqlCopyFromStreamSyntax (BeamSqlBackendCopyFromStreamSyntax be),+ ProjectibleWithPredicate AnyType () Text proj+ ) =>+ DatabaseEntity be db (TableEntity table) ->+ -- | Projection from which to copy columns. Other columns+ -- will have their default value inserted.+ --+ -- To copy the stream into the entire table, use 'id'.+ (table (QField s) -> proj) ->+ SqlCopyFromStreamParams (BeamSqlBackendCopyFromStreamSyntax be) ->+ SqlCopyFromStream be proj+copyTableFromStream (DatabaseEntity dt@(DatabaseTable {})) mkProj options =+ case nonEmpty (projection dt mkProj) of+ Nothing -> SqlCopyFromStreamNoColumns+ Just cols ->+ let source = copyTableFromSyntax (dt ^. dbEntitySchema) (dt ^. dbEntityName) (Just cols)+ in SqlCopyFromStream+ (copyFromStreamStmt source options)++-- | 'MonadBeam's that support streaming data out of a database through the+-- client connection (e.g. PostgreSQL's @COPY ... TO STDOUT@).+--+-- The supplied @ByteString -> IO ()@ callback is invoked once per chunk+-- received. The 'runCopyToStream' call blocks until the COPY completes; on+-- failure it raises the underlying backend's exception.+--+-- See 'MonadBeamCopyFromStream' for the inverse operation.+--+-- @since 0.11.1.0+class (MonadBeam be m) => MonadBeamCopyToStream be m | m -> be where+ -- | Execute a built streaming @COPY ... TO@ stream statement. The supplied sink+ -- is invoked from 'IO' once per chunk emitted by the server, in order;+ -- 'runCopyToStream' returns once the server signals end of stream.+ runCopyToStream ::+ SqlCopyToStream be a ->+ -- | Sink. Called once for each chunk of bytes the server emits.+ (ByteString -> IO ()) ->+ m ()++instance (MonadBeamCopyToStream be m) => MonadBeamCopyToStream be (ExceptT e m) where+ runCopyToStream s cb = lift (runCopyToStream s cb)++instance (MonadBeamCopyToStream be m) => MonadBeamCopyToStream be (ContT r m) where+ runCopyToStream s cb = lift (runCopyToStream s cb)++instance (MonadBeamCopyToStream be m) => MonadBeamCopyToStream be (ReaderT r m) where+ runCopyToStream s cb = lift (runCopyToStream s cb)++instance (MonadBeamCopyToStream be m) => MonadBeamCopyToStream be (Lazy.StateT r m) where+ runCopyToStream s cb = lift (runCopyToStream s cb)++instance (MonadBeamCopyToStream be m) => MonadBeamCopyToStream be (Strict.StateT r m) where+ runCopyToStream s cb = lift (runCopyToStream s cb)++instance (MonadBeamCopyToStream be m, Monoid r) => MonadBeamCopyToStream be (Lazy.WriterT r m) where+ runCopyToStream s cb = lift (runCopyToStream s cb)++instance (MonadBeamCopyToStream be m, Monoid r) => MonadBeamCopyToStream be (Strict.WriterT r m) where+ runCopyToStream s cb = lift (runCopyToStream s cb)++instance (MonadBeamCopyToStream be m, Monoid w) => MonadBeamCopyToStream be (Lazy.RWST r w s m) where+ runCopyToStream s cb = lift (runCopyToStream s cb)++instance (MonadBeamCopyToStream be m, Monoid w) => MonadBeamCopyToStream be (Strict.RWST r w s m) where+ runCopyToStream s cb = lift (runCopyToStream s cb)++-- | 'MonadBeam's that support streaming data into a database through the+-- client connection (e.g. PostgreSQL's @COPY ... FROM STDIN@).+--+-- The supplied @IO (Maybe ByteString)@ source is pulled repeatedly until it+-- returns 'Nothing', signalling end of data. 'runCopyFromStream' blocks+-- until the COPY commits; on failure it raises the underlying backend's+-- exception.+--+-- See 'MonadBeamCopyToStream' for the inverse operation.+--+-- @since 0.11.1.0+class (MonadBeam be m) => MonadBeamCopyFromStream be m | m -> be where+ -- | Execute a built streaming @COPY ... FROM@ statement. The supplied+ -- producer is pulled from 'IO' until it returns 'Nothing'; each 'Just'+ -- chunk is forwarded to the server in order. 'runCopyFromStream' returns+ -- once the server has acknowledged the end of stream.+ runCopyFromStream ::+ SqlCopyFromStream be a ->+ -- | Source. Called repeatedly. 'Nothing' signals end of data.+ IO (Maybe ByteString) ->+ m ()++instance (MonadBeamCopyFromStream be m) => MonadBeamCopyFromStream be (ExceptT e m) where+ runCopyFromStream s producer = lift (runCopyFromStream s producer)++instance (MonadBeamCopyFromStream be m) => MonadBeamCopyFromStream be (ContT r m) where+ runCopyFromStream s producer = lift (runCopyFromStream s producer)++instance (MonadBeamCopyFromStream be m) => MonadBeamCopyFromStream be (ReaderT r m) where+ runCopyFromStream s producer = lift (runCopyFromStream s producer)++instance (MonadBeamCopyFromStream be m) => MonadBeamCopyFromStream be (Lazy.StateT r m) where+ runCopyFromStream s producer = lift (runCopyFromStream s producer)++instance (MonadBeamCopyFromStream be m) => MonadBeamCopyFromStream be (Strict.StateT r m) where+ runCopyFromStream s producer = lift (runCopyFromStream s producer)++instance (MonadBeamCopyFromStream be m, Monoid r) => MonadBeamCopyFromStream be (Lazy.WriterT r m) where+ runCopyFromStream s producer = lift (runCopyFromStream s producer)++instance (MonadBeamCopyFromStream be m, Monoid r) => MonadBeamCopyFromStream be (Strict.WriterT r m) where+ runCopyFromStream s producer = lift (runCopyFromStream s producer)++instance (MonadBeamCopyFromStream be m, Monoid w) => MonadBeamCopyFromStream be (Lazy.RWST r w s m) where+ runCopyFromStream s producer = lift (runCopyFromStream s producer)++instance (MonadBeamCopyFromStream be m, Monoid w) => MonadBeamCopyFromStream be (Strict.RWST r w s m) where+ runCopyFromStream s producer = lift (runCopyFromStream s producer)
Database/Beam/Backend/SQL/Builder.hs view
@@ -191,6 +191,7 @@ minutesField = SqlSyntaxBuilder (byteString "MINUTE") hourField = SqlSyntaxBuilder (byteString "HOUR") dayField = SqlSyntaxBuilder (byteString "DAY")+ weekField = SqlSyntaxBuilder (byteString "WEEK") monthField = SqlSyntaxBuilder (byteString "MONTH") yearField = SqlSyntaxBuilder (byteString "YEAR") @@ -272,7 +273,9 @@ defaultE = SqlSyntaxBuilder (byteString "DEFAULT") inE a es = SqlSyntaxBuilder (byteString "(" <> buildSql a <> byteString ") IN (" <>- buildSepBy (byteString ", ") (map buildSql es))+ buildSepBy (byteString ", ") (map buildSql es) <> byteString ")")+ inSelectE a sel = SqlSyntaxBuilder (byteString "(" <> buildSql a <> byteString ") IN (" <>+ buildSql sel <> byteString ")") instance IsSql99FunctionExpressionSyntax SqlSyntaxBuilder where functionNameE fn = SqlSyntaxBuilder (byteString (TE.encodeUtf8 fn))@@ -402,6 +405,9 @@ (map (\vs -> byteString "(" <> buildSepBy (byteString ", ") (map buildSql vs) <> byteString ")") vss)++instance IsSql92SchemaNameSyntax SqlSyntaxBuilder where+ schemaName = SqlSyntaxBuilder . quoteSql instance IsSql92TableNameSyntax SqlSyntaxBuilder where tableName Nothing t = SqlSyntaxBuilder $ quoteSql t
Database/Beam/Backend/SQL/Row.hs view
@@ -13,6 +13,9 @@ , ColumnParseError(..), BeamRowReadError(..) , FromBackendRow(..)++ -- * Exported so we can override defaults+ , GFromBackendRow(..) -- for 'runSelectReturningList' and co ) where import Database.Beam.Backend.SQL.Types@@ -20,6 +23,7 @@ import Control.Applicative import Control.Exception (Exception)+import Control.Monad import Control.Monad.Free.Church import Control.Monad.Identity import Data.Kind (Type)@@ -101,6 +105,8 @@ valuesNeeded :: Proxy be -> Proxy a -> Int valuesNeeded _ _ = 1 +deriving instance FromBackendRow be a => FromBackendRow be (Identity a)+ class GFromBackendRow be (exposed :: Type -> Type) rep where gFromBackendRow :: Proxy exposed -> FromBackendRowM be (rep ()) gValuesNeeded :: Proxy be -> Proxy exposed -> Proxy rep -> Int@@ -114,6 +120,9 @@ 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 x => GFromBackendRow be (K1 R (Exposed x)) (K1 R (Identity 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
Database/Beam/Backend/SQL/SQL92.hs view
@@ -206,6 +206,7 @@ minutesField :: extractField hourField :: extractField dayField :: extractField+ weekField :: extractField monthField :: extractField yearField :: extractField @@ -315,6 +316,7 @@ defaultE :: expr inE :: expr -> [ expr ] -> expr+ inSelectE :: expr -> Sql92ExpressionSelectSyntax expr -> expr instance HasSqlValueSyntax syntax x => HasSqlValueSyntax syntax (SqlSerial x) where sqlValueSyntax (SqlSerial x) = sqlValueSyntax x@@ -341,6 +343,10 @@ type Sql92OrderingExpressionSyntax ord :: Type ascOrdering, descOrdering :: Sql92OrderingExpressionSyntax ord -> ord++class IsSql92SchemaNameSyntax schemaName where+ schemaName :: Text {-^ Schema name -}+ -> schemaName class IsSql92TableNameSyntax tblName where tableName :: Maybe Text {-^ Schema -}
Database/Beam/Backend/SQL/Types.hs view
@@ -3,14 +3,15 @@ import qualified Data.Aeson as Json import Data.Bits+import GHC.Generics (Generic) data SqlNull = SqlNull- deriving (Show, Eq, Ord, Bounded, Enum)+ deriving (Show, Eq, Ord, Bounded, Enum, Generic) newtype SqlBitString = SqlBitString Integer- deriving (Show, Eq, Ord, Enum, Bits)+ deriving (Show, Eq, Ord, Enum, Bits, Generic) newtype SqlSerial a = SqlSerial { unSerial :: a }- deriving (Show, Read, Eq, Ord, Num, Integral, Real, Enum)+ deriving (Show, Read, Eq, Ord, Num, Integral, Real, Enum, Generic) instance Json.FromJSON a => Json.FromJSON (SqlSerial a) where parseJSON a = SqlSerial <$> Json.parseJSON a
Database/Beam/Backend/Types.hs view
@@ -6,8 +6,8 @@ , Exposed, Nullable ) where+import Data.Kind (Type, Constraint) -import GHC.Types -- | Class for all Beam backends class BeamBackend be where
Database/Beam/Query.hs view
@@ -45,6 +45,7 @@ , HasTableEquality , SqlEq(..), SqlOrd(..), SqlIn(..) , HasSqlInTable(..)+ , inQuery_ -- ** Quantified Comparison Operators #quantified-comparison-operator# , SqlEqQuantified(..), SqlOrdQuantified(..)@@ -64,6 +65,7 @@ , select, selectWith, lookup_ , runSelectReturningList , runSelectReturningOne+ , runSelectReturningFirst , dumpSqlSelect -- ** @INSERT@@@ -194,6 +196,15 @@ SqlSelect be a -> m (Maybe a) runSelectReturningOne (SqlSelect s) = runReturningOne (selectCmd s)++-- | Run a 'SqlSelect' in a 'MonadBeam' and get the first result, if there is+-- one.+-- This is not guaranteed to automatically limit the query to one result.+runSelectReturningFirst ::+ (MonadBeam be m, BeamSqlBackend be, FromBackendRow be a) =>+ SqlSelect be a -> m (Maybe a)+runSelectReturningFirst (SqlSelect s) =+ runReturningFirst (selectCmd s) -- | Use a special debug syntax to print out an ANSI Standard @SELECT@ statement -- that may be generated for a given 'Q'.
Database/Beam/Query/CTE.hs view
@@ -8,8 +8,9 @@ import Database.Beam.Query.Internal import Database.Beam.Query.Types +import Control.Monad.Fix import Control.Monad.Free.Church-import Control.Monad.Writer hiding ((<>))+import Control.Monad.Writer (WriterT, tell) import Control.Monad.State.Strict import Data.Kind (Type)
Database/Beam/Query/Combinators.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE CPP #-} module Database.Beam.Query.Combinators ( -- * Various SQL functions and constructs@@ -41,7 +40,8 @@ , QIfCond, QIfElse , (<|>.) - , limit_, offset_+ , limit_, limitMaybe_+ , offset_, offsetMaybe_ , as_ @@ -66,8 +66,8 @@ , orderBy_, asc_, desc_, nullsFirst_, nullsLast_ ) where -import Database.Beam.Backend.Types import Database.Beam.Backend.SQL+import Database.Beam.Backend.Types import Database.Beam.Query.Internal import Database.Beam.Query.Ord@@ -80,41 +80,49 @@ import Control.Monad.Free import Control.Applicative +import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe import Data.Proxy import Data.Time (LocalTime)+import Unsafe.Coerce (unsafeCoerce) import GHC.TypeLits (TypeError, ErrorMessage(Text)) -- | Introduce all entries of a table into the 'Q' monad-all_ :: ( Database be db, BeamSqlBackend be )- => DatabaseEntity be db (TableEntity table)- -> Q be db s (table (QExpr be s))+all_ :: BeamSqlBackend be+ => DatabaseEntity be db (TableEntity table)+ -> 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_ :: ( Database be db, Beamable table- , BeamSqlBackend be )- => DatabaseEntity be db (ViewEntity table)- -> Q be db s (table (QExpr be s))+allFromView_ :: ( Beamable table, BeamSqlBackend be )+ => DatabaseEntity be db (ViewEntity table)+ -> 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) --- | SQL @VALUES@ clause. Introduce the elements of the given list as+-- | SQL @VALUES@ clause. Introduce the elements of the given non-empty list as -- rows in a joined table. values_ :: forall be db s a . ( Projectible be a , BeamSqlBackend be )- => [ a ] -> Q be db s a+ => NonEmpty 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))+ Q $ liftF (QAll (\tblPfx -> + fromTable + (tableFromValues (NonEmpty.toList (NonEmpty.map (\row -> project (Proxy @be) row tblPfx) rows))) + . Just + . (,Just fieldNames)) (\tblNm' -> fst $ mkFieldNames (qualifiedField tblNm'))- (\_ -> Nothing) snd)+ (\_ -> Nothing) snd+ ) where fieldNames = snd $ mkFieldNames @be @a unqualifiedField @@ -123,7 +131,7 @@ -- '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, BeamSqlBackend be )+join_ :: ( 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))@@ -131,7 +139,7 @@ -- | Like 'join_', but accepting an @ON@ condition that returns -- 'SqlBool'-join_' :: ( Database be db, Table table, BeamSqlBackend be )+join_' :: ( 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))@@ -152,7 +160,7 @@ -> Q be db s (Retag Nullable (WithRewrittenThread (QNested s) s r)) perhaps_ (Q sub) = Q $ liftF (QArbitraryJoin- sub leftJoin+ sub "" leftJoin (\_ -> Nothing) (\r -> retag (\(Columnar' (QExpr e) :: Columnar' (QExpr be s) a) -> Columnar' (QExpr e) :: Columnar' (Nullable (QExpr be s)) a) $@@ -232,7 +240,7 @@ -> Q be db s (Retag Nullable (WithRewrittenThread (QNested s) s r)) leftJoin_' (Q sub) on_ = Q $ liftF (QArbitraryJoin- sub leftJoin+ sub "" leftJoin (\r -> let QExpr e = on_ (rewriteThread (Proxy @s) r) in Just e) (\r -> retag (\(Columnar' (QExpr e) :: Columnar' (QExpr be s) a) -> Columnar' (QExpr e) :: Columnar' (Nullable (QExpr be s)) a) $@@ -281,7 +289,7 @@ -- | Introduce all entries of the given table which are referenced by the given 'PrimaryKey' related_ :: forall be db rel s- . ( Database be db, Table rel, BeamSqlBackend be+ . ( Table rel, BeamSqlBackend be , HasTableEquality be (PrimaryKey rel) ) => DatabaseEntity be db (TableEntity rel)@@ -292,7 +300,7 @@ -- | Introduce all entries of the given table for which the expression (which can depend on the queried table returns true) relatedBy_ :: forall be db rel s- . ( Database be db, Table rel, BeamSqlBackend be )+ . ( Table rel, BeamSqlBackend be ) => DatabaseEntity be db (TableEntity rel) -> (rel (QExpr be s) -> QExpr be s Bool) -> Q be db s (rel (QExpr be s))@@ -300,7 +308,7 @@ -- | Introduce all entries of the given table for which the expression (which can depend on the queried table returns true) relatedBy_' :: forall be db rel s- . ( Database be db, Table rel, BeamSqlBackend be )+ . ( Table rel, BeamSqlBackend be ) => DatabaseEntity be db (TableEntity rel) -> (rel (QExpr be s) -> QExpr be s SqlBool) -> Q be db s (rel (QExpr be s))@@ -328,6 +336,8 @@ nub_ (Q sub) = Q $ liftF (QDistinct (\_ _ -> setQuantifierDistinct) sub id) -- | Limit the number of results returned by a query.+--+-- See also `limitMaybe_` to conditionally apply a limit. limit_ :: forall s a be db . ( Projectible be a , ThreadRewritable (QNested s) a )@@ -335,7 +345,22 @@ limit_ limit' (Q q) = Q (liftF (QLimit limit' q (rewriteThread (Proxy @s)))) --- | Drop the first `offset'` results.+-- | Conditionally limit the number of results returned by a query.+--+-- @since 0.10.4.0+limitMaybe_ :: forall s a be db+ . ( Projectible be a+ , ThreadRewritable (QNested s) a )+ => Maybe Integer -> Q be db (QNested s) a -> Q be db s (WithRewrittenThread (QNested s) s a)+limitMaybe_ (Just limit') (Q q) =+ Q (liftF (QLimit limit' q (rewriteThread (Proxy @s))))+-- This uses unsafeCoerce, but should be safe since this function is tested.+-- See discussion on https://github.com/haskell-beam/beam/pull/633.+limitMaybe_ Nothing (Q q) = Q (unsafeCoerce q)++-- | Drop the first `offset` results.+--+-- See also `offsetMaybe_` to conditionally apply an offset offset_ :: forall s a be db . ( Projectible be a , ThreadRewritable (QNested s) a )@@ -343,6 +368,19 @@ offset_ offset' (Q q) = Q (liftF (QOffset offset' q (rewriteThread (Proxy @s)))) +-- | Conditionally drop the first `offset` results.+--+-- @since 0.10.4.0+offsetMaybe_ :: forall s a be db+ . ( Projectible be a+ , ThreadRewritable (QNested s) a )+ => Maybe Integer -> Q be db (QNested s) a -> Q be db s (WithRewrittenThread (QNested s) s a)+offsetMaybe_ (Just offset') (Q q) =+ Q (liftF (QOffset offset' q (rewriteThread (Proxy @s))))+-- This uses unsafeCoerce, but should be safe since this function is tested.+-- See discussion on https://github.com/haskell-beam/beam/pull/633.+offsetMaybe_ Nothing (Q q) = Q (unsafeCoerce q)+ -- | Use the SQL @EXISTS@ operator to determine if the given query returns any results exists_ :: ( BeamSqlBackend be, HasQBuilder be, Projectible be a) => Q be db s a -> QExpr be s Bool@@ -564,7 +602,14 @@ in changeBeamRep (\(Columnar' (WithConstraint x :: WithConstraint (BeamSqlBackendCanSerialize be) (Maybe x))) -> Columnar' (QExpr (pure (valueE (sqlValueSyntax x))))) fields +-- | SQL @DEFAULT@ support.+--+-- Note that `default_` has restrictions not currently represented in the Haskell type system.+-- For example, using `default_` as the argument to a function like `coalesce_`+-- will result in a runtime error, just like the SQL code @COALESCE (NULL, DEFAULT)@+-- would raise a runtime error. default_ :: BeamSqlBackend be => QGenExpr ctxt be s a+-- See #744 for issues with `default_`. default_ = QExpr (pure defaultE) -- * Window functions@@ -854,7 +899,7 @@ isNothing_ t = allE (allBeamValues (\(Columnar' e) -> isNothing_ e) t) maybe_ (QExpr onNothing) onJust tbl = let QExpr onJust' = onJust (changeBeamRep (\(Columnar' (QExpr e)) -> Columnar' (QExpr e)) tbl)- QExpr cond = isJust_ tbl+ QExpr cond = isJust_ @be tbl in QExpr (\tblPfx -> caseE [(cond tblPfx, onJust' tblPfx)] (onNothing tblPfx)) infixl 3 <|>.
Database/Beam/Query/Extensions.hs view
@@ -47,13 +47,13 @@ lead1_, lag1_ :: (BeamSqlBackend be, BeamSqlT615Backend be)- => QExpr be s a -> QAgg be s a+ => QExpr be s a -> QAgg be s (Maybe a) lead1_ (QExpr a) = QExpr (leadE <$> a <*> pure Nothing <*> pure Nothing) lag1_ (QExpr a) = QExpr (lagE <$> a <*> pure Nothing <*> pure Nothing) lead_, lag_ :: (BeamSqlBackend be, BeamSqlT615Backend be, Integral n)- => QExpr be s a -> QExpr be s n -> QAgg be s a+ => QExpr be s a -> QExpr be s n -> QAgg be s (Maybe 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)
Database/Beam/Query/Extract.hs view
@@ -7,7 +7,7 @@ -- ** SQL92 fields hour_, minutes_, seconds_,- year_, month_, day_,+ year_, month_, week_, day_, HasSqlTime, HasSqlDate ) where@@ -53,9 +53,10 @@ instance HasSqlDate UTCTime instance HasSqlDate Day -year_, month_, day_+year_, month_, week_, day_ :: ( BeamSqlBackend be, HasSqlDate tgt ) => ExtractField be tgt Double year_ = ExtractField yearField month_ = ExtractField monthField day_ = ExtractField dayField+week_ = ExtractField weekField
Database/Beam/Query/Internal.hs view
@@ -1,6 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors#-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE CPP #-} module Database.Beam.Query.Internal where @@ -10,21 +9,18 @@ import qualified Data.DList as DList import Data.Functor.Const+import Data.Kind (Type, Constraint) import Data.String import qualified Data.Text as T 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 import Control.Monad.Free.Church import Control.Monad.State import Control.Monad.Writer import GHC.TypeLits-import GHC.Types import Unsafe.Coerce @@ -41,12 +37,18 @@ QAll :: Projectible be r => (TablePrefix -> T.Text -> BeamSqlBackendFromSyntax be)+ -- ^ build the FROM syntax using the table prefix and the table name -> (T.Text -> r)+ -- ^ Given a table name, get the various Qs for all the expressions in that table -> (r -> Maybe (WithExprContext (BeamSqlBackendExpressionSyntax be)))- -> ((T.Text, r) -> next) -> QF be db s next+ -- ^ on clause, if any+ -> ((T.Text, r) -> next)+ -- ^ Generate the result from the table name and projectible result+ -> QF be db s next QArbitraryJoin :: Projectible be r => QM be db (QNested s) r+ -> T.Text -- Table namespace -> (BeamSqlBackendFromSyntax be -> BeamSqlBackendFromSyntax be -> Maybe (BeamSqlBackendExpressionSyntax be) -> BeamSqlBackendFromSyntax be)
Database/Beam/Query/Ord.hs view
@@ -38,6 +38,8 @@ , anyOf_, anyIn_ , allOf_, allIn_ + , inQuery_+ , between_ ) where @@ -199,7 +201,11 @@ where toExpr :: table (QGenExpr context be s) -> TablePrefix -> BeamSqlBackendExpressionSyntax be toExpr = fmap rowE . sequence . allBeamValues (\(Columnar' (QExpr x)) -> x) -infix 4 `between_`, `in_`+infix 4 `between_`, `in_`, `inQuery_`++inQuery_ :: (HasQBuilder be, BeamSqlBackend be)+ => QGenExpr ctx be s a -> Q be db s (QExpr be s a) -> QGenExpr ctx be s Bool+inQuery_ (QExpr needle) haystack = QExpr (inSelectE <$> needle <*> flip buildSqlQuery haystack) -- | Class for expression types or expression containers for which there is a -- notion of equality.
Database/Beam/Query/SQL92.hs view
@@ -212,28 +212,29 @@ -> T.Text {-^ Table prefix -} -> Q be db s a -> BeamSqlBackendSelectSyntax be-buildSql92Query' arbitrarilyNestedCombinations tblPfx (Q q) =- buildSelect tblPfx (buildQuery (fromF q))+buildSql92Query' arbitrarilyNestedCombinations baseTblPfx (Q q) =+ buildSelect baseTblPfx (buildQuery baseTblPfx (fromF q)) where be :: Proxy be be = Proxy buildQuery :: forall s x . Projectible be x- => Free (QF be db s) x+ => T.Text+ -> 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- buildQuery f@(Free QArbitraryJoin {}) = buildJoinedQuery f emptyQb- buildQuery f@(Free QTwoWayJoin {}) = buildJoinedQuery f emptyQb- buildQuery (Free (QSubSelect q' next)) =- let sb = buildQuery (fromF q')+ buildQuery _ (Pure x) = SelectBuilderQ x emptyQb+ buildQuery tblPfx f@(Free (QGuard _ _)) = buildJoinedQuery tblPfx f emptyQb+ buildQuery tblPfx f@(Free QAll {}) = buildJoinedQuery tblPfx f emptyQb+ buildQuery tblPfx f@(Free QArbitraryJoin {}) = buildJoinedQuery tblPfx f emptyQb+ buildQuery tblPfx f@(Free QTwoWayJoin {}) = buildJoinedQuery tblPfx f emptyQb+ buildQuery tblPfx (Free (QSubSelect q' next)) =+ let sb = buildQuery tblPfx (fromF q') (proj, qb) = selectBuilderToQueryBuilder tblPfx sb- in buildJoinedQuery (next proj) qb- buildQuery (Free (QDistinct nubType q' next)) =+ in buildJoinedQuery tblPfx (next proj) qb+ buildQuery tblPfx (Free (QDistinct nubType q' next)) = let (proj, qb, gp, hv) =- case buildQuery (fromF q') of+ case buildQuery tblPfx (fromF q') of SelectBuilderQ proj qb -> ( proj, qb, Nothing, Nothing) SelectBuilderGrouping proj qb gp hv Nothing ->@@ -244,11 +245,11 @@ in case next proj of Pure x -> SelectBuilderGrouping x qb gp hv (Just (exprWithContext tblPfx (nubType proj))) _ -> let ( proj', qb' ) = selectBuilderToQueryBuilder tblPfx (SelectBuilderGrouping proj qb gp hv (Just (exprWithContext tblPfx (nubType proj))))- in buildJoinedQuery (next proj') qb'- buildQuery (Free (QAggregate mkAgg q' next)) =- let sb = buildQuery (fromF q')+ in buildJoinedQuery tblPfx (next proj') qb'+ buildQuery tblPfx (Free (QAggregate mkAgg q' next)) =+ let sb = buildQuery tblPfx (fromF q') (groupingSyntax, aggProj) = mkAgg (sbProj sb) (nextTblPfx tblPfx)- in case tryBuildGuardsOnly (next aggProj) Nothing of+ in case tryBuildGuardsOnly tblPfx (next aggProj) Nothing of Just (proj, having) -> case sb of SelectBuilderQ _ q'' -> SelectBuilderGrouping proj q'' groupingSyntax having Nothing@@ -256,13 +257,13 @@ -- We'll have to generate a subselect _ -> let (subProj, qb) = selectBuilderToQueryBuilder tblPfx sb --(setSelectBuilderProjection sb aggProj) (groupingSyntax, aggProj') = mkAgg subProj (nextTblPfx tblPfx)- in case tryBuildGuardsOnly (next aggProj') Nothing of+ in case tryBuildGuardsOnly tblPfx (next aggProj') Nothing of Nothing -> error "buildQuery (Free (QAggregate ...)): Impossible" Just (aggProj'', having') -> SelectBuilderGrouping aggProj'' qb groupingSyntax having' Nothing Nothing ->- let (_, having) = tryCollectHaving (next aggProj') Nothing- (next', _) = tryCollectHaving (next x') Nothing+ let (_, having) = tryCollectHaving tblPfx (next aggProj') Nothing+ (next', _) = tryCollectHaving tblPfx (next x') Nothing (groupingSyntax', aggProj', qb) = case sb of SelectBuilderQ _ q'' -> (groupingSyntax, aggProj, q'')@@ -271,10 +272,10 @@ in (groupingSyntax', aggProj', qb''') (x', qb') = selectBuilderToQueryBuilder tblPfx $ SelectBuilderGrouping aggProj' qb groupingSyntax' having Nothing- in buildJoinedQuery next' qb'+ in buildJoinedQuery tblPfx next' qb' - buildQuery (Free (QOrderBy mkOrdering q' next)) =- let sb = buildQuery (fromF q')+ buildQuery tblPfx (Free (QOrderBy mkOrdering q' next)) =+ let sb = buildQuery tblPfx (fromF q') proj = sbProj sb ordering = exprWithContext tblPfx (mkOrdering proj) @@ -296,7 +297,7 @@ | otherwise -> error "buildQuery (Free (QOrderBy ...)): query inspected expression" (joinedProj, qb) = selectBuilderToQueryBuilder tblPfx sb'- in buildJoinedQuery (next joinedProj) qb+ in buildJoinedQuery tblPfx (next joinedProj) qb in case next proj of Pure proj' -> case ordering of@@ -320,8 +321,13 @@ | otherwise -> error "buildQuery (Free (QOrderBy ...)): query inspected expression" _ -> doJoined - buildQuery (Free (QWindowOver mkWindows mkProjection q' next)) =- let sb = buildQuery (fromF q')+ buildQuery tblPfx (Free (QWindowOver mkWindows mkProjection q' next)) =+ -- If the inner select carries DISTINCT, GROUP BY, or HAVING, those must+ -- apply to the row set *before* the window function. Emitting them in+ -- the same SELECT as the window projection inverts that order in SQL,+ -- yielding wrong results (issue #746). Materialise the inner select as+ -- a subquery in that case so the window evaluates over its output.+ let sb = forceSubqueryIfGrouping (buildQuery tblPfx (fromF q')) x = sbProj sb windows = mkWindows x@@ -334,10 +340,21 @@ sb' -> SelectBuilderTopLevel Nothing Nothing [] sb' Nothing _ -> let (x', qb) = selectBuilderToQueryBuilder tblPfx (setSelectBuilderProjection sb projection)- in buildJoinedQuery (next x') qb+ in buildJoinedQuery tblPfx (next x') qb+ where+ forceSubqueryIfGrouping :: Projectible be x' => SelectBuilder be db x' -> SelectBuilder be db x'+ forceSubqueryIfGrouping sb0+ | hasGroupingClause sb0 = uncurry SelectBuilderQ $ selectBuilderToQueryBuilder tblPfx sb0+ | otherwise = sb0+ where+ hasGroupingClause :: SelectBuilder be db x' -> Bool+ hasGroupingClause (SelectBuilderGrouping _ _ grouping having distinct) =+ isJust grouping || isJust having || isJust distinct+ hasGroupingClause (SelectBuilderTopLevel _ _ _ inner _) = hasGroupingClause inner+ hasGroupingClause _ = False - buildQuery (Free (QLimit limit q' next)) =- let sb = limitSelectBuilder limit (buildQuery (fromF q'))+ buildQuery tblPfx (Free (QLimit limit q' next)) =+ let sb = limitSelectBuilder limit (buildQuery tblPfx (fromF q')) x = sbProj sb -- In the case of limit, we must directly return whatever was given in case next x of@@ -345,23 +362,23 @@ -- Otherwise, this is going to be part of a join... _ -> let (x', qb) = selectBuilderToQueryBuilder tblPfx sb- in buildJoinedQuery (next x') qb+ in buildJoinedQuery tblPfx (next x') qb - buildQuery (Free (QOffset offset q' next)) =- let sb = offsetSelectBuilder offset (buildQuery (fromF q'))+ buildQuery tblPfx (Free (QOffset offset q' next)) =+ let sb = offsetSelectBuilder offset (buildQuery tblPfx (fromF q')) x = sbProj sb -- In the case of limit, we must directly return whatever was given in case next x of Pure x' -> setSelectBuilderProjection sb x' -- Otherwise, this is going to be part of a join... _ -> let (x', qb) = selectBuilderToQueryBuilder tblPfx sb- in buildJoinedQuery (next x') qb+ in buildJoinedQuery tblPfx (next x') qb - buildQuery (Free (QSetOp combine left right next)) =- buildTableCombination combine left right next+ buildQuery tblPfx (Free (QSetOp combine left right next)) =+ buildTableCombination tblPfx combine left right next - buildQuery (Free (QForceSelect selectStmt' over next)) =- let sb = buildQuery (fromF over)+ buildQuery tblPfx (Free (QForceSelect selectStmt' over next)) =+ let sb = buildQuery tblPfx (fromF over) x = sbProj sb selectStmt'' = selectStmt' (sbProj sb)@@ -375,33 +392,36 @@ in case next (sbProj sb') of Pure x' -> setSelectBuilderProjection sb' x' _ -> let (x', qb) = selectBuilderToQueryBuilder tblPfx sb'- in buildJoinedQuery (next x') qb+ in buildJoinedQuery tblPfx (next x') qb tryBuildGuardsOnly :: forall s x- . Free (QF be db s) x+ . T.Text+ -> Free (QF be db s) x -> Maybe (BeamSqlBackendExpressionSyntax be) -> Maybe (x, Maybe (BeamSqlBackendExpressionSyntax be))- tryBuildGuardsOnly next having =- case tryCollectHaving next having of+ tryBuildGuardsOnly tblPfx next having =+ case tryCollectHaving tblPfx next having of (Pure x, having') -> Just (x, having') _ -> Nothing - tryCollectHaving :: forall s x.- Free (QF be db s) x+ tryCollectHaving :: forall s x+ . T.Text+ -> 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)+ tryCollectHaving tblPfx (Free (QGuard cond next)) having = tryCollectHaving tblPfx next (andE' having (Just (exprWithContext tblPfx cond)))+ tryCollectHaving _ next having = (next, having) buildTableCombination :: forall s x r . ( Projectible be r, Projectible be x )- => (BeamSqlBackendSelectTableSyntax be -> BeamSqlBackendSelectTableSyntax be -> BeamSqlBackendSelectTableSyntax be)+ => T.Text+ -> (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)+ buildTableCombination tblPfx combineTables left right next =+ let leftSb = buildQuery tblPfx (fromF left) leftTb = selectBuilderToTableSource tblPfx leftSb- rightSb = buildQuery (fromF right)+ rightSb = buildQuery tblPfx (fromF right) rightTb = selectBuilderToTableSource tblPfx rightSb proj = reproject be (fieldNameFunc unqualifiedField) (sbProj leftSb)@@ -423,16 +443,16 @@ | projOrder be proj (nextTblPfx tblPfx) == projOrder be proj' (nextTblPfx tblPfx) -> setSelectBuilderProjection sb proj' _ -> let (x', qb) = selectBuilderToQueryBuilder tblPfx sb- in buildJoinedQuery (next x') qb+ in buildJoinedQuery tblPfx (next x') qb - buildJoinedQuery :: forall s 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 mkTbl on next)) qb =+ buildJoinedQuery :: forall s x+ . Projectible be x+ => T.Text -> Free (QF be db s) x -> QueryBuilder be -> SelectBuilder be db x+ buildJoinedQuery _ (Pure x) qb = SelectBuilderQ x qb+ buildJoinedQuery tblPfx (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 =+ in buildJoinedQuery tblPfx (next (newTblNm, newTbl)) qb'+ buildJoinedQuery tblPfx (Free (QArbitraryJoin q tblNs mkJoin on next)) qb = case fromF q of Free (QAll mkDbFrom dbMkTbl on' next') | (newTbl, newTblNm, qb') <- nextTbl qb tblPfx dbMkTbl,@@ -444,10 +464,12 @@ case qbFrom qb' of Nothing -> (Just newSource, andE' (qbWhere qb) on'') Just oldFrom -> (Just (mkJoin oldFrom newSource on''), qbWhere qb)- in buildJoinedQuery (next proj) (qb' { qbFrom = from', qbWhere = where' })+ in buildJoinedQuery tblPfx (next proj) (qb' { qbFrom = from', qbWhere = where' }) - q' -> let sb = buildQuery q'- tblSource = buildSelect tblPfx sb+ q' -> let tblPfx' = tblPfx <> tblNs++ sb = buildQuery tblPfx' q'+ tblSource = buildSelect tblPfx' sb newTblNm = tblPfx <> fromString (show (qbNextTblRef qb)) newSource = fromTable (tableFromSubSelect tblSource) (Just (newTblNm, Nothing))@@ -460,9 +482,9 @@ Nothing -> (Just newSource, andE' (qbWhere qb) on') Just oldFrom -> (Just (mkJoin oldFrom newSource on'), qbWhere qb) - in buildJoinedQuery (next proj') (qb { qbNextTblRef = qbNextTblRef qb + 1- , qbFrom = from', qbWhere = where' })- buildJoinedQuery (Free (QTwoWayJoin a b mkJoin on next)) qb =+ in buildJoinedQuery tblPfx (next proj') (qb { qbNextTblRef = qbNextTblRef qb + 1+ , qbFrom = from', qbWhere = where' })+ buildJoinedQuery tblPfx (Free (QTwoWayJoin a b mkJoin on next)) qb = let (aProj, aSource, qb') = case fromF a of Free (QAll mkDbFrom dbMkTbl on' next')@@ -470,7 +492,7 @@ Nothing <- on' newTbl, Pure proj <- next' (newTblNm, newTbl) -> (proj, mkDbFrom (nextTblPfx tblPfx) newTblNm, qb') - a -> let sb = buildQuery a+ a -> let sb = buildQuery tblPfx a tblSource = buildSelect tblPfx sb newTblNm = tblPfx <> fromString (show (qbNextTblRef qb))@@ -485,7 +507,7 @@ Nothing <- on' newTbl, Pure proj <- next' (newTblNm, newTbl) -> (proj, mkDbFrom (nextTblPfx tblPfx) newTblNm, qb'') - b -> let sb = buildQuery b+ b -> let sb = buildQuery tblPfx b tblSource = buildSelect tblPfx sb newTblNm = tblPfx <> fromString (show (qbNextTblRef qb))@@ -500,16 +522,16 @@ Nothing -> Just abSource Just oldFrom -> Just (innerJoin oldFrom abSource Nothing) - in buildJoinedQuery (next (aProj, bProj)) (qb'' { qbFrom = from' })- buildJoinedQuery (Free (QGuard cond next)) qb =- buildJoinedQuery next (qb { qbWhere = andE' (qbWhere qb) (Just (exprWithContext tblPfx cond)) })- buildJoinedQuery now qb =+ in buildJoinedQuery tblPfx (next (aProj, bProj)) (qb'' { qbFrom = from' })+ buildJoinedQuery tblPfx (Free (QGuard cond next)) qb =+ buildJoinedQuery tblPfx next (qb { qbWhere = andE' (qbWhere qb) (Just (exprWithContext tblPfx cond)) })+ buildJoinedQuery tblPfx now qb = onlyQ now (\now' next ->- let sb = buildQuery now'+ let sb = buildQuery tblPfx now' tblSource = buildSelect tblPfx sb (x', qb') = buildJoinTableSourceQuery tblPfx tblSource (sbProj sb) qb- in buildJoinedQuery (next x') qb')+ in buildJoinedQuery tblPfx (next x') qb') onlyQ :: forall s x. Free (QF be db s) x@@ -518,8 +540,8 @@ 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 (QArbitraryJoin entity tblNs mkJoin mkOn next)) f =+ f (Free (QArbitraryJoin entity tblNs mkJoin mkOn Pure)) next onlyQ (Free (QTwoWayJoin a b mkJoin mkOn next)) f = f (Free (QTwoWayJoin a b mkJoin mkOn Pure)) next onlyQ (Free (QSubSelect q' next)) f =
Database/Beam/Schema/Lenses.hs view
@@ -4,12 +4,18 @@ ( tableLenses , TableLens(..) - , dbLenses ) where+ , dbLenses + -- * Exported so we can override defaults+ , GTableLenses(..)+ , GDatabaseLenses(..)+ ) where+ import Database.Beam.Schema.Tables import Control.Monad.Identity +import Data.Function import Data.Kind (Type) import Data.Proxy
Database/Beam/Schema/Tables.hs view
@@ -19,13 +19,14 @@ , DatabaseEntityDescriptor(..) , DatabaseEntity(..), TableEntity, ViewEntity, DomainTypeEntity , dbEntityDescriptor+ , dbName, dbSchema, dbTableFields , DatabaseModification, EntityModification(..) , FieldModification(..) , dbModification, tableModification, withDbModification , withTableModification, modifyTable, modifyEntityName , setEntityName, modifyTableFields, fieldNamed , modifyEntitySchema, setEntitySchema- , defaultDbSettings+ , defaultDbSettings, embedDatabase , RenamableWithRule(..), RenamableField(..) , FieldRenamer(..)@@ -57,7 +58,20 @@ , pk , allBeamValues, changeBeamRep , alongsideTable- , defaultFieldName )+ , defaultFieldName++ -- * Exported so we can override defaults+ -- ** For 'Beamable'+ , GZipTables(..)+ , GTableSkeleton(..)+ -- ** For 'Database'+ , GZipDatabase(..)+ -- ** For 'defaultDbSettings'+ , GAutoDbSettings(..)+ , GDefaultTableFieldSettings(..)+ , ChooseSubTableStrategy+ , SubTableStrategyImpl+ ) where import Database.Beam.Backend.Types@@ -65,11 +79,13 @@ import Control.Applicative (liftA2) import Control.Arrow (first) import Control.Monad.Identity-import Control.Monad.Writer hiding ((<>))+import Control.Monad.Writer (Writer, execWriter, tell) import Data.Char (isUpper, toLower) import Data.Foldable (fold)+import Data.Kind (Type, Constraint) import qualified Data.List.NonEmpty as NE+import Data.Monoid import Data.Proxy import Data.String (IsString(..)) import Data.Text (Text)@@ -79,10 +95,8 @@ import qualified GHC.Generics as Generic import GHC.Generics hiding (R, C) import GHC.TypeLits-import GHC.Types import Lens.Micro hiding (to)-import qualified Lens.Micro as Lens -- | Allows introspection into database types. --@@ -186,7 +200,9 @@ -- > db = defaultDbSettings `withDbModification` -- > dbModification { -- > -- Change default name "table1" to "Table_1". Change the name of "table1Field1" to "first_name"--- > table1 = modifyTable (\_ -> "Table_1") (tableModification { table1Field1 = "first_name" }+-- > table1 = setEntityName "Table_1" <> modifyTableFields tableModification { +-- > table1Field1 = "first_name" +-- > } -- > } withDbModification :: forall db be entity . Database be db@@ -204,7 +220,6 @@ 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.@@ -230,6 +245,14 @@ setEntitySchema :: IsDatabaseEntity be entity => Maybe Text -> EntityModification (DatabaseEntity be db) be entity setEntitySchema nm = modifyEntitySchema (\_ -> nm) +-- | Embed database settings in a larger database+embedDatabase :: forall be embedded db. Database be embedded => DatabaseSettings be embedded -> embedded (EntityModification (DatabaseEntity be db) be)+embedDatabase db =+ runIdentity $+ zipTables (Proxy @be)+ (\(DatabaseEntity x) _ -> pure (EntityModification (Endo (\_ -> DatabaseEntity x))))+ db db+ -- | 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) }))@@ -375,9 +398,22 @@ IsDatabaseEntity be entityType => DatabaseEntityDescriptor be entityType -> DatabaseEntity be db entityType -dbEntityDescriptor :: SimpleGetter (DatabaseEntity be db entityType) (DatabaseEntityDescriptor be entityType)-dbEntityDescriptor = Lens.to (\(DatabaseEntity e) -> e)+dbEntityDescriptor :: Lens' (DatabaseEntity be db entityType) (DatabaseEntityDescriptor be entityType)+dbEntityDescriptor f (DatabaseEntity d) = DatabaseEntity <$> f d +dbName :: IsDatabaseEntity be entityType => Lens' (DatabaseEntity be db entityType) Text+dbName = dbEntityDescriptor . dbEntityName++dbSchema :: IsDatabaseEntity be entityType => Traversal' (DatabaseEntity be db entityType) (Maybe Text)+dbSchema = dbEntityDescriptor . dbEntitySchema++dbTableFields :: Lens' (DatabaseEntity be db (TableEntity table)) (TableSettings table)+dbTableFields = dbEntityDescriptor . (\f DatabaseTable { dbTableSchema = sch+ , dbTableOrigName = nm+ , dbTableCurrentName = curNm+ , dbTableSettings = s } ->+ DatabaseTable sch nm curNm <$> f s)+ -- | When parameterized by this entity tag, a database type will hold -- meta-information on the Haskell mappings of database entities. Under the -- hood, each entity type is transformed into its 'DatabaseEntityDescriptor'@@ -397,6 +433,16 @@ GAutoDbSettings (S1 f (K1 Generic.R (DatabaseEntity be db x)) p) where autoDbSettings' = M1 (K1 (DatabaseEntity (dbEntityAuto name))) where name = T.pack (selName (undefined :: S1 f (K1 Generic.R (DatabaseEntity be db x)) p))+instance ( Database be embedded+ , Generic (DatabaseSettings be embedded)+ , GAutoDbSettings (Rep (DatabaseSettings be embedded) ()) ) =>+ GAutoDbSettings (S1 f (K1 Generic.R (embedded (DatabaseEntity be super))) p) where+ autoDbSettings' =+ M1 . K1 . runIdentity $+ zipTables (Proxy @be)+ (\(DatabaseEntity x) _ -> pure (DatabaseEntity x))+ db db+ where db = defaultDbSettings @be class GZipDatabase be f g h x y z where gZipDatabase :: Applicative m =>@@ -416,7 +462,12 @@ gZipDatabase _ combine ~(K1 x) ~(K1 y) = K1 <$> combine x y+instance Database be db =>+ GZipDatabase be f g h (K1 Generic.R (db f)) (K1 Generic.R (db g)) (K1 Generic.R (db h)) where + gZipDatabase _ combine ~(K1 x) ~(K1 y) =+ K1 <$> zipTables (Proxy @be) combine x y+ data Lenses (t :: (Type -> Type) -> Type) (f :: Type -> Type) x data LensFor t x where LensFor :: Generic t => Lens' t x -> LensFor t x@@ -447,7 +498,7 @@ -- > { _refToAnotherTable :: PrimaryKey AnotherTableT (Nullable f) -- > , ... } ----- Now we can use 'justRef' and 'nothingRef' to refer to this table optionally. The embedded 'PrimaryKey' in '_refToAnotherTable'+-- Now we can use 'just_' and 'nothing_' to refer to this table optionally. The embedded 'PrimaryKey' in '_refToAnotherTable' -- automatically has its fields converted into 'Maybe' using 'Nullable'. -- -- The last 'Columnar' rule is
beam-core.cabal view
@@ -1,8 +1,5 @@--- Initial beam.cabal generated by cabal init. For further documentation,--- see http://haskell.org/cabal/users-guide/- name: beam-core-version: 0.9.2.1+version: 0.11.1.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@@ -50,7 +47,10 @@ Database.Beam.Backend.Internal.Compat - other-modules: Database.Beam.Query.Aggregate+ other-modules: Database.Beam.Backend.SQL.BeamExtensions.Copy.File+ Database.Beam.Backend.SQL.BeamExtensions.Copy.Stream++ Database.Beam.Query.Aggregate Database.Beam.Query.Combinators Database.Beam.Query.Extensions Database.Beam.Query.Extract@@ -61,21 +61,20 @@ Database.Beam.Schema.Lenses build-depends: base >=4.11 && <5.0,- aeson >=0.11 && <2.1,- text >=1.2.2.0 && <1.3,- bytestring >=0.10 && <0.12,- mtl >=2.2.1 && <2.3,- microlens >=0.4 && <0.5,- ghc-prim >=0.5 && <0.9,- free >=4.12 && <5.2,+ aeson >=0.11 && <2.3,+ text >=1.2.2.0 && <2.2,+ bytestring >=0.10 && <0.13,+ mtl >=2.2.1 && <2.4,+ microlens >=0.4 && <0.6,+ free >=4.12 && <5.3, dlist >=0.7.1.2 && <1.1,- time >=1.6 && <1.12,- hashable >=1.2.4.0 && <1.5,+ time >=1.6 && <1.17,+ hashable >=1.2.4.0 && <1.6, network-uri >=2.6 && <2.7,- containers >=0.5 && <0.7,+ containers >=0.5 && <0.9, scientific >=0.3 && <0.4,- vector >=0.11 && <0.13,- vector-sized >=0.5 && <1.6,+ vector >=0.11 && <0.14,+ vector-sized >=0.5 && <1.7, tagged >=0.8 && <0.9 Default-language: Haskell2010@@ -83,9 +82,14 @@ GeneralizedNewtypeDeriving, RankNTypes, TupleSections, ConstraintKinds, StandaloneDeriving, TypeOperators, DefaultSignatures, KindSignatures, MultiParamTypeClasses, DeriveGeneric, DeriveFunctor, DeriveDataTypeable, TypeApplications, FunctionalDependencies, DataKinds, BangPatterns, InstanceSigs- ghc-options: -Wall -O3+ ghc-options: -Wall+ -Widentities+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates if impl(ghc >= 8.8) ghc-options: -Wcompat+ if impl(ghc >= 8.10)+ ghc-options: -Wunused-packages if flag(werror) ghc-options: -Werror if impl(ghc >= 8.10)@@ -101,7 +105,7 @@ hs-source-dirs: test main-is: Main.hs other-modules: Database.Beam.Test.Schema Database.Beam.Test.SQL- build-depends: base, beam-core, text, bytestring, time, tasty, tasty-hunit+ build-depends: base, beam-core, text, bytestring, time, tasty, tasty-hunit, microlens default-language: Haskell2010 default-extensions: OverloadedStrings, FlexibleInstances, FlexibleContexts, GADTs, TypeFamilies, DeriveGeneric, DefaultSignatures, RankNTypes, StandaloneDeriving, KindSignatures,
test/Database/Beam/Test/SQL.hs view
@@ -12,7 +12,7 @@ import Database.Beam import Database.Beam.Backend.SQL (MockSqlBackend) import Database.Beam.Backend.SQL.AST-+import Data.Kind (Type) import Data.Int import Data.Time.Clock import Data.Text (Text)@@ -24,12 +24,14 @@ tests = testGroup "SQL generation tests" [ simpleSelect , simpleWhere+ , simpleWhereNoFrom , simpleJoin , selfJoin , leftJoin , leftJoinSingle , aggregates , orderBy+ , innerNub , joinHaving @@ -118,6 +120,32 @@ selectWhere @?= Just (ExpressionBinOp "AND" salaryCond (ExpressionBinOp "AND" ageCond nameCond)) +-- | Simple select without FROM clause (#667)++data EmptyDb (f :: Type -> Type) = EmptyDb++simpleWhereNoFrom :: TestTree+simpleWhereNoFrom =+ testCase "WHERE clause not dropped if there is no FROM" $ do+ SqlSelect Select { selectTable = SelectTable { .. }, .. } <- pure $ selectMock simple++ selectGrouping @?= Nothing+ selectOrdering @?= []+ selectLimit @?= Nothing+ selectOffset @?= Nothing+ selectHaving @?= Nothing+ selectQuantifier @?= Nothing+ -- Important point: no FROM clause, yet WHERE clause should still be here+ selectFrom @?= Nothing+ selectWhere @?= (Just (ExpressionValue (Value False)))++ where+ simple :: Q (MockSqlBackend Command) EmptyDb s (QExpr (MockSqlBackend Command) s Bool)+ simple = do+ guard_ (val_ False)+ pure (val_ True)++ -- | Ensure that multiple tables are correctly joined simpleJoin :: TestTree@@ -743,6 +771,61 @@ (FromTable (TableFromSubSelect subselect) (Just ("t1", Nothing))) Nothing) ++-- | Ensure that a SQL DISTINCT in a subquery does not propagate up (see issue #746)+innerNub :: TestTree+innerNub =+ testCase "DISTINCT clause on inner SELECT" $ do+ stmt@(SqlSelect Select{selectTable = SelectTable{..}, ..}) <- pure $ selectMock query++ selectGrouping @?= Nothing+ selectOrdering @?= []+ selectLimit @?= Nothing+ selectOffset @?= Nothing+ selectHaving @?= Nothing+ selectQuantifier @?= Nothing -- quantifier should be in the subquery+ selectFrom+ @?= Just+ ( FromTable+ ( TableFromSubSelect+ ( Select+ { selectTable =+ SelectTable+ { selectQuantifier = Just SetQuantifierDistinct+ , selectProjection = ProjExprs [(ExpressionFieldName (QualifiedField "t0" "first_name"), Just "res0")]+ , selectFrom = Just (FromTable (TableNamed (TableName Nothing "employees")) (Just ("t0", Nothing)))+ , selectWhere = Nothing+ , selectGrouping = Nothing+ , selectHaving = Nothing+ }+ , selectOrdering = []+ , selectLimit = Nothing+ , selectOffset = Nothing+ }+ )+ )+ (Just ("t0", Nothing))+ )+ selectWhere+ @?= Just+ ( ExpressionCompOp+ "=="+ Nothing+ (ExpressionFieldName (QualifiedField "t0" "res0"))+ (ExpressionValue (Value @Text "Alice"))+ )+ where+ query :: Q (MockSqlBackend Command) EmployeeDb s (QExpr (MockSqlBackend Command) s Text)+ query = do+ name <- subQuery+ guard_ (name ==. val_ "Alice")+ pure name++ -- This sub query contains a DISTINCT clause via `nub_`+ subQuery :: Q (MockSqlBackend Command) EmployeeDb s (QExpr (MockSqlBackend Command) s Text)+ subQuery = nub_ $ _employeeFirstName <$> (all_ (_employees employeeDbSettings))++ -- | HAVING clause should not be floated out of a join joinHaving :: TestTree@@ -1032,7 +1115,9 @@ limitOffset :: TestTree limitOffset = testGroup "LIMIT/OFFSET support"- [ limitSupport, offsetSupport, limitOffsetSupport+ [ limitSupport, maybeLimitSupportJust, maybeLimitSupportNothing+ , offsetSupport, maybeOffsetSupportJust, maybeOffsetSupportNothing+ , limitOffsetSupport , limitPlacedOnUnion ] where@@ -1044,6 +1129,22 @@ selectLimit @?= Just 20 selectOffset @?= Nothing + maybeLimitSupportJust =+ testCase "Maybe LIMIT support (Just)" $+ do SqlSelect Select { selectLimit, selectOffset } <-+ pure $ selectMock $ limitMaybe_ (Just 20) (all_ (_employees employeeDbSettings))++ selectLimit @?= Just 20+ selectOffset @?= Nothing++ maybeLimitSupportNothing =+ testCase "Maybe LIMIT support (Nothing)" $+ do SqlSelect Select { selectLimit, selectOffset } <-+ pure $ selectMock $ limitMaybe_ Nothing (all_ (_employees employeeDbSettings))++ selectLimit @?= Nothing+ selectOffset @?= Nothing+ offsetSupport = testCase "Basic OFFSET support" $ do SqlSelect Select { selectLimit, selectOffset } <-@@ -1051,6 +1152,22 @@ selectLimit @?= Nothing selectOffset @?= Just 102++ maybeOffsetSupportJust =+ testCase "Maybe OFFSET support (Just)" $+ do SqlSelect Select { selectLimit, selectOffset } <-+ pure $ selectMock $ offsetMaybe_ (Just 2) $ offset_ 100 (all_ (_employees employeeDbSettings))++ selectLimit @?= Nothing+ selectOffset @?= Just 102++ maybeOffsetSupportNothing =+ testCase "Maybe OFFSET support (Nothing)" $+ do SqlSelect Select { selectLimit, selectOffset } <-+ pure $ selectMock $ offsetMaybe_ Nothing $ offset_ 100 (all_ (_employees employeeDbSettings))++ selectLimit @?= Nothing+ selectOffset @?= Just 100 limitOffsetSupport = testCase "Basic LIMIT .. OFFSET .. support" $
test/Database/Beam/Test/Schema.hs view
@@ -23,6 +23,8 @@ import qualified Data.Text as T import Data.Time.Clock (UTCTime) +import Lens.Micro.Extras (view)+ import Test.Tasty import Test.Tasty.HUnit @@ -34,9 +36,8 @@ , parametricAndFixedNestedBeamsAreEquivalent -- , automaticNestedFieldsAreUnset -- , nullableForeignKeysGivenMaybeType- , underscoresAreHandledGracefully ]--- , dbSchemaGeneration ]--- , dbSchemaModification ]+ , underscoresAreHandledGracefully+ , embeddedDatabases ] data DummyBackend @@ -315,34 +316,38 @@ Nothing -> defName Just _ -> "pfx_" <> defName) --- employeeDbSettingsModified :: DatabaseSettings EmployeeDb--- employeeDbSettingsModified =--- defaultDbSettings `withDbModifications`--- (modifyingDb { _employees = tableModification (\_ -> "emps") tableFieldsModification--- , _departments = tableModification (\_ -> "depts")--- (tableFieldsModification--- { _departmentName = fieldModification (\_ -> "depts_name") id }) })+data VehicleDb f+ = VehicleDb+ { _vdbVehiculesA :: f (TableEntity ADepartmentVehiculeT)+ , _vdbVehiculesB :: f (TableEntity BDepartmentVehiculeT)+ } deriving Generic+instance Database be VehicleDb --- dbSchemaGeneration :: TestTree--- dbSchemaGeneration =--- testCase "Database schema generation" $--- do let names = allTables (\(DatabaseTable _ nm _) -> nm) employeeDbSettings--- names @?= [ "employees"--- , "departments"--- , "roles"--- , "funny" ]+data SuperDb f+ = SuperDb+ { _embedEmployeeDb :: EmployeeDb f+ , _embedVehicleDb :: VehicleDb f+ } deriving Generic+instance Database be SuperDb --- dbSchemaModification :: TestTree--- dbSchemaModification =--- testCase "Database schema modification" $--- do let names = allTables (\(DatabaseTable _ nm _ ) -> nm) employeeDbSettingsModified--- names @?= [ "emps"--- , "depts"--- , "roles"--- , "funny" ]+superDbSettingsDefault :: DatabaseSettings be SuperDb+superDbSettingsDefault = defaultDbSettings --- let DatabaseTable _ _ departmentT = _departments employeeDbSettingsModified--- departmentT @?= DepartmentT (TableField "depts_name" (DummyField False False DummyFieldText))--- (EmployeeId (TableField "head__first_name" (DummyField True False (DummyFieldMaybe DummyFieldText)))--- (TableField "head__last_name" (DummyField True False (DummyFieldMaybe DummyFieldText)))--- (TableField "head__created" (DummyField True False (DummyFieldMaybe DummyFieldUTCTime))))+superDbSettingsCustom :: DatabaseSettings be SuperDb+superDbSettingsCustom = defaultDbSettings `withDbModification` dbModification { _embedVehicleDb = embedDatabase customVehicleDb }++customVehicleDb :: DatabaseSettings be VehicleDb+customVehicleDb = defaultDbSettings `withDbModification` dbModification+ { _vdbVehiculesA = setEntityName "something_random" }+++embeddedDatabases :: TestTree+embeddedDatabases =+ testGroup "Embedded databases"+ [ testCase "Databases can be embedded" $ do+ view (dbEntityDescriptor . dbEntityName) (_vdbVehiculesA (_embedVehicleDb superDbSettingsDefault)) @?= "vehicules_a"+ view (dbEntityDescriptor . dbEntityName) (_vdbVehiculesB (_embedVehicleDb superDbSettingsDefault)) @?= "vehicules_b"+ , testCase "Databases can be customized when embedded" $ do+ view (dbEntityDescriptor . dbEntityName) (_vdbVehiculesA (_embedVehicleDb superDbSettingsCustom)) @?= "something_random"+ ]+