beam-core 0.8.0.0 → 0.11.1.0

raw patch · 35 files changed

Files

• ChangeLog.md +170/−3
• Database/Beam.hs +1/−1
• Database/Beam/Backend/Internal/Compat.hs +16/−0
• Database/Beam/Backend/SQL.hs +18/−10
• Database/Beam/Backend/SQL/AST.hs +18/−2
• Database/Beam/Backend/SQL/BeamExtensions.hs +206/−54
• 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 +18/−13
• Database/Beam/Backend/SQL/Row.hs +23/−6
• Database/Beam/Backend/SQL/SQL2003.hs +7/−6
• Database/Beam/Backend/SQL/SQL92.hs +45/−38
• Database/Beam/Backend/SQL/SQL99.hs +3/−2
• Database/Beam/Backend/SQL/Types.hs +4/−3
• Database/Beam/Backend/Types.hs +3/−3
• Database/Beam/Backend/URI.hs +3/−6
• Database/Beam/Query.hs +187/−38
• Database/Beam/Query/Adhoc.hs +94/−0
• Database/Beam/Query/Aggregate.hs +9/−9
• Database/Beam/Query/CTE.hs +30/−17
• Database/Beam/Query/Combinators.hs +119/−50
• Database/Beam/Query/CustomSQL.hs +9/−11
• Database/Beam/Query/Extensions.hs +9/−9
• Database/Beam/Query/Extract.hs +3/−2
• Database/Beam/Query/Internal.hs +23/−17
• Database/Beam/Query/Operator.hs +35/−8
• Database/Beam/Query/Ord.hs +40/−16
• Database/Beam/Query/Relationships.hs +9/−9
• Database/Beam/Query/SQL92.hs +97/−79
• Database/Beam/Schema.hs +1/−1
• Database/Beam/Schema/Lenses.hs +9/−2
• Database/Beam/Schema/Tables.hs +152/−89
• beam-core.cabal +38/−24
• test/Database/Beam/Test/SQL.hs +152/−35
• test/Database/Beam/Test/Schema.hs +41/−46

@@ -1,3 +1,171 @@+# 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++ * Aeson 2.0 support++# 0.9.2.0++## Added features++ * Heterogeneous variants of `like_` and `similarTo_`: `like_'` and `similarTo_'`+ * GHC 9.2 and 9.0 support++# 0.9.1.0++## Added features++ * Improve error message when `asc_` or `desc_` is missing in `orderBy_`++# 0.9.0.0++## Removal of machine-dependent `Int`/`Word` instances++Beam now mandates that you use unambiguous integer types like `Int32`, `Int64`, or `Integer` instead of the machine-dependent `Int` or `Word`.+Custom type errors have been added to guide migration where required.++Combinators which previously returned `Int`, such as `countAll_` and `rowNumber_`, now match functions such as `count_` in returning any `Integral` type.+The type of these functions vary across databases and doesn't in general correspond to the `INTEGER` type.+(For example Postgres uses `bigint` for these.)++## `in_` on row values++Beam now supports using `in_` on row values, for backends which support it.+This fulfills the often requested ability to use `in_` on `PrimaryKey`s, e.g. ``primaryKey row `in_` [ ... ]``.++## Miscellaneous added features++ * Support for ad-hoc queries on tables which don't have a corresponding `Beamable` type+ * `HasInsertOnConflict` class for backends which support functionality similar to Postgres and SQLite's `INSERT ... ON CONFLICT`+ * Convenience functions `setEntitySchema` and `modifyEntitySchema`+ * Haskell-style conditionals `ifThenElse_` and `bool_`+ * Poly-kinded instances for `Data.Tagged.Tagged`+ * Variants of update functions which use tri-value `SqlBool`: `update'`, `save'`, `updateRow'`, `updateTableRow'`, and corresponding combinator `references'`+ * GHC 8.8 support++## Minor interface changes++ * Split `WithConstraint` apart, to support strict fields+ * `zipTables` supports `Applicative` actions instead of `Monad`++## Bug fixes++ * Database definition fields can be made strict+ * `decimalType` properly emits SQL 92 `DECIMAL` instead of `DOUBLE`+ # 0.8.0.0  ## Common table expressions@@ -71,7 +239,7 @@  ## Changes to parseOneField and peekField -Formerly, the `peekField` function would attemt to parse a field+Formerly, the `peekField` function would attempt 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@@ -128,7 +296,7 @@ ## Aggregations return `Maybe` types  In previous versions of beam, aggregations such as `avg_`, `sum_`, etc-returned the an expression of the same type as its inputs. However,+returned an expression of the same type as its inputs. However, this does not match standard SQL behavior, where these aggregates can return NULL if no rows are selected for the aggregation. This breaks older code, but is more correct. To restore the older behavior, use@@ -229,4 +397,3 @@ * Split out backends from `beam-core` * Allow non-table entities to be stored in databases * Basic migrations support-

@@ -5,7 +5,7 @@ --   The most interesting modules are "Database.Beam.Schema" and "Database.Beam.Query". -- --   This is mainly reference documentation. Most users will want to consult the---   [manual](https://tathougies.github.io/beam).+--   [manual](https://haskell-beam.github.io/beam). module Database.Beam      ( module Database.Beam.Query      , module Database.Beam.Schema

@@ -0,0 +1,16 @@+-- | This module contains utilities that backend writers can use to assist with+-- compatibility and breaking API changes.+--+-- Users should not need anything from this module.+module Database.Beam.Backend.Internal.Compat where++import GHC.TypeLits++-- | A type error directing the user to use an explicitly sized integers,+-- instead of 'Int' or 'Word'.+type PreferExplicitSize implicit explicit =+  'Text "The size of " ':<>:+  'ShowType implicit ':<>:+  'Text " is machine-dependent. Use an explicitly sized integer such as " ':<>:+  'ShowType explicit ':<>:+  'Text " instead."

@@ -1,3 +1,4 @@+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE UndecidableInstances #-} module Database.Beam.Backend.SQL   ( module Database.Beam.Backend.SQL.Row@@ -63,23 +64,24 @@   , 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           Database.Beam.Backend.SQL.SQL2003+import           Database.Beam.Backend.SQL.Row+import           Database.Beam.Backend.SQL.Types+import           Database.Beam.Backend.Types -import Control.Monad.Cont-import Control.Monad.Except+import           Control.Monad.Cont+import           Control.Monad.Except import qualified Control.Monad.RWS.Lazy as Lazy import qualified Control.Monad.RWS.Strict as Strict-import Control.Monad.Reader+import           Control.Monad.Reader import qualified Control.Monad.State.Lazy as Lazy import qualified Control.Monad.Writer.Lazy as Lazy import qualified Control.Monad.State.Strict as Strict import qualified Control.Monad.Writer.Strict as Strict -import Data.Tagged (Tagged)-import Data.Text (Text)+import           Data.Kind (Type)+import           Data.Tagged (Tagged)+import           Data.Text (Text)  -- * MonadBeam class @@ -131,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.@@ -224,7 +232,7 @@       , Eq (BeamSqlBackendExpressionSyntax be)       ) => BeamSqlBackend be -type family BeamSqlBackendSyntax be :: *+type family BeamSqlBackendSyntax be :: Type  -- | Fake backend that cannot deserialize anything, but is useful for testing data MockSqlBackend syntax

@@ -6,6 +6,7 @@  import Prelude hiding (Ordering) +import Database.Beam.Backend.Internal.Compat import Database.Beam.Backend.SQL.SQL92 import Database.Beam.Backend.SQL.SQL99 import Database.Beam.Backend.SQL.SQL2003@@ -17,6 +18,7 @@ import Data.Word (Word16, Word32, Word64) import Data.Typeable import Data.Int+import GHC.TypeLits  data Command   = SelectCommand Select@@ -154,6 +156,7 @@    | ExtractFieldDateTimeYear   | ExtractFieldDateTimeMonth+  | ExtractFieldDateTimeWeek   | ExtractFieldDateTimeDay   | ExtractFieldDateTimeHour   | ExtractFieldDateTimeMinute@@ -232,6 +235,7 @@   | ExpressionRow [ Expression ]    | ExpressionIn Expression [ Expression ]+  | ExpressionInSelect Expression Select    | ExpressionIsNull Expression   | ExpressionIsNotNull Expression@@ -288,6 +292,7 @@   minutesField = ExtractFieldDateTimeMinute   hourField = ExtractFieldDateTimeHour   dayField = ExtractFieldDateTimeDay+  weekField = ExtractFieldDateTimeWeek   monthField = ExtractFieldDateTimeMonth   yearField = ExtractFieldDateTimeYear @@ -357,6 +362,7 @@    defaultE = ExpressionDefault   inE = ExpressionIn+  inSelectE = ExpressionInSelect  instance IsSql99FunctionExpressionSyntax Expression where   functionNameE = ExpressionNamedFunction@@ -460,6 +466,12 @@    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) @@ -502,11 +514,9 @@   Value :: (Show a, Eq a, Typeable a) => a -> Value  #define VALUE_SYNTAX_INSTANCE(ty) instance HasSqlValueSyntax Value ty where { sqlValueSyntax = Value }-VALUE_SYNTAX_INSTANCE(Int) VALUE_SYNTAX_INSTANCE(Int16) VALUE_SYNTAX_INSTANCE(Int32) VALUE_SYNTAX_INSTANCE(Int64)-VALUE_SYNTAX_INSTANCE(Word) VALUE_SYNTAX_INSTANCE(Word16) VALUE_SYNTAX_INSTANCE(Word32) VALUE_SYNTAX_INSTANCE(Word64)@@ -521,6 +531,12 @@ VALUE_SYNTAX_INSTANCE(SqlNull) VALUE_SYNTAX_INSTANCE(Double) VALUE_SYNTAX_INSTANCE(Bool)++instance TypeError (PreferExplicitSize Int Int32) => HasSqlValueSyntax Value Int where+  sqlValueSyntax = Value++instance TypeError (PreferExplicitSize Word Word32) => HasSqlValueSyntax Value Word where+  sqlValueSyntax = Value  instance HasSqlValueSyntax Value x => HasSqlValueSyntax Value (Maybe x) where   sqlValueSyntax (Just x) = sqlValueSyntax x

@@ -1,3 +1,4 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# 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@@ -8,128 +9,279 @@ -- 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   ) where -import Database.Beam.Backend-import Database.Beam.Query-import Database.Beam.Schema+import           Database.Beam.Backend+import           Database.Beam.Query+import           Database.Beam.Query.Internal+import           Database.Beam.Schema+import           Database.Beam.Schema.Tables -import Control.Monad.Identity-import Control.Monad.Cont-import Control.Monad.Except+import           Control.Monad.Cont+import           Control.Monad.Except+import           Control.Monad.Identity import qualified Control.Monad.RWS.Lazy as Lazy import qualified Control.Monad.RWS.Strict as Strict-import Control.Monad.Reader+import           Control.Monad.Reader import qualified Control.Monad.State.Lazy as Lazy-import qualified Control.Monad.Writer.Lazy as Lazy import qualified Control.Monad.State.Strict as Strict+import qualified Control.Monad.Writer.Lazy as Lazy import qualified Control.Monad.Writer.Strict as Strict+import           Data.Functor.Const+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+  data SqlConflictTarget be (table :: (Type -> Type) -> Type) :: Type+  -- | What to do when an @INSERT@ statement inserts a row into the table @tbl@+  -- that violates a constraint.+  data SqlConflictAction be (table :: (Type -> Type) -> Type) :: Type++  insertOnConflict+    :: Beamable table+    => DatabaseEntity be db (TableEntity table)+    -> SqlInsertValues be (table (QExpr be s))+    -> SqlConflictTarget be table+    -> SqlConflictAction be table+    -> SqlInsert be table++  anyConflict :: SqlConflictTarget be table+  conflictingFields+    :: Projectible be proj+    => (table (QExpr be QInternal) -> proj)+    -> SqlConflictTarget be table+  conflictingFieldsWhere+    :: Projectible be proj+    => (table (QExpr be QInternal) -> proj)+    -> (forall s. table (QExpr be s) -> QExpr be s Bool)+    -> SqlConflictTarget be table++  onConflictDoNothing :: SqlConflictAction be table+  onConflictUpdateSet+    :: Beamable table+    => (forall s. table (QField s) -> table (QExpr be s) -> QAssignment be s)+    -> SqlConflictAction be table+  onConflictUpdateSetWhere+    :: Beamable table+    => (forall s. table (QField s) -> table (QExpr be s) -> QAssignment be s)+    -> (forall s. table (QField s) -> table (QExpr be s) -> QExpr be s Bool)+    -> SqlConflictAction be table++newtype InaccessibleQAssignment be = InaccessibleQAssignment+  { unInaccessibleQAssignment :: [(BeamSqlBackendFieldNameSyntax be, BeamSqlBackendExpressionSyntax be)]+  } deriving (Data.Semigroup.Semigroup, Monoid)++onConflictUpdateInstead+  :: forall be table proj+  .  ( BeamHasInsertOnConflict be+     , Beamable table+     , ProjectibleWithPredicate AnyType () (InaccessibleQAssignment be) proj+     )+  => (table (Const (InaccessibleQAssignment be)) -> proj)+  -> SqlConflictAction be table+onConflictUpdateInstead mkProj = onConflictUpdateSet mkAssignments+  where+    mkAssignments+      :: forall s+      .  table (QField s)+      -> table (QExpr be s)+      -> QAssignment be s+    mkAssignments table excluded = QAssignment $ unInaccessibleQAssignment $+      Strict.execWriter $ project'+        (Proxy @AnyType)+        (Proxy @((), InaccessibleQAssignment be))+        (\_ _ a -> Strict.tell a >> return a)+        (mkProj $ runIdentity $ zipBeamFieldsM mkAssignment table excluded)+    mkAssignment+      :: forall s a+      .  Columnar' (QField s) a+      -> Columnar' (QExpr be s) a+      -> Identity (Columnar' (Const (InaccessibleQAssignment be)) a)+    mkAssignment (Columnar' field) (Columnar' value) =+      Identity $ Columnar' $ Const $+        InaccessibleQAssignment $ unQAssignment $ field <-. value++onConflictUpdateAll+  :: forall be table+  .  ( BeamHasInsertOnConflict be+     , Beamable table+     )+  => SqlConflictAction be table+onConflictUpdateAll = onConflictUpdateInstead id

@@ -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

@@ -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)

@@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# LANGUAGE PolyKinds #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE UndecidableInstances #-}  -- | Provides a syntax 'SqlSyntaxBuilder' that uses a --   'Data.ByteString.Builder.Builder' to construct SQL expressions as strings.@@ -18,8 +19,8 @@   , quoteSql   , renderSql ) where +import           Database.Beam.Backend.Internal.Compat import           Database.Beam.Backend.SQL---import           Database.Beam.Backend.Types  import           Control.Monad.IO.Class @@ -35,9 +36,7 @@ import           Data.Int import           Data.String import qualified Control.Monad.Fail as Fail-#if !MIN_VERSION_base(4, 11, 0)-import           Data.Semigroup-#endif+import           GHC.TypeLits  -- | The main syntax. A wrapper over 'Builder' newtype SqlSyntaxBuilder@@ -57,12 +56,11 @@   a == b = toLazyByteString (buildSql a) == toLazyByteString (buildSql b)  instance Semigroup SqlSyntaxBuilder where-  (<>) = mappend+  SqlSyntaxBuilder a <> SqlSyntaxBuilder b =  SqlSyntaxBuilder (a <> b)  instance Monoid SqlSyntaxBuilder where   mempty = SqlSyntaxBuilder mempty-  mappend (SqlSyntaxBuilder a) (SqlSyntaxBuilder b) =-    SqlSyntaxBuilder (mappend a b)+  mappend = (<>)  instance IsSql92Syntax SqlSyntaxBuilder where   type Sql92SelectSyntax SqlSyntaxBuilder = SqlSyntaxBuilder@@ -193,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") @@ -274,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))@@ -405,6 +406,9 @@                     buildSepBy (byteString ", ") (map buildSql vs) <>                     byteString ")") vss) +instance IsSql92SchemaNameSyntax SqlSyntaxBuilder where+  schemaName = SqlSyntaxBuilder . quoteSql+ instance IsSql92TableNameSyntax SqlSyntaxBuilder where   tableName Nothing t  = SqlSyntaxBuilder $ quoteSql t   tableName (Just s) t = SqlSyntaxBuilder $ quoteSql s <> byteString "." <> quoteSql t@@ -433,7 +437,7 @@     varBitType prec = SqlSyntaxBuilder ("BIT VARYING" <> sqlOptPrec prec)      numericType prec = SqlSyntaxBuilder ("NUMERIC" <> sqlOptNumericPrec prec)-    decimalType prec = SqlSyntaxBuilder ("DOUBLE" <> sqlOptNumericPrec prec)+    decimalType prec = SqlSyntaxBuilder ("DECIMAL" <> sqlOptNumericPrec prec)      intType = SqlSyntaxBuilder "INT"     smallIntType = SqlSyntaxBuilder "SMALLINT"@@ -461,9 +465,6 @@ sqlOptNumericPrec (Just (prec, Just dec)) = "(" <> fromString (show prec) <> ", " <> fromString (show dec) <> ")"  -- TODO These instances are wrong (Text doesn't handle quoting for example)-instance HasSqlValueSyntax SqlSyntaxBuilder Int where-  sqlValueSyntax x = SqlSyntaxBuilder $-    byteString (fromString (show x)) instance HasSqlValueSyntax SqlSyntaxBuilder Int32 where   sqlValueSyntax x = SqlSyntaxBuilder $     byteString (fromString (show x))@@ -475,6 +476,10 @@     byteString (fromString (show x)) instance HasSqlValueSyntax SqlSyntaxBuilder SqlNull where   sqlValueSyntax _ = SqlSyntaxBuilder (byteString "NULL")++instance TypeError (PreferExplicitSize Int Int32) => HasSqlValueSyntax SqlSyntaxBuilder Int where+  sqlValueSyntax x = SqlSyntaxBuilder $+    byteString (fromString (show x))  renderSql :: SqlSyntaxBuilder -> String renderSql (SqlSyntaxBuilder b) = BL.unpack (toLazyByteString b)

@@ -3,6 +3,8 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-}  module Database.Beam.Backend.SQL.Row   ( FromBackendRowF(..), FromBackendRowM(..)@@ -11,6 +13,9 @@   , ColumnParseError(..), BeamRowReadError(..)    , FromBackendRow(..)++    -- * Exported so we can override defaults+  , GFromBackendRow(..) -- for 'runSelectReturningList' and co   ) where  import           Database.Beam.Backend.SQL.Types@@ -18,16 +23,16 @@  import           Control.Applicative import           Control.Exception (Exception)+import           Control.Monad import           Control.Monad.Free.Church import           Control.Monad.Identity+import           Data.Kind (Type) 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 qualified Control.Monad.Fail as Fail  import           GHC.Generics import           GHC.TypeLits@@ -57,7 +62,11 @@   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)+instance Functor (FromBackendRowF be) where+  fmap f = \case+    ParseOneField p -> ParseOneField $ f . p+    Alt a b p -> Alt a b $ f . p+    FailParseWith e -> FailParseWith e newtype FromBackendRowM be a = FromBackendRowM (F (FromBackendRowF be) a)   deriving (Functor, Applicative) @@ -67,11 +76,12 @@     FromBackendRowM $     a >>= (\x -> let FromBackendRowM b' = b x in b') +instance Fail.MonadFail (FromBackendRowM be) where   fail = FromBackendRowM . liftF . FailParseWith .          BeamRowReadError Nothing . ColumnErrorInternal  instance Alternative (FromBackendRowM be) where-  empty   = fail "empty"+  empty   = Fail.fail "empty"   a <|> b =     FromBackendRowM (liftF (Alt a b id)) @@ -95,7 +105,9 @@   valuesNeeded :: Proxy be -> Proxy a -> Int   valuesNeeded _ _ = 1 -class GFromBackendRow be (exposed :: * -> *) rep where+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 instance GFromBackendRow be e p => GFromBackendRow be (M1 t f e) (M1 t f p) where@@ -110,6 +122,9 @@ 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     gFromBackendRow _ = K1 <$> fromBackendRow     gValuesNeeded be _ _ = valuesNeeded be (Proxy @(t Identity))@@ -191,7 +206,9 @@                       pure ()))   valuesNeeded be _ = valuesNeeded be (Proxy @x) +#if !MIN_VERSION_base(4, 16, 0) deriving instance Generic (a, b, c, d, e, f, g, h)+#endif  instance (BeamBackend be, FromBackendRow be t) => FromBackendRow be (Tagged tag t) where   fromBackendRow = Tagged <$> fromBackendRow

@@ -25,6 +25,7 @@  import Database.Beam.Backend.SQL.SQL99 +import Data.Kind (Type) import Data.Text (Text)  type Sql2003SanityCheck syntax =@@ -36,7 +37,7 @@ class IsSql92FromSyntax from =>     IsSql2003FromSyntax from where -    type Sql2003FromSampleMethodSyntax from :: *+    type Sql2003FromSampleMethodSyntax from :: Type      fromTableSample :: Sql92FromTableSourceSyntax from                     -> Sql2003FromSampleMethodSyntax from@@ -54,7 +55,7 @@       , IsSql2003WindowFrameSyntax (Sql2003ExpressionWindowFrameSyntax expr) ) =>     IsSql2003ExpressionSyntax expr where -    type Sql2003ExpressionWindowFrameSyntax expr :: *+    type Sql2003ExpressionWindowFrameSyntax expr :: Type      overE :: expr           -> Sql2003ExpressionWindowFrameSyntax expr@@ -83,9 +84,9 @@  class IsSql2003WindowFrameBoundsSyntax (Sql2003WindowFrameBoundsSyntax frame) =>     IsSql2003WindowFrameSyntax frame where-    type Sql2003WindowFrameExpressionSyntax frame :: *-    type Sql2003WindowFrameOrderingSyntax frame :: *-    type Sql2003WindowFrameBoundsSyntax frame :: *+    type Sql2003WindowFrameExpressionSyntax frame :: Type+    type Sql2003WindowFrameOrderingSyntax frame :: Type+    type Sql2003WindowFrameBoundsSyntax frame :: Type      frameSyntax :: Maybe [Sql2003WindowFrameExpressionSyntax frame]                 -> Maybe [Sql2003WindowFrameOrderingSyntax frame]@@ -94,7 +95,7 @@  class IsSql2003WindowFrameBoundSyntax (Sql2003WindowFrameBoundsBoundSyntax bounds) =>     IsSql2003WindowFrameBoundsSyntax bounds where-    type Sql2003WindowFrameBoundsBoundSyntax bounds :: *+    type Sql2003WindowFrameBoundsBoundSyntax bounds :: Type     fromToBoundSyntax :: Sql2003WindowFrameBoundsBoundSyntax bounds                       -> Maybe (Sql2003WindowFrameBoundsBoundSyntax bounds)                       -> bounds

@@ -7,6 +7,7 @@ import Database.Beam.Backend.SQL.Row  import Data.Int+import Data.Kind (Type) import Data.Tagged import Data.Text (Text) import Data.Time (LocalTime)@@ -71,7 +72,7 @@   )  type Sql92ReasonableMarshaller be =-   ( FromBackendRow be Int, FromBackendRow be SqlNull+   ( FromBackendRow be SqlNull    , FromBackendRow be Text, FromBackendRow be Bool    , FromBackendRow be Char    , FromBackendRow be Int16, FromBackendRow be Int32, FromBackendRow be Int64@@ -89,10 +90,10 @@       , IsSql92UpdateSyntax (Sql92UpdateSyntax cmd)       , IsSql92DeleteSyntax (Sql92DeleteSyntax cmd) ) =>   IsSql92Syntax cmd where-  type Sql92SelectSyntax cmd :: *-  type Sql92InsertSyntax cmd :: *-  type Sql92UpdateSyntax cmd :: *-  type Sql92DeleteSyntax cmd :: *+  type Sql92SelectSyntax cmd :: Type+  type Sql92InsertSyntax cmd :: Type+  type Sql92UpdateSyntax cmd :: Type+  type Sql92DeleteSyntax cmd :: Type    selectCmd :: Sql92SelectSyntax cmd -> cmd   insertCmd :: Sql92InsertSyntax cmd -> cmd@@ -102,8 +103,8 @@ class ( IsSql92SelectTableSyntax (Sql92SelectSelectTableSyntax select)       , IsSql92OrderingSyntax (Sql92SelectOrderingSyntax select) ) =>     IsSql92SelectSyntax select where-    type Sql92SelectSelectTableSyntax select :: *-    type Sql92SelectOrderingSyntax select :: *+    type Sql92SelectSelectTableSyntax select :: Type+    type Sql92SelectOrderingSyntax select :: Type      selectStmt :: Sql92SelectSelectTableSyntax select                -> [Sql92SelectOrderingSyntax select]@@ -124,12 +125,12 @@        , Eq (Sql92SelectTableExpressionSyntax select) ) =>     IsSql92SelectTableSyntax select where-  type Sql92SelectTableSelectSyntax select :: *-  type Sql92SelectTableExpressionSyntax select :: *-  type Sql92SelectTableProjectionSyntax select :: *-  type Sql92SelectTableFromSyntax select :: *-  type Sql92SelectTableGroupingSyntax select :: *-  type Sql92SelectTableSetQuantifierSyntax select :: *+  type Sql92SelectTableSelectSyntax select :: Type+  type Sql92SelectTableExpressionSyntax select :: Type+  type Sql92SelectTableProjectionSyntax select :: Type+  type Sql92SelectTableFromSyntax select :: Type+  type Sql92SelectTableGroupingSyntax select :: Type+  type Sql92SelectTableSetQuantifierSyntax select :: Type    selectTableStmt :: Maybe (Sql92SelectTableSetQuantifierSyntax select)                   -> Sql92SelectTableProjectionSyntax select@@ -146,8 +147,8 @@       , IsSql92TableNameSyntax (Sql92InsertTableNameSyntax insert) ) =>   IsSql92InsertSyntax insert where -  type Sql92InsertValuesSyntax insert :: *-  type Sql92InsertTableNameSyntax insert :: *+  type Sql92InsertValuesSyntax insert :: Type+  type Sql92InsertTableNameSyntax insert :: Type    insertStmt :: Sql92InsertTableNameSyntax insert              -> [ Text ]@@ -157,8 +158,8 @@  class IsSql92ExpressionSyntax (Sql92InsertValuesExpressionSyntax insertValues) =>   IsSql92InsertValuesSyntax insertValues where-  type Sql92InsertValuesExpressionSyntax insertValues :: *-  type Sql92InsertValuesSelectSyntax insertValues :: *+  type Sql92InsertValuesExpressionSyntax insertValues :: Type+  type Sql92InsertValuesSelectSyntax insertValues :: Type    insertSqlExpressions :: [ [ Sql92InsertValuesExpressionSyntax insertValues ] ]                        -> insertValues@@ -170,9 +171,9 @@       , IsSql92TableNameSyntax (Sql92UpdateTableNameSyntax update) ) =>       IsSql92UpdateSyntax update where -  type Sql92UpdateTableNameSyntax update :: *-  type Sql92UpdateFieldNameSyntax update :: *-  type Sql92UpdateExpressionSyntax update :: *+  type Sql92UpdateTableNameSyntax  update :: Type+  type Sql92UpdateFieldNameSyntax  update :: Type+  type Sql92UpdateExpressionSyntax update :: Type    updateStmt :: Sql92UpdateTableNameSyntax update              -> [(Sql92UpdateFieldNameSyntax update, Sql92UpdateExpressionSyntax update)]@@ -182,8 +183,8 @@ class ( IsSql92TableNameSyntax (Sql92DeleteTableNameSyntax delete)       , IsSql92ExpressionSyntax (Sql92DeleteExpressionSyntax delete) ) =>   IsSql92DeleteSyntax delete where-  type Sql92DeleteTableNameSyntax delete :: *-  type Sql92DeleteExpressionSyntax delete :: *+  type Sql92DeleteTableNameSyntax  delete :: Type+  type Sql92DeleteExpressionSyntax delete :: Type    deleteStmt :: Sql92DeleteTableNameSyntax delete -> Maybe Text              -> Maybe (Sql92DeleteExpressionSyntax delete)@@ -205,6 +206,7 @@   minutesField :: extractField   hourField :: extractField   dayField :: extractField+  weekField :: extractField   monthField :: extractField   yearField :: extractField @@ -229,7 +231,7 @@   timestampType :: Maybe Word -> Bool {-^ With time zone -} -> dataType   -- TODO interval type -class ( HasSqlValueSyntax (Sql92ExpressionValueSyntax expr) Int+class ( HasSqlValueSyntax (Sql92ExpressionValueSyntax expr) Int32       , HasSqlValueSyntax (Sql92ExpressionValueSyntax expr) Bool       , IsSql92FieldNameSyntax (Sql92ExpressionFieldNameSyntax expr)       , IsSql92QuantifierSyntax (Sql92ExpressionQuantifierSyntax expr)@@ -237,12 +239,12 @@       , IsSql92ExtractFieldSyntax (Sql92ExpressionExtractFieldSyntax expr)       , Typeable expr ) =>     IsSql92ExpressionSyntax expr where-  type Sql92ExpressionQuantifierSyntax expr :: *-  type Sql92ExpressionValueSyntax expr :: *-  type Sql92ExpressionSelectSyntax expr :: *-  type Sql92ExpressionFieldNameSyntax expr :: *-  type Sql92ExpressionCastTargetSyntax expr :: *-  type Sql92ExpressionExtractFieldSyntax expr :: *+  type Sql92ExpressionQuantifierSyntax expr :: Type+  type Sql92ExpressionValueSyntax      expr :: Type+  type Sql92ExpressionSelectSyntax     expr :: Type+  type Sql92ExpressionFieldNameSyntax  expr :: Type+  type Sql92ExpressionCastTargetSyntax expr :: Type+  type Sql92ExpressionExtractFieldSyntax expr :: Type    valueE :: Sql92ExpressionValueSyntax expr -> expr @@ -314,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@@ -321,7 +324,7 @@ class IsSql92AggregationSetQuantifierSyntax (Sql92AggregationSetQuantifierSyntax expr) =>   IsSql92AggregationExpressionSyntax expr where -  type Sql92AggregationSetQuantifierSyntax expr :: *+  type Sql92AggregationSetQuantifierSyntax expr :: Type    countAllE :: expr   countE, avgE, maxE, minE, sumE@@ -331,16 +334,20 @@   setQuantifierDistinct, setQuantifierAll :: q  class IsSql92ExpressionSyntax (Sql92ProjectionExpressionSyntax proj) => IsSql92ProjectionSyntax proj where-  type Sql92ProjectionExpressionSyntax proj :: *+  type Sql92ProjectionExpressionSyntax proj :: Type    projExprs :: [ (Sql92ProjectionExpressionSyntax proj, Maybe Text) ]             -> proj  class IsSql92OrderingSyntax ord where-  type Sql92OrderingExpressionSyntax ord :: *+  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 -}             -> Text {-^ Table name -}@@ -349,9 +356,9 @@ class IsSql92TableNameSyntax (Sql92TableSourceTableNameSyntax tblSource) =>   IsSql92TableSourceSyntax tblSource where -  type Sql92TableSourceSelectSyntax tblSource :: *-  type Sql92TableSourceExpressionSyntax tblSource :: *-  type Sql92TableSourceTableNameSyntax tblSource :: *+  type Sql92TableSourceSelectSyntax tblSource :: Type+  type Sql92TableSourceExpressionSyntax tblSource :: Type+  type Sql92TableSourceTableNameSyntax tblSource :: Type    tableNamed :: Sql92TableSourceTableNameSyntax tblSource              -> tblSource@@ -359,15 +366,15 @@   tableFromValues :: [ [ Sql92TableSourceExpressionSyntax tblSource ] ] -> tblSource  class IsSql92GroupingSyntax grouping where-  type Sql92GroupingExpressionSyntax grouping :: *+  type Sql92GroupingExpressionSyntax grouping :: Type    groupByExpressions :: [ Sql92GroupingExpressionSyntax grouping ] -> grouping  class ( IsSql92TableSourceSyntax (Sql92FromTableSourceSyntax from)       , IsSql92ExpressionSyntax (Sql92FromExpressionSyntax from) ) =>     IsSql92FromSyntax from where-  type Sql92FromTableSourceSyntax from :: *-  type Sql92FromExpressionSyntax from :: *+  type Sql92FromTableSourceSyntax from :: Type+  type Sql92FromExpressionSyntax from :: Type    fromTable :: Sql92FromTableSourceSyntax from             -> Maybe (Text, Maybe [Text])

@@ -15,6 +15,7 @@  import Database.Beam.Backend.SQL.SQL92 +import Data.Kind ( Type ) import Data.Text ( Text )  class IsSql92SelectSyntax select =>@@ -53,7 +54,7 @@  class IsSql92SelectSyntax syntax =>   IsSql99CommonTableExpressionSelectSyntax syntax where-  type Sql99SelectCTESyntax syntax :: *+  type Sql99SelectCTESyntax syntax :: Type    withSyntax :: [ Sql99SelectCTESyntax syntax ] -> syntax -> syntax @@ -63,6 +64,6 @@   withRecursiveSyntax :: [ Sql99SelectCTESyntax syntax ] -> syntax -> syntax  class IsSql99CommonTableExpressionSyntax syntax where-  type Sql99CTESelectSyntax syntax :: *+  type Sql99CTESelectSyntax syntax :: Type    cteSubquerySyntax :: Text -> [Text] -> Sql99CTESelectSyntax syntax -> syntax

@@ -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

@@ -6,13 +6,13 @@   , Exposed, Nullable    ) where+import Data.Kind (Type, Constraint) -import           GHC.Types  -- | 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+  type BackendFromField be :: Type -> Constraint  -- | newtype mainly used to inspect the tag structure of a particular --   'Beamable'. Prevents overlapping instances in some case. Usually not used@@ -27,4 +27,4 @@ -- >                 deriving (Generic, Typeable) -- -- See 'Columnar' for more information.-data Nullable (c :: * -> *) x+data Nullable (c :: Type -> Type) x

@@ -6,9 +6,6 @@ import           Control.Exception  import qualified Data.Map as M-#if !MIN_VERSION_base(4, 11, 0)-import           Data.Semigroup-#endif  import           Network.URI @@ -30,12 +27,12 @@   BeamURIOpeners :: M.Map String (BeamURIOpener c) -> BeamURIOpeners c  instance Semigroup (BeamURIOpeners c) where-  (<>) = mappend+  BeamURIOpeners a <> BeamURIOpeners b =+    BeamURIOpeners (a <> b)  instance Monoid (BeamURIOpeners c) where   mempty = BeamURIOpeners mempty-  mappend (BeamURIOpeners a) (BeamURIOpeners b) =-    BeamURIOpeners (mappend a b)+  mappend = (<>)  data OpenedBeamConnection c where   OpenedBeamConnection

@@ -19,6 +19,7 @@      , QBaseScope +     , module Database.Beam.Query.Combinators     , module Database.Beam.Query.Extensions @@ -32,7 +33,6 @@     , module Database.Beam.Query.Operator      -- ** ANSI SQL Booleans-    , Beam.SqlBool     , isTrue_, isNotTrue_     , isFalse_, isNotFalse_     , isUnknown_, isNotUnknown_@@ -42,14 +42,16 @@      -- ** Unquantified comparison operators     , HasSqlEqualityCheck(..), HasSqlQuantifiedEqualityCheck(..)-    , SqlEq(..), SqlOrd(..)+    , HasTableEquality+    , SqlEq(..), SqlOrd(..), SqlIn(..)+    , HasSqlInTable(..)+    , inQuery_      -- ** Quantified Comparison Operators #quantified-comparison-operator#     , SqlEqQuantified(..), SqlOrdQuantified(..)     , QQuantified     , anyOf_, allOf_, anyIn_, allIn_     , between_-    , in_      , module Database.Beam.Query.Aggregate @@ -63,6 +65,7 @@     , select, selectWith, lookup_     , runSelectReturningList     , runSelectReturningOne+    , runSelectReturningFirst     , dumpSqlSelect      -- ** @INSERT@@@ -79,10 +82,13 @@     -- ** @UPDATE@     , SqlUpdate(..)     , update, save-    , updateTable, set, setFieldsTo+    , update', save'+    , updateTable, updateTable'+    , set, setFieldsTo     , toNewValue, toOldValue, toUpdatedValue     , toUpdatedValueMaybe     , updateRow, updateTableRow+    , updateRow', updateTableRow'     , runUpdate      -- ** @DELETE@@@ -101,8 +107,7 @@ 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+import Database.Beam.Query.Operator import Database.Beam.Query.Ord import Database.Beam.Query.Relationships import Database.Beam.Query.Types (QGenExpr) -- hide QGenExpr constructor@@ -116,6 +121,7 @@ import Control.Monad.Writer import Control.Monad.State.Strict +import Data.Kind (Type) import Data.Functor.Const (Const(..)) import Data.Text (Text) import Data.Proxy@@ -191,6 +197,15 @@ 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'. dumpSqlSelect :: Projectible (MockSqlBackend SqlSyntaxBuilder) res@@ -202,7 +217,7 @@ -- * INSERT  -- | Represents a SQL @INSERT@ command that has not yet been run-data SqlInsert be (table :: (* -> *) -> *)+data SqlInsert be (table :: (Type -> Type) -> Type)   = SqlInsert !(TableSettings table) !(BeamSqlBackendInsertSyntax be)   | SqlInsertNoRows @@ -241,7 +256,7 @@  -- | Represents a source of values that can be inserted into a table shaped like --   'tbl'.-data SqlInsertValues be proj --(tbl :: (* -> *) -> *)+data SqlInsertValues be proj     = SqlInsertValues (BeamSqlBackendInsertValuesSyntax be)     | SqlInsertValuesEmpty @@ -287,13 +302,43 @@ -- * UPDATE  -- | Represents a SQL @UPDATE@ statement for the given @table@.-data SqlUpdate be (table :: (* -> *) -> *)+data SqlUpdate be (table :: (Type -> Type) -> Type)   = 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 --   build a @WHERE@ clause. --+--   An internal implementation for 'update' and 'update'' functions.+--   Allows to choose boolean type in the @WHERE@ clause.+updateImpl :: forall bool table db be+            . ( BeamSqlBackend be, Beamable table )+           => DatabaseEntity be db (TableEntity table)+              -- ^ The table to insert into+           -> (forall s. table (QField s) -> QAssignment be s)+              -- ^ A sequence of assignments to make.+           -> (forall s. table (QExpr be s) -> QExpr be s bool)+              -- ^ Build a @WHERE@ clause given a table containing expressions+           -> SqlUpdate be table+updateImpl (DatabaseEntity dt@(DatabaseTable {})) mkAssignments mkWhere =+  case assignments of+    [] -> SqlIdentityUpdate+    _  -> SqlUpdate (dbTableSettings dt)+                    (updateStmt (tableNameFromEntity dt)+                       assignments (Just (where_ "t")))+  where+    QAssignment assignments = mkAssignments tblFields+    QExpr where_ = mkWhere tblFieldExprs++    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++-- | Build a 'SqlUpdate' given a table, a list of assignments, and a way to+--   build a @WHERE@ clause.+--+--   Use 'update'' for comparisons with 'SqlBool'.+-- --   See the '(<-.)' operator for ways to build assignments. The argument to the --   second argument is a the table parameterized over 'QField', which --   represents the left hand side of assignments. Sometimes, you'd like to also@@ -307,21 +352,31 @@        -> (forall s. table (QExpr be s) -> QExpr be s Bool)           -- ^ Build a @WHERE@ clause given a table containing expressions        -> SqlUpdate be table-update (DatabaseEntity dt@(DatabaseTable {})) mkAssignments mkWhere =-  case assignments of-    [] -> SqlIdentityUpdate-    _  -> SqlUpdate (dbTableSettings dt)-                    (updateStmt (tableNameFromEntity dt)-                       assignments (Just (where_ "t")))-  where-    QAssignment assignments = mkAssignments tblFields-    QExpr where_ = mkWhere tblFieldExprs+update = updateImpl @Bool -    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+-- | Build a 'SqlUpdate' given a table, a list of assignments, and a way to+--   build a @WHERE@ clause.+--+--   Uses a 'SqlBool' comparison. Use 'update' for comparisons with 'Bool'.+--+--   See the '(<-.)' operator for ways to build assignments. The argument to the+--   second argument is a the table parameterized over 'QField', which+--   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' :: ( BeamSqlBackend be, Beamable table )+        => DatabaseEntity be db (TableEntity table)+           -- ^ The table to insert into+        -> (forall s. table (QField s) -> QAssignment be s)+           -- ^ A sequence of assignments to make.+        -> (forall s. table (QExpr be s) -> QExpr be s SqlBool)+           -- ^ Build a @WHERE@ clause given a table containing expressions+        -> SqlUpdate be table+update' = updateImpl @SqlBool --- | A specialization of 'update' that matches the given (already existing) row+-- | A specialization of 'update' that matches the given (already existing) row.+--+--   Use 'updateRow'' for an internal 'SqlBool' comparison. updateRow :: ( BeamSqlBackend be, Table table              , HasTableEquality be (PrimaryKey table)              , SqlValableTable be (PrimaryKey table) )@@ -332,19 +387,38 @@           -> (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)))+updateRow tbl row assignments =+  update tbl assignments (references_ (val_ (pk row))) +-- | A specialization of 'update'' that matches the given (already existing) row.+--+--   Use 'updateRow' for an internal 'Bool' comparison.+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 assignments =+  update' tbl assignments (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 =+--+--   An internal implementation of 'updateTable' and 'updateTable'' functions.+--   Allows choosing between 'Bool' and 'SqlBool'.+updateTableImpl :: forall bool 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+updateTableImpl tblEntity assignments mkWhere =   let mkAssignments :: forall s. table (QField s) -> QAssignment be s       mkAssignments tblFields =         let tblExprs = changeBeamRep (\(Columnar' fd) -> Columnar' (current_ fd)) tblFields@@ -359,10 +433,38 @@                     pure c)              tblFields assignments -  in update tblEntity mkAssignments mkWhere+  in updateImpl tblEntity mkAssignments mkWhere +-- | A specialization of 'update' that is more convenient for normal tables.+--+--   Use 'updateTable'' for comparisons with 'SqlBool'.+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 = updateTableImpl @Bool++-- | A specialization of 'update'' that is more convenient for normal tables.+--+--   Use 'updateTable' for comparisons with 'Bool'.+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 SqlBool)+             -> SqlUpdate be table+updateTable' = updateTableImpl @SqlBool+ -- | Convenience form of 'updateTable' that generates a @WHERE@ clause--- that matches only the already existing entity+-- that matches only the already existing entity.+--+-- Use 'updateTableRow'' for an internal 'SqlBool' comparison. updateTableRow :: ( BeamSqlBackend be, Table table                   , HasTableEquality be (PrimaryKey table)                   , SqlValableTable be (PrimaryKey table) )@@ -373,9 +475,27 @@                -> 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)))+updateTableRow tbl row assignments =+  updateTable tbl assignments (references_ (val_ (pk row))) +-- | Convenience form of 'updateTable'' that generates a @WHERE@ clause+-- that matches only the already existing entity.+--+-- Uses 'update'' with a 'SqlBool' comparison.+-- Use 'updateTableRow' for an internal 'Bool' comparison.+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 assignments =+  updateTable' tbl assignments (references_' (val_ (pk row)))+ set :: forall table be table'. Beamable table => table (QFieldAssignment be table') set = changeBeamRep (\_ -> Columnar' (QFieldAssignment (\_ -> Nothing))) (tblSkeleton :: TableSkeleton table) @@ -429,6 +549,8 @@ --   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.+--+--   Use 'save'' for an internal 'SqlBool' comparison. save :: forall table be db.         ( Table table         , BeamSqlBackend be@@ -447,6 +569,33 @@   updateTableRow tbl v     (setFieldsTo (val_ v)) +-- | Generate a 'SqlUpdate' that will update the given table row with the given value.+-- This is a variant using 'update'' and a 'SqlBool' comparison.+--+--   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.+--+--   Use 'save' for an internal 'Bool' comparison.+save' :: forall table be db.+         ( Table table+         , BeamSqlBackend be++         , SqlValableTable be (PrimaryKey table)+         , SqlValableTable be table++         , HasTableEquality be (PrimaryKey table)+         )+      => DatabaseEntity be db (TableEntity table)+         -- ^ Table to update+      -> table Identity+         -- ^ Value to set to+      -> SqlUpdate be table+save' tbl v =+  updateTableRow' tbl v+    (setFieldsTo (val_ v))+ -- | Run a 'SqlUpdate' in a 'MonadBeam'. runUpdate :: (BeamSqlBackend be, MonadBeam be m)           => SqlUpdate be tbl -> m ()@@ -456,7 +605,7 @@ -- * DELETE  -- | Represents a SQL @DELETE@ statement for the given @table@-data SqlDelete be (table :: (* -> *) -> *)+data SqlDelete be (table :: (Type -> Type) -> Type)   = SqlDelete !(TableSettings table) !(BeamSqlBackendDeleteSyntax be)  -- | Build a 'SqlDelete' from a table and a way to build a @WHERE@ clause

@@ -0,0 +1,94 @@+-- | This module contains support for defining "ad-hoc" queries. That+-- is queries on tables that do not necessarily have corresponding+-- 'Beamable' table types.+module Database.Beam.Query.Adhoc+  ( Adhoc(..)++  , NamedField+  , table_, field_+  ) where++import           Database.Beam.Query.Internal+import           Database.Beam.Backend.SQL++import           Control.Monad.Free.Church++import           Data.Kind (Type)+import qualified Data.Text as T++class Adhoc structure where+  type AdhocTable structure (f :: Type -> Type) :: Type++  mkAdhocField :: (forall a. T.Text -> f a) -> structure -> AdhocTable structure f++newtype NamedField a = NamedField T.Text++instance Adhoc (NamedField a) where+  type AdhocTable (NamedField a) f = f a++  mkAdhocField mk (NamedField nm) = mk nm++instance (Adhoc a, Adhoc b) => Adhoc (a, b) where+  type AdhocTable (a, b) y = (AdhocTable a y, AdhocTable b y)+  mkAdhocField mk (a, b) = (mkAdhocField mk a, mkAdhocField mk b)++instance (Adhoc a, Adhoc b, Adhoc c) => Adhoc (a, b, c) where+  type AdhocTable (a, b, c) y = (AdhocTable a y, AdhocTable b y, AdhocTable c y)+  mkAdhocField mk (a, b, c) = (mkAdhocField mk a, mkAdhocField mk b, mkAdhocField mk c)++instance (Adhoc a, Adhoc b, Adhoc c, Adhoc d) => Adhoc (a, b, c, d) where+  type AdhocTable (a, b, c, d) y = (AdhocTable a y, AdhocTable b y, AdhocTable c y, AdhocTable d y)+  mkAdhocField mk (a, b, c, d) = (mkAdhocField mk a, mkAdhocField mk b, mkAdhocField mk c, mkAdhocField mk d)++instance (Adhoc a, Adhoc b, Adhoc c, Adhoc d, Adhoc e) => Adhoc (a, b, c, d, e) where+  type AdhocTable (a, b, c, d, e) y = ( AdhocTable a y, AdhocTable b y, AdhocTable c y, AdhocTable d y+                                      , AdhocTable e y )+  mkAdhocField mk (a, b, c, d, e) = (mkAdhocField mk a, mkAdhocField mk b, mkAdhocField mk c, mkAdhocField mk d, mkAdhocField mk e)++instance (Adhoc a, Adhoc b, Adhoc c, Adhoc d, Adhoc e, Adhoc f) => Adhoc (a, b, c, d, e, f) where+  type AdhocTable (a, b, c, d, e, f) y = ( AdhocTable a y, AdhocTable b y, AdhocTable c y, AdhocTable d y+                                         , AdhocTable e y, AdhocTable f y )+  mkAdhocField mk (a, b, c, d, e, f) = (mkAdhocField mk a, mkAdhocField mk b, mkAdhocField mk c, mkAdhocField mk d, mkAdhocField mk e, mkAdhocField mk f)++instance (Adhoc a, Adhoc b, Adhoc c, Adhoc d, Adhoc e, Adhoc f, Adhoc g) => Adhoc (a, b, c, d, e, f, g) where+  type AdhocTable (a, b, c, d, e, f, g) y = ( AdhocTable a y, AdhocTable b y, AdhocTable c y, AdhocTable d y+                                            , AdhocTable e y, AdhocTable f y, AdhocTable g y )+  mkAdhocField mk (a, b, c, d, e, f, g) = (mkAdhocField mk a, mkAdhocField mk b, mkAdhocField mk c, mkAdhocField mk d, mkAdhocField mk e, mkAdhocField mk f, mkAdhocField mk g)++instance (Adhoc a, Adhoc b, Adhoc c, Adhoc d, Adhoc e, Adhoc f, Adhoc g, Adhoc h) =>+  Adhoc (a, b, c, d, e, f, g, h) where+  type AdhocTable (a, b, c, d, e, f, g, h) y = ( AdhocTable a y, AdhocTable b y, AdhocTable c y, AdhocTable d y+                                               , AdhocTable e y, AdhocTable f y, AdhocTable g y, AdhocTable h y )+  mkAdhocField mk (a, b, c, d, e, f, g, h) = (mkAdhocField mk a, mkAdhocField mk b, mkAdhocField mk c, mkAdhocField mk d, mkAdhocField mk e, mkAdhocField mk f, mkAdhocField mk g, mkAdhocField mk h)++-- | Introduce a table into a query without using the 'Beamable' and 'Database' machinery.+--+-- The first argument is the optional name of the schema the table is in and the second is the name+-- of the table to source from.+--+-- The third argument is a tuple (or any nesting of tuples) where each value is of type 'NamedField'+-- (use 'field_' to construct).+--+-- The return value is a tuple (or any nesting of tuples) of the same shape as @structure@ but where+-- each value is a 'QExpr'.+--+-- For example, to source from the table @Table1@, with fields @Field1@ (A boolean), @Field2@ (a+-- timestamp), and @Field3@ (a string)+--+-- > table_ Nothing "Table1" ( field_ @Bool "Field1", field_ @UTCTime "Field2", field_ @Text "Field3" )+--+table_ :: forall be db structure s+        . (Adhoc structure, BeamSqlBackend be, Projectible be (AdhocTable structure (QExpr be s)))+       => Maybe T.Text -> T.Text -> structure -> Q be db s (AdhocTable structure (QExpr be s))+table_ schemaNm tblNm tbl =+  Q $ liftF (QAll (\_ -> fromTable (tableNamed (tableName schemaNm tblNm)) . Just . (, Nothing))+                  (\tblNm' -> let mk :: forall a. T.Text -> QExpr be s a+                                  mk nm = QExpr (\_ -> fieldE (qualifiedField tblNm' nm))+                              in mkAdhocField mk tbl)+                  (\_ -> Nothing) snd)++-- | Used to construct 'NamedField's, most often with an explicitly applied type.+--+-- The type can be omitted if the value is used unambiguously elsewhere.+field_ :: forall a. T.Text -> NamedField a+field_ = NamedField

@@ -1,7 +1,7 @@ module Database.Beam.Query.Aggregate   ( -- * Aggregates     -- | See the corresponding-    --   <https://tathougies.github.io/beam/user-guide/queries/aggregates.md manual section>+    --   <https://haskell-beam.github.io/beam/user-guide/queries/aggregates.md manual section>     --   for more detail      aggregate_@@ -61,7 +61,7 @@ --   'QExpr's). -- --   For usage examples, see---   <https://tathougies.github.io/beam/user-guide/queries/aggregates/ the manual>.+--   <https://haskell-beam.github.io/beam/user-guide/queries/aggregates/ the manual>. aggregate_ :: forall be a r db s.               ( BeamSqlBackend be               , Aggregable be a, Projectible be r, Projectible be a@@ -174,7 +174,7 @@ sum_ = sumOver_ allInGroup_  -- | SQL @COUNT(*)@ function-countAll_ :: BeamSqlBackend be => QAgg be s Int+countAll_ :: ( BeamSqlBackend be, Integral a ) => QAgg be s a countAll_ = QExpr (pure countAllE)  -- | SQL @COUNT(ALL ..)@ function (but without the explicit ALL)@@ -193,18 +193,18 @@ percentRank_ = QExpr (pure percentRankAggE)  -- | SQL2003 @DENSE_RANK@ function (Requires T612 Advanced OLAP operations support)-denseRank_ :: BeamSqlT612Backend be-           => QAgg be s Int+denseRank_ :: ( BeamSqlT612Backend be, Integral a )+           => QAgg be s a denseRank_ = QExpr (pure denseRankAggE)  -- | SQL2003 @ROW_NUMBER@ function-rowNumber_ :: BeamSql2003ExpressionBackend be-           =>  QAgg be s Int+rowNumber_ :: ( BeamSql2003ExpressionBackend be, Integral a )+           =>  QAgg be s a rowNumber_ = QExpr (pure rowNumberE)  -- | SQL2003 @RANK@ function (Requires T611 Elementary OLAP operations support)-rank_ :: BeamSqlT611Backend be-      => QAgg be s Int+rank_ :: ( BeamSqlT611Backend be, Integral a )+      => QAgg be s a rank_ = QExpr (pure rankAggE)  minOver_, maxOver_

@@ -8,19 +8,15 @@ 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.Text (Text)-import Data.String+import Data.Kind (Type) import Data.Proxy (Proxy(Proxy))-#if !MIN_VERSION_base(4, 11, 0)-import           Data.Semigroup-#endif---import Unsafe.Coerce+import Data.String+import Data.Text (Text)  data Recursiveness be where     Nonrecursive :: Recursiveness be@@ -29,14 +25,27 @@  instance Monoid (Recursiveness be) where     mempty = Nonrecursive-    mappend Recursive _ = Recursive-    mappend _ Recursive = Recursive-    mappend _ _ = Nonrecursive+    mappend = (<>)  instance Semigroup (Recursiveness be) where-  (<>) = mappend+    Recursive <> _ = Recursive+    _ <> Recursive = Recursive+    _ <> _ = Nonrecursive -newtype With be (db :: (* -> *) -> *) a+-- | Monad in which @SELECT@ statements can be made (via 'selecting')+-- and bound to result names for re-use later. This has the advantage+-- of only computing each result once. In SQL, this is translated to a+-- common table expression.+--+-- Once introduced, results can be re-used in future queries with 'reuse'.+--+-- 'With' is also a member of 'MonadFix' for backends that support+-- recursive CTEs. In this case, you can use @mdo@ or @rec@ notation+-- (with @RecursiveDo@ enabled) to bind result values (again, using+-- 'reuse') even /before/ they're introduced.+--+-- See further documentation <https://haskell-beam.github.io/beam/user-guide/queries/common-table-expressions/ here>.+newtype With be (db :: (Type -> Type) -> Type) a     = With { runWith :: WriterT (Recursiveness be, [ BeamSql99BackendCTESyntax be ])                                 (State Int) a }     deriving (Monad, Applicative, Functor)@@ -47,6 +56,9 @@  data QAnyScope +-- | Query results that have been introduced into a common table+-- expression via 'selecting' that can be used in future queries with+-- 'reuse'. 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 @@ -63,6 +75,9 @@                                  (\_ -> Nothing)                                  (rewriteThread @QAnyScope @res proxyS . snd))) +-- | Introduce the result of a query as a result in a common table+-- expression. The returned value can be used in future queries by+-- applying 'reuse'. selecting :: forall res be db            . ( BeamSql99CommonTableExpressionBackend be, HasQBuilder be              , Projectible be res@@ -80,9 +95,7 @@      pure (reusableForCTE tblNm) -rescopeQ :: QM be db s res -> QM be db s' res-rescopeQ = unsafeCoerce-+-- | Introduces the result of a previous 'selecting' (a CTE) into a new query reuse :: forall s be db res        . ReusableQ be db res -> Q be db s (WithRewrittenThread QAnyScope s res) reuse (ReusableQ _ q) = q (Proxy @s)

@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE CPP #-}  module Database.Beam.Query.Combinators     ( -- * Various SQL functions and constructs@@ -13,6 +12,7 @@     -- ** @IF-THEN-ELSE@ support     , if_, then_, else_     , then_'+    , ifThenElse_, bool_      -- * SQL @UPDATE@ assignments     , (<-.), current_@@ -30,7 +30,7 @@     , related_, relatedBy_, relatedBy_'     , leftJoin_, leftJoin_'     , perhaps_, outerJoin_, outerJoin_'-    , subselect_, references_+    , subselect_, references_, references_'      , nub_ @@ -40,7 +40,8 @@     , QIfCond, QIfElse     , (<|>.) -    , limit_, offset_+    , limit_, limitMaybe_+    , offset_, offsetMaybe_      , as_ @@ -49,14 +50,14 @@      -- ** Set operations     -- |  'Q' values can be combined using a variety of set operations. See the-    --    <https://tathougies.github.io/beam/user-guide/queries/combining-queries manual section>.+    --    <https://haskell-beam.github.io/beam/user-guide/queries/combining-queries manual section>.     , union_, unionAll_     , intersect_, intersectAll_     , except_, exceptAll_      -- * Window functions     -- | See the corresponding-    --   <https://tathougies.github.io/beam/user-guide/queries/window-functions manual section> for more.+    --   <https://haskell-beam.github.io/beam/user-guide/queries/window-functions manual section> for more.     , over_, frame_, bounds_, unbounded_, nrows_, fromBound_     , noBounds_, noOrder_, noPartition_     , partitionBy_, orderPartitionBy_, withWindow_@@ -65,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@@ -79,44 +80,49 @@ 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.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.Generics+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 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 @@ -125,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))@@ -133,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))@@ -154,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) $@@ -234,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) $@@ -267,14 +273,14 @@         => 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'+-- | Synonym for @clause >>= \\x -> guard_ (mkExpr x)>> pure x@. Use 'filter_'' for comparisons with 'SqlBool' 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'+-- | Synonym for @clause >>= \\x -> guard_' (mkExpr x)>> pure x@. Use 'filter_' for comparisons with 'Bool' filter_' :: forall r be db s           . BeamSqlBackend be         => (r -> QExpr be s SqlBool)@@ -283,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,17 +298,17 @@ 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)+-- | 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)) relatedBy_ = join_ --- | Introduce all entries of the given table which for which the expression (which can depend on the queried table returns true)+-- | 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))@@ -310,17 +316,28 @@  -- | Generate an appropriate boolean 'QGenExpr' comparing the given foreign key --   to the given table. Useful for creating join conditions.+--   Use 'references_'' for a 'SqlBool' comparison. 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 +-- | Generate an appropriate boolean 'QGenExpr' comparing the given foreign key+--   to the given table. Useful for creating join conditions.+--   Use 'references_' for a 'Bool' comparison.+references_' :: ( Table t, BeamSqlBackend be+                , HasTableEquality be (PrimaryKey t) )+             => PrimaryKey t (QGenExpr ctxt be s) -> t (QGenExpr ctxt be s) -> QGenExpr ctxt be s SqlBool+references_' fk tbl = fk ==?. pk tbl+ -- | Only return distinct values from a query 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.+--+-- See also `limitMaybe_` to conditionally apply a limit. limit_ :: forall s a be db         . ( Projectible be a           , ThreadRewritable (QNested s) a )@@ -328,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 )@@ -336,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@@ -359,18 +404,18 @@   QExpr (\tbl -> subqueryE (buildSqlQuery tbl q))  -- | SQL @CHAR_LENGTH@ function-charLength_ :: ( BeamSqlBackend be, BeamSqlBackendIsString be text )-            => QGenExpr context be s text -> QGenExpr context be s Int+charLength_ :: ( BeamSqlBackend be, BeamSqlBackendIsString be text, Integral a )+            => QGenExpr context be s text -> QGenExpr context be s a charLength_ (QExpr s) = QExpr (charLengthE <$> s)  -- | SQL @OCTET_LENGTH@ function-octetLength_ :: ( BeamSqlBackend be, BeamSqlBackendIsString be text )-             => QGenExpr context be s text -> QGenExpr context be s Int+octetLength_ :: ( BeamSqlBackend be, BeamSqlBackendIsString be text, Integral a )+             => QGenExpr context be s text -> QGenExpr context be s a octetLength_ (QExpr s) = QExpr (octetLengthE <$> s)  -- | SQL @BIT_LENGTH@ function-bitLength_ :: BeamSqlBackend be-           => QGenExpr context be s SqlBitString -> QGenExpr context be s Int+bitLength_ :: ( BeamSqlBackend be, Integral a )+           => QGenExpr context be s SqlBitString -> QGenExpr context be s a bitLength_ (QExpr x) = QExpr (bitLengthE <$> x)  -- | SQL @CURRENT_TIMESTAMP@ function@@ -512,7 +557,7 @@ -- --   But this is not ----- > aggregate_ (\_ -> as_ @Int countAll_) ..+-- > aggregate_ (\_ -> as_ @Int32 countAll_) .. -- as_ :: forall a ctxt be s. QGenExpr ctxt be s a -> QGenExpr ctxt be s a as_ = id@@ -543,8 +588,7 @@   SqlValable (table (QGenExpr ctxt be s)) where   val_ tbl =     let fields :: table (WithConstraint (BeamSqlBackendCanSerialize be))-        fields = to (gWithConstrainedFields (Proxy @(BeamSqlBackendCanSerialize be))-                                            (Proxy @(Rep (table Exposed))) (from tbl))+        fields = withConstrainedFields tbl     in changeBeamRep (\(Columnar' (WithConstraint x :: WithConstraint (BeamSqlBackendCanSerialize be) x)) ->                          Columnar' (QExpr (pure (valueE (sqlValueSyntax x))))) fields instance ( Beamable table, BeamSqlBackend be@@ -554,12 +598,18 @@    val_ tbl =     let fields :: table (Nullable (WithConstraint (BeamSqlBackendCanSerialize be)))-        fields = to (gWithConstrainedFields (Proxy @(BeamSqlBackendCanSerialize be))-                                            (Proxy @(Rep (table (Nullable Exposed)))) (from tbl))+        fields = withNullableConstrainedFields tbl     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@@ -587,10 +637,10 @@        => Int -> QFrameBound be nrows_ x = QFrameBound (nrowsBoundSyntax x) -noPartition_ :: Maybe (QExpr be s Int)+noPartition_ :: Integral a => Maybe (QExpr be s a) noPartition_ = Nothing -noOrder_ :: Maybe (QOrd be s Int)+noOrder_ :: Integral a => Maybe (QOrd be s a) noOrder_ = Nothing  partitionBy_, orderPartitionBy_ :: partition -> Maybe partition@@ -652,6 +702,9 @@     makeSQLOrdering :: Proxy be -> a -> [ WithExprContext (BeamSqlBackendOrderingSyntax be) ] instance SqlOrderable be (QOrd be s a) where     makeSQLOrdering _ (QOrd x) = [x]+instance TypeError ('Text "Missing mandatory sorting order. Use either 'asc_' or 'desc_' to specify sorting order.") =>+    SqlOrderable be (QGenExpr ctx be s a) where+        makeSQLOrdering = error "unreachable SqlOrderable QGenExpr instance" 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@@ -697,7 +750,7 @@ --   generated by a backend-specific ordering) or an (possibly nested) tuple of --   results of the former. -----   The <https://tathougies.github.io/beam/user-guide/queries/ordering manual section>+--   The <https://haskell-beam.github.io/beam/user-guide/queries/ordering manual section> --   has more information. orderBy_ :: forall s a ordering be db           . ( Projectible be a, SqlOrderable be ordering@@ -789,6 +842,22 @@ if_ conds (QIfElse (QExpr elseExpr)) =   QExpr (\tbl -> caseE (map (\(QIfCond (QExpr cond) (QExpr res)) -> (cond tbl, res tbl)) conds) (elseExpr tbl)) +ifThenElse_+  :: BeamSqlBackend be+  => QGenExpr context be s Bool+  -> QGenExpr context be s a+  -> QGenExpr context be s a+  -> QGenExpr context be s a+ifThenElse_ c t f = if_ [c `then_` t] (else_ f)++bool_+  :: BeamSqlBackend be+  => QGenExpr context be s a+  -> QGenExpr context be s a+  -> QGenExpr context be s Bool+  -> QGenExpr context be s a+bool_ f t c = ifThenElse_ c t f+ -- | SQL @COALESCE@ support coalesce_ :: BeamSqlBackend be           => [ QGenExpr ctxt be s (Maybe a) ] -> QGenExpr ctxt be s a -> QGenExpr ctxt be s a@@ -797,7 +866,7 @@     onNull' <- onNull     coalesceE . (<> [onNull']) <$> mapM (\(QExpr q) -> q) qs --- | Converta a 'Maybe' value to a concrete value, by suppling a default+-- | Convert a 'Maybe' value to a concrete value, by suppling a default 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@@ -830,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 <|>.

@@ -20,10 +20,10 @@ -- --   The returned function is polymorphic in the types of SQL expressions it --   will accept, but you can give it a more specific signature. For example, to---   mandate that we receive two 'Int's and a 'T.Text' and return a 'Bool'.+--   mandate that we receive two 'Int32's and a 'T.Text' and return a 'Bool'. -- -- @--- myFunc_ :: QGenExpr e ctxt s Int -> QGenExpr e ctxt s Int -> QGenExpr e ctxt s T.Text -> QGenExpr e ctxt s Bool+-- myFunc_ :: QGenExpr e ctxt s Int32 -> QGenExpr e ctxt s Int32 -> QGenExpr e ctxt s T.Text -> QGenExpr e ctxt s Bool -- myFunc_ = customExpr_ myFuncImpl -- @ --@@ -31,7 +31,7 @@ --   is called with arguments representing SQL expressions, that, when --   evaluated, will evaluate to the result of the expressions supplied as --   arguments to 'customExpr_'. See the section on---   <http://tathougies.github.io/beam/user-guide/extensibility/ extensibility>+--   <https://haskell-beam.github.io/beam/user-guide/extensibility/extensibility> --   in the user guide for example usage. module Database.Beam.Query.CustomSQL   (@@ -51,17 +51,15 @@ import           Data.ByteString (ByteString) import           Data.ByteString.Builder (byteString, toLazyByteString) import           Data.ByteString.Lazy (toStrict)-#if !MIN_VERSION_base(4, 11, 0)-import           Data.Semigroup-#endif +import           Data.Kind (Type) import           Data.String import qualified Data.Text as T  -- | A type-class for expression syntaxes that can embed custom expressions. class (Monoid (CustomSqlSyntax syntax), Semigroup (CustomSqlSyntax syntax), IsString (CustomSqlSyntax syntax)) =>   IsCustomSqlSyntax syntax where-  data CustomSqlSyntax syntax :: *+  data CustomSqlSyntax syntax :: Type    -- | Given an arbitrary string-like expression, produce a 'syntax' that represents the   --   'ByteString' as a SQL expression.@@ -80,11 +78,12 @@  newtype CustomSqlSnippet be = CustomSqlSnippet (T.Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)) instance IsCustomSqlSyntax (BeamSqlBackendExpressionSyntax be) => Semigroup (CustomSqlSnippet be) where-  (<>) = mappend+  CustomSqlSnippet a <> CustomSqlSnippet b =+    CustomSqlSnippet $ \pfx -> a pfx <> b pfx instance IsCustomSqlSyntax (BeamSqlBackendExpressionSyntax be) => Monoid (CustomSqlSnippet be) where   mempty = CustomSqlSnippet (pure mempty)-  mappend (CustomSqlSnippet a) (CustomSqlSnippet b) =-    CustomSqlSnippet $ \pfx -> a pfx <> b pfx+  mappend = (<>)+ instance IsCustomSqlSyntax (BeamSqlBackendExpressionSyntax be) => IsString (CustomSqlSnippet be) where   fromString s = CustomSqlSnippet $ \_ -> fromString s @@ -109,4 +108,3 @@ --   aggregates for use in 'aggregate_'. agg_ :: QAgg be s a -> QAgg be s a agg_ = id-

@@ -41,25 +41,25 @@  import Database.Beam.Backend.SQL -ntile_ :: (BeamSqlBackend be, BeamSqlT614Backend be)-       => QExpr be s Int -> QAgg be s a+ntile_ :: (BeamSqlBackend be, BeamSqlT614Backend be, Integral n)+       => QExpr be s n -> QAgg be s a ntile_ (QExpr a) = QExpr (ntileE <$> a)  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)-  => QExpr be s a -> QExpr be s Int -> QAgg be s a+  :: (BeamSqlBackend be, BeamSqlT615Backend be, Integral n)+  => 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)  leadWithDefault_, lagWithDefault_-  :: (BeamSqlBackend be, BeamSqlT615Backend be)-  => QExpr be s a -> QExpr be s Int -> QExpr be s a+  :: (BeamSqlBackend be, BeamSqlT615Backend be, Integral n)+  => QExpr be s a -> QExpr be s n -> QExpr be s a   -> QAgg be s a leadWithDefault_ (QExpr a) (QExpr n) (QExpr def) =   QExpr (leadE <$> a <*> fmap Just n <*> fmap Just def)@@ -75,8 +75,8 @@  -- TODO see comment for 'firstValue_' and 'lastValue_' nthValue_-  :: (BeamSqlBackend be, BeamSqlT618Backend be)-  => QExpr be s a -> QExpr be s Int -> QAgg be s a+  :: (BeamSqlBackend be, BeamSqlT618Backend be, Integral n)+  => QExpr be s a -> QExpr be s n -> QAgg be s a nthValue_ (QExpr a) (QExpr n) = QExpr (nthValueE <$> a <*> n)  ln_, exp_, sqrt_

@@ -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

@@ -1,6 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors#-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE CPP #-}  module Database.Beam.Query.Internal where @@ -10,42 +9,46 @@  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+ type ProjectibleInBackend be a =-  ( -- Eq (Sql92SelectExpressionSyntax syntax)-    Projectible be a+  ( Projectible be a   , ProjectibleValue be a )  type TablePrefix = T.Text -data QF be (db :: (* -> *) -> *) s next where+data QF be (db :: (Type -> Type) -> Type) s next where   QDistinct :: Projectible be r             => (r -> WithExprContext (BeamSqlBackendSetQuantifierSyntax be))             -> QM be db s r -> (r -> next) -> QF be db s next    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)@@ -110,7 +113,7 @@ -- | 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 be (db :: (* -> *) -> *) s a+newtype Q be (db :: (Type -> Type) -> Type) s a   = Q { runQ :: QM be db s a }     deriving (Monad, Applicative, Functor) @@ -125,7 +128,7 @@   deriving (Show, Eq, Ord)  newtype QAssignment be s-  = QAssignment [(BeamSqlBackendFieldNameSyntax be, BeamSqlBackendExpressionSyntax be)]+  = QAssignment { unQAssignment :: [(BeamSqlBackendFieldNameSyntax be, BeamSqlBackendExpressionSyntax be)] }   deriving (Monoid, Semigroup)  newtype QFieldAssignment be tbl a@@ -269,8 +272,8 @@ 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 :: *+class ThreadRewritable (s :: Type) (a :: Type) | a -> s where+  type WithRewrittenThread s (s' :: Type) a :: Type    rewriteThread :: Proxy s' -> a -> WithRewrittenThread s s' a instance Beamable tbl => ThreadRewritable s (tbl (QGenExpr ctxt syntax s)) where@@ -341,7 +344,7 @@     , rewriteThread s' e, rewriteThread s' f, rewriteThread s' g, rewriteThread s' h )  class ContextRewritable a where-  type WithRewrittenContext a ctxt :: *+  type WithRewrittenContext a ctxt :: Type    rewriteContext :: Proxy ctxt -> a -> WithRewrittenContext a ctxt instance Beamable tbl => ContextRewritable (tbl (QGenExpr old syntax s)) where@@ -425,7 +428,7 @@   { fromBeamSqlBackendWindowFrameSyntax :: BeamSqlBackendWindowFrameSyntax be   } -class ProjectibleWithPredicate (contextPredicate :: * -> Constraint) be res a | a -> be where+class ProjectibleWithPredicate (contextPredicate :: Type -> 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)@@ -592,7 +595,7 @@     zipBeamFieldsM (\_ _ -> Columnar' . QField False "" <$> mkM (Proxy @()) (Proxy @()))                    (tblSkeleton :: TableSkeleton t) (tblSkeleton :: TableSkeleton t) -instance Beamable t => ProjectibleWithPredicate AnyType () T.Text (t (Const T.Text)) where+instance Beamable t => ProjectibleWithPredicate AnyType () res (t (Const res)) where   project' _ be mutateM a =     zipBeamFieldsM (\(Columnar' f) _ ->                       Columnar' <$> project' (Proxy @AnyType) be mutateM f) a a@@ -610,7 +613,7 @@     zipBeamFieldsM (\_ _ -> Columnar' . Const <$> mkM (Proxy @()) (Proxy @()))                    (tblSkeleton :: TableSkeleton t) (tblSkeleton :: TableSkeleton t) -instance ProjectibleWithPredicate AnyType () T.Text (Const T.Text a) where+instance ProjectibleWithPredicate AnyType () res (Const res a) where   project' _ _ mutateM (Const a) = Const <$> mutateM (Proxy @()) (Proxy @()) a    projectSkeleton' _ _ mkM =@@ -665,3 +668,6 @@                     -> name  tableNameFromEntity = tableName <$> dbTableSchema <*> dbTableCurrentName++rescopeQ :: QM be db s res -> QM be db s' res+rescopeQ = unsafeCoerce

@@ -6,6 +6,7 @@   , (&&?.), (||?.), sqlNot_    , like_, similarTo_+  , like_', similarTo_'    , concat_   ) where@@ -59,17 +60,43 @@ infixr 2 ||., ||?.  -- | SQL @LIKE@ operator-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) =+like_+  :: (BeamSqlBackendIsString be text, BeamSqlBackend be)+  => QGenExpr ctxt be s text+  -> QGenExpr ctxt be s text+  -> QGenExpr ctxt be s Bool+like_ = like_'++-- | SQL @LIKE@ operator but heterogeneous over the text type+like_'+  :: ( BeamSqlBackendIsString be left+     , BeamSqlBackendIsString be right+     , BeamSqlBackend be+     )+  => QGenExpr ctxt be s left+  -> QGenExpr ctxt be s right+  -> QGenExpr ctxt be s Bool+like_' (QExpr scrutinee) (QExpr search) =   QExpr (liftA2 likeE scrutinee search)  -- | SQL99 @SIMILAR TO@ operator-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) =+similarTo_+  :: (BeamSqlBackendIsString be text, BeamSql99ExpressionBackend be)+  => QGenExpr ctxt be s text+  -> QGenExpr ctxt be s text+  -> QGenExpr ctxt be s text+similarTo_ = similarTo_'++-- | SQL99 @SIMILAR TO@ operator but heterogeneous over the text type+similarTo_'+  :: ( BeamSqlBackendIsString be left+     , BeamSqlBackendIsString be right+     , BeamSql99ExpressionBackend be+     )+  => QGenExpr ctxt be s left+  -> QGenExpr ctxt be s right+  -> QGenExpr ctxt be s left+similarTo_' (QExpr scrutinee) (QExpr search) =   QExpr (liftA2 similarToE scrutinee search)  infix 4 `like_`, `similarTo_`

@@ -20,7 +20,8 @@ -- -- > x >*. allOf_ .. module Database.Beam.Query.Ord-  ( SqlEq(..), SqlEqQuantified(..)+  ( SqlEq(..), SqlEqQuantified(..), SqlIn(..)+  , HasSqlInTable(..)   , SqlOrd(..), SqlOrdQuantified(..)   , QQuantified(..) @@ -37,9 +38,10 @@   , anyOf_, anyIn_   , allOf_, allIn_ -  , between_+  , inQuery_ -  , in_ ) where+  , between_+  ) where  import Database.Beam.Query.Internal import Database.Beam.Query.Types@@ -173,16 +175,38 @@ between_ (QExpr a) (QExpr min_) (QExpr max_) =   QExpr (liftA3 betweenE a min_ max_) --- | SQL @IN@ predicate-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)+class SqlIn expr a | a -> expr where+  -- | SQL @IN@ predicate+  in_ :: a -> [ a ] -> expr Bool -infix 4 `between_`, `in_`+instance BeamSqlBackend be => SqlIn (QGenExpr context be s) (QGenExpr context be s a) where+  in_ _ [] = QExpr (pure (valueE (sqlValueSyntax False)))+  in_ (QExpr row) options = QExpr (inE <$> row <*> mapM (\(QExpr o) -> o) options) +-- | Class for backends which support SQL @IN@ on lists of row values, which is+-- not part of ANSI SQL. This is useful for @IN@ on primary keys.+class BeamSqlBackend be => HasSqlInTable be where+  inRowValuesE+    :: Proxy be+    -> BeamSqlBackendExpressionSyntax be+    -> [ BeamSqlBackendExpressionSyntax be ]+    -> BeamSqlBackendExpressionSyntax be+  inRowValuesE Proxy = inE++instance ( HasSqlInTable be, Beamable table ) =>+  SqlIn (QGenExpr context be s) (table (QGenExpr context be s)) where++  in_ _ [] = QExpr (pure (valueE (sqlValueSyntax False)))+  in_ row options = QExpr (inRowValuesE (Proxy @be) <$> toExpr row <*> (mapM toExpr options))+    where toExpr :: table (QGenExpr context be s) -> TablePrefix -> BeamSqlBackendExpressionSyntax be+          toExpr = fmap rowE . sequence . allBeamValues (\(Columnar' (QExpr x)) -> x)++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. --@@ -207,7 +231,7 @@   -- | Quantified equality and inequality using /SQL semantics/ (tri-state boolean)   (==*.), (/=*.) :: a -> quantified -> expr SqlBool -infix 4 ==., /=., ==*., /=*.+infix 4 ==., /=., ==?., /=?., ==*., /=*. infix 4 <., >., <=., >=. infix 4 <*., >*., <=*., >=*. @@ -293,7 +317,7 @@          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) ->+                                   (\x'@(Columnar' (Columnar' HasConstraint :*: Columnar' x)) (Columnar' y) ->                                        do modify (\expr ->                                                     case expr of                                                       Nothing -> Just $ x ==. y@@ -303,7 +327,7 @@   a /=. b = not_ (a ==. b)    a ==?. b = let (_, e) = runState (zipBeamFieldsM-                                    (\x'@(Columnar' (Columnar' (WithConstraint _) :*: Columnar' x)) (Columnar' y) ->+                                    (\x'@(Columnar' (Columnar' HasConstraint :*: Columnar' x)) (Columnar' y) ->                                         do modify (\expr ->                                                      case expr of                                                        Nothing -> Just $ x ==?. y@@ -317,7 +341,7 @@     => 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+                                      (\x'@(Columnar' (Columnar' HasConstraint :*: Columnar' x)) (Columnar' y) -> do                                           modify (\expr ->                                                     case expr of                                                       Nothing -> Just $ x ==. y@@ -328,7 +352,7 @@   a /=. b = not_ (a ==. b)    a ==?. b = let (_, e) = runState (zipBeamFieldsM-                                    (\x'@(Columnar' (Columnar' (WithConstraint _) :*: Columnar' x)) (Columnar' y) ->+                                    (\x'@(Columnar' (Columnar' HasConstraint :*: Columnar' x)) (Columnar' y) ->                                         do modify (\expr ->                                                      case expr of                                                        Nothing -> Just $ x ==?. y

@@ -1,7 +1,7 @@ -- | Combinators and types specific to relationships. -- --   These types and functions correspond with the relationships section in the---   <http://tathougies.github.io/beam/user-guide/queries/relationships/ user guide>.+--   <https://haskell-beam.github.io/beam/user-guide/queries/relationships/ user guide>. module Database.Beam.Query.Relationships   ( -- * Relationships @@ -33,7 +33,7 @@  -- | Convenience type to declare one-to-many relationships. See the manual --   section on---   <http://tathougies.github.io/beam/user-guide/queries/relationships/ relationships>+--   <https://haskell-beam.github.io/beam/user-guide/queries/relationships/ relationships> --   for more information type OneToMany be db s one many =   ( BeamSqlBackend be, BeamSqlBackendCanSerialize be Bool ) =>@@ -45,7 +45,7 @@  -- | Convenience type to declare one-to-many relationships with a nullable --   foreign key. See the manual section on---   <http://tathougies.github.io/beam/user-guide/queries/relationships/ relationships>+--   <https://haskell-beam.github.io/beam/user-guide/queries/relationships/ relationships> --   for more information type OneToManyOptional be db s tbl rel =   ( BeamSqlBackend be, BeamSqlBackendCanSerialize be Bool@@ -88,7 +88,7 @@  -- | Convenience type to declare many-to-many relationships. See the manual --   section on---   <http://tathougies.github.io/beam/user-guide/queries/relationships/ relationships>+--   <https://haskell-beam.github.io/beam/user-guide/queries/relationships/ relationships> --   for more information type ManyToMany be db left right =   forall s.@@ -101,7 +101,7 @@  -- | Convenience type to declare many-to-many relationships with additional --   data. See the manual section on---   <http://tathougies.github.io/beam/user-guide/queries/relationships/ relationships>+--   <https://haskell-beam.github.io/beam/user-guide/queries/relationships/ relationships> --   for more information type ManyToManyThrough be db through left right =   forall s.@@ -116,8 +116,8 @@ --   Takes the join table and two key extraction functions from that table to the --   related tables. Also takes two `Q`s representing the table sources to relate. -----   See <http://tathougies.github.io/beam/user-guide/queries/relationships/ the manual>---   for more indformation.+--   See <https://haskell-beam.github.io/beam/user-guide/queries/relationships/ the manual>+--   for more information. manyToMany_   :: ( Database be db      , Table joinThrough, Table left, Table right@@ -137,8 +137,8 @@ --   join table and two key extraction functions from that table to the related --   tables. Also takes two `Q`s representing the table sources to relate. -----   See <http://tathougies.github.io/beam/user-guide/queries/relationships/ the manual>---   for more indformation.+--   See <https://haskell-beam.github.io/beam/user-guide/queries/relationships/ the manual>+--   for more information. manyToManyPassthrough_   :: ( Database be db      , Table joinThrough, Table left, Table right

@@ -12,11 +12,7 @@ import           Control.Monad.Free.Church import           Control.Monad.Free -#if !MIN_VERSION_base(4, 11, 0)-import           Control.Monad.Writer hiding ((<>))-import           Data.Semigroup-#endif-+import           Data.Kind (Type) import           Data.Maybe import           Data.Proxy (Proxy(Proxy)) import           Data.String@@ -52,7 +48,7 @@   , qbFrom  :: Maybe (BeamSqlBackendFromSyntax be)   , qbWhere :: Maybe (BeamSqlBackendExpressionSyntax be) } -data SelectBuilder be (db :: (* -> *) -> *) a where+data SelectBuilder be (db :: (Type -> Type) -> Type) a where   SelectBuilderQ :: ( BeamSqlBackend be                     , Projectible be a )                  => a -> QueryBuilder be -> SelectBuilder be db a@@ -216,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 ->@@ -248,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@@ -260,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'')@@ -275,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) @@ -300,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@@ -324,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@@ -338,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@@ -349,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)@@ -379,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)@@ -427,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,@@ -448,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))@@ -464,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')@@ -474,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))@@ -489,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))@@ -504,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@@ -522,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 =

@@ -47,7 +47,7 @@ -- $db-construction -- Types and functions to express database types and auto-generate name mappings -- for them. See the--- [manual](https://tathougies.github.io/beam/user-guide/databases.md) for more+-- [manual](https://haskell-beam.github.io/beam/user-guide/databases.md) for more -- information.  -- $entities

@@ -4,19 +4,26 @@     ( 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  import GHC.Generics  import Lens.Micro hiding (to) -class GTableLenses t (m :: * -> *) a (lensType :: * -> *) where+class GTableLenses t (m :: Type -> Type) a (lensType :: Type -> Type) where     gTableLenses :: Proxy a -> Lens' (t m) (a p) -> lensType () instance GTableLenses t m a al => GTableLenses t m (M1 s d a) (M1 s d al) where     gTableLenses (Proxy :: Proxy (M1 s d a)) lensToHere = M1 $ gTableLenses (Proxy :: Proxy a) (\f -> lensToHere (\(M1 x) -> M1 <$> f x))

@@ -19,12 +19,14 @@     , DatabaseEntityDescriptor(..)     , DatabaseEntity(..), TableEntity, ViewEntity, DomainTypeEntity     , dbEntityDescriptor+    , dbName, dbSchema, dbTableFields     , DatabaseModification, EntityModification(..)     , FieldModification(..)     , dbModification, tableModification, withDbModification     , withTableModification, modifyTable, modifyEntityName     , setEntityName, modifyTableFields, fieldNamed-    , defaultDbSettings+    , modifyEntitySchema, setEntitySchema+    , defaultDbSettings, embedDatabase      , RenamableWithRule(..), RenamableField(..)     , FieldRenamer(..)@@ -43,6 +45,7 @@     , GFieldsFulfillConstraint(..), FieldsFulfillConstraint     , FieldsFulfillConstraintNullable     , WithConstraint(..)+    , HasConstraint(..)     , TagReducesTo(..), ReplaceBaseTag     , withConstrainedFields, withConstraints     , withNullableConstrainedFields, withNullableConstraints@@ -55,23 +58,35 @@     , 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 +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 (Endo(..))+import           Data.Monoid 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@@ -80,16 +95,15 @@ 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. -----   All database types must be of kind '(* -> *) -> *'. If the type parameter---   is named 'f', each field must be of the type of 'f' applied to some type---   for which an 'IsDatabaseEntity' instance exists.+--   All database types must be of kind '(Type -> Type) -> Type'. If+--   the type parameter is named 'f', each field must be of the type+--   of 'f' applied to some type for which an 'IsDatabaseEntity'+--   instance exists. -- --   The 'be' type parameter is necessary so that the compiler can --   ensure that backend-specific entities only work on the proper@@ -97,25 +111,25 @@ -- --   Entities are documented under [the corresponding --   section](Database.Beam.Schema#entities) and in the---   [manual](http://tathougies.github.io/beam/user-guide/databases/)+--   [manual](https://haskell-beam.github.io/beam/user-guide/databases/) class Database be db where      -- | Default derived function. Do not implement this yourself.     --     --   The idea is that, for any two databases over particular entity tags 'f'     --   and 'g', if we can take any entity in 'f' and 'g' to the corresponding-    --   entity in 'h' (in the possibly effectful monad 'm'), then we can+    --   entity in 'h' (in the possibly effectful applicative functor 'm'), then we can     --   transform the two databases over 'f' and 'g' to a database in 'h',-    --   within the monad 'm'.+    --   within 'm'.     --     --   If that doesn't make sense, don't worry. This is mostly beam internal-    zipTables :: Monad m+    zipTables :: Applicative m               => Proxy be               -> (forall tbl. (IsDatabaseEntity be tbl, DatabaseEntityRegularRequirements be tbl) =>                   f tbl -> g tbl -> m (h tbl))               -> db f -> db g -> m (db h)     default zipTables :: ( Generic (db f), Generic (db g), Generic (db h)-                         , Monad m+                         , Applicative m                          , GZipDatabase be f g h                                         (Rep (db f)) (Rep (db g)) (Rep (db h)) ) =>                          Proxy be ->@@ -134,7 +148,7 @@ -- | Automatically provide names for tables, and descriptions for tables (using --   'defTblFieldSettings'). Your database must implement 'Generic', and must be --   auto-derivable. For more information on name generation, see the---   [manual](https://tathougies.github.io/beam/user-guide/models)+--   [manual](https://haskell-beam.github.io/beam/user-guide/models) defaultDbSettings :: ( Generic (DatabaseSettings be db)                      , GAutoDbSettings (Rep (DatabaseSettings be db) ()) ) =>                      DatabaseSettings be db@@ -148,7 +162,7 @@ --   contstruct these for you. newtype EntityModification f be e = EntityModification (Endo (f e))   deriving (Monoid, Semigroup)--- | A newtype wrapper around 'Columnar f a -> Columnar f ' (i.e., an+-- | A newtype wrapper around 'Columnar f a -> Columnar f a' (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 ~ --   TableField'@@ -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.@@ -219,10 +234,25 @@ modifyEntityName :: IsDatabaseEntity be entity => (Text -> Text) -> EntityModification (DatabaseEntity be db) be entity modifyEntityName modTblNm = EntityModification (Endo (\(DatabaseEntity tbl) -> DatabaseEntity (tbl & dbEntityName %~ modTblNm))) +-- | Construct an 'EntityModification' to set the schema of a database entity+modifyEntitySchema :: IsDatabaseEntity be entity => (Maybe Text -> Maybe Text) -> EntityModification (DatabaseEntity be db) be entity+modifyEntitySchema modSchema = EntityModification (Endo (\(DatabaseEntity tbl) -> DatabaseEntity (tbl & dbEntitySchema %~ modSchema)))+ -- | 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) +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) }))@@ -264,11 +294,11 @@ -- * Database entity types  -- | An entity tag for tables. See the documentation for 'Table' or consult the---   [manual](https://tathougies.github.io/beam/user-guide/models) for more.-data TableEntity (tbl :: (* -> *) -> *)-data ViewEntity (view :: (* -> *) -> *)+--   [manual](https://haskell-beam.github.io/beam/user-guide/models) for more.+data TableEntity (tbl :: (Type -> Type) -> Type)+data ViewEntity (view :: (Type -> Type) -> Type) --data UniqueConstraint (tbl :: (* -> *) -> *) (c :: (* -> *) -> *)-data DomainTypeEntity (ty :: *)+data DomainTypeEntity (ty :: Type) --data CharacterSetEntity --data CollationEntity --data TranslationEntity@@ -276,7 +306,7 @@  class RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor be entityType)) =>     IsDatabaseEntity be entityType where-  data DatabaseEntityDescriptor be entityType :: *+  data DatabaseEntityDescriptor be entityType :: Type   type DatabaseEntityDefaultRequirements be entityType :: Constraint   type DatabaseEntityRegularRequirements be entityType :: Constraint @@ -363,14 +393,27 @@ -- | Represents a meta-description of a particular entityType. Mostly, a wrapper --   around 'DatabaseEntityDescriptor be entityType', but carries around the --   'IsDatabaseEntity' dictionary.-data DatabaseEntity be (db :: (* -> *) -> *) entityType  where+data DatabaseEntity be (db :: (Type -> Type) -> Type) entityType  where     DatabaseEntity ::       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'@@ -390,9 +433,19 @@   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 :: Monad m =>+  gZipDatabase :: Applicative m =>                   (Proxy f, Proxy g, Proxy h, Proxy be)                -> (forall tbl. (IsDatabaseEntity be tbl, DatabaseEntityRegularRequirements be tbl) => f tbl -> g tbl -> m (h tbl))                -> x () -> y () -> m (z ())@@ -403,16 +456,19 @@          , GZipDatabase be f g h bx by bz ) =>   GZipDatabase be f g h (ax :*: bx) (ay :*: by) (az :*: bz) where   gZipDatabase p combine ~(ax :*: bx) ~(ay :*: by) =-    do a <- gZipDatabase p combine ax ay-       b <- gZipDatabase p combine bx by-       pure (a :*: b)+    liftA2 (:*:) (gZipDatabase p combine ax ay) (gZipDatabase p combine bx by) instance (IsDatabaseEntity be tbl, DatabaseEntityRegularRequirements be tbl) =>   GZipDatabase be f g h (K1 Generic.R (f tbl)) (K1 Generic.R (g tbl)) (K1 Generic.R (h tbl)) where    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 -data Lenses (t :: (* -> *) -> *) (f :: * -> *) x+  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 @@ -442,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@@ -454,7 +510,7 @@ --   turned into query expressions. -- --   The other rules are used within Beam to provide lenses and to expose the inner structure of the data type.-type family Columnar (f :: * -> *) x where+type family Columnar (f :: Type -> Type) x where     Columnar Exposed x = Exposed x      Columnar Identity x = x@@ -492,7 +548,7 @@ --   naming convention for you, and then modify it with 'withDbModification' if --   necessary. Under this scheme, the field n be renamed using the 'IsString' --   instance for 'TableField', or the 'fieldNamed' function.-data TableField (table :: (* -> *) -> *) ty+data TableField (table :: (Type -> Type) -> Type) ty   = TableField   { _fieldPath :: NE.NonEmpty T.Text     -- ^ The path that led to this field. Each element is the haskell@@ -539,12 +595,15 @@  -- | The big Kahuna! All beam tables implement this class. -----   The kind of all table types is '(* -> *) -> *'. This is because all table types are actually /table type constructors/.---   Every table type takes in another type constructor, called the /column tag/, and uses that constructor to instantiate the column types.---   See the documentation for 'Columnar'.+--   The kind of all table types is '(Type -> Type) -> Type'. This is+--   because all table types are actually /table type constructors/.+--   Every table type takes in another type constructor, called the+--   /column tag/, and uses that constructor to instantiate the column+--   types.  See the documentation for 'Columnar'. -----   This class is mostly Generic-derivable. You need only specify a type for the table's primary key and a method to extract the primary key---   given the table.+--   This class is mostly Generic-derivable. You need only specify a+--   type for the table's primary key and a method to extract the+--   primary key given the table. -- --   An example table: --@@ -569,11 +628,11 @@ --       `_blogPostTagline` is declared 'Maybe' so 'Nothing' will be stored as NULL in the database. `_blogPostImageGallery` will be allowed to be empty because it uses the 'Nullable' tag modifier. --     * `blogPostAuthor` references the `AuthorT` table (not given here) and is required. --     * `blogPostImageGallery` references the `ImageGalleryT` table (not given here), but this relation is not required (i.e., it may be 'Nothing'. See 'Nullable').-class (Typeable table, Beamable table, Beamable (PrimaryKey table)) => Table (table :: (* -> *) -> *) where+class (Typeable table, Beamable table, Beamable (PrimaryKey table)) => Table (table :: (Type -> Type) -> Type) where      -- | A data type representing the types of primary keys for this table.     --   In order to play nicely with the default deriving mechanism, this type must be an instance of 'Generic'.-    data PrimaryKey table (column :: * -> *) :: *+    data PrimaryKey table (column :: Type -> Type) :: Type      -- | Given a table, this should return the PrimaryKey from the table. By keeping this polymorphic over column,     --   we ensure that the primary key values come directly from the table (i.e., they can't be arbitrary constants)@@ -583,7 +642,7 @@ --   to "zip" tables with different column tags together. Always instantiate an --   empty 'Beamable' instance for tables, primary keys, and any type that you --   would like to embed within either. See the---   [manual](https://tathougies.github.io/beam/user-guide/models) for more+--   [manual](https://haskell-beam.github.io/beam/user-guide/models) for more --   information on embedding. class Beamable table where     zipBeamFieldsM :: Applicative m =>@@ -629,12 +688,12 @@   zipBeamFieldsM (\x y -> pure (Columnar' (x :*: y))) a b  class Retaggable f x | x -> f where-  type Retag (tag :: (* -> *) -> * -> *) x :: *+  type Retag (tag :: (Type -> Type) -> Type -> Type) x :: Type    retag :: (forall a. Columnar' f a -> Columnar' (tag f) a) -> x         -> Retag tag x -instance Beamable tbl => Retaggable f (tbl (f :: * -> *)) where+instance Beamable tbl => Retaggable f (tbl (f :: Type -> Type)) where   type Retag tag (tbl f) = tbl (tag f)    retag = changeBeamRep@@ -701,54 +760,58 @@     ( retag transform a, retag transform b, retag transform c, retag transform d     , retag transform e, retag transform f, retag transform g, retag transform h ) --- Carry a constraint instance-data WithConstraint (c :: * -> Constraint) x where+-- | Carry a constraint instance and the value it applies to.+data WithConstraint (c :: Type -> Constraint) x where   WithConstraint :: c x => x -> WithConstraint c x -class GFieldsFulfillConstraint (c :: * -> Constraint) (exposed :: * -> *) values withconstraint where-  gWithConstrainedFields :: Proxy c -> Proxy exposed -> values () -> withconstraint ()-instance GFieldsFulfillConstraint c exposed values withconstraint =>-    GFieldsFulfillConstraint c (M1 s m exposed) (M1 s m values) (M1 s m withconstraint) where-  gWithConstrainedFields c _ (M1 x) = M1 (gWithConstrainedFields c (Proxy @exposed) x)-instance GFieldsFulfillConstraint c U1 U1 U1 where-  gWithConstrainedFields _ _ _ = U1-instance (GFieldsFulfillConstraint c aExp a aC, GFieldsFulfillConstraint c bExp b bC) =>-  GFieldsFulfillConstraint c (aExp :*: bExp) (a :*: b) (aC :*: bC) where-  gWithConstrainedFields be _ (a :*: b) = gWithConstrainedFields be (Proxy @aExp) a :*: gWithConstrainedFields be (Proxy @bExp) b-instance (c x) => GFieldsFulfillConstraint c (K1 Generic.R (Exposed x)) (K1 Generic.R x) (K1 Generic.R (WithConstraint c x)) where-  gWithConstrainedFields _ _ (K1 x) = K1 (WithConstraint x)+-- | Carry a constraint instance.+data HasConstraint (c :: Type -> Constraint) x where+  HasConstraint :: c x => HasConstraint c x++class GFieldsFulfillConstraint (c :: Type -> Constraint) (exposed :: Type -> Type) withconstraint where+  gWithConstrainedFields :: Proxy c -> Proxy exposed -> withconstraint ()+instance GFieldsFulfillConstraint c exposed withconstraint =>+    GFieldsFulfillConstraint c (M1 s m exposed) (M1 s m withconstraint) where+  gWithConstrainedFields c _ = M1 (gWithConstrainedFields c (Proxy @exposed))+instance GFieldsFulfillConstraint c U1 U1 where+  gWithConstrainedFields _ _ = U1+instance (GFieldsFulfillConstraint c aExp aC, GFieldsFulfillConstraint c bExp bC) =>+  GFieldsFulfillConstraint c (aExp :*: bExp) (aC :*: bC) where+  gWithConstrainedFields be _ = gWithConstrainedFields be (Proxy @aExp) :*: gWithConstrainedFields be (Proxy @bExp)+instance (c x) => GFieldsFulfillConstraint c (K1 Generic.R (Exposed x)) (K1 Generic.R (HasConstraint c x)) where+  gWithConstrainedFields _ _ = K1 HasConstraint instance FieldsFulfillConstraint c t =>-    GFieldsFulfillConstraint c (K1 Generic.R (t Exposed)) (K1 Generic.R (t Identity)) (K1 Generic.R (t (WithConstraint c))) where-  gWithConstrainedFields _ _ (K1 x) = K1 (to (gWithConstrainedFields (Proxy @c) (Proxy @(Rep (t Exposed))) (from x)))+    GFieldsFulfillConstraint c (K1 Generic.R (t Exposed)) (K1 Generic.R (t (HasConstraint c))) where+  gWithConstrainedFields _ _ = K1 (to (gWithConstrainedFields (Proxy @c) (Proxy @(Rep (t Exposed))))) instance FieldsFulfillConstraintNullable c t =>-    GFieldsFulfillConstraint c (K1 Generic.R (t (Nullable Exposed))) (K1 Generic.R (t (Nullable Identity))) (K1 Generic.R (t (Nullable (WithConstraint c)))) where-  gWithConstrainedFields _ _ (K1 x) = K1 (to (gWithConstrainedFields (Proxy @c) (Proxy @(Rep (t (Nullable Exposed)))) (from x)))+    GFieldsFulfillConstraint c (K1 Generic.R (t (Nullable Exposed))) (K1 Generic.R (t (Nullable (HasConstraint c)))) where+  gWithConstrainedFields _ _ = K1 (to (gWithConstrainedFields (Proxy @c) (Proxy @(Rep (t (Nullable Exposed))))))  withConstrainedFields :: forall c tbl-                       . FieldsFulfillConstraint c tbl => tbl Identity -> tbl (WithConstraint c)-withConstrainedFields =-  to . gWithConstrainedFields (Proxy @c) (Proxy @(Rep (tbl Exposed))) . from+                       . (FieldsFulfillConstraint c tbl, Beamable tbl) => tbl Identity -> tbl (WithConstraint c)+withConstrainedFields = runIdentity . zipBeamFieldsM f (withConstraints @c @tbl)+  where f :: forall a. Columnar' (HasConstraint c) a -> Columnar' Identity a -> Identity (Columnar' (WithConstraint c) a)+        f (Columnar' HasConstraint) (Columnar' a) = Identity $ Columnar' $ WithConstraint a -withConstraints :: forall c tbl. (Beamable tbl, FieldsFulfillConstraint c tbl) => tbl (WithConstraint c)-withConstraints =-  withConstrainedFields (changeBeamRep (\_ -> Columnar' undefined) tblSkeleton)+withConstraints :: forall c tbl. (Beamable tbl, FieldsFulfillConstraint c tbl) => tbl (HasConstraint c)+withConstraints = to $ gWithConstrainedFields (Proxy @c) (Proxy @(Rep (tbl Exposed)))  withNullableConstrainedFields :: forall c tbl-                               . FieldsFulfillConstraintNullable c tbl => tbl (Nullable Identity) -> tbl (Nullable (WithConstraint c))-withNullableConstrainedFields =-  to . gWithConstrainedFields (Proxy @c) (Proxy @(Rep (tbl (Nullable Exposed)))) . from+                               . (FieldsFulfillConstraintNullable c tbl, Beamable tbl) => tbl (Nullable Identity) -> tbl (Nullable (WithConstraint c))+withNullableConstrainedFields = runIdentity . zipBeamFieldsM f (withNullableConstraints @c @tbl)+  where f :: forall a. Columnar' (Nullable (HasConstraint c)) a -> Columnar' (Nullable Identity) a -> Identity (Columnar' (Nullable (WithConstraint c)) a)+        f (Columnar' HasConstraint) (Columnar' a) = Identity $ Columnar' $ WithConstraint a -withNullableConstraints ::  forall c tbl. (Beamable tbl, FieldsFulfillConstraintNullable c tbl) => tbl (Nullable (WithConstraint c))-withNullableConstraints =-  withNullableConstrainedFields (changeBeamRep (\_ -> Columnar' undefined) tblSkeleton)+withNullableConstraints ::  forall c tbl. (Beamable tbl, FieldsFulfillConstraintNullable c tbl) => tbl (Nullable (HasConstraint c))+withNullableConstraints = to $ gWithConstrainedFields (Proxy @c) (Proxy @(Rep (tbl (Nullable Exposed)))) -type FieldsFulfillConstraint (c :: * -> Constraint) t =-  ( Generic (t (WithConstraint c)), Generic (t Identity), Generic (t Exposed)-  , GFieldsFulfillConstraint c (Rep (t Exposed)) (Rep (t Identity)) (Rep (t (WithConstraint c))))+type FieldsFulfillConstraint (c :: Type -> Constraint) t =+  ( Generic (t (HasConstraint c)), Generic (t Identity), Generic (t Exposed)+  , GFieldsFulfillConstraint c (Rep (t Exposed)) (Rep (t (HasConstraint c)))) -type FieldsFulfillConstraintNullable (c :: * -> Constraint) t =-  ( Generic (t (Nullable (WithConstraint c))), Generic (t (Nullable Identity)), Generic (t (Nullable Exposed))-  , GFieldsFulfillConstraint c (Rep (t (Nullable Exposed))) (Rep (t (Nullable Identity))) (Rep (t (Nullable (WithConstraint c)))))+type FieldsFulfillConstraintNullable (c :: Type -> Constraint) t =+  ( Generic (t (Nullable (HasConstraint c))), Generic (t (Nullable Identity)), Generic (t (Nullable Exposed))+  , GFieldsFulfillConstraint c (Rep (t (Nullable Exposed))) (Rep (t (Nullable (HasConstraint c)))))  -- | Synonym for 'primaryKey' pk :: Table t => t f -> PrimaryKey t f@@ -756,7 +819,7 @@  -- | Return a 'TableSettings' for the appropriate 'table' type where each column --   has been given its default name. See the---   [manual](https://tathougies.github.io/beam/user-guide/models) for+--   [manual](https://haskell-beam.github.io/beam/user-guide/models) for --   information on the default naming convention. defTblFieldSettings :: ( Generic (TableSettings table)                        , GDefaultTableFieldSettings (Rep (TableSettings table) ())) =>@@ -765,7 +828,7 @@     where withProxy :: (Proxy (Rep (TableSettings table) ()) -> TableSettings table) -> TableSettings table           withProxy f = f Proxy -class GZipTables f g h (exposedRep :: * -> *) fRep gRep hRep where+class GZipTables f g h (exposedRep :: Type -> Type) fRep gRep hRep where     gZipTables :: Applicative m => Proxy exposedRep                                 -> (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))                                 -> fRep ()@@ -850,20 +913,20 @@   | BeamableStrategy   | RecursiveKeyStrategy -type family ChooseSubTableStrategy (tbl :: (* -> *) -> *) (sub :: (* -> *) -> *) :: SubTableStrategy where+type family ChooseSubTableStrategy (tbl :: (Type -> Type) -> Type) (sub :: (Type -> Type) -> Type) :: SubTableStrategy where   ChooseSubTableStrategy tbl (PrimaryKey tbl) = 'RecursiveKeyStrategy   ChooseSubTableStrategy tbl (PrimaryKey rel) = 'PrimaryKeyStrategy   ChooseSubTableStrategy tbl sub = 'BeamableStrategy  -- TODO is this necessary-type family CheckNullable (f :: * -> *) :: Constraint where+type family CheckNullable (f :: Type -> Type) :: Constraint where   CheckNullable (Nullable f) = ()-  CheckNullable f = TypeError ('Text "Recursive reference without Nullable constraint forms an infinite loop." ':$$:+  CheckNullable f = TypeError ('Text "Recursive references without Nullable constraint form an infinite loop." ':$$:                                'Text "Hint: Only embed nullable 'PrimaryKey tbl' within the definition of 'tbl'." ':$$:                                'Text "      For example, replace 'PrimaryKey tbl f' with 'PrimaryKey tbl (Nullable f)'")  -class SubTableStrategyImpl (strategy :: SubTableStrategy) (f :: * -> *) sub where+class SubTableStrategyImpl (strategy :: SubTableStrategy) (f :: Type -> Type) sub where   namedSubTable :: Proxy strategy -> sub f  -- The defaulting with @TableField rel@ is necessary to avoid infinite loops

@@ -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.8.0.0+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@@ -10,7 +7,7 @@                      well as the corresponding backend.                       For more information, see the user manual and tutorial on-                     <https://tathougies.github.io/beam GitHub pages>.+                     <https://haskell-beam.github.io/beam GitHub pages>. homepage:            http://travis.athougies.net/projects/beam.html license:             MIT license-file:        LICENSE@@ -19,12 +16,13 @@ category:            Database build-type:          Simple cabal-version:       1.18-bug-reports:         https://github.com/tathougies/beam/issues+bug-reports:         https://github.com/haskell-beam/beam/issues extra-doc-files:     ChangeLog.md  library   exposed-modules:     Database.Beam Database.Beam.Backend                        Database.Beam.Query+                       Database.Beam.Query.Adhoc                        Database.Beam.Query.Internal                        Database.Beam.Query.CustomSQL                        Database.Beam.Query.CTE@@ -46,7 +44,13 @@                        Database.Beam.Backend.SQL.SQL2003                        Database.Beam.Backend.SQL.Builder                        Database.Beam.Backend.SQL.AST-  other-modules:       Database.Beam.Query.Aggregate++                       Database.Beam.Backend.Internal.Compat++  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@@ -55,31 +59,41 @@                        Database.Beam.Query.Relationships                         Database.Beam.Schema.Lenses-  build-depends:       base         >=4.7     && <5.0,-                       aeson        >=0.11    && <1.5,-                       text         >=1.0     && <1.3,-                       bytestring   >=0.10    && <0.11,-                       mtl          >=2.1     && <2.3,-                       microlens    >=0.4     && <0.5,-                       ghc-prim     >=0.5     && <0.6,-                       free         >=4.12    && <5.2,-                       dlist        >=0.7.1.2 && <0.9,-                       time         >=1.6     && <1.10,-                       hashable     >=1.1     && <1.3,++  build-depends:       base         >=4.11    && <5.0,+                       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.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.3,+                       vector       >=0.11    && <0.14,+                       vector-sized >=0.5     && <1.7,                        tagged       >=0.8     && <0.9+   Default-language:    Haskell2010   default-extensions:  ScopedTypeVariables, OverloadedStrings, GADTs, RecursiveDo, FlexibleInstances, FlexibleContexts, TypeFamilies,                        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)+    default-extensions: TypeFamilyDependencies  flag werror   description: Enable -Werror during development@@ -91,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,@@ -99,5 +113,5 @@  source-repository head   type: git-  location: https://github.com/tathougies/beam.git+  location: https://github.com/haskell-beam/beam.git   subdir: beam-core

@@ -10,10 +10,10 @@ 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.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 @@ -113,11 +115,37 @@      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)))+         ageCond = ExpressionCompOp "<" Nothing (ExpressionFieldName (QualifiedField employees "age")) (ExpressionValue (Value (30 :: Int32)))          nameCond = ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField employees "first_name")) (ExpressionFieldName (QualifiedField employees "last_name"))       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@@ -275,7 +303,7 @@                           , selectOrdering = [] } <-            pure $ selectMock $            do (age, maxNameLength) <- aggregate_ (\e -> ( group_ (_employeeAge e)-                                                        , fromMaybe_ 0 (max_ (charLength_ (_employeeFirstName e)))) ) $+                                                        , fromMaybe_ 0 (max_ (as_ @Int32 (charLength_ (_employeeFirstName e))))) ) $                                       all_ (_employees employeeDbSettings)               guard_ (maxNameLength >. 42)               pure (age, maxNameLength)@@ -283,13 +311,13 @@          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" ) ]+                                                               , ExpressionValue (Value (0 :: Int32)) ], Just "res1" ) ]          selectWhere @?= Nothing          selectGrouping @?= Just (Grouping [ ExpressionFieldName (QualifiedField t0 "age") ])          selectHaving @?= Just (ExpressionCompOp ">" Nothing                                 (ExpressionCoalesce [ ExpressionAgg "MAX" Nothing [ ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "first_name")) ]-                                                    , ExpressionValue (Value (0 :: Int)) ])-                                (ExpressionValue (Value (42 :: Int))))+                                                    , ExpressionValue (Value (0 :: Int32)) ])+                                (ExpressionValue (Value (42 :: Int32))))      aggregateInJoin =       testCase "Aggregate in JOIN" $@@ -399,24 +427,24 @@            pure $ selectMock $            filter_ (\(_, l) -> l <. 10 ||. l >. 20) $            aggregate_ (\e -> ( group_ (_employeeAge e)-                             , fromMaybe_ 0 (max_ (charLength_ (_employeeFirstName e)))) ) $+                             , fromMaybe_ 0 (max_ (as_ @Int32 (charLength_ (_employeeFirstName e))))) ) $            limit_ 10 (all_ (_employees employeeDbSettings))          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"))]-                                                              , ExpressionValue (Value (0 :: Int)) ], Just "res1")+                                                              , ExpressionValue (Value (0 :: Int32)) ], Just "res1")                                         ]          selectWhere @?= Nothing          selectGrouping @?= Just (Grouping [ExpressionFieldName (QualifiedField t0 "res3")])          selectHaving @?= Just (ExpressionBinOp "OR" (ExpressionCompOp "<" Nothing                                                       (ExpressionCoalesce [ ExpressionAgg "MAX" Nothing [ ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "res0")) ]-                                                                          , ExpressionValue (Value (0 :: Int)) ])-                                                      (ExpressionValue (Value (10 :: Int))))+                                                                          , ExpressionValue (Value (0 :: Int32)) ])+                                                      (ExpressionValue (Value (10 :: Int32))))                                                      (ExpressionCompOp ">" Nothing                                                       (ExpressionCoalesce [ ExpressionAgg "MAX" Nothing [ ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "res0")) ]-                                                                          , ExpressionValue (Value (0 :: Int)) ])-                                                      (ExpressionValue (Value (20 :: Int)))))+                                                                          , ExpressionValue (Value (0 :: Int32)) ])+                                                      (ExpressionValue (Value (20 :: Int32)))))           selectLimit subselect @?= Just 10          selectOffset subselect @?= Nothing@@ -446,7 +474,7 @@            pure $ selectMock $            do (lastName, firstNameLength) <-                   filter_ (\(_, charLength) -> fromMaybe_ 0 charLength >. 10) $-                  aggregate_ (\e -> (group_ (_employeeLastName e), max_ (charLength_ (_employeeFirstName e)))) $+                  aggregate_ (\e -> (group_ (_employeeLastName e), max_ (as_ @Int32 (charLength_ (_employeeFirstName e))))) $                   limit_ 10 (all_ (_employees employeeDbSettings))               role <- relatedBy_ (_roles employeeDbSettings) (\r -> _roleName r ==. lastName)               pure (firstNameLength, role, lastName)@@ -474,8 +502,8 @@          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)) ])-                                                             (ExpressionValue (Value (10 :: Int))))+                                                                                 , ExpressionValue (Value (0 :: Int32)) ])+                                                             (ExpressionValue (Value (10 :: Int32))))          selectGrouping @?= Just (Grouping [ (ExpressionFieldName (QualifiedField t0' "res1")) ])          selectProjection @?= ProjExprs [ ( ExpressionFieldName (QualifiedField t0' "res1"), Just "res0" )                                         , ( ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0' "res0"))], Just "res1" ) ]@@ -507,7 +535,7 @@               (lastName, firstNameLength) <-                   filter_ (\(_, charLength) -> charLength >. 10) $                   aggregate_ (\e -> ( group_ (_employeeLastName e)-                                    , fromMaybe_ 0 $ max_ (charLength_ (_employeeFirstName e))) ) $+                                    , fromMaybe_ 0 $ max_ (as_ @Int32 (charLength_ (_employeeFirstName e)))) ) $                   limit_ 10 (all_ (_employees employeeDbSettings))               guard_ (_roleName role ==. lastName)               pure (firstNameLength, role, lastName)@@ -517,7 +545,7 @@                          Nothing) <-            pure selectFrom          selectWhere @?= Just (ExpressionBinOp "AND"-                               (ExpressionCompOp ">" Nothing (ExpressionFieldName (QualifiedField t1 "res1")) (ExpressionValue (Value (10 :: Int))))+                               (ExpressionCompOp ">" Nothing (ExpressionFieldName (QualifiedField t1 "res1")) (ExpressionValue (Value (10 :: Int32))))                                (ExpressionCompOp "==" Nothing (ExpressionFieldName (QualifiedField t0 "name")) (ExpressionFieldName (QualifiedField t1 "res0"))))          selectProjection @?= ProjExprs [ ( ExpressionFieldName (QualifiedField t1 "res1"), Just "res0" )                                         , ( ExpressionFieldName (QualifiedField t0 "for_employee__first_name"), Just "res1" )@@ -538,7 +566,7 @@          selectGrouping @?= Just (Grouping [ (ExpressionFieldName (QualifiedField t0' "res1")) ])          selectProjection @?= ProjExprs [ ( ExpressionFieldName (QualifiedField t0' "res1"), Just "res0" )                                         , ( ExpressionCoalesce [ ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0' "res0"))]-                                                               , ExpressionValue (Value (0 :: Int)) ]+                                                               , ExpressionValue (Value (0 :: Int32)) ]                                           , Just "res1" ) ]           Select { selectTable = SelectTable { .. }, selectLimit = Just 10@@ -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@@ -753,7 +836,7 @@                       , selectOrdering = [] } <-        pure $ selectMock $        do (age, maxFirstNameLength) <- filter_ (\(_, nameLength) -> fromMaybe_ 0 nameLength >=. 20) $-                                       aggregate_ (\e -> (group_ (_employeeAge e), max_ (charLength_ (_employeeFirstName e)))) $+                                       aggregate_ (\e -> (group_ (_employeeAge e), max_ (as_ @Int32 (charLength_ (_employeeFirstName e))))) $                                        all_ (_employees employeeDbSettings)           role <- all_ (_roles employeeDbSettings)           pure (age, maxFirstNameLength, _roleName role)@@ -779,8 +862,8 @@      selectGrouping @?= Just (Grouping [ExpressionFieldName (QualifiedField t0 "age")])      selectHaving @?= Just (ExpressionCompOp ">=" Nothing                             (ExpressionCoalesce [ ExpressionAgg "MAX" Nothing [ExpressionCharLength (ExpressionFieldName (QualifiedField t0 "first_name"))]-                                                , ExpressionValue (Value (0 :: Int)) ])-                            (ExpressionValue (Value (20 :: Int))))+                                                , ExpressionValue (Value (0 :: Int32)) ])+                            (ExpressionValue (Value (20 :: Int32))))  -- | Ensure that isJustE and isNothingE work correctly for simple types @@ -868,7 +951,7 @@ related :: TestTree related =   testCase "related_ generate the correct ON conditions" $-  do SqlSelect Select { .. } <-+  do SqlSelect Select{} <-        pure $ selectMock $        do r <- all_ (_roles employeeDbSettings)           e <- related_ (_employees employeeDbSettings) (_roleForEmployee r)@@ -913,7 +996,7 @@      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 Int32, 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)@@ -928,11 +1011,11 @@          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")+                                                               (ExpressionValue (Value (23 :: Int32))), Just "res1")                                         , (ExpressionFieldName (QualifiedField subselectTbl "res2"), Just "res2") ]          selectHaving @?= Nothing          selectGrouping @?= Nothing-         selectWhere @?= Just (ExpressionCompOp "<" Nothing (ExpressionFieldName (QualifiedField subselectTbl "res1")) (ExpressionValue (Value (22 :: Int))))+         selectWhere @?= Just (ExpressionCompOp "<" Nothing (ExpressionFieldName (QualifiedField subselectTbl "res1")) (ExpressionValue (Value (22 :: Int32))))           Select { selectTable = UnionTables False hireDatesQuery leaveDatesQuery                 , selectLimit = Just 10, selectOffset = Nothing@@ -976,7 +1059,7 @@      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 Int32 )              hireDates = do e <- all_ (_employees employeeDbSettings)                             pure (_employeeFirstName e, _employeeLastName e, _employeeAge e)              leaveDates = do e <- all_ (_employees employeeDbSettings)@@ -990,7 +1073,7 @@      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 Int32, 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)@@ -1023,7 +1106,7 @@          proj @?= ProjExprs [ ( ExpressionFieldName (QualifiedField t0 "res0"), Just "res0" )                             , ( ExpressionFieldName (QualifiedField t0 "res1"), Just "res1" )                             , ( ExpressionFieldName (QualifiedField t0 "res2"), Just "res2" ) ]-         where_ @?= ExpressionCompOp "<" Nothing (ExpressionFieldName (QualifiedField "t0" "res1")) (ExpressionValue (Value (40 :: Int)))+         where_ @?= ExpressionCompOp "<" Nothing (ExpressionFieldName (QualifiedField "t0" "res1")) (ExpressionValue (Value (40 :: Int32)))          pure ()  @@ -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 } <-@@ -1052,6 +1153,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" $       do SqlSelect Select { selectLimit, selectOffset } <-@@ -1077,7 +1194,7 @@                                           , (ExpressionFieldName (QualifiedField "t0" "leave_date"), Just "res6")                                           , (ExpressionFieldName (QualifiedField "t0" "created"), Just "res7") ]          selectFrom a @?= Just (FromTable (TableNamed (TableName Nothing "employees")) (Just ("t0", Nothing)))-         selectWhere a @?= Just (ExpressionCompOp "<" Nothing (ExpressionFieldName (QualifiedField "t0" "age")) (ExpressionValue (Value (40 :: Int))))+         selectWhere a @?= Just (ExpressionCompOp "<" Nothing (ExpressionFieldName (QualifiedField "t0" "age")) (ExpressionValue (Value (40 :: Int32))))          selectGrouping a @?= Nothing          selectHaving a @?= Nothing @@ -1090,7 +1207,7 @@                                           , (ExpressionFieldName (QualifiedField "t0" "leave_date"), Just "res6")                                           , (ExpressionFieldName (QualifiedField "t0" "created"), Just "res7") ]          selectFrom b @?= Just (FromTable (TableNamed (TableName Nothing "employees")) (Just ("t0", Nothing)))-         selectWhere b @?= Just (ExpressionCompOp ">" Nothing (ExpressionFieldName (QualifiedField "t0" "age")) (ExpressionValue (Value (50 :: Int))))+         selectWhere b @?= Just (ExpressionCompOp ">" Nothing (ExpressionFieldName (QualifiedField "t0" "age")) (ExpressionValue (Value (50 :: Int32))))          selectGrouping b @?= Nothing          selectHaving b @?= Nothing @@ -1110,7 +1227,7 @@              role <- all_ (_roles employeeDbSettings)              guard_ (not_ (exists_ (do dept <- all_ (_departments employeeDbSettings)                                        guard_ (_departmentName dept ==. _roleName role)-                                       pure (as_ @Int 1))))+                                       pure (as_ @Int32 1))))              pure role           let existsQuery = Select@@ -1118,7 +1235,7 @@                          , selectOrdering = []                          , selectTable = SelectTable                                        { selectQuantifier = Nothing-                                       , selectProjection = ProjExprs [ (ExpressionValue (Value (1 :: Int)), Just "res0") ]+                                       , selectProjection = ProjExprs [ (ExpressionValue (Value (1 :: Int32)), Just "res0") ]                                        , selectGrouping = Nothing                                        , selectHaving = Nothing                                        , selectWhere = Just joinExpr@@ -1143,7 +1260,7 @@                          (\employee -> _employeeFirstName employee ==. "Joe")       updateTable @?= (TableName Nothing "employees")-     updateFields @?= [ (UnqualifiedField "age", ExpressionBinOp "+" (ExpressionFieldName (UnqualifiedField "age")) (ExpressionValue (Value (1 :: Int)))) ]+     updateFields @?= [ (UnqualifiedField "age", ExpressionBinOp "+" (ExpressionFieldName (UnqualifiedField "age")) (ExpressionValue (Value (1 :: Int32)))) ]      updateWhere @?= Just (ExpressionCompOp "==" Nothing (ExpressionFieldName (UnqualifiedField "first_name")) (ExpressionValue (Value ("Joe" :: String))))  updateNullable :: TestTree

@@ -16,15 +16,15 @@ import           Database.Beam import           Database.Beam.Schema.Tables import           Database.Beam.Backend-import           Database.Beam.Backend.SQL.AST +import           Data.Int import           Data.List.NonEmpty ( NonEmpty((:|)) )-import           Data.Monoid-import           Data.Proxy import           Data.Text (Text) import qualified Data.Text as T import           Data.Time.Clock (UTCTime) +import           Lens.Micro.Extras (view)+ import           Test.Tasty import           Test.Tasty.HUnit @@ -36,9 +36,8 @@                   , parametricAndFixedNestedBeamsAreEquivalent --                  , automaticNestedFieldsAreUnset --                  , nullableForeignKeysGivenMaybeType-                  , underscoresAreHandledGracefully ]---                  , dbSchemaGeneration ]---                  , dbSchemaModification ]+                  , underscoresAreHandledGracefully+                  , embeddedDatabases ]  data DummyBackend @@ -52,7 +51,7 @@   , _employeeLastName  :: Columnar f Text   , _employeePhoneNumber :: Columnar f Text -  , _employeeAge       :: Columnar f Int+  , _employeeAge       :: Columnar f Int32   , _employeeSalary    :: Columnar f Double    , _employeeHireDate  :: Columnar f UTCTime@@ -117,9 +116,6 @@ deriving instance Show (TableSettings (PrimaryKey RoleT)) deriving instance Eq (TableSettings (PrimaryKey RoleT)) -roleTableSchema :: TableSettings RoleT-roleTableSchema = defTblFieldSettings- -- * Ensure that fields of a nullable primary key are given the proper Maybe type  data DepartmentT f@@ -135,9 +131,6 @@ deriving instance Show (TableSettings DepartmentT) deriving instance Eq (TableSettings DepartmentT) -departmentTableSchema :: TableSettings DepartmentT-departmentTableSchema = defTblFieldSettings- -- nullableForeignKeysGivenMaybeType :: TestTree -- nullableForeignKeysGivenMaybeType = --   testCase "Nullable foreign keys are given maybe type" $@@ -155,7 +148,7 @@   , funny_first_name :: Columnar f Text   , _funny_lastName :: Columnar f Text   , _funny_middle_Name :: Columnar f Text-  , ___ :: Columnar f Int }+  , ___ :: Columnar f Int32 }   deriving Generic instance Beamable FunnyT instance Table FunnyT where@@ -227,7 +220,6 @@ -- `ADepartmentVehiculeT` and `BDepartmentVehiculeT` are equivalent, but one was using params while -- the other had its sub-beams fixed. -type ADepartmentVehicule   = ADepartmentVehiculeT Identity type ADepartmentVehiculeT  = DepartamentRelatedT VehiculeInformationT VehiculeT data DepartamentRelatedT metaInfo prop f = DepartamentProperty       { _aDepartament  :: PrimaryKey DepartmentT f@@ -235,7 +227,6 @@       , _aMetaInfo     :: metaInfo (Nullable f)       } deriving Generic -type BDepartmentVehicule    = BDepartmentVehiculeT Identity data BDepartmentVehiculeT f = BDepartmentVehicule       { _bDepartament  :: PrimaryKey DepartmentT f       , _bRelatesTo    :: VehiculeT f@@ -258,7 +249,7 @@ data VehiculeT f = VehiculeT       { _vehiculeId     :: C f Text       , _vehiculeType   :: C f Text-      , _numberOfWheels :: C f Int+      , _numberOfWheels :: C f Int32       } deriving Generic  instance Beamable VehiculeT@@ -323,36 +314,40 @@                                                 let defName = defaultFieldName field                                                 in case T.stripPrefix "funny" defName of                                                   Nothing -> defName-                                                  Just fieldNm -> "pfx_" <> 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"+      ]+