esqueleto 3.3.4.1 → 3.6.0.0
raw patch · 35 files changed
Files
- README.md +59/−4
- changelog.md +406/−1
- esqueleto.cabal +106/−147
- src/Database/Esqueleto.hs +21/−78
- src/Database/Esqueleto/Experimental.hs +298/−611
- src/Database/Esqueleto/Experimental/From.hs +139/−0
- src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs +124/−0
- src/Database/Esqueleto/Experimental/From/Join.hs +572/−0
- src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs +106/−0
- src/Database/Esqueleto/Experimental/ToAlias.hs +213/−0
- src/Database/Esqueleto/Experimental/ToAliasReference.hs +209/−0
- src/Database/Esqueleto/Experimental/ToMaybe.hs +78/−0
- src/Database/Esqueleto/Internal/ExprParser.hs +33/−32
- src/Database/Esqueleto/Internal/Internal.hs +4468/−3610
- src/Database/Esqueleto/Internal/Language.hs +0/−69
- src/Database/Esqueleto/Internal/PersistentImport.hs +36/−145
- src/Database/Esqueleto/Internal/Sql.hs +0/−78
- src/Database/Esqueleto/Legacy.hs +419/−0
- src/Database/Esqueleto/MySQL.hs +19/−6
- src/Database/Esqueleto/PostgreSQL.hs +617/−175
- src/Database/Esqueleto/PostgreSQL/JSON.hs +107/−109
- src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs +42/−39
- src/Database/Esqueleto/Record.hs +902/−0
- src/Database/Esqueleto/SQLite.hs +3/−3
- test/Common/Record.hs +464/−0
- test/Common/Test.hs +2557/−2657
- test/Common/Test/CTE.hs +35/−0
- test/Common/Test/Import.hs +87/−0
- test/Common/Test/Models.hs +209/−0
- test/Common/Test/Select.hs +22/−0
- test/MySQL/Test.hs +91/−111
- test/PostgreSQL/MigrateJSON.hs +22/−22
- test/PostgreSQL/Test.hs +1823/−1266
- test/SQLite/Test.hs +122/−173
- test/Spec.hs +21/−0
README.md view
@@ -1,4 +1,4 @@-Esqueleto [](https://travis-ci.org/bitemyapp/esqueleto)+Esqueleto [](https://github.com/bitemyapp/esqueleto/actions/workflows/haskell.yml) ========== @@ -127,8 +127,62 @@ WHERE Person.age >= 18 ``` -Since `age` is an optional `Person` field, we use `just` to lift`val 18 :: SqlExpr (Value Int)` into `just (val 18) ::SqlExpr (Value (Maybe Int))`.+Since `age` is an optional `Person` field, we use `just` to lift `val 18 :: SqlExpr (Value Int)` into `just (val 18) ::SqlExpr (Value (Maybe Int))`. +### Alternative Field Projections++The `(^.)` operator works on an `EntityField` value, which are generated by+`persistent` as the table name + the field name. This can get a little bit+verbose. As of `persistent-2.11`, you can use `OverloadedLabels` to make this a+bit more concise:++```haskell+{-# LANGUAGE OverloadedLabels #-}++select $ do+ p <- from $ table @Person+ pure+ ( p ^. PersonName+ , p ^. #name+ )+```++The `OverloadedLabels` support uses the `fieldName` as given by the Persistent+entity definition syntax - no type name prefix necessary. Additionally, these+field accesses are *polymorphic* - the following query filters any table that+has a `name` column:++```haskell+rowsByName+ :: forall rec.+ ( PersistEntity rec+ , PersistEntityBackend rec ~ SqlBackend+ , SymbolToField "name" rec Text+ )+ => SqlExpr (Value Text)+ -> SqlQuery (SqlExpr (Entity rec))+rowsByName name = do+ rec <- from $ table @rec+ where_ $ rec ^. #name ==. name+ pure rec+```++GHC 9.2 introduces the `OverloadedRecordDot` language extension, and `esqueleto`+supports this on `SqlExpr (Entity rec)` and `SqlExpr (Maybe (Entity rec))`. It+looks like this:++```haskell+select $ do+ (person, blogPost) <-+ from $+ table @Person+ `leftJoin` table @BlogPost+ `on` do+ \(person :& blogPost) ->+ just person.id ==. blogPost.authorId+ pure (person.name, blogPost.title)+```+ ## Experimental/New Joins There's a new way to write `JOIN`s in esqueleto! It has less potential for@@ -165,7 +219,7 @@ - `ON` clause is attached directly to the relevant join, so you never need to worry about how they're ordered, nor will you ever run into bugs where the `on` clause is on the wrong `JOIN`-- The `ON` clause lambda will all the available tables in it. This forbids+- The `ON` clause lambda will exclusively have all the available tables in it. This forbids runtime errors where an `ON` clause refers to a table that isn't in scope yet. - You can join on a table twice, and the aliases work out fine with the `ON` clause.@@ -487,5 +541,6 @@ ``` mysql> CREATE DATABASE esqutest; mysql> CREATE USER 'travis'@'localhost';-mysql> GRANT ALL ON esqutest.* TO 'travis';+mysql> ALTER USER 'travis'@'localhost' IDENTIFIED BY 'esqutest';+mysql> GRANT ALL ON esqutest.* TO 'travis'@'localhost'; ```
changelog.md view
@@ -1,8 +1,413 @@-3.3.4.1+3.6.0.0+=======+- @parsonsmatt+ - [#422](https://github.com/bitemyapp/esqueleto/pull/422)+ - The instance of `HasField` for `SqlExpr (Maybe (Entity a))` joins+ `Maybe` values together. This means that if you `leftJoin` a table+ with a `Maybe` column, the result will be a `SqlExpr (Value (Maybe+ typ))`, instead of `SqlExpr (Value (Maybe (Maybe typ)))`.+ - To make this a less breaking change, `joinV` has been given a similar+ behavior. If the input type to `joinV` is `Maybe (Maybe typ)`, then+ the result becomes `Maybe typ`. If the input type is `Maybe typ`, then+ the output is also `Maybe typ`. The `joinV'` function is given as an+ alternative with monomorphic behavior.+ - The `just` function is also modified to avoid nesting `Maybe`.+ Likewise, `just'` is provided to give monomorphic behavior.+ - `subSelect`, `max_`, `min_`, and `coalesce` were all+ given `Nullable` output types as well. This should help to reduce the+ incidence of nested `Maybe`.+ - The operator `??.` was introduced which can do nested `Maybe`. You may+ want this if you have type inference issues with `?.` combining+ `Maybe`.+ - [#420](https://github.com/bitemyapp/esqueleto/pull/420)+ - Add a fixity declaration to `?.`+ - [#412](https://github.com/bitemyapp/esqueleto/pull/412)+ - The `random_` and `rand` functions (deprecated in 2.6.0) have been+ removed. Please refer to the database specific ones (ie+ `Database.Esqueleto.PostgreSQL` etc)+ - The `sub_select` function (deprecated in 3.2.0) has been removed.+ Please use the safer variants like `subSelect`, `subSelectMaybe`, etc.+ - The `ToAliasT` and `ToAliasReferenceT` types has been removed after having been deprecated in 3.4.0.1.+ - The `Union` type (deprecated in 3.4) was removed. Please use `union_`+ instead.+ - The `UnionAll` type (deprecated in 3.4) was removed. Please use+ `unionAll_` instead.+ - The `Except` type (deprecated in 3.4) was removed. Please use+ `except_` instead.+ - The `Intersect` type (deprecated in 3.4) was removed. Please use+ `intersect_` instead.+ - The `SubQuery` type (deprecated in 3.4) was removed. You do not need+ to tag subqueries to use them in `from` clauses.+ - The `SelectQuery` type (deprecated in 3.4) was removed. You do not+ need to tag `SqlQuery` values with `SelectQuery`.+ - [#287](https://github.com/bitemyapp/esqueleto/pull/278)+ - Deprecate `distinctOn` and `distinctOnOrderBy`. Use the variants+ defined in `PostgreSQL` module instead. The signature has changed, but+ the refactor is straightforward:+ ```+ -- old:+ p <- from $ table+ distinctOn [don x] $ do+ pure p + -- new:+ p <- from $ table+ distinctOn [don x]+ pure p+ ```+ - [#301](https://github.com/bitemyapp/esqueleto/pull/301)+ - Postgresql `upsert` and `upsertBy` now require a `NonEmpty` list of+ updates. If you want to provide an empty list of updates, you'll need+ to use `upsertMaybe` and `upsertMaybeBe` instead. Postgres does not+ return rows from the database if no updates are performed.+ - [#413](https://github.com/bitemyapp/esqueleto/pull/413)+ - The ability to `coerce` `SqlExpr` was removed. Instead, use+ `veryUnsafeCoerceSqlExpr`. See the documentation on+ `veryUnsafeCoerceSqlExpr` for safe use example.+ - `unsafeCeorceSqlExpr` is provided as an option when the underlying+ Haskell types are coercible. This is still unsafe, as different+ `PersistFieldSql` instances may be at play.+ - [#420](https://github.com/bitemyapp/esqueleto/pull/421)+ - The `LockingKind` constructors are deprecated, and will be removed+ from non-Internal modules in a future release. Smart constructors+ replace them, and you may need to import them from a different+ database-specific module.+ - [#425](https://github.com/bitemyapp/esqueleto/pull/425)+ - `fromBaseId` is introduced as the inverse of `toBaseId`.+ - `toBaseIdMaybe` and `fromBaseIdMaybe` are introduced.++3.5.14.0+========+- @parsonsmatt+ - [#415](https://github.com/bitemyapp/esqueleto/pull/415)+ - Export the `SqlSelect` type from `Database.Esqueleto.Experimental`+ - [#414](https://github.com/bitemyapp/esqueleto/pull/414)+ - Derive `Foldable` and `Traversable` for `Value`.+ - [#416](https://github.com/bitemyapp/esqueleto/pull/416)+ - Derive `Functor` and `Bifunctor` for `:&`+- @matthewbauer+ - [#341](https://github.com/bitemyapp/esqueleto/pull/341/)+ - Add functions for `NULLS FIRST` and `NULLS LAST` in the Postgresql+ module+- @JoelMcCracken+ - [#354](https://github.com/bitemyapp/esqueleto/pull/354), [#417](https://github.com/bitemyapp/esqueleto/pull/417)+ - Add `withMaterialized`, `withNotMaterialized` to the PostgreSQL module++3.5.13.2+========+- @blujupiter32+ - [#379](https://github.com/bitemyapp/esqueleto/pull/379)+ - Fix a bug where `not_ (a &&. b)` would be interpeted as `(not_ a) &&. b`+- @RikvanToor+ - [#373](https://github.com/bitemyapp/esqueleto/pull/373), [#410](https://github.com/bitemyapp/esqueleto/pull/410)+ - Fix name clashes when using CTEs multiple times+- @TeofilC+ - [#394](https://github.com/bitemyapp/esqueleto/pull/394)+ - Use TH quotes to eliminate some CPP.+- @parsonsmatt, @jappeace+ - [#346](#https://github.com/bitemyapp/esqueleto/pull/346), [#411](https://github.com/bitemyapp/esqueleto/pull/411)+ - Add docs for more SQL operators++3.5.13.1+========+- @csamak+ - [#405](https://github.com/bitemyapp/esqueleto/pull/405)+ - Fix a bug introduced in 3.5.12.0 where deriveEsqueletoRecord incorrectly errors++3.5.13.0+========+- @ac251+ - [#402](https://github.com/bitemyapp/esqueleto/pull/402)+ - Add `forNoKeyUpdate` and `forKeyShare` locking kinds for postgres++3.5.12.0+========+- @csamak+ - [#405](https://github.com/bitemyapp/esqueleto/pull/405)+ - `ToMaybe` instances are now derived for Maybe records.+ See [Issue #401](https://github.com/bitemyapp/esqueleto/issues/401).++3.5.11.2+========+- @arguri+ - [#387](https://github.com/bitemyapp/esqueleto/pull/387)+ - Fix build for ghc 9.8.1 / template-haskell 2.18++3.5.11.0+========+- @9999years, @halogenandtoast+ - [#378](https://github.com/bitemyapp/esqueleto/pull/378)+ - `ToMaybe` instances are now derived for records so you can now left+ join them in queries++3.5.10.3+========+- @ttuegel+ - [#377](https://github.com/bitemyapp/esqueleto/pull/377)+ - Fix Postgres syntax for `noWait`++3.5.10.2+========+- @parsonsmatt+ - [#376](https://github.com/bitemyapp/esqueleto/pull/376)+ - When using Postgres 15, `LIMIT`, and the `locking` functions, you+ could accidentally construct SQL code like:++ > ... LIMIT 1FOR UPDATE ...++ This parsed on Postgres <15, but the new Postgres parser is more+ strict, and fails to parse. This PR introduces newlines between each+ query chunk, which fixes the issue.++3.5.10.1+========+- @9999years+ - [#369](https://github.com/bitemyapp/esqueleto/pull/369)+ - Fix `myAge` type in `deriveEsqueletoRecord` documentation++3.5.10.0+========+- @ivanbakel+ - [#328](https://github.com/bitemyapp/esqueleto/pull/328)+ - Add `ToAlias` instances for 9- to 16-tuples+ - Add `ToAliasReference` instances for 9- to 16-tuples+- @parsonsmatt+ - [#365](https://github.com/bitemyapp/esqueleto/pull/365)+ - Add `isNothing_` and `groupBy_` to avoid name conflicts with+ `Data.List` and `Data.Maybe`.++3.5.9.1+=======+- @duplode+ - [#363](https://github.com/bitemyapp/esqueleto/pull/363)+ - Add missing `just` to left join examples in the Haddocks+++3.5.9.0+=======+- @9999years+ - [#350](https://github.com/bitemyapp/esqueleto/pull/350)+ - Add `GetFirstTable`, `getTable`, `getTableMaybe` helpers for selecting+ tables from `:&` chains+- @josephsumabat+ - [#339](https://github.com/bitemyapp/esqueleto/pull/333)+ - Add `forUpdateOf`, `forShareOf` locking kinds for postgres+- @parsonsmatt+ - [#342](https://github.com/bitemyapp/esqueleto/pull/342)+ - Create a `TypeError` instance for `Functor SqlExpr`, adding+ documentation and work arounds for the need.+- @9999years+ - [#327](https://github.com/bitemyapp/esqueleto/pull/327)+ - Fixed a Haddock typo causing documentation to render incorrectly++3.5.8.1+=======+- @belevy+ - [#336](https://github.com/bitemyapp/esqueleto/pull/336)+ - Fix bug with multiple nested subqueries introduced in 3.5.7.1+ - Set operations will now only reuse variable names within the context of the set operation.+ a subquery that references the set operation will correctly pick up where the subquery left off+3.5.8.0+=======+- @ivanbakel+ - [#331](https://github.com/bitemyapp/esqueleto/pull/331)+ - Add `deriveEsqueletoRecordWith` to derive Esqueleto instances for+ records using custom deriving settings.+ - Add `DeriveEsqueletoRecordSettings` to control how Esqueleto record+ instances are derived.+ - Add `sqlNameModifier` to control how Esqueleto record instance+ deriving generates the SQL record type name.+ - Add `sqlFieldModifier` to control how Esqueleto record instance+ deriving generates the SQL record fields.++3.5.7.1+=======+- @belevy+ - [#334](https://github.com/bitemyapp/esqueleto/pull/334)+ - Fix alias name bug with union and subselect++3.5.7.0+=======+- @ivanbakel+ - [#329](https://github.com/bitemyapp/esqueleto/pull/329)+ - Add `ToAlias` and `ToAliasReference` instances to the type produced+ by `deriveEsqueletoRecord`, allowing in-SQL records to be used in+ CTEs++- @9999years+ - [#324](https://github.com/bitemyapp/esqueleto/pull/324)+ - Add ability to use nested records with `deriveEsqueletoRecord`++3.5.6.0+=======+- @9999years+ - [#323](https://github.com/bitemyapp/esqueleto/pull/323)+ - Add ability to derive esqueleto instances for records++3.5.5.0+=======+- @parsonsmatt+ - [#317](https://github.com/bitemyapp/esqueleto/pull/317)+ - Add `Eq` and `Show` instances to `:&`++3.5.4.2+=======+- @parsonsmatt+ - [#318](https://github.com/bitemyapp/esqueleto/pull/318)+ - Remove use of `SqlReadT` and `SqlWriteT` type alias so that Simplified+ Subsumption doesn't bite end users++3.5.4.1+=======+- @parsonsmatt+ - [#312](https://github.com/bitemyapp/esqueleto/pull/312/)+ - Support `persistent-2.14.0.0`++3.5.4.0+=======+- @parsonsmatt+ - [#310](https://github.com/bitemyapp/esqueleto/pull/310)+ - Add instances of `HasField` for `SqlExpr (Entity rec)` and `SqlExpr+ (Maybe (Entity rec))`. These instances allow you to use the+ `OverloadedRecordDot` language extension in GHC 9.2 with SQL+ representations of database entities.++3.5.3.2+=======+- @parsonsmatt+ - [#309](https://github.com/bitemyapp/esqueleto/pull/309)+ - Bump `time` version bound++3.5.3.1+=======+- @jappeace+ - [#303](https://github.com/bitemyapp/esqueleto/pull/303)+ - Added docs for delete function for new experimental API.++3.5.3.0+=======+- @m4dc4p+ - [#291](https://github.com/bitemyapp/esqueleto/pull/291)+ - Added `ToAlias` and `ToAliasReference` instaces to the `:&` type, mirroring+ the tuple instances for the same classes. See [Issue #290](https://github.com/bitemyapp/esqueleto/issues/290)+ for discussion.+- @NikitaRazmakhnin+ - [#284](https://github.com/bitemyapp/esqueleto/pull/284)+ - Add PostgreSQL-specific support of VALUES(..) literals+++3.5.2.2+=======+- @NikitaRazmakhnin+ - [#278](https://github.com/bitemyapp/esqueleto/pull/278)+ - Fix generating of bad sql using nexted expressions with `distinctOnOrderBy`.++3.5.2.1+=======+- @cdparks+ - [#273](https://github.com/bitemyapp/esqueleto/pull/273)+ - Avoid generating an empty list as the left operand to `NOT IN`.++3.5.2.0+=======+- @ivanbakel+ - [#268](https://github.com/bitemyapp/esqueleto/pull/268)+ - Added `SqlSelect` instance for `(:&)`, allowing it to be returned from+ queries just like `(,)` tuples.++3.5.1.0+=======+- @ibarrae+ - [#265](https://github.com/bitemyapp/esqueleto/pull/265)+ - Added `selectOne`++3.5.0.0+=======+- @belevy+ - [#228](https://github.com/bitemyapp/esqueleto/pull/228)+ - Destroy all GADTs; Removes the From GADT and SqlExpr GADT+ - From GADT is replaced with a From data type and FromRaw+ - SqlExpr is now all defined in terms of ERaw+ - Modified ERaw to contain a SqlExprMeta with any extra information+ that may be needed+ - Experimental top level is now strictly for documentation and all the+ implementation details are in Experimental.* modules+- @parsonsmatt+ - [#259](https://github.com/bitemyapp/esqueleto/pull/259)+ - Create the `Database.Esqueleto.Legacy` module. The+ `Database.Esqueleto` module now emits a warning, directing users to+ either import `Database.Esqueleto.Legacy` to keep the old behavior or+ to import `Database.Esqueleto.Experimental` to opt in to the new+ behavior.+ - Deleted the deprecated modules+ `Database.Esqueleto.Internal.{Language,Sql}`. Please use+ `Database.Esqueleto.Internal.Internal` instead, or ideally post what+ you need from the library so we can support you safely.+ - Support GHC 9++3.4.2.2+=======+- @parsonsmatt+ - [#255](https://github.com/bitemyapp/esqueleto/pull/255)+ - Fix a bug where a composite primary key in a `groupBy` clause would break.++3.4.2.1+=======+- @parsonsmatt+ - [#245](https://github.com/bitemyapp/esqueleto/pull/245)+ - Support `persistent-2.13`++3.4.2.0+=======+- @parsonsmatt+ - [#243](https://github.com/bitemyapp/esqueleto/pull/243)+ - Support `persistent-2.12`++3.4.1.1+=======+- @MaxGabriel+ - [#240](https://github.com/bitemyapp/esqueleto/pull/240/files)+ - Improve recommend hlint to avoid doing `x = NULL` SQL queries++3.4.1.0+=======+- @arthurxavierx+ - [#238](https://github.com/bitemyapp/esqueleto/pull/238)+ - Fix non-exhaustive patterns in `unsafeSqlAggregateFunction`+- @Vlix+ - [#232](https://github.com/bitemyapp/esqueleto/pull/232)+ - Export the `ValidOnClauseValue` type family+++3.4.0.1+=======+- @arthurxavierx+ - [#221](https://github.com/bitemyapp/esqueleto/pull/221)+ - Deprecate `ToAliasT` and `ToAliasReferenceT`+- @parsonsmatt+ - [#226](https://github.com/bitemyapp/esqueleto/pull/226)+ - Support `persistent-2.11`+- @belevy+ - [#225](https://github.com/bitemyapp/esqueleto/pull/225)+ - Simplify `ToFromT` extracting the overlapping and type error instances+ - Make `ToFromT` and associated type family of `ToFrom`++3.4.0.0+=======+- @belevy, @charukiewicz+ - [#215](https://github.com/bitemyapp/esqueleto/pull/215)+ - Added support for common table expressions (`with`, `withRecursive`)+ - Added support for lateral JOINs with updated example (Example #6)+ - Deprecated `SelectQuery`, removing the neccessity to tag `SqlQuery` values+ - Deprecated use of data constructors for SQL set operations (replaced with functions)+ - Refactored module structure to fix haddock build (fixes build from `3.3.4.0`)++3.3.4.1+======= - @maxgabriel - [#214](https://github.com/bitemyapp/esqueleto/pull/214) - Add suggested hlint rules for proper `isNothing` usage+ 3.3.4.0 =======
esqueleto.cabal view
@@ -1,7 +1,7 @@ cabal-version: 1.12 name: esqueleto-version: 3.3.4.1+version: 3.6.0.0 synopsis: Type-safe EDSL for SQL queries on persistent backends. description: @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends. Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime. .@@ -23,152 +23,111 @@ changelog.md source-repository head- type: git- location: git://github.com/bitemyapp/esqueleto.git+ type: git+ location: git://github.com/bitemyapp/esqueleto.git library- exposed-modules:- Database.Esqueleto- Database.Esqueleto.Experimental- Database.Esqueleto.Internal.Language- Database.Esqueleto.Internal.Sql- Database.Esqueleto.Internal.Internal- Database.Esqueleto.Internal.ExprParser- Database.Esqueleto.MySQL- Database.Esqueleto.PostgreSQL- Database.Esqueleto.PostgreSQL.JSON- Database.Esqueleto.SQLite- other-modules:- Database.Esqueleto.Internal.PersistentImport- Database.Esqueleto.PostgreSQL.JSON.Instances- Paths_esqueleto- hs-source-dirs:- src/- build-depends:- base >=4.8 && <5.0- , aeson >=1.0- , attoparsec >= 0.13 && < 0.14- , blaze-html- , bytestring- , conduit >=1.3- , containers- , monad-logger- , persistent >=2.10.0 && <2.11- , resourcet >=1.2- , tagged >=0.2- , text >=0.11 && <1.3- , time >=1.5.0.1 && <=1.10- , transformers >=0.2- , unliftio- , unordered-containers >=0.2- if impl(ghc >=8.0)- ghc-options: -Wall -Wno-redundant-constraints- else- ghc-options: -Wall- default-language: Haskell2010--test-suite mysql- type: exitcode-stdio-1.0- main-is: MySQL/Test.hs- other-modules:- Common.Test- Paths_esqueleto- hs-source-dirs:- test- ghc-options: -Wall- build-depends:- base >=4.8 && <5.0- , attoparsec- , blaze-html- , bytestring- , conduit >=1.3- , containers- , esqueleto- , exceptions- , hspec- , monad-logger- , mtl- , mysql- , mysql-simple- , persistent >=2.8.0 && <2.11- , persistent-mysql- , persistent-template- , resourcet >=1.2- , tagged >=0.2- , text >=0.11 && <1.3- , time - , transformers >=0.2- , unliftio- , unordered-containers >=0.2- default-language: Haskell2010--test-suite postgresql- type: exitcode-stdio-1.0- main-is: PostgreSQL/Test.hs- other-modules:- Common.Test- PostgreSQL.MigrateJSON- Paths_esqueleto- hs-source-dirs:- test- ghc-options: -Wall- build-depends:- base >=4.8 && <5.0- , aeson- , attoparsec- , blaze-html- , bytestring- , conduit >=1.3- , containers- , esqueleto- , exceptions- , hspec- , monad-logger- , mtl- , persistent >=2.10.0 && <2.11- , persistent-postgresql >= 2.10.0 && <2.11- , persistent-template- , postgresql-libpq- , postgresql-simple- , resourcet >=1.2- , tagged >=0.2- , text >=0.11 && <1.3- , time - , transformers >=0.2- , unliftio- , unordered-containers >=0.2- , vector- default-language: Haskell2010+ exposed-modules:+ Database.Esqueleto+ Database.Esqueleto.Legacy+ Database.Esqueleto.Experimental+ Database.Esqueleto.Internal.Internal+ Database.Esqueleto.Internal.ExprParser+ Database.Esqueleto.MySQL+ Database.Esqueleto.PostgreSQL+ Database.Esqueleto.PostgreSQL.JSON+ Database.Esqueleto.Record+ Database.Esqueleto.SQLite+ Database.Esqueleto.Experimental.From+ Database.Esqueleto.Experimental.From.CommonTableExpression+ Database.Esqueleto.Experimental.From.Join+ Database.Esqueleto.Experimental.From.SqlSetOperation+ Database.Esqueleto.Experimental.ToAlias+ Database.Esqueleto.Experimental.ToAliasReference+ Database.Esqueleto.Experimental.ToMaybe+ other-modules:+ Database.Esqueleto.PostgreSQL.JSON.Instances+ Database.Esqueleto.Internal.PersistentImport+ Paths_esqueleto+ hs-source-dirs:+ src/+ build-depends:+ base >=4.12 && <5.0+ , aeson >=1.0+ , attoparsec >= 0.13 && < 0.15+ , blaze-html+ , bytestring+ , conduit >=1.3+ , containers+ , monad-logger+ , persistent >=2.13 && <3+ , resourcet >=1.2+ , tagged >=0.2+ , template-haskell+ , text >=0.11 && <2.2+ , time >=1.5.0.1 && <=1.13+ , transformers >=0.2+ , unliftio+ , unordered-containers >=0.2+ ghc-options:+ -Wall+ -Wno-redundant-constraints+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wpartial-fields+ -Wmissing-home-modules+ -Widentities+ -Wcpp-undef+ -Wcpp-undef+ default-language: Haskell2010 -test-suite sqlite- type: exitcode-stdio-1.0- main-is: SQLite/Test.hs- other-modules:- Common.Test- Paths_esqueleto- hs-source-dirs:- test- ghc-options: -Wall- build-depends:- base >=4.8 && <5.0- , attoparsec- , blaze-html- , bytestring- , conduit >=1.3- , containers- , esqueleto- , exceptions- , hspec- , monad-logger- , mtl- , persistent >=2.8.0 && <2.11- , persistent-sqlite- , persistent-template- , resourcet >=1.2- , tagged >=0.2- , text >=0.11 && <1.3- , time - , transformers >=0.2- , unliftio- , unordered-containers >=0.2- default-language: Haskell2010+test-suite specs+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Common.Test+ Common.Test.CTE+ Common.Test.Models+ Common.Test.Import+ Common.Test.Select+ Common.Record+ PostgreSQL.MigrateJSON+ SQLite.Test+ PostgreSQL.Test+ MySQL.Test+ default-extensions:+ RankNTypes+ hs-source-dirs:+ test+ ghc-options: -Wall -threaded+ build-depends:+ base >=4.8 && <5.0+ , aeson+ , attoparsec+ , blaze-html+ , bytestring+ , conduit+ , containers+ , esqueleto+ , exceptions+ , hspec+ , hspec-core+ , monad-logger+ , mtl+ , mysql+ , mysql-simple+ , persistent+ , persistent-mysql+ , persistent-postgresql+ , persistent-sqlite+ , postgresql-simple+ , QuickCheck+ , resourcet+ , tagged+ , template-haskell+ , text+ , time+ , transformers+ , unliftio+ , unordered-containers+ default-language: Haskell2010
src/Database/Esqueleto.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+ -- | The @esqueleto@ EDSL (embedded domain specific language). -- This module replaces @Database.Persist@, so instead of -- importing that module you should just import this one:@@ -28,11 +32,15 @@ -- Other than identifier name clashes, @esqueleto@ does not -- conflict with @persistent@ in any way. ----- Note that the faciliites for @JOIN@ have been significantly improved in the+-- Note that the facilities for @JOIN@ have been significantly improved in the -- "Database.Esqueleto.Experimental" module. The definition of 'from' and 'on' -- in this module will be replaced with those at the 4.0.0.0 version, so you are -- encouraged to migrate to the new method.-module Database.Esqueleto+--+-- This module has an attached WARNING message indicating that the Experimental+-- syntax will become the default. If you want to continue using the old syntax,+-- please refer to "Database.Esqueleto.Legacy" as a drop-in replacement.+module Database.Esqueleto {-# WARNING "This module will switch over to the Experimental syntax in an upcoming major version release. Please migrate to the Database.Esqueleto.Legacy module to continue using the old syntax, or translate to the new and improved syntax in Database.Esqueleto.Experimental." #-} ( -- * Setup -- $setup @@ -43,14 +51,14 @@ -- $gettingstarted -- * @esqueleto@'s Language- where_, on, groupBy, orderBy, rand, asc, desc, limit, offset+ where_, on, groupBy, orderBy, asc, desc, limit, offset , distinct, distinctOn, don, distinctOnOrderBy, having, locking- , sub_select, (^.), (?.)- , val, isNothing, just, nothing, joinV, withNonNull+ , (^.), (?.)+ , val, isNothing, just, just', nothing, joinV, joinV', withNonNull , countRows, count, countDistinct , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , between, (+.), (-.), (/.), (*.)- , random_, round_, ceiling_, floor_+ , round_, ceiling_, floor_ , min_, max_, sum_, avg_, castNum, castNumM , coalesce, coalesceDefault , lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_@@ -58,7 +66,7 @@ , subList_select, valList, justList , in_, notIn, exists, notExists , set, (=.), (+=.), (-=.), (*=.), (/=.)- , case_, toBaseId+ , case_, toBaseId, fromBaseId, toBaseIdMaybe, fromBaseIdMaybe , subSelect , subSelectMaybe , subSelectCount@@ -75,6 +83,9 @@ , OrderBy , DistinctOn , LockingKind(..)+ , forUpdate+ , forUpdateSkipLocked+ , LockableEntity(..) , SqlString -- ** Joins , InnerJoin(..)@@ -89,6 +100,7 @@ , SqlExpr , SqlEntity , select+ , selectOne , selectSource , delete , deleteCount@@ -120,14 +132,8 @@ , module Database.Esqueleto.Internal.PersistentImport ) where -import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Trans.Reader (ReaderT)-import Data.Int (Int64)-import qualified Data.Map.Strict as Map-import Database.Esqueleto.Internal.Language-import Database.Esqueleto.Internal.Sql+import Database.Esqueleto.Legacy import Database.Esqueleto.Internal.PersistentImport-import qualified Database.Persist -- $setup@@ -410,66 +416,3 @@ -- -- In order to use these functions, you need to explicitly import -- their corresponding modules, they're not re-exported here.------------------------------------------------------------------------------ | @valkey i = 'val' . 'toSqlKey'@--- (<https://github.com/prowdsponsor/esqueleto/issues/9>).-valkey :: (ToBackendKey SqlBackend entity, PersistField (Key entity)) =>- Int64 -> SqlExpr (Value (Key entity))-valkey = val . toSqlKey----- | @valJ@ is like @val@ but for something that is already a @Value@. The use--- case it was written for was, given a @Value@ lift the @Key@ for that @Value@--- into the query expression in a type safe way. However, the implementation is--- more generic than that so we call it @valJ@.------ Its important to note that the input entity and the output entity are--- constrained to be the same by the type signature on the function--- (<https://github.com/prowdsponsor/esqueleto/pull/69>).------ /Since: 1.4.2/-valJ :: (PersistField (Key entity)) =>- Value (Key entity) -> SqlExpr (Value (Key entity))-valJ = val . unValue------------------------------------------------------------------------------ | Synonym for 'Database.Persist.Store.delete' that does not--- clash with @esqueleto@'s 'delete'.-deleteKey :: ( PersistStore backend- , BaseBackend backend ~ PersistEntityBackend val- , MonadIO m- , PersistEntity val )- => Key val -> ReaderT backend m ()-deleteKey = Database.Persist.delete---- | Avoid N+1 queries and join entities into a map structure--- @--- getFoosAndNestedBarsFromParent :: ParentId -> (Map (Key Foo) (Foo, [Maybe (Entity Bar)]))--- getFoosAndNestedBarsFromParent parentId = 'fmap' associateJoin $ 'select' $--- 'from' $ \\(foo `'LeftOuterJoin`` bar) -> do--- 'on' (bar '?.' BarFooId '==.' foo '^.' FooId)--- 'where_' (foo '^.' FooParentId '==.' 'val' parentId)--- 'pure' (foo, bar)--- @------ @since 3.1.2-associateJoin- :: forall e1 e0- . Ord (Key e0)- => [(Entity e0, e1)]- -> Map.Map (Key e0) (e0, [e1])-associateJoin = foldr f start- where- start = Map.empty- f (one, many) =- Map.insertWith- (\(oneOld, manyOld) (_, manyNew) -> (oneOld, manyNew ++ manyOld ))- (entityKey one)- (entityVal one, [many])
src/Database/Esqueleto/Experimental.hs view
@@ -1,23 +1,11 @@-{-# LANGUAGE CPP- , DataKinds- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , GADTs- , MultiParamTypeClasses- , TypeOperators- , TypeFamilies- , UndecidableInstances- , OverloadedStrings- , PatternSynonyms- #-}+{-# LANGUAGE PatternSynonyms #-} -- | This module contains a new way (introduced in 3.3.3.0) of using @FROM@ in -- Haskell. The old method was a bit finicky and could permit runtime errors, -- and this new way is both significantly safer and much more powerful. ----- Esqueleto users are encouraged to migrate to this module, as it will become--- the default in a new major version @4.0.0.0@.+-- This syntax will become the default syntax exported from the library in+-- version @3.6.0.0@. To use the old syntax, see "Database.Esqueleto.Legacy". module Database.Esqueleto.Experimental ( -- * Setup -- $setup@@ -30,60 +18,221 @@ -- * Documentation - SqlSetOperation(Union, UnionAll, Except, Intersect)- , pattern SelectQuery- , From(..)- , on- , from+ -- ** Basic Queries+ from+ , table+ , Table(..)+ , selectQuery++ -- ** Joins , (:&)(..)- -- * Internals- , ToFrom(..)- , ToFromT+ , on+ , innerJoin+ , innerJoinLateral+ , leftJoin+ , leftJoinLateral+ , rightJoin+ , fullOuterJoin+ , crossJoin+ , crossJoinLateral++ -- ** Set Operations+ -- $sql-set-operations+ , union_+ , unionAll_+ , except_+ , intersect_++ -- ** Common Table Expressions+ , with+ , withRecursive++ -- ** Internals+ , From(..) , ToMaybe(..)- , ToMaybeT , ToAlias(..)- , ToAliasT , ToAliasReference(..)- , ToAliasReferenceT+ , ToSqlSetOperation(..)+ , SqlSelect+ , Nullable+ -- * The Normal Stuff- , module Database.Esqueleto- )- where+ , where_+ , groupBy+ , groupBy_+ , orderBy+ , asc+ , desc+ , limit+ , offset -import Database.Esqueleto hiding (from, on, From(..))-import qualified Control.Monad.Trans.Writer as W-import qualified Control.Monad.Trans.State as S-import Control.Monad.Trans.Class (lift)-#if __GLASGOW_HASKELL__ < 804-import Data.Semigroup-#endif-import Data.Proxy (Proxy(..))+ , distinct+ , distinctOn+ , don+ , distinctOnOrderBy+ , having+ , locking+ , forUpdate+ , forUpdateSkipLocked++ , (^.)+ , (?.)++ , val+ , isNothing+ , isNothing_+ , just+ , nothing+ , joinV+ , withNonNull++ , countRows+ , count+ , countDistinct++ , not_+ , (==.)+ , (>=.)+ , (>.)+ , (<=.)+ , (<.)+ , (!=.)+ , (&&.)+ , (||.)++ , between+ , (+.)+ , (-.)+ , (/.)+ , (*.)++ , round_+ , ceiling_+ , floor_++ , min_+ , max_+ , sum_+ , avg_+ , castNum+ , castNumM++ , coalesce+ , coalesceDefault++ , lower_+ , upper_+ , trim_+ , ltrim_+ , rtrim_+ , length_+ , left_+ , right_++ , like+ , ilike+ , (%)+ , concat_+ , (++.)+ , castString++ , subList_select+ , valList+ , justList++ , in_+ , notIn+ , exists+ , notExists++ , set+ , (=.)+ , (+=.)+ , (-=.)+ , (*=.)+ , (/=.)++ , case_+ , toBaseId+ , toBaseIdMaybe+ , fromBaseId+ , fromBaseIdMaybe+ , subSelect+ , subSelectMaybe+ , subSelectCount+ , subSelectForeign+ , subSelectList+ , subSelectUnsafe+ , ToBaseId(..)+ , when_+ , then_+ , else_+ , Value(..)+ , ValueList(..)+ , OrderBy+ , DistinctOn+ , LockingKind(..)+ , LockableEntity(..)+ , SqlString++ -- ** Joins+ , InnerJoin(..)+ , CrossJoin(..)+ , LeftOuterJoin(..)+ , RightOuterJoin(..)+ , FullOuterJoin(..)+ , JoinKind(..)+ , OnClauseWithoutMatchingJoinException(..)+ -- *** Join Helpers+ , getTable+ , getTableMaybe+ , GetFirstTable(..)++ -- ** SQL backend+ , SqlQuery+ , SqlExpr+ , SqlEntity+ , select+ , selectOne+ , selectSource+ , delete+ , deleteCount+ , update+ , updateCount+ , insertSelect+ , insertSelectCount+ , (<#)+ , (<&>)++ -- ** Rendering Queries+ , renderQueryToText+ , renderQuerySelect+ , renderQueryUpdate+ , renderQueryDelete+ , renderQueryInsertInto++ -- ** Helpers+ , valkey+ , valJ+ , associateJoin++ -- ** Re-exports+ -- $reexports+ , deleteKey+ , module Database.Esqueleto.Internal.PersistentImport+ ) where++import Database.Esqueleto.Internal.Internal hiding (From, from, on) import Database.Esqueleto.Internal.PersistentImport-import Database.Esqueleto.Internal.Internal- ( SqlExpr(..)- , InnerJoin(..)- , CrossJoin(..)- , LeftOuterJoin(..)- , RightOuterJoin(..)- , FullOuterJoin(..)- , FromClause(..)- , SqlQuery(..)- , SideData(..)- , Value(..)- , JoinKind(..)- , newIdentFor- , SqlSelect(..)- , Mode(..)- , toRawSql- , Ident(..)- , to3, to4, to5, to6, to7, to8- , from3, from4, from5, from6, from7, from8- , veryUnsafeCoerceSqlExprValue- , parensM- , NeedParens(..)- )-import GHC.TypeLits +import Database.Esqueleto.Experimental.From+import Database.Esqueleto.Experimental.From.CommonTableExpression+import Database.Esqueleto.Experimental.From.Join+import Database.Esqueleto.Experimental.From.SqlSetOperation+import Database.Esqueleto.Experimental.ToAlias+import Database.Esqueleto.Experimental.ToAliasReference+import Database.Esqueleto.Experimental.ToMaybe+ -- $setup -- -- If you're already using "Database.Esqueleto", then you can get@@ -95,9 +244,11 @@ -- -- ... ----- import Database.Esqueleto hiding (on, from) -- import Database.Esqueleto.Experimental -- @+--+-- Note: Prior to @esqueleto-3.3.4.0@, the @Database.Esqueleto.Experimental@+-- module did not reexport @Data.Esqueleto@. ---------------------------------------------------------------------- @@ -170,7 +321,7 @@ -- -- @ -- select $ do--- people <- from $ Table \@Person+-- people <- from $ table \@Person -- where_ (people ^. PersonName ==. val \"John\") -- pure people -- @@@ -186,8 +337,8 @@ -- @ -- select $ -- from $ \\(people \`LeftOuterJoin\` blogPosts) -> do--- on (people ^. PersonId ==. blogPosts ?. BlogPostAuthorId)--- where_ (people ^. PersonAge >. val 18)+-- on (just (people ^. PersonId) ==. blogPosts ?. BlogPostAuthorId)+-- where_ (people ^. PersonAge >. just (val 18)) -- pure (people, blogPosts) -- @ --@@ -198,11 +349,11 @@ -- @ -- select $ do -- (people :& blogPosts) <---- from $ Table \@Person--- \`LeftOuterJoin\` Table \@BlogPost+-- from $ table \@Person+-- \`leftJoin\` table \@BlogPost -- \`on\` (\\(people :& blogPosts) ->--- people ^. PersonId ==. blogPosts ?. BlogPostAuthorId)--- where_ (people ^. PersonAge >. val 18)+-- just (people ^. PersonId) ==. blogPosts ?. BlogPostAuthorId)+-- where_ (people ^. PersonAge >. just (val 18)) -- pure (people, blogPosts) -- @ --@@ -230,7 +381,7 @@ -- -- In this version, with each successive 'on' clause, only the tables -- we have already joined into are in scope, so we must pattern match--- accordingly. In this case, in the second 'InnerJoin', we do not use+-- accordingly. In this case, in the second 'innerJoin', we do not use -- the first `Person` reference, so we use @_@ as a placeholder to -- ignore it. This prevents a possible runtime error where a table -- is referenced before it appears in the sequence of 'JOIN's.@@ -238,11 +389,11 @@ -- @ -- select $ do -- (people1 :& followers :& people2) <---- from $ Table \@Person--- \`InnerJoin` Table \@Follow+-- from $ table \@Person+-- \`innerJoin` table \@Follow -- \`on\` (\\(people1 :& followers) -> -- people1 ^. PersonId ==. followers ^. FollowFollowed)--- \`InnerJoin` Table \@Person+-- \`innerJoin` table \@Person -- \`on\` (\\(_ :& followers :& people2) -> -- followers ^. FollowFollower ==. people2 ^. PersonId) -- where_ (people1 ^. PersonName ==. val \"John\")@@ -272,10 +423,10 @@ -- @ -- select $ do -- peopleWithPosts <---- from $ SelectQuery $ do+-- from $ do -- (people :& blogPosts) <---- from $ Table \@Person--- \`InnerJoin\` Table \@BlogPost+-- from $ table \@Person+-- \`innerJoin\` table \@BlogPost -- \`on\` (\\(p :& bP) -> -- p ^. PersonId ==. bP ^. BlogPostAuthorId) -- groupBy (people ^. PersonId)@@ -303,23 +454,23 @@ -- @ -- select $ do -- (authors, blogPosts) <- from $--- (SelectQuery $ do+-- (do -- (author :& blogPost) <---- from $ Table \@Person--- \`InnerJoin\` Table \@BlogPost+-- from $ table \@Person+-- \`innerJoin\` table \@BlogPost -- \`on\` (\\(a :& bP) -> -- a ^. PersonId ==. bP ^. BlogPostAuthorId) -- where_ (author ^. PersonId ==. val currentPersonId) -- pure (author, blogPost) -- )--- \`Union\`--- (SelectQuery $ do+-- \`union_\`+-- (do -- (follow :& blogPost :& author) <---- from $ Table \@Follow--- \`InnerJoin\` Table \@BlogPost+-- from $ table \@Follow+-- \`innerJoin\` table \@BlogPost -- \`on\` (\\(f :& bP) -> -- f ^. FollowFollowed ==. bP ^. BlogPostAuthorId)--- \`InnerJoin\` Table \@Person+-- \`innerJoin\` table \@Person -- \`on\` (\\(_ :& bP :& a) -> -- bP ^. BlogPostAuthorId ==. a ^. PersonId) -- where_ (follow ^. FollowFollower ==. val currentPersonId)@@ -329,551 +480,87 @@ -- limit 25 -- pure (authors, blogPosts) -- @---- | A left-precedence pair. Pronounced \"and\". Used to represent expressions--- that have been joined together. ----- The precedence behavior can be demonstrated by:+-- === Example 6: LATERAL JOIN ----- @--- a :& b :& c == ((a :& b) :& c)--- @+-- As of version @3.4.0.0@, lateral subquery joins are supported. ----- See the examples at the beginning of this module to see how this--- operator is used in 'JOIN' operations.-data (:&) a b = a :& b-infixl 2 :&---- | Data type that represents SQL set operations. This includes--- 'UNION', 'UNION' 'ALL', 'EXCEPT', and 'INTERSECT'. This data--- type is defined as a binary tree, with @SelectQuery@ on the leaves. ----- Each constructor corresponding to the aforementioned set operations--- can be used as an infix function in a @from@ to help with readability--- and lead to code that closely resembles the underlying SQL. For example,--- -- @--- select $ from $--- (SelectQuery ...)--- \`Union\`--- (SelectQuery ...)+-- select $ do+-- (salesPerson :& maxSaleAmount :& maxSaleCustomerName) <-+-- from $ table \@SalesPerson+-- \`crossJoinLateral\` (\\salesPerson -> do+-- sales <- from $ table \@Sale+-- where_ $ sales ^. SaleSalesPersonId ==. salesPerson ^. SalesPersonId+-- pure $ max_ (sales ^. SaleAmount)+-- )+-- \`crossJoinLateral\` (\\(salesPerson :& maxSaleAmount) -> do+-- sales <- from $ table \@Sale+-- where_ $ sales ^. SaleSalesPersonId ==. salesPerson ^. SalesPersonId+-- &&. sales ^. SaleAmount ==. maxSaleAmount+-- pure $ sales ^. SaleCustomerName)+-- )+-- pure (salesPerson ^. SalesPersonName, maxSaleAmount, maxSaleCustomerName) -- @ ----- is translated into+-- This is the equivalent to the following SQL (example taken from the+-- [MySQL Lateral Derived Table](https://dev.mysql.com/doc/refman/8.0/en/lateral-derived-tables.html)+-- documentation): -- -- @--- SELECT * FROM (--- (SELECT * FROM ...)--- UNION--- (SELECT * FROM ...)--- )+-- SELECT+-- salesperson.name,+-- max_sale.amount,+-- max_sale_customer.customer_name+-- FROM+-- salesperson,+-- -- calculate maximum size, cache it in transient derived table max_sale+-- LATERAL+-- (SELECT MAX(amount) AS amount+-- FROM all_sales+-- WHERE all_sales.salesperson_id = salesperson.id)+-- AS max_sale,+-- LATERAL+-- (SELECT customer_name+-- FROM all_sales+-- WHERE all_sales.salesperson_id = salesperson.id+-- AND all_sales.amount =+-- -- the cached maximum size+-- max_sale.amount)+-- AS max_sale_customer; -- @++-- $sql-set-operations ----- @SelectQuery@ can be used without any of the set operations to construct--- a subquery. This can be used in 'JOIN' trees. For example,+-- Data type that represents SQL set operations. This includes+-- 'UNION', 'UNION' 'ALL', 'EXCEPT', and 'INTERSECT'. These types form+-- a binary tree, with @SqlQuery@ values on the leaves. --+-- Each function corresponding to the aforementioned set operations+-- can be used as an infix in a @from@ to help with readability+-- and lead to code that closely resembles the underlying SQL. For example,+-- -- @ -- select $ from $--- Table \@SomeTable--- \`InnerJoin\` (SelectQuery ...)--- \`on\` ...+-- (do+-- a <- from $ table @A+-- pure $ a ^. ASomeCol+-- )+-- \`union_\`+-- (do+-- b <- from $ table @B+-- pure $ b ^. BSomeCol+-- ) -- @ -- -- is translated into -- -- @--- SELECT *--- FROM SomeTable--- INNER JOIN (SELECT * FROM ...)--- ON ...--- @-data SqlSetOperation a =- Union (SqlSetOperation a) (SqlSetOperation a)- | UnionAll (SqlSetOperation a) (SqlSetOperation a)- | Except (SqlSetOperation a) (SqlSetOperation a)- | Intersect (SqlSetOperation a) (SqlSetOperation a)- | SelectQueryP NeedParens (SqlQuery a)--pattern SelectQuery :: SqlQuery a -> SqlSetOperation a-pattern SelectQuery q = SelectQueryP Never q---- | Data type that represents the syntax of a 'JOIN' tree. In practice,--- only the @Table@ constructor is used directly when writing queries. For example,------ @--- select $ from $ Table \@People--- @-data From a where- Table :: PersistEntity ent => From (SqlExpr (Entity ent))- SubQuery :: (SqlSelect a' r, SqlSelect a'' r', ToAlias a, a' ~ ToAliasT a, ToAliasReference a', ToAliasReferenceT a' ~ a'')- => SqlQuery a- -> From a''- SqlSetOperation :: (SqlSelect a' r, ToAlias a, a' ~ ToAliasT a, ToAliasReference a', ToAliasReferenceT a' ~ a'')- => SqlSetOperation a- -> From a''- InnerJoinFrom :: From a- -> (From b, (a :& b) -> SqlExpr (Value Bool))- -> From (a :& b)- CrossJoinFrom :: From a- -> From b- -> From (a :& b)- LeftJoinFrom :: ToMaybe b- => From a- -> (From b, (a :& ToMaybeT b) -> SqlExpr (Value Bool))- -> From (a :& ToMaybeT b)- RightJoinFrom :: ToMaybe a- => From a- -> (From b, (ToMaybeT a :& b) -> SqlExpr (Value Bool))- -> From (ToMaybeT a :& b)- FullJoinFrom :: (ToMaybe a, ToMaybe b )- => From a- -> (From b, (ToMaybeT a :& ToMaybeT b) -> SqlExpr (Value Bool))- -> From (ToMaybeT a :& ToMaybeT b)---- | An @ON@ clause that describes how two tables are related. This should be--- used as an infix operator after a 'JOIN'. For example,------ @--- select $--- from $ Table \@Person--- \`InnerJoin\` Table \@BlogPost--- \`on\` (\\(p :& bP) ->--- p ^. PersonId ==. bP ^. BlogPostAuthorId)+-- SELECT * FROM (+-- (SELECT a.some_col FROM a)+-- UNION+-- (SELECT b.some_col FROM b)+-- ) -- @ ---on :: ToFrom a => a -> (b -> SqlExpr (Value Bool)) -> (a, b -> SqlExpr (Value Bool))-on = (,)-infix 9 `on`--type JoinErrorMsg jk = 'Text "Missing on statement for " ':<>: 'Text jk--type family ToFromT a where- ToFromT (From a) = a- ToFromT (SqlSetOperation a) = ToAliasReferenceT (ToAliasT a)- ToFromT (LeftOuterJoin a (b, c -> SqlExpr (Value Bool))) = c- ToFromT (FullOuterJoin a (b, c -> SqlExpr (Value Bool))) = c- ToFromT (RightOuterJoin a (b, c -> SqlExpr (Value Bool))) = c- ToFromT (InnerJoin a (b, c -> SqlExpr (Value Bool))) = c- ToFromT (CrossJoin a b) = (ToFromT a :& ToFromT b)- ToFromT (InnerJoin a b) = TypeError (JoinErrorMsg "InnerJoin")- ToFromT (LeftOuterJoin a b) = TypeError (JoinErrorMsg "LeftOuterJoin")- ToFromT (RightOuterJoin a b) = TypeError (JoinErrorMsg "RightOuterJoin")- ToFromT (FullOuterJoin a b) = TypeError (JoinErrorMsg "FullOuterJoin")--{-- Type class magic to allow the use of the `InnerJoin` family of data constructors in from --}-class ToFrom a where- toFrom :: a -> From (ToFromT a)--instance ToFrom (From a) where- toFrom = id--instance {-# OVERLAPPABLE #-} ToFrom (InnerJoin a b) where- toFrom = undefined-instance {-# OVERLAPPABLE #-} ToFrom (LeftOuterJoin a b) where- toFrom = undefined-instance {-# OVERLAPPABLE #-} ToFrom (RightOuterJoin a b) where- toFrom = undefined-instance {-# OVERLAPPABLE #-} ToFrom (FullOuterJoin a b) where- toFrom = undefined--instance (SqlSelect a' r,SqlSelect a'' r', ToAlias a, a' ~ ToAliasT a, ToAliasReference a', ToAliasReferenceT a' ~ a'') => ToFrom (SqlSetOperation a) where- -- If someone uses just a plain SelectQuery it should behave like a normal subquery- toFrom (SelectQueryP _ q) = SubQuery q- -- Otherwise use the SqlSetOperation- toFrom q = SqlSetOperation q--instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b', ToMaybe b', mb ~ ToMaybeT b')- => ToFrom (LeftOuterJoin a (b, (a' :& mb) -> SqlExpr (Value Bool))) where- toFrom (LeftOuterJoin lhs (rhs, on')) = LeftJoinFrom (toFrom lhs) (toFrom rhs, on')--instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b', ToMaybe a', ma ~ ToMaybeT a', ToMaybe b', mb ~ ToMaybeT b')- => ToFrom (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) where- toFrom (FullOuterJoin lhs (rhs, on')) = FullJoinFrom (toFrom lhs) (toFrom rhs, on')--instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b', ToMaybe a', ma ~ ToMaybeT a')- => ToFrom (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) where- toFrom (RightOuterJoin lhs (rhs, on')) = RightJoinFrom (toFrom lhs) (toFrom rhs, on')--instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b') => ToFrom (InnerJoin a (b, (a' :& b') -> SqlExpr (Value Bool))) where- toFrom (InnerJoin lhs (rhs, on')) = InnerJoinFrom (toFrom lhs) (toFrom rhs, on')--instance (ToFrom a, ToFrom b) => ToFrom (CrossJoin a b) where- toFrom (CrossJoin lhs rhs) = CrossJoinFrom (toFrom lhs) (toFrom rhs)--type family Nullable a where- Nullable (Maybe a) = a- Nullable a = a--type family ToMaybeT a where- ToMaybeT (SqlExpr (Maybe a)) = SqlExpr (Maybe a)- ToMaybeT (SqlExpr (Entity a)) = SqlExpr (Maybe (Entity a))- ToMaybeT (SqlExpr (Value a)) = SqlExpr (Value (Maybe (Nullable a)))- ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b)- ToMaybeT (a, b) = (ToMaybeT a, ToMaybeT b)- ToMaybeT (a, b, c) = (ToMaybeT a, ToMaybeT b, ToMaybeT c)- ToMaybeT (a, b, c, d) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d)- ToMaybeT (a, b, c, d, e) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e)- ToMaybeT (a, b, c, d, e, f) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f)- ToMaybeT (a, b, c, d, e, f, g) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f, ToMaybeT g)- ToMaybeT (a, b, c, d, e, f, g, h) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f, ToMaybeT g, ToMaybeT h)--class ToMaybe a where- toMaybe :: a -> ToMaybeT a--instance ToMaybe (SqlExpr (Maybe a)) where- toMaybe = id--instance ToMaybe (SqlExpr (Entity a)) where- toMaybe = EMaybe--instance ToMaybe (SqlExpr (Value a)) where- toMaybe = veryUnsafeCoerceSqlExprValue--instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where- toMaybe (a :& b) = (toMaybe a :& toMaybe b)--instance (ToMaybe a, ToMaybe b) => ToMaybe (a,b) where- toMaybe (a, b) = (toMaybe a, toMaybe b)--instance ( ToMaybe a- , ToMaybe b- , ToMaybe c- ) => ToMaybe (a,b,c) where- toMaybe = to3 . toMaybe . from3--instance ( ToMaybe a- , ToMaybe b- , ToMaybe c- , ToMaybe d- ) => ToMaybe (a,b,c,d) where- toMaybe = to4 . toMaybe . from4--instance ( ToMaybe a- , ToMaybe b- , ToMaybe c- , ToMaybe d- , ToMaybe e- ) => ToMaybe (a,b,c,d,e) where- toMaybe = to5 . toMaybe . from5--instance ( ToMaybe a- , ToMaybe b- , ToMaybe c- , ToMaybe d- , ToMaybe e- , ToMaybe f- ) => ToMaybe (a,b,c,d,e,f) where- toMaybe = to6 . toMaybe . from6--instance ( ToMaybe a- , ToMaybe b- , ToMaybe c- , ToMaybe d- , ToMaybe e- , ToMaybe f- , ToMaybe g- ) => ToMaybe (a,b,c,d,e,f,g) where- toMaybe = to7 . toMaybe . from7--instance ( ToMaybe a- , ToMaybe b- , ToMaybe c- , ToMaybe d- , ToMaybe e- , ToMaybe f- , ToMaybe g- , ToMaybe h- ) => ToMaybe (a,b,c,d,e,f,g,h) where- toMaybe = to8 . toMaybe . from8---- | 'FROM' clause, used to bring entities into scope.------ Internally, this function uses the `From` datatype and the--- `ToFrom` typeclass. Unlike the old `Database.Esqueleto.from`,--- this does not take a function as a parameter, but rather--- a value that represents a 'JOIN' tree constructed out of--- instances of `ToFrom`. This implementation eliminates certain--- types of runtime errors by preventing the construction of--- invalid SQL (e.g. illegal nested-@from@).-from :: ToFrom a => a -> SqlQuery (ToFromT a)-from parts = do- (a, clause) <- runFrom $ toFrom parts- Q $ W.tell mempty{sdFromClause=[clause]}- pure a- where- runFrom :: From a -> SqlQuery (a, FromClause)- runFrom e@Table = do- let ed = entityDef $ getVal e- ident <- newIdentFor (entityDB ed)- let entity = EEntity ident- pure $ (entity, FromStart ident ed)- where- getVal :: PersistEntity ent => From (SqlExpr (Entity ent)) -> Proxy ent- getVal = const Proxy- runFrom (SubQuery subquery) = do- -- We want to update the IdentState without writing the query to side data- (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery- aliasedValue <- toAlias ret- -- Make a fake query with the aliased results, this allows us to ensure that the query is only run once- let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)- -- Add the FromQuery that renders the subquery to our side data- subqueryAlias <- newIdentFor (DBName "q")- -- Pass the aliased results of the subquery to the outer query- -- create aliased references from the outer query results (e.g value from subquery will be `subquery`.`value`),- -- this is probably overkill as the aliases should already be unique but seems to be good practice.- ref <- toAliasReference subqueryAlias aliasedValue- pure (ref , FromQuery subqueryAlias (\info -> toRawSql SELECT info aliasedQuery))-- runFrom (SqlSetOperation operation) = do- (aliasedOperation, ret) <- aliasQueries operation- ident <- newIdentFor (DBName "u")- ref <- toAliasReference ident ret- pure (ref, FromQuery ident $ operationToSql aliasedOperation)-- where- aliasQueries o =- case o of- SelectQueryP p q -> do- (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ q- prevState <- Q $ lift S.get- aliasedRet <- toAlias ret- Q $ lift $ S.put prevState- let p' =- case p of- Parens -> Parens- Never ->- if (sdLimitClause sideData) /= mempty- || length (sdOrderByClause sideData) > 0 then- Parens- else- Never- pure (SelectQueryP p' $ Q $ W.WriterT $ pure (aliasedRet, sideData), aliasedRet)- Union o1 o2 -> do- (o1', ret) <- aliasQueries o1- (o2', _ ) <- aliasQueries o2- pure (Union o1' o2', ret)- UnionAll o1 o2 -> do- (o1', ret) <- aliasQueries o1- (o2', _ ) <- aliasQueries o2- pure (UnionAll o1' o2', ret)- Except o1 o2 -> do- (o1', ret) <- aliasQueries o1- (o2', _ ) <- aliasQueries o2- pure (Except o1' o2', ret)- Intersect o1 o2 -> do- (o1', ret) <- aliasQueries o1- (o2', _ ) <- aliasQueries o2- pure (Intersect o1' o2', ret)-- operationToSql o info =- case o of- SelectQueryP p q ->- let (builder, values) = toRawSql SELECT info q- in (parensM p builder, values)- Union o1 o2 -> doSetOperation "UNION" info o1 o2- UnionAll o1 o2 -> doSetOperation "UNION ALL" info o1 o2- Except o1 o2 -> doSetOperation "EXCEPT" info o1 o2- Intersect o1 o2 -> doSetOperation "INTERSECT" info o1 o2-- doSetOperation operationText info o1 o2 =- let- (q1, v1) = operationToSql o1 info- (q2, v2) = operationToSql o2 info- in (q1 <> " " <> operationText <> " " <> q2, v1 <> v2)--- runFrom (InnerJoinFrom leftPart (rightPart, on')) = do- (leftVal, leftFrom) <- runFrom leftPart- (rightVal, rightFrom) <- runFrom rightPart- let ret = leftVal :& rightVal- pure $ (ret, FromJoin leftFrom InnerJoinKind rightFrom (Just (on' ret)))- runFrom (CrossJoinFrom leftPart rightPart) = do- (leftVal, leftFrom) <- runFrom leftPart- (rightVal, rightFrom) <- runFrom rightPart- let ret = leftVal :& rightVal- pure $ (ret, FromJoin leftFrom CrossJoinKind rightFrom Nothing)- runFrom (LeftJoinFrom leftPart (rightPart, on')) = do- (leftVal, leftFrom) <- runFrom leftPart- (rightVal, rightFrom) <- runFrom rightPart- let ret = leftVal :& (toMaybe rightVal)- pure $ (ret, FromJoin leftFrom LeftOuterJoinKind rightFrom (Just (on' ret)))- runFrom (RightJoinFrom leftPart (rightPart, on')) = do- (leftVal, leftFrom) <- runFrom leftPart- (rightVal, rightFrom) <- runFrom rightPart- let ret = (toMaybe leftVal) :& rightVal- pure $ (ret, FromJoin leftFrom RightOuterJoinKind rightFrom (Just (on' ret)))- runFrom (FullJoinFrom leftPart (rightPart, on')) = do- (leftVal, leftFrom) <- runFrom leftPart- (rightVal, rightFrom) <- runFrom rightPart- let ret = (toMaybe leftVal) :& (toMaybe rightVal)- pure $ (ret, FromJoin leftFrom FullOuterJoinKind rightFrom (Just (on' ret)))--type family ToAliasT a where- ToAliasT (SqlExpr (Value a)) = SqlExpr (Value a)- ToAliasT (SqlExpr (Entity a)) = SqlExpr (Entity a)- ToAliasT (SqlExpr (Maybe (Entity a))) = SqlExpr (Maybe (Entity a))- ToAliasT (a, b) = (ToAliasT a, ToAliasT b)- ToAliasT (a, b, c) = (ToAliasT a, ToAliasT b, ToAliasT c)- ToAliasT (a, b, c, d) = (ToAliasT a, ToAliasT b, ToAliasT c, ToAliasT d)- ToAliasT (a, b, c, d, e) = (ToAliasT a, ToAliasT b, ToAliasT c, ToAliasT d, ToAliasT e)- ToAliasT (a, b, c, d, e, f) = (ToAliasT a, ToAliasT b, ToAliasT c, ToAliasT d, ToAliasT e, ToAliasT f)- ToAliasT (a, b, c, d, e, f, g) = (ToAliasT a, ToAliasT b, ToAliasT c, ToAliasT d, ToAliasT e, ToAliasT f, ToAliasT g)- ToAliasT (a, b, c, d, e, f, g, h) = (ToAliasT a, ToAliasT b, ToAliasT c, ToAliasT d, ToAliasT e, ToAliasT f, ToAliasT g, ToAliasT h)---- Tedious tuple magic-class ToAlias a where- toAlias :: a -> SqlQuery (ToAliasT a)--instance ToAlias (SqlExpr (Value a)) where- toAlias v@(EAliasedValue _ _) = pure v- toAlias v = do- ident <- newIdentFor (DBName "v")- pure $ EAliasedValue ident v--instance ToAlias (SqlExpr (Entity a)) where- toAlias v@(EAliasedEntityReference _ _) = pure v- toAlias v@(EAliasedEntity _ _) = pure v- toAlias (EEntity tableIdent) = do- ident <- newIdentFor (DBName "v")- pure $ EAliasedEntity ident tableIdent--instance ToAlias (SqlExpr (Maybe (Entity a))) where- toAlias (EMaybe e) = EMaybe <$> toAlias e--instance (ToAlias a, ToAlias b) => ToAlias (a,b) where- toAlias (a,b) = (,) <$> toAlias a <*> toAlias b--instance ( ToAlias a- , ToAlias b- , ToAlias c- ) => ToAlias (a,b,c) where- toAlias x = to3 <$> (toAlias $ from3 x)--instance ( ToAlias a- , ToAlias b- , ToAlias c- , ToAlias d- ) => ToAlias (a,b,c,d) where- toAlias x = to4 <$> (toAlias $ from4 x)--instance ( ToAlias a- , ToAlias b- , ToAlias c- , ToAlias d- , ToAlias e- ) => ToAlias (a,b,c,d,e) where- toAlias x = to5 <$> (toAlias $ from5 x)--instance ( ToAlias a- , ToAlias b- , ToAlias c- , ToAlias d- , ToAlias e- , ToAlias f- ) => ToAlias (a,b,c,d,e,f) where- toAlias x = to6 <$> (toAlias $ from6 x)--instance ( ToAlias a- , ToAlias b- , ToAlias c- , ToAlias d- , ToAlias e- , ToAlias f- , ToAlias g- ) => ToAlias (a,b,c,d,e,f,g) where- toAlias x = to7 <$> (toAlias $ from7 x)--instance ( ToAlias a- , ToAlias b- , ToAlias c- , ToAlias d- , ToAlias e- , ToAlias f- , ToAlias g- , ToAlias h- ) => ToAlias (a,b,c,d,e,f,g,h) where- toAlias x = to8 <$> (toAlias $ from8 x)---type family ToAliasReferenceT a where- ToAliasReferenceT (SqlExpr (Value a)) = SqlExpr (Value a)- ToAliasReferenceT (SqlExpr (Entity a)) = SqlExpr (Entity a)- ToAliasReferenceT (SqlExpr (Maybe (Entity a))) = SqlExpr (Maybe (Entity a))- ToAliasReferenceT (a,b) = (ToAliasReferenceT a, ToAliasReferenceT b)- ToAliasReferenceT (a,b,c) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c)- ToAliasReferenceT (a, b, c, d) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c, ToAliasReferenceT d)- ToAliasReferenceT (a, b, c, d, e) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c, ToAliasReferenceT d, ToAliasReferenceT e)- ToAliasReferenceT (a, b, c, d, e, f) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c, ToAliasReferenceT d, ToAliasReferenceT e, ToAliasReferenceT f)- ToAliasReferenceT (a, b, c, d, e, f, g) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c, ToAliasReferenceT d, ToAliasReferenceT e, ToAliasReferenceT f, ToAliasReferenceT g)- ToAliasReferenceT (a, b, c, d, e, f, g, h) = (ToAliasReferenceT a, ToAliasReferenceT b, ToAliasReferenceT c, ToAliasReferenceT d, ToAliasReferenceT e, ToAliasReferenceT f, ToAliasReferenceT g, ToAliasReferenceT h)---- more tedious tuple magic-class ToAliasReference a where- toAliasReference :: Ident -> a -> SqlQuery (ToAliasReferenceT a)--instance ToAliasReference (SqlExpr (Value a)) where- toAliasReference aliasSource (EAliasedValue aliasIdent _) = pure $ EValueReference aliasSource (\_ -> aliasIdent)- toAliasReference _ v@(ERaw _ _) = toAlias v- toAliasReference _ v@(ECompositeKey _) = toAlias v- toAliasReference s (EValueReference _ b) = pure $ EValueReference s b--instance ToAliasReference (SqlExpr (Entity a)) where- toAliasReference aliasSource (EAliasedEntity ident _) = pure $ EAliasedEntityReference aliasSource ident- toAliasReference _ e@(EEntity _) = toAlias e- toAliasReference s (EAliasedEntityReference _ b) = pure $ EAliasedEntityReference s b--instance ToAliasReference (SqlExpr (Maybe (Entity a))) where- toAliasReference s (EMaybe e) = EMaybe <$> toAliasReference s e-instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a, b) where- toAliasReference ident (a,b) = (,) <$> (toAliasReference ident a) <*> (toAliasReference ident b)--instance ( ToAliasReference a- , ToAliasReference b- , ToAliasReference c- ) => ToAliasReference (a,b,c) where- toAliasReference ident x = fmap to3 $ toAliasReference ident $ from3 x--instance ( ToAliasReference a- , ToAliasReference b- , ToAliasReference c- , ToAliasReference d- ) => ToAliasReference (a,b,c,d) where- toAliasReference ident x = fmap to4 $ toAliasReference ident $ from4 x--instance ( ToAliasReference a- , ToAliasReference b- , ToAliasReference c- , ToAliasReference d- , ToAliasReference e- ) => ToAliasReference (a,b,c,d,e) where- toAliasReference ident x = fmap to5 $ toAliasReference ident $ from5 x--instance ( ToAliasReference a- , ToAliasReference b- , ToAliasReference c- , ToAliasReference d- , ToAliasReference e- , ToAliasReference f- ) => ToAliasReference (a,b,c,d,e,f) where- toAliasReference ident x = to6 <$> (toAliasReference ident $ from6 x)--instance ( ToAliasReference a- , ToAliasReference b- , ToAliasReference c- , ToAliasReference d- , ToAliasReference e- , ToAliasReference f- , ToAliasReference g- ) => ToAliasReference (a,b,c,d,e,f,g) where- toAliasReference ident x = to7 <$> (toAliasReference ident $ from7 x)--instance ( ToAliasReference a- , ToAliasReference b- , ToAliasReference c- , ToAliasReference d- , ToAliasReference e- , ToAliasReference f- , ToAliasReference g- , ToAliasReference h- ) => ToAliasReference (a,b,c,d,e,f,g,h) where- toAliasReference ident x = to8 <$> (toAliasReference ident $ from8 x)
+ src/Database/Esqueleto/Experimental/From.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Database.Esqueleto.Experimental.From+ where++import qualified Control.Monad.Trans.Writer as W+import Data.Coerce (coerce)+import Data.Proxy+import qualified Data.Text.Lazy.Builder as TLB+import Database.Esqueleto.Experimental.ToAlias+import Database.Esqueleto.Experimental.ToAliasReference+import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)+import Database.Esqueleto.Internal.PersistentImport++-- | 'FROM' clause, used to bring entities into scope.+--+-- Internally, this function uses the `From` datatype.+-- Unlike the old `Database.Esqueleto.from`, this does not+-- take a function as a parameter, but rather a value that+-- represents a 'JOIN' tree constructed out of instances of `From`.+-- This implementation eliminates certain+-- types of runtime errors by preventing the construction of+-- invalid SQL (e.g. illegal nested-@from@).+from :: ToFrom a a' => a -> SqlQuery a'+from f = do+ (a, clause) <- unFrom (toFrom f)+ Q $ W.tell mempty{sdFromClause=[FromRaw $ clause]}+ pure a++type RawFn = NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])++-- | Data type defining the "From" language. This should not+-- constructed directly in application code.+--+-- A @From@ is a SqlQuery which returns a reference to the result of calling from+-- and a function that produces a portion of a FROM clause. This gets passed to+-- the FromRaw FromClause constructor directly when converting+-- from a @From@ to a @SqlQuery@ using @from@+--+-- @since 3.5.0.0+newtype From a = From+ { unFrom :: SqlQuery (a, RawFn)}+++-- | A helper class primarily designed to allow using @SqlQuery@ directly in+-- a From expression. This is also useful for embedding a @SqlSetOperation@,+-- as well as supporting backwards compatibility for the+-- data constructor join tree used prior to /3.5.0.0/+--+-- @since 3.5.0.0+class ToFrom a r | a -> r where+ toFrom :: a -> From r+instance ToFrom (From a) a where+ toFrom = id++{-# DEPRECATED Table "@since 3.5.0.0 - use 'table' instead" #-}+data Table a = Table++instance PersistEntity ent => ToFrom (Table ent) (SqlExpr (Entity ent)) where+ toFrom _ = table++-- | Bring a PersistEntity into scope from a table+--+-- @+-- select $ from $ table \@People+-- @+--+-- @since 3.5.0.0+table :: forall ent. PersistEntity ent => From (SqlExpr (Entity ent))+table = From $ do+ let ed = entityDef (Proxy @ent)+ ident <- newIdentFor (coerce $ getEntityDBName ed)+ let entity = unsafeSqlEntity ident+ pure $ ( entity, const $ base ident ed )+ where+ base ident@(I identText) def info =+ let db = coerce $ getEntityDBName def+ in ( (fromDBName info (coerce db)) <>+ if db == identText+ then mempty+ else " AS " <> useIdent info ident+ , mempty+ )+++instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SqlQuery a) a where+ toFrom = selectQuery++-- | Select from a subquery, often used in conjuction with joins but can be+-- used without any joins. Because @SqlQuery@ has a @ToFrom@ instance you probably+-- dont need to use this function directly.+--+-- @+-- select $+-- p <- from $+-- selectQuery do+-- p <- from $ table \@Person+-- limit 5+-- orderBy [ asc p ^. PersonAge ]+-- ...+-- @+--+-- @since 3.5.0.0+selectQuery :: (SqlSelect a r, ToAlias a, ToAliasReference a) => SqlQuery a -> From a+selectQuery subquery = From $ do+ -- We want to update the IdentState without writing the query to side data+ (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery+ aliasedValue <- toAlias ret+ -- Make a fake query with the aliased results, this allows us to ensure that the query is only run once+ let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)+ -- Add the FromQuery that renders the subquery to our side data+ subqueryAlias <- newIdentFor (DBName "q")+ -- Pass the aliased results of the subquery to the outer query+ -- create aliased references from the outer query results (e.g value from subquery will be `subquery`.`value`),+ -- this is probably overkill as the aliases should already be unique but seems to be good practice.+ ref <- toAliasReference subqueryAlias aliasedValue++ pure (ref, \_ info ->+ let (queryText,queryVals) = toRawSql SELECT info aliasedQuery+ in+ ( (parens queryText) <> " AS " <> useIdent info subqueryAlias+ , queryVals+ )+ )
+ src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Esqueleto.Experimental.From.CommonTableExpression+ where++import qualified Control.Monad.Trans.Writer as W+import qualified Data.Text.Lazy.Builder as TLB+import Database.Esqueleto.Experimental.From+import Database.Esqueleto.Experimental.From.SqlSetOperation+import Database.Esqueleto.Experimental.ToAlias+import Database.Esqueleto.Experimental.ToAliasReference+import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)++-- | @WITH@ clause used to introduce a [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression).+-- CTEs are supported in most modern SQL engines and can be useful+-- in performance tuning. In Esqueleto, CTEs should be used as a+-- subquery memoization tactic. When writing plain SQL, CTEs+-- are sometimes used to organize the SQL code, in Esqueleto, this+-- is better achieved through function that return 'SqlQuery' values.+--+-- @+-- select $ do+-- cte <- with subQuery+-- cteResult <- from cte+-- where_ $ cteResult ...+-- pure cteResult+-- @+--+-- __WARNING__: In some SQL engines using a CTE can diminish performance.+-- In these engines the CTE is treated as an optimization fence. You should+-- always verify that using a CTE will in fact improve your performance+-- over a regular subquery.+--+-- Notably, in PostgreSQL prior to version 12, CTEs are always fully+-- calculated, which can potentially significantly pessimize queries. As of+-- PostgreSQL 12, non-recursive and side-effect-free queries may be inlined and+-- optimized accordingly if not declared @MATERIALIZED@ to get the previous+-- behaviour. See [the PostgreSQL CTE documentation](https://www.postgresql.org/docs/current/queries-with.html#id-1.5.6.12.7),+-- section Materialization, for more information. To use a @MATERIALIZED@ query+-- in Esquelto, see functions 'withMaterialized' and 'withRecursiveMaterialized'.+--+-- /Since: 3.4.0.0/+with :: ( ToAlias a+ , ToAliasReference a+ , SqlSelect a r+ ) => SqlQuery a -> SqlQuery (From a)+with query = do+ (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ query+ aliasedValue <- toAlias ret+ let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)+ ident <- newIdentFor (DBName "cte")+ let clause = CommonTableExpressionClause NormalCommonTableExpression (\_ _ -> "") ident (\info -> toRawSql SELECT info aliasedQuery)+ Q $ W.tell mempty{sdCteClause = [clause]}+ ref <- toAliasReference ident aliasedValue+ pure $ From $ do+ newIdent <- newIdentFor (DBName "cte")+ localRef <- toAliasReference newIdent ref+ let makeLH info = useIdent info ident <> " AS " <> useIdent info newIdent+ pure (localRef, (\_ info -> (makeLH info, mempty)))++-- | @WITH@ @RECURSIVE@ allows one to make a recursive subquery, which can+-- reference itself. Like @WITH@, this is supported in most modern SQL engines.+-- Useful for hierarchical, self-referential data, like a tree of data.+--+-- @+-- select $ do+-- cte <- withRecursive+-- (do+-- person <- from $ table \@Person+-- where_ $ person ^. PersonId ==. val personId+-- pure person+-- )+-- unionAll_+-- (\\self -> do+-- (p :& f :& p2 :& pSelf) <- from self+-- \`innerJoin\` $ table \@Follow+-- \`on\` (\\(p :& f) ->+-- p ^. PersonId ==. f ^. FollowFollower)+-- \`innerJoin\` $ table \@Person+-- \`on\` (\\(p :& f :& p2) ->+-- f ^. FollowFollowed ==. p2 ^. PersonId)+-- \`leftJoin\` self+-- \`on\` (\\(_ :& _ :& p2 :& pSelf) ->+-- just (p2 ^. PersonId) ==. pSelf ?. PersonId)+-- where_ $ isNothing (pSelf ?. PersonId)+-- groupBy (p2 ^. PersonId)+-- pure p2+-- )+-- from cte+-- @+--+-- /Since: 3.4.0.0/+withRecursive :: ( ToAlias a+ , ToAliasReference a+ , SqlSelect a r+ )+ => SqlQuery a+ -> UnionKind+ -> (From a -> SqlQuery a)+ -> SqlQuery (From a)+withRecursive baseCase unionKind recursiveCase = do+ (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ baseCase+ aliasedValue <- toAlias ret+ let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)+ ident <- newIdentFor (DBName "cte")+ ref <- toAliasReference ident aliasedValue+ let refFrom = From (pure (ref, (\_ info -> (useIdent info ident, mempty))))+ let recursiveQuery = recursiveCase refFrom+ let noModifier _ _ = ""+ let clause = CommonTableExpressionClause RecursiveCommonTableExpression noModifier ident+ (\info -> (toRawSql SELECT info aliasedQuery)+ <> ("\n" <> (unUnionKind unionKind) <> "\n", mempty)+ <> (toRawSql SELECT info recursiveQuery)+ )+ Q $ W.tell mempty{sdCteClause = [clause]}+ pure refFrom++newtype UnionKind = UnionKind { unUnionKind :: TLB.Builder }+instance Union_ UnionKind where+ union_ = UnionKind "UNION"+instance UnionAll_ UnionKind where+ unionAll_ = UnionKind "UNION ALL"
+ src/Database/Esqueleto/Experimental/From/Join.hs view
@@ -0,0 +1,572 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Database.Esqueleto.Experimental.From.Join+ ( (:&)(..)+ , ValidOnClause+ , on+ , ErrorOnLateral+ , fromJoin+ , HasOnClause+ , innerJoin+ , innerJoinLateral+ , crossJoin+ , crossJoinLateral+ , leftJoin+ , leftJoinLateral+ , rightJoin+ , fullOuterJoin+ , GetFirstTable(..)+ , getTable+ , getTableMaybe+ -- Compatability for old syntax+ , Lateral+ , NotLateral+ , IsLateral+ , DoInnerJoin(..)+ , DoLeftJoin(..)+ , DoCrossJoin(..)+ ) where++import Data.Bifunctor (first)+import Data.Kind (Constraint)+import Data.Proxy+import qualified Data.Text.Lazy.Builder as TLB+import Database.Esqueleto.Experimental.From+import Database.Esqueleto.Experimental.ToAlias+import Database.Esqueleto.Experimental.ToAliasReference+import Database.Esqueleto.Experimental.ToMaybe+import Database.Esqueleto.Internal.Internal hiding+ (From(..), from, fromJoin, on)+import Database.Esqueleto.Internal.PersistentImport (Entity)+import GHC.TypeLits++instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where+ type ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b)+ toMaybe (a :& b) = (toMaybe a :& toMaybe b)++class ValidOnClause a+instance {-# OVERLAPPABLE #-} ToFrom a a' => ValidOnClause a+instance ValidOnClause (a -> SqlQuery b)++-- | You may return joined values from a 'select' query - this is+-- identical to the tuple instance, but is provided for convenience.+--+-- @since 3.5.2.0+instance (SqlSelect a ra, SqlSelect b rb) => SqlSelect (a :& b) (ra :& rb) where+ sqlSelectCols esc (a :& b) = sqlSelectCols esc (a, b)+ sqlSelectColCount = sqlSelectColCount . toTuple+ where+ toTuple :: Proxy (a :& b) -> Proxy (a, b)+ toTuple = const Proxy+ sqlSelectProcessRow = fmap (uncurry (:&)) . sqlSelectProcessRow++-- | Identical to the tuple instance and provided for convenience.+--+-- @since 3.5.3.0+instance (ToAlias a, ToAlias b) => ToAlias (a :& b) where+ toAlias (a :& b) = (:&) <$> toAlias a <*> toAlias b++-- | Identical to the tuple instance and provided for convenience.+--+-- @since 3.5.3.0+instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a :& b) where+ toAliasReference ident (a :& b) = (:&) <$> (toAliasReference ident a) <*> (toAliasReference ident b)++-- | An @ON@ clause that describes how two tables are related. This should be+-- used as an infix operator after a 'JOIN'. For example,+--+-- @+-- select $+-- from $ table \@Person+-- \`innerJoin\` table \@BlogPost+-- \`on\` (\\(p :& bP) ->+-- p ^. PersonId ==. bP ^. BlogPostAuthorId)+-- @+on :: ValidOnClause a => a -> (b -> SqlExpr (Value Bool)) -> (a, b -> SqlExpr (Value Bool))+on = (,)+infix 9 `on`++type family ErrorOnLateral a :: Constraint where+ ErrorOnLateral (a -> SqlQuery b) = TypeError ('Text "LATERAL can only be used for INNER, LEFT, and CROSS join kinds.")+ ErrorOnLateral _ = ()++fromJoin :: TLB.Builder -> RawFn -> RawFn -> Maybe (SqlExpr (Value Bool)) -> RawFn+fromJoin joinKind lhs rhs monClause =+ \paren info ->+ first (parensM paren) $+ mconcat [ lhs Never info+ , (joinKind, mempty)+ , rhs Parens info+ , maybe mempty (makeOnClause info) monClause+ ]+ where+ makeOnClause info (ERaw _ f) = first (" ON " <>) (f Never info)++type family HasOnClause actual expected :: Constraint where+ HasOnClause (a, b -> SqlExpr (Value Bool)) c = () -- Let the compiler handle the type mismatch+ HasOnClause a expected =+ TypeError ( 'Text "Missing ON clause for join with"+ ':$$: 'ShowType a+ ':$$: 'Text ""+ ':$$: 'Text "Expected: "+ ':$$: 'ShowType a+ ':$$: 'Text "`on` " ':<>: 'ShowType (expected -> SqlExpr (Value Bool))+ ':$$: 'Text ""+ )+++-- | INNER JOIN+--+-- Used as an infix operator \`innerJoin\`+--+-- @+-- select $+-- from $ table \@Person+-- \`innerJoin\` table \@BlogPost+-- \`on\` (\\(p :& bp) ->+-- p ^. PersonId ==. bp ^. BlogPostAuthorId)+-- @+--+-- @since 3.5.0.0+innerJoin :: ( ToFrom a a'+ , ToFrom b b'+ , HasOnClause rhs (a' :& b')+ , rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool))+ ) => a -> rhs -> From (a' :& b')+innerJoin lhs (rhs, on') = From $ do+ (leftVal, leftFrom) <- unFrom (toFrom lhs)+ (rightVal, rightFrom) <- unFrom (toFrom rhs)+ let ret = leftVal :& rightVal+ pure $ (ret, fromJoin " INNER JOIN " leftFrom rightFrom (Just $ on' ret))+++-- | INNER JOIN LATERAL+--+-- A Lateral subquery join allows the joined query to reference entities from the+-- left hand side of the join. Discards rows that don't match the on clause+--+-- Used as an infix operator \`innerJoinLateral\`+--+-- See example 6+--+-- @since 3.5.0.0+innerJoinLateral :: ( ToFrom a a'+ , HasOnClause rhs (a' :& b)+ , SqlSelect b r+ , ToAlias b+ , ToAliasReference b+ , rhs ~ (a' -> SqlQuery b, (a' :& b) -> SqlExpr (Value Bool))+ )+ => a -> rhs -> From (a' :& b)+innerJoinLateral lhs (rhsFn, on') = From $ do+ (leftVal, leftFrom) <- unFrom (toFrom lhs)+ (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal))+ let ret = leftVal :& rightVal+ pure $ (ret, fromJoin " INNER JOIN LATERAL " leftFrom rightFrom (Just $ on' ret))++-- | CROSS JOIN+--+-- Used as an infix \`crossJoin\`+--+-- @+-- select $ do+-- from $ table \@Person+-- \`crossJoin\` table \@BlogPost+-- @+--+-- @since 3.5.0.0+crossJoin :: ( ToFrom a a'+ , ToFrom b b'+ ) => a -> b -> From (a' :& b')+crossJoin lhs rhs = From $ do+ (leftVal, leftFrom) <- unFrom (toFrom lhs)+ (rightVal, rightFrom) <- unFrom (toFrom rhs)+ let ret = leftVal :& rightVal+ pure $ (ret, fromJoin " CROSS JOIN " leftFrom rightFrom Nothing)++-- | CROSS JOIN LATERAL+--+-- A Lateral subquery join allows the joined query to reference entities from the+-- left hand side of the join.+--+-- Used as an infix operator \`crossJoinLateral\`+--+-- See example 6+--+-- @since 3.5.0.0+crossJoinLateral :: ( ToFrom a a'+ , SqlSelect b r+ , ToAlias b+ , ToAliasReference b+ )+ => a -> (a' -> SqlQuery b) -> From (a' :& b)+crossJoinLateral lhs rhsFn = From $ do+ (leftVal, leftFrom) <- unFrom (toFrom lhs)+ (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal))+ let ret = leftVal :& rightVal+ pure $ (ret, fromJoin " CROSS JOIN LATERAL " leftFrom rightFrom Nothing)++-- | LEFT OUTER JOIN+--+-- Join where the right side may not exist.+-- If the on clause fails then the right side will be NULL'ed+-- Because of this the right side needs to be handled as a Maybe+--+-- Used as an infix operator \`leftJoin\`+--+-- @+-- select $+-- from $ table \@Person+-- \`leftJoin\` table \@BlogPost+-- \`on\` (\\(p :& bp) ->+-- just (p ^. PersonId) ==. bp ?. BlogPostAuthorId)+-- @+--+-- @since 3.5.0.0+leftJoin :: ( ToFrom a a'+ , ToFrom b b'+ , ToMaybe b'+ , HasOnClause rhs (a' :& ToMaybeT b')+ , rhs ~ (b, (a' :& ToMaybeT b') -> SqlExpr (Value Bool))+ ) => a -> rhs -> From (a' :& ToMaybeT b')+leftJoin lhs (rhs, on') = From $ do+ (leftVal, leftFrom) <- unFrom (toFrom lhs)+ (rightVal, rightFrom) <- unFrom (toFrom rhs)+ let ret = leftVal :& toMaybe rightVal+ pure $ (ret, fromJoin " LEFT OUTER JOIN " leftFrom rightFrom (Just $ on' ret))++-- | LEFT OUTER JOIN LATERAL+--+-- Lateral join where the right side may not exist.+-- In the case that the query returns nothing or the on clause fails the right+-- side of the join will be NULL'ed+-- Because of this the right side needs to be handled as a Maybe+--+-- Used as an infix operator \`leftJoinLateral\`+--+-- See example 6 for how to use LATERAL+--+-- @since 3.5.0.0+leftJoinLateral :: ( ToFrom a a'+ , SqlSelect b r+ , HasOnClause rhs (a' :& ToMaybeT b)+ , ToAlias b+ , ToAliasReference b+ , ToMaybe b+ , rhs ~ (a' -> SqlQuery b, (a' :& ToMaybeT b) -> SqlExpr (Value Bool))+ )+ => a -> rhs -> From (a' :& ToMaybeT b)+leftJoinLateral lhs (rhsFn, on') = From $ do+ (leftVal, leftFrom) <- unFrom (toFrom lhs)+ (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal))+ let ret = leftVal :& toMaybe rightVal+ pure $ (ret, fromJoin " LEFT OUTER JOIN LATERAL " leftFrom rightFrom (Just $ on' ret))++-- | RIGHT OUTER JOIN+--+-- Join where the left side may not exist.+-- If the on clause fails then the left side will be NULL'ed+-- Because of this the left side needs to be handled as a Maybe+--+-- Used as an infix operator \`rightJoin\`+--+-- @+-- select $+-- from $ table \@Person+-- \`rightJoin\` table \@BlogPost+-- \`on\` (\\(p :& bp) ->+-- p ?. PersonId ==. bp ^. BlogPostAuthorId)+-- @+--+-- @since 3.5.0.0+rightJoin :: ( ToFrom a a'+ , ToFrom b b'+ , ToMaybe a'+ , HasOnClause rhs (ToMaybeT a' :& b')+ , rhs ~ (b, (ToMaybeT a' :& b') -> SqlExpr (Value Bool))+ ) => a -> rhs -> From (ToMaybeT a' :& b')+rightJoin lhs (rhs, on') = From $ do+ (leftVal, leftFrom) <- unFrom (toFrom lhs)+ (rightVal, rightFrom) <- unFrom (toFrom rhs)+ let ret = toMaybe leftVal :& rightVal+ pure $ (ret, fromJoin " RIGHT OUTER JOIN " leftFrom rightFrom (Just $ on' ret))++-- | FULL OUTER JOIN+--+-- Join where both sides of the join may not exist.+-- Because of this the result needs to be handled as a Maybe+--+-- Used as an infix operator \`fullOuterJoin\`+--+-- @+-- select $+-- from $ table \@Person+-- \`fullOuterJoin\` table \@BlogPost+-- \`on\` (\\(p :& bp) ->+-- p ?. PersonId ==. bp ?. BlogPostAuthorId)+-- @+--+-- @since 3.5.0.0+fullOuterJoin :: ( ToFrom a a'+ , ToFrom b b'+ , ToMaybe a'+ , ToMaybe b'+ , HasOnClause rhs (ToMaybeT a' :& ToMaybeT b')+ , rhs ~ (b, (ToMaybeT a' :& ToMaybeT b') -> SqlExpr (Value Bool))+ ) => a -> rhs -> From (ToMaybeT a' :& ToMaybeT b')+fullOuterJoin lhs (rhs, on') = From $ do+ (leftVal, leftFrom) <- unFrom (toFrom lhs)+ (rightVal, rightFrom) <- unFrom (toFrom rhs)+ let ret = toMaybe leftVal :& toMaybe rightVal+ pure $ (ret, fromJoin " FULL OUTER JOIN " leftFrom rightFrom (Just $ on' ret))++infixl 2 `innerJoin`,+ `innerJoinLateral`,+ `leftJoin`,+ `leftJoinLateral`,+ `crossJoin`,+ `crossJoinLateral`,+ `rightJoin`,+ `fullOuterJoin`++-- | Typeclass for selecting tables using type application syntax.+--+-- If you have a long chain of tables joined with `(:&)`, like+-- @a :& b :& c :& d@, then @getTable \@c (a :& b :& c :& d)@ will give you the+-- @c@ table back.+--+-- Note that this typeclass will only select the first table of the given type;+-- it may be less useful if there's multiple tables of the same type.+--+-- @since 3.5.9.0+class GetFirstTable t ts where+ -- | Get the first table of type `t` from the tables `ts`.+ --+ -- @since 3.5.9.0+ getFirstTable :: ts -> t++instance GetFirstTable t (t :& ts) where+ getFirstTable (t :& _) = t++instance GetFirstTable t (x :& t) where+ getFirstTable (_ :& t) = t++-- The associativity of (:&) means we do the recursion along the left-hand side.+instance {-# OVERLAPPABLE #-} GetFirstTable t ts => GetFirstTable t (ts :& x) where+ getFirstTable (ts :& _) = getFirstTable ts++-- | Get the first table of a given type from a chain of tables joined with `(:&)`.+--+-- This can make it easier to write queries with a large number of join clauses:+--+-- @+-- select $ do+-- (people :& followers :& blogPosts) <-+-- from $ table \@Person+-- \`innerJoin` table \@Follow+-- \`on\` (\\(person :& follow) ->+-- person ^. PersonId ==. follow ^. FollowFollowed)+-- \`innerJoin` table \@BlogPost+-- \`on\` (\\((getTable \@Follow -> follow) :& blogPost) ->+-- blogPost ^. BlogPostAuthorId ==. follow ^. FollowFollower)+-- where_ (people1 ^. PersonName ==. val \"John\")+-- pure (followers, people2)+-- @+--+-- This example is a bit trivial, but once you've joined five or six tables it+-- becomes enormously helpful. The above example uses a @ViewPattern@ to call+-- the function and assign the variable directly, but you can also imagine it+-- being written like this:+--+-- @+-- \`on\` (\\(prev :& blogPost) ->+-- let+-- follow = getTable \@Follow prev+-- in+-- blogPost ^. BlogPostAuthorId ==. follow ^. FollowFollower)+-- @+--+-- This function will pluck out the first table that matches the applied type,+-- so if you join on the same table multiple times, it will always select the+-- first one provided.+--+-- The `(:&)` operator associates so that the left hand side can be a wildcard+-- for an arbitrary amount of nesting, and the "most recent" or "newest" table+-- in a join sequence is always available on the rightmost - so @(prev :& bar)@+-- is a pattern that matches @bar@ table (the most recent table added) and+-- @prev@ tables (all prior tables in the join match).+--+-- By calling 'getTable' on the @prev@, you can select exactly the table you+-- want, allowing you to omit a large number of spurious pattern matches.+-- Consider a query that does several @LEFT JOIN@ on a first table:+--+-- @+-- SELECT *+-- FROM person+-- LEFT JOIN car+-- ON person.id = car.person_id+-- LEFT JOIN bike+-- ON person.id = bike.person_id+-- LEFT JOIN food+-- ON person.id = food.person_id+-- LEFT JOIN address+-- ON person.id = address.person_id+-- @+--+-- The final 'on' clause in esqueleto would look like this:+--+-- @+-- \`on\` do+-- \\(person :& _car :& _bike :& _food :& address) ->+-- person.id ==. address.personId+-- @+--+-- First, we can change it to a @prev :& newest@ match. We can do this because+-- of the operator associativity. This is kind of like how a list @:@ operator+-- associates, but in the other direction: @a : (b : c) = a : b : c@.+--+-- @+-- \`on\` do+-- \\(prev :& address) ->+-- let (person :& _car :& _bike :& _food) = prev+-- in person.id ==. address.personId+-- @+--+-- Then, we can use 'getTable' to select the @Person@ table directly, instead of+-- pattern matching manually.+--+-- @+-- \`on\` do+-- \\(prev :& address) ->+-- let person = getTable \@Person prev+-- in person.id ==. address.personId+-- @+--+-- Finally, we can use a @ViewPattern@ language extension to "inline" the+-- access.+--+-- @+-- \`on\` do+-- \\((getTable \@Person -> person) :& address) ->+-- person.id ==. address.personId+-- @+--+-- With this form, you do not need to be concerned about the number and wildcard+-- status of tables that do not matter to the specific @ON@ clause.+--+-- @since 3.5.9.0+getTable :: forall t ts. GetFirstTable (SqlExpr (Entity t)) ts+ => ts+ -> SqlExpr (Entity t)+getTable = getFirstTable++-- | A variant of `getTable` that operates on possibly-null entities.+--+-- @since 3.5.9.0+getTableMaybe :: forall t ts. GetFirstTable (SqlExpr (Maybe (Entity t))) ts+ => ts+ -> SqlExpr (Maybe (Entity t))+getTableMaybe = getFirstTable++------ Compatibility for old syntax++data Lateral+data NotLateral++type family IsLateral a where+ IsLateral (a -> SqlQuery b, c) = Lateral+ IsLateral (a -> SqlQuery b) = Lateral+ IsLateral a = NotLateral++class DoInnerJoin lateral lhs rhs res | lateral rhs lhs -> res where+ doInnerJoin :: Proxy lateral -> lhs -> rhs -> From res++instance ( ToFrom a a'+ , ToFrom b b'+ , HasOnClause rhs (a' :& b')+ , rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool))+ ) => DoInnerJoin NotLateral a rhs (a' :& b') where+ doInnerJoin _ = innerJoin++instance ( ToFrom a a'+ , SqlSelect b r+ , ToAlias b+ , ToAliasReference b+ , d ~ (a' :& b)+ ) => DoInnerJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where+ doInnerJoin _ = innerJoinLateral++instance ( DoInnerJoin lateral lhs rhs r, lateral ~ IsLateral rhs )+ => ToFrom (InnerJoin lhs rhs) r where+ toFrom (InnerJoin a b) = doInnerJoin (Proxy @lateral) a b++class DoLeftJoin lateral lhs rhs res | lateral rhs lhs -> res where+ doLeftJoin :: Proxy lateral -> lhs -> rhs -> From res++instance ( ToFrom a a'+ , ToFrom b b'+ , ToMaybe b'+ , ToMaybeT b' ~ mb+ , HasOnClause rhs (a' :& mb)+ , rhs ~ (b, (a' :& mb) -> SqlExpr (Value Bool))+ ) => DoLeftJoin NotLateral a rhs (a' :& mb) where+ doLeftJoin _ = leftJoin++instance ( ToFrom a a'+ , ToMaybe b+ , d ~ (a' :& ToMaybeT b)+ , SqlSelect b r+ , ToAlias b+ , ToAliasReference b+ ) => DoLeftJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where+ doLeftJoin _ = leftJoinLateral++instance ( DoLeftJoin lateral lhs rhs r, lateral ~ IsLateral rhs )+ => ToFrom (LeftOuterJoin lhs rhs) r where+ toFrom (LeftOuterJoin a b) = doLeftJoin (Proxy @lateral) a b++class DoCrossJoin lateral lhs rhs res | lateral lhs rhs -> res where+ doCrossJoin :: Proxy lateral -> lhs -> rhs -> From res++instance (ToFrom a a', ToFrom b b') => DoCrossJoin NotLateral a b (a' :& b') where+ doCrossJoin _ = crossJoin+instance (ToFrom a a', SqlSelect b r, ToAlias b, ToAliasReference b)+ => DoCrossJoin Lateral a (a' -> SqlQuery b) (a' :& b) where+ doCrossJoin _ = crossJoinLateral++instance (DoCrossJoin lateral lhs rhs r, IsLateral rhs ~ lateral)+ => ToFrom (CrossJoin lhs rhs) r where+ toFrom (CrossJoin a b) = doCrossJoin (Proxy @lateral) a b++instance ( ToFrom a a'+ , ToFrom b b'+ , ToMaybe a'+ , ToMaybeT a' ~ ma+ , HasOnClause rhs (ma :& b')+ , ErrorOnLateral b+ , rhs ~ (b, (ma :& b') -> SqlExpr (Value Bool))+ ) => ToFrom (RightOuterJoin a rhs) (ma :& b') where+ toFrom (RightOuterJoin a b) = rightJoin a b++instance ( ToFrom a a'+ , ToFrom b b'+ , ToMaybe a'+ , ToMaybeT a' ~ ma+ , ToMaybe b'+ , ToMaybeT b' ~ mb+ , HasOnClause rhs (ma :& mb)+ , ErrorOnLateral b+ , rhs ~ (b, (ma :& mb) -> SqlExpr (Value Bool))+ ) => ToFrom (FullOuterJoin a rhs) (ma :& mb) where+ toFrom (FullOuterJoin a b) = fullOuterJoin a b
+ src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Database.Esqueleto.Experimental.From.SqlSetOperation+ where++import Control.Arrow (first)+import Control.Monad.Trans.Class (lift)+import qualified Control.Monad.Trans.State as S+import qualified Control.Monad.Trans.Writer as W+import qualified Data.Text.Lazy.Builder as TLB+import Database.Esqueleto.Experimental.From+import Database.Esqueleto.Experimental.ToAlias+import Database.Esqueleto.Experimental.ToAliasReference+import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)+import Database.Esqueleto.Internal.PersistentImport (PersistValue)++-- | Data type used to implement the SqlSetOperation language+-- this type is implemented in the same way as a @From@+--+-- Semantically a @SqlSetOperation@ is always a @From@ but not vice versa+--+-- @since 3.5.0.0+newtype SqlSetOperation a = SqlSetOperation+ { unSqlSetOperation :: NeedParens -> SqlQuery (a, IdentInfo -> (TLB.Builder, [PersistValue]))}++instance ToAliasReference a => ToFrom (SqlSetOperation a) a where+ toFrom setOperation = From $ do+ ident <- newIdentFor (DBName "u")+ (a, fromClause) <- unSqlSetOperation setOperation Never+ ref <- toAliasReference ident a+ pure (ref, \_ info -> (first parens $ fromClause info) <> (" AS " <> useIdent info ident, mempty))++-- | Type class to support direct use of @SqlQuery@ in a set operation tree+--+-- @since 3.5.0.0+class ToSqlSetOperation a r | a -> r where+ toSqlSetOperation :: a -> SqlSetOperation r+instance ToSqlSetOperation (SqlSetOperation a) a where+ toSqlSetOperation = id+instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToSqlSetOperation (SqlQuery a) a where+ toSqlSetOperation subquery =+ SqlSetOperation $ \p -> do+ (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery+ aliasedValue <- toAlias ret+ let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)+ let p' =+ case p of+ Parens -> Parens+ Never ->+ if (sdLimitClause sideData) /= mempty+ || length (sdOrderByClause sideData) > 0 then+ Parens+ else+ Never+ pure (aliasedValue, \info -> first (parensM p') $ toRawSql SELECT info aliasedQuery)++-- | Helper function for defining set operations+-- @since 3.5.0.0+mkSetOperation :: (ToSqlSetOperation a a', ToSqlSetOperation b a')+ => TLB.Builder -> a -> b -> SqlSetOperation a'+mkSetOperation operation lhs rhs = SqlSetOperation $ \p -> do+ state <- Q $ lift S.get+ (leftValue, leftClause) <- unSqlSetOperation (toSqlSetOperation lhs) p+ Q $ lift $ S.put state+ (_, rightClause) <- unSqlSetOperation (toSqlSetOperation rhs) p+ pure (leftValue, \info -> leftClause info <> (operation, mempty) <> rightClause info)++-- | Overloaded @union_@ function to support use in both 'SqlSetOperation'+-- and 'withRecursive'+--+-- @since 3.5.0.0+class Union_ a where+ -- | @UNION@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.+ union_ :: a++instance (ToSqlSetOperation a c, ToSqlSetOperation b c, res ~ SqlSetOperation c)+ => Union_ (a -> b -> res) where+ union_ = mkSetOperation " UNION "++-- | Overloaded @unionAll_@ function to support use in both 'SqlSetOperation'+-- and 'withRecursive'+--+-- @since 3.5.0.0+class UnionAll_ a where+ -- | @UNION@ @ALL@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.+ unionAll_ :: a+instance (ToSqlSetOperation a c, ToSqlSetOperation b c, res ~ SqlSetOperation c)+ => UnionAll_ (a -> b -> res) where+ unionAll_ = mkSetOperation " UNION ALL "++-- | @EXCEPT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.+except_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a'+except_ = mkSetOperation " EXCEPT "++-- | @INTERSECT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.+intersect_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a'+intersect_ = mkSetOperation " INTERSECT "
+ src/Database/Esqueleto/Experimental/ToAlias.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Esqueleto.Experimental.ToAlias+ where++import Database.Esqueleto.Internal.Internal hiding (From, from, on)+import Database.Esqueleto.Internal.PersistentImport++-- Tedious tuple magic+class ToAlias a where+ toAlias :: a -> SqlQuery a++instance ToAlias (SqlExpr (Value a)) where+ toAlias e@(ERaw m f)+ | Just _ <- sqlExprMetaAlias m = pure e+ | otherwise = do+ ident <- newIdentFor (DBName "v")+ pure $ ERaw noMeta{sqlExprMetaAlias = Just ident} f++instance ToAlias (SqlExpr (Entity a)) where+ toAlias e@(ERaw m f)+ | Just _ <- sqlExprMetaAlias m = pure e+ | otherwise = do+ ident <- newIdentFor (DBName "v")+ pure $ ERaw m{sqlExprMetaIsReference = False, sqlExprMetaAlias = Just ident} f++instance ToAlias (SqlExpr (Maybe (Entity a))) where+ -- FIXME: Code duplication because the compiler doesnt like half final encoding+ toAlias e@(ERaw m f)+ | Just _ <- sqlExprMetaAlias m = pure e+ | otherwise = do+ ident <- newIdentFor (DBName "v")+ pure $ ERaw m{sqlExprMetaIsReference = False, sqlExprMetaAlias = Just ident} f++instance (ToAlias a, ToAlias b) => ToAlias (a,b) where+ toAlias (a,b) = (,) <$> toAlias a <*> toAlias b++instance ( ToAlias a+ , ToAlias b+ , ToAlias c+ ) => ToAlias (a,b,c) where+ toAlias x = to3 <$> (toAlias $ from3 x)++instance ( ToAlias a+ , ToAlias b+ , ToAlias c+ , ToAlias d+ ) => ToAlias (a,b,c,d) where+ toAlias x = to4 <$> (toAlias $ from4 x)++instance ( ToAlias a+ , ToAlias b+ , ToAlias c+ , ToAlias d+ , ToAlias e+ ) => ToAlias (a,b,c,d,e) where+ toAlias x = to5 <$> (toAlias $ from5 x)++instance ( ToAlias a+ , ToAlias b+ , ToAlias c+ , ToAlias d+ , ToAlias e+ , ToAlias f+ ) => ToAlias (a,b,c,d,e,f) where+ toAlias x = to6 <$> (toAlias $ from6 x)++instance ( ToAlias a+ , ToAlias b+ , ToAlias c+ , ToAlias d+ , ToAlias e+ , ToAlias f+ , ToAlias g+ ) => ToAlias (a,b,c,d,e,f,g) where+ toAlias x = to7 <$> (toAlias $ from7 x)++instance ( ToAlias a+ , ToAlias b+ , ToAlias c+ , ToAlias d+ , ToAlias e+ , ToAlias f+ , ToAlias g+ , ToAlias h+ ) => ToAlias (a,b,c,d,e,f,g,h) where+ toAlias x = to8 <$> (toAlias $ from8 x)++instance ( ToAlias a+ , ToAlias b+ , ToAlias c+ , ToAlias d+ , ToAlias e+ , ToAlias f+ , ToAlias g+ , ToAlias h+ , ToAlias i+ ) => ToAlias (a,b,c,d,e,f,g,h,i) where+ toAlias x = to9 <$> (toAlias $ from9 x)++instance ( ToAlias a+ , ToAlias b+ , ToAlias c+ , ToAlias d+ , ToAlias e+ , ToAlias f+ , ToAlias g+ , ToAlias h+ , ToAlias i+ , ToAlias j+ ) => ToAlias (a,b,c,d,e,f,g,h,i,j) where+ toAlias x = to10 <$> (toAlias $ from10 x)++instance ( ToAlias a+ , ToAlias b+ , ToAlias c+ , ToAlias d+ , ToAlias e+ , ToAlias f+ , ToAlias g+ , ToAlias h+ , ToAlias i+ , ToAlias j+ , ToAlias k+ ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k) where+ toAlias x = to11 <$> (toAlias $ from11 x)++instance ( ToAlias a+ , ToAlias b+ , ToAlias c+ , ToAlias d+ , ToAlias e+ , ToAlias f+ , ToAlias g+ , ToAlias h+ , ToAlias i+ , ToAlias j+ , ToAlias k+ , ToAlias l+ ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k,l) where+ toAlias x = to12 <$> (toAlias $ from12 x)++instance ( ToAlias a+ , ToAlias b+ , ToAlias c+ , ToAlias d+ , ToAlias e+ , ToAlias f+ , ToAlias g+ , ToAlias h+ , ToAlias i+ , ToAlias j+ , ToAlias k+ , ToAlias l+ , ToAlias m+ ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k,l,m) where+ toAlias x = to13 <$> (toAlias $ from13 x)++instance ( ToAlias a+ , ToAlias b+ , ToAlias c+ , ToAlias d+ , ToAlias e+ , ToAlias f+ , ToAlias g+ , ToAlias h+ , ToAlias i+ , ToAlias j+ , ToAlias k+ , ToAlias l+ , ToAlias m+ , ToAlias n+ ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where+ toAlias x = to14 <$> (toAlias $ from14 x)++instance ( ToAlias a+ , ToAlias b+ , ToAlias c+ , ToAlias d+ , ToAlias e+ , ToAlias f+ , ToAlias g+ , ToAlias h+ , ToAlias i+ , ToAlias j+ , ToAlias k+ , ToAlias l+ , ToAlias m+ , ToAlias n+ , ToAlias o+ ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where+ toAlias x = to15 <$> (toAlias $ from15 x)++instance ( ToAlias a+ , ToAlias b+ , ToAlias c+ , ToAlias d+ , ToAlias e+ , ToAlias f+ , ToAlias g+ , ToAlias h+ , ToAlias i+ , ToAlias j+ , ToAlias k+ , ToAlias l+ , ToAlias m+ , ToAlias n+ , ToAlias o+ , ToAlias p+ ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where+ toAlias x = to16 <$> (toAlias $ from16 x)
+ src/Database/Esqueleto/Experimental/ToAliasReference.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Esqueleto.Experimental.ToAliasReference+ where++import Database.Esqueleto.Internal.Internal hiding (From, from, on)+import Database.Esqueleto.Internal.PersistentImport++-- more tedious tuple magic+class ToAliasReference a where+ toAliasReference :: Ident -> a -> SqlQuery a++instance ToAliasReference (SqlExpr (Value a)) where+ toAliasReference aliasSource (ERaw m _)+ | Just alias <- sqlExprMetaAlias m = pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info ->+ (useIdent info aliasSource <> "." <> useIdent info alias, [])+ toAliasReference _ e = pure e++instance ToAliasReference (SqlExpr (Entity a)) where+ toAliasReference aliasSource (ERaw m _)+ | Just _ <- sqlExprMetaAlias m =+ pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info ->+ (useIdent info aliasSource, [])+ toAliasReference _ e = pure e++instance ToAliasReference (SqlExpr (Maybe (Entity a))) where+ toAliasReference aliasSource e =+ veryUnsafeCoerceSqlExpr <$> toAliasReference aliasSource (veryUnsafeCoerceSqlExpr e :: SqlExpr (Entity a))+++instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a, b) where+ toAliasReference ident (a,b) = (,) <$> (toAliasReference ident a) <*> (toAliasReference ident b)++instance ( ToAliasReference a+ , ToAliasReference b+ , ToAliasReference c+ ) => ToAliasReference (a,b,c) where+ toAliasReference ident x = fmap to3 $ toAliasReference ident $ from3 x++instance ( ToAliasReference a+ , ToAliasReference b+ , ToAliasReference c+ , ToAliasReference d+ ) => ToAliasReference (a,b,c,d) where+ toAliasReference ident x = fmap to4 $ toAliasReference ident $ from4 x++instance ( ToAliasReference a+ , ToAliasReference b+ , ToAliasReference c+ , ToAliasReference d+ , ToAliasReference e+ ) => ToAliasReference (a,b,c,d,e) where+ toAliasReference ident x = fmap to5 $ toAliasReference ident $ from5 x++instance ( ToAliasReference a+ , ToAliasReference b+ , ToAliasReference c+ , ToAliasReference d+ , ToAliasReference e+ , ToAliasReference f+ ) => ToAliasReference (a,b,c,d,e,f) where+ toAliasReference ident x = to6 <$> (toAliasReference ident $ from6 x)++instance ( ToAliasReference a+ , ToAliasReference b+ , ToAliasReference c+ , ToAliasReference d+ , ToAliasReference e+ , ToAliasReference f+ , ToAliasReference g+ ) => ToAliasReference (a,b,c,d,e,f,g) where+ toAliasReference ident x = to7 <$> (toAliasReference ident $ from7 x)++instance ( ToAliasReference a+ , ToAliasReference b+ , ToAliasReference c+ , ToAliasReference d+ , ToAliasReference e+ , ToAliasReference f+ , ToAliasReference g+ , ToAliasReference h+ ) => ToAliasReference (a,b,c,d,e,f,g,h) where+ toAliasReference ident x = to8 <$> (toAliasReference ident $ from8 x)++instance ( ToAliasReference a+ , ToAliasReference b+ , ToAliasReference c+ , ToAliasReference d+ , ToAliasReference e+ , ToAliasReference f+ , ToAliasReference g+ , ToAliasReference h+ , ToAliasReference i+ ) => ToAliasReference (a,b,c,d,e,f,g,h,i) where+ toAliasReference ident x = to9 <$> (toAliasReference ident $ from9 x)++instance ( ToAliasReference a+ , ToAliasReference b+ , ToAliasReference c+ , ToAliasReference d+ , ToAliasReference e+ , ToAliasReference f+ , ToAliasReference g+ , ToAliasReference h+ , ToAliasReference i+ , ToAliasReference j+ ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j) where+ toAliasReference ident x = to10 <$> (toAliasReference ident $ from10 x)++instance ( ToAliasReference a+ , ToAliasReference b+ , ToAliasReference c+ , ToAliasReference d+ , ToAliasReference e+ , ToAliasReference f+ , ToAliasReference g+ , ToAliasReference h+ , ToAliasReference i+ , ToAliasReference j+ , ToAliasReference k+ ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k) where+ toAliasReference ident x = to11 <$> (toAliasReference ident $ from11 x)++instance ( ToAliasReference a+ , ToAliasReference b+ , ToAliasReference c+ , ToAliasReference d+ , ToAliasReference e+ , ToAliasReference f+ , ToAliasReference g+ , ToAliasReference h+ , ToAliasReference i+ , ToAliasReference j+ , ToAliasReference k+ , ToAliasReference l+ ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l) where+ toAliasReference ident x = to12 <$> (toAliasReference ident $ from12 x)++instance ( ToAliasReference a+ , ToAliasReference b+ , ToAliasReference c+ , ToAliasReference d+ , ToAliasReference e+ , ToAliasReference f+ , ToAliasReference g+ , ToAliasReference h+ , ToAliasReference i+ , ToAliasReference j+ , ToAliasReference k+ , ToAliasReference l+ , ToAliasReference m+ ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m) where+ toAliasReference ident x = to13 <$> (toAliasReference ident $ from13 x)++instance ( ToAliasReference a+ , ToAliasReference b+ , ToAliasReference c+ , ToAliasReference d+ , ToAliasReference e+ , ToAliasReference f+ , ToAliasReference g+ , ToAliasReference h+ , ToAliasReference i+ , ToAliasReference j+ , ToAliasReference k+ , ToAliasReference l+ , ToAliasReference m+ , ToAliasReference n+ ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where+ toAliasReference ident x = to14 <$> (toAliasReference ident $ from14 x)++instance ( ToAliasReference a+ , ToAliasReference b+ , ToAliasReference c+ , ToAliasReference d+ , ToAliasReference e+ , ToAliasReference f+ , ToAliasReference g+ , ToAliasReference h+ , ToAliasReference i+ , ToAliasReference j+ , ToAliasReference k+ , ToAliasReference l+ , ToAliasReference m+ , ToAliasReference n+ , ToAliasReference o+ ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where+ toAliasReference ident x = to15 <$> (toAliasReference ident $ from15 x)++instance ( ToAliasReference a+ , ToAliasReference b+ , ToAliasReference c+ , ToAliasReference d+ , ToAliasReference e+ , ToAliasReference f+ , ToAliasReference g+ , ToAliasReference h+ , ToAliasReference i+ , ToAliasReference j+ , ToAliasReference k+ , ToAliasReference l+ , ToAliasReference m+ , ToAliasReference n+ , ToAliasReference o+ , ToAliasReference p+ ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where+ toAliasReference ident x = to16 <$> (toAliasReference ident $ from16 x)
+ src/Database/Esqueleto/Experimental/ToMaybe.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Esqueleto.Experimental.ToMaybe+ ( module Database.Esqueleto.Experimental.ToMaybe+ , Nullable+ )+ where++import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)+import Database.Esqueleto.Internal.PersistentImport (Entity(..))++class ToMaybe a where+ type ToMaybeT a+ toMaybe :: a -> ToMaybeT a++instance ToMaybe (SqlExpr (Maybe a)) where+ type ToMaybeT (SqlExpr (Maybe a)) = SqlExpr (Maybe a)+ toMaybe = id++instance ToMaybe (SqlExpr (Entity a)) where+ type ToMaybeT (SqlExpr (Entity a)) = SqlExpr (Maybe (Entity a))+ toMaybe (ERaw f m) = (ERaw f m)++instance ToMaybe (SqlExpr (Value a)) where+ type ToMaybeT (SqlExpr (Value a)) = SqlExpr (Value (Maybe (Nullable a)))+ toMaybe = veryUnsafeCoerceSqlExprValue+++instance (ToMaybe a, ToMaybe b) => ToMaybe (a,b) where+ type ToMaybeT (a, b) = (ToMaybeT a, ToMaybeT b)+ toMaybe (a, b) = (toMaybe a, toMaybe b)++instance ( ToMaybe a , ToMaybe b , ToMaybe c) => ToMaybe (a,b,c) where+ type ToMaybeT (a, b, c) = (ToMaybeT a, ToMaybeT b, ToMaybeT c)+ toMaybe = to3 . toMaybe . from3++instance ( ToMaybe a , ToMaybe b , ToMaybe c , ToMaybe d) => ToMaybe (a,b,c,d) where+ type ToMaybeT (a, b, c, d) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d)+ toMaybe = to4 . toMaybe . from4++instance ( ToMaybe a , ToMaybe b , ToMaybe c , ToMaybe d , ToMaybe e) => ToMaybe (a,b,c,d,e) where+ type ToMaybeT (a, b, c, d, e) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e)+ toMaybe = to5 . toMaybe . from5++instance ( ToMaybe a+ , ToMaybe b+ , ToMaybe c+ , ToMaybe d+ , ToMaybe e+ , ToMaybe f+ ) => ToMaybe (a,b,c,d,e,f) where+ type ToMaybeT (a, b, c, d, e, f) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f)+ toMaybe = to6 . toMaybe . from6++instance ( ToMaybe a+ , ToMaybe b+ , ToMaybe c+ , ToMaybe d+ , ToMaybe e+ , ToMaybe f+ , ToMaybe g+ ) => ToMaybe (a,b,c,d,e,f,g) where+ type ToMaybeT (a, b, c, d, e, f, g) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f, ToMaybeT g)+ toMaybe = to7 . toMaybe . from7++instance ( ToMaybe a+ , ToMaybe b+ , ToMaybe c+ , ToMaybe d+ , ToMaybe e+ , ToMaybe f+ , ToMaybe g+ , ToMaybe h+ ) => ToMaybe (a,b,c,d,e,f,g,h) where+ type ToMaybeT (a, b, c, d, e, f, g, h) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f, ToMaybeT g, ToMaybeT h)+ toMaybe = to8 . toMaybe . from8+
src/Database/Esqueleto/Internal/ExprParser.hs view
@@ -1,21 +1,22 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards #-} -- | This is an internal module. This module may have breaking changes without -- a corresponding major version bump. If you use this module, please open an -- issue with your use-case so we can safely support it. module Database.Esqueleto.Internal.ExprParser where -import Prelude hiding (takeWhile)+import Prelude hiding (takeWhile) -import Control.Applicative ((<|>))-import Control.Monad (void)-import Data.Attoparsec.Text-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Text (Text)-import qualified Data.Text as Text-import Database.Persist.Sql+import Control.Applicative ((<|>))+import Control.Monad (void)+import Data.Attoparsec.Text+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import Database.Persist.Sql+import Database.Persist.SqlBackend -- | A type representing the access of a table value. In Esqueleto, we get -- a guarantee that the access will look something like:@@ -26,54 +27,54 @@ -- table name column name -- @ data TableAccess = TableAccess- { tableAccessTable :: Text- , tableAccessColumn :: Text- }- deriving (Eq, Ord, Show)+ { tableAccessTable :: Text+ , tableAccessColumn :: Text+ }+ deriving (Eq, Ord, Show) -- | Parse a @SqlExpr (Value Bool)@'s textual representation into a list of -- 'TableAccess' parseOnExpr :: SqlBackend -> Text -> Either String (Set TableAccess) parseOnExpr sqlBackend text = do- c <- mkEscapeChar sqlBackend- parseOnly (onExpr c) text+ c <- mkEscapeChar sqlBackend+ parseOnly (onExpr c) text -- | This function uses the 'connEscapeName' function in the 'SqlBackend' with an -- empty identifier to pull out an escape character. This implementation works -- with postgresql, mysql, and sqlite backends. mkEscapeChar :: SqlBackend -> Either String Char mkEscapeChar sqlBackend =- case Text.uncons (connEscapeName sqlBackend (DBName "")) of- Nothing ->- Left "Failed to get an escape character from the SQL backend."- Just (c, _) ->- Right c+ case Text.uncons (getEscapedRawName "" sqlBackend) of+ Nothing ->+ Left "Failed to get an escape character from the SQL backend."+ Just (c, _) ->+ Right c type ExprParser a = Char -> Parser a onExpr :: ExprParser (Set TableAccess) onExpr e = Set.fromList <$> many' tableAccesses where- tableAccesses = do- skipToEscape e <?> "Skipping to an escape char"- parseTableAccess e <?> "Parsing a table access"+ tableAccesses = do+ skipToEscape e <?> "Skipping to an escape char"+ parseTableAccess e <?> "Parsing a table access" skipToEscape :: ExprParser () skipToEscape escapeChar = void (takeWhile (/= escapeChar)) parseEscapedIdentifier :: ExprParser [Char] parseEscapedIdentifier escapeChar = do- char escapeChar- str <- parseEscapedChars escapeChar- char escapeChar- pure str+ _ <- char escapeChar+ str <- parseEscapedChars escapeChar+ _ <- char escapeChar+ pure str parseTableAccess :: ExprParser TableAccess parseTableAccess ec = do- tableAccessTable <- Text.pack <$> parseEscapedIdentifier ec- _ <- char '.'- tableAccessColumn <- Text.pack <$> parseEscapedIdentifier ec- pure TableAccess {..}+ tableAccessTable <- Text.pack <$> parseEscapedIdentifier ec+ _ <- char '.'+ tableAccessColumn <- Text.pack <$> parseEscapedIdentifier ec+ pure TableAccess {..} parseEscapedChars :: ExprParser [Char] parseEscapedChars escapeChar = go
src/Database/Esqueleto/Internal/Internal.hs view
@@ -1,3610 +1,4468 @@-{-# LANGUAGE DeriveDataTypeable- , EmptyDataDecls- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , MultiParamTypeClasses- , TypeFamilies- , UndecidableInstances- , GADTs- #-}-{-# LANGUAGE ConstraintKinds- , EmptyDataDecls- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , GADTs- , MultiParamTypeClasses- , OverloadedStrings- , UndecidableInstances- , ScopedTypeVariables- , InstanceSigs- , Rank2Types- , CPP- #-}--- | This is an internal module, anything exported by this module--- may change without a major version bump. Please use only--- "Database.Esqueleto" if possible.------ If you use this module, please report what your use case is on the issue--- tracker so we can safely support it.-module Database.Esqueleto.Internal.Internal where--import Control.Applicative ((<|>))-import Control.Arrow ((***), first)-import Control.Exception (Exception, throw, throwIO)-import qualified Data.Maybe as Maybe-import Control.Monad (guard, ap, MonadPlus(..), void)-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Resource (MonadResource, release)-import Data.Acquire (with, allocateAcquire, Acquire)-import Data.Int (Int64)-import Data.List (intersperse)-#if __GLASGOW_HASKELL__ < 804-import Data.Semigroup-#endif-import qualified Data.Monoid as Monoid-import Data.Proxy (Proxy(..))-import Database.Esqueleto.Internal.PersistentImport-import Database.Persist.Sql.Util (entityColumnNames, entityColumnCount, parseEntityValues, isIdField, hasCompositeKey)-import qualified Data.Set as Set-import Data.Set (Set)-import qualified Control.Monad.Trans.Reader as R-import qualified Control.Monad.Trans.State as S-import qualified Control.Monad.Trans.Writer as W-import qualified Data.ByteString as B-import qualified Data.Conduit as C-import qualified Data.Conduit.List as CL-import qualified Data.HashSet as HS-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TLB--import Data.Typeable (Typeable)-import Text.Blaze.Html (Html)---import Database.Esqueleto.Internal.ExprParser (TableAccess(..), parseOnExpr)---- | (Internal) Start a 'from' query with an entity. 'from'--- does two kinds of magic using 'fromStart', 'fromJoin' and--- 'fromFinish':------ 1. The simple but tedious magic of allowing tuples to be--- used.------ 2. The more advanced magic of creating @JOIN@s. The--- @JOIN@ is processed from right to left. The rightmost--- entity of the @JOIN@ is created with 'fromStart'. Each--- @JOIN@ step is then translated into a call to 'fromJoin'.--- In the end, 'fromFinish' is called to materialize the--- @JOIN@.-fromStart- :: ( PersistEntity a- , BackendCompatible SqlBackend (PersistEntityBackend a) )- => SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Entity a))))-fromStart = x- where- x = do- let ed = entityDef (getVal x)- ident <- newIdentFor (entityDB ed)- let ret = EEntity ident- f' = FromStart ident ed- return (EPreprocessedFrom ret f')- getVal :: SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))) -> Proxy a- getVal = const Proxy---- | (Internal) Same as 'fromStart', but entity may be missing.-fromStartMaybe- :: ( PersistEntity a- , BackendCompatible SqlBackend (PersistEntityBackend a) )- => SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a)))))-fromStartMaybe = maybelize <$> fromStart- where- maybelize :: SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))- -> SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a))))- maybelize (EPreprocessedFrom ret f') = EPreprocessedFrom (EMaybe ret) f'---- | (Internal) Do a @JOIN@.-fromJoin- :: IsJoinKind join- => SqlExpr (PreprocessedFrom a)- -> SqlExpr (PreprocessedFrom b)- -> SqlQuery (SqlExpr (PreprocessedFrom (join a b)))-fromJoin (EPreprocessedFrom lhsRet lhsFrom)- (EPreprocessedFrom rhsRet rhsFrom) = Q $ do- let ret = smartJoin lhsRet rhsRet- from' = FromJoin lhsFrom -- LHS- (reifyJoinKind ret) -- JOIN- rhsFrom -- RHS- Nothing -- ON- return (EPreprocessedFrom ret from')---- | (Internal) Finish a @JOIN@.-fromFinish- :: SqlExpr (PreprocessedFrom a)- -> SqlQuery a-fromFinish (EPreprocessedFrom ret f') = Q $ do- W.tell mempty { sdFromClause = [f'] }- return ret---- | @WHERE@ clause: restrict the query's result.-where_ :: SqlExpr (Value Bool) -> SqlQuery ()-where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr }---- | An @ON@ clause, useful to describe how two tables are related. Cross joins--- and tuple-joins do not need an 'on' clause, but 'InnerJoin' and the various--- outer joins do.------ Note that this function will be replaced by the one in--- "Database.Esqueleto.Experimental" in version 4.0.0.0 of the library. The--- @Experimental@ module has a dramatically improved means for introducing--- tables and entities that provides more power and less potential for runtime--- errors.------ If you don't include an 'on' clause (or include too many!) then a runtime--- exception will be thrown.------ As an example, consider this simple join:------ @--- 'select' $--- 'from' $ \\(foo `'InnerJoin`` bar) -> do--- 'on' (foo '^.' FooId '==.' bar '^.' BarFooId)--- ...--- @------ We need to specify the clause for joining the two columns together. If we had--- this:------ @--- 'select' $--- 'from' $ \\(foo `'CrossJoin`` bar) -> do--- ...--- @------ Then we can safely omit the 'on' clause, because the cross join will make--- pairs of all records possible.------ You can do multiple 'on' clauses in a query. This query joins three tables,--- and has two 'on' clauses:------ @--- 'select' $--- 'from' $ \\(foo `'InnerJoin`` bar `'InnerJoin`` baz) -> do--- 'on' (baz '^.' BazId '==.' bar '^.' BarBazId)--- 'on' (foo '^.' FooId '==.' bar '^.' BarFooId)--- ...--- @------ Old versions of esqueleto required that you provide the 'on' clauses in--- reverse order. This restriction has been lifted - you can now provide 'on'--- clauses in any order, and the SQL should work itself out. The above query is--- now totally equivalent to this:------ @--- 'select' $--- 'from' $ \\(foo `'InnerJoin`` bar `'InnerJoin`` baz) -> do--- 'on' (foo '^.' FooId '==.' bar '^.' BarFooId)--- 'on' (baz '^.' BazId '==.' bar '^.' BarBazId)--- ...--- @-on :: SqlExpr (Value Bool) -> SqlQuery ()-on expr = Q $ W.tell mempty { sdFromClause = [OnClause expr] }---- | @GROUP BY@ clause. You can enclose multiple columns--- in a tuple.------ @--- select $ 'from' \\(foo `'InnerJoin`` bar) -> do--- 'on' (foo '^.' FooBarId '==.' bar '^.' BarId)--- 'groupBy' (bar '^.' BarId, bar '^.' BarName)--- return (bar '^.' BarId, bar '^.' BarName, countRows)--- @------ With groupBy you can sort by aggregate functions, like so--- (we used @let@ to restrict the more general 'countRows' to--- @SqlSqlExpr (Value Int)@ to avoid ambiguity---the second use of--- 'countRows' has its type restricted by the @:: Int@ below):------ @--- r \<- select $ 'from' \\(foo `'InnerJoin`` bar) -> do--- 'on' (foo '^.' FooBarId '==.' bar '^.' BarId)--- 'groupBy' $ bar '^.' BarName--- let countRows' = 'countRows'--- 'orderBy' ['asc' countRows']--- return (bar '^.' BarName, countRows')--- forM_ r $ \\('Value' name, 'Value' count) -> do--- print name--- print (count :: Int)--- @------ === Need more columns?------ The 'ToSomeValues' class is defined for 'SqlExpr' and tuples of 'SqlExpr's.--- We only have definitions for up to 8 elements in a tuple right now, so it's--- possible that you may need to have more than 8 elements.------ For example, consider a query with a 'groupBy' call like this:------ @--- groupBy (e0, e1, e2, e3, e4, e5, e6, e7)--- @------ This is the biggest you can get with a single tuple. However, you can easily--- nest the tuples to add more:------ @--- groupBy ((e0, e1, e2, e3, e4, e5, e6, e7), e8, e9)--- @-groupBy :: (ToSomeValues a) => a -> SqlQuery ()-groupBy expr = Q $ W.tell mempty { sdGroupByClause = GroupBy $ toSomeValues expr }---- | @ORDER BY@ clause. See also 'asc' and 'desc'.------ Multiple calls to 'orderBy' get concatenated on the final--- query, including 'distinctOnOrderBy'.-orderBy :: [SqlExpr OrderBy] -> SqlQuery ()-orderBy exprs = Q $ W.tell mempty { sdOrderByClause = exprs }---- | Ascending order of this field or SqlExpression.-asc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy-asc = EOrderBy ASC---- | Descending order of this field or SqlExpression.-desc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy-desc = EOrderBy DESC---- | @LIMIT@. Limit the number of returned rows.-limit :: Int64 -> SqlQuery ()-limit n = Q $ W.tell mempty { sdLimitClause = Limit (Just n) Nothing }---- | @OFFSET@. Usually used with 'limit'.-offset :: Int64 -> SqlQuery ()-offset n = Q $ W.tell mempty { sdLimitClause = Limit Nothing (Just n) }---- | @DISTINCT@. Change the current @SELECT@ into @SELECT--- DISTINCT@. For example:------ @--- select $ distinct $--- 'from' \\foo -> do--- ...--- @------ Note that this also has the same effect:------ @--- select $--- 'from' \\foo -> do--- distinct (return ())--- ...--- @------ /Since: 2.2.4/-distinct :: SqlQuery a -> SqlQuery a-distinct act = Q (W.tell mempty { sdDistinctClause = DistinctStandard }) >> act---- | @DISTINCT ON@. Change the current @SELECT@ into--- @SELECT DISTINCT ON (SqlExpressions)@. For example:------ @--- select $--- 'from' \\foo ->--- 'distinctOn' ['don' (foo ^. FooName), 'don' (foo ^. FooState)] $ do--- ...--- @------ You can also chain different calls to 'distinctOn'. The--- above is equivalent to:------ @--- select $--- 'from' \\foo ->--- 'distinctOn' ['don' (foo ^. FooName)] $--- 'distinctOn' ['don' (foo ^. FooState)] $ do--- ...--- @------ Each call to 'distinctOn' adds more SqlExpressions. Calls to--- 'distinctOn' override any calls to 'distinct'.------ Note that PostgreSQL requires the SqlExpressions on @DISTINCT--- ON@ to be the first ones to appear on a @ORDER BY@. This is--- not managed automatically by esqueleto, keeping its spirit--- of trying to be close to raw SQL.------ Supported by PostgreSQL only.------ /Since: 2.2.4/-distinctOn :: [SqlExpr DistinctOn] -> SqlQuery a -> SqlQuery a-distinctOn exprs act = Q (W.tell mempty { sdDistinctClause = DistinctOn exprs }) >> act---- | Erase an SqlExpression's type so that it's suitable to--- be used by 'distinctOn'.------ /Since: 2.2.4/-don :: SqlExpr (Value a) -> SqlExpr DistinctOn-don = EDistinctOn---- | A convenience function that calls both 'distinctOn' and--- 'orderBy'. In other words,------ @--- 'distinctOnOrderBy' [asc foo, desc bar, desc quux] $ do--- ...--- @------ is the same as:------ @--- 'distinctOn' [don foo, don bar, don quux] $ do--- 'orderBy' [asc foo, desc bar, desc quux]--- ...--- @------ /Since: 2.2.4/-distinctOnOrderBy :: [SqlExpr OrderBy] -> SqlQuery a -> SqlQuery a-distinctOnOrderBy exprs act =- distinctOn (toDistinctOn <$> exprs) $ do- orderBy exprs- act- where- toDistinctOn :: SqlExpr OrderBy -> SqlExpr DistinctOn- toDistinctOn (EOrderBy _ f) = EDistinctOn f- toDistinctOn EOrderRandom =- error "We can't select distinct by a random order!"---- | @ORDER BY random()@ clause.------ /Since: 1.3.10/-rand :: SqlExpr OrderBy-rand = EOrderRandom---- | @HAVING@.------ /Since: 1.2.2/-having :: SqlExpr (Value Bool) -> SqlQuery ()-having expr = Q $ W.tell mempty { sdHavingClause = Where expr }---- | Add a locking clause to the query. Please read--- 'LockingKind' documentation and your RDBMS manual.------ If multiple calls to 'locking' are made on the same query,--- the last one is used.------ /Since: 2.2.7/-locking :: LockingKind -> SqlQuery ()-locking kind = Q $ W.tell mempty { sdLockingClause = Monoid.Last (Just kind) }--{-#- DEPRECATED- sub_select- "sub_select \n \-sub_select is an unsafe function to use. If used with a SqlQuery that \n \-returns 0 results, then it may return NULL despite not mentioning Maybe \n \-in the return type. If it returns more than 1 result, then it will throw a \n \-SQL error.\n\n Instead, consider using one of the following alternatives: \n \-- subSelect: attaches a LIMIT 1 and the Maybe return type, totally safe. \n \-- subSelectMaybe: Attaches a LIMIT 1, useful for a query that already \n \- has a Maybe in the return type. \n \-- subSelectCount: Performs a count of the query - this is always safe. \n \-- subSelectUnsafe: Performs no checks or guarantees. Safe to use with \n \- countRows and friends."- #-}--- | Execute a subquery @SELECT@ in an SqlExpression. Returns a--- simple value so should be used only when the @SELECT@ query--- is guaranteed to return just one row.------ Deprecated in 3.2.0.-sub_select :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)-sub_select = sub SELECT---- | Execute a subquery @SELECT@ in a 'SqlExpr'. The query passed to this--- function will only return a single result - it has a @LIMIT 1@ passed in to--- the query to make it safe, and the return type is 'Maybe' to indicate that--- the subquery might result in 0 rows.------ If you find yourself writing @'joinV' . 'subSelect'@, then consider using--- 'subSelectMaybe'.------ If you're performing a 'countRows', then you can use 'subSelectCount' which--- is safe.------ If you know that the subquery will always return exactly one row (eg--- a foreign key constraint guarantees that you'll get exactly one row), then--- consider 'subSelectUnsafe', along with a comment explaining why it is safe.------ @since 3.2.0-subSelect- :: PersistField a- => SqlQuery (SqlExpr (Value a))- -> SqlExpr (Value (Maybe a))-subSelect query = just (subSelectUnsafe (query <* limit 1))---- | Execute a subquery @SELECT@ in a 'SqlExpr'. This function is a shorthand--- for the common @'joinV' . 'subSelect'@ idiom, where you are calling--- 'subSelect' on an expression that would be 'Maybe' already.------ As an example, you would use this function when calling 'sum_' or 'max_',--- which have 'Maybe' in the result type (for a 0 row query).------ @since 3.2.0-subSelectMaybe- :: PersistField a- => SqlQuery (SqlExpr (Value (Maybe a)))- -> SqlExpr (Value (Maybe a))-subSelectMaybe = joinV . subSelect---- | Performs a @COUNT@ of the given query in a @subSelect@ manner. This is--- always guaranteed to return a result value, and is completely safe.------ @since 3.2.0-subSelectCount- :: (Num a, PersistField a)- => SqlQuery ignored- -> SqlExpr (Value a)-subSelectCount query = do- subSelectUnsafe $ do- _ <- query- pure countRows---- | Execute a subquery @SELECT@ in a 'SqlExpr' that returns a list. This is an--- alias for 'subList_select' and is provided for symmetry with the other safe--- subselect functions.------ @since 3.2.0-subSelectList- :: PersistField a- => SqlQuery (SqlExpr (Value a))- -> SqlExpr (ValueList a)-subSelectList = subList_select---- | Performs a sub-select using the given foreign key on the entity. This is--- useful to extract values that are known to be present by the database schema.------ As an example, consider the following persistent definition:------ @--- User--- profile ProfileId------ Profile--- name Text--- @------ The following query will return the name of the user.------ @--- getUserWithName =--- 'select' $--- 'from' $ \user ->--- 'pure' (user, 'subSelectForeign' user UserProfile (^. ProfileName)--- @------ @since 3.2.0-subSelectForeign- ::- ( BackendCompatible SqlBackend (PersistEntityBackend val1)- , PersistEntity val1, PersistEntity val2, PersistField a- )- => SqlExpr (Entity val2)- -- ^ An expression representing the table you have access to now.- -> EntityField val2 (Key val1)- -- ^ The foreign key field on the table.- -> (SqlExpr (Entity val1) -> SqlExpr (Value a))- -- ^ A function to extract a value from the foreign reference table.- -> SqlExpr (Value a)-subSelectForeign expr foreignKey k =- subSelectUnsafe $- from $ \table -> do- where_ $ expr ^. foreignKey ==. table ^. persistIdField- pure (k table)---- | Execute a subquery @SELECT@ in a 'SqlExpr'. This function is unsafe,--- because it can throw runtime exceptions in two cases:------ 1. If the query passed has 0 result rows, then it will return a @NULL@ value.--- The @persistent@ parsing operations will fail on an unexpected @NULL@.--- 2. If the query passed returns more than one row, then the SQL engine will--- fail with an error like "More than one row returned by a subquery used as--- an expression".------ This function is safe if you guarantee that exactly one row will be returned,--- or if the result already has a 'Maybe' type for some reason.------ For variants with the safety encoded already, see 'subSelect' and--- 'subSelectMaybe'. For the most common safe use of this, see 'subSelectCount'.------ @since 3.2.0-subSelectUnsafe :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)-subSelectUnsafe = sub SELECT---- | Project a field of an entity.-(^.)- :: forall typ val. (PersistEntity val, PersistField typ)- => SqlExpr (Entity val)- -> EntityField val typ- -> SqlExpr (Value typ)-(EAliasedEntityReference source base) ^. field =- EValueReference source (\_ -> aliasedEntityColumnIdent base fieldDef)- where- fieldDef =- if isIdField field then- -- TODO what about composite natural keys in a join this will ignore them- head $ entityKeyFields ed- else- persistFieldDef field-- ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val)))--e ^. field- | isIdField field = idFieldValue- | otherwise = ERaw Never $ \info -> (dot info $ persistFieldDef field, [])- where- idFieldValue =- case entityKeyFields ed of- idField:[] ->- ERaw Never $ \info -> (dot info idField, [])-- idFields ->- ECompositeKey $ \info -> dot info <$> idFields--- ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val)))-- dot info fieldDef =- useIdent info sourceIdent <> "." <> fieldIdent- where- sourceIdent =- case e of- EEntity ident -> ident- EAliasedEntity baseI _ -> baseI- fieldIdent =- case e of- EEntity _ -> fromDBName info (fieldDB fieldDef)- EAliasedEntity baseI _ -> useIdent info $ aliasedEntityColumnIdent baseI fieldDef---- | Project an SqlExpression that may be null, guarding against null cases.-withNonNull :: PersistField typ- => SqlExpr (Value (Maybe typ))- -> (SqlExpr (Value typ) -> SqlQuery a)- -> SqlQuery a-withNonNull field f = do- where_ $ not_ $ isNothing field- f $ veryUnsafeCoerceSqlExprValue field---- | Project a field of an entity that may be null.-(?.) :: (PersistEntity val, PersistField typ) =>- SqlExpr (Maybe (Entity val)) -> EntityField val typ -> SqlExpr (Value (Maybe typ))-EMaybe r ?. field = just (r ^. field)---- | Lift a constant value from Haskell-land to the query.-val :: PersistField typ => typ -> SqlExpr (Value typ)-val v = ERaw Never $ const ("?", [toPersistValue v])---- | @IS NULL@ comparison.------ For @IS NOT NULL@, you can negate this with 'not_', as in @not_ (isNothing (person ^. PersonAge))@------ Warning: Persistent and Esqueleto have different behavior for @!= Nothing@:------ +----------------+----------------------------------+---------------+--- | | Haskell | SQL |--- +================+==================================+===============+--- | __Persistent__ | @'Database.Persist.!=.' Nothing@ | @IS NOT NULL@ |--- +----------------+----------------------------------+---------------+--- | __Esqueleto__ | @'!=.' Nothing@ | @!= NULL@ |--- +----------------+----------------------------------+---------------+------ In SQL, @= NULL@ and @!= NULL@ return NULL instead of true or false. For this reason, you very likely do not want to use @'!=.' Nothing@ in Esqueleto.--- You may find these @hlint@ rules helpful to enforce this:------ > - error: {lhs: v ==. nothing, rhs: Database.Esqueleto.isNothing v, name: Use Esqueleto's isNothing}--- > - error: {lhs: v ==. val Nothing, rhs: Database.Esqueleto.isNothing v, name: Use Esqueleto's isNothing}--- > - error: {lhs: v !=. nothing, rhs: not_ (Database.Esqueleto.isNothing v), name: Use Esqueleto's not isNothing}--- > - error: {lhs: v !=. val Nothing, rhs: not_ (Database.Esqueleto.isNothing v), name: Use Esqueleto's not isNothing}----isNothing :: PersistField typ => SqlExpr (Value (Maybe typ)) -> SqlExpr (Value Bool)-isNothing v =- case v of- ERaw p f -> isNullExpr $ first (parensM p) . f- EAliasedValue i _ -> isNullExpr $ aliasedValueIdentToRawSql i- EValueReference i i' -> isNullExpr $ valueReferenceToRawSql i i'- ECompositeKey f -> ERaw Parens $ flip (,) [] . (intersperseB " AND " . map (<> " IS NULL")) . f- where- isNullExpr :: (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value Bool)- isNullExpr g = ERaw Parens $ first ((<> " IS NULL")) . g---- | Analogous to 'Just', promotes a value of type @typ@ into--- one of type @Maybe typ@. It should hold that @'val' . Just--- === just . 'val'@.-just :: SqlExpr (Value typ) -> SqlExpr (Value (Maybe typ))-just (ERaw p f) = ERaw p f-just (ECompositeKey f) = ECompositeKey f-just (EAliasedValue i v) = EAliasedValue i (just v)-just (EValueReference i i') = EValueReference i i'---- | @NULL@ value.-nothing :: SqlExpr (Value (Maybe typ))-nothing = unsafeSqlValue "NULL"---- | Join nested 'Maybe's in a 'Value' into one. This is useful when--- calling aggregate functions on nullable fields.-joinV :: SqlExpr (Value (Maybe (Maybe typ))) -> SqlExpr (Value (Maybe typ))-joinV (ERaw p f) = ERaw p f-joinV (ECompositeKey f) = ECompositeKey f-joinV (EAliasedValue i v) = EAliasedValue i (joinV v)-joinV (EValueReference i i') = EValueReference i i'---countHelper :: Num a => TLB.Builder -> TLB.Builder -> SqlExpr (Value typ) -> SqlExpr (Value a)-countHelper open close v =- case v of- ERaw _ f -> countRawSql f- EAliasedValue i _ -> countRawSql $ aliasedValueIdentToRawSql i- EValueReference i i' -> countRawSql $ valueReferenceToRawSql i i'- ECompositeKey _ -> countRows- where- countRawSql :: (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a)- countRawSql x = ERaw Never $ first (\b -> "COUNT" <> open <> parens b <> close) . x---- | @COUNT(*)@ value.-countRows :: Num a => SqlExpr (Value a)-countRows = unsafeSqlValue "COUNT(*)"---- | @COUNT@.-count :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a)-count = countHelper "" ""---- | @COUNT(DISTINCT x)@.------ /Since: 2.4.1/-countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a)-countDistinct = countHelper "(DISTINCT " ")"--not_ :: SqlExpr (Value Bool) -> SqlExpr (Value Bool)-not_ v = ERaw Never (\info -> first ("NOT " <>) $ x info)- where- x info =- case v of- ERaw p f ->- let (b, vals) = f info- in (parensM p b, vals)- ECompositeKey _ -> throw (CompositeKeyErr NotError)- EAliasedValue i _ -> aliasedValueIdentToRawSql i info- EValueReference i i' -> valueReferenceToRawSql i i' info--(==.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)-(==.) = unsafeSqlBinOpComposite " = " " AND "--(>=.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)-(>=.) = unsafeSqlBinOp " >= "--(>.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)-(>.) = unsafeSqlBinOp " > "--(<=.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)-(<=.) = unsafeSqlBinOp " <= "--(<.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)-(<.) = unsafeSqlBinOp " < "-(!=.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)-(!=.) = unsafeSqlBinOpComposite " != " " OR "--(&&.) :: SqlExpr (Value Bool) -> SqlExpr (Value Bool) -> SqlExpr (Value Bool)-(&&.) = unsafeSqlBinOp " AND "--(||.) :: SqlExpr (Value Bool) -> SqlExpr (Value Bool) -> SqlExpr (Value Bool)-(||.) = unsafeSqlBinOp " OR "--(+.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a)-(+.) = unsafeSqlBinOp " + "--(-.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a)-(-.) = unsafeSqlBinOp " - "--(/.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a)-(/.) = unsafeSqlBinOp " / "--(*.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a)-(*.) = unsafeSqlBinOp " * "---- | @BETWEEN@.------ @since: 3.1.0-between :: PersistField a => SqlExpr (Value a) -> (SqlExpr (Value a), SqlExpr (Value a)) -> SqlExpr (Value Bool)-a `between` (b, c) = a >=. b &&. a <=. c--random_ :: (PersistField a, Num a) => SqlExpr (Value a)-random_ = unsafeSqlValue "RANDOM()"--round_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr (Value a) -> SqlExpr (Value b)-round_ = unsafeSqlFunction "ROUND"--ceiling_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr (Value a) -> SqlExpr (Value b)-ceiling_ = unsafeSqlFunction "CEILING"--floor_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr (Value a) -> SqlExpr (Value b)-floor_ = unsafeSqlFunction "FLOOR"--sum_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr (Value (Maybe b))-sum_ = unsafeSqlFunction "SUM"-min_ :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe a))-min_ = unsafeSqlFunction "MIN"-max_ :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe a))-max_ = unsafeSqlFunction "MAX"-avg_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr (Value (Maybe b))-avg_ = unsafeSqlFunction "AVG"---- | Allow a number of one type to be used as one of another--- type via an implicit cast. An explicit cast is not made,--- this function changes only the types on the Haskell side.------ /Caveat/: Trying to use @castNum@ from @Double@ to @Int@--- will not result in an integer, the original fractional--- number will still be used! Use 'round_', 'ceiling_' or--- 'floor_' instead.------ /Safety/: This operation is mostly safe due to the 'Num'--- constraint between the types and the fact that RDBMSs--- usually allow numbers of different types to be used--- interchangeably. However, there may still be issues with--- the query not being accepted by the RDBMS or @persistent@--- not being able to parse it.------ /Since: 2.2.9/-castNum :: (Num a, Num b) => SqlExpr (Value a) -> SqlExpr (Value b)-castNum = veryUnsafeCoerceSqlExprValue---- | Same as 'castNum', but for nullable values.------ /Since: 2.2.9/-castNumM :: (Num a, Num b) => SqlExpr (Value (Maybe a)) -> SqlExpr (Value (Maybe b))-castNumM = veryUnsafeCoerceSqlExprValue---- | @COALESCE@ function. Evaluates the arguments in order and--- returns the value of the first non-NULL SqlExpression, or NULL--- (Nothing) otherwise. Some RDBMSs (such as SQLite) require--- at least two arguments; please refer to the appropriate--- documentation.------ /Since: 1.4.3/-coalesce :: PersistField a => [SqlExpr (Value (Maybe a))] -> SqlExpr (Value (Maybe a))-coalesce = unsafeSqlFunctionParens "COALESCE"---- | Like @coalesce@, but takes a non-nullable SqlExpression--- placed at the end of the SqlExpression list, which guarantees--- a non-NULL result.------ /Since: 1.4.3/-coalesceDefault :: PersistField a => [SqlExpr (Value (Maybe a))] -> SqlExpr (Value a) -> SqlExpr (Value a)-coalesceDefault exprs = unsafeSqlFunctionParens "COALESCE" . (exprs ++) . return . just---- | @LOWER@ function.-lower_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s)-lower_ = unsafeSqlFunction "LOWER"---- | @UPPER@ function.--- /Since: 3.3.0/-upper_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s)-upper_ = unsafeSqlFunction "UPPER"---- | @TRIM@ function.--- /Since: 3.3.0/-trim_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s)-trim_ = unsafeSqlFunction "TRIM"---- | @RTRIM@ function.--- /Since: 3.3.0/-rtrim_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s)-rtrim_ = unsafeSqlFunction "RTRIM"---- | @LTRIM@ function.--- /Since: 3.3.0/-ltrim_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s)-ltrim_ = unsafeSqlFunction "LTRIM"---- | @LENGTH@ function.--- /Since: 3.3.0/-length_ :: (SqlString s, Num a) => SqlExpr (Value s) -> SqlExpr (Value a)-length_ = unsafeSqlFunction "LENGTH"---- | @LEFT@ function.--- /Since: 3.3.0/-left_ :: (SqlString s, Num a) => (SqlExpr (Value s), SqlExpr (Value a)) -> SqlExpr (Value s)-left_ = unsafeSqlFunction "LEFT"---- | @RIGHT@ function.--- /Since: 3.3.0/-right_ :: (SqlString s, Num a) => (SqlExpr (Value s), SqlExpr (Value a)) -> SqlExpr (Value s)-right_ = unsafeSqlFunction "RIGHT"---- | @LIKE@ operator.-like :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value Bool)-like = unsafeSqlBinOp " LIKE "---- | @ILIKE@ operator (case-insensitive @LIKE@).------ Supported by PostgreSQL only.------ /Since: 2.2.3/-ilike :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value Bool)-ilike = unsafeSqlBinOp " ILIKE "---- | The string @'%'@. May be useful while using 'like' and--- concatenation ('concat_' or '++.', depending on your--- database). Note that you always have to type the parenthesis,--- for example:------ @--- name `'like`` (%) ++. 'val' \"John\" ++. (%)--- @-(%) :: SqlString s => SqlExpr (Value s)-(%) = unsafeSqlValue "'%'"---- | The @CONCAT@ function with a variable number of--- parameters. Supported by MySQL and PostgreSQL.-concat_ :: SqlString s => [SqlExpr (Value s)] -> SqlExpr (Value s)-concat_ = unsafeSqlFunction "CONCAT"---- | The @||@ string concatenation operator (named after--- Haskell's '++' in order to avoid naming clash with '||.').--- Supported by SQLite and PostgreSQL.-(++.) :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value s)-(++.) = unsafeSqlBinOp " || "---- | Cast a string type into 'Text'. This function--- is very useful if you want to use @newtype@s, or if you want--- to apply functions such as 'like' to strings of different--- types.------ /Safety:/ This is a slightly unsafe function, especially if--- you have defined your own instances of 'SqlString'. Also,--- since 'Maybe' is an instance of 'SqlString', it's possible--- to turn a nullable value into a non-nullable one. Avoid--- using this function if possible.-castString :: (SqlString s, SqlString r) => SqlExpr (Value s) -> SqlExpr (Value r)-castString = veryUnsafeCoerceSqlExprValue---- | Execute a subquery @SELECT@ in an SqlExpression. Returns a--- list of values.-subList_select :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (ValueList a)-subList_select = EList . sub_select---- | Lift a list of constant value from Haskell-land to the query.-valList :: PersistField typ => [typ] -> SqlExpr (ValueList typ)-valList [] = EEmptyList-valList vals = EList $ ERaw Parens $ const ( uncommas ("?" <$ vals)- , map toPersistValue vals )---- | Same as 'just' but for 'ValueList'. Most of the time you--- won't need it, though, because you can use 'just' from--- inside 'subList_select' or 'Just' from inside 'valList'.------ /Since: 2.2.12/-justList :: SqlExpr (ValueList typ) -> SqlExpr (ValueList (Maybe typ))-justList EEmptyList = EEmptyList-justList (EList v) = EList (just v)---- | @IN@ operator. For example if you want to select all @Person@s by a list--- of IDs:------ @--- SELECT *--- FROM Person--- WHERE Person.id IN (?)--- @------ In @esqueleto@, we may write the same query above as:------ @--- select $--- 'from' $ \\person -> do--- 'where_' $ person '^.' PersonId `'in_`` 'valList' personIds--- return person--- @------ Where @personIds@ is of type @[Key Person]@.-in_ :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (ValueList typ) -> SqlExpr (Value Bool)-v `in_` e = ifNotEmptyList e False $ unsafeSqlBinOp " IN " v (veryUnsafeCoerceSqlExprValueList e)---- | @NOT IN@ operator.-notIn :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (ValueList typ) -> SqlExpr (Value Bool)-v `notIn` e = ifNotEmptyList e True $ unsafeSqlBinOp " NOT IN " v (veryUnsafeCoerceSqlExprValueList e)---- | @EXISTS@ operator. For example:------ @--- select $--- 'from' $ \\person -> do--- 'where_' $ 'exists' $--- 'from' $ \\post -> do--- 'where_' (post '^.' BlogPostAuthorId '==.' person '^.' PersonId)--- return person--- @-exists :: SqlQuery () -> SqlExpr (Value Bool)-exists = unsafeSqlFunction "EXISTS " . existsHelper---- | @NOT EXISTS@ operator.-notExists :: SqlQuery () -> SqlExpr (Value Bool)-notExists = unsafeSqlFunction "NOT EXISTS " . existsHelper---- | @SET@ clause used on @UPDATE@s. Note that while it's not--- a type error to use this function on a @SELECT@, it will--- most certainly result in a runtime error.-set :: PersistEntity val => SqlExpr (Entity val) -> [SqlExpr (Update val)] -> SqlQuery ()-set ent upds = Q $ W.tell mempty { sdSetClause = map apply upds }- where- apply (ESet f) = SetClause (f ent)--(=.) :: (PersistEntity val, PersistField typ) => EntityField val typ -> SqlExpr (Value typ) -> SqlExpr (Update val)-field =. expr = setAux field (const expr)--(+=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> SqlExpr (Update val)-field +=. expr = setAux field (\ent -> ent ^. field +. expr)--(-=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> SqlExpr (Update val)-field -=. expr = setAux field (\ent -> ent ^. field -. expr)--(*=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> SqlExpr (Update val)-field *=. expr = setAux field (\ent -> ent ^. field *. expr)--(/=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> SqlExpr (Update val)-field /=. expr = setAux field (\ent -> ent ^. field /. expr)---- | Apply a 'PersistField' constructor to @SqlExpr Value@ arguments.-(<#) :: (a -> b) -> SqlExpr (Value a) -> SqlExpr (Insertion b)-(<#) _ (ERaw _ f) = EInsert Proxy f-(<#) _ (ECompositeKey _) = throw (CompositeKeyErr ToInsertionError)-(<#) _ (EAliasedValue i _) = EInsert Proxy $ aliasedValueIdentToRawSql i-(<#) _ (EValueReference i i') = EInsert Proxy $ valueReferenceToRawSql i i'----- | Apply extra @SqlExpr Value@ arguments to a 'PersistField' constructor-(<&>) :: SqlExpr (Insertion (a -> b)) -> SqlExpr (Value a) -> SqlExpr (Insertion b)-(EInsert _ f) <&> v = EInsert Proxy $ \x ->- let (fb, fv) = f x- (gb, gv) = g x- in (fb <> ", " <> gb, fv ++ gv)- where- g =- case v of- ERaw _ f' -> f'- EAliasedValue i _ -> aliasedValueIdentToRawSql i- EValueReference i i' -> valueReferenceToRawSql i i'- ECompositeKey _ -> throw (CompositeKeyErr CombineInsertionError)---- | @CASE@ statement. For example:------ @--- select $--- return $--- 'case_'--- [ 'when_'--- ('exists' $--- 'from' $ \\p -> do--- 'where_' (p '^.' PersonName '==.' 'val' \"Mike\"))--- 'then_'--- ('sub_select' $--- 'from' $ \\v -> do--- let sub =--- 'from' $ \\c -> do--- 'where_' (c '^.' PersonName '==.' 'val' \"Mike\")--- return (c '^.' PersonFavNum)--- 'where_' (v '^.' PersonFavNum >. 'sub_select' sub)--- return $ 'count' (v '^.' PersonName) +. 'val' (1 :: Int)) ]--- ('else_' $ 'val' (-1))--- @------ This query is a bit complicated, but basically it checks if a person--- named @\"Mike\"@ exists, and if that person does, run the subquery to find--- out how many people have a ranking (by Fav Num) higher than @\"Mike\"@.------ __NOTE:__ There are a few things to be aware about this statement.------ * This only implements the full CASE statement, it does not--- implement the \"simple\" CASE statement.--------- * At least one 'when_' and 'then_' is mandatory otherwise it will--- emit an error.--------- * The 'else_' is also mandatory, unlike the SQL statement in which--- if the @ELSE@ is omitted it will return a @NULL@. You can--- reproduce this via 'nothing'.------ /Since: 2.1.2/-case_ :: PersistField a => [(SqlExpr (Value Bool), SqlExpr (Value a))] -> SqlExpr (Value a) -> SqlExpr (Value a)-case_ = unsafeSqlCase---- | Convert an entity's key into another entity's.------ This function is to be used when you change an entity's @Id@ to be--- that of another entity. For example:------ @--- Bar--- barNum Int--- Foo--- bar BarId--- fooNum Int--- Primary bar--- @------ In this example, Bar is said to be the BaseEnt(ity), and Foo the child.--- To model this in Esqueleto, declare:------ @--- instance ToBaseId Foo where--- type BaseEnt Foo = Bar--- toBaseIdWitness barId = FooKey barId--- @------ Now you're able to write queries such as:------ @--- 'select' $--- 'from' $ \(bar `'InnerJoin`` foo) -> do--- 'on' ('toBaseId' (foo '^.' FooId) '==.' bar '^.' BarId)--- return (bar, foo)--- @------ Note: this function may be unsafe to use in conditions not like the--- one of the example above.------ /Since: 2.4.3/-toBaseId :: ToBaseId ent => SqlExpr (Value (Key ent)) -> SqlExpr (Value (Key (BaseEnt ent)))-toBaseId = veryUnsafeCoerceSqlExprValue--{-# DEPRECATED random_ "Since 2.6.0: `random_` is not uniform across all databases! Please use a specific one such as 'Database.Esqueleto.PostgreSQL.random_', 'Database.Esqueleto.MySQL.random_', or 'Database.Esqueleto.SQLite.random_'" #-}--{-# DEPRECATED rand "Since 2.6.0: `rand` ordering function is not uniform across all databases! To avoid accidental partiality it will be removed in the next major version." #-}---- Fixity declarations-infixl 9 ^.-infixl 7 *., /.-infixl 6 +., -.-infixr 5 ++.-infix 4 ==., >=., >., <=., <., !=.-infixr 3 &&., =., +=., -=., *=., /=.-infixr 2 ||., `like`, `ilike`-infixl 2 `InnerJoin`, `CrossJoin`, `LeftOuterJoin`, `RightOuterJoin`, `FullOuterJoin`---- | Syntax sugar for 'case_'.------ /Since: 2.1.2/-when_ :: expr (Value Bool) -> () -> expr a -> (expr (Value Bool), expr a)-when_ cond _ expr = (cond, expr)---- | Syntax sugar for 'case_'.------ /Since: 2.1.2/-then_ :: ()-then_ = ()---- | Syntax sugar for 'case_'.------ /Since: 2.1.2/-else_ :: expr a -> expr a-else_ = id----- | A single value (as opposed to a whole entity). You may use--- @('^.')@ or @('?.')@ to get a 'Value' from an 'Entity'.-newtype Value a = Value { unValue :: a } deriving (Eq, Ord, Show, Typeable)----- | /Since: 1.4.4/-instance Functor Value where- fmap f (Value a) = Value (f a)--instance Applicative Value where- (<*>) (Value f) (Value a) = Value (f a)- pure = Value--instance Monad Value where- (>>=) x f = valueJoin $ fmap f x- where valueJoin (Value v) = v---- | A list of single values. There's a limited set of functions--- able to work with this data type (such as 'subList_select',--- 'valList', 'in_' and 'exists').-newtype ValueList a = ValueList a deriving (Eq, Ord, Show, Typeable)----- | A wrapper type for for any @expr (Value a)@ for all a.-data SomeValue where- SomeValue :: SqlExpr (Value a) -> SomeValue---- | A class of things that can be converted into a list of SomeValue. It has--- instances for tuples and is the reason why 'groupBy' can take tuples, like--- @'groupBy' (foo '^.' FooId, foo '^.' FooName, foo '^.' FooType)@.-class ToSomeValues a where- toSomeValues :: a -> [SomeValue]--instance ( ToSomeValues a- , ToSomeValues b- ) => ToSomeValues (a, b) where- toSomeValues (a,b) = toSomeValues a ++ toSomeValues b--instance ( ToSomeValues a- , ToSomeValues b- , ToSomeValues c- ) => ToSomeValues (a, b, c) where- toSomeValues (a,b,c) = toSomeValues a ++ toSomeValues b ++ toSomeValues c--instance ( ToSomeValues a- , ToSomeValues b- , ToSomeValues c- , ToSomeValues d- ) => ToSomeValues (a, b, c, d) where- toSomeValues (a,b,c,d) = toSomeValues a ++ toSomeValues b ++ toSomeValues c ++- toSomeValues d--instance ( ToSomeValues a- , ToSomeValues b- , ToSomeValues c- , ToSomeValues d- , ToSomeValues e- ) => ToSomeValues (a, b, c, d, e) where- toSomeValues (a,b,c,d,e) = toSomeValues a ++ toSomeValues b ++- toSomeValues c ++ toSomeValues d ++ toSomeValues e--instance ( ToSomeValues a- , ToSomeValues b- , ToSomeValues c- , ToSomeValues d- , ToSomeValues e- , ToSomeValues f- ) => ToSomeValues (a, b, c, d, e, f) where- toSomeValues (a,b,c,d,e,f) = toSomeValues a ++ toSomeValues b ++- toSomeValues c ++ toSomeValues d ++ toSomeValues e ++ toSomeValues f--instance ( ToSomeValues a- , ToSomeValues b- , ToSomeValues c- , ToSomeValues d- , ToSomeValues e- , ToSomeValues f- , ToSomeValues g- ) => ToSomeValues (a, b, c, d, e, f, g) where- toSomeValues (a,b,c,d,e,f,g) = toSomeValues a ++ toSomeValues b ++- toSomeValues c ++ toSomeValues d ++ toSomeValues e ++ toSomeValues f ++- toSomeValues g--instance ( ToSomeValues a- , ToSomeValues b- , ToSomeValues c- , ToSomeValues d- , ToSomeValues e- , ToSomeValues f- , ToSomeValues g- , ToSomeValues h- ) => ToSomeValues (a, b, c, d, e, f, g, h) where- toSomeValues (a,b,c,d,e,f,g,h) = toSomeValues a ++ toSomeValues b ++- toSomeValues c ++ toSomeValues d ++ toSomeValues e ++ toSomeValues f ++- toSomeValues g ++ toSomeValues h--type family KnowResult a where- KnowResult (i -> o) = KnowResult o- KnowResult a = a---- | A class for constructors or function which result type is known.------ @since 3.1.3-class FinalResult a where- finalR :: a -> KnowResult a--instance FinalResult (Unique val) where- finalR = id--instance (FinalResult b) => FinalResult (a -> b) where- finalR f = finalR (f undefined)---- | Convert a constructor for a 'Unique' key on a record to the 'UniqueDef' that defines it. You--- can supply just the constructor itself, or a value of the type - the library is capable of figuring--- it out from there.------ @since 3.1.3-toUniqueDef :: forall a val. (KnowResult a ~ (Unique val), PersistEntity val,FinalResult a) =>- a -> UniqueDef-toUniqueDef uniqueConstructor = uniqueDef- where- proxy :: Proxy val- proxy = Proxy- unique :: Unique val- unique = finalR uniqueConstructor- -- there must be a better way to get the constrain name from a unique, make this not a list search- filterF = (==) (persistUniqueToFieldNames unique) . uniqueFields- uniqueDef = head . filter filterF . entityUniques . entityDef $ proxy---- | Render updates to be use in a SET clause for a given sql backend.------ @since 3.1.3-renderUpdates :: (BackendCompatible SqlBackend backend) =>- backend- -> [SqlExpr (Update val)]- -> (TLB.Builder, [PersistValue])-renderUpdates conn = uncommas' . concatMap renderUpdate- where- mk :: SqlExpr (Value ()) -> [(TLB.Builder, [PersistValue])]- mk (ERaw _ f) = [f info]- mk (ECompositeKey _) = throw (CompositeKeyErr MakeSetError) -- FIXME- mk (EAliasedValue i _) = [aliasedValueIdentToRawSql i info]- mk (EValueReference i i') = [valueReferenceToRawSql i i' info]-- renderUpdate :: SqlExpr (Update val) -> [(TLB.Builder, [PersistValue])]- renderUpdate (ESet f) = mk (f undefined) -- second parameter of f is always unused- info = (projectBackend conn, initialIdentState)---- | Data type that represents an @INNER JOIN@ (see 'LeftOuterJoin' for an example).-data InnerJoin a b = a `InnerJoin` b---- | Data type that represents a @CROSS JOIN@ (see 'LeftOuterJoin' for an example).-data CrossJoin a b = a `CrossJoin` b---- | Data type that represents a @LEFT OUTER JOIN@. For example,------ @--- select $--- 'from' $ \\(person `'LeftOuterJoin`` pet) ->--- ...--- @------ is translated into------ @--- SELECT ...--- FROM Person LEFT OUTER JOIN Pet--- ...--- @------ See also: 'from'.-data LeftOuterJoin a b = a `LeftOuterJoin` b---- | Data type that represents a @RIGHT OUTER JOIN@ (see 'LeftOuterJoin' for an example).-data RightOuterJoin a b = a `RightOuterJoin` b---- | Data type that represents a @FULL OUTER JOIN@ (see 'LeftOuterJoin' for an example).-data FullOuterJoin a b = a `FullOuterJoin` b----- | (Internal) A kind of @JOIN@.-data JoinKind =- InnerJoinKind -- ^ @INNER JOIN@- | CrossJoinKind -- ^ @CROSS JOIN@- | LeftOuterJoinKind -- ^ @LEFT OUTER JOIN@- | RightOuterJoinKind -- ^ @RIGHT OUTER JOIN@- | FullOuterJoinKind -- ^ @FULL OUTER JOIN@- deriving (Eq, Show)----- | (Internal) Functions that operate on types (that should be)--- of kind 'JoinKind'.-class IsJoinKind join where- -- | (Internal) @smartJoin a b@ is a @JOIN@ of the correct kind.- smartJoin :: a -> b -> join a b- -- | (Internal) Reify a @JoinKind@ from a @JOIN@. This- -- function is non-strict.- reifyJoinKind :: join a b -> JoinKind--instance IsJoinKind InnerJoin where- smartJoin a b = a `InnerJoin` b- reifyJoinKind _ = InnerJoinKind-instance IsJoinKind CrossJoin where- smartJoin a b = a `CrossJoin` b- reifyJoinKind _ = CrossJoinKind-instance IsJoinKind LeftOuterJoin where- smartJoin a b = a `LeftOuterJoin` b- reifyJoinKind _ = LeftOuterJoinKind-instance IsJoinKind RightOuterJoin where- smartJoin a b = a `RightOuterJoin` b- reifyJoinKind _ = RightOuterJoinKind-instance IsJoinKind FullOuterJoin where- smartJoin a b = a `FullOuterJoin` b- reifyJoinKind _ = FullOuterJoinKind----- | Exception thrown whenever 'on' is used to create an @ON@--- clause but no matching @JOIN@ is found.-data OnClauseWithoutMatchingJoinException =- OnClauseWithoutMatchingJoinException String- deriving (Eq, Ord, Show, Typeable)-instance Exception OnClauseWithoutMatchingJoinException where---- | (Internal) Phantom type used to process 'from' (see 'fromStart').-data PreprocessedFrom a------- | Phantom type used by 'orderBy', 'asc' and 'desc'.-data OrderBy----- | Phantom type used by 'distinctOn' and 'don'.-data DistinctOn----- | Phantom type for a @SET@ operation on an entity of the given--- type (see 'set' and '(=.)').-data Update typ----- | Phantom type used by 'insertSelect'.-data Insertion a----- | Different kinds of locking clauses supported by 'locking'.------ Note that each RDBMS has different locking support. The--- constructors of this datatype specify only the /syntax/ of the--- locking mechanism, not its /semantics/. For example, even--- though both MySQL and PostgreSQL support 'ForUpdate', there--- are no guarantees that they will behave the same.------ /Since: 2.2.7/-data LockingKind =- ForUpdate- -- ^ @FOR UPDATE@ syntax. Supported by MySQL, Oracle and- -- PostgreSQL.- --- -- /Since: 2.2.7/- | ForUpdateSkipLocked- -- ^ @FOR UPDATE SKIP LOCKED@ syntax. Supported by MySQL, Oracle and- -- PostgreSQL.- --- -- /Since: 2.2.7/- | ForShare- -- ^ @FOR SHARE@ syntax. Supported by PostgreSQL.- --- -- /Since: 2.2.7/- | LockInShareMode- -- ^ @LOCK IN SHARE MODE@ syntax. Supported by MySQL.- --- -- /Since: 2.2.7/----- | Phantom class of data types that are treated as strings by the--- RDBMS. It has no methods because it's only used to avoid type--- errors such as trying to concatenate integers.------ If you have a custom data type or @newtype@, feel free to make--- it an instance of this class.------ /Since: 2.4.0/-class PersistField a => SqlString a where---- | /Since: 2.3.0/-instance (a ~ Char) => SqlString [a] where---- | /Since: 2.3.0/-instance SqlString T.Text where---- | /Since: 2.3.0/-instance SqlString TL.Text where---- | /Since: 2.3.0/-instance SqlString B.ByteString where---- | /Since: 2.3.0/-instance SqlString Html where---- | /Since: 2.4.0/-instance SqlString a => SqlString (Maybe a) where---- | Class that enables one to use 'toBaseId' to convert an entity's--- key on a query into another (cf. 'toBaseId').-class ToBaseId ent where- -- | e.g. @type BaseEnt MyBase = MyChild@- type BaseEnt ent :: *- -- | Convert from the key of the BaseEnt(ity) to the key of the child entity.- -- This function is not actually called, but that it typechecks proves this operation is safe.- toBaseIdWitness :: Key (BaseEnt ent) -> Key ent----- | @FROM@ clause: bring entities into scope.------ Note that this function will be replaced by the one in--- "Database.Esqueleto.Experimental" in version 4.0.0.0 of the library. The--- @Experimental@ module has a dramatically improved means for introducing--- tables and entities that provides more power and less potential for runtime--- errors.------ This function internally uses two type classes in order to--- provide some flexibility of how you may call it. Internally--- we refer to these type classes as the two different magics.------ The innermost magic allows you to use @from@ with the--- following types:------ * @expr (Entity val)@, which brings a single entity into--- scope.------ * @expr (Maybe (Entity val))@, which brings a single entity--- that may be @NULL@ into scope. Used for @OUTER JOIN@s.------ * A @JOIN@ of any other two types allowed by the innermost--- magic, where a @JOIN@ may be an 'InnerJoin', a 'CrossJoin', a--- 'LeftOuterJoin', a 'RightOuterJoin', or a 'FullOuterJoin'.--- The @JOINs@ have left fixity.------ The outermost magic allows you to use @from@ on any tuples of--- types supported by innermost magic (and also tuples of tuples,--- and so on), up to 8-tuples.------ Note that using @from@ for the same entity twice does work and--- corresponds to a self-join. You don't even need to use two--- different calls to @from@, you may use a @JOIN@ or a tuple.------ The following are valid examples of uses of @from@ (the types--- of the arguments of the lambda are inside square brackets):------ @--- 'from' $ \\person -> ...--- 'from' $ \\(person, blogPost) -> ...--- 'from' $ \\(p `'LeftOuterJoin`` mb) -> ...--- 'from' $ \\(p1 `'InnerJoin`` f `'InnerJoin`` p2) -> ...--- 'from' $ \\((p1 `'InnerJoin`` f) `'InnerJoin`` p2) -> ...--- @------ The types of the arguments to the lambdas above are,--- respectively:------ @--- person--- :: ( Esqueleto query expr backend--- , PersistEntity Person--- , PersistEntityBackend Person ~ backend--- ) => expr (Entity Person)--- (person, blogPost)--- :: (...) => (expr (Entity Person), expr (Entity BlogPost))--- (p `'LeftOuterJoin`` mb)--- :: (...) => InnerJoin (expr (Entity Person)) (expr (Maybe (Entity BlogPost)))--- (p1 `'InnerJoin`` f `'InnerJoin`` p2)--- :: (...) => InnerJoin--- (InnerJoin (expr (Entity Person))--- (expr (Entity Follow)))--- (expr (Entity Person))--- (p1 `'InnerJoin`` (f `'InnerJoin`` p2)) ::--- :: (...) => InnerJoin--- (expr (Entity Person))--- (InnerJoin (expr (Entity Follow))--- (expr (Entity Person)))--- @------ Note that some backends may not support all kinds of @JOIN@s.-from :: From a => (a -> SqlQuery b) -> SqlQuery b-from = (from_ >>=)----- | (Internal) Class that implements the tuple 'from' magic (see--- 'fromStart').-class From a where- from_ :: SqlQuery a--instance ( FromPreprocess (SqlExpr (Entity val))- ) => From (SqlExpr (Entity val)) where- from_ = fromPreprocess >>= fromFinish--instance ( FromPreprocess (SqlExpr (Maybe (Entity val)))- ) => From (SqlExpr (Maybe (Entity val))) where- from_ = fromPreprocess >>= fromFinish--instance ( FromPreprocess (InnerJoin a b)- ) => From (InnerJoin a b) where- from_ = fromPreprocess >>= fromFinish--instance ( FromPreprocess (CrossJoin a b)- ) => From (CrossJoin a b) where- from_ = fromPreprocess >>= fromFinish--instance ( FromPreprocess (LeftOuterJoin a b)- ) => From (LeftOuterJoin a b) where- from_ = fromPreprocess >>= fromFinish--instance ( FromPreprocess (RightOuterJoin a b)- ) => From (RightOuterJoin a b) where- from_ = fromPreprocess >>= fromFinish--instance ( FromPreprocess (FullOuterJoin a b)- ) => From (FullOuterJoin a b) where- from_ = fromPreprocess >>= fromFinish--instance ( From a- , From b- ) => From (a, b) where- from_ = (,) <$> from_ <*> from_--instance ( From a- , From b- , From c- ) => From (a, b, c) where- from_ = (,,) <$> from_ <*> from_ <*> from_--instance ( From a- , From b- , From c- , From d- ) => From (a, b, c, d) where- from_ = (,,,) <$> from_ <*> from_ <*> from_ <*> from_--instance ( From a- , From b- , From c- , From d- , From e- ) => From (a, b, c, d, e) where- from_ = (,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_--instance ( From a- , From b- , From c- , From d- , From e- , From f- ) => From (a, b, c, d, e, f) where- from_ = (,,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_--instance ( From a- , From b- , From c- , From d- , From e- , From f- , From g- ) => From (a, b, c, d, e, f, g) where- from_ = (,,,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_--instance ( From a- , From b- , From c- , From d- , From e- , From f- , From g- , From h- ) => From (a, b, c, d, e, f, g, h) where- from_ = (,,,,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_------ | (Internal) Class that implements the @JOIN@ 'from' magic--- (see 'fromStart').-class FromPreprocess a where- fromPreprocess :: SqlQuery (SqlExpr (PreprocessedFrom a))--instance ( PersistEntity val- , BackendCompatible SqlBackend (PersistEntityBackend val)- ) => FromPreprocess (SqlExpr (Entity val)) where- fromPreprocess = fromStart--instance ( PersistEntity val- , BackendCompatible SqlBackend (PersistEntityBackend val)- ) => FromPreprocess (SqlExpr (Maybe (Entity val))) where- fromPreprocess = fromStartMaybe--instance ( FromPreprocess a- , FromPreprocess b- , IsJoinKind join- ) => FromPreprocess (join a b) where- fromPreprocess = do- a <- fromPreprocess- b <- fromPreprocess- fromJoin a b---- | Exception data type for @esqueleto@ internal errors-data EsqueletoError =- CompositeKeyErr CompositeKeyError- | AliasedValueErr UnexpectedValueError- | UnexpectedCaseErr UnexpectedCaseError- | SqlBinOpCompositeErr SqlBinOpCompositeError- deriving (Show)--instance Exception EsqueletoError--data UnexpectedValueError =- NotError- | ToInsertionError- | CombineInsertionError- | FoldHelpError- | SqlCaseError- | SqlCastAsError- | SqlFunctionError- | MakeOnClauseError- | MakeExcError- | MakeSetError- | MakeWhereError- | MakeHavingError- | FilterWhereAggError- | FilterWhereClauseError- deriving (Show)--type CompositeKeyError = UnexpectedValueError--data UnexpectedCaseError =- EmptySqlExprValueList- | MakeFromError- | UnsupportedSqlInsertIntoType- | InsertionFinalError- | NewIdentForError- | UnsafeSqlCaseError- | OperationNotSupported- | NotImplemented- deriving (Show)--data SqlBinOpCompositeError =- MismatchingLengthsError- | NullPlaceholdersError- | DeconstructionError- deriving (Show)------ | SQL backend for @esqueleto@ using 'SqlPersistT'.-newtype SqlQuery a =- Q { unQ :: W.WriterT SideData (S.State IdentState) a }--instance Functor SqlQuery where- fmap f = Q . fmap f . unQ--instance Monad SqlQuery where- return = Q . return- m >>= f = Q (unQ m >>= unQ . f)--instance Applicative SqlQuery where- pure = return- (<*>) = ap----- | Constraint synonym for @persistent@ entities whose backend--- is 'SqlPersistT'.-type SqlEntity ent = (PersistEntity ent, PersistEntityBackend ent ~ SqlBackend)------------------------------------------------------------------------------ | Side data written by 'SqlQuery'.-data SideData = SideData { sdDistinctClause :: !DistinctClause- , sdFromClause :: ![FromClause]- , sdSetClause :: ![SetClause]- , sdWhereClause :: !WhereClause- , sdGroupByClause :: !GroupByClause- , sdHavingClause :: !HavingClause- , sdOrderByClause :: ![OrderByClause]- , sdLimitClause :: !LimitClause- , sdLockingClause :: !LockingClause- }--instance Semigroup SideData where- SideData d f s w g h o l k <> SideData d' f' s' w' g' h' o' l' k' =- SideData (d <> d') (f <> f') (s <> s') (w <> w') (g <> g') (h <> h') (o <> o') (l <> l') (k <> k')--instance Monoid SideData where- mempty = SideData mempty mempty mempty mempty mempty mempty mempty mempty mempty- mappend = (<>)---- | The @DISTINCT@ "clause".-data DistinctClause =- DistinctAll -- ^ The default, everything.- | DistinctStandard -- ^ Only @DISTINCT@, SQL standard.- | DistinctOn [SqlExpr DistinctOn] -- ^ @DISTINCT ON@, PostgreSQL extension.--instance Semigroup DistinctClause where- DistinctOn a <> DistinctOn b = DistinctOn (a <> b)- DistinctOn a <> _ = DistinctOn a- DistinctStandard <> _ = DistinctStandard- DistinctAll <> b = b--instance Monoid DistinctClause where- mempty = DistinctAll- mappend = (<>)---- | A part of a @FROM@ clause.-data FromClause =- FromStart Ident EntityDef- | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool)))- | OnClause (SqlExpr (Value Bool))- | FromQuery Ident (IdentInfo -> (TLB.Builder, [PersistValue]))--collectIdents :: FromClause -> Set Ident-collectIdents fc = case fc of- FromStart i _ -> Set.singleton i- FromJoin lhs _ rhs _ -> collectIdents lhs <> collectIdents rhs- OnClause _ -> mempty- FromQuery _ _ -> mempty--instance Show FromClause where- show fc = case fc of- FromStart i _ ->- "(FromStart " <> show i <> ")"- FromJoin lhs jk rhs mexpr ->- mconcat- [ "(FromJoin "- , show lhs- , " "- , show jk- , " "- , case mexpr of- Nothing -> "(no on clause)"- Just expr -> "(" <> render' expr <> ")"- , " "- , show rhs- , ")"- ]- OnClause expr ->- "(OnClause " <> render' expr <> ")"- FromQuery ident _->- "(FromQuery " <> show ident <> ")"--- where- dummy = SqlBackend- { connEscapeName = \(DBName x) -> x- }- render' = T.unpack . renderExpr dummy----- | A part of a @SET@ clause.-newtype SetClause = SetClause (SqlExpr (Value ()))----- | Collect 'OnClause's on 'FromJoin's. Returns the first--- unmatched 'OnClause's data on error. Returns a list without--- 'OnClauses' on success.-collectOnClauses- :: SqlBackend- -> [FromClause]- -> Either (SqlExpr (Value Bool)) [FromClause]-collectOnClauses sqlBackend = go Set.empty []- -- . (\fc -> Debug.trace ("From Clauses: " <> show fc) fc)- where- go is [] (f@(FromStart i _) : fs) =- fmap (f:) (go (Set.insert i is) [] fs) -- fast path- go idents acc (OnClause expr : fs) = do- (idents', a) <- findMatching idents acc expr- go idents' a fs- go idents acc (f:fs) =- go idents (f:acc) fs- go _ acc [] =- return $ reverse acc-- findMatching- :: Set Ident- -> [FromClause]- -> SqlExpr (Value Bool)- -> Either (SqlExpr (Value Bool)) (Set Ident, [FromClause])- findMatching idents fromClauses expr =- -- Debug.trace ("From Clause: " <> show fromClauses) $- case fromClauses of- f : acc ->- let- idents' =- idents- <> Set.fromList (Maybe.catMaybes [findLeftmostIdent f, findRightmostIdent f])- in- case tryMatch idents' expr f of- Just (idents'', f') ->- return (idents'', f' : acc)- Nothing ->- fmap (f:) <$> findMatching idents' acc expr- [] ->- Left expr-- findRightmostIdent (FromStart i _) = Just i- findRightmostIdent (FromJoin _ _ r _) = findRightmostIdent r- findRightmostIdent (OnClause {}) = Nothing- findRightmostIdent (FromQuery _ _) = Nothing-- findLeftmostIdent (FromStart i _) = Just i- findLeftmostIdent (FromJoin l _ _ _) = findLeftmostIdent l- findLeftmostIdent (OnClause {}) = Nothing- findLeftmostIdent (FromQuery _ _) = Nothing-- tryMatch- :: Set Ident- -> SqlExpr (Value Bool)- -> FromClause- -> Maybe (Set Ident, FromClause)- tryMatch idents expr fromClause =- case fromClause of- FromJoin l k r onClause ->- matchTable <|> matchR <|> matchC <|> matchL <|> matchPartial -- right to left- where- matchR = fmap (\r' -> FromJoin l k r' onClause)- <$> tryMatch idents expr r- matchL = fmap (\l' -> FromJoin l' k r onClause)- <$> tryMatch idents expr l-- matchPartial = do- --Debug.traceM $ "matchPartial"- --Debug.traceM $ "matchPartial: identsInOnClause: " <> show identsInOnClause- i1 <- findLeftmostIdent l- i2 <- findLeftmostIdent r- let leftIdents = collectIdents l- -- Debug.traceM $ "matchPartial: i1: " <> show i1- -- Debug.traceM $ "matchPartial: i2: " <> show i2- -- Debug.traceM $ "matchPartial: idents: " <> show idents- guard $- Set.isSubsetOf- identsInOnClause- (Set.fromList [i1, i2] <> leftIdents)- guard $ k /= CrossJoinKind- guard $ Maybe.isNothing onClause- pure (idents, FromJoin l k r (Just expr))-- matchC =- case onClause of- Nothing- | "?" `T.isInfixOf` renderedExpr ->- return (idents, FromJoin l k r (Just expr))- | Set.null identsInOnClause ->- return (idents, FromJoin l k r (Just expr))- | otherwise ->- Nothing- Just _ ->- Nothing- matchTable = do- i1 <- findLeftmostIdent r- i2 <- findRightmostIdent l- guard $ Set.fromList [i1, i2] `Set.isSubsetOf` identsInOnClause- guard $ k /= CrossJoinKind- guard $ Maybe.isNothing onClause- pure (Set.fromList [i1, i2] <> idents, FromJoin l k r (Just expr))-- _ ->- Nothing- where- identsInOnClause =- onExprToTableIdentifiers-- renderedExpr =- renderExpr sqlBackend expr-- onExprToTableIdentifiers =- Set.map (I . tableAccessTable)- . either error id- . parseOnExpr sqlBackend- $ renderedExpr---- | A complete @WHERE@ clause.-data WhereClause = Where (SqlExpr (Value Bool))- | NoWhere--instance Semigroup WhereClause where- NoWhere <> w = w- w <> NoWhere = w- Where e1 <> Where e2 = Where (e1 &&. e2)--instance Monoid WhereClause where- mempty = NoWhere- mappend = (<>)---- | A @GROUP BY@ clause.-newtype GroupByClause = GroupBy [SomeValue]--instance Semigroup GroupByClause where- GroupBy fs <> GroupBy fs' = GroupBy (fs <> fs')--instance Monoid GroupByClause where- mempty = GroupBy []- mappend = (<>)---- | A @HAVING@ cause.-type HavingClause = WhereClause---- | A @ORDER BY@ clause.-type OrderByClause = SqlExpr OrderBy----- | A @LIMIT@ clause.-data LimitClause = Limit (Maybe Int64) (Maybe Int64)- deriving Eq--instance Semigroup LimitClause where- Limit l1 o1 <> Limit l2 o2 =- Limit (l2 `mplus` l1) (o2 `mplus` o1)- -- More than one 'limit' or 'offset' is issued, we want to- -- keep the latest one. That's why we use mplus with- -- "reversed" arguments.--instance Monoid LimitClause where- mempty = Limit mzero mzero- mappend = (<>)---- | A locking clause.-type LockingClause = Monoid.Last LockingKind------------------------------------------------------------------------------ | Identifier used for table names.-newtype Ident = I T.Text- deriving (Eq, Ord, Show)----- | List of identifiers already in use and supply of temporary--- identifiers.-newtype IdentState = IdentState { inUse :: HS.HashSet T.Text }--initialIdentState :: IdentState-initialIdentState = IdentState mempty----- | Create a fresh 'Ident'. If possible, use the given--- 'DBName'.-newIdentFor :: DBName -> SqlQuery Ident-newIdentFor (DBName original) = Q $ lift $ findFree Nothing- where- findFree msuffix = do- let- withSuffix =- maybe id (\suffix -> (<> T.pack (show suffix))) msuffix original- isInUse <- S.gets (HS.member withSuffix . inUse)- if isInUse- then findFree (succ <$> (msuffix <|> Just (1 :: Int)))- else do- S.modify (\s -> s { inUse = HS.insert withSuffix (inUse s) })- pure (I withSuffix)---- | Information needed to escape and use identifiers.-type IdentInfo = (SqlBackend, IdentState)----- | Use an identifier.-useIdent :: IdentInfo -> Ident -> TLB.Builder-useIdent info (I ident) = fromDBName info $ DBName ident------- | An expression on the SQL backend.------ There are many comments describing the constructors of this--- data type. However, Haddock doesn't like GADTs, so you'll have to read them by hitting \"Source\".-data SqlExpr a where- -- An entity, created by 'from' (cf. 'fromStart').- EEntity :: Ident -> SqlExpr (Entity val)- -- Base Table- EAliasedEntity :: Ident -> Ident -> SqlExpr (Entity val)- -- Source Base- EAliasedEntityReference :: Ident -> Ident -> SqlExpr (Entity val)-- -- Just a tag stating that something is nullable.- EMaybe :: SqlExpr a -> SqlExpr (Maybe a)-- -- Raw expression: states whether parenthesis are needed- -- around this expression, and takes information about the SQL- -- connection (mainly for escaping names) and returns both an- -- string ('TLB.Builder') and a list of values to be- -- interpolated by the SQL backend.- ERaw :: NeedParens -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a)--- -- A raw expression with an alias- EAliasedValue :: Ident -> SqlExpr (Value a) -> SqlExpr (Value a)-- -- A reference to an aliased field in a table or subquery- EValueReference :: Ident -> (IdentInfo -> Ident) -> SqlExpr (Value a)-- -- A composite key.- --- -- Persistent uses the same 'PersistList' constructor for both- -- fields which are (homogeneous) lists of values and the- -- (probably heterogeneous) values of a composite primary key.- --- -- We need to treat composite keys as fields. For example, we- -- have to support using ==., otherwise you wouldn't be able to- -- join. OTOH, lists of values should be treated exactly the- -- same as any other scalar value.- --- -- In particular, this is valid for persistent via rawSql for- -- an F field that is a list:- --- -- A.F in ? -- [PersistList [foo, bar]]- --- -- However, this is not for a composite key entity:- --- -- A.ID = ? -- [PersistList [foo, bar]]- --- -- The ID field doesn't exist on the DB for a composite key- -- table, it exists only on the Haskell side. Those variations- -- also don't work:- --- -- (A.KeyA, A.KeyB) = ? -- [PersistList [foo, bar]]- -- [A.KeyA, A.KeyB] = ? -- [PersistList [foo, bar]]- --- -- We have to generate:- --- -- A.KeyA = ? AND A.KeyB = ? -- [foo, bar]- --- -- Note that the PersistList had to be deconstructed into its- -- components.- --- -- In order to disambiguate behaviors, this constructor is used- -- /only/ to represent a composite field access. It does not- -- represent a 'PersistList', not even if the 'PersistList' is- -- used in the context of a composite key. That's because it's- -- impossible, e.g., for 'val' to disambiguate between these- -- uses.- ECompositeKey :: (IdentInfo -> [TLB.Builder]) -> SqlExpr (Value a)-- -- 'EList' and 'EEmptyList' are used by list operators.- EList :: SqlExpr (Value a) -> SqlExpr (ValueList a)- EEmptyList :: SqlExpr (ValueList a)-- -- A 'SqlExpr' accepted only by 'orderBy'.- EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy-- EOrderRandom :: SqlExpr OrderBy-- -- A 'SqlExpr' accepted only by 'distinctOn'.- EDistinctOn :: SqlExpr (Value a) -> SqlExpr DistinctOn-- -- A 'SqlExpr' accepted only by 'set'.- ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val)-- -- An internal 'SqlExpr' used by the 'from' hack.- EPreprocessedFrom :: a -> FromClause -> SqlExpr (PreprocessedFrom a)-- -- Used by 'insertSelect'.- EInsert :: Proxy a -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Insertion a)- EInsertFinal :: PersistEntity a => SqlExpr (Insertion a) -> SqlExpr InsertFinal---- | Phantom type used to mark a @INSERT INTO@ query.-data InsertFinal--data NeedParens = Parens | Never- deriving Eq--parensM :: NeedParens -> TLB.Builder -> TLB.Builder-parensM Never = id-parensM Parens = parens--data OrderByType = ASC | DESC---instance ToSomeValues (SqlExpr (Value a)) where- toSomeValues a = [SomeValue a]--fieldName :: (PersistEntity val, PersistField typ)- => IdentInfo -> EntityField val typ -> TLB.Builder-fieldName info = fromDBName info . fieldDB . persistFieldDef---- FIXME: Composite/non-id pKS not supported on set-setAux :: (PersistEntity val, PersistField typ)- => EntityField val typ- -> (SqlExpr (Entity val) -> SqlExpr (Value typ))- -> SqlExpr (Update val)-setAux field mkVal = ESet $ \ent -> unsafeSqlBinOp " = " name (mkVal ent)- where name = ERaw Never $ \info -> (fieldName info field, mempty)--sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)-sub mode query = ERaw Parens $ \info -> toRawSql mode info query--fromDBName :: IdentInfo -> DBName -> TLB.Builder-fromDBName (conn, _) = TLB.fromText . connEscapeName conn--existsHelper :: SqlQuery () -> SqlExpr (Value Bool)-existsHelper = sub SELECT . (>> return true)- where- true :: SqlExpr (Value Bool)- true = val True--ifNotEmptyList :: SqlExpr (ValueList a) -> Bool -> SqlExpr (Value Bool) -> SqlExpr (Value Bool)-ifNotEmptyList EEmptyList b _ = val b-ifNotEmptyList (EList _) _ x = x------------------------------------------------------------------------------- | (Internal) Create a case statement.------ Since: 2.1.1-unsafeSqlCase :: PersistField a => [(SqlExpr (Value Bool), SqlExpr (Value a))] -> SqlExpr (Value a) -> SqlExpr (Value a)-unsafeSqlCase when v = ERaw Never buildCase- where- buildCase :: IdentInfo -> (TLB.Builder, [PersistValue])- buildCase info =- let (elseText, elseVals) = valueToSql v info- (whenText, whenVals) = mapWhen when info- in ( "CASE" <> whenText <> " ELSE " <> elseText <> " END", whenVals <> elseVals)-- mapWhen :: [(SqlExpr (Value Bool), SqlExpr (Value a))] -> IdentInfo -> (TLB.Builder, [PersistValue])- mapWhen [] _ = throw (UnexpectedCaseErr UnsafeSqlCaseError)- mapWhen when' info = foldl (foldHelp info) (mempty, mempty) when'-- foldHelp :: IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr (Value Bool), SqlExpr (Value a)) -> (TLB.Builder, [PersistValue])- foldHelp _ _ (ECompositeKey _, _) = throw (CompositeKeyErr FoldHelpError)- foldHelp _ _ (_, ECompositeKey _) = throw (CompositeKeyErr FoldHelpError)- foldHelp info (b0, vals0) (v1, v2) =- let (b1, vals1) = valueToSql v1 info- (b2, vals2) = valueToSql v2 info- in ( b0 <> " WHEN " <> b1 <> " THEN " <> b2, vals0 <> vals1 <> vals2 )-- valueToSql :: SqlExpr (Value a) -> IdentInfo -> (TLB.Builder, [PersistValue])- valueToSql (ERaw p f) = (first (parensM p)) . f- valueToSql (ECompositeKey _) = throw (CompositeKeyErr SqlCaseError)- valueToSql (EAliasedValue i _) = aliasedValueIdentToRawSql i- valueToSql (EValueReference i i') = valueReferenceToRawSql i i'---- | (Internal) Create a custom binary operator. You /should/--- /not/ use this function directly since its type is very--- general, you should always use it with an explicit type--- signature. For example:------ @--- (==.) :: SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value Bool)--- (==.) = unsafeSqlBinOp " = "--- @------ In the example above, we constraint the arguments to be of the--- same type and constraint the result to be a boolean value.-unsafeSqlBinOp :: TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c)-unsafeSqlBinOp op (ERaw p1 f1) (ERaw p2 f2) = ERaw Parens f- where- f info = let (b1, vals1) = f1 info- (b2, vals2) = f2 info- in ( parensM p1 b1 <> op <> parensM p2 b2- , vals1 <> vals2 )-unsafeSqlBinOp op a b = unsafeSqlBinOp op (construct a) (construct b)- where construct :: SqlExpr (Value a) -> SqlExpr (Value a)- construct (ERaw p f) = ERaw (if p == Never then Parens else Never) $ \info ->- let (b1, vals) = f info- build ("?", [PersistList vals']) =- (uncommas $ replicate (length vals') "?", vals')- build expr = expr- in build (parensM p b1, vals)- construct (ECompositeKey f) =- ERaw Parens $ \info -> (uncommas $ f info, mempty)- construct (EAliasedValue i _) =- ERaw Never $ aliasedValueIdentToRawSql i- construct (EValueReference i i') =- ERaw Never $ valueReferenceToRawSql i i'-{-# INLINE unsafeSqlBinOp #-}------- | Similar to 'unsafeSqlBinOp', but may also be applied to--- composite keys. Uses the operator given as the second--- argument whenever applied to composite keys.------ Usage example:------ @--- (==.) :: SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value Bool)--- (==.) = unsafeSqlBinOpComposite " = " " AND "--- @------ Persistent has a hack for implementing composite keys (see--- 'ECompositeKey' doc for more details), so we're forced to use--- a hack here as well. We deconstruct 'ERaw' values based on--- two rules:------ - If it is a single placeholder, then it's assumed to be--- coming from a 'PersistList' and thus its components are--- separated so that they may be applied to a composite key.------ - If it is not a single placeholder, then it's assumed to be--- a foreign (composite or not) key, so we enforce that it has--- no placeholders and split it on the commas.-unsafeSqlBinOpComposite :: TLB.Builder -> TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c)-unsafeSqlBinOpComposite op sep a b- | isCompositeKey a || isCompositeKey b = ERaw Parens $ compose (listify a) (listify b)- | otherwise = unsafeSqlBinOp op a b- where- isCompositeKey :: SqlExpr (Value x) -> Bool- isCompositeKey (ECompositeKey _) = True- isCompositeKey _ = False-- listify :: SqlExpr (Value x) -> IdentInfo -> ([TLB.Builder], [PersistValue])- listify (ECompositeKey f) = flip (,) [] . f- listify (ERaw _ f) = deconstruct . f- listify (EAliasedValue i _) = deconstruct . (aliasedValueIdentToRawSql i)- listify (EValueReference i i') = deconstruct . (valueReferenceToRawSql i i')-- deconstruct :: (TLB.Builder, [PersistValue]) -> ([TLB.Builder], [PersistValue])- deconstruct ("?", [PersistList vals]) = (replicate (length vals) "?", vals)- deconstruct (b', []) = (TLB.fromLazyText <$> TL.splitOn "," (TLB.toLazyText b'), [])- deconstruct _ = throw (SqlBinOpCompositeErr DeconstructionError)-- compose f1 f2 info- | not (null v1 || null v2) = throw (SqlBinOpCompositeErr NullPlaceholdersError)- | length b1 /= length b2 = throw (SqlBinOpCompositeErr MismatchingLengthsError)- | otherwise = (bc, vc)- where- (b1, v1) = f1 info- (b2, v2) = f2 info- bc = intersperseB sep [x <> op <> y | (x, y) <- zip b1 b2]- vc = v1 <> v2---- | (Internal) A raw SQL value. The same warning from--- 'unsafeSqlBinOp' applies to this function as well.-unsafeSqlValue :: TLB.Builder -> SqlExpr (Value a)-unsafeSqlValue v = ERaw Never $ const (v, mempty)-{-# INLINE unsafeSqlValue #-}--valueToFunctionArg :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue])-valueToFunctionArg info v =- case v of- ERaw _ f -> f info- EAliasedValue i _ -> aliasedValueIdentToRawSql i info- EValueReference i i' -> valueReferenceToRawSql i i' info- ECompositeKey _ -> throw (CompositeKeyErr SqlFunctionError)---- | (Internal) A raw SQL function. Once again, the same warning--- from 'unsafeSqlBinOp' applies to this function as well.-unsafeSqlFunction :: UnsafeSqlFunctionArgument a =>- TLB.Builder -> a -> SqlExpr (Value b)-unsafeSqlFunction name arg =- ERaw Never $ \info ->- let (argsTLB, argsVals) =- uncommas' $ map (valueToFunctionArg info) $ toArgList arg- in (name <> parens argsTLB, argsVals)---- | (Internal) An unsafe SQL function to extract a subfield from a compound--- field, e.g. datetime. See 'unsafeSqlBinOp' for warnings.------ Since: 1.3.6.-unsafeSqlExtractSubField :: UnsafeSqlFunctionArgument a =>- TLB.Builder -> a -> SqlExpr (Value b)-unsafeSqlExtractSubField subField arg =- ERaw Never $ \info ->- let (argsTLB, argsVals) =- uncommas' $ map (valueToFunctionArg info) $ toArgList arg- in ("EXTRACT" <> parens (subField <> " FROM " <> argsTLB), argsVals)---- | (Internal) A raw SQL function. Preserves parentheses around arguments.--- See 'unsafeSqlBinOp' for warnings.-unsafeSqlFunctionParens :: UnsafeSqlFunctionArgument a =>- TLB.Builder -> a -> SqlExpr (Value b)-unsafeSqlFunctionParens name arg =- ERaw Never $ \info ->- let- valueToFunctionArgParens v =- case v of- ERaw p f -> first (parensM p) (f info)- EAliasedValue i _ -> aliasedValueIdentToRawSql i info- EValueReference i i' -> valueReferenceToRawSql i i' info- ECompositeKey _ -> throw (CompositeKeyErr SqlFunctionError)- (argsTLB, argsVals) =- uncommas' $ map valueToFunctionArgParens $ toArgList arg- in (name <> parens argsTLB, argsVals)---- | (Internal) An explicit SQL type cast using CAST(value as type).--- See 'unsafeSqlBinOp' for warnings.-unsafeSqlCastAs :: T.Text -> SqlExpr (Value a) -> SqlExpr (Value b)-unsafeSqlCastAs t v = ERaw Never ((first (\value -> "CAST" <> parens (value <> " AS " <> TLB.fromText t))) . valueToText)- where- valueToText info =- case v of- (ERaw p f) ->- let (b, vals) = f info- in (parensM p b, vals)- EAliasedValue i _ -> aliasedValueIdentToRawSql i info- EValueReference i i' -> valueReferenceToRawSql i i' info- ECompositeKey _ -> throw (CompositeKeyErr SqlCastAsError)--- | (Internal) This class allows 'unsafeSqlFunction' to work with different--- numbers of arguments; specifically it allows providing arguments to a sql--- function via an n-tuple of @SqlExpr (Value _)@ values, which are not all--- necessarily required to be the same type. There are instances for up to--- 10-tuples, but for sql functions which take more than 10 arguments, you can--- also nest tuples, as e.g. @toArgList ((a,b),(c,d))@ is the same as--- @toArgList (a,b,c,d)@.-class UnsafeSqlFunctionArgument a where- toArgList :: a -> [SqlExpr (Value ())]---- | Useful for 0-argument functions, like @now@ in Postgresql.------ @since 3.2.1-instance UnsafeSqlFunctionArgument () where- toArgList _ = []--instance (a ~ Value b) => UnsafeSqlFunctionArgument (SqlExpr a) where- toArgList = (:[]) . veryUnsafeCoerceSqlExprValue-instance UnsafeSqlFunctionArgument a =>- UnsafeSqlFunctionArgument [a] where- toArgList = concatMap toArgList-instance ( UnsafeSqlFunctionArgument a- , UnsafeSqlFunctionArgument b- ) => UnsafeSqlFunctionArgument (a, b) where- toArgList (a, b) = toArgList a ++ toArgList b-instance ( UnsafeSqlFunctionArgument a- , UnsafeSqlFunctionArgument b- , UnsafeSqlFunctionArgument c- ) => UnsafeSqlFunctionArgument (a, b, c) where- toArgList = toArgList . from3-instance ( UnsafeSqlFunctionArgument a- , UnsafeSqlFunctionArgument b- , UnsafeSqlFunctionArgument c- , UnsafeSqlFunctionArgument d- ) => UnsafeSqlFunctionArgument (a, b, c, d) where- toArgList = toArgList . from4--- | @since 3.2.3-instance ( UnsafeSqlFunctionArgument a- , UnsafeSqlFunctionArgument b- , UnsafeSqlFunctionArgument c- , UnsafeSqlFunctionArgument d- , UnsafeSqlFunctionArgument e- ) => UnsafeSqlFunctionArgument (a, b, c, d, e) where- toArgList = toArgList . from5--- | @since 3.2.3-instance ( UnsafeSqlFunctionArgument a- , UnsafeSqlFunctionArgument b- , UnsafeSqlFunctionArgument c- , UnsafeSqlFunctionArgument d- , UnsafeSqlFunctionArgument e- , UnsafeSqlFunctionArgument f- ) => UnsafeSqlFunctionArgument (a, b, c, d, e, f) where- toArgList = toArgList . from6--- | @since 3.2.3-instance ( UnsafeSqlFunctionArgument a- , UnsafeSqlFunctionArgument b- , UnsafeSqlFunctionArgument c- , UnsafeSqlFunctionArgument d- , UnsafeSqlFunctionArgument e- , UnsafeSqlFunctionArgument f- , UnsafeSqlFunctionArgument g- ) => UnsafeSqlFunctionArgument (a, b, c, d, e, f, g) where- toArgList = toArgList . from7--- | @since 3.2.3-instance ( UnsafeSqlFunctionArgument a- , UnsafeSqlFunctionArgument b- , UnsafeSqlFunctionArgument c- , UnsafeSqlFunctionArgument d- , UnsafeSqlFunctionArgument e- , UnsafeSqlFunctionArgument f- , UnsafeSqlFunctionArgument g- , UnsafeSqlFunctionArgument h- ) => UnsafeSqlFunctionArgument (a, b, c, d, e, f, g, h) where- toArgList = toArgList . from8--- | @since 3.2.3-instance ( UnsafeSqlFunctionArgument a- , UnsafeSqlFunctionArgument b- , UnsafeSqlFunctionArgument c- , UnsafeSqlFunctionArgument d- , UnsafeSqlFunctionArgument e- , UnsafeSqlFunctionArgument f- , UnsafeSqlFunctionArgument g- , UnsafeSqlFunctionArgument h- , UnsafeSqlFunctionArgument i- ) => UnsafeSqlFunctionArgument (a, b, c, d, e, f, g, h, i) where- toArgList = toArgList . from9--- | @since 3.2.3-instance ( UnsafeSqlFunctionArgument a- , UnsafeSqlFunctionArgument b- , UnsafeSqlFunctionArgument c- , UnsafeSqlFunctionArgument d- , UnsafeSqlFunctionArgument e- , UnsafeSqlFunctionArgument f- , UnsafeSqlFunctionArgument g- , UnsafeSqlFunctionArgument h- , UnsafeSqlFunctionArgument i- , UnsafeSqlFunctionArgument j- ) => UnsafeSqlFunctionArgument (a, b, c, d, e, f, g, h, i, j) where- toArgList = toArgList . from10----- | (Internal) Coerce a value's type from 'SqlExpr (Value a)' to--- 'SqlExpr (Value b)'. You should /not/ use this function--- unless you know what you're doing!-veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b)-veryUnsafeCoerceSqlExprValue (ERaw p f) = ERaw p f-veryUnsafeCoerceSqlExprValue (ECompositeKey f) = ECompositeKey f-veryUnsafeCoerceSqlExprValue (EAliasedValue i v) = EAliasedValue i (veryUnsafeCoerceSqlExprValue v)-veryUnsafeCoerceSqlExprValue (EValueReference i i') = EValueReference i i'----- | (Internal) Coerce a value's type from 'SqlExpr (ValueList--- a)' to 'SqlExpr (Value a)'. Does not work with empty lists.-veryUnsafeCoerceSqlExprValueList :: SqlExpr (ValueList a) -> SqlExpr (Value a)-veryUnsafeCoerceSqlExprValueList (EList v) = v-veryUnsafeCoerceSqlExprValueList EEmptyList = throw (UnexpectedCaseErr EmptySqlExprValueList)----------------------------------------------------------------------------- | (Internal) Execute an @esqueleto@ @SELECT@ 'SqlQuery' inside--- @persistent@'s 'SqlPersistT' monad.-rawSelectSource :: ( SqlSelect a r- , MonadIO m1- , MonadIO m2- )- => Mode- -> SqlQuery a- -> SqlReadT m1 (Acquire (C.ConduitT () r m2 ()))-rawSelectSource mode query =- do- conn <- projectBackend <$> R.ask- let _ = conn :: SqlBackend- res <- R.withReaderT (const conn) (run conn)- return $ (C..| massage) `fmap` res- where-- run conn =- uncurry rawQueryRes $- first builderToText $- toRawSql mode (conn, initialIdentState) query-- massage = do- mrow <- C.await- case process <$> mrow of- Just (Right r) -> C.yield r >> massage- Just (Left err) -> liftIO $ throwIO $ PersistMarshalError err- Nothing -> return ()-- process = sqlSelectProcessRow----- | Execute an @esqueleto@ @SELECT@ query inside @persistent@'s--- 'SqlPersistT' monad and return a 'C.Source' of rows.-selectSource :: ( SqlSelect a r- , BackendCompatible SqlBackend backend- , IsPersistBackend backend- , PersistQueryRead backend- , PersistStoreRead backend, PersistUniqueRead backend- , MonadResource m )- => SqlQuery a- -> C.ConduitT () r (R.ReaderT backend m) ()-selectSource query = do- res <- lift $ rawSelectSource SELECT query- (key, src) <- lift $ allocateAcquire res- src- lift $ release key---- | Execute an @esqueleto@ @SELECT@ query inside @persistent@'s--- 'SqlPersistT' monad and return a list of rows.------ We've seen that 'from' has some magic about which kinds of--- things you may bring into scope. This 'select' function also--- has some magic for which kinds of things you may bring back to--- Haskell-land by using @SqlQuery@'s @return@:------ * You may return a @SqlExpr ('Entity' v)@ for an entity @v@--- (i.e., like the @*@ in SQL), which is then returned to--- Haskell-land as just @Entity v@.------ * You may return a @SqlExpr (Maybe (Entity v))@ for an entity--- @v@ that may be @NULL@, which is then returned to--- Haskell-land as @Maybe (Entity v)@. Used for @OUTER JOIN@s.------ * You may return a @SqlExpr ('Value' t)@ for a value @t@--- (i.e., a single column), where @t@ is any instance of--- 'PersistField', which is then returned to Haskell-land as--- @Value t@. You may use @Value@ to return projections of an--- @Entity@ (see @('^.')@ and @('?.')@) or to return any other--- value calculated on the query (e.g., 'countRows' or--- 'subSelect').------ The @SqlSelect a r@ class has functional dependencies that--- allow type information to flow both from @a@ to @r@ and--- vice-versa. This means that you'll almost never have to give--- any type signatures for @esqueleto@ queries. For example, the--- query @'select' $ from $ \\p -> return p@ alone is ambiguous, but--- in the context of------ @--- do ps <- 'select' $--- 'from' $ \\p ->--- return p--- liftIO $ mapM_ (putStrLn . personName . entityVal) ps--- @------ we are able to infer from that single @personName . entityVal@--- function composition that the @p@ inside the query is of type--- @SqlExpr (Entity Person)@.-select :: ( SqlSelect a r- , MonadIO m- )- => SqlQuery a -> SqlReadT m [r]-select query = do- res <- rawSelectSource SELECT query- conn <- R.ask- liftIO $ with res $ flip R.runReaderT conn . runSource---- | (Internal) Run a 'C.Source' of rows.-runSource :: Monad m =>- C.ConduitT () r (R.ReaderT backend m) ()- -> R.ReaderT backend m [r]-runSource src = C.runConduit $ src C..| CL.consume------------------------------------------------------------------------------ | (Internal) Execute an @esqueleto@ statement inside--- @persistent@'s 'SqlPersistT' monad.-rawEsqueleto :: ( MonadIO m, SqlSelect a r, BackendCompatible SqlBackend backend)- => Mode- -> SqlQuery a- -> R.ReaderT backend m Int64-rawEsqueleto mode query = do- conn <- R.ask- uncurry rawExecuteCount $- first builderToText $- toRawSql mode (conn, initialIdentState) query----- | Execute an @esqueleto@ @DELETE@ query inside @persistent@'s--- 'SqlPersistT' monad. Note that currently there are no type--- checks for statements that should not appear on a @DELETE@--- query.------ Example of usage:------ @--- 'delete' $--- 'from' $ \\appointment ->--- 'where_' (appointment '^.' AppointmentDate '<.' 'val' now)--- @------ Unlike 'select', there is a useful way of using 'delete' that--- will lead to type ambiguities. If you want to delete all rows--- (i.e., no 'where_' clause), you'll have to use a type signature:------ @--- 'delete' $--- 'from' $ \\(appointment :: 'SqlExpr' ('Entity' Appointment)) ->--- return ()--- @-delete :: ( MonadIO m )- => SqlQuery ()- -> SqlWriteT m ()-delete = void . deleteCount---- | Same as 'delete', but returns the number of rows affected.-deleteCount :: ( MonadIO m )- => SqlQuery ()- -> SqlWriteT m Int64-deleteCount = rawEsqueleto DELETE----- | Execute an @esqueleto@ @UPDATE@ query inside @persistent@'s--- 'SqlPersistT' monad. Note that currently there are no type--- checks for statements that should not appear on a @UPDATE@--- query.------ Example of usage:------ @--- 'update' $ \\p -> do--- 'set' p [ PersonAge '=.' 'just' ('val' thisYear) -. p '^.' PersonBorn ]--- 'where_' $ isNothing (p '^.' PersonAge)--- @-update- ::- ( MonadIO m, PersistEntity val- , BackendCompatible SqlBackend (PersistEntityBackend val)- )- => (SqlExpr (Entity val) -> SqlQuery ())- -> SqlWriteT m ()-update = void . updateCount---- | Same as 'update', but returns the number of rows affected.-updateCount- ::- ( MonadIO m, PersistEntity val- , BackendCompatible SqlBackend (PersistEntityBackend val)- )- => (SqlExpr (Entity val) -> SqlQuery ())- -> SqlWriteT m Int64-updateCount = rawEsqueleto UPDATE . from----------------------------------------------------------------------------builderToText :: TLB.Builder -> T.Text-builderToText = TL.toStrict . TLB.toLazyTextWith defaultChunkSize- where- defaultChunkSize = 1024 - 32----- | (Internal) Pretty prints a 'SqlQuery' into a SQL query.------ Note: if you're curious about the SQL query being generated by--- @esqueleto@, instead of manually using this function (which is--- possible but tedious), see the 'renderQueryToText' function (along with--- 'renderQuerySelect', 'renderQueryUpdate', etc).-toRawSql- :: (SqlSelect a r, BackendCompatible SqlBackend backend)- => Mode -> (backend, IdentState) -> SqlQuery a -> (TLB.Builder, [PersistValue])-toRawSql mode (conn, firstIdentState) query =- let ((ret, sd), finalIdentState) =- flip S.runState firstIdentState $- W.runWriterT $- unQ query- SideData distinctClause- fromClauses- setClauses- whereClauses- groupByClause- havingClause- orderByClauses- limitClause- lockingClause = sd- -- Pass the finalIdentState (containing all identifiers- -- that were used) to the subsequent calls. This ensures- -- that no name clashes will occur on subqueries that may- -- appear on the expressions below.- info = (projectBackend conn, finalIdentState)- in mconcat- [ makeInsertInto info mode ret- , makeSelect info mode distinctClause ret- , makeFrom info mode fromClauses- , makeSet info setClauses- , makeWhere info whereClauses- , makeGroupBy info groupByClause- , makeHaving info havingClause- , makeOrderBy info orderByClauses- , makeLimit info limitClause orderByClauses- , makeLocking lockingClause- ]---- | Renders a 'SqlQuery' into a 'Text' value along with the list of--- 'PersistValue's that would be supplied to the database for @?@ placeholders.------ You must ensure that the 'Mode' you pass to this function corresponds with--- the actual 'SqlQuery'. If you pass a query that uses incompatible features--- (like an @INSERT@ statement with a @SELECT@ mode) then you'll get a weird--- result.------ @since 3.1.1-renderQueryToText- :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m)- => Mode- -- ^ Whether to render as an 'SELECT', 'DELETE', etc.- -> SqlQuery a- -- ^ The SQL query you want to render.- -> R.ReaderT backend m (T.Text, [PersistValue])-renderQueryToText mode query = do- backend <- R.ask- let (builder, pvals) = toRawSql mode (backend, initialIdentState) query- pure (builderToText builder, pvals)---- | Renders a 'SqlQuery' into a 'Text' value along with the list of--- 'PersistValue's that would be supplied to the database for @?@ placeholders.------ @since 3.1.1-renderQuerySelect- :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m)- => SqlQuery a- -- ^ The SQL query you want to render.- -> R.ReaderT backend m (T.Text, [PersistValue])-renderQuerySelect = renderQueryToText SELECT---- | Renders a 'SqlQuery' into a 'Text' value along with the list of--- 'PersistValue's that would be supplied to the database for @?@ placeholders.------ @since 3.1.1-renderQueryDelete- :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m)- => SqlQuery a- -- ^ The SQL query you want to render.- -> R.ReaderT backend m (T.Text, [PersistValue])-renderQueryDelete = renderQueryToText DELETE---- | Renders a 'SqlQuery' into a 'Text' value along with the list of--- 'PersistValue's that would be supplied to the database for @?@ placeholders.------ @since 3.1.1-renderQueryUpdate- :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m)- => SqlQuery a- -- ^ The SQL query you want to render.- -> R.ReaderT backend m (T.Text, [PersistValue])-renderQueryUpdate = renderQueryToText UPDATE---- | Renders a 'SqlQuery' into a 'Text' value along with the list of--- 'PersistValue's that would be supplied to the database for @?@ placeholders.------ @since 3.1.1-renderQueryInsertInto- :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m)- => SqlQuery a- -- ^ The SQL query you want to render.- -> R.ReaderT backend m (T.Text, [PersistValue])-renderQueryInsertInto = renderQueryToText INSERT_INTO---- | (Internal) Mode of query being converted by 'toRawSql'.-data Mode =- SELECT- | DELETE- | UPDATE- | INSERT_INTO---uncommas :: [TLB.Builder] -> TLB.Builder-uncommas = intersperseB ", "--intersperseB :: TLB.Builder -> [TLB.Builder] -> TLB.Builder-intersperseB a = mconcat . intersperse a . filter (/= mempty)--uncommas' :: Monoid a => [(TLB.Builder, a)] -> (TLB.Builder, a)-uncommas' = (uncommas *** mconcat) . unzip---makeInsertInto :: SqlSelect a r => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue])-makeInsertInto info INSERT_INTO ret = sqlInsertInto info ret-makeInsertInto _ _ _ = mempty---makeSelect :: SqlSelect a r => IdentInfo -> Mode -> DistinctClause -> a -> (TLB.Builder, [PersistValue])-makeSelect info mode_ distinctClause ret = process mode_- where- process mode =- case mode of- SELECT -> withCols selectKind- DELETE -> plain "DELETE "- UPDATE -> plain "UPDATE "- INSERT_INTO -> process SELECT- selectKind =- case distinctClause of- DistinctAll -> ("SELECT ", [])- DistinctStandard -> ("SELECT DISTINCT ", [])- DistinctOn exprs -> first (("SELECT DISTINCT ON (" <>) . (<> ") ")) $- uncommas' (processExpr <$> exprs)- where processExpr (EDistinctOn f) = materializeExpr info f- withCols v = v <> sqlSelectCols info ret- plain v = (v, [])---makeFrom- :: IdentInfo- -> Mode- -> [FromClause]- -> (TLB.Builder, [PersistValue])-makeFrom _ _ [] = mempty-makeFrom info mode fs = ret- where- ret = case collectOnClauses (fst info) fs of- Left expr -> throw $ mkExc expr- Right fs' -> keyword $ uncommas' (map (mk Never) fs')- keyword = case mode of- UPDATE -> id- _ -> first ("\nFROM " <>)-- mk _ (FromStart i def) = base i def- mk paren (FromJoin lhs kind rhs monClause) =- first (parensM paren) $- mconcat [ mk Never lhs- , (fromKind kind, mempty)- , mk Parens rhs- , maybe mempty makeOnClause monClause- ]- mk _ (OnClause _) = throw (UnexpectedCaseErr MakeFromError)- mk _ (FromQuery ident f) =- let (queryText, queryVals) = f info- in ((parens queryText) <> " AS " <> useIdent info ident, queryVals)-- base ident@(I identText) def =- let db@(DBName dbText) = entityDB def- in ( if dbText == identText- then fromDBName info db- else fromDBName info db <> (" AS " <> useIdent info ident)- , mempty )-- fromKind InnerJoinKind = " INNER JOIN "- fromKind CrossJoinKind = " CROSS JOIN "- fromKind LeftOuterJoinKind = " LEFT OUTER JOIN "- fromKind RightOuterJoinKind = " RIGHT OUTER JOIN "- fromKind FullOuterJoinKind = " FULL OUTER JOIN "-- makeOnClause (ERaw _ f) = first (" ON " <>) (f info)- makeOnClause (ECompositeKey _) = throw (CompositeKeyErr MakeOnClauseError)- makeOnClause (EAliasedValue _ _) = throw (AliasedValueErr MakeOnClauseError)- makeOnClause (EValueReference _ _) = throw (AliasedValueErr MakeOnClauseError)-- mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException- mkExc (ERaw _ f) =- OnClauseWithoutMatchingJoinException $- TL.unpack $ TLB.toLazyText $ fst (f info)- mkExc (ECompositeKey _) = throw (CompositeKeyErr MakeExcError)- mkExc (EAliasedValue _ _) = throw (AliasedValueErr MakeExcError)- mkExc (EValueReference _ _) = throw (AliasedValueErr MakeExcError)--makeSet :: IdentInfo -> [SetClause] -> (TLB.Builder, [PersistValue])-makeSet _ [] = mempty-makeSet info os = first ("\nSET " <>) . uncommas' $ concatMap mk os- where- mk (SetClause (ERaw _ f)) = [f info]- mk (SetClause (ECompositeKey _)) = throw (CompositeKeyErr MakeSetError) -- FIXME- mk (SetClause (EAliasedValue i _)) = [aliasedValueIdentToRawSql i info]- mk (SetClause (EValueReference i i')) = [valueReferenceToRawSql i i' info]--makeWhere :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue])-makeWhere _ NoWhere = mempty-makeWhere info (Where v) = first ("\nWHERE " <>) $ x info- where- x =- case v of- ERaw _ f -> f- EAliasedValue i _ -> aliasedValueIdentToRawSql i- EValueReference i i' -> valueReferenceToRawSql i i'- ECompositeKey _ -> throw (CompositeKeyErr MakeWhereError)--makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue])-makeGroupBy _ (GroupBy []) = (mempty, [])-makeGroupBy info (GroupBy fields) = first ("\nGROUP BY " <>) build- where- build :: (TLB.Builder, [PersistValue])- build = uncommas' $ map match fields-- match :: SomeValue -> (TLB.Builder, [PersistValue])- match (SomeValue (ERaw _ f)) = f info- match (SomeValue (ECompositeKey f)) = (mconcat $ f info, mempty)- match (SomeValue (EAliasedValue i _)) = aliasedValueIdentToRawSql i info- match (SomeValue (EValueReference i i')) = valueReferenceToRawSql i i' info--makeHaving :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue])-makeHaving _ NoWhere = mempty-makeHaving info (Where v) = first ("\nHAVING " <>) $ x info- where- x =- case v of- ERaw _ f -> f- EAliasedValue i _ -> aliasedValueIdentToRawSql i- EValueReference i i' -> valueReferenceToRawSql i i'- ECompositeKey _ -> throw (CompositeKeyErr MakeHavingError)---- makeHaving, makeWhere and makeOrderBy-makeOrderByNoNewline ::- IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue])-makeOrderByNoNewline _ [] = mempty-makeOrderByNoNewline info os = first ("ORDER BY " <>) . uncommas' $ concatMap mk os- where- mk :: OrderByClause -> [(TLB.Builder, [PersistValue])]- mk (EOrderBy t (ECompositeKey f)) =- let fs = f info- vals = repeat []- in zip (map (<> orderByType t) fs) vals- mk (EOrderBy t v) =- let x = case v of- ERaw p f -> (first (parensM p)) . f- EAliasedValue i _ -> aliasedValueIdentToRawSql i- EValueReference i i' -> valueReferenceToRawSql i i'- ECompositeKey _ -> undefined -- defined above- in [ first (<> orderByType t) $ x info ]- mk EOrderRandom = [first (<> "RANDOM()") mempty]-- orderByType ASC = " ASC"- orderByType DESC = " DESC"--makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue])-makeOrderBy _ [] = mempty-makeOrderBy info is =- let (tlb, vals) = makeOrderByNoNewline info is- in ("\n" <> tlb, vals)--{-# DEPRECATED EOrderRandom "Since 2.6.0: `rand` ordering function is not uniform across all databases! To avoid accidental partiality it will be removed in the next major version." #-}--makeLimit :: IdentInfo -> LimitClause -> [OrderByClause] -> (TLB.Builder, [PersistValue])-makeLimit (conn, _) (Limit ml mo) orderByClauses =- let limitRaw = connLimitOffset conn (v ml, v mo) hasOrderClause "\n"- hasOrderClause = not (null orderByClauses)- v = maybe 0 fromIntegral- in (TLB.fromText limitRaw, mempty)---makeLocking :: LockingClause -> (TLB.Builder, [PersistValue])-makeLocking = flip (,) [] . maybe mempty toTLB . Monoid.getLast- where- toTLB ForUpdate = "\nFOR UPDATE"- toTLB ForUpdateSkipLocked = "\nFOR UPDATE SKIP LOCKED"- toTLB ForShare = "\nFOR SHARE"- toTLB LockInShareMode = "\nLOCK IN SHARE MODE"----parens :: TLB.Builder -> TLB.Builder-parens b = "(" <> (b <> ")")--aliasedValueIdentToRawSql :: Ident -> IdentInfo -> (TLB.Builder, [PersistValue])-aliasedValueIdentToRawSql i info =- (useIdent info i, mempty)--valueReferenceToRawSql :: Ident -> (IdentInfo -> Ident) -> IdentInfo -> (TLB.Builder, [PersistValue])-valueReferenceToRawSql sourceIdent columnIdentF info =- (useIdent info sourceIdent <> "." <> useIdent info (columnIdentF info), mempty)--aliasedEntityColumnIdent :: Ident -> FieldDef -> Ident-aliasedEntityColumnIdent (I baseIdent) field =- I (baseIdent <> "_" <> (unDBName $ fieldDB field))--aliasedColumnName :: Ident -> IdentInfo -> T.Text -> TLB.Builder-aliasedColumnName (I baseIdent) info columnName =- useIdent info (I (baseIdent <> "_" <> columnName))----------------------------------------------------------------------------- | (Internal) Class for mapping results coming from 'SqlQuery'--- into actual results.------ This looks very similar to @RawSql@, and it is! However,--- there are some crucial differences and ultimately they're--- different classes.-class SqlSelect a r | a -> r, r -> a where- -- | Creates the variable part of the @SELECT@ query and- -- returns the list of 'PersistValue's that will be given to- -- 'rawQuery'.- sqlSelectCols :: IdentInfo -> a -> (TLB.Builder, [PersistValue])-- -- | Number of columns that will be consumed.- sqlSelectColCount :: Proxy a -> Int-- -- | Transform a row of the result into the data type.- sqlSelectProcessRow :: [PersistValue] -> Either T.Text r-- -- | Create @INSERT INTO@ clause instead.- sqlInsertInto :: IdentInfo -> a -> (TLB.Builder, [PersistValue])- sqlInsertInto = throw (UnexpectedCaseErr UnsupportedSqlInsertIntoType)----- | @INSERT INTO@ hack.-instance SqlSelect (SqlExpr InsertFinal) InsertFinal where- sqlInsertInto info (EInsertFinal (EInsert p _)) =- let fields = uncommas $- map (fromDBName info . fieldDB) $- entityFields $- entityDef p- table = fromDBName info . entityDB . entityDef $ p- in ("INSERT INTO " <> table <> parens fields <> "\n", [])- sqlSelectCols info (EInsertFinal (EInsert _ f)) = f info- sqlSelectColCount = const 0- sqlSelectProcessRow =- const (Right (throw (UnexpectedCaseErr InsertionFinalError)))----- | Not useful for 'select', but used for 'update' and 'delete'.-instance SqlSelect () () where- sqlSelectCols _ _ = ("1", [])- sqlSelectColCount _ = 1- sqlSelectProcessRow _ = Right ()--unescapedColumnNames :: EntityDef -> [DBName]-unescapedColumnNames ent =- (if hasCompositeKey ent- then [] else [fieldDB (entityId ent)])- <> map fieldDB (entityFields ent)---- | You may return an 'Entity' from a 'select' query.-instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where- sqlSelectCols info expr@(EEntity ident) = ret- where- process ed = uncommas $- map ((name <>) . TLB.fromText) $- entityColumnNames ed (fst info)- -- 'name' is the biggest difference between 'RawSql' and- -- 'SqlSelect'. We automatically create names for tables- -- (since it's not the user who's writing the FROM- -- clause), while 'rawSql' assumes that it's just the- -- name of the table (which doesn't allow self-joins, for- -- example).- name = useIdent info ident <> "."- ret = let ed = entityDef $ getEntityVal $ return expr- in (process ed, mempty)- sqlSelectCols info expr@(EAliasedEntity aliasIdent tableIdent) = ret- where- process ed = uncommas $- map ((name <>) . aliasName) $- unescapedColumnNames ed- aliasName columnName = (fromDBName info columnName) <> " AS " <> aliasedColumnName aliasIdent info (unDBName columnName)- name = useIdent info tableIdent <> "."- ret = let ed = entityDef $ getEntityVal $ return expr- in (process ed, mempty)- sqlSelectCols info expr@(EAliasedEntityReference sourceIdent baseIdent) = ret- where- process ed = uncommas $- map ((name <>) . aliasedColumnName baseIdent info . unDBName) $- unescapedColumnNames ed- name = useIdent info sourceIdent <> "."- ret = let ed = entityDef $ getEntityVal $ return expr- in (process ed, mempty)- sqlSelectColCount = entityColumnCount . entityDef . getEntityVal- sqlSelectProcessRow = parseEntityValues ed- where ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity a)))---getEntityVal :: Proxy (SqlExpr (Entity a)) -> Proxy a-getEntityVal = const Proxy----- | You may return a possibly-@NULL@ 'Entity' from a 'select' query.-instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where- sqlSelectCols info (EMaybe ent) = sqlSelectCols info ent- sqlSelectColCount = sqlSelectColCount . fromEMaybe- where- fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e)- fromEMaybe = const Proxy- sqlSelectProcessRow cols- | all (== PersistNull) cols = return Nothing- | otherwise = Just <$> sqlSelectProcessRow cols----- | You may return any single value (i.e. a single column) from--- a 'select' query.-instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where- sqlSelectCols = materializeExpr- sqlSelectColCount = const 1- sqlSelectProcessRow [pv] = Value <$> fromPersistValue pv- sqlSelectProcessRow pvs = Value <$> fromPersistValue (PersistList pvs)---- | Materialize a @SqlExpr (Value a)@.-materializeExpr :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue])-materializeExpr info (ERaw p f) =- let (b, vals) = f info- in (parensM p b, vals)-materializeExpr info (ECompositeKey f) =- let bs = f info- in (uncommas $ map (parensM Parens) bs, [])-materializeExpr info (EAliasedValue ident x) =- let (b, vals) = materializeExpr info x- in (b <> " AS " <> (useIdent info ident), vals)-materializeExpr info (EValueReference sourceIdent columnIdent) =- valueReferenceToRawSql sourceIdent columnIdent info---- | You may return tuples (up to 16-tuples) and tuples of tuples--- from a 'select' query.-instance ( SqlSelect a ra- , SqlSelect b rb- ) => SqlSelect (a, b) (ra, rb) where- sqlSelectCols esc (a, b) =- uncommas'- [ sqlSelectCols esc a- , sqlSelectCols esc b- ]- sqlSelectColCount = uncurry (+) . (sqlSelectColCount *** sqlSelectColCount) . fromTuple- where- fromTuple :: Proxy (a,b) -> (Proxy a, Proxy b)- fromTuple = const (Proxy, Proxy)- sqlSelectProcessRow =- let x = getType processRow- getType :: SqlSelect a r => (z -> Either y (r,x)) -> Proxy a- getType = const Proxy-- colCountFst = sqlSelectColCount x-- processRow row =- let (rowFst, rowSnd) = splitAt colCountFst row- in (,) <$> sqlSelectProcessRow rowFst- <*> sqlSelectProcessRow rowSnd-- in colCountFst `seq` processRow- -- Avoids recalculating 'colCountFst'.---instance ( SqlSelect a ra- , SqlSelect b rb- , SqlSelect c rc- ) => SqlSelect (a, b, c) (ra, rb, rc) where- sqlSelectCols esc (a, b, c) =- uncommas'- [ sqlSelectCols esc a- , sqlSelectCols esc b- , sqlSelectCols esc c- ]- sqlSelectColCount = sqlSelectColCount . from3P- sqlSelectProcessRow = fmap to3 . sqlSelectProcessRow--from3P :: Proxy (a,b,c) -> Proxy ((a,b),c)-from3P = const Proxy--from3 :: (a,b,c) -> ((a,b),c)-from3 (a,b,c) = ((a,b),c)--to3 :: ((a,b),c) -> (a,b,c)-to3 ((a,b),c) = (a,b,c)---instance ( SqlSelect a ra- , SqlSelect b rb- , SqlSelect c rc- , SqlSelect d rd- ) => SqlSelect (a, b, c, d) (ra, rb, rc, rd) where- sqlSelectCols esc (a, b, c, d) =- uncommas'- [ sqlSelectCols esc a- , sqlSelectCols esc b- , sqlSelectCols esc c- , sqlSelectCols esc d- ]- sqlSelectColCount = sqlSelectColCount . from4P- sqlSelectProcessRow = fmap to4 . sqlSelectProcessRow--from4P :: Proxy (a,b,c,d) -> Proxy ((a,b),(c,d))-from4P = const Proxy--from4 :: (a,b,c,d) -> ((a,b),(c,d))-from4 (a,b,c,d) = ((a,b),(c,d))--to4 :: ((a,b),(c,d)) -> (a,b,c,d)-to4 ((a,b),(c,d)) = (a,b,c,d)---instance ( SqlSelect a ra- , SqlSelect b rb- , SqlSelect c rc- , SqlSelect d rd- , SqlSelect e re- ) => SqlSelect (a, b, c, d, e) (ra, rb, rc, rd, re) where- sqlSelectCols esc (a, b, c, d, e) =- uncommas'- [ sqlSelectCols esc a- , sqlSelectCols esc b- , sqlSelectCols esc c- , sqlSelectCols esc d- , sqlSelectCols esc e- ]- sqlSelectColCount = sqlSelectColCount . from5P- sqlSelectProcessRow = fmap to5 . sqlSelectProcessRow--from5P :: Proxy (a,b,c,d,e) -> Proxy ((a,b),(c,d),e)-from5P = const Proxy--from5 :: (a,b,c,d,e) -> ((a,b),(c,d),e)-from5 (a,b,c,d,e) = ((a,b),(c,d),e)--to5 :: ((a,b),(c,d),e) -> (a,b,c,d,e)-to5 ((a,b),(c,d),e) = (a,b,c,d,e)---instance ( SqlSelect a ra- , SqlSelect b rb- , SqlSelect c rc- , SqlSelect d rd- , SqlSelect e re- , SqlSelect f rf- ) => SqlSelect (a, b, c, d, e, f) (ra, rb, rc, rd, re, rf) where- sqlSelectCols esc (a, b, c, d, e, f) =- uncommas'- [ sqlSelectCols esc a- , sqlSelectCols esc b- , sqlSelectCols esc c- , sqlSelectCols esc d- , sqlSelectCols esc e- , sqlSelectCols esc f- ]- sqlSelectColCount = sqlSelectColCount . from6P- sqlSelectProcessRow = fmap to6 . sqlSelectProcessRow--from6P :: Proxy (a,b,c,d,e,f) -> Proxy ((a,b),(c,d),(e,f))-from6P = const Proxy--from6 :: (a,b,c,d,e,f) -> ((a,b),(c,d),(e,f))-from6 (a,b,c,d,e,f) = ((a,b),(c,d),(e,f))--to6 :: ((a,b),(c,d),(e,f)) -> (a,b,c,d,e,f)-to6 ((a,b),(c,d),(e,f)) = (a,b,c,d,e,f)---instance ( SqlSelect a ra- , SqlSelect b rb- , SqlSelect c rc- , SqlSelect d rd- , SqlSelect e re- , SqlSelect f rf- , SqlSelect g rg- ) => SqlSelect (a, b, c, d, e, f, g) (ra, rb, rc, rd, re, rf, rg) where- sqlSelectCols esc (a, b, c, d, e, f, g) =- uncommas'- [ sqlSelectCols esc a- , sqlSelectCols esc b- , sqlSelectCols esc c- , sqlSelectCols esc d- , sqlSelectCols esc e- , sqlSelectCols esc f- , sqlSelectCols esc g- ]- sqlSelectColCount = sqlSelectColCount . from7P- sqlSelectProcessRow = fmap to7 . sqlSelectProcessRow--from7P :: Proxy (a,b,c,d,e,f,g) -> Proxy ((a,b),(c,d),(e,f),g)-from7P = const Proxy--from7 :: (a,b,c,d,e,f,g) -> ((a,b),(c,d),(e,f),g)-from7 (a,b,c,d,e,f,g) = ((a,b),(c,d),(e,f),g)--to7 :: ((a,b),(c,d),(e,f),g) -> (a,b,c,d,e,f,g)-to7 ((a,b),(c,d),(e,f),g) = (a,b,c,d,e,f,g)---instance ( SqlSelect a ra- , SqlSelect b rb- , SqlSelect c rc- , SqlSelect d rd- , SqlSelect e re- , SqlSelect f rf- , SqlSelect g rg- , SqlSelect h rh- ) => SqlSelect (a, b, c, d, e, f, g, h) (ra, rb, rc, rd, re, rf, rg, rh) where- sqlSelectCols esc (a, b, c, d, e, f, g, h) =- uncommas'- [ sqlSelectCols esc a- , sqlSelectCols esc b- , sqlSelectCols esc c- , sqlSelectCols esc d- , sqlSelectCols esc e- , sqlSelectCols esc f- , sqlSelectCols esc g- , sqlSelectCols esc h- ]- sqlSelectColCount = sqlSelectColCount . from8P- sqlSelectProcessRow = fmap to8 . sqlSelectProcessRow--from8P :: Proxy (a,b,c,d,e,f,g,h) -> Proxy ((a,b),(c,d),(e,f),(g,h))-from8P = const Proxy--from8 :: (a,b,c,d,e,f,g,h) -> ((a,b),(c,d),(e,f),(g,h))-from8 (a,b,c,d,e,f,g,h) = ((a,b),(c,d),(e,f),(g,h))--to8 :: ((a,b),(c,d),(e,f),(g,h)) -> (a,b,c,d,e,f,g,h)-to8 ((a,b),(c,d),(e,f),(g,h)) = (a,b,c,d,e,f,g,h)--instance ( SqlSelect a ra- , SqlSelect b rb- , SqlSelect c rc- , SqlSelect d rd- , SqlSelect e re- , SqlSelect f rf- , SqlSelect g rg- , SqlSelect h rh- , SqlSelect i ri- ) => SqlSelect (a, b, c, d, e, f, g, h, i) (ra, rb, rc, rd, re, rf, rg, rh, ri) where- sqlSelectCols esc (a, b, c, d, e, f, g, h, i) =- uncommas'- [ sqlSelectCols esc a- , sqlSelectCols esc b- , sqlSelectCols esc c- , sqlSelectCols esc d- , sqlSelectCols esc e- , sqlSelectCols esc f- , sqlSelectCols esc g- , sqlSelectCols esc h- , sqlSelectCols esc i- ]- sqlSelectColCount = sqlSelectColCount . from9P- sqlSelectProcessRow = fmap to9 . sqlSelectProcessRow--from9P :: Proxy (a,b,c,d,e,f,g,h,i) -> Proxy ((a,b),(c,d),(e,f),(g,h),i)-from9P = const Proxy--from9 :: (a,b,c,d,e,f,g,h,i) -> ((a,b),(c,d),(e,f),(g,h),i)-from9 (a,b,c,d,e,f,g,h,i) = ((a,b),(c,d),(e,f),(g,h),i)--to9 :: ((a,b),(c,d),(e,f),(g,h),i) -> (a,b,c,d,e,f,g,h,i)-to9 ((a,b),(c,d),(e,f),(g,h),i) = (a,b,c,d,e,f,g,h,i)--instance ( SqlSelect a ra- , SqlSelect b rb- , SqlSelect c rc- , SqlSelect d rd- , SqlSelect e re- , SqlSelect f rf- , SqlSelect g rg- , SqlSelect h rh- , SqlSelect i ri- , SqlSelect j rj- ) => SqlSelect (a, b, c, d, e, f, g, h, i, j) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj) where- sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j) =- uncommas'- [ sqlSelectCols esc a- , sqlSelectCols esc b- , sqlSelectCols esc c- , sqlSelectCols esc d- , sqlSelectCols esc e- , sqlSelectCols esc f- , sqlSelectCols esc g- , sqlSelectCols esc h- , sqlSelectCols esc i- , sqlSelectCols esc j- ]- sqlSelectColCount = sqlSelectColCount . from10P- sqlSelectProcessRow = fmap to10 . sqlSelectProcessRow--from10P :: Proxy (a,b,c,d,e,f,g,h,i,j) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j))-from10P = const Proxy--from10 :: (a,b,c,d,e,f,g,h,i,j) -> ((a,b),(c,d),(e,f),(g,h),(i,j))-from10 (a,b,c,d,e,f,g,h,i,j) = ((a,b),(c,d),(e,f),(g,h),(i,j))--to10 :: ((a,b),(c,d),(e,f),(g,h),(i,j)) -> (a,b,c,d,e,f,g,h,i,j)-to10 ((a,b),(c,d),(e,f),(g,h),(i,j)) = (a,b,c,d,e,f,g,h,i,j)---instance ( SqlSelect a ra- , SqlSelect b rb- , SqlSelect c rc- , SqlSelect d rd- , SqlSelect e re- , SqlSelect f rf- , SqlSelect g rg- , SqlSelect h rh- , SqlSelect i ri- , SqlSelect j rj- , SqlSelect k rk- ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk) where- sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k) =- uncommas'- [ sqlSelectCols esc a- , sqlSelectCols esc b- , sqlSelectCols esc c- , sqlSelectCols esc d- , sqlSelectCols esc e- , sqlSelectCols esc f- , sqlSelectCols esc g- , sqlSelectCols esc h- , sqlSelectCols esc i- , sqlSelectCols esc j- , sqlSelectCols esc k- ]- sqlSelectColCount = sqlSelectColCount . from11P- sqlSelectProcessRow = fmap to11 . sqlSelectProcessRow--from11P :: Proxy (a,b,c,d,e,f,g,h,i,j,k) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),k)-from11P = const Proxy--to11 :: ((a,b),(c,d),(e,f),(g,h),(i,j),k) -> (a,b,c,d,e,f,g,h,i,j,k)-to11 ((a,b),(c,d),(e,f),(g,h),(i,j),k) = (a,b,c,d,e,f,g,h,i,j,k)--instance ( SqlSelect a ra- , SqlSelect b rb- , SqlSelect c rc- , SqlSelect d rd- , SqlSelect e re- , SqlSelect f rf- , SqlSelect g rg- , SqlSelect h rh- , SqlSelect i ri- , SqlSelect j rj- , SqlSelect k rk- , SqlSelect l rl- ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl) where- sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l) =- uncommas'- [ sqlSelectCols esc a- , sqlSelectCols esc b- , sqlSelectCols esc c- , sqlSelectCols esc d- , sqlSelectCols esc e- , sqlSelectCols esc f- , sqlSelectCols esc g- , sqlSelectCols esc h- , sqlSelectCols esc i- , sqlSelectCols esc j- , sqlSelectCols esc k- , sqlSelectCols esc l- ]- sqlSelectColCount = sqlSelectColCount . from12P- sqlSelectProcessRow = fmap to12 . sqlSelectProcessRow--from12P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l))-from12P = const Proxy--to12 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) -> (a,b,c,d,e,f,g,h,i,j,k,l)-to12 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) = (a,b,c,d,e,f,g,h,i,j,k,l)--instance ( SqlSelect a ra- , SqlSelect b rb- , SqlSelect c rc- , SqlSelect d rd- , SqlSelect e re- , SqlSelect f rf- , SqlSelect g rg- , SqlSelect h rh- , SqlSelect i ri- , SqlSelect j rj- , SqlSelect k rk- , SqlSelect l rl- , SqlSelect m rm- ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm) where- sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m) =- uncommas'- [ sqlSelectCols esc a- , sqlSelectCols esc b- , sqlSelectCols esc c- , sqlSelectCols esc d- , sqlSelectCols esc e- , sqlSelectCols esc f- , sqlSelectCols esc g- , sqlSelectCols esc h- , sqlSelectCols esc i- , sqlSelectCols esc j- , sqlSelectCols esc k- , sqlSelectCols esc l- , sqlSelectCols esc m- ]- sqlSelectColCount = sqlSelectColCount . from13P- sqlSelectProcessRow = fmap to13 . sqlSelectProcessRow--from13P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m)-from13P = const Proxy--to13 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) -> (a,b,c,d,e,f,g,h,i,j,k,l,m)-to13 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) = (a,b,c,d,e,f,g,h,i,j,k,l,m)--instance ( SqlSelect a ra- , SqlSelect b rb- , SqlSelect c rc- , SqlSelect d rd- , SqlSelect e re- , SqlSelect f rf- , SqlSelect g rg- , SqlSelect h rh- , SqlSelect i ri- , SqlSelect j rj- , SqlSelect k rk- , SqlSelect l rl- , SqlSelect m rm- , SqlSelect n rn- ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn) where- sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n) =- uncommas'- [ sqlSelectCols esc a- , sqlSelectCols esc b- , sqlSelectCols esc c- , sqlSelectCols esc d- , sqlSelectCols esc e- , sqlSelectCols esc f- , sqlSelectCols esc g- , sqlSelectCols esc h- , sqlSelectCols esc i- , sqlSelectCols esc j- , sqlSelectCols esc k- , sqlSelectCols esc l- , sqlSelectCols esc m- , sqlSelectCols esc n- ]- sqlSelectColCount = sqlSelectColCount . from14P- sqlSelectProcessRow = fmap to14 . sqlSelectProcessRow--from14P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n))-from14P = const Proxy--to14 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n)-to14 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n)--instance ( SqlSelect a ra- , SqlSelect b rb- , SqlSelect c rc- , SqlSelect d rd- , SqlSelect e re- , SqlSelect f rf- , SqlSelect g rg- , SqlSelect h rh- , SqlSelect i ri- , SqlSelect j rj- , SqlSelect k rk- , SqlSelect l rl- , SqlSelect m rm- , SqlSelect n rn- , SqlSelect o ro- ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn, ro) where- sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) =- uncommas'- [ sqlSelectCols esc a- , sqlSelectCols esc b- , sqlSelectCols esc c- , sqlSelectCols esc d- , sqlSelectCols esc e- , sqlSelectCols esc f- , sqlSelectCols esc g- , sqlSelectCols esc h- , sqlSelectCols esc i- , sqlSelectCols esc j- , sqlSelectCols esc k- , sqlSelectCols esc l- , sqlSelectCols esc m- , sqlSelectCols esc n- , sqlSelectCols esc o- ]- sqlSelectColCount = sqlSelectColCount . from15P- sqlSelectProcessRow = fmap to15 . sqlSelectProcessRow--from15P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n, o) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o)-from15P = const Proxy--to15 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)-to15 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)--instance ( SqlSelect a ra- , SqlSelect b rb- , SqlSelect c rc- , SqlSelect d rd- , SqlSelect e re- , SqlSelect f rf- , SqlSelect g rg- , SqlSelect h rh- , SqlSelect i ri- , SqlSelect j rj- , SqlSelect k rk- , SqlSelect l rl- , SqlSelect m rm- , SqlSelect n rn- , SqlSelect o ro- , SqlSelect p rp- ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn, ro, rp) where- sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) =- uncommas'- [ sqlSelectCols esc a- , sqlSelectCols esc b- , sqlSelectCols esc c- , sqlSelectCols esc d- , sqlSelectCols esc e- , sqlSelectCols esc f- , sqlSelectCols esc g- , sqlSelectCols esc h- , sqlSelectCols esc i- , sqlSelectCols esc j- , sqlSelectCols esc k- , sqlSelectCols esc l- , sqlSelectCols esc m- , sqlSelectCols esc n- , sqlSelectCols esc o- , sqlSelectCols esc p- ]- sqlSelectColCount = sqlSelectColCount . from16P- sqlSelectProcessRow = fmap to16 . sqlSelectProcessRow--from16P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p))-from16P = const Proxy--to16 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)-to16 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)----- | Insert a 'PersistField' for every selected value.------ /Since: 2.4.2/-insertSelect :: (MonadIO m, PersistEntity a) =>- SqlQuery (SqlExpr (Insertion a)) -> SqlWriteT m ()-insertSelect = void . insertSelectCount---- | Insert a 'PersistField' for every selected value, return the count afterward-insertSelectCount :: (MonadIO m, PersistEntity a) =>- SqlQuery (SqlExpr (Insertion a)) -> SqlWriteT m Int64-insertSelectCount = rawEsqueleto INSERT_INTO . fmap EInsertFinal---- | Renders an expression into 'Text'. Only useful for creating a textual--- representation of the clauses passed to an "On" clause.------ @since 3.2.0-renderExpr :: SqlBackend -> SqlExpr (Value Bool) -> T.Text-renderExpr sqlBackend e =- case e of- ERaw _ mkBuilderValues -> do- let (builder, _) = mkBuilderValues (sqlBackend, initialIdentState)- in (builderToText builder)- ECompositeKey mkInfo ->- throw- . RenderExprUnexpectedECompositeKey- . builderToText- . mconcat- . mkInfo- $ (sqlBackend, initialIdentState)- EAliasedValue i _ ->- builderToText $ useIdent (sqlBackend, initialIdentState) i- EValueReference i i' ->- let (builder, _) = valueReferenceToRawSql i i' (sqlBackend, initialIdentState)- in (builderToText builder)--- | An exception thrown by 'RenderExpr' - it's not designed to handle composite--- keys, and will blow up if you give it one.------ @since 3.2.0-data RenderExprException = RenderExprUnexpectedECompositeKey T.Text- deriving Show---- |------ @since 3.2.0-instance Exception RenderExprException+{-# LANGUAGE CPP #-}+{-# language AllowAmbiguousTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# language DerivingStrategies, GeneralizedNewtypeDeriving #-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}++-- | This is an internal module, anything exported by this module+-- may change without a major version bump. Please use only+-- "Database.Esqueleto" if possible.+--+-- If you use this module, please report what your use case is on the issue+-- tracker so we can safely support it.+module Database.Esqueleto.Internal.Internal where++import Data.Typeable (TypeRep, typeRep)+import Data.Coerce (Coercible)+import Control.Applicative ((<|>))+import Control.Arrow (first, (***))+import Control.Exception (Exception, throw, throwIO)+import Control.Monad (MonadPlus(..), guard, void)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Resource (MonadResource, release)+import Data.Acquire (Acquire, allocateAcquire, with)+import Data.Int (Int64)+import Data.List (intersperse)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NEL+import qualified Data.Maybe as Maybe+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup+#endif+import qualified Control.Monad.Trans.Reader as R+import qualified Control.Monad.Trans.State as S+import qualified Control.Monad.Trans.Writer as W+import qualified Data.ByteString as B+import Data.Bifunctor (Bifunctor, bimap)+import Data.Coerce (coerce)+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import qualified Data.HashSet as HS+import Data.Kind (Type)+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import qualified Data.Monoid as Monoid+import Data.Proxy (Proxy(..))+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import Data.Typeable (Typeable)+import Database.Esqueleto.Internal.ExprParser (TableAccess(..), parseOnExpr)+import Database.Esqueleto.Internal.PersistentImport+import Database.Persist (EntityNameDB(..), FieldNameDB(..), SymbolToField(..))+import qualified Database.Persist+import Database.Persist.Sql.Util+ ( entityColumnCount+ , isIdField+ , keyAndEntityColumnNames+ , parseEntityValues+ )+import Database.Persist.SqlBackend+import GHC.Records+import GHC.TypeLits+import Text.Blaze.Html (Html)++-- | (Internal) Start a 'from' query with an entity. 'from'+-- does two kinds of magic using 'fromStart', 'fromJoin' and+-- 'fromFinish':+--+-- 1. The simple but tedious magic of allowing tuples to be+-- used.+--+-- 2. The more advanced magic of creating @JOIN@s. The+-- @JOIN@ is processed from right to left. The rightmost+-- entity of the @JOIN@ is created with 'fromStart'. Each+-- @JOIN@ step is then translated into a call to 'fromJoin'.+-- In the end, 'fromFinish' is called to materialize the+-- @JOIN@.+fromStart+ :: forall a.+ ( PersistEntity a+ , BackendCompatible SqlBackend (PersistEntityBackend a)+ )+ => SqlQuery (PreprocessedFrom (SqlExpr (Entity a)))+fromStart = do+ let ed = entityDef (Proxy :: Proxy a)+ ident <- newIdentFor (coerce $ getEntityDBName ed)+ let ret = unsafeSqlEntity ident+ f' = FromStart ident ed+ return (PreprocessedFrom ret f')++-- | Copied from @persistent@+newtype DBName = DBName { unDBName :: T.Text }++-- | (Internal) Same as 'fromStart', but entity may be missing.+fromStartMaybe+ :: ( PersistEntity a+ , BackendCompatible SqlBackend (PersistEntityBackend a)+ )+ => SqlQuery (PreprocessedFrom (SqlExpr (Maybe (Entity a))))+fromStartMaybe = maybelize <$> fromStart+ where+ maybelize+ :: PreprocessedFrom (SqlExpr (Entity a))+ -> PreprocessedFrom (SqlExpr (Maybe (Entity a)))+ maybelize (PreprocessedFrom e f') = PreprocessedFrom (veryUnsafeCoerceSqlExpr e) f'++-- | (Internal) Do a @JOIN@.+fromJoin+ :: IsJoinKind join+ => PreprocessedFrom a+ -> PreprocessedFrom b+ -> SqlQuery (PreprocessedFrom (join a b))+fromJoin (PreprocessedFrom lhsRet lhsFrom)+ (PreprocessedFrom rhsRet rhsFrom) = Q $ do+ let ret = smartJoin lhsRet rhsRet+ from' =+ FromJoin+ lhsFrom -- LHS+ (reifyJoinKind ret) -- JOIN+ rhsFrom -- RHS+ Nothing -- ON+ return (PreprocessedFrom ret from')++-- | (Internal) Finish a @JOIN@.+fromFinish+ :: PreprocessedFrom a+ -> SqlQuery a+fromFinish (PreprocessedFrom ret f') = Q $ do+ W.tell mempty { sdFromClause = [f'] }+ return ret++-- | @WHERE@ clause: restrict the query's result.+where_ :: SqlExpr (Value Bool) -> SqlQuery ()+where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr }++-- | An @ON@ clause, useful to describe how two tables are related. Cross joins+-- and tuple-joins do not need an 'on' clause, but 'InnerJoin' and the various+-- outer joins do.+--+-- "Database.Esqueleto.Experimental" in version 4.0.0.0 of the library. The+-- @Experimental@ module has a dramatically improved means for introducing+-- tables and entities that provides more power and less potential for runtime+-- errors.+--+-- If you don't include an 'on' clause (or include too many!) then a runtime+-- exception will be thrown.+--+-- As an example, consider this simple join:+--+-- @+-- 'select' $+-- 'from' $ \\(foo `'InnerJoin`` bar) -> do+-- 'on' (foo '^.' FooId '==.' bar '^.' BarFooId)+-- ...+-- @+--+-- We need to specify the clause for joining the two columns together. If we had+-- this:+--+-- @+-- 'select' $+-- 'from' $ \\(foo `'CrossJoin`` bar) -> do+-- ...+-- @+--+-- Then we can safely omit the 'on' clause, because the cross join will make+-- pairs of all records possible.+--+-- You can do multiple 'on' clauses in a query. This query joins three tables,+-- and has two 'on' clauses:+--+-- @+-- 'select' $+-- 'from' $ \\(foo `'InnerJoin`` bar `'InnerJoin`` baz) -> do+-- 'on' (baz '^.' BazId '==.' bar '^.' BarBazId)+-- 'on' (foo '^.' FooId '==.' bar '^.' BarFooId)+-- ...+-- @+--+-- Old versions of esqueleto required that you provide the 'on' clauses in+-- reverse order. This restriction has been lifted - you can now provide 'on'+-- clauses in any order, and the SQL should work itself out. The above query is+-- now totally equivalent to this:+--+-- @+-- 'select' $+-- 'from' $ \\(foo `'InnerJoin`` bar `'InnerJoin`` baz) -> do+-- 'on' (foo '^.' FooId '==.' bar '^.' BarFooId)+-- 'on' (baz '^.' BazId '==.' bar '^.' BarBazId)+-- ...+-- @+on :: SqlExpr (Value Bool) -> SqlQuery ()+on expr = Q $ W.tell mempty { sdFromClause = [OnClause expr] }++-- | @GROUP BY@ clause. You can enclose multiple columns+-- in a tuple.+--+-- @+-- select $ 'from' \\(foo `'InnerJoin`` bar) -> do+-- 'on' (foo '^.' FooBarId '==.' bar '^.' BarId)+-- 'groupBy' (bar '^.' BarId, bar '^.' BarName)+-- return (bar '^.' BarId, bar '^.' BarName, countRows)+-- @+--+-- With groupBy you can sort by aggregate functions, like so+-- (we used @let@ to restrict the more general 'countRows' to+-- @SqlSqlExpr (Value Int)@ to avoid ambiguity---the second use of+-- 'countRows' has its type restricted by the @:: Int@ below):+--+-- @+-- r \<- select $ 'from' \\(foo `'InnerJoin`` bar) -> do+-- 'on' (foo '^.' FooBarId '==.' bar '^.' BarId)+-- 'groupBy' $ bar '^.' BarName+-- let countRows' = 'countRows'+-- 'orderBy' ['asc' countRows']+-- return (bar '^.' BarName, countRows')+-- forM_ r $ \\('Value' name, 'Value' count) -> do+-- print name+-- print (count :: Int)+-- @+--+-- === Need more columns?+--+-- The 'ToSomeValues' class is defined for 'SqlExpr' and tuples of 'SqlExpr's.+-- We only have definitions for up to 8 elements in a tuple right now, so it's+-- possible that you may need to have more than 8 elements.+--+-- For example, consider a query with a 'groupBy' call like this:+--+-- @+-- groupBy (e0, e1, e2, e3, e4, e5, e6, e7)+-- @+--+-- This is the biggest you can get with a single tuple. However, you can easily+-- nest the tuples to add more:+--+-- @+-- groupBy ((e0, e1, e2, e3, e4, e5, e6, e7), e8, e9)+-- @+groupBy :: (ToSomeValues a) => a -> SqlQuery ()+groupBy expr = Q $ W.tell mempty { sdGroupByClause = GroupBy $ toSomeValues expr }++-- | An alias for 'groupBy' that avoids conflict with the term from "Data.List"+-- 'Data.List.groupBy'.+--+-- @since 3.5.10.0+groupBy_ :: (ToSomeValues a) => a -> SqlQuery ()+groupBy_ = groupBy++-- | @ORDER BY@ clause. See also 'asc' and 'desc'.+--+-- Multiple calls to 'orderBy' get concatenated on the final+-- query, including 'distinctOnOrderBy'.+orderBy :: [SqlExpr OrderBy] -> SqlQuery ()+orderBy exprs = Q $ W.tell mempty { sdOrderByClause = exprs }++-- | Ascending order of this field or SqlExpression.+asc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy+asc = orderByExpr " ASC"++-- | Descending order of this field or SqlExpression.+desc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy+desc = orderByExpr " DESC"++orderByExpr :: TLB.Builder -> SqlExpr (Value a) -> SqlExpr OrderBy+orderByExpr orderByType (ERaw m f)+ | Just fields <- sqlExprMetaCompositeFields m =+ ERaw noMeta $ \_ info ->+ let fs = fields info+ vals = repeat []+ in uncommas' $ zip (map (<> orderByType) fs) vals+ | otherwise =+ ERaw noMeta $ \_ info ->+ first (<> orderByType) $ f Never info++-- | @LIMIT@. Limit the number of returned rows.+limit :: Int64 -> SqlQuery ()+limit n = Q $ W.tell mempty { sdLimitClause = Limit (Just n) Nothing }++-- | @OFFSET@. Usually used with 'limit'.+offset :: Int64 -> SqlQuery ()+offset n = Q $ W.tell mempty { sdLimitClause = Limit Nothing (Just n) }++-- | @DISTINCT@. Change the current @SELECT@ into @SELECT+-- DISTINCT@. For example:+--+-- @+-- select $ distinct $+-- 'from' \\foo -> do+-- ...+-- @+--+-- Note that this also has the same effect:+--+-- @+-- select $+-- 'from' \\foo -> do+-- distinct (return ())+-- ...+-- @+--+-- @since 2.2.4+distinct :: SqlQuery a -> SqlQuery a+distinct act = Q (W.tell mempty { sdDistinctClause = DistinctStandard }) >> act++-- | @DISTINCT ON@. Change the current @SELECT@ into+-- @SELECT DISTINCT ON (SqlExpressions)@. For example:+--+-- @+-- select $+-- 'from' \\foo ->+-- 'distinctOn' ['don' (foo ^. FooName), 'don' (foo ^. FooState)] $ do+-- ...+-- @+--+-- You can also chain different calls to 'distinctOn'. The+-- above is equivalent to:+--+-- @+-- select $+-- 'from' \\foo ->+-- 'distinctOn' ['don' (foo ^. FooName)] $+-- 'distinctOn' ['don' (foo ^. FooState)] $ do+-- ...+-- @+--+-- Each call to 'distinctOn' adds more SqlExpressions. Calls to+-- 'distinctOn' override any calls to 'distinct'.+--+-- Note that PostgreSQL requires the SqlExpressions on @DISTINCT+-- ON@ to be the first ones to appear on a @ORDER BY@. This is+-- not managed automatically by esqueleto, keeping its spirit+-- of trying to be close to raw SQL.+--+-- Supported by PostgreSQL only.+--+-- @since 2.2.4+distinctOn :: [SqlExpr DistinctOn] -> SqlQuery a -> SqlQuery a+distinctOn exprs act = Q (W.tell mempty { sdDistinctClause = DistinctOn exprs }) >> act++{-# DEPRECATED distinctOn "This function is deprecated, as it is only supported in Postgresql. Please use the variant in `Database.Esqueleto.PostgreSQL` instead." #-}++-- | Erase an SqlExpression's type so that it's suitable to+-- be used by 'distinctOn'.+--+-- @since 2.2.4+don :: SqlExpr (Value a) -> SqlExpr DistinctOn+don = veryUnsafeCoerceSqlExpr++-- | A convenience function that calls both 'distinctOn' and+-- 'orderBy'. In other words,+--+-- @+-- 'distinctOnOrderBy' [asc foo, desc bar, desc quux] $ do+-- ...+-- @+--+-- is the same as:+--+-- @+-- 'distinctOn' [don foo, don bar, don quux] $ do+-- 'orderBy' [asc foo, desc bar, desc quux]+-- ...+-- @+--+-- @since 2.2.4+distinctOnOrderBy :: [SqlExpr OrderBy] -> SqlQuery a -> SqlQuery a+distinctOnOrderBy exprs act =+ distinctOn (toDistinctOn <$> exprs) $ do+ orderBy exprs+ act+ where+ toDistinctOn :: SqlExpr OrderBy -> SqlExpr DistinctOn+ toDistinctOn (ERaw m f) = ERaw m $ \p info ->+ let (b, vals) = f p info+ in ( TLB.fromLazyText+ $ TL.replace " DESC" ""+ $ TL.replace " ASC" ""+ $ TLB.toLazyText b+ , vals )++{-# DEPRECATED distinctOnOrderBy "This function is deprecated, as it is only supported in Postgresql. Please use the function defined in `Database.Esqueleto.PostgreSQL` instead." #-}++-- | @HAVING@.+--+-- @since 1.2.2+having :: SqlExpr (Value Bool) -> SqlQuery ()+having expr = Q $ W.tell mempty { sdHavingClause = Where expr }++-- | Add a locking clause to the query. Please read+-- 'LockingKind' documentation and your RDBMS manual.+-- Unsafe since not all locking clauses are implemented for every RDBMS+--+-- If multiple calls to 'locking' are made on the same query,+-- the last one is used.+--+-- @since 2.2.7+locking :: LockingKind -> SqlQuery ()+locking kind = putLocking $ LegacyLockingClause kind++-- | Helper to add a any type of locking clause to a query+--+-- @since 3.5.9.0+putLocking :: LockingClause -> SqlQuery ()+putLocking clause = Q $ W.tell mempty { sdLockingClause = clause }++-- | Execute a subquery @SELECT@ in a 'SqlExpr'. The query passed to this+-- function will only return a single result - it has a @LIMIT 1@ passed in to+-- the query to make it safe, and the return type is 'Maybe' to indicate that+-- the subquery might result in 0 rows.+--+-- If you find yourself writing @'joinV' . 'subSelect'@, then consider using+-- 'subSelectMaybe'.+--+-- If you're performing a 'countRows', then you can use 'subSelectCount' which+-- is safe.+--+-- If you know that the subquery will always return exactly one row (eg+-- a foreign key constraint guarantees that you'll get exactly one row), then+-- consider 'subSelectUnsafe', along with a comment explaining why it is safe.+--+-- @since 3.2.0+subSelect+ :: (PersistField a, NullableFieldProjection a a')+ => SqlQuery (SqlExpr (Value a))+ -> SqlExpr (Value (Maybe a'))+subSelect query = just (subSelectUnsafe (query <* limit 1))++-- | Execute a subquery @SELECT@ in a 'SqlExpr'. This function is a shorthand+-- for the common @'joinV' . 'subSelect'@ idiom, where you are calling+-- 'subSelect' on an expression that would be 'Maybe' already.+--+-- As an example, you would use this function when calling 'sum_' or 'max_',+-- which have 'Maybe' in the result type (for a 0 row query).+--+-- @since 3.2.0+subSelectMaybe+ :: PersistField a+ => SqlQuery (SqlExpr (Value (Maybe a)))+ -> SqlExpr (Value (Maybe a))+subSelectMaybe = joinV . subSelect++-- | Performs a @COUNT@ of the given query in a @subSelect@ manner. This is+-- always guaranteed to return a result value, and is completely safe.+--+-- @since 3.2.0+subSelectCount+ :: (Num a, PersistField a)+ => SqlQuery ignored+ -> SqlExpr (Value a)+subSelectCount query =+ subSelectUnsafe $ do+ _ <- query+ pure countRows++-- | Execute a subquery @SELECT@ in a 'SqlExpr' that returns a list. This is an+-- alias for 'subList_select' and is provided for symmetry with the other safe+-- subselect functions.+--+-- @since 3.2.0+subSelectList+ :: PersistField a+ => SqlQuery (SqlExpr (Value a))+ -> SqlExpr (ValueList a)+subSelectList = subList_select++-- | Performs a sub-select using the given foreign key on the entity. This is+-- useful to extract values that are known to be present by the database schema.+--+-- As an example, consider the following persistent definition:+--+-- @+-- User+-- profile ProfileId+--+-- Profile+-- name Text+-- @+--+-- The following query will return the name of the user.+--+-- @+-- getUserWithName =+-- 'select' $+-- 'from' $ \user ->+-- 'pure' (user, 'subSelectForeign' user UserProfile (^. ProfileName)+-- @+--+-- @since 3.2.0+subSelectForeign+ ::+ ( BackendCompatible SqlBackend (PersistEntityBackend val1)+ , PersistEntity val1, PersistEntity val2, PersistField a+ )+ => SqlExpr (Entity val2)+ -- ^ An expression representing the table you have access to now.+ -> EntityField val2 (Key val1)+ -- ^ The foreign key field on the table.+ -> (SqlExpr (Entity val1) -> SqlExpr (Value a))+ -- ^ A function to extract a value from the foreign reference table.+ -> SqlExpr (Value a)+subSelectForeign expr foreignKey k =+ subSelectUnsafe $+ from $ \table -> do+ where_ $ expr ^. foreignKey ==. table ^. persistIdField+ pure (k table)++-- | Execute a subquery @SELECT@ in a 'SqlExpr'. This function is unsafe,+-- because it can throw runtime exceptions in two cases:+--+-- 1. If the query passed has 0 result rows, then it will return a @NULL@ value.+-- The @persistent@ parsing operations will fail on an unexpected @NULL@.+-- 2. If the query passed returns more than one row, then the SQL engine will+-- fail with an error like "More than one row returned by a subquery used as+-- an expression".+--+-- This function is safe if you guarantee that exactly one row will be returned,+-- or if the result already has a 'Maybe' type for some reason.+--+-- For variants with the safety encoded already, see 'subSelect' and+-- 'subSelectMaybe'. For the most common safe use of this, see 'subSelectCount'.+--+-- @since 3.2.0+subSelectUnsafe :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)+subSelectUnsafe = sub SELECT++-- | Project a field of an entity.+(^.) :: forall typ val . (PersistEntity val, PersistField typ)+ => SqlExpr (Entity val)+ -> EntityField val typ+ -> SqlExpr (Value typ)+ERaw m f ^. field+ | isIdField field = idFieldValue+ | Just alias <- sqlExprMetaAlias m =+ ERaw noMeta $ \_ info ->+ f Never info <> ("." <> useIdent info (aliasedEntityColumnIdent alias fieldDef), [])+ | otherwise = ERaw noMeta $ \_ info -> (dot info $ persistFieldDef field, [])+ where+ fieldDef =+ if isIdField field then+ -- TODO what about composite natural keys in a join this will ignore them+ NEL.head $ getEntityKeyFields ed+ else+ persistFieldDef field+ idFieldValue =+ case getEntityKeyFields ed of+ idField :| [] ->+ ERaw noMeta $ \_ info -> (dot info idField, [])++ idFields ->+ let renderedFields info = dot info <$> NEL.toList idFields+ in ERaw noMeta{ sqlExprMetaCompositeFields = Just renderedFields} $+ \p info -> (parensM p $ uncommas $ renderedFields info, [])++ ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val)))++ dot info fieldDef' =+ sourceIdent info <> "." <> fieldIdent+ where+ sourceIdent = fmap fst $ f Never+ fieldIdent+ | Just baseI <- sqlExprMetaAlias m =+ useIdent info $ aliasedEntityColumnIdent baseI fieldDef'+ | otherwise =+ fromDBName info (coerce $ fieldDB fieldDef')++-- | Project an SqlExpression that may be null, guarding against null cases.+withNonNull+ :: PersistField typ+ => SqlExpr (Value (Maybe typ))+ -> (SqlExpr (Value typ) -> SqlQuery a)+ -> SqlQuery a+withNonNull field f = do+ where_ $ not_ $ isNothing field+ f $ veryUnsafeCoerceSqlExprValue field++-- | Project an 'EntityField' of a nullable entity. The result type will be+-- 'Nullable', meaning that nested 'Maybe' won't be produced here.+--+-- As of v3.6.0.0, this will attempt to combine nested 'Maybe'. If you want to+-- keep nested 'Maybe', then see '??.'.+(?.) :: (PersistEntity val , PersistField typ)+ => SqlExpr (Maybe (Entity val))+ -> EntityField val typ+ -> SqlExpr (Value (Maybe (Nullable typ)))+ent ?. field = veryUnsafeCoerceSqlExprValue (ent ??. field)++-- | Project a field of an entity that may be null.+--+-- This variant will produce a nested 'Maybe' if you select a 'Maybe' column.+-- If you want to collapse 'Maybe', see '?.'.+--+-- @since 3.6.0.0+(??.) :: ( PersistEntity val , PersistField typ)+ => SqlExpr (Maybe (Entity val))+ -> EntityField val typ+ -> SqlExpr (Value (Maybe typ))+ERaw m f ??. field = just (ERaw m f ^. field)++-- | Lift a constant value from Haskell-land to the query.+val :: PersistField typ => typ -> SqlExpr (Value typ)+val v = ERaw noMeta $ \_ _ -> ("?", [toPersistValue v])++-- | @IS NULL@ comparison.+--+-- For @IS NOT NULL@, you can negate this with 'not_', as in @not_ (isNothing (person ^. PersonAge))@+--+-- Warning: Persistent and Esqueleto have different behavior for @!= Nothing@:+--+-- +----------------+----------------------------------+---------------++-- | | Haskell | SQL |+-- +================+==================================+===============++-- | __Persistent__ | @'Database.Persist.!=.' Nothing@ | @IS NOT NULL@ |+-- +----------------+----------------------------------+---------------++-- | __Esqueleto__ | @'!=.' Nothing@ | @!= NULL@ |+-- +----------------+----------------------------------+---------------++--+-- In SQL, @= NULL@ and @!= NULL@ return NULL instead of true or false. For this reason, you very likely do not want to use @'!=.' Nothing@ in Esqueleto.+-- You may find these @hlint@ rules helpful to enforce this:+--+-- > - error: {lhs: v Database.Esqueleto.==. Database.Esqueleto.nothing, rhs: Database.Esqueleto.isNothing v, name: Use Esqueleto's isNothing}+-- > - error: {lhs: v Database.Esqueleto.==. Database.Esqueleto.val Nothing, rhs: Database.Esqueleto.isNothing v, name: Use Esqueleto's isNothing}+-- > - error: {lhs: v Database.Esqueleto.!=. Database.Esqueleto.nothing, rhs: not_ (Database.Esqueleto.isNothing v), name: Use Esqueleto's not isNothing}+-- > - error: {lhs: v Database.Esqueleto.!=. Database.Esqueleto.val Nothing, rhs: not_ (Database.Esqueleto.isNothing v), name: Use Esqueleto's not isNothing}+isNothing :: PersistField typ => SqlExpr (Value (Maybe typ)) -> SqlExpr (Value Bool)+isNothing v =+ case v of+ ERaw m f ->+ case sqlExprMetaCompositeFields m of+ Just fields ->+ ERaw noMeta $ \p info ->+ first (parensM p) . flip (,) [] . (intersperseB " AND " . map (<> " IS NULL")) $ fields info+ Nothing ->+ ERaw noMeta $ \p info ->+ first (parensM p) . isNullExpr $ f Never info+ where+ isNullExpr :: (TLB.Builder, a) -> (TLB.Builder, a)+ isNullExpr = first ((<> " IS NULL"))++-- | An alias for 'isNothing' that avoids clashing with the function from+-- "Data.Maybe" 'Data.Maybe.isNothing'.+--+-- @since 3.5.10.0+isNothing_ :: PersistField typ => SqlExpr (Value (Maybe typ)) -> SqlExpr (Value Bool)+isNothing_ = isNothing++-- | Analogous to 'Just', promotes a value of type @typ@ into+-- one of type @Maybe typ@. It should hold that @'val' . Just+-- === just . 'val'@.+--+-- This function will try not to produce a nested 'Maybe'. This is in accord+-- with how SQL represents @NULL@. That means that @'just' . 'just' = 'just'@.+-- This behavior was changed in v3.6.0.0. If you want to produce nested 'Maybe',+-- see 'just''.+just+ :: (NullableFieldProjection typ typ')+ => SqlExpr (Value typ) -> SqlExpr (Value (Maybe typ'))+just = veryUnsafeCoerceSqlExprValue++-- | Like 'just', but this function does not try to collapse nested 'Maybe'.+-- This may be useful if you have type inference problems with 'just'.+--+-- @since 3.6.0.0+just' :: SqlExpr (Value typ) -> SqlExpr (Value (Maybe typ))+just' = veryUnsafeCoerceSqlExprValue++-- | @NULL@ value.+nothing :: SqlExpr (Value (Maybe typ))+nothing = unsafeSqlValue "NULL"++-- | Join nested 'Maybe's in a 'Value' into one. This is useful when+-- calling aggregate functions on nullable fields.+--+-- As of v3.6.0.0, this function will attempt to work on both @'SqlExpr'+-- ('Value' ('Maybe' a))@ as well as @'SqlExpr' ('Value' ('Maybe' ('Maybe' a)))@+-- inputs to make transitioning to 'NullableFieldProjection' easier. This may+-- make type inference worse in some cases. If you want the monomorphic variant,+-- see 'joinV''+joinV+ :: (NullableFieldProjection typ typ')+ => SqlExpr (Value (Maybe typ))+ -> SqlExpr (Value (Maybe typ'))+joinV = veryUnsafeCoerceSqlExprValue++-- | Like 'joinV', but monomorphic: the input type only works on @'SqlExpr'+-- ('Value' (Maybe (Maybe a)))@.+--+-- This function may be useful if you have type inference issues with 'joinV'.+--+-- @since 3.6.0.0+joinV'+ :: SqlExpr (Value (Maybe (Maybe typ)))+ -> SqlExpr (Value (Maybe typ))+joinV' = veryUnsafeCoerceSqlExprValue+++countHelper :: Num a => TLB.Builder -> TLB.Builder -> SqlExpr (Value typ) -> SqlExpr (Value a)+countHelper open close v =+ case v of+ ERaw meta f ->+ if hasCompositeKeyMeta meta then+ countRows+ else+ countRawSql (f Never)+ where+ countRawSql :: (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a)+ countRawSql x = ERaw noMeta $ \_ -> first (\b -> "COUNT" <> open <> parens b <> close) . x++-- | @COUNT(*)@ value.+countRows :: Num a => SqlExpr (Value a)+countRows = unsafeSqlValue "COUNT(*)"++-- | @COUNT@.+count :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a)+count = countHelper "" ""++-- | @COUNT(DISTINCT x)@.+--+-- @since 2.4.1+countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a)+countDistinct = countHelper "(DISTINCT " ")"++not_ :: SqlExpr (Value Bool) -> SqlExpr (Value Bool)+not_ v = ERaw noMeta (const $ first ("NOT " <>) . x)+ where+ x info =+ case v of+ ERaw m f ->+ if hasCompositeKeyMeta m then+ throw (CompositeKeyErr NotError)+ else+ f Parens info++-- | This operator produces the SQL operator @=@, which is used to compare+-- values for equality.+--+-- Example:+--+-- @+-- query :: UserId -> SqlPersistT IO [Entity User]+-- query userId = select $ do+-- user <- from $ table \@User+-- where_ (user ^. UserId ==. val userId)+-- pure user+-- @+--+-- This would generate the following SQL:+--+-- @+-- SELECT user.*+-- FROM user+-- WHERE user.id = ?+-- @+(==.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)+(==.) = unsafeSqlBinOpComposite " = " " AND "++-- | This operator translates to the SQL operator @>=@.+--+-- Example:+--+-- @+-- where_ $ user ^. UserAge >=. val 21+-- @+(>=.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)+(>=.) = unsafeSqlBinOp " >= "++-- | This operator translates to the SQL operator @>@.+--+-- Example:+--+-- @+-- where_ $ user ^. UserAge >. val 20+-- @+(>.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)+(>.) = unsafeSqlBinOp " > "++-- | This operator translates to the SQL operator @<=@.+--+-- Example:+--+-- @+-- where_ $ val 21 <=. user ^. UserAge+-- @+(<=.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)+(<=.) = unsafeSqlBinOp " <= "++-- | This operator translates to the SQL operator @<@.+--+-- Example:+--+-- @+-- where_ $ val 20 <. user ^. UserAge+-- @+(<.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)+(<.) = unsafeSqlBinOp " < "++-- | This operator translates to the SQL operator @!=@.+--+-- Example:+--+-- @+-- where_ $ user ^. UserName !=. val "Bob"+-- @+(!=.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)+(!=.) = unsafeSqlBinOpComposite " != " " OR "++-- | This operator translates to the SQL operator @AND@.+--+-- Example:+--+-- @+-- where_ $+-- user ^. UserName ==. val "Matt"+-- &&. user ^. UserAge >=. val 21+-- @+(&&.) :: SqlExpr (Value Bool) -> SqlExpr (Value Bool) -> SqlExpr (Value Bool)+(&&.) = unsafeSqlBinOp " AND "++-- | This operator translates to the SQL operator @AND@.+--+-- Example:+--+-- @+-- where_ $+-- user ^. UserName ==. val "Matt"+-- ||. user ^. UserName ==. val "John"+-- @+(||.) :: SqlExpr (Value Bool) -> SqlExpr (Value Bool) -> SqlExpr (Value Bool)+(||.) = unsafeSqlBinOp " OR "++-- | This operator translates to the SQL operator @+@.+--+-- This does not require or assume anything about the SQL values. Interpreting+-- what @+.@ means for a given type is left to the database engine.+--+-- Example:+--+-- @+-- user ^. UserAge +. val 10+-- @+(+.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a)+(+.) = unsafeSqlBinOp " + "++-- | This operator translates to the SQL operator @-@.+--+-- This does not require or assume anything about the SQL values. Interpreting+-- what @-.@ means for a given type is left to the database engine.+--+-- Example:+--+-- @+-- user ^. UserAge -. val 10+-- @+(-.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a)+(-.) = unsafeSqlBinOp " - "++-- | This operator translates to the SQL operator @/@.+--+-- This does not require or assume anything about the SQL values. Interpreting+-- what @/.@ means for a given type is left to the database engine.+--+-- Example:+--+-- @+-- user ^. UserAge /. val 10+-- @+(/.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a)+(/.) = unsafeSqlBinOp " / "++-- | This operator translates to the SQL operator @*@.+--+-- This does not require or assume anything about the SQL values. Interpreting+-- what @*.@ means for a given type is left to the database engine.+--+-- Example:+--+-- @+-- user ^. UserAge *. val 10+-- @+(*.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a)+(*.) = unsafeSqlBinOp " * "++-- | @a `between` (b, c)@ translates to the SQL expression @a >= b AND a <= c@.+-- It does not use a SQL @BETWEEN@ operator.+--+-- @since: 3.1.0+between :: PersistField a => SqlExpr (Value a) -> (SqlExpr (Value a), SqlExpr (Value a)) -> SqlExpr (Value Bool)+a `between` (b, c) = a >=. b &&. a <=. c++round_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr (Value a) -> SqlExpr (Value b)+round_ = unsafeSqlFunction "ROUND"++ceiling_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr (Value a) -> SqlExpr (Value b)+ceiling_ = unsafeSqlFunction "CEILING"++floor_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr (Value a) -> SqlExpr (Value b)+floor_ = unsafeSqlFunction "FLOOR"++sum_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr (Value (Maybe b))+sum_ = unsafeSqlFunction "SUM"++min_+ :: (PersistField a)+ => SqlExpr (Value a)+ -> SqlExpr (Value (Maybe (Nullable a)))+min_ = unsafeSqlFunction "MIN"++max_+ :: (PersistField a)+ => SqlExpr (Value a)+ -> SqlExpr (Value (Maybe (Nullable a)))+max_ = unsafeSqlFunction "MAX"++avg_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr (Value (Maybe b))+avg_ = unsafeSqlFunction "AVG"++-- | Allow a number of one type to be used as one of another+-- type via an implicit cast. An explicit cast is not made,+-- this function changes only the types on the Haskell side.+--+-- /Caveat/: Trying to use @castNum@ from @Double@ to @Int@+-- will not result in an integer, the original fractional+-- number will still be used! Use 'round_', 'ceiling_' or+-- 'floor_' instead.+--+-- /Safety/: This operation is mostly safe due to the 'Num'+-- constraint between the types and the fact that RDBMSs+-- usually allow numbers of different types to be used+-- interchangeably. However, there may still be issues with+-- the query not being accepted by the RDBMS or @persistent@+-- not being able to parse it.+--+-- @since 2.2.9+castNum :: (Num a, Num b) => SqlExpr (Value a) -> SqlExpr (Value b)+castNum = veryUnsafeCoerceSqlExprValue++-- | Same as 'castNum', but for nullable values.+--+-- @since 2.2.9+castNumM :: (Num a, Num b) => SqlExpr (Value (Maybe a)) -> SqlExpr (Value (Maybe b))+castNumM = veryUnsafeCoerceSqlExprValue++-- | @COALESCE@ function. Evaluates the arguments in order and+-- returns the value of the first non-NULL SqlExpression, or NULL+-- (Nothing) otherwise. Some RDBMSs (such as SQLite) require+-- at least two arguments; please refer to the appropriate+-- documentation.+--+-- @since 1.4.3+coalesce+ :: (PersistField a, NullableFieldProjection a a')+ => [SqlExpr (Value (Maybe a))]+ -> SqlExpr (Value (Maybe a'))+coalesce = unsafeSqlFunctionParens "COALESCE"++-- | Like @coalesce@, but takes a non-nullable SqlExpression+-- placed at the end of the SqlExpression list, which guarantees+-- a non-NULL result.+--+-- @since 1.4.3+coalesceDefault :: PersistField a => [SqlExpr (Value (Maybe a))] -> SqlExpr (Value a) -> SqlExpr (Value a)+coalesceDefault exprs = unsafeSqlFunctionParens "COALESCE" . (exprs ++) . return . just++-- | @LOWER@ function.+lower_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s)+lower_ = unsafeSqlFunction "LOWER"++-- | @UPPER@ function.+-- @since 3.3.0+upper_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s)+upper_ = unsafeSqlFunction "UPPER"++-- | @TRIM@ function.+-- @since 3.3.0+trim_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s)+trim_ = unsafeSqlFunction "TRIM"++-- | @RTRIM@ function.+-- @since 3.3.0+rtrim_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s)+rtrim_ = unsafeSqlFunction "RTRIM"++-- | @LTRIM@ function.+-- @since 3.3.0+ltrim_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s)+ltrim_ = unsafeSqlFunction "LTRIM"++-- | @LENGTH@ function.+-- @since 3.3.0+length_ :: (SqlString s, Num a) => SqlExpr (Value s) -> SqlExpr (Value a)+length_ = unsafeSqlFunction "LENGTH"++-- | @LEFT@ function.+-- @since 3.3.0+left_ :: (SqlString s, Num a) => (SqlExpr (Value s), SqlExpr (Value a)) -> SqlExpr (Value s)+left_ = unsafeSqlFunction "LEFT"++-- | @RIGHT@ function.+-- @since 3.3.0+right_ :: (SqlString s, Num a) => (SqlExpr (Value s), SqlExpr (Value a)) -> SqlExpr (Value s)+right_ = unsafeSqlFunction "RIGHT"++-- | @LIKE@ operator.+like :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value Bool)+like = unsafeSqlBinOp " LIKE "++-- | @ILIKE@ operator (case-insensitive @LIKE@).+--+-- Supported by PostgreSQL only. Deprecated in version 3.6.0 in favor of the+-- version available from "Database.Esqueleto.PostgreSQL".+--+-- @since 2.2.3+ilike :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value Bool)+ilike = unsafeSqlBinOp " ILIKE "++{-# DEPRECATED ilike "Since 3.6.0: `ilike` is only supported on Postgres. Please import it from 'Database.Esqueleto.PostgreSQL." #-}++-- | The string @'%'@. May be useful while using 'like' and+-- concatenation ('concat_' or '++.', depending on your+-- database). Note that you always have to type the parenthesis,+-- for example:+--+-- @+-- name `'like`` (%) ++. 'val' \"John\" ++. (%)+-- @+(%) :: SqlString s => SqlExpr (Value s)+(%) = unsafeSqlValue "'%'"++-- | The @CONCAT@ function with a variable number of+-- parameters. Supported by MySQL and PostgreSQL. SQLite supports this in+-- versions after 3.44.0, and @persistent-sqlite@ supports this in versions+-- @2.13.3.0@ and after.+concat_ :: SqlString s => [SqlExpr (Value s)] -> SqlExpr (Value s)+concat_ = unsafeSqlFunction "CONCAT"++-- | The @||@ string concatenation operator (named after+-- Haskell's '++' in order to avoid naming clash with '||.').+--+-- Supported by SQLite and PostgreSQL.+--+-- MySQL support requires setting the SQL mode to @PIPES_AS_CONCAT@ or @ANSI@+-- - see <https://stackoverflow.com/a/24777235 this StackOverflow answer>.+(++.) :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value s)+(++.) = unsafeSqlBinOp " || "++-- | Cast a string type into 'Text'. This function+-- is very useful if you want to use @newtype@s, or if you want+-- to apply functions such as 'like' to strings of different+-- types.+--+-- /Safety:/ This is a slightly unsafe function, especially if+-- you have defined your own instances of 'SqlString'. Also,+-- since 'Maybe' is an instance of 'SqlString', it's possible+-- to turn a nullable value into a non-nullable one. Avoid+-- using this function if possible.+castString :: (SqlString s, SqlString r) => SqlExpr (Value s) -> SqlExpr (Value r)+castString = veryUnsafeCoerceSqlExprValue++-- | Execute a subquery @SELECT@ in an SqlExpression. Returns a+-- list of values.+subList_select :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (ValueList a)+subList_select query = ERaw noMeta $ \_ info -> first parens $ toRawSql SELECT info query+++-- | Lift a list of constant value from Haskell-land to the query.+valList :: PersistField typ => [typ] -> SqlExpr (ValueList typ)+valList [] = ERaw noMeta $ \_ _ -> ("()", [])+valList vals = ERaw noMeta $ \p -> const (parensM p (uncommas ("?" <$ vals)), map toPersistValue vals )++-- | Same as 'just' but for 'ValueList'. Most of the time you+-- won't need it, though, because you can use 'just' from+-- inside 'subList_select' or 'Just' from inside 'valList'.+--+-- @since 2.2.12+justList :: SqlExpr (ValueList typ) -> SqlExpr (ValueList (Maybe typ))+justList (ERaw m f) = ERaw m f++-- | @IN@ operator. For example if you want to select all @Person@s by a list+-- of IDs:+--+-- @+-- SELECT *+-- FROM Person+-- WHERE Person.id IN (?)+-- @+--+-- In @esqueleto@, we may write the same query above as:+--+-- @+-- select $+-- 'from' $ \\person -> do+-- 'where_' $ person '^.' PersonId `'in_`` 'valList' personIds+-- return person+-- @+--+-- Where @personIds@ is of type @[Key Person]@.+in_ :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (ValueList typ) -> SqlExpr (Value Bool)+(ERaw _ v) `in_` (ERaw _ list) =+ ERaw noMeta $ \_ info ->+ let (b1, vals1) = v Parens info+ (b2, vals2) = list Parens info+ in+ if b2 == "()" then+ ("FALSE", [])+ else+ (b1 <> " IN " <> b2, vals1 <> vals2)++-- | @NOT IN@ operator.+notIn :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (ValueList typ) -> SqlExpr (Value Bool)+(ERaw _ v) `notIn` (ERaw _ list) =+ ERaw noMeta $ \_ info ->+ let (b1, vals1) = v Parens info+ (b2, vals2) = list Parens info+ in+ if b2 == "()" then+ ("TRUE", [])+ else+ (b1 <> " NOT IN " <> b2, vals1 <> vals2)++-- | @EXISTS@ operator. For example:+--+-- @+-- select $+-- 'from' $ \\person -> do+-- 'where_' $ 'exists' $+-- 'from' $ \\post -> do+-- 'where_' (post '^.' BlogPostAuthorId '==.' person '^.' PersonId)+-- return person+-- @+exists :: SqlQuery () -> SqlExpr (Value Bool)+exists q = ERaw noMeta $ \p info ->+ let ERaw _ f = existsHelper q+ (b, vals) = f Never info+ in ( parensM p $ "EXISTS " <> b, vals)++-- | @NOT EXISTS@ operator.+notExists :: SqlQuery () -> SqlExpr (Value Bool)+notExists q = ERaw noMeta $ \p info ->+ let ERaw _ f = existsHelper q+ (b, vals) = f Never info+ in ( parensM p $ "NOT EXISTS " <> b, vals)++-- | @SET@ clause used on @UPDATE@s. Note that while it's not+-- a type error to use this function on a @SELECT@, it will+-- most certainly result in a runtime error.+set :: PersistEntity val => SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update] -> SqlQuery ()+set ent upds = Q $ W.tell mempty { sdSetClause = map apply upds }+ where+ apply f = SetClause (f ent)++(=.) :: (PersistEntity val, PersistField typ) => EntityField val typ -> SqlExpr (Value typ) -> (SqlExpr (Entity val) -> SqlExpr Update )+field =. expr = setAux field (const expr)++(+=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> (SqlExpr (Entity val) -> SqlExpr Update)+field +=. expr = setAux field (\ent -> ent ^. field +. expr)++(-=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> (SqlExpr (Entity val) -> SqlExpr Update)+field -=. expr = setAux field (\ent -> ent ^. field -. expr)++(*=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> (SqlExpr (Entity val) -> SqlExpr Update)+field *=. expr = setAux field (\ent -> ent ^. field *. expr)++(/=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> (SqlExpr (Entity val) -> SqlExpr Update)+field /=. expr = setAux field (\ent -> ent ^. field /. expr)++-- | Apply a 'PersistField' constructor to @SqlExpr Value@ arguments.+(<#) :: (a -> b) -> SqlExpr (Value a) -> SqlExpr (Insertion b)+(<#) _ (ERaw _ f) = ERaw noMeta f++-- | Apply extra @SqlExpr Value@ arguments to a 'PersistField' constructor+(<&>) :: SqlExpr (Insertion (a -> b)) -> SqlExpr (Value a) -> SqlExpr (Insertion b)+(ERaw _ f) <&> (ERaw _ g) =+ ERaw noMeta $ \_ info ->+ let (fb, fv) = f Never info+ (gb, gv) = g Never info+ in (fb <> ", " <> gb, fv ++ gv)++-- | @CASE@ statement. For example:+--+-- @+-- select $+-- return $+-- 'case_'+-- [ 'when_'+-- ('exists' $+-- 'from' $ \\p -> do+-- 'where_' (p '^.' PersonName '==.' 'val' \"Mike\"))+-- 'then_'+-- ('subSelect' $+-- 'from' $ \\v -> do+-- let sub =+-- 'from' $ \\c -> do+-- 'where_' (c '^.' PersonName '==.' 'val' \"Mike\")+-- return (c '^.' PersonFavNum)+-- 'where_' ('just' (v '^.' PersonFavNum) >. 'subSelect' sub)+-- return $ 'count' (v '^.' PersonName) +. 'val' (1 :: Int)) ]+-- ('else_' $ 'val' (-1))+-- @+--+-- This query is a bit complicated, but basically it checks if a person+-- named @\"Mike\"@ exists, and if that person does, run the subquery to find+-- out how many people have a ranking (by Fav Num) higher than @\"Mike\"@.+--+-- __NOTE:__ There are a few things to be aware about this statement.+--+-- * This only implements the full CASE statement, it does not+-- implement the \"simple\" CASE statement.+--+--+-- * At least one 'when_' and 'then_' is mandatory otherwise it will+-- emit an error.+--+--+-- * The 'else_' is also mandatory, unlike the SQL statement in which+-- if the @ELSE@ is omitted it will return a @NULL@. You can+-- reproduce this via 'nothing'.+--+-- @since 2.1.2+case_ :: PersistField a => [(SqlExpr (Value Bool), SqlExpr (Value a))] -> SqlExpr (Value a) -> SqlExpr (Value a)+case_ = unsafeSqlCase++-- | Convert an entity's key into another entity's.+--+-- This function is to be used when you change an entity's @Id@ to be+-- that of another entity. For example:+--+-- @+-- Bar+-- barNum Int+-- Foo+-- bar BarId+-- fooNum Int+-- Primary bar+-- @+--+-- In this example, Bar is said to be the BaseEnt(ity), and Foo the child.+-- To model this in Esqueleto, declare:+--+-- @+-- instance ToBaseId Foo where+-- type BaseEnt Foo = Bar+-- toBaseIdWitness barId = FooKey barId+-- @+--+-- Now you're able to write queries such as:+--+-- @+-- 'select' $+-- 'from' $ \(bar `'InnerJoin`` foo) -> do+-- 'on' ('toBaseId' (foo '^.' FooId) '==.' bar '^.' BarId)+-- return (bar, foo)+-- @+--+-- Note: this function may be unsafe to use in conditions not like the+-- one of the example above.+--+-- @since 2.4.3+toBaseId :: ToBaseId ent => SqlExpr (Value (Key ent)) -> SqlExpr (Value (Key (BaseEnt ent)))+toBaseId = veryUnsafeCoerceSqlExprValue++-- | Like 'toBaseId', but works on 'Maybe' keys.+--+-- @since 3.6.0.0+toBaseIdMaybe+ :: (ToBaseId ent)+ => SqlExpr (Value (Maybe (Key ent)))+ -> SqlExpr (Value (Maybe (Key (BaseEnt ent))))+toBaseIdMaybe = veryUnsafeCoerceSqlExprValue++-- | The inverse of 'toBaseId'. Note that this is somewhat less "safe" than+-- 'toBaseId'. Calling 'toBaseId' will usually mean that a foreign key+-- constraint is present that guarantees the presence of the base ID.+-- 'fromBaseId' has no such guarantee. Consider the code example given in+-- 'toBaseId':+--+-- @+-- Bar+-- barNum Int+-- Foo+-- bar BarId+-- fooNum Int+-- Primary bar+-- @+--+-- @+-- instance ToBaseId Foo where+-- type BaseEnt Foo = Bar+-- toBaseIdWitness barId = FooKey barId+-- @+--+-- The type of 'toBaseId' for @Foo@ would be:+--+-- @+-- toBaseId :: SqlExpr (Value FooId) -> SqlExpr (Value BarId)+-- @+--+-- The foreign key constraint on @Foo@ means that every @FooId@ points to+-- a @BarId@ in the database. However, 'fromBaseId' will not have this:+--+-- @+-- fromBaseId :: SqlExpr (Value BarId) -> SqlExpr (Value FooId)+-- @+--+-- @since 3.6.0.0+fromBaseId+ :: (ToBaseId ent)+ => SqlExpr (Value (Key (BaseEnt ent)))+ -> SqlExpr (Value (Key ent))+fromBaseId = veryUnsafeCoerceSqlExprValue++-- | As 'fromBaseId', but works on 'Maybe' keys.+--+-- @since 3.6.0.0+fromBaseIdMaybe+ :: (ToBaseId ent)+ => SqlExpr (Value (Maybe (Key (BaseEnt ent))))+ -> SqlExpr (Value (Maybe (Key ent)))+fromBaseIdMaybe = veryUnsafeCoerceSqlExprValue++-- Fixity declarations+infixl 9 ^., ?.+infixl 7 *., /.+infixl 6 +., -.+infixr 5 ++.+infix 4 ==., >=., >., <=., <., !=.+infixr 3 &&., =., +=., -=., *=., /=.+infixr 2 ||., `like`, `ilike`+infixl 2 `InnerJoin`, `CrossJoin`, `LeftOuterJoin`, `RightOuterJoin`, `FullOuterJoin`++-- | Syntax sugar for 'case_'.+--+-- @since 2.1.2+when_ :: expr (Value Bool) -> () -> expr a -> (expr (Value Bool), expr a)+when_ cond _ expr = (cond, expr)++-- | Syntax sugar for 'case_'.+--+-- @since 2.1.2+then_ :: ()+then_ = ()++-- | Syntax sugar for 'case_'.+--+-- @since 2.1.2+else_ :: expr a -> expr a+else_ = id++-- | A single value (as opposed to a whole entity). You may use+-- @('^.')@ or @('?.')@ to get a 'Value' from an 'Entity'.+newtype Value a = Value { unValue :: a }+ deriving (Eq, Ord, Show, Typeable, Functor, Foldable, Traversable)++instance Applicative Value where+ (<*>) (Value f) (Value a) = Value (f a)+ pure = Value++instance Monad Value where+ (>>=) x f = valueJoin $ fmap f x+ where valueJoin (Value v) = v++-- | A list of single values. There's a limited set of functions+-- able to work with this data type (such as 'subList_select',+-- 'valList', 'in_' and 'exists').+newtype ValueList a = ValueList a deriving (Eq, Ord, Show, Typeable)++-- | A wrapper type for for any @expr (Value a)@ for all a.+data SomeValue where+ SomeValue :: SqlExpr (Value a) -> SomeValue++-- | A class of things that can be converted into a list of SomeValue. It has+-- instances for tuples and is the reason why 'groupBy' can take tuples, like+-- @'groupBy' (foo '^.' FooId, foo '^.' FooName, foo '^.' FooType)@.+class ToSomeValues a where+ toSomeValues :: a -> [SomeValue]++instance+ ( ToSomeValues a+ , ToSomeValues b+ )+ =>+ ToSomeValues (a, b)+ where+ toSomeValues (a,b) = toSomeValues a ++ toSomeValues b++instance+ ( ToSomeValues a+ , ToSomeValues b+ , ToSomeValues c+ )+ =>+ ToSomeValues (a, b, c)+ where+ toSomeValues (a,b,c) = toSomeValues a ++ toSomeValues b ++ toSomeValues c++instance+ ( ToSomeValues a+ , ToSomeValues b+ , ToSomeValues c+ , ToSomeValues d+ )+ =>+ ToSomeValues (a, b, c, d)+ where+ toSomeValues (a,b,c,d) =+ toSomeValues a ++ toSomeValues b ++ toSomeValues c ++ toSomeValues d++instance+ ( ToSomeValues a+ , ToSomeValues b+ , ToSomeValues c+ , ToSomeValues d+ , ToSomeValues e+ )+ =>+ ToSomeValues (a, b, c, d, e)+ where+ toSomeValues (a,b,c,d,e) = concat+ [ toSomeValues a, toSomeValues b, toSomeValues c , toSomeValues d+ , toSomeValues e+ ]++instance+ ( ToSomeValues a+ , ToSomeValues b+ , ToSomeValues c+ , ToSomeValues d+ , ToSomeValues e+ , ToSomeValues f+ )+ =>+ ToSomeValues (a, b, c, d, e, f)+ where+ toSomeValues (a,b,c,d,e,f) = concat+ [ toSomeValues a, toSomeValues b, toSomeValues c, toSomeValues d+ , toSomeValues e , toSomeValues f+ ]++instance+ ( ToSomeValues a+ , ToSomeValues b+ , ToSomeValues c+ , ToSomeValues d+ , ToSomeValues e+ , ToSomeValues f+ , ToSomeValues g+ )+ =>+ ToSomeValues (a, b, c, d, e, f, g)+ where+ toSomeValues (a,b,c,d,e,f,g) = concat+ [ toSomeValues a, toSomeValues b, toSomeValues c, toSomeValues d+ , toSomeValues e, toSomeValues f, toSomeValues g+ ]++instance+ ( ToSomeValues a+ , ToSomeValues b+ , ToSomeValues c+ , ToSomeValues d+ , ToSomeValues e+ , ToSomeValues f+ , ToSomeValues g+ , ToSomeValues h+ )+ =>+ ToSomeValues (a, b, c, d, e, f, g, h)+ where+ toSomeValues (a,b,c,d,e,f,g,h) = concat+ [ toSomeValues a, toSomeValues b, toSomeValues c, toSomeValues d+ , toSomeValues e, toSomeValues f, toSomeValues g, toSomeValues h+ ]++type family KnowResult a where+ KnowResult (i -> o) = KnowResult o+ KnowResult a = a++-- | A class for constructors or function which result type is known.+--+-- @since 3.1.3+class FinalResult a where+ finalR :: a -> KnowResult a++instance FinalResult (Unique val) where+ finalR = id++instance (FinalResult b) => FinalResult (a -> b) where+ finalR f = finalR (f undefined)++-- | Convert a constructor for a 'Unique' key on a record to the 'UniqueDef'+-- that defines it. You can supply just the constructor itself, or a value of+-- the type - the library is capable of figuring it out from there.+--+-- @since 3.1.3+toUniqueDef+ :: forall a val.+ ( KnowResult a ~ Unique val+ , PersistEntity val+ , FinalResult a+ )+ => a+ -> UniqueDef+toUniqueDef uniqueConstructor = uniqueDef+ where+ proxy :: Proxy val+ proxy = Proxy+ unique :: Unique val+ unique = finalR uniqueConstructor+ -- there must be a better way to get the constrain name from a unique, make this not a list search+ filterF = (==) (persistUniqueToFieldNames unique) . uniqueFields+ uniqueDef = head . filter filterF . getEntityUniques . entityDef $ proxy++-- | Render updates to be use in a SET clause for a given sql backend.+--+-- @since 3.1.3+renderUpdates+ :: (BackendCompatible SqlBackend backend)+ => backend+ -> [SqlExpr (Entity val) -> SqlExpr Update]+ -> (TLB.Builder, [PersistValue])+renderUpdates conn = uncommas' . concatMap renderUpdate+ where+ mk :: SqlExpr Update -> [(TLB.Builder, [PersistValue])]+ mk (ERaw _ f) = [f Never info]++ renderUpdate :: (SqlExpr (Entity val) -> SqlExpr Update) -> [(TLB.Builder, [PersistValue])]+ renderUpdate f = mk (f undefined) -- second parameter of f is always unused+ info = (projectBackend conn, initialIdentState)++-- | Data type that represents an @INNER JOIN@ (see 'LeftOuterJoin' for an example).+data InnerJoin a b = a `InnerJoin` b++-- | Data type that represents a @CROSS JOIN@ (see 'LeftOuterJoin' for an example).+data CrossJoin a b = a `CrossJoin` b++-- | Data type that represents a @LEFT OUTER JOIN@. For example,+--+-- @+-- select $+-- 'from' $ \\(person `'LeftOuterJoin`` pet) ->+-- ...+-- @+--+-- is translated into+--+-- @+-- SELECT ...+-- FROM Person LEFT OUTER JOIN Pet+-- ...+-- @+--+-- See also: 'from'.+data LeftOuterJoin a b = a `LeftOuterJoin` b++-- | Data type that represents a @RIGHT OUTER JOIN@ (see 'LeftOuterJoin' for an example).+data RightOuterJoin a b = a `RightOuterJoin` b++-- | Data type that represents a @FULL OUTER JOIN@ (see 'LeftOuterJoin' for an example).+data FullOuterJoin a b = a `FullOuterJoin` b+++-- | (Internal) A kind of @JOIN@.+data JoinKind+ = InnerJoinKind -- ^ @INNER JOIN@+ | CrossJoinKind -- ^ @CROSS JOIN@+ | LeftOuterJoinKind -- ^ @LEFT OUTER JOIN@+ | RightOuterJoinKind -- ^ @RIGHT OUTER JOIN@+ | FullOuterJoinKind -- ^ @FULL OUTER JOIN@+ deriving (Eq, Show)+++-- | (Internal) Functions that operate on types (that should be)+-- of kind 'JoinKind'.+class IsJoinKind join where+ -- | (Internal) @smartJoin a b@ is a @JOIN@ of the correct kind.+ smartJoin :: a -> b -> join a b+ -- | (Internal) Reify a @JoinKind@ from a @JOIN@. This+ -- function is non-strict.+ reifyJoinKind :: join a b -> JoinKind++instance IsJoinKind InnerJoin where+ smartJoin a b = a `InnerJoin` b+ reifyJoinKind _ = InnerJoinKind+instance IsJoinKind CrossJoin where+ smartJoin a b = a `CrossJoin` b+ reifyJoinKind _ = CrossJoinKind+instance IsJoinKind LeftOuterJoin where+ smartJoin a b = a `LeftOuterJoin` b+ reifyJoinKind _ = LeftOuterJoinKind+instance IsJoinKind RightOuterJoin where+ smartJoin a b = a `RightOuterJoin` b+ reifyJoinKind _ = RightOuterJoinKind+instance IsJoinKind FullOuterJoin where+ smartJoin a b = a `FullOuterJoin` b+ reifyJoinKind _ = FullOuterJoinKind+++-- | Exception thrown whenever 'on' is used to create an @ON@+-- clause but no matching @JOIN@ is found.+data OnClauseWithoutMatchingJoinException =+ OnClauseWithoutMatchingJoinException String+ deriving (Eq, Ord, Show, Typeable)++instance Exception OnClauseWithoutMatchingJoinException++-- | Phantom type used by 'orderBy', 'asc' and 'desc'.+data OrderBy++-- | Phantom type used by 'distinctOn' and 'don'.+data DistinctOn++-- | Phantom type for a @SET@ operation on an entity of the given+-- type (see 'set' and '(=.)').+data Update++-- | Phantom type used by 'insertSelect'.+data Insertion a++-- | A left-precedence pair. Pronounced \"and\". Used to represent expressions+-- that have been joined together.+--+-- The precedence behavior can be demonstrated by:+--+-- @+-- a :& b :& c == ((a :& b) :& c)+-- @+--+-- See the examples at the beginning of this module to see how this+-- operator is used in 'JOIN' operations.+data (:&) a b = a :& b+ deriving (Eq, Show, Functor)+infixl 2 :&++-- |+--+-- @since 3.5.14.0+instance Bifunctor (:&) where+ bimap f g (a :& b) = f a :& g b++-- | Different kinds of locking clauses supported by 'locking'.+--+-- Note that each RDBMS has different locking support. The+-- constructors of this datatype specify only the /syntax/ of the+-- locking mechanism, not its /semantics/. For example, even+-- though both MySQL and PostgreSQL support 'ForUpdate', there+-- are no guarantees that they will behave the same.+--+-- @since 2.2.7+data LockingKind+ = ForUpdate+ -- ^ @FOR UPDATE@ syntax. Supported by MySQL, Oracle and+ -- PostgreSQL.+ --+ -- @since 2.2.7+ | ForUpdateSkipLocked+ -- ^ @FOR UPDATE SKIP LOCKED@ syntax. Supported by MySQL, Oracle and+ -- PostgreSQL.+ --+ -- @since 2.2.7+ | ForShare+ -- ^ @FOR SHARE@ syntax. Supported by PostgreSQL.+ --+ -- @since 2.2.7+ | LockInShareMode+ -- ^ @LOCK IN SHARE MODE@ syntax. Supported by MySQL.+ --+ -- @since 2.2.7++{-# DEPRECATED ForUpdate, ForUpdateSkipLocked "The constructors for 'LockingKind' are deprecated in v3.6.0.0. Instead, please refer to the smart constructors 'forUpdate' and 'forUpdateSkipLocked'." #-}+{-# DEPRECATED ForShare "The constructors for 'LockingKind' are deprecated in v3.6.0.0. Instead, please refer to the smart constructor 'forShare' exported from Database.Esqueleto.PostgreSQL." #-}+{-# DEPRECATED LockInShareMode "The constructors for 'LockingKind' are deprecated in v3.6.0.0. Instead, please refer to the smart constructors 'lockInShareMode' exported from Database.Esqueleto.MySQL." #-}++-- | @FOR UPDATE@ syntax.+--+-- Usage:+--+-- @+-- 'locking' 'forUpdate'+-- @+--+-- @since 3.6.0.0+forUpdate :: LockingKind+forUpdate = ForUpdate++-- | @FOR UPDATE SKIP LOCKED@ syntax.+--+-- @+-- 'locking' 'forUpdateSkipLocked'+-- @+--+-- @since 3.6.0.0+forUpdateSkipLocked :: LockingKind+forUpdateSkipLocked = ForUpdateSkipLocked++-- | Postgres specific locking, used only internally+--+-- @since 3.5.9.0+data PostgresLockingKind =+ PostgresLockingKind+ {+ postgresRowLevelLockStrength :: PostgresRowLevelLockStrength+ , postgresLockingOfClause :: Maybe LockingOfClause+ , postgresOnLockedBehavior :: OnLockedBehavior+ }++-- Arranged in order of lock strength+data PostgresRowLevelLockStrength =+ PostgresForUpdate+ | PostgresForNoKeyUpdate+ | PostgresForShare+ | PostgresForKeyShare+ deriving (Ord, Eq)++data LockingOfClause where+ LockingOfClause :: LockableEntity a => a -> LockingOfClause++data OnLockedBehavior =+ NoWait+ -- ^ @NOWAIT@ syntax locking behaviour.+ -- query excutes immediately failing on locked rows+ --+ -- @since 3.5.9.0+ | SkipLocked+ -- ^ @SKIP LOCKED@ syntax locking behaviour.+ -- query skips locked rows+ --+ -- @since 3.5.9.0+ | Wait+ -- ^ default locking behaviour.+ -- query will wait on locked rows+ --+ -- @since 3.5.9.0+ deriving (Ord, Eq, Show)+++-- | Lockable entity+--+-- Example use:+--+-- @+-- select $ do+-- (p :& bp) <- from $+-- table @Person+-- `innerJoin` table @BlogPost+-- `on` do+-- \(p :& bp) -> p ^. PersonId ==. b ^. BlogPostAuthorId+-- forUpdateOf (p :& b) skipLocked+-- return p+-- @+class LockableEntity a where+ flattenLockableEntity :: a -> NonEmpty LockableSqlExpr++makeLockableEntity :: LockableEntity a => IdentInfo -> a -> (TLB.Builder, [PersistValue])+makeLockableEntity info lockableEntity =+ uncommas' $ Set.toList . Set.fromList $ (\(LockableSqlExpr (ERaw _ f)) -> f Never info) <$> NEL.toList (flattenLockableEntity lockableEntity)++instance PersistEntity val => LockableEntity (SqlExpr (Entity val)) where+ flattenLockableEntity e = LockableSqlExpr e :| []++instance (LockableEntity a, LockableEntity b) => LockableEntity (a :& b) where+ flattenLockableEntity (a :& b) = flattenLockableEntity a <> flattenLockableEntity b++data LockableSqlExpr where+ LockableSqlExpr :: PersistEntity val => (SqlExpr (Entity val)) -> LockableSqlExpr++-- | Phantom class of data types that are treated as strings by the+-- RDBMS. It has no methods because it's only used to avoid type+-- errors such as trying to concatenate integers.+--+-- If you have a custom data type or @newtype@, feel free to make+-- it an instance of this class.+--+-- @since 2.4.0+class PersistField a => SqlString a where++-- | @since 2.3.0+instance (a ~ Char) => SqlString [a] where++-- | @since 2.3.0+instance SqlString T.Text where++-- | @since 2.3.0+instance SqlString TL.Text where++-- | @since 2.3.0+instance SqlString B.ByteString where++-- | @since 2.3.0+instance SqlString Html where++-- | @since 2.4.0+instance SqlString a => SqlString (Maybe a) where++-- | Class that enables one to use 'toBaseId' to convert an entity's+-- key on a query into another (cf. 'toBaseId').+class ToBaseId ent where+ -- | e.g. @type BaseEnt MyBase = MyChild@+ type BaseEnt ent :: Type+ -- | Convert from the key of the BaseEnt(ity) to the key of the child entity.+ -- This function is not actually called, but that it typechecks proves this operation is safe.+ toBaseIdWitness :: Key (BaseEnt ent) -> Key ent+++-- | @FROM@ clause: bring entities into scope.+--+-- Note that this function will be replaced by the one in+-- "Database.Esqueleto.Experimental" in version 4.0.0.0 of the library. The+-- @Experimental@ module has a dramatically improved means for introducing+-- tables and entities that provides more power and less potential for runtime+-- errors.+--+-- This function internally uses two type classes in order to+-- provide some flexibility of how you may call it. Internally+-- we refer to these type classes as the two different magics.+--+-- The innermost magic allows you to use @from@ with the+-- following types:+--+-- * @expr (Entity val)@, which brings a single entity into+-- scope.+--+-- * @expr (Maybe (Entity val))@, which brings a single entity+-- that may be @NULL@ into scope. Used for @OUTER JOIN@s.+--+-- * A @JOIN@ of any other two types allowed by the innermost+-- magic, where a @JOIN@ may be an 'InnerJoin', a 'CrossJoin', a+-- 'LeftOuterJoin', a 'RightOuterJoin', or a 'FullOuterJoin'.+-- The @JOINs@ have left fixity.+--+-- The outermost magic allows you to use @from@ on any tuples of+-- types supported by innermost magic (and also tuples of tuples,+-- and so on), up to 8-tuples.+--+-- Note that using @from@ for the same entity twice does work and+-- corresponds to a self-join. You don't even need to use two+-- different calls to @from@, you may use a @JOIN@ or a tuple.+--+-- The following are valid examples of uses of @from@ (the types+-- of the arguments of the lambda are inside square brackets):+--+-- @+-- 'from' $ \\person -> ...+-- 'from' $ \\(person, blogPost) -> ...+-- 'from' $ \\(p `'LeftOuterJoin`` mb) -> ...+-- 'from' $ \\(p1 `'InnerJoin`` f `'InnerJoin`` p2) -> ...+-- 'from' $ \\((p1 `'InnerJoin`` f) `'InnerJoin`` p2) -> ...+-- @+--+-- The types of the arguments to the lambdas above are,+-- respectively:+--+-- @+-- person+-- :: ( Esqueleto query expr backend+-- , PersistEntity Person+-- , PersistEntityBackend Person ~ backend+-- ) => expr (Entity Person)+-- (person, blogPost)+-- :: (...) => (expr (Entity Person), expr (Entity BlogPost))+-- (p `'LeftOuterJoin`` mb)+-- :: (...) => InnerJoin (expr (Entity Person)) (expr (Maybe (Entity BlogPost)))+-- (p1 `'InnerJoin`` f `'InnerJoin`` p2)+-- :: (...) => InnerJoin+-- (InnerJoin (expr (Entity Person))+-- (expr (Entity Follow)))+-- (expr (Entity Person))+-- (p1 `'InnerJoin`` (f `'InnerJoin`` p2)) ::+-- :: (...) => InnerJoin+-- (expr (Entity Person))+-- (InnerJoin (expr (Entity Follow))+-- (expr (Entity Person)))+-- @+--+-- Note that some backends may not support all kinds of @JOIN@s.+from :: From a => (a -> SqlQuery b) -> SqlQuery b+from = (from_ >>=)+++-- | (Internal) Class that implements the tuple 'from' magic (see+-- 'fromStart').+class From a where+ from_ :: SqlQuery a++instance+ ( FromPreprocess (SqlExpr (Entity val))+ )+ =>+ From (SqlExpr (Entity val))+ where+ from_ = fromPreprocess >>= fromFinish++instance+ ( FromPreprocess (SqlExpr (Maybe (Entity val)))+ )+ =>+ From (SqlExpr (Maybe (Entity val)))+ where+ from_ = fromPreprocess >>= fromFinish++instance+ ( FromPreprocess (InnerJoin a b)+ )+ =>+ From (InnerJoin a b)+ where+ from_ = fromPreprocess >>= fromFinish++instance+ ( FromPreprocess (CrossJoin a b)+ )+ =>+ From (CrossJoin a b)+ where+ from_ = fromPreprocess >>= fromFinish++instance (FromPreprocess (LeftOuterJoin a b)) => From (LeftOuterJoin a b) where+ from_ = fromPreprocess >>= fromFinish++instance (FromPreprocess (RightOuterJoin a b)) => From (RightOuterJoin a b) where+ from_ = fromPreprocess >>= fromFinish++instance (FromPreprocess (FullOuterJoin a b)) => From (FullOuterJoin a b) where+ from_ = fromPreprocess >>= fromFinish++instance (From a, From b) => From (a, b) where+ from_ = (,) <$> from_ <*> from_++instance (From a, From b, From c) => From (a, b, c) where+ from_ = (,,) <$> from_ <*> from_ <*> from_++instance (From a, From b, From c, From d) => From (a, b, c, d) where+ from_ = (,,,) <$> from_ <*> from_ <*> from_ <*> from_++instance (From a, From b, From c, From d, From e) => From (a, b, c, d, e) where+ from_ = (,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_++instance+ (From a, From b, From c, From d, From e, From f)+ =>+ From (a, b, c, d, e, f)+ where+ from_ = (,,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_++instance+ (From a, From b, From c, From d, From e, From f, From g)+ =>+ From (a, b, c, d, e, f, g)+ where+ from_ =+ (,,,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_++instance+ (From a, From b, From c, From d, From e, From f, From g, From h)+ =>+ From (a, b, c, d, e, f, g, h)+ where+ from_ =+ (,,,,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_++++-- | (Internal) Class that implements the @JOIN@ 'from' magic+-- (see 'fromStart').+class FromPreprocess a where+ fromPreprocess :: SqlQuery (PreprocessedFrom a)++instance+ (PersistEntity val, BackendCompatible SqlBackend (PersistEntityBackend val))+ =>+ FromPreprocess (SqlExpr (Entity val))+ where+ fromPreprocess = fromStart++instance+ (PersistEntity val, BackendCompatible SqlBackend (PersistEntityBackend val))+ =>+ FromPreprocess (SqlExpr (Maybe (Entity val)))+ where+ fromPreprocess = fromStartMaybe++instance+ (FromPreprocess a, FromPreprocess b, IsJoinKind join)+ =>+ FromPreprocess (join a b)+ where+ fromPreprocess = do+ a <- fromPreprocess+ b <- fromPreprocess+ fromJoin a b++-- | Exception data type for @esqueleto@ internal errors+data EsqueletoError+ = CompositeKeyErr CompositeKeyError+ | AliasedValueErr UnexpectedValueError+ | UnexpectedCaseErr UnexpectedCaseError+ | SqlBinOpCompositeErr SqlBinOpCompositeError+ deriving (Show)++instance Exception EsqueletoError++data UnexpectedValueError+ = NotError+ | ToInsertionError+ | CombineInsertionError+ | FoldHelpError+ | SqlCaseError+ | SqlCastAsError+ | SqlFunctionError+ | MakeOnClauseError+ | MakeExcError+ | MakeSetError+ | MakeWhereError+ | MakeHavingError+ | FilterWhereAggError+ | FilterWhereClauseError+ deriving (Show)++type CompositeKeyError = UnexpectedValueError++data UnexpectedCaseError+ = EmptySqlExprValueList+ | MakeFromError+ | UnsupportedSqlInsertIntoType+ | InsertionFinalError+ | NewIdentForError+ | UnsafeSqlCaseError+ | OperationNotSupported+ | NotImplemented+ deriving (Show)++data SqlBinOpCompositeError+ = MismatchingLengthsError+ | NullPlaceholdersError+ | DeconstructionError+ deriving (Show)++-- | SQL backend for @esqueleto@ using 'SqlPersistT'.+newtype SqlQuery a = Q { unQ :: W.WriterT SideData (S.State IdentState) a }+ deriving newtype (Functor, Applicative, Monad)++-- | Constraint synonym for @persistent@ entities whose backend+-- is 'SqlBackend'.+type SqlEntity ent = (PersistEntity ent, PersistEntityBackend ent ~ SqlBackend)+++----------------------------------------------------------------------+++-- | Side data written by 'SqlQuery'.+data SideData = SideData+ { sdDistinctClause :: !DistinctClause+ , sdFromClause :: ![FromClause]+ , sdSetClause :: ![SetClause]+ , sdWhereClause :: !WhereClause+ , sdGroupByClause :: !GroupByClause+ , sdHavingClause :: !HavingClause+ , sdOrderByClause :: ![OrderByClause]+ , sdLimitClause :: !LimitClause+ , sdLockingClause :: !LockingClause+ , sdCteClause :: ![CommonTableExpressionClause]+ }++instance Semigroup SideData where+ SideData d f s w g h o l k c <> SideData d' f' s' w' g' h' o' l' k' c' =+ SideData (d <> d') (f <> f') (s <> s') (w <> w') (g <> g') (h <> h') (o <> o') (l <> l') (k <> k') (c <> c')++instance Monoid SideData where+ mempty = SideData mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty+ mappend = (<>)++-- | The @DISTINCT@ "clause".+data DistinctClause+ = DistinctAll+ -- ^ The default, everything.+ | DistinctStandard+ -- ^ Only @DISTINCT@, SQL standard.+ | DistinctOn [SqlExpr DistinctOn]+ -- ^ @DISTINCT ON@, PostgreSQL extension.++instance Semigroup DistinctClause where+ DistinctOn a <> DistinctOn b = DistinctOn (a <> b)+ DistinctOn a <> _ = DistinctOn a+ DistinctStandard <> _ = DistinctStandard+ DistinctAll <> b = b++instance Monoid DistinctClause where+ mempty = DistinctAll+ mappend = (<>)++-- | A part of a @FROM@ clause.+data FromClause+ = FromStart Ident EntityDef+ | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool)))+ | OnClause (SqlExpr (Value Bool))+ | FromRaw (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]))++data CommonTableExpressionKind+ = RecursiveCommonTableExpression+ | NormalCommonTableExpression+ deriving Eq++type CommonTableExpressionModifierAfterAs = CommonTableExpressionClause -> IdentInfo -> TLB.Builder++data CommonTableExpressionClause+ = CommonTableExpressionClause CommonTableExpressionKind CommonTableExpressionModifierAfterAs Ident (IdentInfo -> (TLB.Builder, [PersistValue]))++data SubQueryType+ = NormalSubQuery+ | LateralSubQuery+ deriving Show++collectIdents :: FromClause -> Set Ident+collectIdents fc = case fc of+ FromStart i _ -> Set.singleton i+ FromJoin lhs _ rhs _ -> collectIdents lhs <> collectIdents rhs+ OnClause _ -> mempty+ FromRaw _ -> mempty++instance Show FromClause where+ show fc = case fc of+ FromStart i _ ->+ "(FromStart " <> show i <> ")"+ FromJoin lhs jk rhs mexpr ->+ mconcat+ [ "(FromJoin "+ , show lhs+ , " "+ , show jk+ , " "+ , case mexpr of+ Nothing -> "(no on clause)"+ Just expr -> "(" <> render' expr <> ")"+ , " "+ , show rhs+ , ")"+ ]+ OnClause expr ->+ "(OnClause " <> render' expr <> ")"+ FromRaw _ ->+ "(FromRaw _)"++ where+ -- We just want to use this to render expressions for a `Show` instance+ -- so we leave most of the fields undefined. But we explicitly+ -- initialize them to `undefined` so that GHC doesn't complain.+ dummy = mkSqlBackend MkSqlBackendArgs+ { connEscapeRawName = id+ , connPrepare = undefined+ , connInsertSql = undefined+ , connStmtMap = undefined+ , connClose = undefined+ , connMigrateSql = undefined+ , connBegin = undefined+ , connCommit = undefined+ , connRollback = undefined+ , connEscapeFieldName = undefined+ , connEscapeTableName = undefined+ , connNoLimit = undefined+ , connRDBMS = undefined+ , connLimitOffset = undefined+ , connLogFunc = undefined+ }+ render' = T.unpack . renderExpr dummy++-- | A part of a @SET@ clause.+newtype SetClause = SetClause (SqlExpr Update)++-- | Collect 'OnClause's on 'FromJoin's. Returns the first+-- unmatched 'OnClause's data on error. Returns a list without+-- 'OnClauses' on success.+collectOnClauses+ :: SqlBackend+ -> [FromClause]+ -> Either (SqlExpr (Value Bool)) [FromClause]+collectOnClauses sqlBackend = go Set.empty []+ where+ go is [] (f@(FromStart i _) : fs) =+ fmap (f:) (go (Set.insert i is) [] fs) -- fast path+ go idents acc (OnClause expr : fs) = do+ (idents', a) <- findMatching idents acc expr+ go idents' a fs+ go idents acc (f:fs) =+ go idents (f:acc) fs+ go _ acc [] =+ return $ reverse acc++ findMatching+ :: Set Ident+ -> [FromClause]+ -> SqlExpr (Value Bool)+ -> Either (SqlExpr (Value Bool)) (Set Ident, [FromClause])+ findMatching idents fromClauses expr =+ case fromClauses of+ f : acc ->+ let idents' =+ idents+ <> Set.fromList+ (Maybe.catMaybes [findLeftmostIdent f, findRightmostIdent f])+ in+ case tryMatch idents' expr f of+ Just (idents'', f') ->+ return (idents'', f' : acc)+ Nothing ->+ fmap (f:) <$> findMatching idents' acc expr+ [] ->+ Left expr++ findRightmostIdent (FromStart i _) = Just i+ findRightmostIdent (FromJoin _ _ r _) = findRightmostIdent r+ findRightmostIdent (OnClause {}) = Nothing+ findRightmostIdent (FromRaw _) = Nothing++ findLeftmostIdent (FromStart i _) = Just i+ findLeftmostIdent (FromJoin l _ _ _) = findLeftmostIdent l+ findLeftmostIdent (OnClause {}) = Nothing+ findLeftmostIdent (FromRaw _) = Nothing++ tryMatch+ :: Set Ident+ -> SqlExpr (Value Bool)+ -> FromClause+ -> Maybe (Set Ident, FromClause)+ tryMatch idents expr fromClause =+ case fromClause of+ FromJoin l k r onClause ->+ matchTable <|> matchR <|> matchC <|> matchL <|> matchPartial -- right to left+ where+ matchR = fmap (\r' -> FromJoin l k r' onClause)+ <$> tryMatch idents expr r+ matchL = fmap (\l' -> FromJoin l' k r onClause)+ <$> tryMatch idents expr l++ matchPartial = do+ --Debug.traceM $ "matchPartial"+ --Debug.traceM $ "matchPartial: identsInOnClause: " <> show identsInOnClause+ i1 <- findLeftmostIdent l+ i2 <- findLeftmostIdent r+ let leftIdents = collectIdents l+ -- Debug.traceM $ "matchPartial: i1: " <> show i1+ -- Debug.traceM $ "matchPartial: i2: " <> show i2+ -- Debug.traceM $ "matchPartial: idents: " <> show idents+ guard $+ Set.isSubsetOf+ identsInOnClause+ (Set.fromList [i1, i2] <> leftIdents)+ guard $ k /= CrossJoinKind+ guard $ Maybe.isNothing onClause+ pure (idents, FromJoin l k r (Just expr))++ matchC =+ case onClause of+ Nothing+ | "?" `T.isInfixOf` renderedExpr ->+ return (idents, FromJoin l k r (Just expr))+ | Set.null identsInOnClause ->+ return (idents, FromJoin l k r (Just expr))+ | otherwise ->+ Nothing+ Just _ ->+ Nothing+ matchTable = do+ i1 <- findLeftmostIdent r+ i2 <- findRightmostIdent l+ guard $ Set.fromList [i1, i2] `Set.isSubsetOf` identsInOnClause+ guard $ k /= CrossJoinKind+ guard $ Maybe.isNothing onClause+ pure (Set.fromList [i1, i2] <> idents, FromJoin l k r (Just expr))++ _ ->+ Nothing+ where+ identsInOnClause =+ onExprToTableIdentifiers++ renderedExpr =+ renderExpr sqlBackend expr++ onExprToTableIdentifiers =+ Set.map (I . tableAccessTable)+ . either error id+ . parseOnExpr sqlBackend+ $ renderedExpr++-- | A complete @WHERE@ clause.+data WhereClause = Where (SqlExpr (Value Bool))+ | NoWhere++instance Semigroup WhereClause where+ NoWhere <> w = w+ w <> NoWhere = w+ Where e1 <> Where e2 = Where (e1 &&. e2)++instance Monoid WhereClause where+ mempty = NoWhere+ mappend = (<>)++-- | A @GROUP BY@ clause.+newtype GroupByClause = GroupBy [SomeValue]++instance Semigroup GroupByClause where+ GroupBy fs <> GroupBy fs' = GroupBy (fs <> fs')++instance Monoid GroupByClause where+ mempty = GroupBy []+ mappend = (<>)++-- | A @HAVING@ cause.+type HavingClause = WhereClause++-- | A @ORDER BY@ clause.+type OrderByClause = SqlExpr OrderBy++-- | A @LIMIT@ clause.+data LimitClause = Limit (Maybe Int64) (Maybe Int64)+ deriving Eq++instance Semigroup LimitClause where+ Limit l1 o1 <> Limit l2 o2 =+ Limit (l2 `mplus` l1) (o2 `mplus` o1)+ -- More than one 'limit' or 'offset' is issued, we want to+ -- keep the latest one. That's why we use mplus with+ -- "reversed" arguments.++instance Monoid LimitClause where+ mempty = Limit mzero mzero++-- | A locking clause.+data LockingClause =+ LegacyLockingClause LockingKind+ -- ^ Locking clause not specific to any database implementation+ | PostgresLockingClauses [PostgresLockingKind]+ -- ^ Locking clause specific to postgres+ | NoLockingClause++instance Semigroup LockingClause where+ -- Postgres allows us to have multiple locking clauses+ (<>) (PostgresLockingClauses pleft) (PostgresLockingClauses pright) = PostgresLockingClauses (pleft <> pright)+ (<>) mleft NoLockingClause = mleft+ (<>) _ mright = mright+--+instance Monoid LockingClause where+ mempty = NoLockingClause+ mappend = (<>)++----------------------------------------------------------------------++-- | Identifier used for table names.+newtype Ident = I T.Text+ deriving (Eq, Ord, Show)++-- | List of identifiers already in use and supply of temporary+-- identifiers.+newtype IdentState = IdentState { inUse :: HS.HashSet T.Text }++initialIdentState :: IdentState+initialIdentState = IdentState mempty++-- | Create a fresh 'Ident'. If possible, use the given+-- 'DBName'.+newIdentFor :: DBName -> SqlQuery Ident+newIdentFor (DBName original) = Q $ lift $ findFree Nothing+ where+ findFree msuffix = do+ let+ withSuffix =+ maybe id (\suffix -> (<> T.pack (show suffix))) msuffix original+ isInUse <- S.gets (HS.member withSuffix . inUse)+ if isInUse+ then findFree (succ <$> (msuffix <|> Just (1 :: Int)))+ else do+ S.modify (\s -> s { inUse = HS.insert withSuffix (inUse s) })+ pure (I withSuffix)++-- | Information needed to escape and use identifiers.+type IdentInfo = (SqlBackend, IdentState)++-- | Use an identifier.+useIdent :: IdentInfo -> Ident -> TLB.Builder+useIdent info (I ident) = fromDBName info $ DBName ident++data SqlExprMeta = SqlExprMeta+ { -- A composite key.+ --+ -- Persistent uses the same 'PersistList' constructor for both+ -- fields which are (homogeneous) lists of values and the+ -- (probably heterogeneous) values of a composite primary key.+ --+ -- We need to treat composite keys as fields. For example, we+ -- have to support using ==., otherwise you wouldn't be able to+ -- join. OTOH, lists of values should be treated exactly the+ -- same as any other scalar value.+ --+ -- In particular, this is valid for persistent via rawSql for+ -- an F field that is a list:+ --+ -- A.F in ? -- [PersistList [foo, bar]]+ --+ -- However, this is not for a composite key entity:+ --+ -- A.ID = ? -- [PersistList [foo, bar]]+ --+ -- The ID field doesn't exist on the DB for a composite key+ -- table, it exists only on the Haskell side. Those variations+ -- also don't work:+ --+ -- (A.KeyA, A.KeyB) = ? -- [PersistList [foo, bar]]+ -- [A.KeyA, A.KeyB] = ? -- [PersistList [foo, bar]]+ --+ -- We have to generate:+ --+ -- A.KeyA = ? AND A.KeyB = ? -- [foo, bar]+ --+ -- Note that the PersistList had to be deconstructed into its+ -- components.+ --+ -- In order to disambiguate behaviors, this constructor is used+ -- /only/ to represent a composite field access. It does not+ -- represent a 'PersistList', not even if the 'PersistList' is+ -- used in the context of a composite key. That's because it's+ -- impossible, e.g., for 'val' to disambiguate between these+ -- uses.+ sqlExprMetaCompositeFields :: Maybe (IdentInfo -> [TLB.Builder])+ , sqlExprMetaAlias :: Maybe Ident -- Alias ident if this is an aliased value/entity+ , sqlExprMetaIsReference :: Bool -- Is this SqlExpr a reference to the selected value/entity (supports subqueries)+ }++-- | Empty 'SqlExprMeta' if you are constructing an 'ERaw' probably use this+-- for your meta+noMeta :: SqlExprMeta+noMeta = SqlExprMeta+ { sqlExprMetaCompositeFields = Nothing+ , sqlExprMetaAlias = Nothing+ , sqlExprMetaIsReference = False+ }++-- | Does this meta contain values for composite fields.+-- This field is field out for composite key values+hasCompositeKeyMeta :: SqlExprMeta -> Bool+hasCompositeKeyMeta = Maybe.isJust . sqlExprMetaCompositeFields++entityAsValue+ :: SqlExpr (Entity val)+ -> SqlExpr (Value (Entity val))+entityAsValue = veryUnsafeCoerceSqlExpr++entityAsValueMaybe+ :: SqlExpr (Maybe (Entity val))+ -> SqlExpr (Value (Maybe (Entity val)))+entityAsValueMaybe = veryUnsafeCoerceSqlExpr++-- | An expression on the SQL backend.+--+-- Raw expression: Contains a 'SqlExprMeta' and a function for+-- building the expr. It recieves a parameter telling it whether+-- it is in a parenthesized context, and takes information about the SQL+-- connection (mainly for escaping names) and returns both an+-- string ('TLB.Builder') and a list of values to be+-- interpolated by the SQL backend.+data SqlExpr a = ERaw SqlExprMeta (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]))++type role SqlExpr nominal++-- | The type @'SqlExpr' a@ represents a SQL expression that evaluates to+-- a value that can be parsed in Haskell to an @a@. There are often many+-- underlying SQL values that can parse exactly. The function+-- 'veryUnsafeCoerceSqlExpr' allows you to change this type.+--+-- There is no guarantee that the result works! To be safe, you want to provide+-- a local helper function that calls this at a tested type.+--+-- As an example, you may know that two types share an identical SQL+-- representation, and can be parsed exactly the same way. Perhaps you have+-- a @data SomeEnum@ which you represent as a @TEXT@ in Postgres, and you+-- want to treat it as a @TEXT@. You could define a top-level+-- type-restricted alias to this which allows this to be done safely:+--+-- @+-- enumToText :: SqlExpr (Value SomeEnum) -> SqlExpr (Value Text)+-- enumToText = veryUnsafeCoerceSqlExpr+-- @+--+-- Note that this is fragile: if you change the encoding of 'SomeEnum' to+-- be anything other than 'Text', then your code will fail at runtime.+--+-- @since 3.6.0.0+veryUnsafeCoerceSqlExpr :: SqlExpr a -> SqlExpr b+veryUnsafeCoerceSqlExpr (ERaw m k) = ERaw m k++-- | While 'veryUnsafeCoerceSqlExpr' allows you to coerce anything at all, this+-- requires that the two types are 'Coercible' in Haskell. This is not truly+-- safe: after all, the point of @newtype@ is to allow you to provide different+-- instances of classes like 'PersistFieldSql' and 'SqlSelect'. Using this may+-- break your code if you change the underlying SQL representation.+--+-- @since 3.6.0.0+unsafeCoerceSqlExpr :: (Coercible a b) => SqlExpr a -> SqlExpr b+unsafeCoerceSqlExpr = veryUnsafeCoerceSqlExpr++-- | Like 'unsafeCoerceSqlExpr' but for the common case where you are+-- coercing a 'Value'.+--+-- @since 3.6.0.0+unsafeCoerceSqlExprValue :: (Coercible a b) => SqlExpr (Value a) -> SqlExpr (Value b)+unsafeCoerceSqlExprValue = veryUnsafeCoerceSqlExpr++-- | Folks often want the ability to promote a Haskell function into the+-- 'SqlExpr' expression language - and naturally reach for 'fmap'.+-- Unfortunately, this is impossible. We cannot send *functions* to the+-- database, which is what we would need to do in order for this to make sense.+-- Let's consider the type of 'fmap' for 'SqlExpr':+--+-- @+-- fmap :: (a -> b) -> 'SqlExpr' a -> 'SqlExpr' b+-- @+--+-- This type signature is making a pretty strong claim: "Give me a Haskell+-- function from @a -> b@. I will then transform a SQL expression representing+-- a Haskell value of type @a@ and turn it into a SQL expression representing+-- a Haskell value of type @b@."+--+-- Let's suppose we *could* do this - @fmap (+1)@ would have to somehow inspect+-- the function expression means "add one", and then translate that to the+-- appropriate SQL.+--+-- This is why @esqueleto@ defines a bunch of operators: @x '+.' ('val' 1)@ can+-- be used instead of @'fmap' (+1) x@.+--+-- If you do have a SQL function, then you can provide a safe type and introduce+-- it with 'unsafeSqlFunction' or 'unsafeSqlBinOp'.+--+-- @since 3.5.8.2+instance TypeError SqlExprFunctorMessage => Functor SqlExpr where+ fmap = error "impossible"++-- | The type error message given when you try to do 'fmap' on a 'SqlExpr'. This+-- is intended to guide folks towards the docs, which should guide them towards+-- alternative implementations.+--+-- @since 3.5.8.2+type SqlExprFunctorMessage =+ 'Text "You're trying to treat `SqlExpr` like a `Functor`, but it cannot be one."+ ':$$: 'Text "We would need to send arbitrary functions to the database for interpretation to support that instance."+ ':$$: 'Text "See the docs for the fake instance of `Functor SqlExpr` for more information."+ ':$$: 'Text "Consider using a SQL function with `unsafeSqlFunction` and a good type signature."++-- | This instance allows you to use @record.field@ notation with GHC 9.2's+-- @OverloadedRecordDot@ extension.+--+-- Example:+--+-- @+-- -- persistent model:+-- BlogPost+-- authorId PersonId+-- title Text+--+-- -- query:+-- 'select' $ do+-- bp <- 'from' $ 'table' \@BlogPost+-- pure $ bp.title+-- @+--+-- This is exactly equivalent to the following:+--+-- @+-- blogPost :: SqlExpr (Entity BlogPost)+--+-- blogPost ^. BlogPostTitle+-- blogPost ^. #title+-- blogPost.title+-- @+-- There's another instance defined on @'SqlExpr' ('Entity' ('Maybe' rec))@,+-- which allows you to project from a @LEFT JOIN@ed entity.+--+-- @since 3.5.4.0+instance+ (PersistEntity rec, PersistField typ, SymbolToField sym rec typ)+ =>+ HasField sym (SqlExpr (Entity rec)) (SqlExpr (Value typ))+ where+ getField expr = expr ^. symbolToField @sym++-- | This instance allows you to use @record.field@ notation with GC 9.2's+-- @OverloadedRecordDot@ extension.+--+-- Example:+--+-- @+-- -- persistent model:+-- Person+-- name Text+--+-- BlogPost+-- title Text+-- authorId PersonId+--+-- -- query:+--+-- 'select' $ do+-- (p :& bp) <- 'from' $+-- 'table' @Person+-- `leftJoin` table @BlogPost+-- `on` do+-- \\(p :& bp) ->+-- just p.id ==. bp.authorId+-- pure (p.name, bp.title)+-- @+--+-- The following forms are all equivalent:+--+-- @+-- blogPost :: SqlExpr (Maybe (Entity BlogPost))+--+-- blogPost ?. BlogPostTitle+-- blogPost ?. #title+-- blogPost.title+-- @+--+-- @since 3.5.4.0+instance+ (PersistEntity rec, PersistField typ, PersistField typ', SymbolToField sym rec typ+ , NullableFieldProjection typ typ'+ , HasField sym (SqlExpr (Maybe (Entity rec))) (SqlExpr (Value (Maybe typ')))+ )+ =>+ HasField sym (SqlExpr (Maybe (Entity rec))) (SqlExpr (Value (Maybe typ')))+ where+ getField expr = veryUnsafeCoerceSqlExpr (expr ?. symbolToField @sym)++-- | The 'NullableFieldProjection' type is used to determine whether+-- a 'Maybe' should be stripped off or not. This is used in the 'HasField'+-- for @'SqlExpr' ('Maybe' ('Entity' a))@ to allow you to only have+-- a single level of 'Maybe'.+--+-- @+-- MyTable+-- column Int Maybe+-- someTableId SomeTableId+--+-- select $ do+-- (_ :& maybeMyTable) <-+-- from $ table @SomeTable+-- `leftJoin` table @MyTable+-- `on` do+-- \(someTable :& maybeMyTable) ->+-- just someTable.id ==. maybeMyTable.someTableId+-- where_ $ maybeMyTable.column ==. just (val 10)+-- pure maybeMyTable+-- @+--+-- Without this class, projecting a field with type @'Maybe' typ@ would+-- have resulted in a @'SqlExpr' ('Value' ('Maybe' ('Maybe' typ)))@.+--+-- @since 3.6.0.0+class NullableFieldProjection typ typ'+instance {-# incoherent #-} (typ ~ typ') => NullableFieldProjection (Maybe typ) typ'+instance {-# overlappable #-} (typ ~ typ') => NullableFieldProjection typ typ'++-- | Data type to support from hack+data PreprocessedFrom a = PreprocessedFrom a FromClause++-- | Phantom type used to mark a @INSERT INTO@ query.+data InsertFinal++data NeedParens = Parens | Never+ deriving Eq++parensM :: NeedParens -> TLB.Builder -> TLB.Builder+parensM Never = id+parensM Parens = parens++data OrderByType = ASC | DESC++instance ToSomeValues (SqlExpr (Value a)) where+ toSomeValues a = [SomeValue a]++fieldName+ :: (PersistEntity val, PersistField typ)+ => IdentInfo -> EntityField val typ -> TLB.Builder+fieldName info = fromDBName info . coerce . fieldDB . persistFieldDef++-- FIXME: Composite/non-id pKS not supported on set+setAux+ :: (PersistEntity val, PersistField typ)+ => EntityField val typ+ -> (SqlExpr (Entity val) -> SqlExpr (Value typ))+ -> (SqlExpr (Entity val) -> SqlExpr Update)+setAux field value = \ent -> ERaw noMeta $ \_ info ->+ let ERaw _ valueF = value ent+ (valueToSet, valueVals) = valueF Parens info+ in (fieldName info field <> " = " <> valueToSet, valueVals)++sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)+sub mode query = ERaw noMeta $ \_ info -> first parens $ toRawSql mode info query++fromDBName :: IdentInfo -> DBName -> TLB.Builder+fromDBName (conn, _) = TLB.fromText . flip getEscapedRawName conn . unDBName++existsHelper :: SqlQuery () -> SqlExpr (Value Bool)+existsHelper = sub SELECT . (>> return true)+ where+ true :: SqlExpr (Value Bool)+ true = val True++-- | (Internal) Create a case statement.+--+-- Since: 2.1.1+unsafeSqlCase :: PersistField a => [(SqlExpr (Value Bool), SqlExpr (Value a))] -> SqlExpr (Value a) -> SqlExpr (Value a)+unsafeSqlCase when v = ERaw noMeta buildCase+ where+ buildCase :: NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])+ buildCase _ info =+ let (elseText, elseVals) = valueToSql v Parens info+ (whenText, whenVals) = mapWhen when Parens info+ in ( "CASE" <> whenText <> " ELSE " <> elseText <> " END", whenVals <> elseVals)++ mapWhen :: [(SqlExpr (Value Bool), SqlExpr (Value a))] -> NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])+ mapWhen [] _ _ = throw (UnexpectedCaseErr UnsafeSqlCaseError)+ mapWhen when' p info = foldl (foldHelp p info) (mempty, mempty) when'+++ foldHelp :: NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr (Value Bool), SqlExpr (Value a)) -> (TLB.Builder, [PersistValue])+ foldHelp p info (b0, vals0) (v1, v2) =+ let (b1, vals1) = valueToSql v1 p info+ (b2, vals2) = valueToSql v2 p info+ in ( b0 <> " WHEN " <> b1 <> " THEN " <> b2, vals0 <> vals1 <> vals2 )++ valueToSql :: SqlExpr (Value a) -> NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])+ valueToSql (ERaw _ f) p = f p++-- | (Internal) Create a custom binary operator. You /should/+-- /not/ use this function directly since its type is very+-- general, you should always use it with an explicit type+-- signature. For example:+--+-- @+-- (==.) :: SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value Bool)+-- (==.) = unsafeSqlBinOp " = "+-- @+--+-- In the example above, we constraint the arguments to be of the+-- same type and constraint the result to be a boolean value.+unsafeSqlBinOp :: TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c)+unsafeSqlBinOp op (ERaw m1 f1) (ERaw m2 f2)+ | not (hasCompositeKeyMeta m1 || hasCompositeKeyMeta m2) = ERaw noMeta f+ where+ f p info =+ let (b1, vals1) = f1 Parens info+ (b2, vals2) = f2 Parens info+ in+ ( parensM p (b1 <> op <> b2)+ , vals1 <> vals2+ )+unsafeSqlBinOp op a b = unsafeSqlBinOp op (construct a) (construct b)+ where+ construct :: SqlExpr (Value a) -> SqlExpr (Value a)+ construct (ERaw m f) =+ case sqlExprMetaCompositeFields m of+ Just fields ->+ ERaw noMeta $ \_ info -> (parens $ uncommas $ fields info, mempty)+ Nothing ->+ ERaw noMeta $ \p info ->+ let (b1, vals) = f (if p == Never then Parens else Never) info+ build ("?", [PersistList vals']) =+ (uncommas $ replicate (length vals') "?", vals')+ build expr = expr+ in+ first (parensM p) $ build (b1, vals)+{-# INLINE unsafeSqlBinOp #-}++-- | Similar to 'unsafeSqlBinOp', but may also be applied to+-- composite keys. Uses the operator given as the second+-- argument whenever applied to composite keys.+--+-- Usage example:+--+-- @+-- (==.) :: SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value Bool)+-- (==.) = unsafeSqlBinOpComposite " = " " AND "+-- @+--+-- Persistent has a hack for implementing composite keys (see+-- 'ECompositeKey' doc for more details), so we're forced to use+-- a hack here as well. We deconstruct 'ERaw' values based on+-- two rules:+--+-- - If it is a single placeholder, then it's assumed to be+-- coming from a 'PersistList' and thus its components are+-- separated so that they may be applied to a composite key.+--+-- - If it is not a single placeholder, then it's assumed to be+-- a foreign (composite or not) key, so we enforce that it has+-- no placeholders and split it on the commas.+unsafeSqlBinOpComposite :: TLB.Builder -> TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c)+unsafeSqlBinOpComposite op sep a b+ | isCompositeKey a || isCompositeKey b = ERaw noMeta $ const $ compose (listify a) (listify b)+ | otherwise = unsafeSqlBinOp op a b+ where+ isCompositeKey :: SqlExpr (Value x) -> Bool+ isCompositeKey (ERaw m _) = hasCompositeKeyMeta m++ listify :: SqlExpr (Value x) -> IdentInfo -> ([TLB.Builder], [PersistValue])+ listify (ERaw m f)+ | Just k <- sqlExprMetaCompositeFields m = flip (,) [] . k+ | otherwise = deconstruct . f Parens++ deconstruct :: (TLB.Builder, [PersistValue]) -> ([TLB.Builder], [PersistValue])+ deconstruct ("?", [PersistList vals]) = (replicate (length vals) "?", vals)+ deconstruct (b', []) = (TLB.fromLazyText <$> TL.splitOn "," (TLB.toLazyText b'), [])+ deconstruct _ = throw (SqlBinOpCompositeErr DeconstructionError)++ compose f1 f2 info+ | not (null v1 || null v2) = throw (SqlBinOpCompositeErr NullPlaceholdersError)+ | length b1 /= length b2 = throw (SqlBinOpCompositeErr MismatchingLengthsError)+ | otherwise = (bc, vc)+ where+ (b1, v1) = f1 info+ (b2, v2) = f2 info+ bc = intersperseB sep [x <> op <> y | (x, y) <- zip b1 b2]+ vc = v1 <> v2+++-- | (Internal) A raw SQL value. The same warning from+-- 'unsafeSqlBinOp' applies to this function as well.+unsafeSqlValue :: TLB.Builder -> SqlExpr (Value a)+unsafeSqlValue v = ERaw noMeta $ \_ _ -> (v, mempty)+{-# INLINE unsafeSqlValue #-}++unsafeSqlEntity :: PersistEntity ent => Ident -> SqlExpr (Entity ent)+unsafeSqlEntity ident = ERaw noMeta $ \_ info ->+ (useIdent info ident, [])++valueToFunctionArg :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue])+valueToFunctionArg info (ERaw _ f) = f Never info++-- | (Internal) A raw SQL function. Once again, the same warning+-- from 'unsafeSqlBinOp' applies to this function as well.+unsafeSqlFunction+ :: UnsafeSqlFunctionArgument a+ => TLB.Builder -> a -> SqlExpr (Value b)+unsafeSqlFunction name arg =+ ERaw noMeta $ \_ info ->+ let (argsTLB, argsVals) =+ uncommas' $ map (valueToFunctionArg info) $ toArgList arg+ in+ (name <> parens argsTLB, argsVals)++-- | (Internal) An unsafe SQL function to extract a subfield from a compound+-- field, e.g. datetime. See 'unsafeSqlBinOp' for warnings.+--+-- Since: 1.3.6.+unsafeSqlExtractSubField+ :: UnsafeSqlFunctionArgument a+ => TLB.Builder -> a -> SqlExpr (Value b)+unsafeSqlExtractSubField subField arg =+ ERaw noMeta $ \_ info ->+ let (argsTLB, argsVals) =+ uncommas' $ map (valueToFunctionArg info) $ toArgList arg+ in+ ("EXTRACT" <> parens (subField <> " FROM " <> argsTLB), argsVals)++-- | (Internal) A raw SQL function. Preserves parentheses around arguments.+-- See 'unsafeSqlBinOp' for warnings.+unsafeSqlFunctionParens+ :: UnsafeSqlFunctionArgument a+ => TLB.Builder -> a -> SqlExpr (Value b)+unsafeSqlFunctionParens name arg =+ ERaw noMeta $ \_ info ->+ let valueToFunctionArgParens (ERaw _ f) = f Never info+ (argsTLB, argsVals) =+ uncommas' $ map valueToFunctionArgParens $ toArgList arg+ in (name <> parens argsTLB, argsVals)++-- | (Internal) An explicit SQL type cast using CAST(value as type).+-- See 'unsafeSqlBinOp' for warnings.+unsafeSqlCastAs :: T.Text -> SqlExpr (Value a) -> SqlExpr (Value b)+unsafeSqlCastAs t (ERaw _ f) = ERaw noMeta $ \_ -> ((first (\value -> "CAST" <> parens (value <> " AS " <> TLB.fromText t))) . f Never)++-- | (Internal) This class allows 'unsafeSqlFunction' to work with different+-- numbers of arguments; specifically it allows providing arguments to a sql+-- function via an n-tuple of @SqlExpr (Value _)@ values, which are not all+-- necessarily required to be the same type. There are instances for up to+-- 10-tuples, but for sql functions which take more than 10 arguments, you can+-- also nest tuples, as e.g. @toArgList ((a,b),(c,d))@ is the same as+-- @toArgList (a,b,c,d)@.+class UnsafeSqlFunctionArgument a where+ toArgList :: a -> [SqlExpr (Value ())]++-- | Useful for 0-argument functions, like @now@ in Postgresql.+--+-- @since 3.2.1+instance UnsafeSqlFunctionArgument () where+ toArgList _ = []++instance (a ~ Value b) => UnsafeSqlFunctionArgument (SqlExpr a) where+ toArgList = (:[]) . veryUnsafeCoerceSqlExprValue++instance UnsafeSqlFunctionArgument a => UnsafeSqlFunctionArgument [a] where+ toArgList = concatMap toArgList++instance+ (UnsafeSqlFunctionArgument a , UnsafeSqlFunctionArgument b)+ =>+ UnsafeSqlFunctionArgument (a, b)+ where+ toArgList (a, b) = toArgList a ++ toArgList b++instance+ ( UnsafeSqlFunctionArgument a+ , UnsafeSqlFunctionArgument b+ , UnsafeSqlFunctionArgument c+ )+ =>+ UnsafeSqlFunctionArgument (a, b, c)+ where+ toArgList = toArgList . from3++instance+ ( UnsafeSqlFunctionArgument a+ , UnsafeSqlFunctionArgument b+ , UnsafeSqlFunctionArgument c+ , UnsafeSqlFunctionArgument d+ )+ =>+ UnsafeSqlFunctionArgument (a, b, c, d)+ where+ toArgList = toArgList . from4++-- | @since 3.2.3+instance+ ( UnsafeSqlFunctionArgument a+ , UnsafeSqlFunctionArgument b+ , UnsafeSqlFunctionArgument c+ , UnsafeSqlFunctionArgument d+ , UnsafeSqlFunctionArgument e+ )+ =>+ UnsafeSqlFunctionArgument (a, b, c, d, e)+ where+ toArgList = toArgList . from5++-- | @since 3.2.3+instance+ ( UnsafeSqlFunctionArgument a+ , UnsafeSqlFunctionArgument b+ , UnsafeSqlFunctionArgument c+ , UnsafeSqlFunctionArgument d+ , UnsafeSqlFunctionArgument e+ , UnsafeSqlFunctionArgument f+ )+ =>+ UnsafeSqlFunctionArgument (a, b, c, d, e, f)+ where+ toArgList = toArgList . from6++-- | @since 3.2.3+instance ( UnsafeSqlFunctionArgument a+ , UnsafeSqlFunctionArgument b+ , UnsafeSqlFunctionArgument c+ , UnsafeSqlFunctionArgument d+ , UnsafeSqlFunctionArgument e+ , UnsafeSqlFunctionArgument f+ , UnsafeSqlFunctionArgument g+ ) => UnsafeSqlFunctionArgument (a, b, c, d, e, f, g) where+ toArgList = toArgList . from7+-- | @since 3.2.3+instance ( UnsafeSqlFunctionArgument a+ , UnsafeSqlFunctionArgument b+ , UnsafeSqlFunctionArgument c+ , UnsafeSqlFunctionArgument d+ , UnsafeSqlFunctionArgument e+ , UnsafeSqlFunctionArgument f+ , UnsafeSqlFunctionArgument g+ , UnsafeSqlFunctionArgument h+ ) => UnsafeSqlFunctionArgument (a, b, c, d, e, f, g, h) where+ toArgList = toArgList . from8+-- | @since 3.2.3+instance ( UnsafeSqlFunctionArgument a+ , UnsafeSqlFunctionArgument b+ , UnsafeSqlFunctionArgument c+ , UnsafeSqlFunctionArgument d+ , UnsafeSqlFunctionArgument e+ , UnsafeSqlFunctionArgument f+ , UnsafeSqlFunctionArgument g+ , UnsafeSqlFunctionArgument h+ , UnsafeSqlFunctionArgument i+ ) => UnsafeSqlFunctionArgument (a, b, c, d, e, f, g, h, i) where+ toArgList = toArgList . from9+-- | @since 3.2.3+instance ( UnsafeSqlFunctionArgument a+ , UnsafeSqlFunctionArgument b+ , UnsafeSqlFunctionArgument c+ , UnsafeSqlFunctionArgument d+ , UnsafeSqlFunctionArgument e+ , UnsafeSqlFunctionArgument f+ , UnsafeSqlFunctionArgument g+ , UnsafeSqlFunctionArgument h+ , UnsafeSqlFunctionArgument i+ , UnsafeSqlFunctionArgument j+ ) => UnsafeSqlFunctionArgument (a, b, c, d, e, f, g, h, i, j) where+ toArgList = toArgList . from10+++-- | (Internal) Coerce a value's type from 'SqlExpr (Value a)' to+-- 'SqlExpr (Value b)'. You should /not/ use this function+-- unless you know what you're doing!+--+-- This is an alias for 'veryUnsafeCoerceSqlExpr' with the type fixed to+-- 'Value'.+veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b)+veryUnsafeCoerceSqlExprValue = veryUnsafeCoerceSqlExpr+++-- | (Internal) Coerce a value's type from 'SqlExpr (ValueList+-- a)' to 'SqlExpr (Value a)'. Does not work with empty lists.+--+-- This is an alias for 'veryUnsafeCoerceSqlExpr', with the type fixed to+-- 'ValueList' and 'Value'.+veryUnsafeCoerceSqlExprValueList :: SqlExpr (ValueList a) -> SqlExpr (Value a)+veryUnsafeCoerceSqlExprValueList = veryUnsafeCoerceSqlExpr+++----------------------------------------------------------------------++-- | (Internal) Execute an @esqueleto@ @SELECT@ 'SqlQuery' inside+-- @persistent@'s 'SqlPersistT' monad.+rawSelectSource+ ::+ ( SqlSelect a r+ , MonadIO m1+ , MonadIO m2+ , SqlBackendCanRead backend+ )+ => Mode+ -> SqlQuery a+ -> R.ReaderT backend m1 (Acquire (C.ConduitT () r m2 ()))+rawSelectSource mode query = do+ conn <- projectBackend <$> R.ask+ let _ = conn :: SqlBackend+ res <- R.withReaderT (const conn) (run conn)+ return $ (C..| massage) `fmap` res+ where+ run conn =+ uncurry rawQueryRes $+ first builderToText $+ toRawSql mode (conn, initialIdentState) query++ massage = do+ mrow <- C.await+ case sqlSelectProcessRow <$> mrow of+ Just (Right r) -> C.yield r >> massage+ Just (Left err) -> liftIO $ throwIO $ PersistMarshalError err+ Nothing -> return ()++-- | Execute an @esqueleto@ @SELECT@ query inside @persistent@'s+-- 'SqlPersistT' monad and return a 'C.Source' of rows.+selectSource+ ::+ ( SqlSelect a r+ , BackendCompatible SqlBackend backend+ , IsPersistBackend backend+ , PersistQueryRead backend+ , PersistStoreRead backend, PersistUniqueRead backend+ , MonadResource m+ )+ => SqlQuery a+ -> C.ConduitT () r (R.ReaderT backend m) ()+selectSource query = do+ res <- lift $ rawSelectSource SELECT query+ (key, src) <- lift $ allocateAcquire res+ src+ lift $ release key++-- | Execute an @esqueleto@ @SELECT@ query inside @persistent@'s+-- 'SqlPersistT' monad and return a list of rows.+--+-- We've seen that 'from' has some magic about which kinds of+-- things you may bring into scope. This 'select' function also+-- has some magic for which kinds of things you may bring back to+-- Haskell-land by using @SqlQuery@'s @return@:+--+-- * You may return a @SqlExpr ('Entity' v)@ for an entity @v@+-- (i.e., like the @*@ in SQL), which is then returned to+-- Haskell-land as just @Entity v@.+--+-- * You may return a @SqlExpr (Maybe (Entity v))@ for an entity+-- @v@ that may be @NULL@, which is then returned to+-- Haskell-land as @Maybe (Entity v)@. Used for @OUTER JOIN@s.+--+-- * You may return a @SqlExpr ('Value' t)@ for a value @t@+-- (i.e., a single column), where @t@ is any instance of+-- 'PersistField', which is then returned to Haskell-land as+-- @Value t@. You may use @Value@ to return projections of an+-- @Entity@ (see @('^.')@ and @('?.')@) or to return any other+-- value calculated on the query (e.g., 'countRows' or+-- 'subSelect').+--+-- The @SqlSelect a r@ class has functional dependencies that+-- allow type information to flow both from @a@ to @r@ and+-- vice-versa. This means that you'll almost never have to give+-- any type signatures for @esqueleto@ queries. For example, the+-- query @'select' $ from $ \\p -> return p@ alone is ambiguous, but+-- in the context of+--+-- @+-- do ps <- 'select' $+-- 'from' $ \\p ->+-- return p+-- liftIO $ mapM_ (putStrLn . personName . entityVal) ps+-- @+--+-- we are able to infer from that single @personName . entityVal@+-- function composition that the @p@ inside the query is of type+-- @SqlExpr (Entity Person)@.+select+ ::+ ( SqlSelect a r+ , MonadIO m+ , SqlBackendCanRead backend+ )+ => SqlQuery a+ -> R.ReaderT backend m [r]+select query = do+ res <- rawSelectSource SELECT query+ conn <- R.ask+ liftIO $ with res $ flip R.runReaderT conn . runSource++-- | Execute an @esqueleto@ @SELECT@ query inside @persistent@'s+-- 'SqlPersistT' monad and return the first entry wrapped in a @Maybe@.+-- @since 3.5.1.0+--+-- === __Example usage__+--+-- @+-- firstPerson :: MonadIO m => SqlPersistT m (Maybe (Entity Person))+-- firstPerson =+-- 'selectOne' $ do+-- person <- 'from' $ 'table' @Person+-- return person+-- @+--+-- The above query is equivalent to a 'select' combined with 'limit' but you+-- would still have to transform the results from a list:+--+-- @+-- firstPerson :: MonadIO m => SqlPersistT m [Entity Person]+-- firstPerson =+-- 'select' $ do+-- person <- 'from' $ 'table' @Person+-- 'limit' 1+-- return person+-- @++selectOne :: (SqlSelect a r, MonadIO m, SqlBackendCanRead backend) => SqlQuery a -> R.ReaderT backend m (Maybe r)+selectOne query = fmap Maybe.listToMaybe $ select $ limit 1 >> query++-- | (Internal) Run a 'C.Source' of rows.+runSource+ :: Monad m+ => C.ConduitT () r (R.ReaderT backend m) ()+ -> R.ReaderT backend m [r]+runSource src = C.runConduit $ src C..| CL.consume++-- | (Internal) Execute an @esqueleto@ statement inside+-- @persistent@'s 'SqlPersistT' monad.+rawEsqueleto+ :: (MonadIO m, SqlSelect a r, BackendCompatible SqlBackend backend)+ => Mode+ -> SqlQuery a+ -> R.ReaderT backend m Int64+rawEsqueleto mode query = do+ conn <- R.ask+ uncurry rawExecuteCount $+ first builderToText $+ toRawSql mode (conn, initialIdentState) query++-- | Execute an @esqueleto@ @DELETE@ query inside @persistent@'s+-- 'SqlPersistT' monad. Note that currently there are no type+-- checks for statements that should not appear on a @DELETE@+-- query.+--+-- Example of usage:+--+-- @+-- 'delete' $+-- 'from' $ \\appointment ->+-- 'where_' (appointment '^.' AppointmentDate '<.' 'val' now)+-- @+--+-- Unlike 'select', there is a useful way of using 'delete' that+-- will lead to type ambiguities. If you want to delete all rows+-- (i.e., no 'where_' clause), you'll have to use a type signature:+--+-- @+-- 'delete' $+-- 'from' $ \\(appointment :: 'SqlExpr' ('Entity' Appointment)) ->+-- return ()+-- @+--+-- ==== "Database.Esqueleto.Experimental":+--+-- @+-- delete $ do+-- userFeature <- from $ table @UserFeature+-- where_ ((userFeature ^. UserFeatureFeature) `notIn` valList allKnownFeatureFlags)+-- @+--+delete+ :: (MonadIO m, SqlBackendCanWrite backend)+ => SqlQuery ()+ -> R.ReaderT backend m ()+delete a = void $ deleteCount a++-- | Same as 'delete', but returns the number of rows affected.+deleteCount+ :: (MonadIO m, SqlBackendCanWrite backend)+ => SqlQuery ()+ -> R.ReaderT backend m Int64+deleteCount a = rawEsqueleto DELETE a++-- | Execute an @esqueleto@ @UPDATE@ query inside @persistent@'s+-- 'SqlPersistT' monad. Note that currently there are no type+-- checks for statements that should not appear on a @UPDATE@+-- query.+--+-- Example of usage:+--+-- @+-- 'update' $ \\p -> do+-- 'set' p [ PersonAge '=.' 'just' ('val' thisYear) -. p '^.' PersonBorn ]+-- 'where_' $ isNothing (p '^.' PersonAge)+-- @+update+ ::+ ( MonadIO m, PersistEntity val+ , BackendCompatible SqlBackend (PersistEntityBackend val)+ , SqlBackendCanWrite backend+ )+ => (SqlExpr (Entity val) -> SqlQuery ())+ -> R.ReaderT backend m ()+update a = void $ updateCount a++-- | Same as 'update', but returns the number of rows affected.+updateCount+ ::+ ( MonadIO m, PersistEntity val+ , BackendCompatible SqlBackend (PersistEntityBackend val)+ , SqlBackendCanWrite backend+ )+ => (SqlExpr (Entity val) -> SqlQuery ())+ -> R.ReaderT backend m Int64+updateCount a = rawEsqueleto UPDATE $ from a++builderToText :: TLB.Builder -> T.Text+builderToText = TL.toStrict . TLB.toLazyTextWith defaultChunkSize+ where+ defaultChunkSize :: Int+ defaultChunkSize = 1024 - 32++-- | (Internal) Pretty prints a 'SqlQuery' into a SQL query.+--+-- Note: if you're curious about the SQL query being generated by+-- @esqueleto@, instead of manually using this function (which is+-- possible but tedious), see the 'renderQueryToText' function (along with+-- 'renderQuerySelect', 'renderQueryUpdate', etc).+toRawSql+ :: (SqlSelect a r, BackendCompatible SqlBackend backend)+ => Mode -> (backend, IdentState) -> SqlQuery a -> (TLB.Builder, [PersistValue])+toRawSql mode (conn, firstIdentState) query =+ let ((ret, sd), finalIdentState) =+ flip S.runState firstIdentState $+ W.runWriterT $+ unQ query+ deleteRepeatedNewlines txt =+ let+ (preNewlines, rest) = TL.break (== '\n') txt+ (_, rest') = TL.break (/= '\n') rest+ in+ if TL.null rest'+ then preNewlines <> "\n"+ else preNewlines <> "\n" <> deleteRepeatedNewlines rest'++ SideData distinctClause+ fromClauses+ setClauses+ whereClauses+ groupByClause+ havingClause+ orderByClauses+ limitClause+ lockingClause+ cteClause = sd+ -- Pass the finalIdentState (containing all identifiers+ -- that were used) to the subsequent calls. This ensures+ -- that no name clashes will occur on subqueries that may+ -- appear on the expressions below.+ info = (projectBackend conn, finalIdentState)+ in (\(x, t) -> (TLB.fromLazyText $ deleteRepeatedNewlines $ TL.strip $ TLB.toLazyText x, t)) $ mconcat $ intersperse ("\n", [])+ [ makeCte info cteClause+ , makeInsertInto info mode ret+ , makeSelect info mode distinctClause ret+ , makeFrom info mode fromClauses+ , makeSet info setClauses+ , makeWhere info whereClauses+ , makeGroupBy info groupByClause+ , makeHaving info havingClause+ , makeOrderBy info orderByClauses+ , makeLimit info limitClause+ , makeLocking info lockingClause+ ]+++-- | Renders a 'SqlQuery' into a 'Text' value along with the list of+-- 'PersistValue's that would be supplied to the database for @?@ placeholders.+--+-- You must ensure that the 'Mode' you pass to this function corresponds with+-- the actual 'SqlQuery'. If you pass a query that uses incompatible features+-- (like an @INSERT@ statement with a @SELECT@ mode) then you'll get a weird+-- result.+--+-- @since 3.1.1+renderQueryToText+ :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m)+ => Mode+ -- ^ Whether to render as an 'SELECT', 'DELETE', etc.+ -> SqlQuery a+ -- ^ The SQL query you want to render.+ -> R.ReaderT backend m (T.Text, [PersistValue])+renderQueryToText mode query = do+ backend <- R.ask+ let (builder, pvals) = toRawSql mode (backend, initialIdentState) query+ pure (builderToText builder, pvals)++-- | Renders a 'SqlQuery' into a 'Text' value along with the list of+-- 'PersistValue's that would be supplied to the database for @?@ placeholders.+--+-- @since 3.1.1+renderQuerySelect+ :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m)+ => SqlQuery a+ -- ^ The SQL query you want to render.+ -> R.ReaderT backend m (T.Text, [PersistValue])+renderQuerySelect = renderQueryToText SELECT++-- | Renders a 'SqlQuery' into a 'Text' value along with the list of+-- 'PersistValue's that would be supplied to the database for @?@ placeholders.+--+-- @since 3.1.1+renderQueryDelete+ :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m)+ => SqlQuery a+ -- ^ The SQL query you want to render.+ -> R.ReaderT backend m (T.Text, [PersistValue])+renderQueryDelete = renderQueryToText DELETE++-- | Renders a 'SqlQuery' into a 'Text' value along with the list of+-- 'PersistValue's that would be supplied to the database for @?@ placeholders.+--+-- @since 3.1.1+renderQueryUpdate+ :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m)+ => SqlQuery a+ -- ^ The SQL query you want to render.+ -> R.ReaderT backend m (T.Text, [PersistValue])+renderQueryUpdate = renderQueryToText UPDATE++-- | Renders a 'SqlQuery' into a 'Text' value along with the list of+-- 'PersistValue's that would be supplied to the database for @?@ placeholders.+--+-- @since 3.1.1+renderQueryInsertInto+ :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m)+ => SqlQuery a+ -- ^ The SQL query you want to render.+ -> R.ReaderT backend m (T.Text, [PersistValue])+renderQueryInsertInto = renderQueryToText INSERT_INTO++-- | (Internal) Mode of query being converted by 'toRawSql'.+data Mode+ = SELECT+ | DELETE+ | UPDATE+ | INSERT_INTO++uncommas :: [TLB.Builder] -> TLB.Builder+uncommas = intersperseB ", "++intersperseB :: TLB.Builder -> [TLB.Builder] -> TLB.Builder+intersperseB a = mconcat . intersperse a . filter (/= mempty)++uncommas' :: Monoid a => [(TLB.Builder, a)] -> (TLB.Builder, a)+uncommas' = (uncommas *** mconcat) . unzip++makeCte :: IdentInfo -> [CommonTableExpressionClause] -> (TLB.Builder, [PersistValue])+makeCte info cteClauses =+ let+ withCteText+ | hasRecursive = "WITH RECURSIVE "+ | otherwise = "WITH "+ where++ hasRecursive =+ elem RecursiveCommonTableExpression+ $ fmap (\(CommonTableExpressionClause cteKind _ _ _) -> cteKind)+ $ cteClauses++ cteClauseToText clause@(CommonTableExpressionClause _ cteModifier cteIdent cteFn) =+ first+ (\tlb -> useIdent info cteIdent <> " AS " <> cteModifier clause info <> parens tlb)+ (cteFn info)++ cteBody =+ mconcat+ $ intersperse (",\n", mempty)+ $ fmap cteClauseToText cteClauses+ in+ case cteClauses of+ [] ->+ mempty+ _ ->+ first (\tlb -> withCteText <> tlb <> "\n") cteBody++makeInsertInto :: SqlSelect a r => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue])+makeInsertInto info INSERT_INTO ret = sqlInsertInto info ret+makeInsertInto _ _ _ = mempty++makeSelect :: SqlSelect a r => IdentInfo -> Mode -> DistinctClause -> a -> (TLB.Builder, [PersistValue])+makeSelect info mode_ distinctClause ret = process mode_+ where+ process mode =+ case mode of+ SELECT -> withCols selectKind+ DELETE -> plain "DELETE "+ UPDATE -> plain "UPDATE "+ INSERT_INTO -> process SELECT+ selectKind =+ case distinctClause of+ DistinctAll -> ("SELECT ", [])+ DistinctStandard -> ("SELECT DISTINCT ", [])+ DistinctOn exprs ->+ first (("SELECT DISTINCT ON (" <>) . (<> ") "))+ $ uncommas' (processExpr <$> exprs)+ where+ processExpr e = materializeExpr info (veryUnsafeCoerceSqlExpr e :: SqlExpr (Value a))+ withCols v = v <> sqlSelectCols info ret+ plain v = (v, [])++makeFrom+ :: IdentInfo+ -> Mode+ -> [FromClause]+ -> (TLB.Builder, [PersistValue])+makeFrom _ _ [] = mempty+makeFrom info mode fs = ret+ where+ ret =+ case collectOnClauses (fst info) fs of+ Left expr -> throw $ mkExc expr+ Right fs' -> keyword $ uncommas' (map (mk Never) fs')+ keyword =+ case mode of+ UPDATE -> id+ _ -> first ("\nFROM " <>)++ mk _ (FromStart i def) = base i def+ mk paren (FromJoin lhs kind rhs monClause) =+ first (parensM paren) $+ mconcat [ mk Never lhs+ , (fromKind kind, mempty)+ , mk Parens rhs+ , maybe mempty makeOnClause monClause+ ]+ mk _ (OnClause _) = throw (UnexpectedCaseErr MakeFromError)+ mk paren (FromRaw f) = f paren info++ base ident@(I identText) def =+ let db@(DBName dbText) = coerce $ getEntityDBName def+ in ( fromDBName info db <>+ if dbText == identText+ then mempty+ else " AS " <> useIdent info ident+ , mempty+ )++ fromKind InnerJoinKind = " INNER JOIN "+ fromKind CrossJoinKind = " CROSS JOIN "+ fromKind LeftOuterJoinKind = " LEFT OUTER JOIN "+ fromKind RightOuterJoinKind = " RIGHT OUTER JOIN "+ fromKind FullOuterJoinKind = " FULL OUTER JOIN "++ makeOnClause (ERaw _ f) = first (" ON " <>) (f Never info)++ mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException+ mkExc (ERaw _ f) =+ OnClauseWithoutMatchingJoinException $+ TL.unpack $ TLB.toLazyText $ fst (f Never info)++makeSet :: IdentInfo -> [SetClause] -> (TLB.Builder, [PersistValue])+makeSet _ [] = mempty+makeSet info os = first ("\nSET " <>) . uncommas' $ concatMap mk os+ where+ mk (SetClause (ERaw _ f)) = [f Never info]++makeWhere :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue])+makeWhere _ NoWhere = mempty+makeWhere info (Where (ERaw _ f)) = first ("\nWHERE " <>) $ f Never info++makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue])+makeGroupBy _ (GroupBy []) = (mempty, [])+makeGroupBy info (GroupBy fields) = first ("\nGROUP BY " <>) build+ where+ build :: (TLB.Builder, [PersistValue])+ build = uncommas' $ map match fields++ match :: SomeValue -> (TLB.Builder, [PersistValue])+ match (SomeValue (ERaw _ f)) = f Never info++makeHaving :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue])+makeHaving _ NoWhere = mempty+makeHaving info (Where (ERaw _ f)) = first ("\nHAVING " <>) $ f Never info++-- makeHaving, makeWhere and makeOrderBy+makeOrderByNoNewline+ :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue])+makeOrderByNoNewline _ [] = mempty+makeOrderByNoNewline info os = first ("ORDER BY " <>) . uncommas' $ concatMap mk os+ where+ mk :: OrderByClause -> [(TLB.Builder, [PersistValue])]+ mk (ERaw _ f) = [f Never info]++makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue])+makeOrderBy _ [] = mempty+makeOrderBy info is =+ let (tlb, vals) = makeOrderByNoNewline info is+ in (tlb, vals)++makeLimit :: IdentInfo -> LimitClause -> (TLB.Builder, [PersistValue])+makeLimit (conn, _) (Limit ml mo) =+ let limitRaw = getConnLimitOffset (v ml, v mo) "" conn+ v :: Maybe Int64 -> Int+ v = maybe 0 fromIntegral+ in (TLB.fromText limitRaw, mempty)++makeLocking :: IdentInfo -> LockingClause -> (TLB.Builder, [PersistValue])+makeLocking _ (LegacyLockingClause lockingClause) =+ case lockingClause of+ ForUpdate -> ("\nFOR UPDATE", [])+ ForUpdateSkipLocked -> ("\nFOR UPDATE SKIP LOCKED", [])+ ForShare -> ("\nFOR SHARE", [])+ LockInShareMode -> ("\nLOCK IN SHARE MODE", [])+makeLocking info (PostgresLockingClauses clauses) =+ List.foldl' combineBuilderValPairs ("",[]) (makePostgresLockingClauses <$> clauses)+ where+ combineBuilderValPairs (builder1, persistvals1) (builder2,persistvals2) =+ (builder1 <> builder2 <> "\n", persistvals1 <> persistvals2)++ makePostgresLockingClauses :: PostgresLockingKind -> (TLB.Builder , [PersistValue])+ makePostgresLockingClauses l =+ makeLockingStrength (postgresRowLevelLockStrength l)+ <> plain " "+ <> makeOfClause (postgresLockingOfClause l)+ <> plain " "+ <> makeLockingBehavior (postgresOnLockedBehavior l)+ makeLockingStrength :: PostgresRowLevelLockStrength -> (TLB.Builder, [PersistValue])+ makeLockingStrength PostgresForUpdate = plain "FOR UPDATE"+ makeLockingStrength PostgresForNoKeyUpdate = plain "FOR NO KEY UPDATE"+ makeLockingStrength PostgresForShare = plain "FOR SHARE"+ makeLockingStrength PostgresForKeyShare = plain "FOR KEY SHARE"++ makeLockingBehavior :: OnLockedBehavior -> (TLB.Builder, [PersistValue])+ makeLockingBehavior NoWait = plain "NOWAIT"+ makeLockingBehavior SkipLocked = plain "SKIP LOCKED"+ makeLockingBehavior Wait = plain ""++ makeOfClause :: Maybe LockingOfClause -> (TLB.Builder, [PersistValue])+ makeOfClause (Just (LockingOfClause lockableEnts)) = plain "OF " <> makeLockableEntity info lockableEnts+ makeOfClause Nothing = plain ""++ plain v = (v,[])+makeLocking _ NoLockingClause = mempty++parens :: TLB.Builder -> TLB.Builder+parens b = "(" <> (b <> ")")++aliasedEntityColumnIdent :: Ident -> FieldDef -> Ident+aliasedEntityColumnIdent (I baseIdent) field =+ I (baseIdent <> "_" <> (unDBName $ coerce $ fieldDB field))++aliasedColumnName :: Ident -> IdentInfo -> T.Text -> TLB.Builder+aliasedColumnName (I baseIdent) info columnName =+ useIdent info (I (baseIdent <> "_" <> columnName))++-- | (Internal) Class for mapping results coming from 'SqlQuery'+-- into actual results.+--+-- This looks very similar to @RawSql@, and it is! However,+-- there are some crucial differences and ultimately they're+-- different classes.+class SqlSelect a r | a -> r, r -> a where+ -- | Creates the variable part of the @SELECT@ query and+ -- returns the list of 'PersistValue's that will be given to+ -- 'rawQuery'.+ sqlSelectCols :: IdentInfo -> a -> (TLB.Builder, [PersistValue])++ -- | Number of columns that will be consumed.+ sqlSelectColCount :: Proxy a -> Int++ -- | Transform a row of the result into the data type.+ sqlSelectProcessRow :: [PersistValue] -> Either T.Text r++ -- | Create @INSERT INTO@ clause instead.+ sqlInsertInto :: IdentInfo -> a -> (TLB.Builder, [PersistValue])+ sqlInsertInto = throw (UnexpectedCaseErr UnsupportedSqlInsertIntoType)+++-- | @INSERT INTO@ hack.+instance PersistEntity e => SqlSelect (SqlExpr (Insertion e)) (Insertion e) where+ sqlInsertInto info e =+ let fields =+ uncommas $+ map (fromDBName info . coerce . fieldDB) $+ getEntityFields $+ entityDef (proxy e)++ proxy :: SqlExpr (Insertion a) -> Proxy a+ proxy = const Proxy++ table =+ fromDBName info . DBName . coerce . getEntityDBName . entityDef . proxy+ in+ ("INSERT INTO " <> table e <> parens fields <> "\n", [])+ sqlSelectCols info (ERaw _ f) = f Never info+ sqlSelectColCount = const 0+ sqlSelectProcessRow =+ const (Right (throw (UnexpectedCaseErr InsertionFinalError)))++-- | Not useful for 'select', but used for 'update' and 'delete'.+instance SqlSelect () () where+ sqlSelectCols _ _ = ("1", [])+ sqlSelectColCount _ = 1+ sqlSelectProcessRow _ = Right ()++unescapedColumnNames :: EntityDef -> [DBName]+unescapedColumnNames ent =+ addIdColumn rest+ where+ rest =+ map (coerce . fieldDB) (getEntityFields ent)+ addIdColumn =+ case getEntityId ent of+ EntityIdField fd ->+ (:) (coerce (fieldDB fd))+ EntityIdNaturalKey _ ->+ id++-- | You may return an 'Entity' from a 'select' query.+instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where+ sqlSelectCols info expr@(ERaw m f)+ | Just baseIdent <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m =+ let process = uncommas $+ map ((name <>) . aliasName) $+ unescapedColumnNames ed+ aliasName columnName = (fromDBName info columnName) <> " AS " <> aliasedColumnName baseIdent info (unDBName columnName)+ name = fst (f Never info) <> "."+ ed = entityDef $ getEntityVal $ return expr+ in (process, mempty)+ | Just baseIdent <- sqlExprMetaAlias m, True <- sqlExprMetaIsReference m =+ let process = uncommas $+ map ((name <>) . aliasedColumnName baseIdent info . unDBName) $+ unescapedColumnNames ed+ name = fst (f Never info) <> "."+ ed = entityDef $ getEntityVal $ return expr+ in (process, mempty)+ | otherwise =+ let process =+ uncommas+ $ map ((name <>) . TLB.fromText)+ $ NEL.toList+ $ keyAndEntityColumnNames ed (fst info)+ -- 'name' is the biggest difference between 'RawSql' and+ -- 'SqlSelect'. We automatically create names for tables+ -- (since it's not the user who's writing the FROM+ -- clause), while 'rawSql' assumes that it's just the+ -- name of the table (which doesn't allow self-joins, for+ -- example).+ name = fst (f Never info) <> "."+ ed = entityDef $ getEntityVal $ return expr+ in (process, mempty)++ sqlSelectColCount = entityColumnCount . entityDef . getEntityVal+ sqlSelectProcessRow = parseEntityValues ed+ where+ ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity a)))++getEntityVal :: Proxy (SqlExpr (Entity a)) -> Proxy a+getEntityVal = const Proxy++-- | You may return a possibly-@NULL@ 'Entity' from a 'select' query.+instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where+ sqlSelectCols info e = sqlSelectCols info (veryUnsafeCoerceSqlExpr e :: SqlExpr (Entity a))+ sqlSelectColCount = sqlSelectColCount . fromEMaybe+ where+ fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e)+ fromEMaybe = const Proxy+ sqlSelectProcessRow cols+ | all (== PersistNull) cols = return Nothing+ | otherwise = Just <$> sqlSelectProcessRow cols+++-- | You may return any single value (i.e. a single column) from+-- a 'select' query.+instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where+ sqlSelectCols = materializeExpr+ sqlSelectColCount = const 1+ sqlSelectProcessRow [pv] = Value <$> fromPersistValue pv+ sqlSelectProcessRow pvs = Value <$> fromPersistValue (PersistList pvs)++-- | Materialize a @SqlExpr (Value a)@.+materializeExpr :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue])+materializeExpr info (ERaw m f)+ | Just fields <- sqlExprMetaCompositeFields m = (uncommas $ fmap parens $ fields info, [])+ | Just alias <- sqlExprMetaAlias m+ , not (sqlExprMetaIsReference m) = first (<> " AS " <> useIdent info alias) (f Parens info)+ | otherwise = f Parens info+++-- | You may return tuples (up to 16-tuples) and tuples of tuples+-- from a 'select' query.+instance (SqlSelect a ra, SqlSelect b rb) => SqlSelect (a, b) (ra, rb) where+ sqlSelectCols esc (a, b) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ ]+ sqlSelectColCount = uncurry (+) . (sqlSelectColCount *** sqlSelectColCount) . fromTuple+ where+ fromTuple :: Proxy (a,b) -> (Proxy a, Proxy b)+ fromTuple = const (Proxy, Proxy)+ sqlSelectProcessRow =+ let x = getType processRow+ getType :: SqlSelect a r => (z -> Either y (r,x)) -> Proxy a+ getType = const Proxy++ colCountFst = sqlSelectColCount x++ processRow row =+ let (rowFst, rowSnd) = splitAt colCountFst row+ in (,) <$> sqlSelectProcessRow rowFst+ <*> sqlSelectProcessRow rowSnd++ in colCountFst `seq` processRow+ -- Avoids recalculating 'colCountFst'.++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ ) => SqlSelect (a, b, c) (ra, rb, rc) where+ sqlSelectCols esc (a, b, c) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ ]+ sqlSelectColCount = sqlSelectColCount . from3P+ sqlSelectProcessRow = fmap to3 . sqlSelectProcessRow++from3P :: Proxy (a,b,c) -> Proxy ((a,b),c)+from3P = const Proxy++from3 :: (a,b,c) -> ((a,b),c)+from3 (a,b,c) = ((a,b),c)++to3 :: ((a,b),c) -> (a,b,c)+to3 ((a,b),c) = (a,b,c)++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ ) => SqlSelect (a, b, c, d) (ra, rb, rc, rd) where+ sqlSelectCols esc (a, b, c, d) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ ]+ sqlSelectColCount = sqlSelectColCount . from4P+ sqlSelectProcessRow = fmap to4 . sqlSelectProcessRow++from4P :: Proxy (a,b,c,d) -> Proxy ((a,b),(c,d))+from4P = const Proxy++from4 :: (a,b,c,d) -> ((a,b),(c,d))+from4 (a,b,c,d) = ((a,b),(c,d))++to4 :: ((a,b),(c,d)) -> (a,b,c,d)+to4 ((a,b),(c,d)) = (a,b,c,d)++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ , SqlSelect e re+ ) => SqlSelect (a, b, c, d, e) (ra, rb, rc, rd, re) where+ sqlSelectCols esc (a, b, c, d, e) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ , sqlSelectCols esc e+ ]+ sqlSelectColCount = sqlSelectColCount . from5P+ sqlSelectProcessRow = fmap to5 . sqlSelectProcessRow++from5P :: Proxy (a,b,c,d,e) -> Proxy ((a,b),(c,d),e)+from5P = const Proxy++from5 :: (a,b,c,d,e) -> ((a,b),(c,d),e)+from5 (a,b,c,d,e) = ((a,b),(c,d),e)++to5 :: ((a,b),(c,d),e) -> (a,b,c,d,e)+to5 ((a,b),(c,d),e) = (a,b,c,d,e)++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ , SqlSelect e re+ , SqlSelect f rf+ ) => SqlSelect (a, b, c, d, e, f) (ra, rb, rc, rd, re, rf) where+ sqlSelectCols esc (a, b, c, d, e, f) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ , sqlSelectCols esc e+ , sqlSelectCols esc f+ ]+ sqlSelectColCount = sqlSelectColCount . from6P+ sqlSelectProcessRow = fmap to6 . sqlSelectProcessRow++from6P :: Proxy (a,b,c,d,e,f) -> Proxy ((a,b),(c,d),(e,f))+from6P = const Proxy++from6 :: (a,b,c,d,e,f) -> ((a,b),(c,d),(e,f))+from6 (a,b,c,d,e,f) = ((a,b),(c,d),(e,f))++to6 :: ((a,b),(c,d),(e,f)) -> (a,b,c,d,e,f)+to6 ((a,b),(c,d),(e,f)) = (a,b,c,d,e,f)++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ , SqlSelect e re+ , SqlSelect f rf+ , SqlSelect g rg+ ) => SqlSelect (a, b, c, d, e, f, g) (ra, rb, rc, rd, re, rf, rg) where+ sqlSelectCols esc (a, b, c, d, e, f, g) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ , sqlSelectCols esc e+ , sqlSelectCols esc f+ , sqlSelectCols esc g+ ]+ sqlSelectColCount = sqlSelectColCount . from7P+ sqlSelectProcessRow = fmap to7 . sqlSelectProcessRow++from7P :: Proxy (a,b,c,d,e,f,g) -> Proxy ((a,b),(c,d),(e,f),g)+from7P = const Proxy++from7 :: (a,b,c,d,e,f,g) -> ((a,b),(c,d),(e,f),g)+from7 (a,b,c,d,e,f,g) = ((a,b),(c,d),(e,f),g)++to7 :: ((a,b),(c,d),(e,f),g) -> (a,b,c,d,e,f,g)+to7 ((a,b),(c,d),(e,f),g) = (a,b,c,d,e,f,g)++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ , SqlSelect e re+ , SqlSelect f rf+ , SqlSelect g rg+ , SqlSelect h rh+ ) => SqlSelect (a, b, c, d, e, f, g, h) (ra, rb, rc, rd, re, rf, rg, rh) where+ sqlSelectCols esc (a, b, c, d, e, f, g, h) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ , sqlSelectCols esc e+ , sqlSelectCols esc f+ , sqlSelectCols esc g+ , sqlSelectCols esc h+ ]+ sqlSelectColCount = sqlSelectColCount . from8P+ sqlSelectProcessRow = fmap to8 . sqlSelectProcessRow++from8P :: Proxy (a,b,c,d,e,f,g,h) -> Proxy ((a,b),(c,d),(e,f),(g,h))+from8P = const Proxy++from8 :: (a,b,c,d,e,f,g,h) -> ((a,b),(c,d),(e,f),(g,h))+from8 (a,b,c,d,e,f,g,h) = ((a,b),(c,d),(e,f),(g,h))++to8 :: ((a,b),(c,d),(e,f),(g,h)) -> (a,b,c,d,e,f,g,h)+to8 ((a,b),(c,d),(e,f),(g,h)) = (a,b,c,d,e,f,g,h)++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ , SqlSelect e re+ , SqlSelect f rf+ , SqlSelect g rg+ , SqlSelect h rh+ , SqlSelect i ri+ ) => SqlSelect (a, b, c, d, e, f, g, h, i) (ra, rb, rc, rd, re, rf, rg, rh, ri) where+ sqlSelectCols esc (a, b, c, d, e, f, g, h, i) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ , sqlSelectCols esc e+ , sqlSelectCols esc f+ , sqlSelectCols esc g+ , sqlSelectCols esc h+ , sqlSelectCols esc i+ ]+ sqlSelectColCount = sqlSelectColCount . from9P+ sqlSelectProcessRow = fmap to9 . sqlSelectProcessRow++from9P :: Proxy (a,b,c,d,e,f,g,h,i) -> Proxy ((a,b),(c,d),(e,f),(g,h),i)+from9P = const Proxy++from9 :: (a,b,c,d,e,f,g,h,i) -> ((a,b),(c,d),(e,f),(g,h),i)+from9 (a,b,c,d,e,f,g,h,i) = ((a,b),(c,d),(e,f),(g,h),i)++to9 :: ((a,b),(c,d),(e,f),(g,h),i) -> (a,b,c,d,e,f,g,h,i)+to9 ((a,b),(c,d),(e,f),(g,h),i) = (a,b,c,d,e,f,g,h,i)++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ , SqlSelect e re+ , SqlSelect f rf+ , SqlSelect g rg+ , SqlSelect h rh+ , SqlSelect i ri+ , SqlSelect j rj+ ) => SqlSelect (a, b, c, d, e, f, g, h, i, j) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj) where+ sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ , sqlSelectCols esc e+ , sqlSelectCols esc f+ , sqlSelectCols esc g+ , sqlSelectCols esc h+ , sqlSelectCols esc i+ , sqlSelectCols esc j+ ]+ sqlSelectColCount = sqlSelectColCount . from10P+ sqlSelectProcessRow = fmap to10 . sqlSelectProcessRow++from10P :: Proxy (a,b,c,d,e,f,g,h,i,j) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j))+from10P = const Proxy++from10 :: (a,b,c,d,e,f,g,h,i,j) -> ((a,b),(c,d),(e,f),(g,h),(i,j))+from10 (a,b,c,d,e,f,g,h,i,j) = ((a,b),(c,d),(e,f),(g,h),(i,j))++to10 :: ((a,b),(c,d),(e,f),(g,h),(i,j)) -> (a,b,c,d,e,f,g,h,i,j)+to10 ((a,b),(c,d),(e,f),(g,h),(i,j)) = (a,b,c,d,e,f,g,h,i,j)++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ , SqlSelect e re+ , SqlSelect f rf+ , SqlSelect g rg+ , SqlSelect h rh+ , SqlSelect i ri+ , SqlSelect j rj+ , SqlSelect k rk+ ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk) where+ sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ , sqlSelectCols esc e+ , sqlSelectCols esc f+ , sqlSelectCols esc g+ , sqlSelectCols esc h+ , sqlSelectCols esc i+ , sqlSelectCols esc j+ , sqlSelectCols esc k+ ]+ sqlSelectColCount = sqlSelectColCount . from11P+ sqlSelectProcessRow = fmap to11 . sqlSelectProcessRow++from11P :: Proxy (a,b,c,d,e,f,g,h,i,j,k) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),k)+from11P = const Proxy++from11 :: (a,b,c,d,e,f,g,h,i,j,k) -> ((a,b),(c,d),(e,f),(g,h),(i,j),k)+from11 (a,b,c,d,e,f,g,h,i,j,k) = ((a,b),(c,d),(e,f),(g,h),(i,j),k)++to11 :: ((a,b),(c,d),(e,f),(g,h),(i,j),k) -> (a,b,c,d,e,f,g,h,i,j,k)+to11 ((a,b),(c,d),(e,f),(g,h),(i,j),k) = (a,b,c,d,e,f,g,h,i,j,k)++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ , SqlSelect e re+ , SqlSelect f rf+ , SqlSelect g rg+ , SqlSelect h rh+ , SqlSelect i ri+ , SqlSelect j rj+ , SqlSelect k rk+ , SqlSelect l rl+ ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl) where+ sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ , sqlSelectCols esc e+ , sqlSelectCols esc f+ , sqlSelectCols esc g+ , sqlSelectCols esc h+ , sqlSelectCols esc i+ , sqlSelectCols esc j+ , sqlSelectCols esc k+ , sqlSelectCols esc l+ ]+ sqlSelectColCount = sqlSelectColCount . from12P+ sqlSelectProcessRow = fmap to12 . sqlSelectProcessRow++from12P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l))+from12P = const Proxy++from12 :: (a,b,c,d,e,f,g,h,i,j,k,l) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l))+from12 (a,b,c,d,e,f,g,h,i,j,k,l) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l))++to12 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) -> (a,b,c,d,e,f,g,h,i,j,k,l)+to12 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) = (a,b,c,d,e,f,g,h,i,j,k,l)++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ , SqlSelect e re+ , SqlSelect f rf+ , SqlSelect g rg+ , SqlSelect h rh+ , SqlSelect i ri+ , SqlSelect j rj+ , SqlSelect k rk+ , SqlSelect l rl+ , SqlSelect m rm+ ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm) where+ sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ , sqlSelectCols esc e+ , sqlSelectCols esc f+ , sqlSelectCols esc g+ , sqlSelectCols esc h+ , sqlSelectCols esc i+ , sqlSelectCols esc j+ , sqlSelectCols esc k+ , sqlSelectCols esc l+ , sqlSelectCols esc m+ ]+ sqlSelectColCount = sqlSelectColCount . from13P+ sqlSelectProcessRow = fmap to13 . sqlSelectProcessRow++from13P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m)+from13P = const Proxy++from13 :: (a,b,c,d,e,f,g,h,i,j,k,l,m) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m)+from13 (a,b,c,d,e,f,g,h,i,j,k,l,m) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m)++to13 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) -> (a,b,c,d,e,f,g,h,i,j,k,l,m)+to13 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) = (a,b,c,d,e,f,g,h,i,j,k,l,m)++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ , SqlSelect e re+ , SqlSelect f rf+ , SqlSelect g rg+ , SqlSelect h rh+ , SqlSelect i ri+ , SqlSelect j rj+ , SqlSelect k rk+ , SqlSelect l rl+ , SqlSelect m rm+ , SqlSelect n rn+ ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn) where+ sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ , sqlSelectCols esc e+ , sqlSelectCols esc f+ , sqlSelectCols esc g+ , sqlSelectCols esc h+ , sqlSelectCols esc i+ , sqlSelectCols esc j+ , sqlSelectCols esc k+ , sqlSelectCols esc l+ , sqlSelectCols esc m+ , sqlSelectCols esc n+ ]+ sqlSelectColCount = sqlSelectColCount . from14P+ sqlSelectProcessRow = fmap to14 . sqlSelectProcessRow++from14P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n))+from14P = const Proxy++from14 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n))+from14 (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n))++to14 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n)+to14 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n)++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ , SqlSelect e re+ , SqlSelect f rf+ , SqlSelect g rg+ , SqlSelect h rh+ , SqlSelect i ri+ , SqlSelect j rj+ , SqlSelect k rk+ , SqlSelect l rl+ , SqlSelect m rm+ , SqlSelect n rn+ , SqlSelect o ro+ ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn, ro) where+ sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ , sqlSelectCols esc e+ , sqlSelectCols esc f+ , sqlSelectCols esc g+ , sqlSelectCols esc h+ , sqlSelectCols esc i+ , sqlSelectCols esc j+ , sqlSelectCols esc k+ , sqlSelectCols esc l+ , sqlSelectCols esc m+ , sqlSelectCols esc n+ , sqlSelectCols esc o+ ]+ sqlSelectColCount = sqlSelectColCount . from15P+ sqlSelectProcessRow = fmap to15 . sqlSelectProcessRow++from15P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n, o) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o)+from15P = const Proxy++from15 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o)+from15 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o)++to15 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)+to15 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ , SqlSelect e re+ , SqlSelect f rf+ , SqlSelect g rg+ , SqlSelect h rh+ , SqlSelect i ri+ , SqlSelect j rj+ , SqlSelect k rk+ , SqlSelect l rl+ , SqlSelect m rm+ , SqlSelect n rn+ , SqlSelect o ro+ , SqlSelect p rp+ ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn, ro, rp) where+ sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ , sqlSelectCols esc e+ , sqlSelectCols esc f+ , sqlSelectCols esc g+ , sqlSelectCols esc h+ , sqlSelectCols esc i+ , sqlSelectCols esc j+ , sqlSelectCols esc k+ , sqlSelectCols esc l+ , sqlSelectCols esc m+ , sqlSelectCols esc n+ , sqlSelectCols esc o+ , sqlSelectCols esc p+ ]+ sqlSelectColCount = sqlSelectColCount . from16P+ sqlSelectProcessRow = fmap to16 . sqlSelectProcessRow++from16P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p))+from16P = const Proxy++from16 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p))+from16 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p))++to16 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)+to16 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)++-- | Insert a 'PersistField' for every selected value.+--+-- @since 2.4.2+insertSelect+ :: (MonadIO m, PersistEntity a, SqlBackendCanWrite backend)+ => SqlQuery (SqlExpr (Insertion a))+ -> R.ReaderT backend m ()+insertSelect a = void $ insertSelectCount a++-- | Insert a 'PersistField' for every selected value, return the count afterward+insertSelectCount+ :: (MonadIO m, PersistEntity a, SqlBackendCanWrite backend)+ => SqlQuery (SqlExpr (Insertion a))+ -> R.ReaderT backend m Int64+insertSelectCount a = rawEsqueleto INSERT_INTO a++-- | Renders an expression into 'Text'. Only useful for creating a textual+-- representation of the clauses passed to an "On" clause.+--+-- @since 3.2.0+renderExpr :: SqlBackend -> SqlExpr (Value Bool) -> T.Text+renderExpr sqlBackend e = case e of+ ERaw _ mkBuilderValues ->+ let (builder, _) = mkBuilderValues Never (sqlBackend, initialIdentState)+ in (builderToText builder)++-- | An exception thrown by 'RenderExpr' - it's not designed to handle composite+-- keys, and will blow up if you give it one.+--+-- @since 3.2.0+data RenderExprException = RenderExprUnexpectedECompositeKey T.Text+ deriving Show++-- |+--+-- @since 3.2.0+instance Exception RenderExprException++-- | @valkey i = 'val' . 'toSqlKey'@+-- (<https://github.com/prowdsponsor/esqueleto/issues/9>).+valkey+ :: (ToBackendKey SqlBackend entity, PersistField (Key entity))+ => Int64 -> SqlExpr (Value (Key entity))+valkey = val . toSqlKey++-- | @valJ@ is like @val@ but for something that is already a @Value@. The use+-- case it was written for was, given a @Value@ lift the @Key@ for that @Value@+-- into the query expression in a type safe way. However, the implementation is+-- more generic than that so we call it @valJ@.+--+-- Its important to note that the input entity and the output entity are+-- constrained to be the same by the type signature on the function+-- (<https://github.com/prowdsponsor/esqueleto/pull/69>).+--+-- @since 1.4.2+valJ+ :: (PersistField (Key entity))+ => Value (Key entity)+ -> SqlExpr (Value (Key entity))+valJ = val . unValue+++-- | Synonym for 'Database.Persist.Store.delete' that does not+-- clash with @esqueleto@'s 'delete'.+deleteKey+ ::+ ( PersistStore backend+ , BaseBackend backend ~ PersistEntityBackend val+ , MonadIO m+ , PersistEntity val+ )+ => Key val+ -> R.ReaderT backend m ()+deleteKey = Database.Persist.delete++-- | Avoid N+1 queries and join entities into a map structure.+--+-- This function is useful to call on the result of a single @JOIN@. For+-- example, suppose you have this query:+--+-- @+-- getFoosAndNestedBarsFromParent+-- :: ParentId+-- -> SqlPersistT IO [(Entity Foo, Maybe (Entity Bar))]+-- getFoosAndNestedBarsFromParent parentId =+-- 'select' $ do+-- (foo :& bar) <- from $+-- table @Foo+-- ``LeftOuterJoin``+-- table @Bar+-- ``on`` do+-- \\(foo :& bar) ->+-- foo ^. FooId ==. bar ?. BarFooId+-- where_ $+-- foo ^. FooParentId ==. val parentId+-- pure (foo, bar)+-- @+--+-- This is a natural result type for SQL - a list of tuples. However, it's not+-- what we usually want in Haskell - each @Foo@ in the list will be represented+-- multiple times, once for each @Bar@.+--+-- We can write @'fmap' 'associateJoin'@ and it will translate it into a 'Map'+-- that is keyed on the 'Key' of the left 'Entity', and the value is a tuple of+-- the entity's value as well as the list of each coresponding entity.+--+-- @+-- getFoosAndNestedBarsFromParentHaskellese+-- :: ParentId+-- -> SqlPersistT (Map (Key Foo) (Foo, [Maybe (Entity Bar)]))+-- getFoosAndNestedBarsFromParentHaskellese parentId =+-- 'fmap' 'associateJoin' $ getFoosdAndNestedBarsFromParent parentId+-- @+--+-- What if you have multiple joins?+--+-- Let's use 'associateJoin' with a *two* join query.+--+-- @+-- userPostComments+-- :: SqlQuery (SqlExpr (Entity User, Entity Post, Entity Comment))+-- userPostsComment = do+-- (u :& p :& c) <- from $+-- table @User+-- ``InnerJoin``+-- table @Post+-- `on` do+-- \\(u :& p) ->+-- u ^. UserId ==. p ^. PostUserId+-- ``InnerJoin``+-- table @Comment+-- ``on`` do+-- \\(_ :& p :& c) ->+-- p ^. PostId ==. c ^. CommentPostId+-- pure (u, p, c)+-- @+--+-- This query returns a User, with all of the users Posts, and then all of the+-- Comments on that post.+--+-- First, we *nest* the tuple.+--+-- @+-- nest :: (a, b, c) -> (a, (b, c))+-- nest (a, b, c) = (a, (b, c))+-- @+--+-- This makes the return of the query conform to the input expected from+-- 'associateJoin'.+--+-- @+-- nestedUserPostComments+-- :: SqlPersistT IO [(Entity User, (Entity Post, Entity Comment))]+-- nestedUserPostComments =+-- fmap nest $ select userPostsComments+-- @+--+-- Now, we can call 'associateJoin' on it.+--+-- @+-- associateUsers+-- :: [(Entity User, (Entity Post, Entity Comment))]+-- -> Map UserId (User, [(Entity Post, Entity Comment)])+-- associateUsers =+-- associateJoin+-- @+--+-- Next, we'll use the 'Functor' instances for 'Map' and tuple to call+-- 'associateJoin' on the @[(Entity Post, Entity Comment)]@.+--+-- @+-- associatePostsAndComments+-- :: Map UserId (User, [(Entity Post, Entity Comment)])+-- -> Map UserId (User, Map PostId (Post, [Entity Comment]))+-- associatePostsAndComments =+-- fmap (fmap associateJoin)+-- @+--+-- For more reading on this topic, see+-- <https://www.foxhound.systems/blog/grouping-query-results-haskell/ this Foxhound Systems blog post>.+--+-- @since 3.1.2+associateJoin+ :: forall e1 e0. Ord (Key e0)+ => [(Entity e0, e1)]+ -> Map.Map (Key e0) (e0, [e1])+associateJoin = foldr f start+ where+ start = Map.empty+ f (one, many) =+ Map.insertWith+ (\(oneOld, manyOld) (_, manyNew) -> (oneOld, manyNew ++ manyOld ))+ (entityKey one)+ (entityVal one, [many])++type family Nullable a where+ Nullable (Maybe a) = a+ Nullable a = a
− src/Database/Esqueleto/Internal/Language.hs
@@ -1,69 +0,0 @@-{-# LANGUAGE DeriveDataTypeable- , EmptyDataDecls- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , MultiParamTypeClasses- , TypeFamilies- , UndecidableInstances- , GADTs- #-}--- | This is an internal module, anything exported by this module--- may change without a major version bump. Please use only--- "Database.Esqueleto" if possible.-module Database.Esqueleto.Internal.Language- ( -- * The pretty face- from- , Value(..)- , ValueList(..)- , SomeValue(..)- , ToSomeValues(..)- , InnerJoin(..)- , CrossJoin(..)- , LeftOuterJoin(..)- , RightOuterJoin(..)- , FullOuterJoin(..)- , OnClauseWithoutMatchingJoinException(..)- , OrderBy- , DistinctOn- , Update- , Insertion- , LockingKind(..)- , SqlString- , ToBaseId(..)- -- * The guts- , JoinKind(..)- , IsJoinKind(..)- , BackendCompatible(..)- , PreprocessedFrom- , From- , FromPreprocess- , when_- , then_- , else_- , where_, on, groupBy, orderBy, rand, asc, desc, limit, offset- , distinct, distinctOn, don, distinctOnOrderBy, having, locking- , sub_select, (^.), (?.)- , val, isNothing, just, nothing, joinV, withNonNull- , countRows, count, countDistinct- , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.)- , between, (+.), (-.), (/.), (*.)- , random_, round_, ceiling_, floor_- , min_, max_, sum_, avg_, castNum, castNumM- , coalesce, coalesceDefault- , lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_- , like, ilike, (%), concat_, (++.), castString- , subList_select, valList, justList- , in_, notIn, exists, notExists- , set, (=.), (+=.), (-=.), (*=.), (/=.)- , case_, toBaseId, (<#), (<&>)- , subSelect- , subSelectMaybe- , subSelectCount- , subSelectList- , subSelectForeign- , subSelectUnsafe- ) where--import Database.Esqueleto.Internal.PersistentImport-import Database.Esqueleto.Internal.Internal
src/Database/Esqueleto/Internal/PersistentImport.hs view
@@ -1,150 +1,41 @@+{-# language CPP #-}+ -- | Re-export "Database.Persist.Sql" without any clashes with -- @esqueleto@. module Database.Esqueleto.Internal.PersistentImport--- NOTE: switch back to a module export once https://gitlab.haskell.org/ghc/ghc/merge_requests/276--- has been merged. See https://github.com/bitemyapp/esqueleto/issues/110 for more details- ( toJsonText,- entityIdFromJSON,- entityIdToJSON,- entityValues,- fromPersistValueJSON,- keyValueEntityFromJSON,- keyValueEntityToJSON,- toPersistValueJSON,- selectKeys,- belongsTo,- belongsToJust,- getEntity,- getJust,- getJustEntity,- insertEntity,- insertRecord,- liftPersist,- checkUnique,- getByValue,- insertBy,- insertUniqueEntity,- onlyUnique,- replaceUnique,- transactionSave,- transactionUndo,- defaultAttribute,- mkColumns,- getMigration,- migrate,- parseMigration,- parseMigration',- printMigration,- runMigration,- runMigrationSilent,- runMigrationUnsafe,- showMigration,- decorateSQLWithLimitOffset,- fieldDBName,- fromSqlKey,- getFieldName,- getTableName,- tableDBName,- toSqlKey,- withRawQuery,- getStmtConn,- rawExecute,- rawExecuteCount,- rawQuery,- rawQueryRes,- rawSql,- askLogFunc,- close',- createSqlPool,- liftSqlPersistMPool,- runSqlConn,- runSqlPersistM,- runSqlPersistMPool,- runSqlPool,- withSqlConn,- withSqlPool,- readToUnknown,- readToWrite,- writeToUnknown,- entityKeyFields,- entityPrimary,- fromPersistValueText,- keyAndEntityFields,- toEmbedEntityDef,- PersistStore,- PersistUnique,- DeleteCascade(..),- PersistConfig(..),- BackendSpecificUpdate,- Entity(..),- PersistEntity(..),- PersistField(..),- SomePersistField(..),- PersistQueryRead(..),- PersistQueryWrite(..),- BackendCompatible(..),- BackendKey(..),- HasPersistBackend(..),- IsPersistBackend,- PersistCore(..),- PersistRecordBackend,- PersistStoreRead(..),- PersistStoreWrite(..),- ToBackendKey(..),- PersistUniqueRead(..),- PersistUniqueWrite(..),- PersistFieldSql(..),- RawSql(..),- CautiousMigration,- Column(..),- ConnectionPool,- Migration,- PersistentSqlException(..),- Single(..),- Sql,- SqlPersistM,- SqlPersistT,- InsertSqlResult(..),- IsSqlBackend,- LogFunc,- SqlBackend(..),- SqlBackendCanRead,- SqlBackendCanWrite,- SqlReadBackend(..),- SqlReadT,- SqlWriteBackend(..),- SqlWriteT,- Statement(..),- Attr,- Checkmark(..),- CompositeDef(..),- DBName(..),- EmbedEntityDef(..),- EmbedFieldDef(..),- EntityDef(..),- ExtraLine,- FieldDef(..),- FieldType(..),- ForeignDef(..),- ForeignFieldDef,- HaskellName(..),- IsNullable(..),- OnlyUniqueException(..),- PersistException(..),- PersistFilter(..),- PersistUpdate(..),- PersistValue(..),- ReferenceDef(..),- SqlType(..),- UniqueDef(..),- UpdateException(..),- WhyNullable(..)- ) where+ (module Database.Persist.Sql) where import Database.Persist.Sql hiding- ( BackendSpecificFilter, Filter(..), PersistQuery, SelectOpt(..)- , Update(..), delete, deleteWhereCount, updateWhereCount, selectList- , selectKeysList, deleteCascadeWhere, (=.), (+=.), (-=.), (*=.), (/=.)- , (==.), (!=.), (<.), (>.), (<=.), (>=.), (<-.), (/<-.), (||.)- , listToJSON, mapToJSON, getPersistMap, limitOffsetOrder, selectSource- , update , count )+ ( BackendSpecificFilter+ , Filter(..)+ , PersistQuery+ , SelectOpt(..)+ , Update(..)+ , count+ , delete+ , deleteWhereCount+ , exists+ , getPersistMap+ , limitOffsetOrder+ , listToJSON+ , mapToJSON+ , selectKeysList+ , selectList+ , selectSource+ , update+ , updateWhereCount+ , (!=.)+ , (*=.)+ , (+=.)+ , (-=.)+ , (/<-.)+ , (/=.)+ , (<-.)+ , (<.)+ , (<=.)+ , (=.)+ , (==.)+ , (>.)+ , (>=.)+ , (||.)+ )
− src/Database/Esqueleto/Internal/Sql.hs
@@ -1,78 +0,0 @@-{-# LANGUAGE DeriveDataTypeable- , EmptyDataDecls- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , MultiParamTypeClasses- , TypeFamilies- , UndecidableInstances- , GADTs- #-}-{-# LANGUAGE ConstraintKinds- , EmptyDataDecls- , FlexibleContexts- , FlexibleInstances- , FunctionalDependencies- , GADTs- , MultiParamTypeClasses- , OverloadedStrings- , UndecidableInstances- , ScopedTypeVariables- , InstanceSigs- , Rank2Types- , CPP- #-}--- | This is an internal module, anything exported by this module--- may change without a major version bump. Please use only--- "Database.Esqueleto" if possible.-module Database.Esqueleto.Internal.Sql- ( -- * The pretty face- SqlQuery- , SqlExpr(..)- , SqlEntity- , select- , selectSource- , delete- , deleteCount- , update- , updateCount- , insertSelect- , insertSelectCount- -- * The guts- , unsafeSqlCase- , unsafeSqlBinOp- , unsafeSqlBinOpComposite- , unsafeSqlValue- , unsafeSqlCastAs- , unsafeSqlFunction- , unsafeSqlExtractSubField- , UnsafeSqlFunctionArgument- , OrderByClause- , rawSelectSource- , runSource- , rawEsqueleto- , toRawSql- , Mode(..)- , NeedParens(..)- , IdentState- , renderExpr- , initialIdentState- , IdentInfo- , SqlSelect(..)- , veryUnsafeCoerceSqlExprValue- , veryUnsafeCoerceSqlExprValueList- -- * Helper functions- , renderQueryToText- , renderQuerySelect- , renderQueryUpdate- , renderQueryDelete- , renderQueryInsertInto- , makeOrderByNoNewline- , uncommas'- , parens- , toArgList- , builderToText- , Ident(..)- ) where--import Database.Esqueleto.Internal.Internal
+ src/Database/Esqueleto/Legacy.hs view
@@ -0,0 +1,419 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++-- | WARNING+--+-- This module is introduced in version @3.5.0.0@ to provide a smooth migration+-- experience from this legacy syntax to the new and improved syntax. If you've+-- imported this module, it means you've decided to use the old syntax for+-- a little bit longer, rather than migrate to the new stuff. That's fine!+--+-- But you should know that this module, and all of the legacy syntax, will be+-- completely removed from the library in version @4.0.0.0@.+--+-- The @esqueleto@ EDSL (embedded domain specific language).+-- This module replaces @Database.Persist@, so instead of+-- importing that module you should just import this one:+--+-- @+-- -- For a module using just esqueleto.+-- import Database.Esqueleto+-- @+--+-- If you need to use @persistent@'s default support for queries+-- as well, either import it qualified:+--+-- @+-- -- For a module that mostly uses esqueleto.+-- import Database.Esqueleto+-- import qualified Database.Persist as P+-- @+--+-- or import @esqueleto@ itself qualified:+--+-- @+-- -- For a module that uses esqueleto just on some queries.+-- import Database.Persist+-- import qualified Database.Esqueleto as E+-- @+--+-- Other than identifier name clashes, @esqueleto@ does not+-- conflict with @persistent@ in any way.+module Database.Esqueleto.Legacy+ ( -- * Setup+ -- $setup++ -- * Introduction+ -- $introduction++ -- * Getting started+ -- $gettingstarted++ -- * @esqueleto@'s Language+ where_, on, groupBy, orderBy, asc, desc, limit, offset+ , distinct, distinctOn, don, distinctOnOrderBy, having, locking+ , (^.), (?.)+ , val, isNothing, just, just', nothing, joinV, joinV', withNonNull+ , countRows, count, countDistinct+ , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.)+ , between, (+.), (-.), (/.), (*.)+ , round_, ceiling_, floor_+ , min_, max_, sum_, avg_, castNum, castNumM+ , coalesce, coalesceDefault+ , lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_+ , like, ilike, (%), concat_, (++.), castString+ , subList_select, valList, justList+ , in_, notIn, exists, notExists+ , set, (=.), (+=.), (-=.), (*=.), (/=.)+ , case_, toBaseId, fromBaseId, fromBaseIdMaybe, toBaseIdMaybe+ , subSelect+ , subSelectMaybe+ , subSelectCount+ , subSelectForeign+ , subSelectList+ , subSelectUnsafe+ , ToBaseId(..)+ , when_+ , then_+ , else_+ , from+ , Value(..)+ , ValueList(..)+ , OrderBy+ , DistinctOn+ , LockingKind(..)+ , forUpdate+ , forUpdateSkipLocked+ , LockableEntity(..)+ , SqlString+ -- ** Joins+ , InnerJoin(..)+ , CrossJoin(..)+ , LeftOuterJoin(..)+ , RightOuterJoin(..)+ , FullOuterJoin(..)+ , JoinKind(..)+ , OnClauseWithoutMatchingJoinException(..)+ -- * SQL backend+ , SqlQuery+ , SqlExpr+ , SqlEntity+ , select+ , selectOne+ , selectSource+ , delete+ , deleteCount+ , update+ , updateCount+ , insertSelect+ , insertSelectCount+ , (<#)+ , (<&>)+ -- ** Rendering Queries+ , renderQueryToText+ , renderQuerySelect+ , renderQueryUpdate+ , renderQueryDelete+ , renderQueryInsertInto+ -- * Internal.Language+ , From+ -- * RDBMS-specific modules+ -- $rdbmsSpecificModules++ -- * Helpers+ , valkey+ , valJ+ , associateJoin++ -- * Re-exports+ -- $reexports+ , deleteKey+ , module Database.Esqueleto.Internal.PersistentImport+ ) where++import Database.Esqueleto.Internal.Internal+import Database.Esqueleto.Internal.PersistentImport+++-- $setup+--+-- If you're already using @persistent@, then you're ready to use+-- @esqueleto@, no further setup is needed. If you're just+-- starting a new project and would like to use @esqueleto@, take+-- a look at @persistent@'s book first+-- (<http://www.yesodweb.com/book/persistent>) to learn how to+-- define your schema.+++----------------------------------------------------------------------+++-- $introduction+--+-- The main goals of @esqueleto@ are to:+--+-- * Be easily translatable to SQL. When you take a look at a+-- @esqueleto@ query, you should be able to know exactly how+-- the SQL query will end up. (As opposed to being a+-- relational algebra EDSL such as HaskellDB, which is+-- non-trivial to translate into SQL.)+--+-- * Support the most widely used SQL features. We'd like you to be+-- able to use @esqueleto@ for all of your queries, no+-- exceptions. Send a pull request or open an issue on our+-- project page (<https://github.com/prowdsponsor/esqueleto>) if+-- there's anything missing that you'd like to see.+--+-- * Be as type-safe as possible. We strive to provide as many+-- type checks as possible. If you get bitten by some invalid+-- code that type-checks, please open an issue on our project+-- page so we can take a look.+--+-- However, it is /not/ a goal to be able to write portable SQL.+-- We do not try to hide the differences between DBMSs from you,+-- and @esqueleto@ code that works for one database may not work+-- on another. This is a compromise we have to make in order to+-- give you as much control over the raw SQL as possible without+-- losing too much convenience. This also means that you may+-- type-check a query that doesn't work on your DBMS.+++----------------------------------------------------------------------+++-- $gettingstarted+--+-- We like clean, easy-to-read EDSLs. However, in order to+-- achieve this goal we've used a lot of type hackery, leading to+-- some hard-to-read type signatures. On this section, we'll try+-- to build some intuition about the syntax.+--+-- For the following examples, we'll use this example schema:+--+-- @+-- share [mkPersist sqlSettings, mkMigrate \"migrateAll\"] [persist|+-- Person+-- name String+-- age Int Maybe+-- deriving Eq Show+-- BlogPost+-- title String+-- authorId PersonId+-- deriving Eq Show+-- Follow+-- follower PersonId+-- followed PersonId+-- deriving Eq Show+-- |]+-- @+--+-- Most of @esqueleto@ was created with @SELECT@ statements in+-- mind, not only because they're the most common but also+-- because they're the most complex kind of statement. The most+-- simple kind of @SELECT@ would be:+--+-- @+-- SELECT *+-- FROM Person+-- @+--+-- In @esqueleto@, we may write the same query above as:+--+-- @+-- do people <- 'select' $+-- 'from' $ \\person -> do+-- return person+-- liftIO $ mapM_ (putStrLn . personName . entityVal) people+-- @+--+-- The expression above has type @SqlPersist m ()@, while+-- @people@ has type @[Entity Person]@. The query above will be+-- translated into exactly the same query we wrote manually, but+-- instead of @SELECT *@ it will list all entity fields (using+-- @*@ is not robust). Note that @esqueleto@ knows that we want+-- an @Entity Person@ just because of the @personName@ that we're+-- printing later.+--+-- However, most of the time we need to filter our queries using+-- @WHERE@. For example:+--+-- @+-- SELECT *+-- FROM Person+-- WHERE Person.name = \"John\"+-- @+--+-- In @esqueleto@, we may write the same query above as:+--+-- @+-- 'select' $+-- 'from' $ \\p -> do+-- 'where_' (p '^.' PersonName '==.' 'val' \"John\")+-- return p+-- @+--+-- Although @esqueleto@'s code is a bit more noisy, it's has+-- almost the same structure (save from the @return@). The+-- @('^.')@ operator is used to project a field from an entity.+-- The field name is the same one generated by @persistent@'s+-- Template Haskell functions. We use 'val' to lift a constant+-- Haskell value into the SQL query.+--+-- Another example would be:+--+-- @+-- SELECT *+-- FROM Person+-- WHERE Person.age >= 18+-- @+--+-- In @esqueleto@, we may write the same query above as:+--+-- @+-- 'select' $+-- 'from' $ \\p -> do+-- 'where_' (p '^.' PersonAge '>=.' 'just' ('val' 18))+-- return p+-- @+--+-- Since @age@ is an optional @Person@ field, we use 'just' to lift+-- @'val' 18 :: SqlExpr (Value Int)@ into @just ('val' 18) ::+-- SqlExpr (Value (Maybe Int))@.+--+-- Implicit joins are represented by tuples. For example, to get+-- the list of all blog posts and their authors, we could write:+--+-- @+-- SELECT BlogPost.*, Person.*+-- FROM BlogPost, Person+-- WHERE BlogPost.authorId = Person.id+-- ORDER BY BlogPost.title ASC+-- @+--+-- In @esqueleto@, we may write the same query above as:+--+-- @+-- 'select' $+-- 'from' $ \\(b, p) -> do+-- 'where_' (b '^.' BlogPostAuthorId '==.' p '^.' PersonId)+-- 'orderBy' ['asc' (b '^.' BlogPostTitle)]+-- return (b, p)+-- @+--+-- However, you may want your results to include people who don't+-- have any blog posts as well using a @LEFT OUTER JOIN@:+--+-- @+-- SELECT Person.*, BlogPost.*+-- FROM Person LEFT OUTER JOIN BlogPost+-- ON Person.id = BlogPost.authorId+-- ORDER BY Person.name ASC, BlogPost.title ASC+-- @+--+-- In @esqueleto@, we may write the same query above as:+--+-- @+-- 'select' $+-- 'from' $ \\(p `'LeftOuterJoin`` mb) -> do+-- 'on' ('just' (p '^.' PersonId) '==.' mb '?.' BlogPostAuthorId)+-- 'orderBy' ['asc' (p '^.' PersonName), 'asc' (mb '?.' BlogPostTitle)]+-- return (p, mb)+-- @+--+-- On a @LEFT OUTER JOIN@ the entity on the right hand side may+-- not exist (i.e. there may be a @Person@ without any+-- @BlogPost@s), so while @p :: SqlExpr (Entity Person)@, we have+-- @mb :: SqlExpr (Maybe (Entity BlogPost))@. The whole+-- expression above has type @SqlPersist m [(Entity Person, Maybe+-- (Entity BlogPost))]@. Instead of using @(^.)@, we used+-- @('?.')@ to project a field from a @Maybe (Entity a)@.+--+-- We are by no means limited to joins of two tables, nor by+-- joins of different tables. For example, we may want a list+-- of the @Follow@ entity:+--+-- @+-- SELECT P1.*, Follow.*, P2.*+-- FROM Person AS P1+-- INNER JOIN Follow ON P1.id = Follow.follower+-- INNER JOIN Person AS P2 ON P2.id = Follow.followed+-- @+--+-- In @esqueleto@, we may write the same query above as:+--+-- @+-- 'select' $+-- 'from' $ \\(p1 `'InnerJoin`` f `'InnerJoin`` p2) -> do+-- 'on' (p1 '^.' PersonId '==.' f '^.' FollowFollower)+-- 'on' (p2 '^.' PersonId '==.' f '^.' FollowFollowed)+-- return (p1, f, p2)+-- @+--+-- We also currently support @UPDATE@ and @DELETE@ statements.+-- For example:+--+-- @+-- do 'update' $ \\p -> do+-- 'set' p [ PersonName '=.' 'val' \"João\" ]+-- 'where_' (p '^.' PersonName '==.' 'val' \"Joao\")+-- 'delete' $+-- 'from' $ \\p -> do+-- 'where_' (p '^.' PersonAge '<.' 'just' ('val' 14))+-- @+--+-- The results of queries can also be used for insertions.+-- In @SQL@, we might write the following, inserting a new blog+-- post for every user:+--+-- @+-- INSERT INTO BlogPost+-- SELECT ('Group Blog Post', id)+-- FROM Person+-- @+--+-- In @esqueleto@, we may write the same query above as:+--+-- @+-- 'insertSelect' $ 'from' $ \\p->+-- return $ BlogPost '<#' \"Group Blog Post\" '<&>' (p '^.' PersonId)+-- @+--+-- Individual insertions can be performed through Persistent's+-- 'insert' function, reexported for convenience.+++----------------------------------------------------------------------+++-- $reexports+--+-- We re-export many symbols from @persistent@ for convenince:+--+-- * \"Store functions\" from "Database.Persist".+--+-- * Everything from "Database.Persist.Class" except for+-- @PersistQuery@ and @delete@ (use 'deleteKey' instead).+--+-- * Everything from "Database.Persist.Types" except for+-- @Update@, @SelectOpt@, @BackendSpecificFilter@ and @Filter@.+--+-- * Everything from "Database.Persist.Sql" except for+-- @deleteWhereCount@ and @updateWhereCount@.+++----------------------------------------------------------------------+++-- $rdbmsSpecificModules+--+-- There are many differences between SQL syntax and functions+-- supported by different RDBMSs. Since version 2.2.8,+-- @esqueleto@ includes modules containing functions that are+-- specific to a given RDBMS.+--+-- * PostgreSQL: "Database.Esqueleto.PostgreSQL".+--+-- In order to use these functions, you need to explicitly import+-- their corresponding modules, they're not re-exported here.
src/Database/Esqueleto/MySQL.hs view
@@ -1,18 +1,31 @@ {-# LANGUAGE OverloadedStrings #-}+ -- | This module contain MySQL-specific functions. ----- /Since: 2.2.8/+-- @since 2.2.8 module Database.Esqueleto.MySQL- ( random_- ) where+ ( random_+ , lockInShareMode+ ) where -import Database.Esqueleto.Internal.Language hiding (random_)+import Database.Esqueleto.Internal.Internal hiding (random_) import Database.Esqueleto.Internal.PersistentImport-import Database.Esqueleto.Internal.Sql -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. ----- /Since: 2.6.0/+-- @since 2.6.0 random_ :: (PersistField a, Num a) => SqlExpr (Value a) random_ = unsafeSqlValue "RAND()"++-- | @LOCK IN SHARE MODE@ syntax.+--+-- Example:+--+-- @+-- 'locking' 'lockInShareMode'+-- @+--+-- @since 3.6.0.0+lockInShareMode :: LockingKind+lockInShareMode = LockInShareMode
src/Database/Esqueleto/PostgreSQL.hs view
@@ -1,62 +1,157 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings- , GADTs, CPP, Rank2Types- , ScopedTypeVariables- #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+ -- | This module contain PostgreSQL-specific functions. ----- /Since: 2.2.8/+-- @since 2.2.8 module Database.Esqueleto.PostgreSQL- ( AggMode(..)- , arrayAggDistinct- , arrayAgg- , arrayAggWith- , arrayRemove- , arrayRemoveNull- , stringAgg- , stringAggWith- , maybeArray- , chr- , now_- , random_- , upsert- , upsertBy- , insertSelectWithConflict- , insertSelectWithConflictCount- , filterWhere- -- * Internal- , unsafeSqlAggregateFunction- ) where+ ( AggMode(..)+ , arrayAggDistinct+ , arrayAgg+ , arrayAggWith+ , arrayRemove+ , arrayRemoveNull+ , stringAgg+ , stringAggWith+ , maybeArray+ , chr+ , now_+ , random_+ , upsert+ , upsertMaybe+ , upsertBy+ , upsertMaybeBy+ , insertSelectWithConflict+ , insertSelectWithConflictCount+ , noWait+ , wait+ , skipLocked+ , forUpdateOf+ , forNoKeyUpdateOf+ , forShare+ , forShareOf+ , forKeyShareOf+ , filterWhere+ , values+ , ilike+ , distinctOn+ , distinctOnOrderBy+ , withMaterialized+ , withNotMaterialized+ , ascNullsFirst+ , ascNullsLast+ , descNullsFirst+ , descNullsLast+ -- * Internal+ , unsafeSqlAggregateFunction+ ) where -#if __GLASGOW_HASKELL__ < 804-import Data.Semigroup-#endif-import qualified Data.Text.Internal.Builder as TLB-import Data.Time.Clock (UTCTime)-import Database.Esqueleto.Internal.Language hiding (random_)-import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy)-import Database.Esqueleto.Internal.Sql-import Database.Esqueleto.Internal.Internal (EsqueletoError(..), CompositeKeyError(..),- UnexpectedCaseError(..), SetClause, Ident(..),- uncommas, FinalResult(..), toUniqueDef,- KnowResult, renderUpdates, UnexpectedValueError(..))-import Database.Persist.Class (OnlyOneUniqueKey)-import Data.List.NonEmpty ( NonEmpty( (:|) ) )-import Data.Int (Int64)-import Data.Proxy (Proxy(..))-import Control.Arrow ((***), first)-import Control.Exception (throw)-import Control.Monad (void)-import Control.Monad.IO.Class (MonadIO (..))-import qualified Control.Monad.Trans.Reader as R+import Control.Arrow (first)+import Control.Exception (throw)+import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO(..))+import qualified Control.Monad.Trans.Reader as R+import qualified Control.Monad.Trans.Writer as W+import Data.Int (Int64)+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Proxy (Proxy(..))+import qualified Data.Text as Text+import qualified Data.Text.Internal.Builder as TLB+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import Data.Time.Clock (UTCTime)+import qualified Database.Esqueleto.Experimental as Ex+import qualified Database.Esqueleto.Experimental.From as Ex+import Database.Esqueleto.Experimental.From.CommonTableExpression+import Database.Esqueleto.Experimental.From.SqlSetOperation+import Database.Esqueleto.Experimental.ToAlias+import Database.Esqueleto.Experimental.ToAliasReference+import Database.Esqueleto.Internal.Internal hiding+ (From(..), ilike, distinctOn, distinctOnOrderBy, from, on, random_)+import Database.Esqueleto.Internal.PersistentImport hiding+ (uniqueFields, upsert, upsertBy)+import Database.Persist (ConstraintNameDB(..), EntityNameDB(..))+import Database.Persist.Class (OnlyOneUniqueKey)+import Database.Persist.SqlBackend+import GHC.Stack -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. ----- /Since: 2.6.0/+-- @since 2.6.0 random_ :: (PersistField a, Num a) => SqlExpr (Value a) random_ = unsafeSqlValue "RANDOM()" +-- | @DISTINCT ON@. Change the current @SELECT@ into+-- @SELECT DISTINCT ON (SqlExpressions)@. For example:+--+-- @+-- select $ do+-- foo <- 'from' $ table \@Foo+-- 'distinctOn' ['don' (foo ^. FooName), 'don' (foo ^. FooState)]+-- pure foo+-- @+--+-- You can also chain different calls to 'distinctOn'. The+-- above is equivalent to:+--+-- @+-- select $ do+-- foo <- 'from' $ table \@Foo+-- 'distinctOn' ['don' (foo ^. FooName)]+-- 'distinctOn' ['don' (foo ^. FooState)]+-- pure foo+-- @+--+-- Each call to 'distinctOn' adds more SqlExpressions. Calls to+-- 'distinctOn' override any calls to 'distinct'.+--+-- Note that PostgreSQL requires the SqlExpressions on @DISTINCT+-- ON@ to be the first ones to appear on a @ORDER BY@. This is+-- not managed automatically by esqueleto, keeping its spirit+-- of trying to be close to raw SQL.+--+-- @since 3.6.0+distinctOn :: [SqlExpr DistinctOn] -> SqlQuery ()+distinctOn exprs = Q (W.tell mempty { sdDistinctClause = DistinctOn exprs })++-- | A convenience function that calls both 'distinctOn' and+-- 'orderBy'. In other words,+--+-- @+-- 'distinctOnOrderBy' [asc foo, desc bar, desc quux]+-- @+--+-- is the same as:+--+-- @+-- 'distinctOn' [don foo, don bar, don quux]+-- 'orderBy' [asc foo, desc bar, desc quux]+-- ...+-- @+--+-- @since 3.6.0.0+distinctOnOrderBy :: [SqlExpr OrderBy] -> SqlQuery ()+distinctOnOrderBy exprs = do+ distinctOn (toDistinctOn <$> exprs)+ orderBy exprs+ where+ toDistinctOn :: SqlExpr OrderBy -> SqlExpr DistinctOn+ toDistinctOn (ERaw m f) = ERaw m $ \p info ->+ let (b, vals) = f p info+ in ( TLB.fromLazyText+ $ TL.replace " DESC" ""+ $ TL.replace " ASC" ""+ $ TLB.toLazyText b+ , vals )+ -- | Empty array literal. (@val []@) does unfortunately not work emptyArray :: SqlExpr (Value [a]) emptyArray = unsafeSqlValue "'{}'"@@ -69,45 +164,48 @@ maybeArray x = coalesceDefault [x] (emptyArray) -- | Aggregate mode-data AggMode = AggModeAll -- ^ ALL- | AggModeDistinct -- ^ DISTINCT- deriving (Show)+data AggMode+ = AggModeAll -- ^ ALL+ | AggModeDistinct -- ^ DISTINCT+ deriving (Show) -- | (Internal) Create a custom aggregate functions with aggregate mode -- -- /Do/ /not/ use this function directly, instead define a new function and give -- it a type (see `unsafeSqlBinOp`)-unsafeSqlAggregateFunction ::- UnsafeSqlFunctionArgument a- => TLB.Builder- -> AggMode- -> a- -> [OrderByClause]- -> SqlExpr (Value b)-unsafeSqlAggregateFunction name mode args orderByClauses =- ERaw Never $ \info ->+unsafeSqlAggregateFunction+ :: UnsafeSqlFunctionArgument a+ => TLB.Builder+ -> AggMode+ -> a+ -> [OrderByClause]+ -> SqlExpr (Value b)+unsafeSqlAggregateFunction name mode args orderByClauses = ERaw noMeta $ \_ info -> let (orderTLB, orderVals) = makeOrderByNoNewline info orderByClauses -- Don't add a space if we don't have order by clauses- orderTLBSpace = case orderByClauses of- [] -> ""- (_:_) -> " "+ orderTLBSpace =+ case orderByClauses of+ [] -> ""+ (_:_) -> " " (argsTLB, argsVals) =- uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList args- aggMode = case mode of- AggModeAll -> "" -- ALL is the default, so we don't need to- -- specify it- AggModeDistinct -> "DISTINCT "+ uncommas' $ map (\(ERaw _ f) -> f Never info) $ toArgList args+ aggMode =+ case mode of+ AggModeAll -> ""+ -- ALL is the default, so we don't need to+ -- specify it+ AggModeDistinct -> "DISTINCT " in ( name <> parens (aggMode <> argsTLB <> orderTLBSpace <> orderTLB) , argsVals <> orderVals ) --- | (@array_agg@) Concatenate input values, including @NULL@s, --- into an array.-arrayAggWith ::- AggMode- -> SqlExpr (Value a)- -> [OrderByClause]- -> SqlExpr (Value (Maybe [a]))+arrayAggWith+ :: AggMode+ -> SqlExpr (Value a)+ -> [OrderByClause]+ -> SqlExpr (Value (Maybe [a])) arrayAggWith = unsafeSqlAggregateFunction "array_agg" --- | (@array_agg@) Concatenate input values, including @NULL@s,@@ -118,18 +216,17 @@ -- | (@array_agg@) Concatenate distinct input values, including @NULL@s, into -- an array. ----- /Since: 2.5.3/-arrayAggDistinct ::- (PersistField a, PersistField [a])- => SqlExpr (Value a)- -> SqlExpr (Value (Maybe [a]))+-- @since 2.5.3+arrayAggDistinct+ :: (PersistField a, PersistField [a])+ => SqlExpr (Value a)+ -> SqlExpr (Value (Maybe [a])) arrayAggDistinct x = arrayAggWith AggModeDistinct x [] - -- | (@array_remove@) Remove all elements equal to the given value from the -- array. ----- /Since: 2.5.3/+-- @since 2.5.3 arrayRemove :: SqlExpr (Value [a]) -> SqlExpr (Value a) -> SqlExpr (Value [a]) arrayRemove arr elem' = unsafeSqlFunction "array_remove" (arr, elem') @@ -154,7 +251,7 @@ -- | (@string_agg@) Concatenate input values separated by a -- delimiter. ----- /Since: 2.2.8/+-- @since 2.2.8 stringAgg :: SqlString s => SqlExpr (Value s) -- ^ Input values.@@ -165,63 +262,168 @@ -- | (@chr@) Translate the given integer to a character. (Note the result will -- depend on the character set of your database.) ----- /Since: 2.2.11/+-- @since 2.2.11 chr :: SqlString s => SqlExpr (Value Int) -> SqlExpr (Value s) chr = unsafeSqlFunction "chr" now_ :: SqlExpr (Value UTCTime) now_ = unsafeSqlFunction "NOW" () -upsert :: (MonadIO m,- PersistEntity record,- OnlyOneUniqueKey record,- PersistRecordBackend record SqlBackend,- IsPersistBackend (PersistEntityBackend record))+-- | Perform an @upsert@ operation on the given record.+--+-- If the record exists in the database already, then the updates will be+-- performed on that record. If the record does not exist, then the+-- provided record will be inserted.+--+-- If you wish to provide an empty list of updates (ie "if the record+-- exists, do nothing"), then you will need to call 'upsertMaybe'. Postgres+-- will not return anything if there are no modifications or inserts made.+upsert+ ::+ ( MonadIO m+ , PersistEntity record+ , OnlyOneUniqueKey record+ , PersistRecordBackend record SqlBackend+ , IsPersistBackend (PersistEntityBackend record)+ ) => record -- ^ new record to insert- -> [SqlExpr (Update record)]+ -> NE.NonEmpty (SqlExpr (Entity record) -> SqlExpr Update) -- ^ updates to perform if the record already exists -> R.ReaderT SqlBackend m (Entity record) -- ^ the record in the database after the operation-upsert record updates = do- uniqueKey <- onlyUnique record- upsertBy uniqueKey record updates+upsert record =+ upsertBy (onlyUniqueP record) record -upsertBy :: (MonadIO m,- PersistEntity record,- IsPersistBackend (PersistEntityBackend record))- => Unique record- -- ^ uniqueness constraint to find by- -> record- -- ^ new record to insert- -> [SqlExpr (Update record)]- -- ^ updates to perform if the record already exists- -> R.ReaderT SqlBackend m (Entity record)- -- ^ the record in the database after the operation-upsertBy uniqueKey record updates = do- sqlB <- R.ask- maybe- (throw (UnexpectedCaseErr OperationNotSupported)) -- Postgres backend should have connUpsertSql, if this error is thrown, check changes on persistent- (handler sqlB)- (connUpsertSql sqlB)+-- | Like 'upsert', but permits an empty list of updates to be performed.+--+-- If no updates are provided and the record already was present in the+-- database, then this will return 'Nothing'. If you want to fetch the+-- record out of the database, you can write:+--+-- @+-- mresult <- upsertMaybe record []+-- case mresult of+-- Nothing ->+-- 'getBy' ('onlyUniqueP' record)+-- Just res ->+-- pure (Just res)+-- @+--+-- @since 3.6.0.0+upsertMaybe+ ::+ ( MonadIO m+ , PersistEntity record+ , OnlyOneUniqueKey record+ , PersistRecordBackend record SqlBackend+ , IsPersistBackend (PersistEntityBackend record)+ )+ => record+ -- ^ new record to insert+ -> [SqlExpr (Entity record) -> SqlExpr Update]+ -- ^ updates to perform if the record already exists+ -> R.ReaderT SqlBackend m (Maybe (Entity record))+ -- ^ the record in the database after the operation+upsertMaybe rec upds = do+ upsertMaybeBy (onlyUniqueP rec) rec upds++-- | Attempt to insert a @record@ into the database. If the @record@+-- already exists for the given @'Unique' record@, then a list of updates+-- will be performed.+--+-- If you provide an empty list of updates, then this function will return+-- 'Nothing' if the record already exists in the database.+--+-- @since 3.6.0.0+upsertMaybeBy+ ::+ ( MonadIO m+ , PersistEntity record+ , IsPersistBackend (PersistEntityBackend record)+ )+ => Unique record+ -- ^ uniqueness constraint to find by+ -> record+ -- ^ new record to insert+ -> [SqlExpr (Entity record) -> SqlExpr Update]+ -- ^ updates to perform if the record already exists+ -> R.ReaderT SqlBackend m (Maybe (Entity record))+ -- ^ the record in the database after the operation+upsertMaybeBy uniqueKey record updates = do+ sqlB <- R.ask+ case getConnUpsertSql sqlB of+ Nothing ->+ -- Postgres backend should have connUpsertSql, if this error is+ -- thrown, check changes on persistent+ throw (UnexpectedCaseErr OperationNotSupported)+ Just upsertSql ->+ handler sqlB upsertSql where- addVals l = map toPersistValue (toPersistFields record) ++ l ++ persistUniqueToValues uniqueKey- entDef = entityDef (Just record)- uDef = toUniqueDef uniqueKey- updatesText conn = first builderToText $ renderUpdates conn updates- handler conn f = fmap head $ uncurry rawSql $- (***) (f entDef (uDef :| [])) addVals $ updatesText conn+ addVals l =+ map toPersistValue (toPersistFields record) ++ l ++ case updates of+ [] ->+ []+ _ ->+ persistUniqueToValues uniqueKey+ entDef =+ entityDef (Just record)+ updatesText conn =+ first builderToText $ renderUpdates conn updates+ uniqueFields = persistUniqueToFieldNames uniqueKey+ handler sqlB upsertSql = do+ let (updateText, updateVals) =+ updatesText sqlB+ queryTextUnmodified =+ upsertSql entDef uniqueFields updateText+ queryText =+ case updates of+ [] ->+ let+ (okay, _bad) =+ Text.breakOn "DO UPDATE" queryTextUnmodified+ good =+ okay <> "DO NOTHING RETURNING ??"+ in+ good+ _ ->+ queryTextUnmodified + queryVals =+ addVals updateVals+ xs <- rawSql queryText queryVals+ pure (listToMaybe xs)++upsertBy+ ::+ ( MonadIO m+ , PersistEntity record+ , IsPersistBackend (PersistEntityBackend record)+ , HasCallStack+ )+ => Unique record+ -- ^ uniqueness constraint to find by+ -> record+ -- ^ new record to insert+ -> NE.NonEmpty (SqlExpr (Entity record) -> SqlExpr Update)+ -- ^ updates to perform if the record already exists+ -> R.ReaderT SqlBackend m (Entity record)+ -- ^ the record in the database after the operation+upsertBy uniqueKey record updates = do+ mrec <- upsertMaybeBy uniqueKey record (NE.toList updates)+ case mrec of+ Nothing ->+ error "non-empty list of updates should have resulted in a row being returned"+ Just rec ->+ pure rec+ -- | Inserts into a table the results of a query similar to 'insertSelect' but allows -- to update values that violate a constraint during insertions. -- -- Example of usage: -- -- @--- share [ mkPersist sqlSettings--- , mkDeleteCascade sqlSettings--- , mkMigrate "migrate"--- ] [persistLowerCase|+-- 'mkPersist' 'sqlSettings' ['persistLowerCase'| -- Bar -- num Int -- deriving Eq Show@@ -231,74 +433,78 @@ -- deriving Eq Show -- |] ----- insertSelectWithConflict--- UniqueFoo -- (UniqueFoo undefined) or (UniqueFoo anyNumber) would also work--- (from $ \b ->--- return $ Foo <# (b ^. BarNum)--- )--- (\current excluded ->--- [FooNum =. (current ^. FooNum) +. (excluded ^. FooNum)]--- )+-- action = do+-- 'insertSelectWithConflict'+-- UniqueFoo -- (UniqueFoo undefined) or (UniqueFoo anyNumber) would also work+-- (do+-- b <- from $ table \@Bar+-- return $ Foo <# (b ^. BarNum)+-- )+-- (\\current excluded ->+-- [FooNum =. (current ^. FooNum) +. (excluded ^. FooNum)]+-- ) -- @ ----- Inserts to table Foo all Bar.num values and in case of conflict SomeFooUnique,+-- Inserts to table @Foo@ all @Bar.num@ values and in case of conflict @SomeFooUnique@, -- the conflicting value is updated to the current plus the excluded. -- -- @since 3.1.3-insertSelectWithConflict :: forall a m val. (- FinalResult a,- KnowResult a ~ (Unique val),- MonadIO m,- PersistEntity val) =>- a- -- ^ Unique constructor or a unique, this is used just to get the name of the postgres constraint, the value(s) is(are) never used, so if you have a unique "MyUnique 0", "MyUnique undefined" would work as well.- -> SqlQuery (SqlExpr (Insertion val))- -- ^ Insert query.- -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)])- -- ^ A list of updates to be applied in case of the constraint being violated. The expression takes the current and excluded value to produce the updates.- -> SqlWriteT m ()-insertSelectWithConflict unique query = void . insertSelectWithConflictCount unique query+insertSelectWithConflict+ :: forall a m val backend+ . (FinalResult a, KnowResult a ~ Unique val, MonadIO m, PersistEntity val, SqlBackendCanWrite backend)+ => a+ -- ^ Unique constructor or a unique, this is used just to get the name of+ -- the postgres constraint, the value(s) is(are) never used, so if you have+ -- a unique "MyUnique 0", "MyUnique undefined" would work as well.+ -> SqlQuery (SqlExpr (Insertion val))+ -- ^ Insert query.+ -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update])+ -- ^ A list of updates to be applied in case of the constraint being+ -- violated. The expression takes the current and excluded value to produce+ -- the updates.+ -> R.ReaderT backend m ()+insertSelectWithConflict unique query a =+ void $ insertSelectWithConflictCount unique query a -- | Same as 'insertSelectWithConflict' but returns the number of rows affected. -- -- @since 3.1.3-insertSelectWithConflictCount :: forall a val m. (- FinalResult a,- KnowResult a ~ (Unique val),- MonadIO m,- PersistEntity val) =>- a- -> SqlQuery (SqlExpr (Insertion val))- -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)])- -> SqlWriteT m Int64+insertSelectWithConflictCount+ :: forall a val m backend+ . (FinalResult a, KnowResult a ~ Unique val, MonadIO m, PersistEntity val,+ SqlBackendCanWrite backend)+ => a+ -> SqlQuery (SqlExpr (Insertion val))+ -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update])+ -> R.ReaderT backend m Int64 insertSelectWithConflictCount unique query conflictQuery = do- conn <- R.ask- uncurry rawExecuteCount $- combine- (toRawSql INSERT_INTO (conn, initialIdentState) (fmap EInsertFinal query))- (conflict conn)+ conn <- R.ask+ uncurry rawExecuteCount $+ combine+ (toRawSql INSERT_INTO (conn, initialIdentState) query)+ (conflict conn) where proxy :: Proxy val proxy = Proxy updates = conflictQuery entCurrent entExcluded combine (tlb1,vals1) (tlb2,vals2) = (builderToText (tlb1 `mappend` tlb2), vals1 ++ vals2)- entExcluded = EEntity $ I "excluded"- tableName = unDBName . entityDB . entityDef- entCurrent = EEntity $ I (tableName proxy)+ entExcluded = unsafeSqlEntity (I "excluded")+ tableName = unEntityNameDB . getEntityDBName . entityDef+ entCurrent = unsafeSqlEntity (I (tableName proxy)) uniqueDef = toUniqueDef unique- constraint = TLB.fromText . unDBName . uniqueDBName $ uniqueDef+ constraint = TLB.fromText . unConstraintNameDB . uniqueDBName $ uniqueDef renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue]) renderedUpdates conn = renderUpdates conn updates- conflict conn = (foldr1 mappend ([+ conflict conn = (mconcat ([ TLB.fromText "ON CONFLICT ON CONSTRAINT \"", constraint, TLB.fromText "\" DO " ] ++ if null updates then [TLB.fromText "NOTHING"] else [ TLB.fromText "UPDATE SET ", updatesTLB- ]),values)+ ]),values') where- (updatesTLB,values) = renderedUpdates conn+ (updatesTLB,values') = renderedUpdates conn -- | Allow aggregate functions to take a filter clause. --@@ -327,18 +533,254 @@ -- -- @since 3.3.3.3 filterWhere- :: SqlExpr (Value a)- -- ^ Aggregate function- -> SqlExpr (Value Bool)- -- ^ Filter clause- -> SqlExpr (Value a)-filterWhere aggExpr clauseExpr = ERaw Never $ \info ->- let (aggBuilder, aggValues) = case aggExpr of- ERaw _ aggF -> aggF info- ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereAggError- (clauseBuilder, clauseValues) = case clauseExpr of- ERaw _ clauseF -> clauseF info- ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereClauseError- in ( aggBuilder <> " FILTER (WHERE " <> clauseBuilder <> ")"- , aggValues <> clauseValues- )+ :: SqlExpr (Value a)+ -- ^ Aggregate function+ -> SqlExpr (Value Bool)+ -- ^ Filter clause+ -> SqlExpr (Value a)+filterWhere aggExpr clauseExpr = ERaw noMeta $ \_ info ->+ let (aggBuilder, aggValues) = case aggExpr of+ ERaw _ aggF -> aggF Never info+ (clauseBuilder, clauseValues) = case clauseExpr of+ ERaw _ clauseF -> clauseF Never info+ in ( aggBuilder <> " FILTER (WHERE " <> clauseBuilder <> ")"+ , aggValues <> clauseValues+ )+++-- | Allows to use `VALUES (..)` in-memory set of values+-- in RHS of `from` expressions. Useful for JOIN's on+-- known values which also can be additionally preprocessed+-- somehow on db side with usage of inner PostgreSQL capabilities.+--+--+-- Example of usage:+--+-- @+-- share [mkPersist sqlSettings] [persistLowerCase|+-- User+-- name Text+-- age Int+-- deriving Eq Show+--+-- select $ do+-- bound :& user <- from $+-- values ( (val (10 :: Int), val ("ten" :: Text))+-- :| [ (val 20, val "twenty")+-- , (val 30, val "thirty") ]+-- )+-- `InnerJoin` table User+-- `on` (\((bound, _boundName) :& user) -> user^.UserAge >=. bound)+-- groupBy bound+-- pure (bound, count @Int $ user^.UserName)+-- @+--+-- @since 3.5.2.3+values :: (ToSomeValues a, Ex.ToAliasReference a, Ex.ToAlias a) => NE.NonEmpty a -> Ex.From a+values exprs = Ex.From $ do+ ident <- newIdentFor $ DBName "vq"+ alias <- Ex.toAlias $ NE.head exprs+ ref <- Ex.toAliasReference ident alias+ let aliasIdents = mapMaybe (\someVal -> case someVal of+ SomeValue (ERaw aliasMeta _) -> sqlExprMetaAlias aliasMeta+ ) $ toSomeValues ref+ pure (ref, const $ mkExpr ident aliasIdents)+ where+ someValueToSql :: IdentInfo -> SomeValue -> (TLB.Builder, [PersistValue])+ someValueToSql info (SomeValue expr) = materializeExpr info expr++ mkValuesRowSql :: IdentInfo -> [SomeValue] -> (TLB.Builder, [PersistValue])+ mkValuesRowSql info vs =+ let materialized = someValueToSql info <$> vs+ valsSql = TLB.toLazyText . fst <$> materialized+ params = concatMap snd materialized+ in (TLB.fromLazyText $ "(" <> TL.intercalate "," valsSql <> ")", params)++ -- (VALUES (v11, v12,..), (v21, v22,..)) as "vq"("v1", "v2",..)+ mkExpr :: Ident -> [Ident] -> IdentInfo -> (TLB.Builder, [PersistValue])+ mkExpr valsIdent colIdents info =+ let materialized = mkValuesRowSql info . toSomeValues <$> NE.toList exprs+ (valsSql, params) =+ ( TL.intercalate "," $ map (TLB.toLazyText . fst) materialized+ , concatMap snd materialized+ )+ colsAliases = TL.intercalate "," (map (TLB.toLazyText . useIdent info) colIdents)+ in+ ( "(VALUES " <> TLB.fromLazyText valsSql <> ") AS "+ <> useIdent info valsIdent+ <> "(" <> TLB.fromLazyText colsAliases <> ")"+ , params+ )++-- | `NOWAIT` syntax for postgres locking+-- error will be thrown if locked rows are attempted to be selected+--+-- @since 3.5.9.0+noWait :: OnLockedBehavior+noWait = NoWait++-- | `SKIP LOCKED` syntax for postgres locking+-- locked rows will be skipped+--+-- @since 3.5.9.0+skipLocked :: OnLockedBehavior+skipLocked = SkipLocked++-- | default behaviour of postgres locks. will attempt to wait for locks to expire+--+-- @since 3.5.9.0+wait :: OnLockedBehavior+wait = Wait++-- | `FOR UPDATE OF` syntax for postgres locking+-- allows locking of specific tables with an update lock in a view or join+--+-- @since 3.5.9.0+forUpdateOf :: LockableEntity a => a -> OnLockedBehavior -> SqlQuery ()+forUpdateOf lockableEntities onLockedBehavior =+ putLocking $ PostgresLockingClauses [PostgresLockingKind PostgresForUpdate (Just $ LockingOfClause lockableEntities) onLockedBehavior]++-- | `FOR NO KEY UPDATE OF` syntax for postgres locking+-- allows locking of specific tables with a no key update lock in a view or join+--+-- @since 3.5.13.0+forNoKeyUpdateOf :: LockableEntity a => a -> OnLockedBehavior -> SqlQuery ()+forNoKeyUpdateOf lockableEntities onLockedBehavior =+ putLocking $ PostgresLockingClauses [PostgresLockingKind PostgresForNoKeyUpdate (Just $ LockingOfClause lockableEntities) onLockedBehavior]++-- | `FOR SHARE OF` syntax for postgres locking+-- allows locking of specific tables with a share lock in a view or join+--+-- @since 3.5.9.0+forShareOf :: LockableEntity a => a -> OnLockedBehavior -> SqlQuery ()+forShareOf lockableEntities onLockedBehavior =+ putLocking $ PostgresLockingClauses [PostgresLockingKind PostgresForShare (Just $ LockingOfClause lockableEntities) onLockedBehavior]++-- | @FOR SHARE@ syntax for Postgres locking.+--+-- Example use:+--+-- @+-- 'locking' 'forShare'+-- @+--+-- @since 3.6.0.0+forShare :: LockingKind+forShare = ForShare++-- | `FOR KEY SHARE OF` syntax for postgres locking+-- allows locking of specific tables with a key share lock in a view or join+--+-- @since 3.5.13.0+forKeyShareOf :: LockableEntity a => a -> OnLockedBehavior -> SqlQuery ()+forKeyShareOf lockableEntities onLockedBehavior =+ putLocking $ PostgresLockingClauses [PostgresLockingKind PostgresForKeyShare (Just $ LockingOfClause lockableEntities) onLockedBehavior]++-- | @ILIKE@ operator (case-insensitive @LIKE@).+--+-- @since 2.2.3+ilike :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value Bool)+ilike = unsafeSqlBinOp " ILIKE "+infixr 2 `ilike`++-- | @WITH@ @MATERIALIZED@ clause is used to introduce a+-- [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression)+-- with the MATERIALIZED keyword. The MATERIALIZED keyword is only supported in PostgreSQL >= version 12.+-- In Esqueleto, CTEs should be used as a subquery memoization tactic. PostgreSQL treats a materialized CTE as an optimization fence.+-- A materialized CTE is always fully calculated, and is not "inlined" with other table joins.+-- Without the MATERIALIZED keyword, PostgreSQL >= 12 may "inline" the CTE as though it was any other join.+-- You should always verify that using a materialized CTE will in fact improve your performance+-- over a regular subquery.+--+-- @+-- select $ do+-- cte <- withMaterialized subQuery+-- cteResult <- from cte+-- where_ $ cteResult ...+-- pure cteResult+-- @+--+--+-- For more information on materialized CTEs, see the PostgreSQL manual documentation on+-- [Common Table Expression Materialization](https://www.postgresql.org/docs/14/queries-with.html#id-1.5.6.12.7).+--+-- @since 3.5.14.0+withMaterialized :: ( ToAlias a+ , ToAliasReference a+ , SqlSelect a r+ ) => SqlQuery a -> SqlQuery (Ex.From a)+withMaterialized query = do+ (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ query+ aliasedValue <- toAlias ret+ let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)+ ident <- newIdentFor (DBName "cte")+ let clause = CommonTableExpressionClause NormalCommonTableExpression (\_ _ -> "MATERIALIZED ") ident (\info -> toRawSql SELECT info aliasedQuery)+ Q $ W.tell mempty{sdCteClause = [clause]}+ ref <- toAliasReference ident aliasedValue+ pure $ Ex.From $ pure (ref, (\_ info -> (useIdent info ident, mempty)))++-- | @WITH@ @NOT@ @MATERIALIZED@ clause is used to introduce a+-- [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression)+-- with the NOT MATERIALIZED keywords. These are only supported in PostgreSQL >=+-- version 12. In Esqueleto, CTEs should be used as a subquery memoization+-- tactic. PostgreSQL treats a materialized CTE as an optimization fence. A+-- MATERIALIZED CTE is always fully calculated, and is not "inlined" with other+-- table joins. Sometimes, this is undesirable, so postgres provides the NOT+-- MATERIALIZED modifier to prevent this behavior, thus enabling it to possibly+-- decide to treat the CTE as any other join.+--+-- Given the above, it is unlikely that this function will be useful, as a+-- normal join should be used instead, but is provided for completeness.+--+-- @+-- select $ do+-- cte <- withNotMaterialized subQuery+-- cteResult <- from cte+-- where_ $ cteResult ...+-- pure cteResult+-- @+--+--+-- For more information on materialized CTEs, see the PostgreSQL manual documentation on+-- [Common Table Expression Materialization](https://www.postgresql.org/docs/14/queries-with.html#id-1.5.6.12.7).+--+-- @since 3.5.14.0+withNotMaterialized :: ( ToAlias a+ , ToAliasReference a+ , SqlSelect a r+ ) => SqlQuery a -> SqlQuery (Ex.From a)+withNotMaterialized query = do+ (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ query+ aliasedValue <- toAlias ret+ let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)+ ident <- newIdentFor (DBName "cte")+ let clause = CommonTableExpressionClause NormalCommonTableExpression (\_ _ -> "NOT MATERIALIZED ") ident (\info -> toRawSql SELECT info aliasedQuery)+ Q $ W.tell mempty{sdCteClause = [clause]}+ ref <- toAliasReference ident aliasedValue+ pure $ Ex.From $ pure (ref, (\_ info -> (useIdent info ident, mempty)))++-- | Ascending order of this field or SqlExpression with nulls coming first.+--+-- @since 3.5.14.0+ascNullsFirst :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy+ascNullsFirst = orderByExpr " ASC NULLS FIRST"++-- | Ascending order of this field or SqlExpression with nulls coming last.+-- Note that this is the same as normal ascending ordering in Postgres, but it has been included for completeness.+--+-- @since 3.5.14.0+ascNullsLast :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy+ascNullsLast = orderByExpr " ASC NULLS LAST"++-- | Descending order of this field or SqlExpression with nulls coming first.+-- Note that this is the same as normal ascending ordering in Postgres, but it has been included for completeness.+--+-- @since 3.5.14.0+descNullsFirst :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy+descNullsFirst = orderByExpr " DESC NULLS FIRST"++-- | Descending order of this field or SqlExpression with nulls coming last.+--+-- @since 3.5.14.0+descNullsLast :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy+descNullsLast = orderByExpr " DESC NULLS LAST"
src/Database/Esqueleto/PostgreSQL/JSON.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+ {-| This module contains PostgreSQL-specific JSON functions. @@ -22,129 +23,126 @@ @since 3.1.0 -} module Database.Esqueleto.PostgreSQL.JSON- ( -- * JSONB Newtype+ ( -- * JSONB Newtype+ --+ -- | With 'JSONB', you can use your Haskell types in your+ -- database table models as long as your type has 'FromJSON'+ -- and 'ToJSON' instances.+ --+ -- @+ -- import Database.Persist.TH+ --+ -- share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|+ -- Example+ -- json (JSONB MyType)+ -- |]+ -- @+ --+ -- CAUTION: Remember that changing the 'FromJSON' instance+ -- of your type might result in old data becoming unparsable!+ -- You can use (@JSONB Data.Aeson.Value@) for unstructured/variable JSON.+ JSONB(..)+ , JSONBExpr+ , jsonbVal+ -- * JSONAccessor+ , JSONAccessor(..)+ -- * Arrow operators --- -- | With 'JSONB', you can use your Haskell types in your- -- database table models as long as your type has 'FromJSON'- -- and 'ToJSON' instances.+ -- | /Better documentation included with individual functions/ --+ -- The arrow operators are selection functions to select values+ -- from JSON arrays or objects.+ --+ -- === PostgreSQL Documentation+ --+ -- /Requires PostgreSQL version >= 9.3/+ -- -- @- -- import Database.Persist.TH+ -- | Type | Description | Example | Example Result+ -- -----+--------+--------------------------------------------+--------------------------------------------------+----------------+ -- -> | int | Get JSON array element (indexed from zero, | '[{"a":"foo"},{"b":"bar"},{"c":"baz"}]'::json->2 | {"c":"baz"}+ -- | | negative integers count from the end) | |+ -- -> | text | Get JSON object field by key | '{"a": {"b":"foo"}}'::json->'a' | {"b":"foo"}+ -- ->> | int | Get JSON array element as text | '[1,2,3]'::json->>2 | 3+ -- ->> | text | Get JSON object field as text | '{"a":1,"b":2}'::json->>'b' | 2+ -- \#> | text[] | Get JSON object at specified path | '{"a": {"b":{"c": "foo"}}}'::json#>'{a,b}' | {"c": "foo"}+ -- \#>> | text[] | Get JSON object at specified path as text | '{"a":[1,2,3],"b":[4,5,6]}'::json#>>'{a,2}' | 3+ -- @+ , (->.)+ , (->>.)+ , (#>.)+ , (#>>.)+ -- * Filter operators --- -- share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|- -- Example- -- json (JSONB MyType)- -- |]+ -- | /Better documentation included with individual functions/+ --+ -- These functions test certain properties of JSON values+ -- and return booleans, so are mainly used in WHERE clauses.+ --+ -- === PostgreSQL Documentation+ --+ -- /Requires PostgreSQL version >= 9.4/+ -- -- @+ -- | Type | Description | Example+ -- ----+--------+-----------------------------------------------------------------+---------------------------------------------------+ -- \@> | jsonb | Does the left JSON value contain within it the right value? | '{"a":1, "b":2}'::jsonb \@> '{"b":2}'::jsonb+ -- <\@ | jsonb | Is the left JSON value contained within the right value? | '{"b":2}'::jsonb <\@ '{"a":1, "b":2}'::jsonb+ -- ? | text | Does the string exist as a top-level key within the JSON value? | '{"a":1, "b":2}'::jsonb ? 'b'+ -- ?| | text[] | Do any of these array strings exist as top-level keys? | '{"a":1, "b":2, "c":3}'::jsonb ?| array['b', 'c']+ -- ?& | text[] | Do all of these array strings exist as top-level keys? | '["a", "b"]'::jsonb ?& array['a', 'b']+ -- @+ , (@>.)+ , (<@.)+ , (?.)+ , (?|.)+ , (?&.)+ -- * Deletion and concatenation operators --- -- CAUTION: Remember that changing the 'FromJSON' instance- -- of your type might result in old data becoming unparsable!- -- You can use (@JSONB Data.Aeson.Value@) for unstructured/variable JSON.- JSONB(..)- , JSONBExpr- , jsonbVal- -- * JSONAccessor- , JSONAccessor(..)- -- * Arrow operators- --- -- | /Better documentation included with individual functions/- --- -- The arrow operators are selection functions to select values- -- from JSON arrays or objects.- --- -- === PostgreSQL Documentation- --- -- /Requires PostgreSQL version >= 9.3/- --- -- @- -- | Type | Description | Example | Example Result- -- -----+--------+--------------------------------------------+--------------------------------------------------+----------------- -- -> | int | Get JSON array element (indexed from zero, | '[{"a":"foo"},{"b":"bar"},{"c":"baz"}]'::json->2 | {"c":"baz"}- -- | | negative integers count from the end) | |- -- -> | text | Get JSON object field by key | '{"a": {"b":"foo"}}'::json->'a' | {"b":"foo"}- -- ->> | int | Get JSON array element as text | '[1,2,3]'::json->>2 | 3- -- ->> | text | Get JSON object field as text | '{"a":1,"b":2}'::json->>'b' | 2- -- \#> | text[] | Get JSON object at specified path | '{"a": {"b":{"c": "foo"}}}'::json#>'{a,b}' | {"c": "foo"}- -- \#>> | text[] | Get JSON object at specified path as text | '{"a":[1,2,3],"b":[4,5,6]}'::json#>>'{a,2}' | 3- -- @- , (->.)- , (->>.)- , (#>.)- , (#>>.)- -- * Filter operators- --- -- | /Better documentation included with individual functions/- --- -- These functions test certain properties of JSON values- -- and return booleans, so are mainly used in WHERE clauses.- --- -- === PostgreSQL Documentation- --- -- /Requires PostgreSQL version >= 9.4/- --- -- @- -- | Type | Description | Example- -- ----+--------+-----------------------------------------------------------------+---------------------------------------------------- -- \@> | jsonb | Does the left JSON value contain within it the right value? | '{"a":1, "b":2}'::jsonb \@> '{"b":2}'::jsonb- -- <\@ | jsonb | Is the left JSON value contained within the right value? | '{"b":2}'::jsonb <\@ '{"a":1, "b":2}'::jsonb- -- ? | text | Does the string exist as a top-level key within the JSON value? | '{"a":1, "b":2}'::jsonb ? 'b'- -- ?| | text[] | Do any of these array strings exist as top-level keys? | '{"a":1, "b":2, "c":3}'::jsonb ?| array['b', 'c']- -- ?& | text[] | Do all of these array strings exist as top-level keys? | '["a", "b"]'::jsonb ?& array['a', 'b']- -- @- , (@>.)- , (<@.)- , (?.)- , (?|.)- , (?&.)- -- * Deletion and concatenation operators- --- -- | /Better documentation included with individual functions/- --- -- These operators change the shape of the JSON value and- -- also have the highest risk of throwing an exception.- -- Please read the descriptions carefully before using these functions.- --- -- === PostgreSQL Documentation- --- -- /Requires PostgreSQL version >= 9.5/- --- -- @- -- | Type | Description | Example- -- ----+---------+------------------------------------------------------------------------+-------------------------------------------------- -- || | jsonb | Concatenate two jsonb values into a new jsonb value | '["a", "b"]'::jsonb || '["c", "d"]'::jsonb- -- - | text | Delete key/value pair or string element from left operand. | '{"a": "b"}'::jsonb - 'a'- -- | | Key/value pairs are matched based on their key value. |- -- - | integer | Delete the array element with specified index (Negative integers count | '["a", "b"]'::jsonb - 1- -- | | from the end). Throws an error if top level container is not an array. |- -- \#- | text[] | Delete the field or element with specified path | '["a", {"b":1}]'::jsonb \#- '{1,b}'- -- | | (for JSON arrays, negative integers count from the end) |- -- @- --- -- /Requires PostgreSQL version >= 10/- --- -- @- -- | Type | Description | Example- -- ----+---------+------------------------------------------------------------------------+-------------------------------------------------- -- - | text[] | Delete multiple key/value pairs or string elements from left operand. | '{"a": "b", "c": "d"}'::jsonb - '{a,c}'::text[]- -- | | Key/value pairs are matched based on their key value. |- -- @- , (-.)- , (--.)- , (#-.)- , (||.)- ) where+ -- | /Better documentation included with individual functions/+ --+ -- These operators change the shape of the JSON value and+ -- also have the highest risk of throwing an exception.+ -- Please read the descriptions carefully before using these functions.+ --+ -- === PostgreSQL Documentation+ --+ -- /Requires PostgreSQL version >= 9.5/+ --+ -- @+ -- | Type | Description | Example+ -- ----+---------+------------------------------------------------------------------------+-------------------------------------------------+ -- || | jsonb | Concatenate two jsonb values into a new jsonb value | '["a", "b"]'::jsonb || '["c", "d"]'::jsonb+ -- - | text | Delete key/value pair or string element from left operand. | '{"a": "b"}'::jsonb - 'a'+ -- | | Key/value pairs are matched based on their key value. |+ -- - | integer | Delete the array element with specified index (Negative integers count | '["a", "b"]'::jsonb - 1+ -- | | from the end). Throws an error if top level container is not an array. |+ -- \#- | text[] | Delete the field or element with specified path | '["a", {"b":1}]'::jsonb \#- '{1,b}'+ -- | | (for JSON arrays, negative integers count from the end) |+ -- @+ --+ -- /Requires PostgreSQL version >= 10/+ --+ -- @+ -- | Type | Description | Example+ -- ----+---------+------------------------------------------------------------------------+-------------------------------------------------+ -- - | text[] | Delete multiple key/value pairs or string elements from left operand. | '{"a": "b", "c": "d"}'::jsonb - '{a,c}'::text[]+ -- | | Key/value pairs are matched based on their key value. |+ -- @+ , (-.)+ , (--.)+ , (#-.)+ , (||.)+ ) where import Data.Text (Text)-import Database.Esqueleto.Internal.Language hiding ((?.), (-.), (||.))+import Database.Esqueleto.Internal.Internal hiding ((-.), (?.), (||.)) import Database.Esqueleto.Internal.PersistentImport-import Database.Esqueleto.Internal.Sql import Database.Esqueleto.PostgreSQL.JSON.Instances - infixl 6 ->., ->>., #>., #>>. infixl 6 @>., <@., ?., ?|., ?&. infixl 6 ||., -., --., #-.- -- | /Requires PostgreSQL version >= 9.3/ --
src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-}+{-# language DerivingStrategies #-}+ module Database.Esqueleto.PostgreSQL.JSON.Instances where import Data.Aeson (FromJSON(..), ToJSON(..), encode, eitherDecodeStrict)@@ -13,28 +15,28 @@ import Data.Text (Text) import qualified Data.Text as T (concat, pack) import qualified Data.Text.Encoding as TE (decodeUtf8, encodeUtf8)-import Database.Esqueleto (Value, just, val) import Database.Esqueleto.Internal.PersistentImport-import Database.Esqueleto.Internal.Sql (SqlExpr)+import Database.Esqueleto.Internal.Internal (SqlExpr, Value, just, val) import GHC.Generics (Generic) - -- | Newtype wrapper around any type with a JSON representation. -- -- @since 3.1.0 newtype JSONB a = JSONB { unJSONB :: a }- deriving- ( Generic- , FromJSON- , ToJSON- , Eq- , Foldable- , Functor- , Ord- , Read- , Show- , Traversable- )+ deriving stock+ ( Generic+ , Eq+ , Foldable+ , Functor+ , Ord+ , Read+ , Show+ , Traversable+ )+ deriving newtype+ ( FromJSON+ , ToJSON+ ) -- | 'SqlExpr' of a NULL-able 'JSONB' value. Hence the 'Maybe'. --@@ -60,48 +62,49 @@ -- JSONKey "name" -- -- NOTE: DO NOT USE ANY OF THE 'Num' METHODS ON THIS TYPE!-data JSONAccessor = JSONIndex Int- | JSONKey Text- deriving (Generic, Eq, Show)+data JSONAccessor+ = JSONIndex Int+ | JSONKey Text+ deriving (Generic, Eq, Show) -- | I repeat, DO NOT use any method other than 'fromInteger'! instance Num JSONAccessor where- fromInteger = JSONIndex . fromInteger- negate (JSONIndex i) = JSONIndex $ negate i- negate (JSONKey _) = error "Can not negate a JSONKey"- (+) = numErr- (-) = numErr- (*) = numErr- abs = numErr- signum = numErr+ fromInteger = JSONIndex . fromInteger+ negate (JSONIndex i) = JSONIndex $ negate i+ negate (JSONKey _) = error "Can not negate a JSONKey"+ (+) = numErr+ (-) = numErr+ (*) = numErr+ abs = numErr+ signum = numErr numErr :: a numErr = error "Do not use 'Num' methods on JSONAccessors" instance IsString JSONAccessor where- fromString = JSONKey . T.pack+ fromString = JSONKey . T.pack -- | @since 3.1.0 instance (FromJSON a, ToJSON a) => PersistField (JSONB a) where- toPersistValue = PersistDbSpecific . BSL.toStrict . encode . unJSONB- fromPersistValue pVal = fmap JSONB $ case pVal of- PersistByteString bs -> first (badParse $ TE.decodeUtf8 bs) $ eitherDecodeStrict bs- PersistText t -> first (badParse t) $ eitherDecodeStrict (TE.encodeUtf8 t)- x -> Left $ fromPersistValueError "string or bytea" x+ toPersistValue = PersistLiteralEscaped . BSL.toStrict . encode . unJSONB+ fromPersistValue pVal = fmap JSONB $ case pVal of+ PersistByteString bs -> first (badParse $ TE.decodeUtf8 bs) $ eitherDecodeStrict bs+ PersistText t -> first (badParse t) $ eitherDecodeStrict (TE.encodeUtf8 t)+ x -> Left $ fromPersistValueError "string or bytea" x -- | jsonb -- -- @since 3.1.0 instance (FromJSON a, ToJSON a) => PersistFieldSql (JSONB a) where- sqlType _ = SqlOther "JSONB"+ sqlType _ = SqlOther "JSONB" badParse :: Text -> String -> Text badParse t = fromPersistValueParseError t . T.pack fromPersistValueError- :: Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int".- -> PersistValue -- ^ Incorrect value- -> Text -- ^ Error message+ :: Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int".+ -> PersistValue -- ^ Incorrect value+ -> Text -- ^ Error message fromPersistValueError databaseType received = T.concat [ "Failed to parse Haskell newtype `JSONB a`; " , "expected ", databaseType@@ -110,9 +113,9 @@ ] fromPersistValueParseError- :: Text -- ^ Received value- -> Text -- ^ Additional error- -> Text -- ^ Error message+ :: Text -- ^ Received value+ -> Text -- ^ Additional error+ -> Text -- ^ Error message fromPersistValueParseError received err = T.concat [ "Failed to parse Haskell type `JSONB a`, " , "but received ", received
+ src/Database/Esqueleto/Record.hs view
@@ -0,0 +1,902 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++module Database.Esqueleto.Record+ ( deriveEsqueletoRecord+ , deriveEsqueletoRecordWith++ , DeriveEsqueletoRecordSettings(..)+ , defaultDeriveEsqueletoRecordSettings+ , takeColumns+ , takeMaybeColumns+ ) where++import Control.Monad.Trans.State.Strict (StateT(..), evalStateT)+import Data.Proxy (Proxy(..))+import Database.Esqueleto.Experimental+ (Entity, PersistValue, SqlExpr, Value(..), (:&)(..))+import Database.Esqueleto.Experimental.ToAlias (ToAlias(..))+import Database.Esqueleto.Experimental.ToMaybe (ToMaybe(..))+import Database.Esqueleto.Experimental.ToAliasReference (ToAliasReference(..))+import Database.Esqueleto.Internal.Internal (SqlSelect(..))+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Data.Bifunctor (first)+import Data.Text (Text)+import Control.Monad (forM)+import Data.Foldable (foldl')+import GHC.Exts (IsString(fromString))+import Data.Maybe (mapMaybe, fromMaybe, listToMaybe, isJust)++-- | Takes the name of a Haskell record type and creates a variant of that+-- record prefixed with @Sql@ which can be used in esqueleto expressions. This+-- reduces the amount of pattern matching on large tuples required to interact+-- with data extracted with esqueleto.+--+-- Note that because the input record and the @Sql@-prefixed record share field+-- names, the @{-\# LANGUAGE DuplicateRecordFields \#-}@ extension is required in+-- modules that use `deriveEsqueletoRecord`. Additionally, the @{-\# LANGUAGE+-- TypeApplications \#-}@ extension is required for some of the generated code.+--+-- Given the following record:+--+-- @+-- data MyRecord = MyRecord+-- { myName :: 'Text'+-- , myAge :: 'Maybe' 'Int'+-- , myUser :: 'Entity' User+-- , myAddress :: 'Maybe' ('Entity' Address)+-- }+-- @+--+-- @$('deriveEsqueletoRecord' ''MyRecord)@ will generate roughly the following code:+--+-- @+-- data SqlMyRecord =+-- SqlMyRecord { myName :: 'SqlExpr' ('Value' Text)+-- , myAge :: 'SqlExpr' ('Value' ('Maybe' Int))+-- , myUser :: 'SqlExpr' ('Entity' User)+-- , myAddress :: 'SqlExpr' ('Maybe' ('Entity' Address))+-- }+--+-- instance 'SqlSelect' SqlMyRecord MyRecord where+-- 'sqlSelectCols'+-- identInfo+-- SqlMyRecord { myName = myName+-- , myAge = myAge+-- , myUser = myUser+-- , myAddress = myAddress+-- } =+-- 'sqlSelectCols' identInfo (myName :& myAge :& myUser :& myAddress)+--+-- 'sqlSelectColCount' _ =+-- 'sqlSelectColCount'+-- ('Proxy' \@( ('SqlExpr' ('Value' Text))+-- :& ('SqlExpr' ('Value' ('Maybe' Int)))+-- :& ('SqlExpr' ('Entity' User))+-- :& ('SqlExpr' ('Maybe' ('Entity' Address)))))+--+-- 'sqlSelectProcessRow' columns =+-- 'first' (('fromString' "Failed to parse MyRecord: ") <>)+-- ('evalStateT' process columns)+-- where+-- process = do+-- 'Value' myName <- 'takeColumns' \@('SqlExpr' ('Value' Text))+-- 'Value' myAge <- 'takeColumns' \@('SqlExpr' ('Value' ('Maybe' Int)))+-- myUser <- 'takeColumns' \@('SqlExpr' ('Entity' User))+-- myAddress <- 'takeColumns' \@('SqlExpr' ('Maybe' ('Entity' Address)))+-- 'pure' MyRecord { myName = myName+-- , myAge = myAge+-- , myUser = myUser+-- , myAddress = myAddress+-- }+-- @+--+-- Then, we could write a selection function to use the record in queries:+--+-- @+-- getMyRecord :: 'Database.Esqueleto.SqlPersistT' 'IO' [MyRecord]+-- getMyRecord = 'Database.Esqueleto.Experimental.select' myRecordQuery+--+-- myRecordQuery :: 'Database.Esqueleto.SqlQuery' SqlMyRecord+-- myRecordQuery = do+-- user ':&' address <- 'Database.Esqueleto.Experimental.from' '$'+-- 'Database.Esqueleto.Experimental.table' \@User+-- \`'Database.Esqueleto.Experimental.leftJoin'\`+-- 'Database.Esqueleto.Experimental.table' \@Address+-- \`'Database.Esqueleto.Experimental.on'\` (do \\(user ':&' address) -> user 'Database.Esqueleto.Experimental.^.' #address 'Database.Esqueleto.Experimental.==.' address 'Database.Esqueleto.Experimental.?.' #id)+-- 'pure'+-- SqlMyRecord+-- { myName = 'Database.Esqueleto.Experimental.castString' '$' user 'Database.Esqueleto.Experimental.^.' #firstName+-- , myAge = 'Database.Esqueleto.Experimental.val' 10+-- , myUser = user+-- , myAddress = address+-- }+-- @+--+-- @since 3.5.6.0+deriveEsqueletoRecord :: Name -> Q [Dec]+deriveEsqueletoRecord = deriveEsqueletoRecordWith defaultDeriveEsqueletoRecordSettings++-- | Codegen settings for 'deriveEsqueletoRecordWith'.+--+-- @since 3.5.8.0+data DeriveEsqueletoRecordSettings = DeriveEsqueletoRecordSettings+ { sqlNameModifier :: String -> String+ -- ^ Function applied to the Haskell record's type name and constructor+ -- name to produce the SQL record's type name and constructor name.+ --+ -- @since 3.5.8.0+ , sqlMaybeNameModifier :: String -> String+ -- ^ Function applied to the Haskell record's type name and constructor+ -- name to produce the 'ToMaybe' record's type name and constructor name.+ --+ -- @since 3.5.11.0+ , sqlFieldModifier :: String -> String+ -- ^ Function applied to the Haskell record's field names to produce the+ -- SQL record's field names.+ --+ -- @since 3.5.8.0+ , sqlMaybeFieldModifier :: String -> String+ -- ^ Function applied to the Haskell record's field names to produce the+ -- 'ToMaybe' SQL record's field names.+ --+ -- @since 3.5.11.0+ }++-- | The default codegen settings for 'deriveEsqueletoRecord'.+--+-- These defaults will cause you to require @{-# LANGUAGE DuplicateRecordFields #-}@+-- in certain cases (see 'deriveEsqueletoRecord'.) If you don't want to do this,+-- change the value of 'sqlFieldModifier' so the field names of the generated SQL+-- record different from those of the Haskell record.+--+-- @since 3.5.8.0+defaultDeriveEsqueletoRecordSettings :: DeriveEsqueletoRecordSettings+defaultDeriveEsqueletoRecordSettings = DeriveEsqueletoRecordSettings+ { sqlNameModifier = ("Sql" ++)+ , sqlMaybeNameModifier = ("SqlMaybe" ++)+ , sqlFieldModifier = id+ , sqlMaybeFieldModifier = id+ }++-- | Takes the name of a Haskell record type and creates a variant of that+-- record based on the supplied settings which can be used in esqueleto+-- expressions. This reduces the amount of pattern matching on large tuples+-- required to interact with data extracted with esqueleto.+--+-- This is a variant of 'deriveEsqueletoRecord' which allows you to avoid the+-- use of @{-# LANGUAGE DuplicateRecordFields #-}@, by configuring the+-- 'DeriveEsqueletoRecordSettings' used to generate the SQL record.+--+-- @since 3.5.8.0+deriveEsqueletoRecordWith :: DeriveEsqueletoRecordSettings -> Name -> Q [Dec]+deriveEsqueletoRecordWith settings originalName = do+ info <- getRecordInfo settings originalName+ -- It would be nicer to use `mconcat` here but I don't think the right+ -- instance is available in GHC 8.+ recordDec <- makeSqlRecord info+ sqlSelectInstanceDec <- makeSqlSelectInstance info+ sqlMaybeRecordDec <- makeSqlMaybeRecord info+ toMaybeInstanceDec <- makeToMaybeInstance info+ sqlMaybeToMaybeInstanceDec <- makeSqlMaybeToMaybeInstance info+ sqlMaybeRecordSelectInstanceDec <- makeSqlMaybeRecordSelectInstance info+ toAliasInstanceDec <- makeToAliasInstance info+ sqlMaybeToAliasInstanceDec <- makeSqlMaybeToAliasInstance info+ toAliasReferenceInstanceDec <- makeToAliasReferenceInstance info+ sqlMaybeToAliasReferenceInstanceDec <- makeSqlMaybeToAliasReferenceInstance info+ pure+ [ recordDec+ , sqlSelectInstanceDec+ , sqlMaybeRecordDec+ , toMaybeInstanceDec+ , sqlMaybeToMaybeInstanceDec+ , sqlMaybeRecordSelectInstanceDec+ , toAliasInstanceDec+ , sqlMaybeToAliasInstanceDec+ , toAliasReferenceInstanceDec+ , sqlMaybeToAliasReferenceInstanceDec+ ]++-- | Information about a record we need to generate the declarations.+-- We compute this once and then pass it around to save on complexity /+-- repeated work.+data RecordInfo = RecordInfo+ { -- | The original record's name.+ name :: Name+ , -- | The generated SQL record's name.+ sqlName :: Name+ , -- | The generated SQL 'ToMaybe' record's name.+ sqlMaybeName :: Name+ , -- | The original record's constraints. If this isn't empty it'll probably+ -- cause problems, but it's easy to pass around so might as well.+ constraints :: Cxt+ , -- | The original record's type-variable-binders.+#if MIN_VERSION_template_haskell(2,21,0)+ typeVarBinders :: [TyVarBndr BndrVis]+#elif MIN_VERSION_template_haskell(2,17,0)+ typeVarBinders :: [TyVarBndr ()]+#else+ typeVarBinders :: [TyVarBndr]+#endif+ , -- | The original record's kind, I think.+ kind :: Maybe Kind+ , -- | The original record's constructor name.+ constructorName :: Name+ , -- | The generated SQL record's constructor name.+ sqlConstructorName :: Name+ , -- | The generated SQL 'ToMaybe' record's constructor name.+ sqlMaybeConstructorName :: Name+ , -- | The original record's field names and types, derived from the+ -- constructors.+ fields :: [(Name, Type)]+ , -- | The generated SQL record's field names and types, computed+ -- with 'sqlFieldType'.+ sqlFields :: [(Name, Type)]+ , -- | The generated SQL 'ToMaybe' record's field names and types, computed+ -- with 'sqlMaybeFieldType'.+ sqlMaybeFields :: [(Name, Type)]+ }++-- | Get a `RecordInfo` instance for the given record name.+getRecordInfo :: DeriveEsqueletoRecordSettings -> Name -> Q RecordInfo+getRecordInfo settings name = do+ TyConI dec <- reify name+ (constraints, typeVarBinders, kind, constructors) <-+ case dec of+ DataD constraints' _name typeVarBinders' kind' constructors' _derivingClauses ->+ pure (constraints', typeVarBinders', kind', constructors')+ NewtypeD constraints' _name typeVarBinders' kind' constructor' _derivingClauses ->+ pure (constraints', typeVarBinders', kind', [constructor'])+ _ -> fail $ "Esqueleto records can only be derived for records and newtypes, but " ++ show name ++ " is neither"+ constructor <- case constructors of+ (c : _) -> pure c+ [] -> fail $ "Cannot derive Esqueleto record for a type with no constructors: " ++ show name+ let constructorName =+ case head constructors of+ RecC name' _fields -> name'+ con -> error $ nonRecordConstructorMessage con+ fields = getFields constructor+ sqlName = makeSqlName settings name+ sqlMaybeName = makeSqlMaybeName settings name+ sqlConstructorName = makeSqlName settings constructorName+ sqlMaybeConstructorName = makeSqlMaybeName settings constructorName++ sqlFields <- mapM toSqlField fields+ sqlMaybeFields <- mapM toSqlMaybeField fields++ pure RecordInfo {..}+ where+ getFields :: Con -> [(Name, Type)]+ getFields (RecC _name fields) = [(fieldName', fieldType') | (fieldName', _bang, fieldType') <- fields]+ getFields con = error $ nonRecordConstructorMessage con++ toSqlField (fieldName', ty) = do+ let modifier = mkName . sqlFieldModifier settings . nameBase+ sqlTy <- sqlFieldType ty+ pure (modifier fieldName', sqlTy)++ toSqlMaybeField (fieldName', ty) = do+ let modifier = mkName . sqlMaybeFieldModifier settings . nameBase+ sqlTy <- sqlMaybeFieldType ty+ pure (modifier fieldName', sqlTy)++-- | Create a new name by prefixing @Sql@ to a given name.+makeSqlName :: DeriveEsqueletoRecordSettings -> Name -> Name+makeSqlName settings name = mkName $ sqlNameModifier settings $ nameBase name++-- | Create a new name by prefixing @SqlMaybe@ to a given name.+makeSqlMaybeName :: DeriveEsqueletoRecordSettings -> Name -> Name+makeSqlMaybeName settings name = mkName $ sqlMaybeNameModifier settings $ nameBase name++-- | Transforms a record field type into a corresponding `SqlExpr` type.+--+-- * @'Entity' x@ is transformed into @'SqlExpr' ('Entity' x)@.+-- * @'Maybe' ('Entity' x)@ is transformed into @'SqlExpr' ('Maybe' ('Entity' x))@.+-- * @x@ is transformed into @'SqlExpr' ('Value' x)@.+-- * If there exists an instance @'SqlSelect' sql x@, then @x@ is transformed into @sql@.+--+-- This function should match `sqlSelectProcessRowPat`.+sqlFieldType :: Type -> Q Type+sqlFieldType fieldType = do+ maybeSqlType <- reifySqlSelectType fieldType++ pure $+ flip fromMaybe maybeSqlType $+ case fieldType of+ -- Entity x -> SqlExpr (Entity x)+ AppT (ConT ((==) ''Entity -> True)) _innerType -> AppT (ConT ''SqlExpr) fieldType++ -- Maybe (Entity x) -> SqlExpr (Maybe (Entity x))+ (ConT ((==) ''Maybe -> True))+ `AppT` ((ConT ((==) ''Entity -> True))+ `AppT` _innerType) -> AppT (ConT ''SqlExpr) fieldType++ -- x -> SqlExpr (Value x)+ _ -> (ConT ''SqlExpr)+ `AppT` ((ConT ''Value)+ `AppT` fieldType)++-- | Transforms a record field type into a corresponding `SqlExpr` `ToMaybe` type.+--+-- * @'Entity' x@ is transformed into @'SqlExpr' ('Maybe' ('Entity' x))@.+-- * @'Maybe' ('Entity' x)@ is transformed into @'SqlExpr' ('Maybe' ('Maybe' ('Entity' x)))@.+-- * @x@ is transformed into @'SqlExpr' ('Value' ('Maybe' x))@.+-- * If there exists an instance @'SqlSelect' sql x@, then @x@ is transformed into @sql@.+--+-- This function should match `sqlSelectProcessRowPat`.+sqlMaybeFieldType :: Type -> Q Type+sqlMaybeFieldType fieldType = do+ maybeSqlType <- reifySqlSelectType fieldType++ pure $ maybe convertFieldType convertSqlType maybeSqlType+ where+ convertSqlType = ((ConT ''ToMaybeT) `AppT`)+ convertFieldType = case fieldType of+ -- Entity x -> SqlExpr (Entity x) -> SqlExpr (Maybe (Entity x))+ AppT (ConT ((==) ''Entity -> True)) _innerType ->+ (ConT ''SqlExpr) `AppT` ((ConT ''Maybe) `AppT` fieldType)++ -- Maybe (Entity x) -> SqlExpr (Maybe (Entity x)) -> SqlExpr (Maybe (Entity x))+ (ConT ((==) ''Maybe -> True))+ `AppT` ((ConT ((==) ''Entity -> True))+ `AppT` _innerType) ->+ (ConT ''SqlExpr) `AppT` fieldType++ -- Maybe x -> SqlExpr (Value (Maybe x)) -> SqlExpr (Value (Maybe x))+ inner@((ConT ((==) ''Maybe -> True)) `AppT` _inner) -> (ConT ''SqlExpr) `AppT` ((ConT ''Value) `AppT` inner)++ -- x -> SqlExpr (Value x) -> SqlExpr (Value (Maybe x))+ _ -> (ConT ''SqlExpr)+ `AppT` ((ConT ''Value)+ `AppT` ((ConT ''Maybe) `AppT` fieldType))++-- | Generates the declaration for an @Sql@-prefixed record, given the original+-- record's information.+makeSqlRecord :: RecordInfo -> Q Dec+makeSqlRecord RecordInfo {..} = do+ let newConstructor = RecC sqlConstructorName (makeField `map` sqlFields)+ derivingClauses = []+ pure $ DataD constraints sqlName typeVarBinders kind [newConstructor] derivingClauses+ where+ makeField (fieldName', fieldType) =+ (fieldName', Bang NoSourceUnpackedness NoSourceStrictness, fieldType)++-- | Generates an `SqlSelect` instance for the given record and its+-- @Sql@-prefixed variant.+makeSqlSelectInstance :: RecordInfo -> Q Dec+makeSqlSelectInstance info@RecordInfo {..} = do+ sqlSelectColsDec' <- sqlSelectColsDec info+ sqlSelectColCountDec' <- sqlSelectColCountDec info+ sqlSelectProcessRowDec' <- sqlSelectProcessRowDec info+ let overlap = Nothing+ instanceConstraints = []+ instanceType <- [t| SqlSelect $(conT sqlName) $(conT name) |]++ pure $ InstanceD overlap instanceConstraints instanceType (sqlSelectColsDec' ++ sqlSelectColCountDec' ++ [ sqlSelectProcessRowDec'])++-- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance.+sqlSelectColsDec :: RecordInfo -> Q [Dec]+sqlSelectColsDec RecordInfo {..} = do+ -- Pairs of record field names and local variable names.+ fieldNames <- forM sqlFields (\(name', _type) -> do+ var <- newName $ nameBase name'+ pure (name', var))++ -- Patterns binding record fields to local variables.+ let fieldPatterns :: [FieldPat]+ fieldPatterns = [(name', VarP var) | (name', var) <- fieldNames]++ -- Local variables for fields joined with `:&` in a single expression.+ joinedFields :: Exp+ joinedFields =+ case snd `map` fieldNames of+ [] -> TupE []+ [f1] -> VarE f1+ f1 : rest ->+ let helper lhs field =+ InfixE+ (Just lhs)+ (ConE '(:&))+ (Just $ VarE field)+ in foldl' helper (VarE f1) rest++ identInfo <- newName "identInfo"+ [d| $(varP 'sqlSelectCols) = \ $(varP identInfo) $(pure $ RecP sqlName fieldPatterns) ->+ sqlSelectCols $(varE identInfo) $(pure joinedFields)+ |]++-- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance.+sqlSelectColCountDec :: RecordInfo -> Q [Dec]+sqlSelectColCountDec RecordInfo {..} = do+ let joinedTypes =+ case snd `map` sqlFields of+ [] -> TupleT 0+ t1 : rest ->+ let helper lhs ty =+ InfixT lhs ''(:&) ty+ in foldl' helper t1 rest++ [d| $(varP 'sqlSelectColCount) = \ _ -> sqlSelectColCount (Proxy @($(pure joinedTypes))) |]++-- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect`+-- instance.+sqlSelectProcessRowDec :: RecordInfo -> Q Dec+sqlSelectProcessRowDec RecordInfo {..} = do+ -- Binding statements and field expressions (used in record construction) to+ -- fill out the body of the main generated `do` expression.+ --+ -- Each statement is like:+ -- Value fooName' <- takeColumns @(SqlExpr (Value Text))+ -- A corresponding field expression would be:+ -- fooName = fooName'+ --+ -- See `sqlSelectProcessRowPat` for the left-hand side of the patterns.+ (statements, fieldExps) <-+ unzip <$> forM (zip fields sqlFields) (\((fieldName', fieldType), (_, sqlType')) -> do+ valueName <- newName (nameBase fieldName')+ pattern <- sqlSelectProcessRowPat fieldType valueName+ pure+ ( BindS+ pattern+ (AppTypeE (VarE 'takeColumns) sqlType')+ , (mkName $ nameBase fieldName', VarE valueName)+ ))++ colsName <- newName "columns"+ processName <- newName "process"++ -- Roughly:+ -- sqlSelectProcessRow $colsName =+ -- first ((fromString "Failed to parse $name: ") <>)+ -- (evalStateT $processName $colsName)+ -- where $processName = do $statements+ -- pure $name {$fieldExps}+ bodyExp <- [e|+ first (fromString ("Failed to parse " ++ $(lift $ nameBase name) ++ ": ") <>)+ (evalStateT $(varE processName) $(varE colsName))+ |]++ pure $+ FunD+ 'sqlSelectProcessRow+ [ Clause+ [VarP colsName]+ (NormalB bodyExp)+ -- `where` clause+ [ ValD+ (VarP processName)+ ( NormalB $+ DoE+#if MIN_VERSION_template_haskell(2,17,0)+ Nothing+#endif+ (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE constructorName fieldExps)])+ )+ []+ ]+ ]++-- | Get the left-hand side pattern of a statement in a @do@ block for binding+-- to the result of `sqlSelectProcessRow`.+--+-- * A type of @'Entity' x@ gives a pattern of @var@.+-- * A type of @'Maybe' ('Entity' x)@ gives a pattern of @var@.+-- * A type of @x@ gives a pattern of @'Value' var@.+-- * If there exists an instance @'SqlSelect' sql x@, then a type of @x@ gives a pattern of @var@.+--+-- This function should match `sqlFieldType`.+sqlSelectProcessRowPat :: Type -> Name -> Q Pat+sqlSelectProcessRowPat fieldType var = do+ maybeSqlType <- reifySqlSelectType fieldType++ case maybeSqlType of+ Just _ -> pure $ VarP var+ Nothing -> case fieldType of+ -- Entity x -> var+ AppT (ConT ((==) ''Entity -> True)) _innerType -> pure $ VarP var+ -- Maybe (Entity x) -> var+ (ConT ((==) ''Maybe -> True))+ `AppT` ((ConT ((==) ''Entity -> True))+ `AppT` _innerType) -> pure $ VarP var+ -- x -> Value var+ _ -> [p| Value $(varP var) |]++-- Given a type, find the corresponding SQL type.+--+-- If there exists an instance `SqlSelect sql ty`, then the SQL type for `ty`+-- is `sql`.+--+-- This function definitely works for records and instances generated by this+-- module, and might work for instances outside of it.+reifySqlSelectType :: Type -> Q (Maybe Type)+reifySqlSelectType originalType = do+ -- Here we query the compiler for Instances of `SqlSelect a $(originalType)`;+ -- the API for this is super weird, it interprets a list of types as being+ -- applied as successive arguments to the typeclass name.+ --+ -- See: https://gitlab.haskell.org/ghc/ghc/-/issues/21825+ --+ -- >>> reifyInstances ''SqlSelect [VarT (mkName "a"), ConT ''MyRecord]+ -- [ InstanceD Nothing+ -- []+ -- (AppT (AppT (ConT Database.Esqueleto.Internal.Internal.SqlSelect)+ -- (ConT Ghci3.SqlMyRecord))+ -- (ConT Ghci3.MyRecord))+ -- []+ -- ]+ tyVarName <- newName "a"+ instances <- reifyInstances ''SqlSelect [VarT tyVarName, originalType]++ -- Given the original type (`originalType`) and an instance type for a+ -- `SqlSelect` instance, get the SQL type which corresponds to the original+ -- type.+ let extractSqlRecord :: Type -> Type -> Maybe Type+ extractSqlRecord originalTy instanceTy =+ case instanceTy of+ (ConT ((==) ''SqlSelect -> True))+ `AppT` sqlTy+ `AppT` ((==) originalTy -> True) -> Just sqlTy+ _ -> Nothing++ -- Filter `instances` to the instances which match `originalType`.+ filteredInstances :: [Type]+ filteredInstances =+ flip mapMaybe instances+ (\case InstanceD _overlap+ _constraints+ (extractSqlRecord originalType -> Just sqlRecord)+ _decs ->+ Just sqlRecord+ _ -> Nothing)++ pure $ listToMaybe filteredInstances++-- | Statefully parse some number of columns from a list of `PersistValue`s,+-- where the number of columns to parse is determined by `sqlSelectColCount`+-- for @a@.+--+-- This is used to implement `sqlSelectProcessRow` for records created with+-- `deriveEsqueletoRecord`.+takeColumns ::+ forall a b.+ SqlSelect a b =>+ StateT [PersistValue] (Either Text) b+takeColumns = StateT (\pvs ->+ let targetColCount =+ sqlSelectColCount (Proxy @a)+ (target, other) =+ splitAt targetColCount pvs+ in if length target == targetColCount+ then do+ value <- sqlSelectProcessRow target+ Right (value, other)+ else Left "Insufficient columns when trying to parse a column")++-- | Get an error message for a non-record constructor.+-- This module does not yet support non-record constructors, so we'll tell the+-- user what sort of constructor they provided that we can't use, along with+-- the name of that constructor. This turns out to require recursion, but you+-- can't win every battle.+nonRecordConstructorMessage :: Con -> String+nonRecordConstructorMessage con =+ case con of+ (RecC {}) -> error "Record constructors are not an error"+ (NormalC {}) -> helper "non-record data constructor"+ (InfixC {}) -> helper "infix constructor"+ (ForallC {}) -> helper "constructor qualified by type variables / class contexts"+ (GadtC {}) -> helper "GADT constructor"+ (RecGadtC {}) -> helper "record GADT constructor"+ where+ helper constructorType =+ "Esqueleto records can only be derived for record constructors, but "+ ++ show (constructorName con)+ ++ " is a "+ ++ constructorType++ constructorName constructor =+ case constructor of+ (RecC name _) -> name+ (NormalC name _fields) -> name+ (InfixC _ty1 name _ty2) -> name+ (ForallC _vars _constraints innerConstructor) -> constructorName innerConstructor+ -- If there's GADTs where multiple constructors are declared with the+ -- same type signature you're evil and furthermore this diagnostic will+ -- only show you the first name.+ (GadtC names _fields _ret) -> head names+ (RecGadtC names _fields _ret) -> head names++makeToAliasInstance :: RecordInfo -> Q Dec+makeToAliasInstance RecordInfo {..} = makeToAliasInstanceFor sqlName sqlFields++makeSqlMaybeToAliasInstance :: RecordInfo -> Q Dec+makeSqlMaybeToAliasInstance RecordInfo {..} = makeToAliasInstanceFor sqlMaybeName sqlMaybeFields++makeToAliasInstanceFor :: Name -> [(Name, Type)] -> Q Dec+makeToAliasInstanceFor name fields = do+ toAliasDec' <- toAliasDec name fields+ let overlap = Nothing+ instanceConstraints = []+ instanceType = (ConT ''ToAlias) `AppT` (ConT name)+ pure $ InstanceD overlap instanceConstraints instanceType [toAliasDec']++toAliasDec :: Name -> [(Name, Type)] -> Q Dec+toAliasDec name fields = do+ (statements, fieldPatterns, fieldExps) <-+ unzip3 <$> forM fields (\(fieldName', _) -> do+ fieldPatternName <- newName (nameBase fieldName')+ boundValueName <- newName (nameBase fieldName')+ pure+ ( BindS+ (VarP boundValueName)+ (VarE 'toAlias `AppE` VarE fieldPatternName)+ , (fieldName', VarP fieldPatternName)+ , (fieldName', VarE boundValueName)+ ))++ pure $+ FunD+ 'toAlias+ [ Clause+ [ RecP name fieldPatterns+ ]+ ( NormalB $+ DoE+#if MIN_VERSION_template_haskell(2,17,0)+ Nothing+#endif+ (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE name fieldExps)])+ )+ -- `where` clause.+ []+ ]++makeToAliasReferenceInstance :: RecordInfo -> Q Dec+makeToAliasReferenceInstance RecordInfo {..} = makeToAliasReferenceInstanceFor sqlName sqlFields++makeSqlMaybeToAliasReferenceInstance :: RecordInfo -> Q Dec+makeSqlMaybeToAliasReferenceInstance RecordInfo {..} =+ makeToAliasReferenceInstanceFor sqlMaybeName sqlMaybeFields++makeToAliasReferenceInstanceFor :: Name -> [(Name, Type)] -> Q Dec+makeToAliasReferenceInstanceFor name fields = do+ toAliasReferenceDec' <- toAliasReferenceDec name fields+ let overlap = Nothing+ instanceConstraints = []+ instanceType = (ConT ''ToAliasReference) `AppT` (ConT name)+ pure $ InstanceD overlap instanceConstraints instanceType [toAliasReferenceDec']++toAliasReferenceDec :: Name -> [(Name, Type)] -> Q Dec+toAliasReferenceDec name fields = do+ identInfo <- newName "identInfo"++ (statements, fieldPatterns, fieldExps) <-+ unzip3 <$> forM fields (\(fieldName', _) -> do+ fieldPatternName <- newName (nameBase fieldName')+ boundValueName <- newName (nameBase fieldName')+ pure+ ( BindS+ (VarP boundValueName)+ (VarE 'toAliasReference `AppE` VarE identInfo `AppE` VarE fieldPatternName)+ , (fieldName', VarP fieldPatternName)+ , (fieldName', VarE boundValueName)+ ))++ pure $+ FunD+ 'toAliasReference+ [ Clause+ [ VarP identInfo+ , RecP name fieldPatterns+ ]+ ( NormalB $+ DoE+#if MIN_VERSION_template_haskell(2,17,0)+ Nothing+#endif+ (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE name fieldExps)])+ )+ -- `where` clause.+ []+ ]++-- | Generates the declaration for an @SqlMaybe@-prefixed record, given the original+-- record's information.+makeSqlMaybeRecord :: RecordInfo -> Q Dec+makeSqlMaybeRecord RecordInfo {..} = do+ let newConstructor = RecC sqlMaybeConstructorName (makeField `map` sqlMaybeFields)+ derivingClauses = []+ pure $ DataD constraints sqlMaybeName typeVarBinders kind [newConstructor] derivingClauses+ where+ makeField (fieldName', fieldType) =+ (fieldName', Bang NoSourceUnpackedness NoSourceStrictness, fieldType)+++-- | Generates a `ToMaybe` instance for the given record.+makeToMaybeInstance :: RecordInfo -> Q Dec+makeToMaybeInstance info@RecordInfo {..} = do+ toMaybeTDec' <- toMaybeTDec sqlName sqlMaybeName + toMaybeDec' <- toMaybeDec info+ let overlap = Nothing+ instanceConstraints = []+ instanceType = (ConT ''ToMaybe) `AppT` (ConT sqlName)++ pure $ InstanceD overlap instanceConstraints instanceType (toMaybeTDec' ++ toMaybeDec')++-- | Generates a `ToMaybe` instance for the SqlMaybe of the given record.+makeSqlMaybeToMaybeInstance :: RecordInfo -> Q Dec+makeSqlMaybeToMaybeInstance RecordInfo {..} = do+ sqlMaybeToMaybeTDec' <- toMaybeTDec sqlMaybeName sqlMaybeName+ let toMaybeIdDec = FunD 'toMaybe [ Clause [] (NormalB (VarE 'id)) []]+ overlap = Nothing+ instanceConstraints = []+ instanceType = (ConT ''ToMaybe) `AppT` (ConT sqlMaybeName)+ pure $ InstanceD overlap instanceConstraints instanceType (toMaybeIdDec:sqlMaybeToMaybeTDec')++-- | Generates a `type ToMaybeT ... = ...` declaration for the given names.+toMaybeTDec :: Name -> Name -> Q [Dec]+toMaybeTDec nameLeft nameRight =+ [d| type instance ToMaybeT $(conT nameLeft) = $(conT nameRight) |]++-- | Generates a `toMaybe value = ...` declaration for the given record.+toMaybeDec :: RecordInfo -> Q [Dec]+toMaybeDec RecordInfo {..} = do+ (fieldPatterns, fieldExps) <-+ unzip <$> forM (zip sqlFields sqlMaybeFields) (\((fieldName', _), (maybeFieldName', _)) -> do+ fieldPatternName <- newName (nameBase fieldName')+ pure+ ( (fieldName', VarP fieldPatternName)+ , (maybeFieldName', VarE 'toMaybe `AppE` VarE fieldPatternName)+ ))++ [d| $(varP 'toMaybe) = \ $(pure $ RecP sqlName fieldPatterns) ->+ $(pure $ RecConE sqlMaybeName fieldExps)+ |]++-- | Generates an `SqlSelect` instance for the given record and its+-- @Sql@-prefixed variant.+makeSqlMaybeRecordSelectInstance :: RecordInfo -> Q Dec+makeSqlMaybeRecordSelectInstance info@RecordInfo {..} = do+ sqlSelectColsDec' <- sqlMaybeSelectColsDec info+ sqlSelectColCountDec' <- sqlMaybeSelectColCountDec info+ sqlSelectProcessRowDec' <- sqlMaybeSelectProcessRowDec info+ let overlap = Nothing+ instanceConstraints = []+ instanceType <- [t| SqlSelect $(conT sqlMaybeName) (Maybe $(conT name)) |]+ pure $ InstanceD overlap instanceConstraints instanceType (sqlSelectColsDec' ++ sqlSelectColCountDec' ++ [sqlSelectProcessRowDec'])++-- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance.+sqlMaybeSelectColsDec :: RecordInfo -> Q [Dec]+sqlMaybeSelectColsDec RecordInfo {..} = do+ -- Pairs of record field names and local variable names.+ fieldNames <- forM sqlMaybeFields (\(name', _type) -> do+ var <- newName $ nameBase name'+ pure (name', var))++ -- Patterns binding record fields to local variables.+ let fieldPatterns :: [FieldPat]+ fieldPatterns = [(name', VarP var) | (name', var) <- fieldNames]++ -- Local variables for fields joined with `:&` in a single expression.+ joinedFields :: Exp+ joinedFields =+ case snd `map` fieldNames of+ [] -> TupE []+ [f1] -> VarE f1+ f1 : rest ->+ let helper lhs field =+ InfixE+ (Just lhs)+ (ConE '(:&))+ (Just $ VarE field)+ in foldl' helper (VarE f1) rest++ identInfo <- newName "identInfo"+ [d| $(varP 'sqlSelectCols) = \ $(varP identInfo) $(pure $ RecP sqlMaybeName fieldPatterns) ->+ sqlSelectCols $(varE identInfo) $(pure joinedFields)+ |]++-- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect`+-- instance for a SqlMaybe.+sqlMaybeSelectProcessRowDec :: RecordInfo -> Q Dec+sqlMaybeSelectProcessRowDec RecordInfo {..} = do+ -- See sqlSelectProcessRowDec, which is similar but does not have special handling for Maybe+ (statements, fieldExps) <-+ unzip <$> forM (zip fields sqlMaybeFields) (\((fieldName', fieldType), (_, sqlType')) -> do+ valueName <- newName (nameBase fieldName')+ pattern <- sqlSelectProcessRowPat fieldType valueName+ pure+ ( BindS+ pattern+ (AppTypeE (VarE 'takeColumns) sqlType')+ , (valueName, wrapJust fieldType $ VarE valueName)+ ))++ colsName <- newName "columns"+ processName <- newName "process"++ bodyExp <- [e|+ first (fromString ("Failed to parse " ++ $(lift $ nameBase sqlMaybeName) ++ ": ") <>)+ (evalStateT $(varE processName) $(varE colsName))+ |]++ pure $+ FunD+ 'sqlSelectProcessRow+ [ Clause+ [VarP colsName]+ (NormalB bodyExp)+ -- `where`+ [ ValD+ (VarP processName)+ (NormalB $+ DoE+#if MIN_VERSION_template_haskell(2,17,0)+ Nothing+#endif+ (statements ++ [+ NoBindS $ AppE (VarE 'pure) (+ CondE+ (AppE+ (VarE 'or)+ (ListE $ fmap (\(n, _) -> AppE (VarE 'isJust) (VarE n)) fieldExps))+ (case snd <$> fieldExps of+ [] -> ConE constructorName+ x:xs -> foldl'+ (\a b -> InfixE (Just a) (VarE '(<*>)) (Just b))+ (InfixE (Just $ ConE constructorName) (VarE '(<$>)) (Just x))+ xs)+ (ConE 'Nothing)+ )+ ]+ )+ )+ []+ ]+ ]+ where+ wrapJust x = case x of+ ((ConT ((==) ''Maybe -> True)) `AppT` _inner) -> AppE (ConE 'Just)+ _ -> id++-- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance.+sqlMaybeSelectColCountDec :: RecordInfo -> Q [Dec]+sqlMaybeSelectColCountDec RecordInfo {..} = do+ let joinedTypes =+ case snd `map` sqlMaybeFields of+ [] -> TupleT 0+ t1 : rest ->+ let helper lhs ty =+ InfixT lhs ''(:&) ty+ in foldl' helper t1 rest++ [d| $(varP 'sqlSelectColCount) = \_ -> sqlSelectColCount (Proxy @($(pure joinedTypes))) |]++-- | Statefully parse some number of columns from a list of `PersistValue`s,+-- where the number of columns to parse is determined by `sqlSelectColCount`+-- for @a@.+--+-- This is used to implement `sqlSelectProcessRow` for records created with+-- `deriveEsqueletoRecord`.+takeMaybeColumns ::+ forall a b.+ (SqlSelect a (ToMaybeT b)) =>+ StateT [PersistValue] (Either Text) (ToMaybeT b)+takeMaybeColumns = StateT (\pvs ->+ let targetColCount =+ sqlSelectColCount (Proxy @a)+ (target, other) =+ splitAt targetColCount pvs+ in if length target == targetColCount+ then do+ value <- sqlSelectProcessRow target+ Right (value, other)+ else Left "Insufficient columns when trying to parse a column")
src/Database/Esqueleto/SQLite.hs view
@@ -1,14 +1,14 @@ {-# LANGUAGE OverloadedStrings #-}+ -- | This module contain SQLite-specific functions. ----- /Since: 2.2.8/+-- @since 2.2.8 module Database.Esqueleto.SQLite ( random_ ) where -import Database.Esqueleto.Internal.Language hiding (random_)+import Database.Esqueleto.Internal.Internal hiding (random_) import Database.Esqueleto.Internal.PersistentImport-import Database.Esqueleto.Internal.Sql -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`.
+ test/Common/Record.hs view
@@ -0,0 +1,464 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- Tests for `Database.Esqueleto.Record`.+module Common.Record (testDeriveEsqueletoRecord) where++import Common.Test.Import hiding (from, on)+import Data.List (sortOn)+import Database.Esqueleto.Experimental+import Database.Esqueleto.Record+ ( DeriveEsqueletoRecordSettings(..)+ , defaultDeriveEsqueletoRecordSettings+ , deriveEsqueletoRecord+ , deriveEsqueletoRecordWith+ )+import GHC.Records++data MyRecord =+ MyRecord+ { myName :: Text+ , myAge :: Maybe Int+ , myUser :: Entity User+ , myAddress :: Maybe (Entity Address)+ }+ deriving (Show, Eq)++$(deriveEsqueletoRecord ''MyRecord)++myRecordQuery :: SqlQuery SqlMyRecord+myRecordQuery = do+ user :& address <- from $+ table @User+ `leftJoin`+ table @Address+ `on` (do \(user :& address) -> user ^. #address ==. address ?. #id)+ pure+ SqlMyRecord+ { myName = castString $ user ^. #name+ , myAge = val $ Just 10+ , myUser = user+ , myAddress = address+ }++data MyNestedRecord = MyNestedRecord+ { myName :: Text+ , myRecord :: MyRecord+ , myMaybeRecord :: Maybe MyRecord+ }+ deriving (Show, Eq)++data MyNestedMaybeRecord = MyNestedMaybeRecord+ {myNestedRecord :: Maybe MyRecord}+ deriving (Show, Eq)++$(deriveEsqueletoRecord ''MyNestedRecord)+$(deriveEsqueletoRecord ''MyNestedMaybeRecord)++myNestedRecordQuery :: SqlQuery SqlMyNestedRecord+myNestedRecordQuery = do+ user :& address <-+ from $+ table @User+ `leftJoin` table @Address+ `on` (do \(user :& address) -> user ^. #address ==. address ?. #id)+ pure+ SqlMyNestedRecord+ { myName = castString $ user ^. #name+ , myRecord =+ SqlMyRecord+ { myName = castString $ user ^. #name+ , myAge = val $ Just 10+ , myUser = user+ , myAddress = address+ }+ , myMaybeRecord =+ SqlMaybeMyRecord+ { myName = castString $ user ^. #name+ , myAge = val $ Just 10+ , myUser = toMaybe user+ , myAddress = address+ }+ }++myNestedMaybeRecordQuery :: SqlQuery SqlMyNestedMaybeRecord+myNestedMaybeRecordQuery = do+ user :& address <-+ from $+ table @User+ `leftJoin` table @Address+ `on` (do \(user :& address) -> user ^. #address ==. address ?. #id)+ pure+ SqlMyNestedMaybeRecord+ {+ myNestedRecord =+ SqlMaybeMyRecord+ { myName = castString $ user ^. #name+ , myAge = val $ Just 10+ , myUser = toMaybe user+ , myAddress = address+ }+ }++data MyModifiedRecord =+ MyModifiedRecord+ { myModifiedName :: Text+ , myModifiedAge :: Maybe Int+ , myModifiedUser :: Entity User+ , myModifiedAddress :: Maybe (Entity Address)+ }+ deriving (Show, Eq)++$(deriveEsqueletoRecordWith (defaultDeriveEsqueletoRecordSettings+ { sqlNameModifier = (++ "Sql")+ , sqlFieldModifier = (++ "Sql")+ })+ ''MyModifiedRecord)++myModifiedRecordQuery :: SqlQuery MyModifiedRecordSql+myModifiedRecordQuery = do+ user :& address <- from $+ table @User+ `leftJoin`+ table @Address+ `on` (do \(user :& address) -> user ^. #address ==. address ?. #id)+ pure+ MyModifiedRecordSql+ { myModifiedNameSql = castString $ user ^. #name+ , myModifiedAgeSql = val $ Just 10+ , myModifiedUserSql = user+ , myModifiedAddressSql = address+ }++mySubselectRecordQuery :: SqlQuery (SqlExpr (Maybe (Entity Address)))+mySubselectRecordQuery = do+ _ :& record <- from $+ table @User+ `leftJoin`+ myRecordQuery+ `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" record ?. #id)+ pure $ getField @"myAddress" record++testDeriveEsqueletoRecord :: SpecDb+testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do+ let setup :: MonadIO m => SqlPersistT m ()+ setup = do+ _ <- insert $ User { userAddress = Nothing, userName = "Rebecca" }+ addr <- insert $ Address { addressAddress = "30-50 Feral Hogs Rd" }+ _ <- insert $ User { userAddress = Just addr, userName = "Some Guy" }+ pure ()++ itDb "can select records" $ do+ setup+ records <- select myRecordQuery+ let sortedRecords = sortOn (\MyRecord {myName} -> myName) records+ liftIO $ sortedRecords !! 0+ `shouldSatisfy`+ (\case MyRecord { myName = "Rebecca"+ , myAge = Just 10+ , myUser = Entity _ User { userAddress = Nothing+ , userName = "Rebecca"+ }+ , myAddress = Nothing+ } -> True+ _ -> False)+ liftIO $ sortedRecords !! 1+ `shouldSatisfy`+ (\case MyRecord { myName = "Some Guy"+ , myAge = Just 10+ , myUser = Entity _ User { userAddress = Just addr1+ , userName = "Some Guy"+ }+ , myAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})+ } -> addr1 == addr2 -- The keys should match.+ _ -> False)++ itDb "can select nested records" $ do+ setup+ records <- select myNestedRecordQuery+ let sortedRecords = sortOn (\MyNestedRecord {myName} -> myName) records+ liftIO $ sortedRecords !! 0+ `shouldSatisfy`+ (\case MyNestedRecord+ { myName = "Rebecca"+ , myRecord =+ MyRecord { myName = "Rebecca"+ , myAge = Just 10+ , myUser = Entity _ User { userAddress = Nothing+ , userName = "Rebecca"+ }+ , myAddress = Nothing+ }+ } -> True+ _ -> False)++ liftIO $ sortedRecords !! 1+ `shouldSatisfy`+ (\case MyNestedRecord+ { myName = "Some Guy"+ , myRecord =+ MyRecord { myName = "Some Guy"+ , myAge = Just 10+ , myUser = Entity _ User { userAddress = Just addr1+ , userName = "Some Guy"+ }+ , myAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})+ }+ } -> addr1 == addr2 -- The keys should match.+ _ -> False)++ itDb "can select nested maybe records" $ do+ setup+ records <- select myNestedMaybeRecordQuery+ let sortedRecords = sortOn (\MyNestedMaybeRecord {myNestedRecord} -> case myNestedRecord of+ Just r -> getField @"myName" r+ Nothing -> "No name"+ ) records+ liftIO $ sortedRecords !! 0+ `shouldSatisfy`+ (\case MyNestedMaybeRecord+ {+ myNestedRecord = Just+ MyRecord { myName = "Rebecca"+ , myAge = Just 10+ , myUser = Entity _ User { userAddress = Nothing+ , userName = "Rebecca"+ }+ , myAddress = Nothing+ }+ } -> True+ _ -> False)++ liftIO $ sortedRecords !! 1+ `shouldSatisfy`+ (\case MyNestedMaybeRecord+ {+ myNestedRecord = Just+ MyRecord { myName = "Some Guy"+ , myAge = Just 10+ , myUser = Entity _ User { userAddress = Just addr1+ , userName = "Some Guy"+ }+ , myAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})+ }+ } -> addr1 == addr2 -- The keys should match.+ _ -> False)++ itDb "can select nested nothing records" $ do+ setup+ records <- select $ do+ user :& address <-+ from $ table @User `leftJoin` table @Address `on` (do \(_ :& _) -> val False)+ pure+ SqlMyNestedMaybeRecord+ {+ myNestedRecord =+ SqlMaybeMyRecord+ { myName = val Nothing+ , myAge = val Nothing+ , myUser = toMaybe user+ , myAddress = address+ }+ }+ liftIO $ records `shouldBe`+ [MyNestedMaybeRecord { myNestedRecord = Nothing }, MyNestedMaybeRecord { myNestedRecord = Nothing}]++ itDb "can left join on nested maybed records" $ do+ setup+ records <- select $ do+ from+ ( table @User+ `leftJoin` myNestedMaybeRecordQuery+ `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" (getField @"myNestedRecord" record) ?. #id)+ )+ let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records+ liftIO $ sortedRecords !! 0+ `shouldSatisfy`+ (\case (_ :& Just (MyNestedMaybeRecord+ {+ myNestedRecord = Just+ MyRecord { myName = "Rebecca",+ myAddress = Nothing+ }+ }+ )) -> True+ _ -> False)+ liftIO $ sortedRecords !! 1+ `shouldSatisfy`+ (\case ( _ :& Just (MyNestedMaybeRecord+ { myNestedRecord = Just+ MyRecord { myName = "Some Guy"+ , myAddress = (Just (Entity _ Address {addressAddress = "30-50 Feral Hogs Rd"}))+ }+ }+ )) -> True+ _ -> False)++ itDb "can left join on nothing nested records" $ do+ setup+ records <- select $ do+ from (table @User `leftJoin` myNestedMaybeRecordQuery `on` (do \(_ :& _) -> val False))+ let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records+ liftIO $ sortedRecords !! 0+ `shouldSatisfy`+ (\case (_ :& Nothing) -> True+ _ -> False)+ liftIO $ sortedRecords !! 1+ `shouldSatisfy`+ (\case (_ :& Nothing) -> True+ _ -> False)++ itDb "can be used in a CTE" $ do+ setup+ records <- select $ do+ recordCTE <- with myRecordQuery+ record <- from recordCTE+ pure record+ let sortedRecords = sortOn (\MyRecord {myName} -> myName) records+ liftIO $ sortedRecords !! 0+ `shouldSatisfy`+ (\case MyRecord { myName = "Rebecca"+ , myAge = Just 10+ , myUser = Entity _ User { userAddress = Nothing+ , userName = "Rebecca"+ }+ , myAddress = Nothing+ } -> True+ _ -> False)+ liftIO $ sortedRecords !! 1+ `shouldSatisfy`+ (\case MyRecord { myName = "Some Guy"+ , myAge = Just 10+ , myUser = Entity _ User { userAddress = Just addr1+ , userName = "Some Guy"+ }+ , myAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})+ } -> addr1 == addr2 -- The keys should match.+ _ -> False)++ itDb "can select user-modified records" $ do+ setup+ records <- select myModifiedRecordQuery+ let sortedRecords = sortOn (\MyModifiedRecord {myModifiedName} -> myModifiedName) records+ liftIO $ sortedRecords !! 0+ `shouldSatisfy`+ (\case MyModifiedRecord+ { myModifiedName = "Rebecca"+ , myModifiedAge = Just 10+ , myModifiedUser = Entity _ User { userAddress = Nothing+ , userName = "Rebecca"+ }+ , myModifiedAddress = Nothing+ } -> True+ _ -> False)+ liftIO $ sortedRecords !! 1+ `shouldSatisfy`+ (\case MyModifiedRecord+ { myModifiedName = "Some Guy"+ , myModifiedAge = Just 10+ , myModifiedUser = Entity _ User { userAddress = Just addr1+ , userName = "Some Guy"+ }+ , myModifiedAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})+ } -> addr1 == addr2 -- The keys should match.+ _ -> False)++ itDb "can left join on records" $ do+ setup+ records <- select $ do+ from+ ( table @User+ `leftJoin` myRecordQuery `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" record ?. #id)+ )+ let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records+ liftIO $ sortedRecords !! 0+ `shouldSatisfy`+ (\case (_ :& Just (MyRecord {myName = "Rebecca", myAddress = Nothing})) -> True+ _ -> False)+ liftIO $ sortedRecords !! 1+ `shouldSatisfy`+ (\case ( _ :& Just ( MyRecord { myName = "Some Guy"+ , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"}))+ }+ )) -> True+ _ -> False)++ itDb "can handle joins on records with Nothing" $ do+ setup+ records <- select $ do+ from+ ( table @User+ `leftJoin` myRecordQuery `on` (do \(user :& record) -> user ^. #address ==. getField @"myAddress" record ?. #id)+ )+ let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records+ liftIO $ sortedRecords !! 0+ `shouldSatisfy`+ (\case (_ :& Nothing) -> True+ _ -> False)+ liftIO $ sortedRecords !! 1+ `shouldSatisfy`+ (\case ( _ :& Just ( MyRecord { myName = "Some Guy"+ , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"}))+ }+ )) -> True+ _ -> False)++ itDb "can left join on nested records" $ do+ setup+ records <- select $ do+ from+ ( table @User+ `leftJoin` myNestedRecordQuery+ `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" (getField @"myRecord" record) ?. #id)+ )+ let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records+ liftIO $ sortedRecords !! 0+ `shouldSatisfy`+ (\case (_ :& Just (MyNestedRecord {myRecord = MyRecord {myName = "Rebecca", myAddress = Nothing}})) -> True+ _ -> False)+ liftIO $ sortedRecords !! 1+ `shouldSatisfy`+ (\case ( _ :& Just ( MyNestedRecord { myRecord = MyRecord { myName = "Some Guy"+ , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"}))+ }+ })) -> True+ _ -> False)++ itDb "can handle multiple left joins on the same record" $ do+ setup+ records <- select $ do+ from+ ( table @User+ `leftJoin` myNestedRecordQuery+ `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" (getField @"myRecord" record) ?. #id)+ `leftJoin` myNestedRecordQuery+ `on` (do \(user :& record1 :& record2) -> getField @"myUser" (getField @"myRecord" record1) ?. #id !=. getField @"myUser" (getField @"myRecord" record2) ?. #id)+ )+ let sortedRecords = sortOn (\(Entity _ user :& _ :& _) -> getField @"userName" user) records+ liftIO $ sortedRecords !! 0+ `shouldSatisfy`+ (\case ( _ :& _ :& Just ( MyNestedRecord { myRecord = MyRecord { myName = "Some Guy"+ , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"}))+ }+ })) -> True+ _ -> False)+ liftIO $ sortedRecords !! 1+ `shouldSatisfy`+ (\case (_ :& _ :& Just (MyNestedRecord {myRecord = MyRecord {myName = "Rebecca", myAddress = Nothing}})) -> True+ _ -> False)
test/Common/Test.hs view
@@ -1,2657 +1,2557 @@-{-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# OPTIONS_GHC -fno-warn-deprecations #-}-{-# LANGUAGE ConstraintKinds- , CPP, DerivingStrategies, StandaloneDeriving- , TypeApplications- , PartialTypeSignatures- , UndecidableInstances- , EmptyDataDecls- , FlexibleContexts- , FlexibleInstances- , DeriveGeneric- , GADTs- , GeneralizedNewtypeDeriving- , MultiParamTypeClasses- , OverloadedStrings- , QuasiQuotes- , Rank2Types- , TemplateHaskell- , TypeFamilies- , ScopedTypeVariables- , TypeSynonymInstances- #-}--module Common.Test- ( tests- , testLocking- , testAscRandom- , testRandomMath- , migrateAll- , migrateUnique- , cleanDB- , cleanUniques- , RunDbMonad- , Run- , p1, p2, p3, p4, p5- , l1, l2, l3- , u1, u2, u3, u4- , insert'- , EntityField (..)- , Foo (..)- , Bar (..)- , Person (..)- , BlogPost (..)- , Lord (..)- , Deed (..)- , Follow (..)- , CcList (..)- , Frontcover (..)- , Article (..)- , Tag (..)- , ArticleTag (..)- , Article2 (..)- , Point (..)- , Circle (..)- , Numbers (..)- , OneUnique(..)- , Unique(..)- , DateTruncTest(..)- , DateTruncTestId- , Key(..)- ) where--import Data.Either-import Data.Time-import Control.Monad (forM_, replicateM, replicateM_, void)-import Control.Monad.Reader (ask)-import Control.Monad.Catch (MonadCatch)-#if __GLASGOW_HASKELL__ >= 806-import Control.Monad.Fail (MonadFail)-#endif-import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.Logger (MonadLogger (..), NoLoggingT, runNoLoggingT)-import Control.Monad.Trans.Reader (ReaderT)-import Data.Char (toLower, toUpper)-import Data.Monoid ((<>))-import Database.Esqueleto-import Database.Esqueleto.Experimental hiding (from, on)-import qualified Database.Esqueleto.Experimental as Experimental-import Database.Persist.TH-import Test.Hspec-import UnliftIO-import qualified Data.Attoparsec.Text as AP--import Data.Conduit (ConduitT, (.|), runConduit)-import qualified Data.Conduit.List as CL-import qualified Data.List as L-import qualified Data.Set as S-import qualified Data.Text as Text-import qualified Data.Text.Lazy.Builder as TLB-import qualified Data.Text.Internal.Lazy as TL-import qualified Database.Esqueleto.Internal.Sql as EI-import qualified UnliftIO.Resource as R-import qualified Database.Esqueleto.Internal.ExprParser as P---- Test schema-share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|- Foo- name Int- Primary name- deriving Show Eq Ord- Bar- quux FooId- deriving Show Eq Ord- Baz- blargh FooId- deriving Show Eq- Shoop- baz BazId- deriving Show Eq- Asdf- shoop ShoopId- deriving Show Eq- Another- why BazId- YetAnother- argh ShoopId-- Person- name String- age Int Maybe- weight Int Maybe- favNum Int- deriving Eq Show Ord- BlogPost- title String- authorId PersonId- deriving Eq Show- Comment- body String- blog BlogPostId- deriving Eq Show- CommentReply- body String- comment CommentId- Profile- name String- person PersonId- deriving Eq Show- Reply- guy PersonId- body String- deriving Eq Show-- Lord- county String maxlen=100- dogs Int Maybe- Primary county- deriving Eq Show-- Deed- contract String maxlen=100- ownerId LordId maxlen=100- Primary contract- deriving Eq Show-- Follow- follower PersonId- followed PersonId- deriving Eq Show-- CcList- names [String]-- Frontcover- number Int- title String- Primary number- deriving Eq Show- Article- title String- frontcoverNumber Int- Foreign Frontcover fkfrontcover frontcoverNumber- deriving Eq Show- ArticleMetadata- articleId ArticleId- Primary articleId- deriving Eq Show- Tag- name String maxlen=100- Primary name- deriving Eq Show- ArticleTag- articleId ArticleId- tagId TagId maxlen=100- Primary articleId tagId- deriving Eq Show- Article2- title String- frontcoverId FrontcoverId- deriving Eq Show- Point- x Int- y Int- name String- Primary x y- deriving Eq Show- Circle- centerX Int- centerY Int- name String- Foreign Point fkpoint centerX centerY- deriving Eq Show- Numbers- int Int- double Double- deriving Eq Show-- JoinOne- name String- deriving Eq Show-- JoinTwo- joinOne JoinOneId- name String- deriving Eq Show-- JoinThree- joinTwo JoinTwoId- name String- deriving Eq Show-- JoinFour- name String- joinThree JoinThreeId- deriving Eq Show-- JoinOther- name String- deriving Eq Show-- JoinMany- name String- joinOther JoinOtherId- joinOne JoinOneId- deriving Eq Show-- DateTruncTest- created UTCTime- deriving Eq Show-|]---- Unique Test schema-share [mkPersist sqlSettings, mkMigrate "migrateUnique"] [persistUpperCase|- OneUnique- name String- value Int- UniqueValue value- deriving Eq Show-|]---instance ToBaseId ArticleMetadata where- type BaseEnt ArticleMetadata = Article- toBaseIdWitness articleId = ArticleMetadataKey articleId---- | this could be achieved with S.fromList, but not all lists--- have Ord instances-sameElementsAs :: Eq a => [a] -> [a] -> Bool-sameElementsAs l1' l2' = null (l1' L.\\ l2')---- | Helper for rounding to a specific digit--- Prelude> map (flip roundTo 12.3456) [0..5]--- [12.0, 12.3, 12.35, 12.346, 12.3456, 12.3456]-roundTo :: (Fractional a, RealFrac a1, Integral b) => b -> a1 -> a-roundTo n f =- (fromInteger $ round $ f * (10^n)) / (10.0^^n)--p1 :: Person-p1 = Person "John" (Just 36) Nothing 1--p2 :: Person-p2 = Person "Rachel" Nothing (Just 37) 2--p3 :: Person-p3 = Person "Mike" (Just 17) Nothing 3--p4 :: Person-p4 = Person "Livia" (Just 17) (Just 18) 4--p5 :: Person-p5 = Person "Mitch" Nothing Nothing 5--l1 :: Lord-l1 = Lord "Cornwall" (Just 36)--l2 :: Lord-l2 = Lord "Dorset" Nothing--l3 :: Lord-l3 = Lord "Chester" (Just 17)--u1 :: OneUnique-u1 = OneUnique "First" 0--u2 :: OneUnique-u2 = OneUnique "Second" 1--u3 :: OneUnique-u3 = OneUnique "Third" 0--u4 :: OneUnique-u4 = OneUnique "First" 2--testSelect :: Run -> Spec-testSelect run = do- describe "select" $ do- it "works for a single value" $- run $ do- ret <- select $ return $ val (3 :: Int)- liftIO $ ret `shouldBe` [ Value 3 ]-- it "works for a pair of a single value and ()" $- run $ do- ret <- select $ return (val (3 :: Int), ())- liftIO $ ret `shouldBe` [ (Value 3, ()) ]-- it "works for a single ()" $- run $ do- ret <- select $ return ()- liftIO $ ret `shouldBe` [ () ]-- it "works for a single NULL value" $- run $ do- ret <- select $ return nothing- liftIO $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ]--testSubSelect :: Run -> Spec-testSubSelect run = do- let- setup :: MonadIO m => SqlPersistT m ()- setup = do- _ <- insert $ Numbers 1 2- _ <- insert $ Numbers 2 4- _ <- insert $ Numbers 3 5- _ <- insert $ Numbers 6 7- pure ()- describe "subSelect" $ do- it "is safe for queries that may return multiple results" $ do- let- query =- from $ \n -> do- orderBy [asc (n ^. NumbersInt)]- pure (n ^. NumbersInt)- res <- run $ do- setup- select $ pure $ subSelect query- res `shouldBe` [Value (Just 1)]-- eres <- try $ run $ do- setup- select $ pure $ sub_select query- case eres of- Left (SomeException _) ->- -- We should receive an exception, but the different database- -- libraries throw different exceptions. Hooray.- pure ()- Right v ->- -- This shouldn't happen, but in sqlite land, many things are- -- possible.- v `shouldBe` [Value 1]-- it "is safe for queries that may not return anything" $ do- let- query =- from $ \n -> do- orderBy [asc (n ^. NumbersInt)]- limit 1- pure (n ^. NumbersInt)- res <- run $ select $ pure $ subSelect query- res `shouldBe` [Value Nothing]-- eres <- try $ run $ do- setup- select $ pure $ sub_select query-- case eres of- Left (_ :: PersistException) ->- -- We expect to receive this exception. However, sqlite evidently has- -- no problems with it, so we can't *require* that the exception is- -- thrown. Sigh.- pure ()- Right v ->- -- This shouldn't happen, but in sqlite land, many things are- -- possible.- v `shouldBe` [Value 1]-- describe "subSelectList" $ do- it "is safe on empty databases as well as good databases" $ do- let- query =- from $ \n -> do- where_ $ n ^. NumbersInt `in_` do- subSelectList $- from $ \n' -> do- where_ $ n' ^. NumbersInt >=. val 3- pure (n' ^. NumbersInt)- pure n-- empty <- run $ do- select query-- full <- run $ do- setup- select query-- empty `shouldBe` []- full `shouldSatisfy` (not . null)-- describe "subSelectMaybe" $ do- it "is equivalent to joinV . subSelect" $ do- let- query- :: ( SqlQuery (SqlExpr (Value (Maybe Int)))- -> SqlExpr (Value (Maybe Int))- )- -> SqlQuery (SqlExpr (Value (Maybe Int)))- query selector =- from $ \n -> do- pure $- selector $- from $ \n' -> do- where_ $ n' ^. NumbersDouble >=. n ^. NumbersDouble- pure (max_ (n' ^. NumbersInt))-- a <- run $ do- setup- select (query subSelectMaybe)- b <- run $ do- setup- select (query (joinV . subSelect))- a `shouldBe` b-- describe "subSelectCount" $ do- it "is a safe way to do a countRows" $ do- xs0 <- run $ do- setup- select $- from $ \n -> do- pure $ (,) n $- subSelectCount @Int $- from $ \n' -> do- where_ $ n' ^. NumbersInt >=. n ^. NumbersInt-- xs1 <- run $ do- setup- select $- from $ \n -> do- pure $ (,) n $- subSelectUnsafe $- from $ \n' -> do- where_ $ n' ^. NumbersInt >=. n ^. NumbersInt- pure (countRows :: SqlExpr (Value Int))-- let getter (Entity _ a, b) = (a, b)- map getter xs0 `shouldBe` map getter xs1-- describe "subSelectUnsafe" $ do- it "throws exceptions on multiple results" $ do- eres <- try $ run $ do- setup- bad <- select $- from $ \n -> do- pure $ (,) (n ^. NumbersInt) $- subSelectUnsafe $- from $ \n' -> do- pure (just (n' ^. NumbersDouble))- good <- select $- from $ \n -> do- pure $ (,) (n ^. NumbersInt) $- subSelect $- from $ \n' -> do- pure (n' ^. NumbersDouble)- pure (bad, good)- case eres of- Left (SomeException _) ->- -- Must use SomeException because the database libraries throw their- -- own errors.- pure ()- Right (bad, good) -> do- -- SQLite just takes the first element of the sub-select. lol.- --- bad `shouldBe` good-- it "throws exceptions on null results" $ do- eres <- try $ run $ do- setup- select $- from $ \n -> do- pure $ (,) (n ^. NumbersInt) $- subSelectUnsafe $- from $ \n' -> do- where_ $ val False- pure (n' ^. NumbersDouble)- case eres of- Left (_ :: PersistException) ->- pure ()- Right xs ->- xs `shouldBe` []---testSelectSource :: Run -> Spec-testSelectSource run = do- describe "selectSource" $ do- it "works for a simple example" $- run $ do- let query = selectSource $- from $ \person ->- return person- p1e <- insert' p1- ret <- runConduit $ query .| CL.consume- liftIO $ ret `shouldBe` [ p1e ]-- it "can run a query many times" $- run $ do- let query = selectSource $- from $ \person ->- return person- p1e <- insert' p1- ret0 <- runConduit $ query .| CL.consume- ret1 <- runConduit $ query .| CL.consume- liftIO $ ret0 `shouldBe` [ p1e ]- liftIO $ ret1 `shouldBe` [ p1e ]-- it "works on repro" $ do- let selectPerson :: R.MonadResource m => String -> ConduitT () (Key Person) (SqlPersistT m) ()- selectPerson name = do- let source = selectSource $ from $ \person -> do- where_ $ person ^. PersonName ==. val name- return $ person ^. PersonId- source .| CL.map unValue- run $ do- p1e <- insert' p1- p2e <- insert' p2- r1 <- runConduit $- selectPerson (personName p1) .| CL.consume- r2 <- runConduit $- selectPerson (personName p2) .| CL.consume- liftIO $ do- r1 `shouldBe` [ entityKey p1e ]- r2 `shouldBe` [ entityKey p2e ]----testSelectFrom :: Run -> Spec-testSelectFrom run = do- describe "select/from" $ do- it "works for a simple example" $- run $ do- p1e <- insert' p1- ret <- select $- from $ \person ->- return person- liftIO $ ret `shouldBe` [ p1e ]-- it "works for a simple self-join (one entity)" $- run $ do- p1e <- insert' p1- ret <- select $- from $ \(person1, person2) ->- return (person1, person2)- liftIO $ ret `shouldBe` [ (p1e, p1e) ]-- it "works for a simple self-join (two entities)" $- run $ do- p1e <- insert' p1- p2e <- insert' p2- ret <- select $- from $ \(person1, person2) ->- return (person1, person2)- liftIO $ ret `shouldSatisfy` sameElementsAs [ (p1e, p1e)- , (p1e, p2e)- , (p2e, p1e)- , (p2e, p2e) ]--- it "works for a self-join via sub_select" $- run $ do- p1k <- insert p1- p2k <- insert p2- _f1k <- insert (Follow p1k p2k)- _f2k <- insert (Follow p2k p1k)- ret <- select $- from $ \followA -> do- let subquery =- from $ \followB -> do- where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed- return $ followB ^. FollowFollower- where_ $ followA ^. FollowFollowed ==. sub_select subquery- return followA- liftIO $ length ret `shouldBe` 2-- it "works for a self-join via exists" $- run $ do- p1k <- insert p1- p2k <- insert p2- _f1k <- insert (Follow p1k p2k)- _f2k <- insert (Follow p2k p1k)- ret <- select $- from $ \followA -> do- where_ $ exists $- from $ \followB ->- where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed- return followA- liftIO $ length ret `shouldBe` 2--- it "works for a simple projection" $- run $ do- p1k <- insert p1- p2k <- insert p2- ret <- select $- from $ \p ->- return (p ^. PersonId, p ^. PersonName)- liftIO $ ret `shouldBe` [ (Value p1k, Value (personName p1))- , (Value p2k, Value (personName p2)) ]-- it "works for a simple projection with a simple implicit self-join" $- run $ do- _ <- insert p1- _ <- insert p2- ret <- select $- from $ \(pa, pb) ->- return (pa ^. PersonName, pb ^. PersonName)- liftIO $ ret `shouldSatisfy` sameElementsAs- [ (Value (personName p1), Value (personName p1))- , (Value (personName p1), Value (personName p2))- , (Value (personName p2), Value (personName p1))- , (Value (personName p2), Value (personName p2)) ]-- it "works with many kinds of LIMITs and OFFSETs" $- run $ do- [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]- let people = from $ \p -> do- orderBy [asc (p ^. PersonName)]- return p- ret1 <- select $ do- p <- people- limit 2- limit 1- return p- liftIO $ ret1 `shouldBe` [ p1e ]- ret2 <- select $ do- p <- people- limit 1- limit 2- return p- liftIO $ ret2 `shouldBe` [ p1e, p4e ]- ret3 <- select $ do- p <- people- offset 3- offset 2- return p- liftIO $ ret3 `shouldBe` [ p3e, p2e ]- ret4 <- select $ do- p <- people- offset 3- limit 5- offset 2- limit 3- offset 1- limit 2- return p- liftIO $ ret4 `shouldBe` [ p4e, p3e ]- ret5 <- select $ do- p <- people- offset 1000- limit 1- limit 1000- offset 0- return p- liftIO $ ret5 `shouldBe` [ p1e, p4e, p3e, p2e ]-- it "works with non-id primary key" $- run $ do- let fc = Frontcover number ""- number = 101- Right thePk = keyFromValues [toPersistValue number]- fcPk <- insert fc- [Entity _ ret] <- select $ from return- liftIO $ do- ret `shouldBe` fc- fcPk `shouldBe` thePk-- it "works when returning a custom non-composite primary key from a query" $- run $ do- let name = "foo"- t = Tag name- Right thePk = keyFromValues [toPersistValue name]- tagPk <- insert t- [Value ret] <- select $ from $ \t' -> return (t'^.TagId)- liftIO $ do- ret `shouldBe` thePk- thePk `shouldBe` tagPk-- it "works when returning a composite primary key from a query" $- run $ do- let p = Point 10 20 ""- thePk <- insert p- [Value ppk] <- select $ from $ \p' -> return (p'^.PointId)- liftIO $ ppk `shouldBe` thePk----testSelectJoin :: Run -> Spec-testSelectJoin run = do- describe "select:JOIN" $ do- it "works with a LEFT OUTER JOIN" $- run $ do- p1e <- insert' p1- p2e <- insert' p2- p3e <- insert' p3- p4e <- insert' p4- b12e <- insert' $ BlogPost "b" (entityKey p1e)- b11e <- insert' $ BlogPost "a" (entityKey p1e)- b31e <- insert' $ BlogPost "c" (entityKey p3e)- ret <- select $- from $ \(p `LeftOuterJoin` mb) -> do- on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)- orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ]- return (p, mb)- liftIO $ ret `shouldBe` [ (p1e, Just b11e)- , (p1e, Just b12e)- , (p4e, Nothing)- , (p3e, Just b31e)- , (p2e, Nothing) ]-- it "typechecks (A LEFT OUTER JOIN (B LEFT OUTER JOIN C))" $- let _ = run $- select $- from $ \(a `LeftOuterJoin` (b `LeftOuterJoin` c)) ->- let _ = [a, b, c] :: [ SqlExpr (Entity Person) ]- in return a- in return () :: IO ()-- it "typechecks ((A LEFT OUTER JOIN B) LEFT OUTER JOIN C)" $- let _ = run $- select $- from $ \((a `LeftOuterJoin` b) `LeftOuterJoin` c) ->- let _ = [a, b, c] :: [ SqlExpr (Entity Person) ]- in return a- in return () :: IO ()-- it "throws an error for using on without joins" $- run (select $- from $ \(p, mb) -> do- on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)- orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ]- return (p, mb)- ) `shouldThrow` (\(OnClauseWithoutMatchingJoinException _) -> True)-- it "throws an error for using too many ons" $- run (select $- from $ \(p `FullOuterJoin` mb) -> do- on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)- on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)- orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ]- return (p, mb)- ) `shouldThrow` (\(OnClauseWithoutMatchingJoinException _) -> True)-- it "works with ForeignKey to a non-id primary key returning one entity" $- run $ do- let fc = Frontcover number ""- article = Article "Esqueleto supports composite pks!" number- number = 101- Right thePk = keyFromValues [toPersistValue number]- fcPk <- insert fc- insert_ article- [Entity _ retFc] <- select $- from $ \(a `InnerJoin` f) -> do- on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber)- return f- liftIO $ do- retFc `shouldBe` fc- fcPk `shouldBe` thePk- it "allows using a primary key that is itself a key of another table" $- run $ do- let number = 101- insert_ $ Frontcover number ""- articleId <- insert $ Article "title" number- articleMetaE <- insert' (ArticleMetadata articleId)- result <- select . from $ \articleMetadata -> do- where_ $ (articleMetadata ^. ArticleMetadataId) ==. (val ((ArticleMetadataKey articleId)))- pure articleMetadata- liftIO $ [articleMetaE] `shouldBe` result- it "allows joining between a primary key that is itself a key of another table, using ToBaseId" $ do- run $ do- let number = 101- insert_ $ Frontcover number ""- articleE@(Entity articleId _) <- insert' $ Article "title" number- articleMetaE <- insert' (ArticleMetadata articleId)-- articlesAndMetadata <- select $- from $ \(article `InnerJoin` articleMetadata) -> do- on (toBaseId (articleMetadata ^. ArticleMetadataId) ==. article ^. ArticleId)- return (article, articleMetadata)- liftIO $ [(articleE, articleMetaE)] `shouldBe` articlesAndMetadata-- it "works with a ForeignKey to a non-id primary key returning both entities" $- run $ do- let fc = Frontcover number ""- article = Article "Esqueleto supports composite pks!" number- number = 101- Right thePk = keyFromValues [toPersistValue number]- fcPk <- insert fc- insert_ article- [(Entity _ retFc, Entity _ retArt)] <- select $- from $ \(a `InnerJoin` f) -> do- on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber)- return (f, a)- liftIO $ do- retFc `shouldBe` fc- retArt `shouldBe` article- fcPk `shouldBe` thePk- articleFkfrontcover retArt `shouldBe` thePk-- it "works with a non-id primary key returning one entity" $- run $ do- let fc = Frontcover number ""- article = Article2 "Esqueleto supports composite pks!" thePk- number = 101- Right thePk = keyFromValues [toPersistValue number]- fcPk <- insert fc- insert_ article- [Entity _ retFc] <- select $- from $ \(a `InnerJoin` f) -> do- on (f^.FrontcoverId ==. a^.Article2FrontcoverId)- return f- liftIO $ do- retFc `shouldBe` fc- fcPk `shouldBe` thePk-- it "works with a composite primary key" $- pendingWith "Persistent does not create the CircleFkPoint constructor. See: https://github.com/yesodweb/persistent/issues/341"- {-- run $ do- let p = Point x y ""- c = Circle x y ""- x = 10- y = 15- Right thePk = keyFromValues [toPersistValue x, toPersistValue y]- pPk <- insert p- insert_ c- [Entity _ ret] <- select $ from $ \(c' `InnerJoin` p') -> do- on (p'^.PointId ==. c'^.CircleFkpoint)- return p'- liftIO $ do- ret `shouldBe` p- pPk `shouldBe` thePk- -}-- it "works when joining via a non-id primary key" $- run $ do- let fc = Frontcover number ""- article = Article "Esqueleto supports composite pks!" number- tag = Tag "foo"- otherTag = Tag "ignored"- number = 101- insert_ fc- insert_ otherTag- artId <- insert article- tagId <- insert tag- insert_ $ ArticleTag artId tagId- [(Entity _ retArt, Entity _ retTag)] <- select $- from $ \(a `InnerJoin` at `InnerJoin` t) -> do- on (t^.TagId ==. at^.ArticleTagTagId)- on (a^.ArticleId ==. at^.ArticleTagArticleId)- return (a, t)- liftIO $ do- retArt `shouldBe` article- retTag `shouldBe` tag-- it "respects the associativity of joins" $- run $ do- void $ insert p1- ps <- select . from $- \((p :: SqlExpr (Entity Person))- `LeftOuterJoin`- ((_q :: SqlExpr (Entity Person))- `InnerJoin` (_r :: SqlExpr (Entity Person)))) -> do- on (val False) -- Inner join is empty- on (val True)- return p- liftIO $ (entityVal <$> ps) `shouldBe` [p1]--testSelectSubQuery :: Run -> Spec-testSelectSubQuery run = do- describe "select subquery" $ do- it "works" $ do- run $ do- _ <- insert' p1- let q = do- p <- Experimental.from $ Table @Person- return ( p ^. PersonName, p ^. PersonAge)- ret <- select $ Experimental.from $ SelectQuery q- liftIO $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ]-- it "supports sub-selecting Maybe entities" $ do- run $ do- l1e <- insert' l1- l3e <- insert' l3- l1Deeds <- mapM (\k -> insert' $ Deed k (entityKey l1e)) (map show [1..3 :: Int])- let l1WithDeeds = do d <- l1Deeds- pure (l1e, Just d)- ret <- select $ Experimental.from $ SelectQuery $ do- (lords :& deeds) <-- Experimental.from $ Table @Lord- `LeftOuterJoin` Table @Deed- `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)- pure (lords, deeds)- liftIO $ ret `shouldMatchList` ((l3e, Nothing) : l1WithDeeds)-- it "lets you order by alias" $ do- run $ do- _ <- insert' p1- _ <- insert' p3- let q = do- (name, age) <-- Experimental.from $ SubQuery $ do- p <- Experimental.from $ Table @Person- return ( p ^. PersonName, p ^. PersonAge)- orderBy [ asc age ]- pure name- ret <- select q- liftIO $ ret `shouldBe` [ Value $ personName p3, Value $ personName p1 ]-- it "supports groupBy" $ do- run $ do- l1k <- insert l1- l3k <- insert l3- mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])-- mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])- let q = do- (lord :& deed) <- Experimental.from $ Table @Lord- `InnerJoin` Table @Deed- `Experimental.on` (\(lord :& deed) ->- lord ^. LordId ==. deed ^. DeedOwnerId)- return (lord ^. LordId, deed ^. DeedId)- q' = do- (lordId, deedId) <- Experimental.from $ SubQuery q- groupBy (lordId)- return (lordId, count deedId)- (ret :: [(Value (Key Lord), Value Int)]) <- select q'-- liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7)- , (Value l1k, Value 3) ]-- it "Can count results of aggregate query" $ do- run $ do- l1k <- insert l1- l3k <- insert l3- mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])-- mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])- let q = do- (lord :& deed) <- Experimental.from $ Table @Lord- `InnerJoin` Table @Deed- `Experimental.on` (\(lord :& deed) ->- lord ^. LordId ==. deed ^. DeedOwnerId)- groupBy (lord ^. LordId)- return (lord ^. LordId, count (deed ^. DeedId))-- (ret :: [(Value Int)]) <- select $ do- (lordId, deedCount) <- Experimental.from $ SubQuery q- where_ $ deedCount >. val (3 :: Int)- return (count lordId)-- liftIO $ ret `shouldMatchList` [ (Value 1) ]-- it "joins on subqueries" $ do- run $ do- l1k <- insert l1- l3k <- insert l3- mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])-- mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])- let q = do- (lord :& deed) <- Experimental.from $ Table @Lord- `InnerJoin` (SelectQuery $ Experimental.from $ Table @Deed)- `Experimental.on` (\(lord :& deed) ->- lord ^. LordId ==. deed ^. DeedOwnerId)- groupBy (lord ^. LordId)- return (lord ^. LordId, count (deed ^. DeedId))- (ret :: [(Value (Key Lord), Value Int)]) <- select q- liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7)- , (Value l1k, Value 3) ]-- it "flattens maybe values" $ do- run $ do- l1k <- insert l1- l3k <- insert l3- let q = do- (lord :& (_, dogCounts)) <- Experimental.from $ Table @Lord- `LeftOuterJoin` (SelectQuery $ do- lord <- Experimental.from $ Table @Lord- pure (lord ^. LordId, lord ^. LordDogs)- )- `Experimental.on` (\(lord :& (lordId, _)) ->- just (lord ^. LordId) ==. lordId)- groupBy (lord ^. LordId, dogCounts)- return (lord ^. LordId, dogCounts)- (ret :: [(Value (Key Lord), Value (Maybe Int))]) <- select q- liftIO $ ret `shouldMatchList` [ (Value l3k, Value (lordDogs l3))- , (Value l1k, Value (lordDogs l1)) ]- it "unions" $ do- run $ do- _ <- insert p1- _ <- insert p2- let q = Experimental.from $- (SelectQuery $ do- p <- Experimental.from $ Table @Person- where_ $ not_ $ isNothing $ p ^. PersonAge- return (p ^. PersonName))- `Union`- (SelectQuery $ do- p <- Experimental.from $ Table @Person- where_ $ isNothing $ p ^. PersonAge- return (p ^. PersonName))- `Union`- (SelectQuery $ do- p <- Experimental.from $ Table @Person- where_ $ isNothing $ p ^. PersonAge- return (p ^. PersonName))- names <- select q- liftIO $ names `shouldMatchList` [ (Value $ personName p1)- , (Value $ personName p2) ]-testSelectWhere :: Run -> Spec-testSelectWhere run = do- describe "select where_" $ do- it "works for a simple example with (==.)" $- run $ do- p1e <- insert' p1- _ <- insert' p2- _ <- insert' p3- ret <- select $- from $ \p -> do- where_ (p ^. PersonName ==. val "John")- return p- liftIO $ ret `shouldBe` [ p1e ]-- it "works for a simple example with (==.) and (||.)" $- run $ do- p1e <- insert' p1- p2e <- insert' p2- _ <- insert' p3- ret <- select $- from $ \p -> do- where_ (p ^. PersonName ==. val "John" ||. p ^. PersonName ==. val "Rachel")- return p- liftIO $ ret `shouldBe` [ p1e, p2e ]-- it "works for a simple example with (>.) [uses val . Just]" $- run $ do- p1e <- insert' p1- _ <- insert' p2- _ <- insert' p3- ret <- select $- from $ \p -> do- where_ (p ^. PersonAge >. val (Just 17))- return p- liftIO $ ret `shouldBe` [ p1e ]-- it "works for a simple example with (>.) and not_ [uses just . val]" $- run $ do- _ <- insert' p1- _ <- insert' p2- p3e <- insert' p3- ret <- select $- from $ \p -> do- where_ (not_ $ p ^. PersonAge >. just (val 17))- return p- liftIO $ ret `shouldBe` [ p3e ]-- describe "when using between" $ do- it "works for a simple example with [uses just . val]" $- run $ do- p1e <- insert' p1- _ <- insert' p2- _ <- insert' p3- ret <- select $- from $ \p -> do- where_ ((p ^. PersonAge) `between` (just $ val 20, just $ val 40))- return p- liftIO $ ret `shouldBe` [ p1e ]- it "works for a proyected fields value" $- run $ do- _ <- insert' p1 >> insert' p2 >> insert' p3- ret <-- select $- from $ \p -> do- where_ $- just (p ^. PersonFavNum)- `between`- (p ^. PersonAge, p ^. PersonWeight)- liftIO $ ret `shouldBe` []- describe "when projecting composite keys" $ do- it "works when using composite keys with val" $- run $ do- insert_ $ Point 1 2 ""- ret <-- select $- from $ \p -> do- where_ $- p ^. PointId- `between`- ( val $ PointKey 1 2- , val $ PointKey 5 6 )- liftIO $ ret `shouldBe` [()]- it "works when using ECompositeKey constructor" $- run $ do- insert_ $ Point 1 2 ""- ret <-- select $- from $ \p -> do- where_ $- p ^. PointId- `between`- ( EI.ECompositeKey $ const ["3", "4"]- , EI.ECompositeKey $ const ["5", "6"] )- liftIO $ ret `shouldBe` []-- it "works with avg_" $- run $ do- _ <- insert' p1- _ <- insert' p2- _ <- insert' p3- _ <- insert' p4- ret <- select $- from $ \p->- return $ joinV $ avg_ (p ^. PersonAge)- let testV :: Double- testV = roundTo (4 :: Integer) $ (36 + 17 + 17) / (3 :: Double)-- retV :: [Value (Maybe Double)]- retV = map (Value . fmap (roundTo (4 :: Integer)) . unValue) (ret :: [Value (Maybe Double)])- liftIO $ retV `shouldBe` [ Value $ Just testV ]-- it "works with min_" $- run $ do- _ <- insert' p1- _ <- insert' p2- _ <- insert' p3- _ <- insert' p4- ret <- select $- from $ \p->- return $ joinV $ min_ (p ^. PersonAge)- liftIO $ ret `shouldBe` [ Value $ Just (17 :: Int) ]-- it "works with max_" $- run $ do- _ <- insert' p1- _ <- insert' p2- _ <- insert' p3- _ <- insert' p4- ret <- select $- from $ \p->- return $ joinV $ max_ (p ^. PersonAge)- liftIO $ ret `shouldBe` [ Value $ Just (36 :: Int) ]-- it "works with lower_" $- run $ do- p1e <- insert' p1- p2e@(Entity _ bob) <- insert' $ Person "bob" (Just 36) Nothing 1-- -- lower(name) == 'john'- ret1 <- select $- from $ \p-> do- where_ (lower_ (p ^. PersonName) ==. val (map toLower $ personName p1))- return p- liftIO $ ret1 `shouldBe` [ p1e ]-- -- name == lower('BOB')- ret2 <- select $- from $ \p-> do- where_ (p ^. PersonName ==. lower_ (val $ map toUpper $ personName bob))- return p- liftIO $ ret2 `shouldBe` [ p2e ]-- it "works with round_" $- run $ do- ret <- select $ return $ round_ (val (16.2 :: Double))- liftIO $ ret `shouldBe` [ Value (16 :: Double) ]-- it "works with isNothing" $- run $ do- _ <- insert' p1- p2e <- insert' p2- _ <- insert' p3- ret <- select $- from $ \p -> do- where_ $ isNothing (p ^. PersonAge)- return p- liftIO $ ret `shouldBe` [ p2e ]-- it "works with not_ . isNothing" $- run $ do- p1e <- insert' p1- _ <- insert' p2- ret <- select $- from $ \p -> do- where_ $ not_ (isNothing (p ^. PersonAge))- return p- liftIO $ ret `shouldBe` [ p1e ]-- it "works for a many-to-many implicit join" $- run $ do- p1e@(Entity p1k _) <- insert' p1- p2e@(Entity p2k _) <- insert' p2- _ <- insert' p3- p4e@(Entity p4k _) <- insert' p4- f12 <- insert' (Follow p1k p2k)- f21 <- insert' (Follow p2k p1k)- f42 <- insert' (Follow p4k p2k)- f11 <- insert' (Follow p1k p1k)- ret <- select $- from $ \(follower, follows, followed) -> do- where_ $ follower ^. PersonId ==. follows ^. FollowFollower &&.- followed ^. PersonId ==. follows ^. FollowFollowed- orderBy [ asc (follower ^. PersonName)- , asc (followed ^. PersonName) ]- return (follower, follows, followed)- liftIO $ ret `shouldBe` [ (p1e, f11, p1e)- , (p1e, f12, p2e)- , (p4e, f42, p2e)- , (p2e, f21, p1e) ]-- it "works for a many-to-many explicit join" $- run $ do- p1e@(Entity p1k _) <- insert' p1- p2e@(Entity p2k _) <- insert' p2- _ <- insert' p3- p4e@(Entity p4k _) <- insert' p4- f12 <- insert' (Follow p1k p2k)- f21 <- insert' (Follow p2k p1k)- f42 <- insert' (Follow p4k p2k)- f11 <- insert' (Follow p1k p1k)- ret <- select $- from $ \(follower `InnerJoin` follows `InnerJoin` followed) -> do- on $ followed ^. PersonId ==. follows ^. FollowFollowed- on $ follower ^. PersonId ==. follows ^. FollowFollower- orderBy [ asc (follower ^. PersonName)- , asc (followed ^. PersonName) ]- return (follower, follows, followed)- liftIO $ ret `shouldBe` [ (p1e, f11, p1e)- , (p1e, f12, p2e)- , (p4e, f42, p2e)- , (p2e, f21, p1e) ]-- it "works for a many-to-many explicit join and on order doesn't matter" $ do- run $ void $- selectRethrowingQuery $- from $ \(person `InnerJoin` blog `InnerJoin` comment) -> do- on $ person ^. PersonId ==. blog ^. BlogPostAuthorId- on $ blog ^. BlogPostId ==. comment ^. CommentBlog- pure (person, comment)-- -- we only care that we don't have a SQL error- True `shouldBe` True-- it "works for a many-to-many explicit join with LEFT OUTER JOINs" $- run $ do- p1e@(Entity p1k _) <- insert' p1- p2e@(Entity p2k _) <- insert' p2- p3e <- insert' p3- p4e@(Entity p4k _) <- insert' p4- f12 <- insert' (Follow p1k p2k)- f21 <- insert' (Follow p2k p1k)- f42 <- insert' (Follow p4k p2k)- f11 <- insert' (Follow p1k p1k)- ret <- select $- from $ \(follower `LeftOuterJoin` mfollows `LeftOuterJoin` mfollowed) -> do- on $ mfollowed ?. PersonId ==. mfollows ?. FollowFollowed- on $ just (follower ^. PersonId) ==. mfollows ?. FollowFollower- orderBy [ asc ( follower ^. PersonName)- , asc (mfollowed ?. PersonName) ]- return (follower, mfollows, mfollowed)- liftIO $ ret `shouldBe` [ (p1e, Just f11, Just p1e)- , (p1e, Just f12, Just p2e)- , (p4e, Just f42, Just p2e)- , (p3e, Nothing, Nothing)- , (p2e, Just f21, Just p1e) ]-- it "works with a composite primary key" $- run $ do- let p = Point x y ""- x = 10- y = 15- Right thePk = keyFromValues [toPersistValue x, toPersistValue y]- pPk <- insert p- [Entity _ ret] <- select $ from $ \p' -> do- where_ (p'^.PointId ==. val pPk)- return p'- liftIO $ do- ret `shouldBe` p- pPk `shouldBe` thePk----testSelectOrderBy :: Run -> Spec-testSelectOrderBy run = do- describe "select/orderBy" $ do- it "works with a single ASC field" $- run $ do- p1e <- insert' p1- p2e <- insert' p2- p3e <- insert' p3- ret <- select $- from $ \p -> do- orderBy [asc $ p ^. PersonName]- return p- liftIO $ ret `shouldBe` [ p1e, p3e, p2e ]-- it "works with a sub_select" $- run $ do- [p1k, p2k, p3k, p4k] <- mapM insert [p1, p2, p3, p4]- [b1k, b2k, b3k, b4k] <- mapM (insert . BlogPost "") [p1k, p2k, p3k, p4k]- ret <- select $- from $ \b -> do- orderBy [desc $ sub_select $- from $ \p -> do- where_ (p ^. PersonId ==. b ^. BlogPostAuthorId)- return (p ^. PersonName)- ]- return (b ^. BlogPostId)- liftIO $ ret `shouldBe` (Value <$> [b2k, b3k, b4k, b1k])-- it "works on a composite primary key" $- run $ do- let ps = [Point 2 1 "", Point 1 2 ""]- mapM_ insert ps- eps <- select $- from $ \p' -> do- orderBy [asc (p'^.PointId)]- return p'- liftIO $ map entityVal eps `shouldBe` reverse ps--testAscRandom :: SqlExpr (Value Double) -> Run -> Spec-testAscRandom rand' run =- describe "random_" $- it "asc random_ works" $- run $ do- _p1e <- insert' p1- _p2e <- insert' p2- _p3e <- insert' p3- _p4e <- insert' p4- rets <-- fmap S.fromList $- replicateM 11 $- select $- from $ \p -> do- orderBy [asc (rand' :: SqlExpr (Value Double))]- return (p ^. PersonId :: SqlExpr (Value PersonId))- -- There are 2^4 = 16 possible orderings. The chance- -- of 11 random samplings returning the same ordering- -- is 1/2^40, so this test should pass almost everytime.- liftIO $ S.size rets `shouldSatisfy` (>2)--testSelectDistinct :: Run -> Spec-testSelectDistinct run = do- describe "SELECT DISTINCT" $ do- let selDistTest- :: ( forall m. RunDbMonad m- => SqlQuery (SqlExpr (Value String))- -> SqlPersistT (R.ResourceT m) [Value String])- -> IO ()- selDistTest q = run $ do- p1k <- insert p1- let (t1, t2, t3) = ("a", "b", "c")- mapM_ (insert . flip BlogPost p1k) [t1, t3, t2, t2, t1]- ret <- q $- from $ \b -> do- let title = b ^. BlogPostTitle- orderBy [asc title]- return title- liftIO $ ret `shouldBe` [ Value t1, Value t2, Value t3 ]-- it "works on a simple example (select . distinct)" $- selDistTest (select . distinct)-- it "works on a simple example (distinct (return ()))" $- selDistTest (\act -> select $ distinct (return ()) >> act)----testCoasleceDefault :: Run -> Spec-testCoasleceDefault run = do- describe "coalesce/coalesceDefault" $ do- it "works on a simple example" $- run $ do- mapM_ insert' [p1, p2, p3, p4, p5]- ret1 <- select $- from $ \p -> do- orderBy [asc (p ^. PersonId)]- return (coalesce [p ^. PersonAge, p ^. PersonWeight])- liftIO $ ret1 `shouldBe` [ Value (Just (36 :: Int))- , Value (Just 37)- , Value (Just 17)- , Value (Just 17)- , Value Nothing- ]-- ret2 <- select $- from $ \p -> do- orderBy [asc (p ^. PersonId)]- return (coalesceDefault [p ^. PersonAge, p ^. PersonWeight] (p ^. PersonFavNum))- liftIO $ ret2 `shouldBe` [ Value (36 :: Int)- , Value 37- , Value 17- , Value 17- , Value 5- ]-- it "works with sub-queries" $- run $ do- p1id <- insert p1- p2id <- insert p2- p3id <- insert p3- _ <- insert p4- _ <- insert p5- _ <- insert $ BlogPost "a" p1id- _ <- insert $ BlogPost "b" p2id- _ <- insert $ BlogPost "c" p3id- ret <- select $- from $ \b -> do- let sub =- from $ \p -> do- where_ (p ^. PersonId ==. b ^. BlogPostAuthorId)- return $ p ^. PersonAge- return $ coalesceDefault [sub_select sub] (val (42 :: Int))- liftIO $ ret `shouldBe` [ Value (36 :: Int)- , Value 42- , Value 17- ]----testDelete :: Run -> Spec-testDelete run = do- describe "delete" $- it "works on a simple example" $- run $ do- p1e <- insert' p1- p2e <- insert' p2- p3e <- insert' p3- let getAll = select $- from $ \p -> do- orderBy [asc (p ^. PersonName)]- return p- ret1 <- getAll- liftIO $ ret1 `shouldBe` [ p1e, p3e, p2e ]- () <- delete $- from $ \p ->- where_ (p ^. PersonName ==. val (personName p1))- ret2 <- getAll- liftIO $ ret2 `shouldBe` [ p3e, p2e ]- n <- deleteCount $- from $ \p ->- return ((p :: SqlExpr (Entity Person)) `seq` ())- ret3 <- getAll- liftIO $ (n, ret3) `shouldBe` (2, [])----testUpdate :: Run -> Spec-testUpdate run = do- describe "update" $ do-- it "works with a subexpression having COUNT(*)" $- run $ do- p1k <- insert p1- p2k <- insert p2- p3k <- insert p3- replicateM_ 3 (insert $ BlogPost "" p1k)- replicateM_ 7 (insert $ BlogPost "" p3k)- let blogPostsBy p =- from $ \b -> do- where_ (b ^. BlogPostAuthorId ==. p ^. PersonId)- return countRows- () <- update $ \p -> do- set p [ PersonAge =. just (sub_select (blogPostsBy p)) ]- ret <- select $- from $ \p -> do- orderBy [ asc (p ^. PersonName) ]- return p- liftIO $ ret `shouldBe` [ Entity p1k p1 { personAge = Just 3 }- , Entity p3k p3 { personAge = Just 7 }- , Entity p2k p2 { personAge = Just 0 } ]-- it "works with a composite primary key" $- pendingWith "Need refactor to support composite pks on ESet"- {-- run $ do- let p = Point x y ""- x = 10- y = 15- newX = 20- newY = 25- Right newPk = keyFromValues [toPersistValue newX, toPersistValue newY]- insert_ p- () <- update $ \p' -> do- set p' [PointId =. val newPk]- [Entity _ ret] <- select $ from $ return- liftIO $ do- ret `shouldBe` Point newX newY []- -}-- it "GROUP BY works with COUNT" $- run $ do- p1k <- insert p1- p2k <- insert p2- p3k <- insert p3- replicateM_ 3 (insert $ BlogPost "" p1k)- replicateM_ 7 (insert $ BlogPost "" p3k)- ret <- select $- from $ \(p `LeftOuterJoin` b) -> do- on (p ^. PersonId ==. b ^. BlogPostAuthorId)- groupBy (p ^. PersonId)- let cnt = count (b ^. BlogPostId)- orderBy [ asc cnt ]- return (p, cnt)- liftIO $ ret `shouldBe` [ (Entity p2k p2, Value (0 :: Int))- , (Entity p1k p1, Value 3)- , (Entity p3k p3, Value 7) ]-- it "GROUP BY works with COUNT and InnerJoin" $- run $ do- l1k <- insert l1- l3k <- insert l3- mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])-- mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])-- (ret :: [(Value (Key Lord), Value Int)]) <- select $ from $- \ ( lord `InnerJoin` deed ) -> do- on $ lord ^. LordId ==. deed ^. DeedOwnerId- groupBy (lord ^. LordId)- return (lord ^. LordId, count $ deed ^. DeedId)- liftIO $ ret `shouldMatchList` [ (Value l3k, Value 7)- , (Value l1k, Value 3) ]-- it "GROUP BY works with nested tuples" $ do- run $ do- l1k <- insert l1- l3k <- insert l3- mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])-- mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])-- (ret :: [(Value (Key Lord), Value Int)]) <- select $ from $- \ ( lord `InnerJoin` deed ) -> do- on $ lord ^. LordId ==. deed ^. DeedOwnerId- groupBy ((lord ^. LordId, lord ^. LordDogs), deed ^. DeedContract)- return (lord ^. LordId, count $ deed ^. DeedId)- liftIO $ length ret `shouldBe` 10- it "GROUP BY works with HAVING" $- run $ do- p1k <- insert p1- _p2k <- insert p2- p3k <- insert p3- replicateM_ 3 (insert $ BlogPost "" p1k)- replicateM_ 7 (insert $ BlogPost "" p3k)- ret <- select $- from $ \(p `LeftOuterJoin` b) -> do- on (p ^. PersonId ==. b ^. BlogPostAuthorId)- let cnt = count (b ^. BlogPostId)- groupBy (p ^. PersonId)- having (cnt >. (val 0))- orderBy [ asc cnt ]- return (p, cnt)- liftIO $ ret `shouldBe` [ (Entity p1k p1, Value (3 :: Int))- , (Entity p3k p3, Value 7) ]----- we only care that this compiles. check that SqlWriteT doesn't fail on--- updates.-testSqlWriteT :: MonadIO m => SqlWriteT m ()-testSqlWriteT =- update $ \p -> do- set p [ PersonAge =. just (val 6) ]---- we only care that this compiles. checks that the SqlWriteT monad can run--- select queries.-testSqlWriteTRead :: MonadIO m => SqlWriteT m [(Value (Key Lord), Value Int)]-testSqlWriteTRead =- select $- from $ \ ( lord `InnerJoin` deed ) -> do- on $ lord ^. LordId ==. deed ^. DeedOwnerId- groupBy (lord ^. LordId)- return (lord ^. LordId, count $ deed ^. DeedId)---- we only care that this compiles checks that SqlReadT allows-testSqlReadT :: MonadIO m => SqlReadT m [(Value (Key Lord), Value Int)]-testSqlReadT =- select $- from $ \ ( lord `InnerJoin` deed ) -> do- on $ lord ^. LordId ==. deed ^. DeedOwnerId- groupBy (lord ^. LordId)- return (lord ^. LordId, count $ deed ^. DeedId)--testListOfValues :: Run -> Spec-testListOfValues run = do- describe "lists of values" $ do- it "IN works for valList" $- run $ do- p1k <- insert p1- p2k <- insert p2- _p3k <- insert p3- ret <- select $- from $ \p -> do- where_ (p ^. PersonName `in_` valList (personName <$> [p1, p2]))- return p- liftIO $ ret `shouldBe` [ Entity p1k p1- , Entity p2k p2 ]-- it "IN works for valList (null list)" $- run $ do- _p1k <- insert p1- _p2k <- insert p2- _p3k <- insert p3- ret <- select $- from $ \p -> do- where_ (p ^. PersonName `in_` valList [])- return p- liftIO $ ret `shouldBe` []-- it "IN works for subList_select" $- run $ do- p1k <- insert p1- _p2k <- insert p2- p3k <- insert p3- _ <- insert (BlogPost "" p1k)- _ <- insert (BlogPost "" p3k)- ret <- select $- from $ \p -> do- let subquery =- from $ \bp -> do- orderBy [ asc (bp ^. BlogPostAuthorId) ]- return (bp ^. BlogPostAuthorId)- where_ (p ^. PersonId `in_` subList_select subquery)- return p- liftIO $ L.sort ret `shouldBe` L.sort [Entity p1k p1, Entity p3k p3]-- it "NOT IN works for subList_select" $- run $ do- p1k <- insert p1- p2k <- insert p2- p3k <- insert p3- _ <- insert (BlogPost "" p1k)- _ <- insert (BlogPost "" p3k)- ret <- select $- from $ \p -> do- let subquery =- from $ \bp ->- return (bp ^. BlogPostAuthorId)- where_ (p ^. PersonId `notIn` subList_select subquery)- return p- liftIO $ ret `shouldBe` [ Entity p2k p2 ]-- it "EXISTS works for subList_select" $- run $ do- p1k <- insert p1- _p2k <- insert p2- p3k <- insert p3- _ <- insert (BlogPost "" p1k)- _ <- insert (BlogPost "" p3k)- ret <- select $- from $ \p -> do- where_ $ exists $- from $ \bp -> do- where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId)- orderBy [asc (p ^. PersonName)]- return p- liftIO $ ret `shouldBe` [ Entity p1k p1- , Entity p3k p3 ]-- it "EXISTS works for subList_select" $- run $ do- p1k <- insert p1- p2k <- insert p2- p3k <- insert p3- _ <- insert (BlogPost "" p1k)- _ <- insert (BlogPost "" p3k)- ret <- select $- from $ \p -> do- where_ $ notExists $- from $ \bp -> do- where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId)- return p- liftIO $ ret `shouldBe` [ Entity p2k p2 ]------testListFields :: Run -> Spec-testListFields run = do- describe "list fields" $ do- -- <https://github.com/prowdsponsor/esqueleto/issues/100>- it "can update list fields" $- run $ do- cclist <- insert $ CcList []- update $ \p -> do- set p [ CcListNames =. val ["fred"]]- where_ (p ^. CcListId ==. val cclist)------testInsertsBySelect :: Run -> Spec-testInsertsBySelect run = do- describe "inserts by select" $ do- it "IN works for insertSelect" $- run $ do- _ <- insert p1- _ <- insert p2- _ <- insert p3- insertSelect $ from $ \p -> do- return $ BlogPost <# val "FakePost" <&> (p ^. PersonId)- ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows)- liftIO $ ret `shouldBe` [Value (3::Int)]------testInsertsBySelectReturnsCount :: Run -> Spec-testInsertsBySelectReturnsCount run = do- describe "inserts by select, returns count" $ do- it "IN works for insertSelectCount" $- run $ do- _ <- insert p1- _ <- insert p2- _ <- insert p3- cnt <- insertSelectCount $ from $ \p -> do- return $ BlogPost <# val "FakePost" <&> (p ^. PersonId)- ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows)- liftIO $ ret `shouldBe` [Value (3::Int)]- liftIO $ cnt `shouldBe` 3-----testRandomMath :: Run -> Spec-testRandomMath run = describe "random_ math" $- it "rand returns result in random order" $- run $ do- replicateM_ 20 $ do- _ <- insert p1- _ <- insert p2- _ <- insert p3- _ <- insert p4- _ <- insert $ Person "Jane" Nothing Nothing 0- _ <- insert $ Person "Mark" Nothing Nothing 0- _ <- insert $ Person "Sarah" Nothing Nothing 0- insert $ Person "Paul" Nothing Nothing 0- ret1 <- fmap (map unValue) $ select $ from $ \p -> do- orderBy [rand]- return (p ^. PersonId)- ret2 <- fmap (map unValue) $ select $ from $ \p -> do- orderBy [rand]- return (p ^. PersonId)-- liftIO $ (ret1 == ret2) `shouldBe` False--testMathFunctions :: Run -> Spec-testMathFunctions run = do- describe "Math-related functions" $ do- it "castNum works for multiplying Int and Double" $- run $ do- mapM_ insert [Numbers 2 3.4, Numbers 7 1.1]- ret <-- select $- from $ \n -> do- let r = castNum (n ^. NumbersInt) *. n ^. NumbersDouble- orderBy [asc r]- return r- liftIO $ length ret `shouldBe` 2- let [Value a, Value b] = ret- liftIO $ max (abs (a - 6.8)) (abs (b - 7.7)) `shouldSatisfy` (< 0.01)------testCase :: Run -> Spec-testCase run = do- describe "case" $ do- it "Works for a simple value based when - False" $- run $ do- ret <- select $- return $- case_- [ when_ (val False) then_ (val (1 :: Int)) ]- (else_ (val 2))-- liftIO $ ret `shouldBe` [ Value 2 ]-- it "Works for a simple value based when - True" $- run $ do- ret <- select $- return $- case_- [ when_ (val True) then_ (val (1 :: Int)) ]- (else_ (val 2))-- liftIO $ ret `shouldBe` [ Value 1 ]-- it "works for a semi-complicated query" $- run $ do- _ <- insert p1- _ <- insert p2- _ <- insert p3- _ <- insert p4- _ <- insert p5- ret <- select $- return $- case_- [ when_- (exists $ from $ \p -> do- where_ (p ^. PersonName ==. val "Mike"))- then_- (sub_select $ from $ \v -> do- let sub =- from $ \c -> do- where_ (c ^. PersonName ==. val "Mike")- return (c ^. PersonFavNum)- where_ (v ^. PersonFavNum >. sub_select sub)- return $ count (v ^. PersonName) +. val (1 :: Int)) ]- (else_ $ val (-1))-- liftIO $ ret `shouldBe` [ Value (3) ]------testLocking :: WithConn (NoLoggingT IO) [TL.Text] -> Spec-testLocking withConn = do- describe "locking" $ do- -- The locking clause is the last one, so try to use many- -- others to test if it's at the right position. We don't- -- care about the text of the rest, nor with the RDBMS'- -- reaction to the clause.- let sanityCheck kind syntax = do- let complexQuery =- from $ \(p1' `InnerJoin` p2') -> do- on (p1' ^. PersonName ==. p2' ^. PersonName)- where_ (p1' ^. PersonFavNum >. val 2)- orderBy [desc (p2' ^. PersonAge)]- limit 3- offset 9- groupBy (p1' ^. PersonId)- having (countRows <. val (0 :: Int))- return (p1', p2')- queryWithClause1 = do- r <- complexQuery- locking kind- return r- queryWithClause2 = do- locking ForUpdate- r <- complexQuery- locking ForShare- locking kind- return r- queryWithClause3 = do- locking kind- complexQuery- toText conn q =- let (tlb, _) = EI.toRawSql EI.SELECT (conn, EI.initialIdentState) q- in TLB.toLazyText tlb- [complex, with1, with2, with3] <-- runNoLoggingT $ withConn $ \conn -> return $- map (toText conn) [complexQuery, queryWithClause1, queryWithClause2, queryWithClause3]- let expected = complex <> "\n" <> syntax- (with1, with2, with3) `shouldBe` (expected, expected, expected)-- it "looks sane for ForUpdate" $ sanityCheck ForUpdate "FOR UPDATE"- it "looks sane for ForUpdateSkipLocked" $ sanityCheck ForUpdateSkipLocked "FOR UPDATE SKIP LOCKED"- it "looks sane for ForShare" $ sanityCheck ForShare "FOR SHARE"- it "looks sane for LockInShareMode" $ sanityCheck LockInShareMode "LOCK IN SHARE MODE"------testCountingRows :: Run -> Spec-testCountingRows run = do- describe "counting rows" $ do- forM_ [ ("count (test A)", count . (^. PersonAge), 4)- , ("count (test B)", count . (^. PersonWeight), 5)- , ("countRows", const countRows, 5)- , ("countDistinct", countDistinct . (^. PersonAge), 2) ] $- \(title, countKind, expected) ->- it (title ++ " works as expected") $- run $ do- mapM_ insert- [ Person "" (Just 1) (Just 1) 1- , Person "" (Just 2) (Just 1) 1- , Person "" (Just 2) (Just 1) 1- , Person "" (Just 2) (Just 2) 1- , Person "" Nothing (Just 3) 1]- [Value n] <- select $ from $ return . countKind- liftIO $ (n :: Int) `shouldBe` expected--testRenderSql :: Run -> Spec-testRenderSql run = do- describe "testRenderSql" $ do- it "works" $ do- (queryText, queryVals) <- run $ renderQuerySelect $- from $ \p -> do- where_ $ p ^. PersonName ==. val "Johhny Depp"- pure (p ^. PersonName, p ^. PersonAge)- -- the different backends use different quote marks, so I filter them out- -- here instead of making a duplicate test- Text.filter (\c -> c `notElem` ['`', '"']) queryText- `shouldBe`- Text.unlines- [ "SELECT Person.name, Person.age"- , "FROM Person"- , "WHERE Person.name = ?"- ]- queryVals- `shouldBe`- [toPersistValue ("Johhny Depp" :: TL.Text)]-- describe "renderExpr" $ do- it "renders a value" $ do- (c, expr) <- run $ do- conn <- ask- let Right c = P.mkEscapeChar conn- pure $ (,) c $ EI.renderExpr conn $- EI.EEntity (EI.I "user") ^. PersonId- ==. EI.EEntity (EI.I "blog_post") ^. BlogPostAuthorId- expr- `shouldBe`- Text.intercalate (Text.singleton c) ["", "user", ".", "id", ""]- <>- " = "- <>- Text.intercalate (Text.singleton c) ["", "blog_post", ".", "authorId", ""]- it "renders ? for a val" $ do- expr <- run $ ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1))- expr `shouldBe` "? = ?"-- describe "EEntity Ident behavior" $ do- let- render :: SqlExpr (Entity val) -> Text.Text- render (EI.EEntity (EI.I ident)) = ident- it "renders sensibly" $ do- results <- run $ do- _ <- insert $ Foo 2- _ <- insert $ Foo 3- _ <- insert $ Person "hello" Nothing Nothing 3- select $- from $ \(a `LeftOuterJoin` b) -> do- on $ a ^. FooName ==. b ^. PersonFavNum- pure (val (render a), val (render b))- head results- `shouldBe`- (Value "Foo", Value "Person")-- describe "ExprParser" $ do- let parse parser = AP.parseOnly (parser '#')- describe "parseEscapedChars" $ do- let subject = parse P.parseEscapedChars- it "parses words" $ do- subject "hello world"- `shouldBe`- Right "hello world"- it "only returns a single escape-char if present" $ do- subject "i_am##identifier##"- `shouldBe`- Right "i_am#identifier#"- describe "parseEscapedIdentifier" $ do- let subject = parse P.parseEscapedIdentifier- it "parses the quotes out" $ do- subject "#it's a me, mario#"- `shouldBe`- Right "it's a me, mario"- it "requires a beginning and end quote" $ do- subject "#alas, i have no end"- `shouldSatisfy`- isLeft- describe "parseTableAccess" $ do- let subject = parse P.parseTableAccess- it "parses a table access" $ do- subject "#foo#.#bar#"- `shouldBe`- Right P.TableAccess- { P.tableAccessTable = "foo"- , P.tableAccessColumn = "bar"- }- describe "onExpr" $ do- let subject = parse P.onExpr- it "works" $ do- subject "#foo#.#bar# = #bar#.#baz#"- `shouldBe` do- Right $ S.fromList- [ P.TableAccess- { P.tableAccessTable = "foo"- , P.tableAccessColumn = "bar"- }- , P.TableAccess- { P.tableAccessTable = "bar"- , P.tableAccessColumn = "baz"- }- ]- it "also works with other nonsense" $ do- subject "#foo#.#bar# = 3"- `shouldBe` do- Right $ S.fromList- [ P.TableAccess- { P.tableAccessTable = "foo"- , P.tableAccessColumn = "bar"- }- ]- it "handles a conjunction" $ do- subject "#foo#.#bar# = #bar#.#baz# AND #bar#.#baz# > 10"- `shouldBe` do- Right $ S.fromList- [ P.TableAccess- { P.tableAccessTable = "foo"- , P.tableAccessColumn = "bar"- }- , P.TableAccess- { P.tableAccessTable = "bar"- , P.tableAccessColumn = "baz"- }- ]- it "handles ? okay" $ do- subject "#foo#.#bar# = ?"- `shouldBe` do- Right $ S.fromList- [ P.TableAccess- { P.tableAccessTable = "foo"- , P.tableAccessColumn = "bar"- }- ]- it "handles degenerate cases" $ do- subject "false" `shouldBe` pure mempty- subject "true" `shouldBe` pure mempty- subject "1 = 1" `shouldBe` pure mempty- it "works even if an identifier isn't first" $ do- subject "true and #foo#.#bar# = 2"- `shouldBe` do- Right $ S.fromList- [ P.TableAccess- { P.tableAccessTable = "foo"- , P.tableAccessColumn = "bar"- }- ]--testOnClauseOrder :: Run -> Spec-testOnClauseOrder run = describe "On Clause Ordering" $ do- let- setup :: MonadIO m => SqlPersistT m ()- setup = do- ja1 <- insert (JoinOne "j1 hello")- ja2 <- insert (JoinOne "j1 world")- jb1 <- insert (JoinTwo ja1 "j2 hello")- jb2 <- insert (JoinTwo ja1 "j2 world")- jb3 <- insert (JoinTwo ja2 "j2 foo")- _ <- insert (JoinTwo ja2 "j2 bar")- jc1 <- insert (JoinThree jb1 "j3 hello")- jc2 <- insert (JoinThree jb1 "j3 world")- _ <- insert (JoinThree jb2 "j3 foo")- _ <- insert (JoinThree jb3 "j3 bar")- _ <- insert (JoinThree jb3 "j3 baz")- _ <- insert (JoinFour "j4 foo" jc1)- _ <- insert (JoinFour "j4 bar" jc2)- jd1 <- insert (JoinOther "foo")- jd2 <- insert (JoinOther "bar")- _ <- insert (JoinMany "jm foo hello" jd1 ja1)- _ <- insert (JoinMany "jm foo world" jd1 ja2)- _ <- insert (JoinMany "jm bar hello" jd2 ja1)- _ <- insert (JoinMany "jm bar world" jd2 ja2)- pure ()- describe "identical results for" $ do- it "three tables" $ do- abcs <- run $ do- setup- select $- from $ \(a `InnerJoin` b `InnerJoin` c) -> do- on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)- on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)- pure (a, b, c)- acbs <- run $ do- setup- select $- from $ \(a `InnerJoin` b `InnerJoin` c) -> do- on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)- on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)- pure (a, b, c)-- listsEqualOn abcs acbs $ \(Entity _ j1, Entity _ j2, Entity _ j3) ->- (joinOneName j1, joinTwoName j2, joinThreeName j3)-- it "four tables" $ do- xs0 <- run $ do- setup- select $- from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do- on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)- on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)- on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)- pure (a, b, c, d)- xs1 <- run $ do- setup- select $- from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do- on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)- on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)- on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)- pure (a, b, c, d)- xs2 <- run $ do- setup- select $- from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do- on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)- on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)- on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)- pure (a, b, c, d)- xs3 <- run $ do- setup- select $- from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do- on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)- on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)- on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)- pure (a, b, c, d)- xs4 <- run $ do- setup- select $- from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do- on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)- on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)- on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)- pure (a, b, c, d)-- let getNames (j1, j2, j3, j4) =- ( joinOneName (entityVal j1)- , joinTwoName (entityVal j2)- , joinThreeName (entityVal j3)- , joinFourName (entityVal j4)- )- listsEqualOn xs0 xs1 getNames- listsEqualOn xs0 xs2 getNames- listsEqualOn xs0 xs3 getNames- listsEqualOn xs0 xs4 getNames-- it "associativity of innerjoin" $ do- xs0 <- run $ do- setup- select $- from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do- on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)- on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)- on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)- pure (a, b, c, d)-- xs1 <- run $ do- setup- select $- from $ \(a `InnerJoin` b `InnerJoin` (c `InnerJoin` d)) -> do- on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)- on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)- on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)- pure (a, b, c, d)-- xs2 <- run $ do- setup- select $- from $ \(a `InnerJoin` (b `InnerJoin` c) `InnerJoin` d) -> do- on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)- on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)- on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)- pure (a, b, c, d)-- xs3 <- run $ do- setup- select $- from $ \(a `InnerJoin` (b `InnerJoin` c `InnerJoin` d)) -> do- on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)- on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)- on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)- pure (a, b, c, d)-- let getNames (j1, j2, j3, j4) =- ( joinOneName (entityVal j1)- , joinTwoName (entityVal j2)- , joinThreeName (entityVal j3)- , joinFourName (entityVal j4)- )- listsEqualOn xs0 xs1 getNames- listsEqualOn xs0 xs2 getNames- listsEqualOn xs0 xs3 getNames-- it "inner join on two entities" $ do- (xs0, xs1) <- run $ do- pid <- insert $ Person "hello" Nothing Nothing 3- _ <- insert $ BlogPost "good poast" pid- _ <- insert $ Profile "cool" pid- xs0 <- selectRethrowingQuery $- from $ \(p `InnerJoin` b `InnerJoin` pr) -> do- on $ p ^. PersonId ==. b ^. BlogPostAuthorId- on $ p ^. PersonId ==. pr ^. ProfilePerson- pure (p, b, pr)- xs1 <- selectRethrowingQuery $- from $ \(p `InnerJoin` b `InnerJoin` pr) -> do- on $ p ^. PersonId ==. pr ^. ProfilePerson- on $ p ^. PersonId ==. b ^. BlogPostAuthorId- pure (p, b, pr)- pure (xs0, xs1)- listsEqualOn xs0 xs1 $ \(Entity _ p, Entity _ b, Entity _ pr) ->- (personName p, blogPostTitle b, profileName pr)- it "inner join on three entities" $ do- res <- run $ do- pid <- insert $ Person "hello" Nothing Nothing 3- _ <- insert $ BlogPost "good poast" pid- _ <- insert $ BlogPost "good poast #2" pid- _ <- insert $ Profile "cool" pid- _ <- insert $ Reply pid "u wot m8"- _ <- insert $ Reply pid "how dare you"-- bprr <- selectRethrowingQuery $- from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do- on $ p ^. PersonId ==. b ^. BlogPostAuthorId- on $ p ^. PersonId ==. pr ^. ProfilePerson- on $ p ^. PersonId ==. r ^. ReplyGuy- pure (p, b, pr, r)-- brpr <- selectRethrowingQuery $- from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do- on $ p ^. PersonId ==. b ^. BlogPostAuthorId- on $ p ^. PersonId ==. r ^. ReplyGuy- on $ p ^. PersonId ==. pr ^. ProfilePerson- pure (p, b, pr, r)-- prbr <- selectRethrowingQuery $- from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do- on $ p ^. PersonId ==. pr ^. ProfilePerson- on $ p ^. PersonId ==. b ^. BlogPostAuthorId- on $ p ^. PersonId ==. r ^. ReplyGuy- pure (p, b, pr, r)-- prrb <- selectRethrowingQuery $- from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do- on $ p ^. PersonId ==. pr ^. ProfilePerson- on $ p ^. PersonId ==. r ^. ReplyGuy- on $ p ^. PersonId ==. b ^. BlogPostAuthorId- pure (p, b, pr, r)-- rprb <- selectRethrowingQuery $- from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do- on $ p ^. PersonId ==. r ^. ReplyGuy- on $ p ^. PersonId ==. pr ^. ProfilePerson- on $ p ^. PersonId ==. b ^. BlogPostAuthorId- pure (p, b, pr, r)-- rbpr <- selectRethrowingQuery $- from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do- on $ p ^. PersonId ==. r ^. ReplyGuy- on $ p ^. PersonId ==. b ^. BlogPostAuthorId- on $ p ^. PersonId ==. pr ^. ProfilePerson- pure (p, b, pr, r)-- pure [bprr, brpr, prbr, prrb, rprb, rbpr]- forM_ (zip res (drop 1 (cycle res))) $ \(a, b) -> a `shouldBe` b-- it "many-to-many" $ do- ac <- run $ do- setup- select $- from $ \(a `InnerJoin` b `InnerJoin` c) -> do- on (a ^. JoinOneId ==. b ^. JoinManyJoinOne)- on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther)- pure (a, c)-- ca <- run $ do- setup- select $- from $ \(a `InnerJoin` b `InnerJoin` c) -> do- on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther)- on (a ^. JoinOneId ==. b ^. JoinManyJoinOne)- pure (a, c)-- listsEqualOn ac ca $ \(Entity _ a, Entity _ b) ->- (joinOneName a, joinOtherName b)-- it "left joins on order" $ do- ca <- run $ do- setup- select $- from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do- on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther)- on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne)- orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId]- pure (a, c)- ac <- run $ do- setup- select $- from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do- on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne)- on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther)- orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId]- pure (a, c)-- listsEqualOn ac ca $ \(Entity _ a, b) ->- (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b)-- it "doesn't require an on for a crossjoin" $ do- void $ run $- select $- from $ \(a `CrossJoin` b) -> do- pure (a :: SqlExpr (Entity JoinOne), b :: SqlExpr (Entity JoinTwo))-- it "errors with an on for a crossjoin" $ do- (void $ run $- select $- from $ \(a `CrossJoin` b) -> do- on $ a ^. JoinOneId ==. b ^. JoinTwoJoinOne- pure (a, b))- `shouldThrow` \(OnClauseWithoutMatchingJoinException _) ->- True-- it "left joins associativity" $ do- ca <- run $ do- setup- select $- from $ \(a `LeftOuterJoin` (b `InnerJoin` c)) -> do- on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther)- on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne)- orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId]- pure (a, c)- ca' <- run $ do- setup- select $- from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do- on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther)- on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne)- orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId]- pure (a, c)-- listsEqualOn ca ca' $ \(Entity _ a, b) ->- (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b)-- it "composes queries still" $ do- let- query1 =- from $ \(foo `InnerJoin` bar) -> do- on (foo ^. FooId ==. bar ^. BarQuux)- pure (foo, bar)- query2 =- from $ \(p `LeftOuterJoin` bp) -> do- on (p ^. PersonId ==. bp ^. BlogPostAuthorId)- pure (p, bp)- (a, b) <- run $ do- fid <- insert $ Foo 5- _ <- insert $ Bar fid- pid <- insert $ Person "hey" Nothing Nothing 30- _ <- insert $ BlogPost "WHY" pid- a <- select ((,) <$> query1 <*> query2)- b <- select (flip (,) <$> query1 <*> query2)- pure (a, b)- listsEqualOn a (map (\(x, y) -> (y, x)) b) id-- it "works with joins in subselect" $ do- run $ void $- select $- from $ \(p `InnerJoin` r) -> do- on $ p ^. PersonId ==. r ^. ReplyGuy- pure . (,) (p ^. PersonName) $- subSelect $- from $ \(c `InnerJoin` bp) -> do- on $ bp ^. BlogPostId ==. c ^. CommentBlog- pure (c ^. CommentBody)-- describe "works with nested joins" $ do- it "unnested" $ do- run $ void $- selectRethrowingQuery $- from $ \(f `InnerJoin` b `LeftOuterJoin` baz `InnerJoin` shoop) -> do- on $ f ^. FooId ==. b ^. BarQuux- on $ f ^. FooId ==. baz ^. BazBlargh- on $ baz ^. BazId ==. shoop ^. ShoopBaz- pure ( f ^. FooName)- it "leftmost nesting" $ do- run $ void $- selectRethrowingQuery $- from $ \((f `InnerJoin` b) `LeftOuterJoin` baz `InnerJoin` shoop) -> do- on $ f ^. FooId ==. b ^. BarQuux- on $ f ^. FooId ==. baz ^. BazBlargh- on $ baz ^. BazId ==. shoop ^. ShoopBaz- pure ( f ^. FooName)- describe "middle nesting" $ do- it "direct association" $ do- run $ void $- selectRethrowingQuery $- from $ \(p `InnerJoin` (bp `LeftOuterJoin` c) `LeftOuterJoin` cr) -> do- on $ p ^. PersonId ==. bp ^. BlogPostAuthorId- on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog- on $ c ?. CommentId ==. cr ?. CommentReplyComment- pure (p,bp,c,cr)- it "indirect association" $ do- run $ void $- selectRethrowingQuery $- from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf) -> do- on $ f ^. FooId ==. b ^. BarQuux- on $ f ^. FooId ==. baz ^. BazBlargh- on $ baz ^. BazId ==. shoop ^. ShoopBaz- on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId- pure (f ^. FooName)- it "indirect association across" $ do- run $ void $- selectRethrowingQuery $- from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf `InnerJoin` another `InnerJoin` yetAnother) -> do- on $ f ^. FooId ==. b ^. BarQuux- on $ f ^. FooId ==. baz ^. BazBlargh- on $ baz ^. BazId ==. shoop ^. ShoopBaz- on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId- on $ another ^. AnotherWhy ==. baz ^. BazId- on $ yetAnother ^. YetAnotherArgh ==. shoop ^. ShoopId- pure (f ^. FooName)-- describe "rightmost nesting" $ do- it "direct associations" $ do- run $ void $- selectRethrowingQuery $- from $ \(p `InnerJoin` bp `LeftOuterJoin` (c `LeftOuterJoin` cr)) -> do- on $ p ^. PersonId ==. bp ^. BlogPostAuthorId- on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog- on $ c ?. CommentId ==. cr ?. CommentReplyComment- pure (p,bp,c,cr)-- it "indirect association" $ do- run $ void $- selectRethrowingQuery $- from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop)) -> do- on $ f ^. FooId ==. b ^. BarQuux- on $ f ^. FooId ==. baz ^. BazBlargh- on $ baz ^. BazId ==. shoop ^. ShoopBaz- pure (f ^. FooName)--testExperimentalFrom :: Run -> Spec-testExperimentalFrom run = do- describe "Experimental From" $ do- it "supports basic table queries" $ do- run $ do- p1e <- insert' p1- _ <- insert' p2- p3e <- insert' p3- peopleWithAges <- select $ do- people <- Experimental.from $ Table @Person- where_ $ not_ $ isNothing $ people ^. PersonAge- return people- liftIO $ peopleWithAges `shouldMatchList` [p1e, p3e]-- it "supports inner joins" $ do- run $ do- l1e <- insert' l1- _ <- insert l2- d1e <- insert' $ Deed "1" (entityKey l1e)- d2e <- insert' $ Deed "2" (entityKey l1e)- lordDeeds <- select $ do- (lords :& deeds) <-- Experimental.from $ Table @Lord- `InnerJoin` Table @Deed- `Experimental.on` (\(l :& d) -> l ^. LordId ==. d ^. DeedOwnerId)- pure (lords, deeds)- liftIO $ lordDeeds `shouldMatchList` [ (l1e, d1e)- , (l1e, d2e)- ]-- it "supports outer joins" $ do- run $ do- l1e <- insert' l1- l2e <- insert' l2- d1e <- insert' $ Deed "1" (entityKey l1e)- d2e <- insert' $ Deed "2" (entityKey l1e)- lordDeeds <- select $ do- (lords :& deeds) <-- Experimental.from $ Table @Lord- `LeftOuterJoin` Table @Deed- `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)-- pure (lords, deeds)- liftIO $ lordDeeds `shouldMatchList` [ (l1e, Just d1e)- , (l1e, Just d2e)- , (l2e, Nothing)- ]- it "supports delete" $ do- run $ do- insert_ l1- insert_ l2- insert_ l3- delete $ void $ Experimental.from $ Table @Lord- lords <- select $ Experimental.from $ Table @Lord- liftIO $ lords `shouldMatchList` []-- it "supports implicit cross joins" $ do- run $ do- l1e <- insert' l1- l2e <- insert' l2- ret <- select $ do- lords1 <- Experimental.from $ Table @Lord- lords2 <- Experimental.from $ Table @Lord- pure (lords1, lords2)- ret2 <- select $ do- (lords1 :& lords2) <- Experimental.from $ Table @Lord `CrossJoin` Table @Lord- pure (lords1,lords2)- liftIO $ ret `shouldMatchList` ret2- liftIO $ ret `shouldMatchList` [ (l1e, l1e)- , (l1e, l2e)- , (l2e, l1e)- , (l2e, l2e)- ]--- it "compiles" $ do- run $ void $ do- let q = do- (persons :& profiles :& posts) <-- Experimental.from $ Table @Person- `InnerJoin` Table @Profile- `Experimental.on` (\(people :& profiles) ->- people ^. PersonId ==. profiles ^. ProfilePerson)- `LeftOuterJoin` Table @BlogPost- `Experimental.on` (\(people :& _ :& posts) ->- just (people ^. PersonId) ==. posts ?. BlogPostAuthorId)- pure (persons, posts, profiles)- --error . show =<< renderQuerySelect q- pure ()-- it "can call functions on aliased values" $ do- run $ do- insert_ p1- insert_ p3- -- Pretend this isnt all posts- upperNames <- select $ do- author <- Experimental.from $ SelectQuery $ Experimental.from $ Table @Person- pure $ upper_ $ author ^. PersonName-- liftIO $ upperNames `shouldMatchList` [ Value "JOHN"- , Value "MIKE"- ]--listsEqualOn :: (Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) -> Expectation-listsEqualOn a b f = map f a `shouldBe` map f b--tests :: Run -> Spec-tests run = do- describe "Tests that are common to all backends" $ do- testSelect run- testSubSelect run- testSelectSource run- testSelectFrom run- testSelectJoin run- testSelectSubQuery run- testSelectWhere run- testSelectOrderBy run- testSelectDistinct run- testCoasleceDefault run- testDelete run- testUpdate run- testListOfValues run- testListFields run- testInsertsBySelect run- testMathFunctions run- testCase run- testCountingRows run- testRenderSql run- testOnClauseOrder run- testExperimentalFrom run---insert' :: ( Functor m- , BaseBackend backend ~ PersistEntityBackend val- , PersistStore backend- , MonadIO m- , PersistEntity val )- => val -> ReaderT backend m (Entity val)-insert' v = flip Entity v <$> insert v---type RunDbMonad m = ( MonadUnliftIO m- , MonadIO m- , MonadLogger m- , MonadCatch m )--#if __GLASGOW_HASKELL__ >= 806-type Run = forall a. (forall m. (RunDbMonad m, MonadFail m) => SqlPersistT (R.ResourceT m) a) -> IO a-#else-type Run = forall a. (forall m. (RunDbMonad m) => SqlPersistT (R.ResourceT m) a) -> IO a-#endif--type WithConn m a = RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a---- With SQLite and in-memory databases, a separate connection implies a--- separate database. With 'actual databases', the data is persistent and--- thus must be cleaned after each test.--- TODO: there is certainly a better way...-cleanDB- :: (forall m. RunDbMonad m- => SqlPersistT (R.ResourceT m) ())-cleanDB = do- delete $ from $ \(_ :: SqlExpr (Entity Bar)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity Foo)) -> return ()-- delete $ from $ \(_ :: SqlExpr (Entity Reply)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity Comment)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity Profile)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity BlogPost)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity Follow)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity Person)) -> return ()-- delete $ from $ \(_ :: SqlExpr (Entity Deed)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity Lord)) -> return ()-- delete $ from $ \(_ :: SqlExpr (Entity CcList)) -> return ()-- delete $ from $ \(_ :: SqlExpr (Entity ArticleTag)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity ArticleMetadata)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity Article)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity Article2)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity Tag)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity Frontcover)) -> return ()-- delete $ from $ \(_ :: SqlExpr (Entity Circle)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity Point)) -> return ()-- delete $ from $ \(_ :: SqlExpr (Entity Numbers)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity JoinMany)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity JoinFour)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity JoinThree)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity JoinTwo)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity JoinOne)) -> return ()- delete $ from $ \(_ :: SqlExpr (Entity JoinOther)) -> return ()-- delete $ from $ \(_ :: SqlExpr (Entity DateTruncTest)) -> pure ()---cleanUniques- :: (forall m. RunDbMonad m- => SqlPersistT (R.ResourceT m) ())-cleanUniques =- delete $ from $ \(_ :: SqlExpr (Entity OneUnique)) -> return ()--selectRethrowingQuery- :: (MonadIO m, EI.SqlSelect a r, MonadUnliftIO m)- => SqlQuery a- -> SqlPersistT m [r]-selectRethrowingQuery query =- select query- `catch` \(SomeException e) -> do- (text, _) <- renderQuerySelect query- liftIO . throwIO . userError $ Text.unpack text <> "\n\n" <> show e+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++#if __GLASGOW_HASKELL__ >= 902+{-# LANGUAGE OverloadedRecordDot #-}+#endif++{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}+module Common.Test+ ( tests+ , testLocking+ , testAscRandom+ , migrateAll+ , migrateUnique+ , cleanDB+ , cleanUniques+ , updateRethrowingQuery+ , selectRethrowingQuery+ , p1, p2, p3, p4, p5+ , l1, l2, l3+ , u1, u2, u3, u4+ , insert'+ , EntityField (..)+ , Foo (..)+ , Bar (..)+ , Person (..)+ , BlogPost (..)+ , Lord (..)+ , Deed (..)+ , Follow (..)+ , CcList (..)+ , Frontcover (..)+ , Article (..)+ , Tag (..)+ , ArticleTag (..)+ , Article2 (..)+ , Point (..)+ , Circle (..)+ , Numbers (..)+ , OneUnique(..)+ , Unique(..)+ , DateTruncTest(..)+ , DateTruncTestId+ , Key(..)+ , assertJust+ ) where++import Common.Test.Import hiding (from, on)++import Control.Monad (forM_, replicateM, replicateM_, void)+import qualified Data.Attoparsec.Text as AP+import Data.Char (toLower, toUpper)+import Data.Either+import Database.Esqueleto+import qualified Database.Esqueleto.Experimental as Experimental++import Data.Conduit (ConduitT, runConduit, (.|))+import qualified Data.Conduit.List as CL+import qualified Data.List as L+import qualified Data.Set as S+import qualified Data.Text as Text+import qualified Data.Text.Internal.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import qualified Database.Esqueleto.Internal.ExprParser as P+import qualified Database.Esqueleto.Internal.Internal as EI+import Database.Esqueleto.PostgreSQL as EP+import Database.Persist.Class.PersistEntity+import qualified UnliftIO.Resource as R++import Common.Record (testDeriveEsqueletoRecord)+import Common.Test.Select+import qualified Common.Test.CTE as CTESpec++-- Test schema+-- | this could be achieved with S.fromList, but not all lists+-- have Ord instances+sameElementsAs :: Eq a => [a] -> [a] -> Bool+sameElementsAs l1' l2' = null (l1' L.\\ l2')++-- | Helper for rounding to a specific digit+-- Prelude> map (flip roundTo 12.3456) [0..5]+-- [12.0, 12.3, 12.35, 12.346, 12.3456, 12.3456]+roundTo :: (Fractional a, RealFrac a1, Integral b) => b -> a1 -> a+roundTo n f =+ (fromInteger $ round $ f * (10^n)) / (10.0^^n)++p1 :: Person+p1 = Person "John" (Just 36) Nothing 1++p2 :: Person+p2 = Person "Rachel" Nothing (Just 37) 2++p3 :: Person+p3 = Person "Mike" (Just 17) Nothing 3++p4 :: Person+p4 = Person "Livia" (Just 17) (Just 18) 4++p5 :: Person+p5 = Person "Mitch" Nothing Nothing 5++l1 :: Lord+l1 = Lord "Cornwall" (Just 36)++l2 :: Lord+l2 = Lord "Dorset" Nothing++l3 :: Lord+l3 = Lord "Chester" (Just 17)++u1 :: OneUnique+u1 = OneUnique "First" 0++u2 :: OneUnique+u2 = OneUnique "Second" 1++u3 :: OneUnique+u3 = OneUnique "Third" 0++u4 :: OneUnique+u4 = OneUnique "First" 2++testSubSelect :: SpecDb+testSubSelect = do+ let setup :: MonadIO m => SqlPersistT m ()+ setup = do+ _ <- insert $ Numbers 1 2+ _ <- insert $ Numbers 2 4+ _ <- insert $ Numbers 3 5+ _ <- insert $ Numbers 6 7+ pure ()++ describe "subSelect" $ do+ itDb "is safe for queries that may return multiple results" $ do+ let query =+ from $ \n -> do+ orderBy [asc (n ^. NumbersInt)]+ pure (n ^. NumbersInt)+ setup+ res <- select $ pure $ subSelect query+ asserting $ do+ res `shouldBe` [Value (Just 1)]++ itDb "is safe for queries that may not return anything" $ do+ let query =+ from $ \n -> do+ orderBy [asc (n ^. NumbersInt)]+ limit 1+ pure (n ^. NumbersInt)+ setup+ res <- select $ pure $ subSelect query+ transactionUndo++ asserting $ do+ res `shouldBe` [Value $ Just 1]++ describe "subSelectList" $ do+ itDb "is safe on empty databases as well as good databases" $ do+ let query =+ from $ \n -> do+ where_ $ n ^. NumbersInt `in_` do+ subSelectList $+ from $ \n' -> do+ where_ $ n' ^. NumbersInt >=. val 3+ pure (n' ^. NumbersInt)+ pure n+ empty <- select query++ full <- do+ setup+ select query++ asserting $ do+ empty `shouldBe` []+ full `shouldSatisfy` (not . null)++ describe "subSelectMaybe" $ do+ itDb "is equivalent to joinV . subSelect" $ do+ let query+ :: (SqlQuery (SqlExpr (Value (Maybe Int))) -> SqlExpr (Value (Maybe Int)))+ -> SqlQuery (SqlExpr (Value (Maybe Int)))+ query selector =+ from $ \n -> do+ pure $+ selector $+ from $ \n' -> do+ where_ $ n' ^. NumbersDouble >=. n ^. NumbersDouble+ pure (max_ (n' ^. NumbersInt))++ setup+ a <- select (query subSelectMaybe)+ b <- select (query (joinV . subSelect))+ asserting $ a `shouldBe` b++ describe "subSelectCount" $ do+ itDb "is a safe way to do a countRows" $ do+ setup+ xs0 <-+ select $+ from $ \n -> do+ pure $ (,) n $+ subSelectCount @Int $+ from $ \n' -> do+ where_ $ n' ^. NumbersInt >=. n ^. NumbersInt++ xs1 <-+ select $+ from $ \n -> do+ pure $ (,) n $+ subSelectUnsafe $+ from $ \n' -> do+ where_ $ n' ^. NumbersInt >=. n ^. NumbersInt+ pure (countRows :: SqlExpr (Value Int))++ let getter (Entity _ a, b) = (a, b)+ asserting $+ map getter xs0 `shouldBe` map getter xs1++ describe "subSelectUnsafe" $ do+ itDb "throws exceptions on multiple results" $ do+ setup+ eres <- try $ do+ bad <- select $+ from $ \n -> do+ pure $ (,) (n ^. NumbersInt) $+ subSelectUnsafe $+ from $ \n' -> do+ pure (just (n' ^. NumbersDouble))+ good <- select $+ from $ \n -> do+ pure $ (,) (n ^. NumbersInt) $+ subSelect $+ from $ \n' -> do+ pure (n' ^. NumbersDouble)+ pure (bad, good)+ asserting $ case eres of+ Left (SomeException _) ->+ -- Must use SomeException because the database libraries throw their+ -- own errors.+ pure ()+ Right (bad, good) -> do+ -- SQLite just takes the first element of the sub-select. lol.+ bad `shouldBe` good++ itDb "throws exceptions on null results" $ do+ setup+ eres <- try $ do+ select $+ from $ \n -> do+ pure $ (,) (n ^. NumbersInt) $+ subSelectUnsafe $+ from $ \n' -> do+ where_ $ val False+ pure (n' ^. NumbersDouble)+ asserting $ case eres of+ Left (_ :: PersistException) ->+ pure ()+ Right xs ->+ xs `shouldBe` []++testSelectOne :: SpecDb+testSelectOne =+ describe "selectOne" $ do+ let personQuery =+ selectOne $ do+ person <- Experimental.from $ Experimental.table @Person+ where_ $ person ^. PersonFavNum >=. val 1+ orderBy [asc (person ^. PersonId)]+ return $ person ^. PersonId+ itDb "returns Just" $ do+ person <- insert' p1+ _ <- insert' p2+ res <- personQuery+ asserting $+ res `shouldBe` Just (Value $ entityKey person)++ itDb "returns Nothing" $ do+ res <- personQuery+ asserting $+ res `shouldBe` (Nothing :: Maybe (Value PersonId))++testSelectSource :: SpecDb+testSelectSource = do+ describe "selectSource" $ do+ itDb "works for a simple example" $ do+ let query+ :: ConduitT () (Entity Person) (SqlPersistT (R.ResourceT IO)) ()+ query =+ selectSource $+ from $ \person ->+ return person+ p1e <- insert' p1+ ret <- mapReaderT R.runResourceT $ runConduit $ query .| CL.consume+ asserting $ ret `shouldBe` [ p1e ]++ itDb "can run a query many times" $ do+ let query+ :: ConduitT () (Entity Person) (SqlPersistT (R.ResourceT IO)) ()+ query =+ selectSource $+ from $ \person ->+ return person+ p1e <- insert' p1+ ret0 <- mapReaderT R.runResourceT $ runConduit $ query .| CL.consume+ ret1 <- mapReaderT R.runResourceT $ runConduit $ query .| CL.consume+ asserting $ do+ ret0 `shouldBe` [ p1e ]+ ret1 `shouldBe` [ p1e ]++ itDb "works on repro" $ do+ let selectPerson :: R.MonadResource m => String -> ConduitT () (Key Person) (SqlPersistT m) ()+ selectPerson name = do+ let source =+ selectSource $ from $ \person -> do+ where_ $ person ^. PersonName ==. val name+ return $ person ^. PersonId+ source .| CL.map unValue+ p1e <- insert' p1+ p2e <- insert' p2+ r1 <- mapReaderT R.runResourceT $ runConduit $ selectPerson (personName p1) .| CL.consume+ r2 <- mapReaderT R.runResourceT $ runConduit $ selectPerson (personName p2) .| CL.consume+ asserting $ do+ r1 `shouldBe` [ entityKey p1e ]+ r2 `shouldBe` [ entityKey p2e ]++testSelectFrom :: SpecDb+testSelectFrom = do+ describe "select/from" $ do+ itDb "works for a simple example" $ do+ p1e <- insert' p1+ ret <-+ select $+ from $ \person ->+ return person+ asserting $ ret `shouldBe` [ p1e ]++ itDb "works for a simple self-join (one entity)" $ do+ p1e <- insert' p1+ ret <-+ select $+ from $ \(person1, person2) ->+ return (person1, person2)+ asserting $ ret `shouldBe` [ (p1e, p1e) ]++ itDb "works for a simple self-join (two entities)" $ do+ p1e <- insert' p1+ p2e <- insert' p2+ ret <-+ select $+ from $ \(person1, person2) ->+ return (person1, person2)+ asserting $+ ret+ `shouldSatisfy`+ sameElementsAs+ [ (p1e, p1e)+ , (p1e, p2e)+ , (p2e, p1e)+ , (p2e, p2e)+ ]++ itDb "works for a self-join via subSelect" $ do+ p1k <- insert p1+ p2k <- insert p2+ _f1k <- insert (Follow p1k p2k)+ _f2k <- insert (Follow p2k p1k)+ ret <- select $+ from $ \followA -> do+ let subquery =+ from $ \followB -> do+ where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed+ return $ followB ^. FollowFollower+ where_ $ just (followA ^. FollowFollowed) ==. subSelect subquery+ return followA+ asserting $ length ret `shouldBe` 2++ itDb "works for a self-join via exists" $ do+ p1k <- insert p1+ p2k <- insert p2+ _f1k <- insert (Follow p1k p2k)+ _f2k <- insert (Follow p2k p1k)+ ret <- select $+ from $ \followA -> do+ where_ $ exists $+ from $ \followB ->+ where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed+ return followA+ asserting $ length ret `shouldBe` 2+++ itDb "works for a simple projection" $ do+ p1k <- insert p1+ p2k <- insert p2+ ret <- select $+ from $ \p ->+ return (p ^. PersonId, p ^. PersonName)+ asserting $ ret `shouldBe` [ (Value p1k, Value (personName p1))+ , (Value p2k, Value (personName p2)) ]++ itDb "works for a simple projection with a simple implicit self-join" $ do+ _ <- insert p1+ _ <- insert p2+ ret <- select $+ from $ \(pa, pb) ->+ return (pa ^. PersonName, pb ^. PersonName)+ asserting $ ret `shouldSatisfy` sameElementsAs+ [ (Value (personName p1), Value (personName p1))+ , (Value (personName p1), Value (personName p2))+ , (Value (personName p2), Value (personName p1))+ , (Value (personName p2), Value (personName p2)) ]++ itDb "works with many kinds of LIMITs and OFFSETs" $ do+ [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]+ let people =+ from $ \p -> do+ orderBy [asc (p ^. PersonName)]+ return p+ ret1 <-+ select $ do+ p <- people+ limit 2+ limit 1+ return p+ asserting $ ret1 `shouldBe` [ p1e ]+ ret2 <-+ select $ do+ p <- people+ limit 1+ limit 2+ return p+ asserting $ ret2 `shouldBe` [ p1e, p4e ]+ ret3 <-+ select $ do+ p <- people+ offset 3+ offset 2+ return p+ asserting $ ret3 `shouldBe` [ p3e, p2e ]+ ret4 <-+ select $ do+ p <- people+ offset 3+ limit 5+ offset 2+ limit 3+ offset 1+ limit 2+ return p+ asserting $ ret4 `shouldBe` [ p4e, p3e ]+ ret5 <-+ select $ do+ p <- people+ offset 1000+ limit 1+ limit 1000+ offset 0+ return p+ asserting $ ret5 `shouldBe` [ p1e, p4e, p3e, p2e ]++ itDb "works with non-id primary key" $ do+ let fc = Frontcover number ""+ number = 101 :: Int+ Right thePk = keyFromValues [toPersistValue number]+ fcPk <- insert fc+ [Entity _ ret] <- select $ from return+ asserting $ do+ ret `shouldBe` fc+ fcPk `shouldBe` thePk++ itDb "works when returning a custom non-composite primary key from a query" $ do+ let name = "foo"+ t = Tag name+ Right thePk = keyFromValues [toPersistValue name]+ tagPk <- insert t+ [Value ret] <- select $ from $ \t' -> return (t'^.TagId)+ asserting $ do+ ret `shouldBe` thePk+ thePk `shouldBe` tagPk++ itDb "works when returning a composite primary key from a query" $ do+ let p = Point 10 20 ""+ thePk <- insert p+ [Value ppk] <- select $ from $ \p' -> return (p'^.PointId)+ asserting $ ppk `shouldBe` thePk++testSelectJoin :: SpecDb+testSelectJoin = do+ describe "select:JOIN" $ do+ itDb "works with a LEFT OUTER JOIN" $+ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ p4e <- insert' p4+ b12e <- insert' $ BlogPost "b" (entityKey p1e)+ b11e <- insert' $ BlogPost "a" (entityKey p1e)+ b31e <- insert' $ BlogPost "c" (entityKey p3e)+ ret <- select $+ from $ \(p `LeftOuterJoin` mb) -> do+ on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)+ orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ]+ return (p, mb)+ asserting $ ret `shouldBe` [ (p1e, Just b11e)+ , (p1e, Just b12e)+ , (p4e, Nothing)+ , (p3e, Just b31e)+ , (p2e, Nothing) ]++ itDb "typechecks (A LEFT OUTER JOIN (B LEFT OUTER JOIN C))" $+ let+ _x :: SqlPersistT IO _+ _x =+ select $+ from $ \(a `LeftOuterJoin` (b `LeftOuterJoin` c)) ->+ let _ = [a, b, c] :: [ SqlExpr (Entity Person) ]+ in return a+ in asserting noExceptions++ itDb "typechecks ((A LEFT OUTER JOIN B) LEFT OUTER JOIN C)" $+ let _x :: SqlPersistT IO _+ _x =+ select $+ from $ \((a `LeftOuterJoin` b) `LeftOuterJoin` c) ->+ let _ = [a, b, c] :: [ SqlExpr (Entity Person) ]+ in return a+ in asserting noExceptions++ itDb "throws an error for using on without joins" $ do+ eres <- try $ select $+ from $ \(p, mb) -> do+ on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)+ orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ]+ return (p, mb)+ asserting $ shouldBeOnClauseWithoutMatchingJoinException eres++ itDb "throws an error for using too many ons" $ do+ eres <- try $ select $+ from $ \(p `FullOuterJoin` mb) -> do+ on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)+ on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)+ orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ]+ return (p, mb)+ asserting $ shouldBeOnClauseWithoutMatchingJoinException eres++ itDb "works with ForeignKey to a non-id primary key returning one entity" $+ do+ let fc = Frontcover number ""+ article = Article "Esqueleto supports composite pks!" number+ number = 101+ Right thePk = keyFromValues [toPersistValue number]+ fcPk <- insert fc+ insert_ article+ [Entity _ retFc] <- select $+ from $ \(a `InnerJoin` f) -> do+ on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber)+ return f+ asserting $ do+ retFc `shouldBe` fc+ fcPk `shouldBe` thePk+ itDb "allows using a primary key that is itself a key of another table" $+ do+ let number = 101+ insert_ $ Frontcover number ""+ articleId <- insert $ Article "title" number+ articleMetaE <- insert' (ArticleMetadata articleId)+ result <- select $ from $ \articleMetadata -> do+ where_ $ (articleMetadata ^. ArticleMetadataId) ==. (val ((ArticleMetadataKey articleId)))+ pure articleMetadata+ asserting $ [articleMetaE] `shouldBe` result+ itDb "allows joining between a primary key that is itself a key of another table, using ToBaseId" $ do+ do+ let number = 101+ insert_ $ Frontcover number ""+ articleE@(Entity articleId _) <- insert' $ Article "title" number+ articleMetaE <- insert' (ArticleMetadata articleId)++ articlesAndMetadata <- select $+ from $ \(article `InnerJoin` articleMetadata) -> do+ on (toBaseId (articleMetadata ^. ArticleMetadataId) ==. article ^. ArticleId)+ return (article, articleMetadata)+ asserting $ [(articleE, articleMetaE)] `shouldBe` articlesAndMetadata++ itDb "works with a ForeignKey to a non-id primary key returning both entities" $+ do+ let fc = Frontcover number ""+ article = Article "Esqueleto supports composite pks!" number+ number = 101+ Right thePk = keyFromValues [toPersistValue number]+ fcPk <- insert fc+ insert_ article+ [(Entity _ retFc, Entity _ retArt)] <- select $+ from $ \(a `InnerJoin` f) -> do+ on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber)+ return (f, a)+ asserting $ do+ retFc `shouldBe` fc+ retArt `shouldBe` article+ fcPk `shouldBe` thePk+ articleFkfrontcover retArt `shouldBe` thePk++ itDb "works with a non-id primary key returning one entity" $+ do+ let fc = Frontcover number ""+ article = Article2 "Esqueleto supports composite pks!" thePk+ number = 101+ Right thePk = keyFromValues [toPersistValue number]+ fcPk <- insert fc+ insert_ article+ [Entity _ retFc] <- select $+ from $ \(a `InnerJoin` f) -> do+ on (f^.FrontcoverId ==. a^.Article2FrontcoverId)+ return f+ asserting $ do+ retFc `shouldBe` fc+ fcPk `shouldBe` thePk++ it "works with a composite primary key" $ \_ ->+ pendingWith "Persistent does not create the CircleFkPoint constructor. See: https://github.com/yesodweb/persistent/issues/341"+ {-+ do+ let p = Point x y ""+ c = Circle x y ""+ x = 10+ y = 15+ Right thePk = keyFromValues [toPersistValue x, toPersistValue y]+ pPk <- insert p+ insert_ c+ [Entity _ ret] <- select $ from $ \(c' `InnerJoin` p') -> do+ on (p'^.PointId ==. c'^.CircleFkpoint)+ return p'+ asserting $ do+ ret `shouldBe` p+ pPk `shouldBe` thePk+ -}++ itDb "works when joining via a non-id primary key" $+ do+ let fc = Frontcover number ""+ article = Article "Esqueleto supports composite pks!" number+ tag = Tag "foo"+ otherTag = Tag "ignored"+ number = 101+ insert_ fc+ insert_ otherTag+ artId <- insert article+ tagId <- insert tag+ insert_ $ ArticleTag artId tagId+ [(Entity _ retArt, Entity _ retTag)] <- select $+ from $ \(a `InnerJoin` at `InnerJoin` t) -> do+ on (t^.TagId ==. at^.ArticleTagTagId)+ on (a^.ArticleId ==. at^.ArticleTagArticleId)+ return (a, t)+ asserting $ do+ retArt `shouldBe` article+ retTag `shouldBe` tag++ itDb "respects the associativity of joins" $+ do+ void $ insert p1+ ps <- select $ from $+ \((p :: SqlExpr (Entity Person))+ `LeftOuterJoin`+ ((_q :: SqlExpr (Entity Person))+ `InnerJoin` (_r :: SqlExpr (Entity Person)))) -> do+ on (val False) -- Inner join is empty+ on (val True)+ return p+ asserting $ (entityVal <$> ps) `shouldBe` [p1]++testSelectSubQuery :: SpecDb+testSelectSubQuery = describe "select subquery" $ do+ itDb "works" $ do+ _ <- insert' p1+ let q = do+ p <- Experimental.from $ Table @Person+ return ( p ^. PersonName, p ^. PersonAge)+ ret <- select $ Experimental.from q+ asserting $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ]++ itDb "supports sub-selecting Maybe entities" $ do+ l1e <- insert' l1+ l3e <- insert' l3+ l1Deeds <- mapM (\k -> insert' $ Deed k (entityKey l1e)) (map show [1..3 :: Int])+ let l1WithDeeds = do d <- l1Deeds+ pure (l1e, Just d)+ let q = Experimental.from $ do+ (lords :& deeds) <-+ Experimental.from $ Table @Lord+ `LeftOuterJoin` Table @Deed+ `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)+ pure (lords, deeds)++ ret <- select q+ asserting $ ret `shouldMatchList` ((l3e, Nothing) : l1WithDeeds)++ itDb "lets you order by alias" $ do+ _ <- insert' p1+ _ <- insert' p3+ let q = do+ (name, age) <-+ Experimental.from $ do+ p <- Experimental.from $ Table @Person+ return ( p ^. PersonName, p ^. PersonAge)+ orderBy [ asc age ]+ pure name+ ret <- select q+ asserting $ ret `shouldBe` [ Value $ personName p3, Value $ personName p1 ]++ itDb "supports groupBy" $ do+ l1k <- insert l1+ l3k <- insert l3+ mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])++ mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])+ let q = do+ (lord :& deed) <- Experimental.from $ Table @Lord+ `InnerJoin` Table @Deed+ `Experimental.on` (\(lord :& deed) ->+ lord ^. LordId ==. deed ^. DeedOwnerId)+ return (lord ^. LordId, deed ^. DeedId)+ q' = do+ (lordId, deedId) <- Experimental.from q+ groupBy (lordId)+ return (lordId, count deedId)+ (ret :: [(Value (Key Lord), Value Int)]) <- select q'++ asserting $ ret `shouldMatchList` [ (Value l3k, Value 7)+ , (Value l1k, Value 3) ]++ itDb "Can count results of aggregate query" $ do+ l1k <- insert l1+ l3k <- insert l3+ mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])++ mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])+ let q = do+ (lord :& deed) <- Experimental.from $ Table @Lord+ `InnerJoin` Table @Deed+ `Experimental.on` (\(lord :& deed) ->+ lord ^. LordId ==. deed ^. DeedOwnerId)+ groupBy (lord ^. LordId)+ return (lord ^. LordId, count (deed ^. DeedId))++ (ret :: [(Value Int)]) <- select $ do+ (lordId, deedCount) <- Experimental.from q+ where_ $ deedCount >. val (3 :: Int)+ return (count lordId)++ asserting $ ret `shouldMatchList` [ (Value 1) ]++ itDb "joins on subqueries" $ do+ l1k <- insert l1+ l3k <- insert l3+ mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])++ mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])+ let q = do+ (lord :& deed) <- Experimental.from $ Table @Lord+ `InnerJoin` (Experimental.from $ Table @Deed)+ `Experimental.on` (\(lord :& deed) ->+ lord ^. LordId ==. deed ^. DeedOwnerId)+ groupBy (lord ^. LordId)+ return (lord ^. LordId, count (deed ^. DeedId))+ (ret :: [(Value (Key Lord), Value Int)]) <- select q+ asserting $ ret `shouldMatchList` [ (Value l3k, Value 7)+ , (Value l1k, Value 3) ]++ itDb "flattens maybe values" $ do+ l1k <- insert l1+ l3k <- insert l3+ let q = do+ (lord :& (_, dogCounts)) <- Experimental.from $ Table @Lord+ `LeftOuterJoin` do+ lord <- Experimental.from $ Table @Lord+ pure (lord ^. LordId, lord ^. LordDogs)+ `Experimental.on` (\(lord :& (lordId, _)) ->+ just (lord ^. LordId) ==. lordId)+ groupBy (lord ^. LordId, dogCounts)+ return (lord ^. LordId, dogCounts)+ (ret :: [(Value (Key Lord), Value (Maybe Int))]) <- select q+ asserting $ ret `shouldMatchList` [ (Value l3k, Value (lordDogs l3))+ , (Value l1k, Value (lordDogs l1)) ]+ itDb "unions" $ do+ _ <- insert p1+ _ <- insert p2+ let q = Experimental.from $+ (do+ p <- Experimental.from $ Table @Person+ where_ $ not_ $ isNothing $ p ^. PersonAge+ return (p ^. PersonName))+ `union_`+ (do+ p <- Experimental.from $ Table @Person+ where_ $ isNothing $ p ^. PersonAge+ return (p ^. PersonName))+ `union_`+ (do+ p <- Experimental.from $ Table @Person+ where_ $ isNothing $ p ^. PersonAge+ return (p ^. PersonName))+ names <- select q+ asserting $ names `shouldMatchList` [ (Value $ personName p1)+ , (Value $ personName p2) ]+testSelectWhere :: SpecDb+testSelectWhere = describe "select where_" $ do+ itDb "works for a simple example with (==.)" $ do+ p1e <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonName ==. val "John")+ return p+ asserting $ ret `shouldBe` [ p1e ]++ itDb "works for a simple example with (==.) and (||.)" $ do+ p1e <- insert' p1+ p2e <- insert' p2+ _ <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonName ==. val "John" ||. p ^. PersonName ==. val "Rachel")+ return p+ asserting $ ret `shouldBe` [ p1e, p2e ]++ itDb "works for a simple example with (>.) [uses val . Just]" $ do+ p1e <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonAge >. val (Just 17))+ return p+ asserting $ ret `shouldBe` [ p1e ]++ describe "when using between" $ do+ itDb "works for a simple example with [uses just . val]" $ do+ p1e <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ ((p ^. PersonAge) `between` (just $ val 20, just $ val 40))+ return p+ asserting $ ret `shouldBe` [ p1e ]+ itDb "works for a proyected fields value" $ do+ _ <- insert' p1 >> insert' p2 >> insert' p3+ ret <-+ select $+ from $ \p -> do+ where_ $+ just (p ^. PersonFavNum)+ `between`+ (p ^. PersonAge, p ^. PersonWeight)+ asserting $ ret `shouldBe` []+ describe "when projecting composite keys" $ do+ itDb "works when using composite keys with val" $ do+ insert_ $ Point 1 2 ""+ ret <-+ select $+ from $ \p -> do+ where_ $+ p ^. PointId+ `between`+ ( val $ PointKey 1 2+ , val $ PointKey 5 6 )+ asserting $ ret `shouldBe` [()]++ describe "when using not_" $ do+ itDb "works for a single expression" $ do+ ret <-+ select $+ pure $ not_ $ val True+ asserting $ do+ ret `shouldBe` [Value False]++ itDb "works for a simple example with (>.) [uses just . val]" $ do+ _ <- insert' p1+ _ <- insert' p2+ p3e <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (not_ $ p ^. PersonAge >. just (val 17))+ return p+ asserting $ ret `shouldBe` [ p3e ]+ itDb "works with (==.) and (||.)" $ do+ _ <- insert' p1+ _ <- insert' p2+ p3e <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (not_ $ p ^. PersonName ==. val "John" ||. p ^. PersonName ==. val "Rachel")+ return p+ asserting $ ret `shouldBe` [ p3e ]+ itDb "works with (>.), (<.) and (&&.) [uses just . val]" $ do+ p1e <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (not_ $ (p ^. PersonAge >. just (val 10)) &&. (p ^. PersonAge <. just (val 30)))+ return p+ asserting $ ret `shouldBe` [ p1e ]+ itDb "works with between [uses just . val]" $ do+ _ <- insert' p1+ _ <- insert' p2+ p3e <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (not_ $ (p ^. PersonAge) `between` (just $ val 20, just $ val 40))+ return p+ asserting $ ret `shouldBe` [ p3e ]++ itDb "works with avg_" $ do+ _ <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ _ <- insert' p4+ ret <- select $+ from $ \p->+ return $ joinV $ avg_ (p ^. PersonAge)+ let testV :: Double+ testV = roundTo (4 :: Integer) $ (36 + 17 + 17) / (3 :: Double)++ retV :: [Value (Maybe Double)]+ retV = map (Value . fmap (roundTo (4 :: Integer)) . unValue) (ret :: [Value (Maybe Double)])+ asserting $ retV `shouldBe` [ Value $ Just testV ]++ itDb "works with min_" $+ do+ _ <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ _ <- insert' p4+ ret <- select $+ from $ \p->+ return $ joinV $ min_ (p ^. PersonAge)+ asserting $ ret `shouldBe` [ Value $ Just (17 :: Int) ]++ itDb "works with max_" $ do+ _ <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ _ <- insert' p4+ ret <- select $+ from $ \p->+ return $ joinV $ max_ (p ^. PersonAge)+ asserting $ ret `shouldBe` [ Value $ Just (36 :: Int) ]++ itDb "works with lower_" $ do+ p1e <- insert' p1+ p2e@(Entity _ bob) <- insert' $ Person "bob" (Just 36) Nothing 1++ -- lower(name) == 'john'+ ret1 <- select $+ from $ \p-> do+ where_ (lower_ (p ^. PersonName) ==. val (map toLower $ personName p1))+ return p+ asserting $ ret1 `shouldBe` [ p1e ]++ -- name == lower('BOB')+ ret2 <- select $+ from $ \p-> do+ where_ (p ^. PersonName ==. lower_ (val $ map toUpper $ personName bob))+ return p+ asserting $ ret2 `shouldBe` [ p2e ]++ itDb "works with round_" $ do+ ret <- select $ return $ round_ (val (16.2 :: Double))+ asserting $ ret `shouldBe` [ Value (16 :: Double) ]++ itDb "works with isNothing" $ do+ _ <- insert' p1+ p2e <- insert' p2+ _ <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ $ isNothing (p ^. PersonAge)+ return p+ asserting $ ret `shouldBe` [ p2e ]++ itDb "works with not_ . isNothing" $ do+ p1e <- insert' p1+ _ <- insert' p2+ ret <- select $+ from $ \p -> do+ where_ $ not_ (isNothing (p ^. PersonAge))+ return p+ asserting $ ret `shouldBe` [ p1e ]++ itDb "works for a many-to-many implicit join" $+ do+ p1e@(Entity p1k _) <- insert' p1+ p2e@(Entity p2k _) <- insert' p2+ _ <- insert' p3+ p4e@(Entity p4k _) <- insert' p4+ f12 <- insert' (Follow p1k p2k)+ f21 <- insert' (Follow p2k p1k)+ f42 <- insert' (Follow p4k p2k)+ f11 <- insert' (Follow p1k p1k)+ ret <- select $+ from $ \(follower, follows, followed) -> do+ where_ $ follower ^. PersonId ==. follows ^. FollowFollower &&.+ followed ^. PersonId ==. follows ^. FollowFollowed+ orderBy [ asc (follower ^. PersonName)+ , asc (followed ^. PersonName) ]+ return (follower, follows, followed)+ asserting $ ret `shouldBe` [ (p1e, f11, p1e)+ , (p1e, f12, p2e)+ , (p4e, f42, p2e)+ , (p2e, f21, p1e) ]++ itDb "works for a many-to-many explicit join" $ do+ p1e@(Entity p1k _) <- insert' p1+ p2e@(Entity p2k _) <- insert' p2+ _ <- insert' p3+ p4e@(Entity p4k _) <- insert' p4+ f12 <- insert' (Follow p1k p2k)+ f21 <- insert' (Follow p2k p1k)+ f42 <- insert' (Follow p4k p2k)+ f11 <- insert' (Follow p1k p1k)+ ret <- select $+ from $ \(follower `InnerJoin` follows `InnerJoin` followed) -> do+ on $ followed ^. PersonId ==. follows ^. FollowFollowed+ on $ follower ^. PersonId ==. follows ^. FollowFollower+ orderBy [ asc (follower ^. PersonName)+ , asc (followed ^. PersonName) ]+ return (follower, follows, followed)+ asserting $ ret `shouldBe` [ (p1e, f11, p1e)+ , (p1e, f12, p2e)+ , (p4e, f42, p2e)+ , (p2e, f21, p1e) ]++ itDb "works for a many-to-many explicit join and on order doesn't matter" $ do+ void $+ selectRethrowingQuery $+ from $ \(person `InnerJoin` blog `InnerJoin` comment) -> do+ on $ person ^. PersonId ==. blog ^. BlogPostAuthorId+ on $ blog ^. BlogPostId ==. comment ^. CommentBlog+ pure (person, comment)++ -- we only care that we don't have a SQL error+ asserting noExceptions++ itDb "works for a many-to-many explicit join with LEFT OUTER JOINs" $ do+ p1e@(Entity p1k _) <- insert' p1+ p2e@(Entity p2k _) <- insert' p2+ p3e <- insert' p3+ p4e@(Entity p4k _) <- insert' p4+ f12 <- insert' (Follow p1k p2k)+ f21 <- insert' (Follow p2k p1k)+ f42 <- insert' (Follow p4k p2k)+ f11 <- insert' (Follow p1k p1k)+ ret <- select $+ from $ \(follower `LeftOuterJoin` mfollows `LeftOuterJoin` mfollowed) -> do+ on $ mfollowed ?. PersonId ==. mfollows ?. FollowFollowed+ on $ just (follower ^. PersonId) ==. mfollows ?. FollowFollower+ orderBy [ asc ( follower ^. PersonName)+ , asc (mfollowed ?. PersonName) ]+ return (follower, mfollows, mfollowed)+ asserting $ ret `shouldBe` [ (p1e, Just f11, Just p1e)+ , (p1e, Just f12, Just p2e)+ , (p4e, Just f42, Just p2e)+ , (p3e, Nothing, Nothing)+ , (p2e, Just f21, Just p1e) ]++ itDb "works with a composite primary key" $ do+ let p = Point x y ""+ x = 10+ y = 15+ Right thePk = keyFromValues [toPersistValue x, toPersistValue y]+ pPk <- insert p+ [Entity _ ret] <- select $ from $ \p' -> do+ where_ (p'^.PointId ==. val pPk)+ return p'+ asserting $ do+ ret `shouldBe` p+ pPk `shouldBe` thePk++testSelectOrderBy :: SpecDb+testSelectOrderBy = describe "select/orderBy" $ do+ itDb "works with a single ASC field" $ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ ret <- select $+ from $ \p -> do+ orderBy [asc $ p ^. PersonName]+ return p+ asserting $ ret `shouldBe` [ p1e, p3e, p2e ]++ itDb "works with a subSelect" $ do+ [p1k, p2k, p3k, p4k] <- mapM insert [p1, p2, p3, p4]+ [b1k, b2k, b3k, b4k] <- mapM (insert . BlogPost "") [p1k, p2k, p3k, p4k]+ ret <- select $+ from $ \b -> do+ orderBy [desc $ subSelect $+ from $ \p -> do+ where_ (p ^. PersonId ==. b ^. BlogPostAuthorId)+ return (p ^. PersonName)+ ]+ return (b ^. BlogPostId)+ asserting $ ret `shouldBe` (Value <$> [b2k, b3k, b4k, b1k])++ itDb "works on a composite primary key" $ do+ let ps = [Point 2 1 "", Point 1 2 ""]+ mapM_ insert ps+ eps <- select $+ from $ \p' -> do+ orderBy [asc (p'^.PointId)]+ return p'+ asserting $ map entityVal eps `shouldBe` reverse ps++testAscRandom :: SqlExpr (Value Double) -> SpecDb+testAscRandom rand' = describe "random_" $+ itDb "asc random_ works" $ do+ _p1e <- insert' p1+ _p2e <- insert' p2+ _p3e <- insert' p3+ _p4e <- insert' p4+ rets <-+ fmap S.fromList $+ replicateM 11 $+ select $+ from $ \p -> do+ orderBy [asc (rand' :: SqlExpr (Value Double))]+ return (p ^. PersonId :: SqlExpr (Value PersonId))+ -- There are 2^4 = 16 possible orderings. The chance+ -- of 11 random samplings returning the same ordering+ -- is 1/2^40, so this test should pass almost everytime.+ asserting $ S.size rets `shouldSatisfy` (>2)++testSelectDistinct :: SpecDb+testSelectDistinct = do+ describe "SELECT DISTINCT" $ do+ let selDistTest+ ::+ ( SqlQuery (SqlExpr (Value String))+ -> SqlPersistT IO [Value String]+ )+ -> SqlPersistT IO ()+ selDistTest q = do+ p1k <- insert p1+ let (t1, t2, t3) = ("a", "b", "c")+ mapM_ (insert . flip BlogPost p1k) [t1, t3, t2, t2, t1]+ ret <- q $+ from $ \b -> do+ let title = b ^. BlogPostTitle+ orderBy [asc title]+ return title+ asserting $ ret `shouldBe` [ Value t1, Value t2, Value t3 ]++ itDb "works on a simple example (select . distinct)" $+ selDistTest (\a -> select $ distinct a)++ itDb "works on a simple example (distinct (return ()))" $+ selDistTest (\act -> select $ distinct (return ()) >> act)++++testCoasleceDefault :: SpecDb+testCoasleceDefault = describe "coalesce/coalesceDefault" $ do+ itDb "works on a simple example" $ do+ mapM_ insert' [p1, p2, p3, p4, p5]+ ret1 <- select $+ from $ \p -> do+ orderBy [asc (p ^. PersonId)]+ return (coalesce [p ^. PersonAge, p ^. PersonWeight])+ asserting $ ret1 `shouldBe` [ Value (Just (36 :: Int))+ , Value (Just 37)+ , Value (Just 17)+ , Value (Just 17)+ , Value Nothing+ ]++ ret2 <- select $+ from $ \p -> do+ orderBy [asc (p ^. PersonId)]+ return (coalesceDefault [p ^. PersonAge, p ^. PersonWeight] (p ^. PersonFavNum))+ asserting $ ret2 `shouldBe` [ Value (36 :: Int)+ , Value 37+ , Value 17+ , Value 17+ , Value 5+ ]++ itDb "works with sub-queries" $ do+ p1id <- insert p1+ p2id <- insert p2+ p3id <- insert p3+ _ <- insert p4+ _ <- insert p5+ _ <- insert $ BlogPost "a" p1id+ _ <- insert $ BlogPost "b" p2id+ _ <- insert $ BlogPost "c" p3id+ ret <- select $+ from $ \b -> do+ let sub =+ from $ \p -> do+ where_ (p ^. PersonId ==. b ^. BlogPostAuthorId)+ pure $ p ^. PersonAge+ return $ coalesceDefault [joinV $ subSelect sub] (val (42 :: Int))+ asserting $ ret `shouldBe` [ Value (36 :: Int)+ , Value 42+ , Value 17+ ]+++testDelete :: SpecDb+testDelete = describe "delete" $ do+ itDb "works on a simple example" $ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ let getAll = select $+ from $ \p -> do+ orderBy [asc (p ^. PersonName)]+ return p+ ret1 <- getAll+ asserting $ ret1 `shouldBe` [ p1e, p3e, p2e ]+ () <- delete $+ from $ \p ->+ where_ (p ^. PersonName ==. val (personName p1))+ ret2 <- getAll+ asserting $ ret2 `shouldBe` [ p3e, p2e ]+ n <- deleteCount $+ from $ \p ->+ return ((p :: SqlExpr (Entity Person)) `seq` ())+ ret3 <- getAll+ asserting $ (n, ret3) `shouldBe` (2, [])++testUpdate :: SpecDb+testUpdate = describe "update" $ do+ itDb "works with a subexpression having COUNT(*)" $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ replicateM_ 3 (insert $ BlogPost "" p1k)+ replicateM_ 7 (insert $ BlogPost "" p3k)+ let blogPostsBy p =+ from $ \b -> do+ where_ (b ^. BlogPostAuthorId ==. p ^. PersonId)+ return countRows+ () <- update $ \p -> do+ set p [ PersonAge =. subSelect (blogPostsBy p) ]+ ret <- select $+ from $ \p -> do+ orderBy [ asc (p ^. PersonName) ]+ return p+ asserting $ ret `shouldBe` [ Entity p1k p1 { personAge = Just 3 }+ , Entity p3k p3 { personAge = Just 7 }+ , Entity p2k p2 { personAge = Just 0 } ]++ it "works with a composite primary key" $ \_ ->+ pendingWith "Need refactor to support composite pks on ESet"+ {-+ do+ let p = Point x y ""+ x = 10+ y = 15+ newX = 20+ newY = 25+ Right newPk = keyFromValues [toPersistValue newX, toPersistValue newY]+ insert_ p+ () <- update $ \p' -> do+ set p' [PointId =. val newPk]+ [Entity _ ret] <- select $ from $ return+ asserting $ do+ ret `shouldBe` Point newX newY []+ -}++ itDb "GROUP BY works with COUNT" $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ replicateM_ 3 (insert $ BlogPost "" p1k)+ replicateM_ 7 (insert $ BlogPost "" p3k)+ ret <- select $+ from $ \(p `LeftOuterJoin` b) -> do+ on (p ^. PersonId ==. b ^. BlogPostAuthorId)+ groupBy (p ^. PersonId)+ let cnt = count (b ^. BlogPostId)+ orderBy [ asc cnt ]+ return (p, cnt)+ asserting $ ret `shouldBe` [ (Entity p2k p2, Value (0 :: Int))+ , (Entity p1k p1, Value 3)+ , (Entity p3k p3, Value 7) ]++ itDb "GROUP BY works with composite primary key" $ do+ p1k <- insert $ Point 1 2 "asdf"+ p2k <- insert $ Point 2 3 "asdf"+ ret <-+ selectRethrowingQuery $+ from $ \point -> do+ where_ $ point ^. PointName ==. val "asdf"+ groupBy (point ^. PointId)+ pure (point ^. PointId)+ asserting $ do+ ret `shouldMatchList`+ map Value [p1k, p2k]++++ itDb "GROUP BY works with COUNT and InnerJoin" $ do+ l1k <- insert l1+ l3k <- insert l3+ mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])++ mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])++ (ret :: [(Value (Key Lord), Value Int)]) <- select $ from $+ \ ( lord `InnerJoin` deed ) -> do+ on $ lord ^. LordId ==. deed ^. DeedOwnerId+ groupBy (lord ^. LordId)+ return (lord ^. LordId, count $ deed ^. DeedId)+ asserting $ ret `shouldMatchList` [ (Value l3k, Value 7)+ , (Value l1k, Value 3) ]++ itDb "GROUP BY works with nested tuples" $ do+ l1k <- insert l1+ l3k <- insert l3+ mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int])++ mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int])++ (ret :: [(Value (Key Lord), Value Int)]) <- select $ from $+ \ ( lord `InnerJoin` deed ) -> do+ on $ lord ^. LordId ==. deed ^. DeedOwnerId+ groupBy ((lord ^. LordId, lord ^. LordDogs), deed ^. DeedContract)+ return (lord ^. LordId, count $ deed ^. DeedId)+ asserting $ length ret `shouldBe` 10++ itDb "GROUP BY works with HAVING" $ do+ p1k <- insert p1+ _p2k <- insert p2+ p3k <- insert p3+ replicateM_ 3 (insert $ BlogPost "" p1k)+ replicateM_ 7 (insert $ BlogPost "" p3k)+ ret <- select $+ from $ \(p `LeftOuterJoin` b) -> do+ on (p ^. PersonId ==. b ^. BlogPostAuthorId)+ let cnt = count (b ^. BlogPostId)+ groupBy (p ^. PersonId)+ having (cnt >. (val 0))+ orderBy [ asc cnt ]+ return (p, cnt)+ asserting $ ret `shouldBe` [ (Entity p1k p1, Value (3 :: Int))+ , (Entity p3k p3, Value 7) ]++-- we only care that this compiles. check that SqlWriteT doesn't fail on+-- updates.+testSqlWriteT :: MonadIO m => SqlWriteT m ()+testSqlWriteT =+ update $ \p -> do+ set p [ PersonAge =. just (val 6) ]++-- we only care that this compiles. checks that the SqlWriteT monad can run+-- select queries.+testSqlWriteTRead :: MonadIO m => SqlWriteT m [(Value (Key Lord), Value Int)]+testSqlWriteTRead =+ select $+ from $ \ ( lord `InnerJoin` deed ) -> do+ on $ lord ^. LordId ==. deed ^. DeedOwnerId+ groupBy (lord ^. LordId)+ return (lord ^. LordId, count $ deed ^. DeedId)++-- we only care that this compiles checks that SqlReadT allows+testSqlReadT :: MonadIO m => SqlReadT m [(Value (Key Lord), Value Int)]+testSqlReadT =+ select $+ from $ \ ( lord `InnerJoin` deed ) -> do+ on $ lord ^. LordId ==. deed ^. DeedOwnerId+ groupBy (lord ^. LordId)+ return (lord ^. LordId, count $ deed ^. DeedId)++testListOfValues :: SpecDb+testListOfValues = describe "lists of values" $ do+ itDb "IN works for valList" $ do+ p1k <- insert p1+ p2k <- insert p2+ _p3k <- insert p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonName `in_` valList (personName <$> [p1, p2]))+ return p+ asserting $ ret `shouldBe` [ Entity p1k p1+ , Entity p2k p2 ]++ itDb "IN works for valList (null list)" $ do+ _p1k <- insert p1+ _p2k <- insert p2+ _p3k <- insert p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonName `in_` valList [])+ return p+ asserting $ ret `shouldBe` []++ itDb "IN works for subList_select" $ do+ p1k <- insert p1+ _p2k <- insert p2+ p3k <- insert p3+ _ <- insert (BlogPost "" p1k)+ _ <- insert (BlogPost "" p3k)+ ret <- select $+ from $ \p -> do+ let subquery =+ from $ \bp -> do+ orderBy [ asc (bp ^. BlogPostAuthorId) ]+ return (bp ^. BlogPostAuthorId)+ where_ (p ^. PersonId `in_` subList_select subquery)+ return p+ asserting $ L.sort ret `shouldBe` L.sort [Entity p1k p1, Entity p3k p3]++ itDb "NOT IN works for subList_select" $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ _ <- insert (BlogPost "" p1k)+ _ <- insert (BlogPost "" p3k)+ ret <- select $+ from $ \p -> do+ let subquery =+ from $ \bp ->+ return (bp ^. BlogPostAuthorId)+ where_ (p ^. PersonId `notIn` subList_select subquery)+ return p+ asserting $ ret `shouldBe` [ Entity p2k p2 ]++ itDb "NOT IN works for valList (null list)" $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonName `notIn` valList [])+ return p+ asserting $ ret `shouldMatchList` [ Entity p1k p1+ , Entity p2k p2+ , Entity p3k p3+ ]++ itDb "EXISTS works for subList_select" $ do+ p1k <- insert p1+ _p2k <- insert p2+ p3k <- insert p3+ _ <- insert (BlogPost "" p1k)+ _ <- insert (BlogPost "" p3k)+ ret <- select $+ from $ \p -> do+ where_ $ exists $+ from $ \bp -> do+ where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId)+ orderBy [asc (p ^. PersonName)]+ return p+ asserting $ ret `shouldBe` [ Entity p1k p1+ , Entity p3k p3 ]++ itDb "EXISTS works for subList_select" $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ _ <- insert (BlogPost "" p1k)+ _ <- insert (BlogPost "" p3k)+ ret <- select $+ from $ \p -> do+ where_ $ notExists $+ from $ \bp -> do+ where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId)+ return p+ asserting $ ret `shouldBe` [ Entity p2k p2 ]++testListFields :: SpecDb+testListFields = describe "list fields" $ do+ -- <https://github.com/prowdsponsor/esqueleto/issues/100>+ itDb "can update list fields" $ do+ cclist <- insert $ CcList []+ update $ \p -> do+ set p [ CcListNames =. val ["fred"]]+ where_ (p ^. CcListId ==. val cclist)+ asserting noExceptions++testInsertsBySelect :: SpecDb+testInsertsBySelect = do+ describe "inserts by select" $ do+ itDb "IN works for insertSelect" $+ do+ _ <- insert p1+ _ <- insert p2+ _ <- insert p3+ insertSelect $ from $ \p -> do+ return $ BlogPost <# val "FakePost" <&> (p ^. PersonId)+ ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows)+ asserting $ ret `shouldBe` [Value (3::Int)]++++++testInsertsBySelectReturnsCount :: SpecDb+testInsertsBySelectReturnsCount = do+ describe "inserts by select, returns count" $ do+ itDb "IN works for insertSelectCount" $+ do+ _ <- insert p1+ _ <- insert p2+ _ <- insert p3+ cnt <- insertSelectCount $ from $ \p -> do+ return $ BlogPost <# val "FakePost" <&> (p ^. PersonId)+ ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows)+ asserting $ ret `shouldBe` [Value (3::Int)]+ asserting $ cnt `shouldBe` 3++testMathFunctions :: SpecDb+testMathFunctions = do+ describe "Math-related functions" $ do+ itDb "castNum works for multiplying Int and Double" $+ do+ mapM_ insert [Numbers 2 3.4, Numbers 7 1.1]+ ret <-+ select $+ from $ \n -> do+ let r = castNum (n ^. NumbersInt) *. n ^. NumbersDouble+ orderBy [asc r]+ return r+ asserting $ length ret `shouldBe` 2+ let [Value a, Value b] = ret+ asserting $ max (abs (a - 6.8)) (abs (b - 7.7)) `shouldSatisfy` (< 0.01)++++++testCase :: SpecDb+testCase = do+ describe "case" $ do+ itDb "Works for a simple value based when - False" $+ do+ ret <- select $+ return $+ case_+ [ when_ (val False) then_ (val (1 :: Int)) ]+ (else_ (val 2))++ asserting $ ret `shouldBe` [ Value 2 ]++ itDb "Works for a simple value based when - True" $+ do+ ret <- select $+ return $+ case_+ [ when_ (val True) then_ (val (1 :: Int)) ]+ (else_ (val 2))++ asserting $ ret `shouldBe` [ Value 1 ]++ itDb "works for a semi-complicated query" $+ do+ _ <- insert p1+ _ <- insert p2+ _ <- insert p3+ _ <- insert p4+ _ <- insert p5+ ret <- select $+ return $+ case_+ [ when_+ (exists $ from $ \p -> do+ where_ (p ^. PersonName ==. val "Mike"))+ then_+ (subSelect $ from $ \v -> do+ let sub =+ from $ \c -> do+ where_ (c ^. PersonName ==. val "Mike")+ return (c ^. PersonFavNum)+ where_ (just (v ^. PersonFavNum) >. subSelect sub)+ return $ count (v ^. PersonName) +. val (1 :: Int)) ]+ (else_ $ just $ val (-1))++ asserting $ ret `shouldBe` [ Value (Just 3) ]++testLocking :: SpecDb+testLocking = do+ let toText conn q =+ let (tlb, _) = EI.toRawSql EI.SELECT (conn, EI.initialIdentState) q+ in TLB.toLazyText tlb+ complexQuery =+ from $ \(p1' `InnerJoin` p2') -> do+ on (p1' ^. PersonName ==. p2' ^. PersonName)+ where_ (p1' ^. PersonFavNum >. val 2)+ orderBy [desc (p2' ^. PersonAge)]+ limit 3+ offset 9+ groupBy (p1' ^. PersonId)+ having (countRows <. val (0 :: Int))+ return (p1', p2')+ describe "locking" $ do+ -- The locking clause is the last one, so try to use many+ -- others to test if it's at the right position. We don't+ -- care about the text of the rest, nor with the RDBMS'+ -- reaction to the clause.+ let sanityCheck kind syntax = do+ let queryWithClause1 = do+ r <- complexQuery+ locking kind+ return r+ queryWithClause2 = do+ locking ForUpdate+ r <- complexQuery+ locking ForShare+ locking kind+ return r+ queryWithClause3 = do+ locking kind+ complexQuery+ conn <- ask+ [complex, with1, with2, with3] <-+ return $+ map (toText conn) [complexQuery, queryWithClause1, queryWithClause2, queryWithClause3]+ let expected = complex <> syntax <> "\n"+ asserting $ do+ with1 `shouldBe` expected+ with2 `shouldBe` expected+ with3 `shouldBe` expected+ itDb "looks sane for ForUpdate" $ sanityCheck ForUpdate "FOR UPDATE"+ itDb "looks sane for ForUpdateSkipLocked" $ sanityCheck ForUpdateSkipLocked "FOR UPDATE SKIP LOCKED"+ itDb "looks sane for ForShare" $ sanityCheck ForShare "FOR SHARE"+ itDb "looks sane for LockInShareMode" $ sanityCheck LockInShareMode "LOCK IN SHARE MODE"++ describe "Monoid instance" $ do+ let+ multiplePostgresLockingClauses p = do+ EP.forUpdateOf p EP.skipLocked+ EP.forUpdateOf p EP.skipLocked+ EP.forShareOf p EP.skipLocked++ multipleLegacyLockingClauses = do+ locking ForShare+ locking ForUpdate++ multipleLockingQueryPostgresLast = do+ p <- Experimental.from $ table @Person+ multipleLegacyLockingClauses+ multiplePostgresLockingClauses p++ multipleLockingQueryLegacyLast = do+ p <- Experimental.from $ table @Person+ multiplePostgresLockingClauses p+ multipleLegacyLockingClauses++ expectedPostgresQuery = do+ p <- Experimental.from $ table @Person+ EP.forUpdateOf p EP.skipLocked+ EP.forUpdateOf p EP.skipLocked+ EP.forShareOf p EP.skipLocked++ expectedLegacyQuery = do+ p <- Experimental.from $ table @Person+ locking ForUpdate++ itDb "prioritizes last grouping of locks when mixing legacy and postgres specific locks" $ do++ conn <- ask+ let resPostgresLast = toText conn multipleLockingQueryPostgresLast+ resLegacyLast = toText conn multipleLockingQueryLegacyLast+ resExpectedPostgres = toText conn expectedPostgresQuery+ resExpectedLegacy = toText conn expectedLegacyQuery++ asserting $ resPostgresLast `shouldBe` resExpectedPostgres+ asserting $ resLegacyLast `shouldBe` resExpectedLegacy++testCountingRows :: SpecDb+testCountingRows = do+ describe "counting rows" $ do+ forM_ [ ("count (test A)", count . (^. PersonAge), 4)+ , ("count (test B)", count . (^. PersonWeight), 5)+ , ("countRows", const countRows, 5)+ , ("countDistinct", countDistinct . (^. PersonAge), 2) ] $+ \(title, countKind, expected) ->+ itDb (title ++ " works as expected") $+ do+ mapM_ insert+ [ Person "" (Just 1) (Just 1) 1+ , Person "" (Just 2) (Just 1) 1+ , Person "" (Just 2) (Just 1) 1+ , Person "" (Just 2) (Just 2) 1+ , Person "" Nothing (Just 3) 1]+ [Value n] <- select $ from $ return . countKind+ asserting $ (n :: Int) `shouldBe` expected++testRenderSql :: SpecDb+testRenderSql = do+ describe "testRenderSql" $ do+ itDb "works" $ do+ (queryText, queryVals) <- renderQuerySelect $+ from $ \p -> do+ where_ $ p ^. PersonName ==. val "Johhny Depp"+ pure (p ^. PersonName, p ^. PersonAge)+ -- the different backends use different quote marks, so I filter them out+ -- here instead of making a duplicate test+ asserting $ do+ Text.filter (\c -> c `notElem` ['`', '"']) queryText+ `shouldBe`+ Text.unlines+ [ "SELECT Person.name, Person.age"+ , "FROM Person"+ , "WHERE Person.name = ?"+ ]+ queryVals+ `shouldBe`+ [toPersistValue ("Johhny Depp" :: TL.Text)]++ describe "renderExpr" $ do+ itDb "renders a value" $ do+ (c, expr) <- do+ conn <- ask+ let Right c = P.mkEscapeChar conn+ let user = EI.unsafeSqlEntity (EI.I "user")+ blogPost = EI.unsafeSqlEntity (EI.I "blog_post")+ pure $ (,) c $ EI.renderExpr conn $+ user ^. PersonId ==. blogPost ^. BlogPostAuthorId+ asserting $ do+ expr+ `shouldBe`+ Text.intercalate (Text.singleton c) ["", "user", ".", "id", ""]+ <>+ " = "+ <>+ Text.intercalate (Text.singleton c) ["", "blog_post", ".", "authorId", ""]++ itDb "renders ? for a val" $ do+ expr <- ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1))+ asserting $ expr `shouldBe` "? = ?"++ beforeWith (\_ -> pure ()) $ describe "ExprParser" $ do+ let parse parser = AP.parseOnly (parser '#')+ describe "parseEscapedChars" $ do+ let subject = parse P.parseEscapedChars+ it "parses words" $ do+ subject "hello world"+ `shouldBe`+ Right "hello world"+ it "only returns a single escape-char if present" $ do+ subject "i_am##identifier##"+ `shouldBe`+ Right "i_am#identifier#"+ describe "parseEscapedIdentifier" $ do+ let subject = parse P.parseEscapedIdentifier+ it "parses the quotes out" $ do+ subject "#it's a me, mario#"+ `shouldBe`+ Right "it's a me, mario"+ it "requires a beginning and end quote" $ do+ subject "#alas, i have no end"+ `shouldSatisfy`+ isLeft+ describe "parseTableAccess" $ do+ let subject = parse P.parseTableAccess+ it "parses a table access" $ do+ subject "#foo#.#bar#"+ `shouldBe`+ Right P.TableAccess+ { P.tableAccessTable = "foo"+ , P.tableAccessColumn = "bar"+ }+ describe "onExpr" $ do+ let subject = parse P.onExpr+ it "works" $ do+ subject "#foo#.#bar# = #bar#.#baz#"+ `shouldBe` do+ Right $ S.fromList+ [ P.TableAccess+ { P.tableAccessTable = "foo"+ , P.tableAccessColumn = "bar"+ }+ , P.TableAccess+ { P.tableAccessTable = "bar"+ , P.tableAccessColumn = "baz"+ }+ ]+ it "also works with other nonsense" $ do+ subject "#foo#.#bar# = 3"+ `shouldBe` do+ Right $ S.fromList+ [ P.TableAccess+ { P.tableAccessTable = "foo"+ , P.tableAccessColumn = "bar"+ }+ ]+ it "handles a conjunction" $ do+ subject "#foo#.#bar# = #bar#.#baz# AND #bar#.#baz# > 10"+ `shouldBe` do+ Right $ S.fromList+ [ P.TableAccess+ { P.tableAccessTable = "foo"+ , P.tableAccessColumn = "bar"+ }+ , P.TableAccess+ { P.tableAccessTable = "bar"+ , P.tableAccessColumn = "baz"+ }+ ]+ it "handles ? okay" $ do+ subject "#foo#.#bar# = ?"+ `shouldBe` do+ Right $ S.fromList+ [ P.TableAccess+ { P.tableAccessTable = "foo"+ , P.tableAccessColumn = "bar"+ }+ ]+ it "handles degenerate cases" $ do+ subject "false" `shouldBe` pure mempty+ subject "true" `shouldBe` pure mempty+ subject "1 = 1" `shouldBe` pure mempty+ it "works even if an identifier isn't first" $ do+ subject "true and #foo#.#bar# = 2"+ `shouldBe` do+ Right $ S.fromList+ [ P.TableAccess+ { P.tableAccessTable = "foo"+ , P.tableAccessColumn = "bar"+ }+ ]++testOnClauseOrder :: SpecDb+testOnClauseOrder = describe "On Clause Ordering" $ do+ let+ setup :: MonadIO m => SqlPersistT m ()+ setup = do+ ja1 <- insert (JoinOne "j1 hello")+ ja2 <- insert (JoinOne "j1 world")+ jb1 <- insert (JoinTwo ja1 "j2 hello")+ jb2 <- insert (JoinTwo ja1 "j2 world")+ jb3 <- insert (JoinTwo ja2 "j2 foo")+ _ <- insert (JoinTwo ja2 "j2 bar")+ jc1 <- insert (JoinThree jb1 "j3 hello")+ jc2 <- insert (JoinThree jb1 "j3 world")+ _ <- insert (JoinThree jb2 "j3 foo")+ _ <- insert (JoinThree jb3 "j3 bar")+ _ <- insert (JoinThree jb3 "j3 baz")+ _ <- insert (JoinFour "j4 foo" jc1)+ _ <- insert (JoinFour "j4 bar" jc2)+ jd1 <- insert (JoinOther "foo")+ jd2 <- insert (JoinOther "bar")+ _ <- insert (JoinMany "jm foo hello" jd1 ja1)+ _ <- insert (JoinMany "jm foo world" jd1 ja2)+ _ <- insert (JoinMany "jm bar hello" jd2 ja1)+ _ <- insert (JoinMany "jm bar world" jd2 ja2)+ pure ()+ describe "identical results for" $ do+ itDb "three tables" $ do+ setup+ abcs <-+ select $+ from $ \(a `InnerJoin` b `InnerJoin` c) -> do+ on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)+ on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)+ pure (a, b, c)+ acbs <-+ select $+ from $ \(a `InnerJoin` b `InnerJoin` c) -> do+ on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)+ on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)+ pure (a, b, c)++ asserting $ do+ listsEqualOn abcs acbs $ \(Entity _ j1, Entity _ j2, Entity _ j3) ->+ (joinOneName j1, joinTwoName j2, joinThreeName j3)++ itDb "four tables" $ do+ setup+ xs0 <-+ select $+ from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do+ on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)+ on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)+ on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)+ pure (a, b, c, d)+ xs1 <-+ select $+ from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do+ on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)+ on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)+ on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)+ pure (a, b, c, d)+ xs2 <-+ select $+ from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do+ on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)+ on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)+ on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)+ pure (a, b, c, d)+ xs3 <-+ select $+ from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do+ on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)+ on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)+ on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)+ pure (a, b, c, d)+ xs4 <-+ select $+ from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do+ on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)+ on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)+ on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)+ pure (a, b, c, d)++ let+ getNames (j1, j2, j3, j4) =+ ( joinOneName (entityVal j1)+ , joinTwoName (entityVal j2)+ , joinThreeName (entityVal j3)+ , joinFourName (entityVal j4)+ )+ asserting $ do+ listsEqualOn xs0 xs1 getNames+ listsEqualOn xs0 xs2 getNames+ listsEqualOn xs0 xs3 getNames+ listsEqualOn xs0 xs4 getNames++ itDb "associativity of innerjoin" $ do+ setup+ xs0 <-+ select $+ from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do+ on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)+ on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)+ on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)+ pure (a, b, c, d)++ xs1 <-+ select $+ from $ \(a `InnerJoin` b `InnerJoin` (c `InnerJoin` d)) -> do+ on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)+ on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)+ on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)+ pure (a, b, c, d)++ xs2 <-+ select $+ from $ \(a `InnerJoin` (b `InnerJoin` c) `InnerJoin` d) -> do+ on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)+ on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)+ on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)+ pure (a, b, c, d)++ xs3 <-+ select $+ from $ \(a `InnerJoin` (b `InnerJoin` c `InnerJoin` d)) -> do+ on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)+ on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)+ on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)+ pure (a, b, c, d)++ let getNames (j1, j2, j3, j4) =+ ( joinOneName (entityVal j1)+ , joinTwoName (entityVal j2)+ , joinThreeName (entityVal j3)+ , joinFourName (entityVal j4)+ )+ asserting $ do+ listsEqualOn xs0 xs1 getNames+ listsEqualOn xs0 xs2 getNames+ listsEqualOn xs0 xs3 getNames++ itDb "inner join on two entities" $ do+ (xs0, xs1) <- do+ pid <- insert $ Person "hello" Nothing Nothing 3+ _ <- insert $ BlogPost "good poast" pid+ _ <- insert $ Profile "cool" pid+ xs0 <- selectRethrowingQuery $+ from $ \(p `InnerJoin` b `InnerJoin` pr) -> do+ on $ p ^. PersonId ==. b ^. BlogPostAuthorId+ on $ p ^. PersonId ==. pr ^. ProfilePerson+ pure (p, b, pr)+ xs1 <- selectRethrowingQuery $+ from $ \(p `InnerJoin` b `InnerJoin` pr) -> do+ on $ p ^. PersonId ==. pr ^. ProfilePerson+ on $ p ^. PersonId ==. b ^. BlogPostAuthorId+ pure (p, b, pr)+ pure (xs0, xs1)+ asserting $ listsEqualOn xs0 xs1 $ \(Entity _ p, Entity _ b, Entity _ pr) ->+ (personName p, blogPostTitle b, profileName pr)+ itDb "inner join on three entities" $ do+ res <- do+ pid <- insert $ Person "hello" Nothing Nothing 3+ _ <- insert $ BlogPost "good poast" pid+ _ <- insert $ BlogPost "good poast #2" pid+ _ <- insert $ Profile "cool" pid+ _ <- insert $ Reply pid "u wot m8"+ _ <- insert $ Reply pid "how dare you"++ bprr <- selectRethrowingQuery $+ from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do+ on $ p ^. PersonId ==. b ^. BlogPostAuthorId+ on $ p ^. PersonId ==. pr ^. ProfilePerson+ on $ p ^. PersonId ==. r ^. ReplyGuy+ pure (p, b, pr, r)++ brpr <- selectRethrowingQuery $+ from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do+ on $ p ^. PersonId ==. b ^. BlogPostAuthorId+ on $ p ^. PersonId ==. r ^. ReplyGuy+ on $ p ^. PersonId ==. pr ^. ProfilePerson+ pure (p, b, pr, r)++ prbr <- selectRethrowingQuery $+ from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do+ on $ p ^. PersonId ==. pr ^. ProfilePerson+ on $ p ^. PersonId ==. b ^. BlogPostAuthorId+ on $ p ^. PersonId ==. r ^. ReplyGuy+ pure (p, b, pr, r)++ prrb <- selectRethrowingQuery $+ from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do+ on $ p ^. PersonId ==. pr ^. ProfilePerson+ on $ p ^. PersonId ==. r ^. ReplyGuy+ on $ p ^. PersonId ==. b ^. BlogPostAuthorId+ pure (p, b, pr, r)++ rprb <- selectRethrowingQuery $+ from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do+ on $ p ^. PersonId ==. r ^. ReplyGuy+ on $ p ^. PersonId ==. pr ^. ProfilePerson+ on $ p ^. PersonId ==. b ^. BlogPostAuthorId+ pure (p, b, pr, r)++ rbpr <- selectRethrowingQuery $+ from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do+ on $ p ^. PersonId ==. r ^. ReplyGuy+ on $ p ^. PersonId ==. b ^. BlogPostAuthorId+ on $ p ^. PersonId ==. pr ^. ProfilePerson+ pure (p, b, pr, r)++ pure [bprr, brpr, prbr, prrb, rprb, rbpr]+ asserting $ forM_ (zip res (drop 1 (cycle res))) $ \(a, b) -> a `shouldBe` b++ itDb "many-to-many" $ do+ setup+ ac <-+ select $+ from $ \(a `InnerJoin` b `InnerJoin` c) -> do+ on (a ^. JoinOneId ==. b ^. JoinManyJoinOne)+ on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther)+ pure (a, c)++ ca <-+ select $+ from $ \(a `InnerJoin` b `InnerJoin` c) -> do+ on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther)+ on (a ^. JoinOneId ==. b ^. JoinManyJoinOne)+ pure (a, c)++ asserting $ listsEqualOn ac ca $ \(Entity _ a, Entity _ b) ->+ (joinOneName a, joinOtherName b)++ itDb "left joins on order" $ do+ setup+ ca <-+ select $+ from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do+ on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther)+ on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne)+ orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId]+ pure (a, c)+ ac <-+ select $+ from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do+ on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne)+ on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther)+ orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId]+ pure (a, c)++ asserting $ listsEqualOn ac ca $ \(Entity _ a, b) ->+ (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b)++ itDb "doesn't require an on for a crossjoin" $ do+ void $+ select $+ from $ \(a `CrossJoin` b) -> do+ pure (a :: SqlExpr (Entity JoinOne), b :: SqlExpr (Entity JoinTwo))+ asserting noExceptions++ itDb "errors with an on for a crossjoin" $ do+ eres <-+ try $+ select $+ from $ \(a `CrossJoin` b) -> do+ on $ a ^. JoinOneId ==. b ^. JoinTwoJoinOne+ pure (a, b)+ asserting $+ case eres of+ Left (OnClauseWithoutMatchingJoinException _) ->+ pure ()+ Right _ ->+ expectationFailure "Expected OnClause exception"++ itDb "left joins associativity" $ do+ setup+ ca <-+ select $+ from $ \(a `LeftOuterJoin` (b `InnerJoin` c)) -> do+ on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther)+ on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne)+ orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId]+ pure (a, c)+ ca' <-+ select $+ from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do+ on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther)+ on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne)+ orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId]+ pure (a, c)++ asserting $ listsEqualOn ca ca' $ \(Entity _ a, b) ->+ (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b)++ itDb "composes queries still" $ do+ let+ query1 =+ from $ \(foo `InnerJoin` bar) -> do+ on (foo ^. FooId ==. bar ^. BarQuux)+ pure (foo, bar)+ query2 =+ from $ \(p `LeftOuterJoin` bp) -> do+ on (p ^. PersonId ==. bp ^. BlogPostAuthorId)+ pure (p, bp)+ fid <- insert $ Foo 5+ _ <- insert $ Bar fid+ pid <- insert $ Person "hey" Nothing Nothing 30+ _ <- insert $ BlogPost "WHY" pid+ a <- select ((,) <$> query1 <*> query2)+ b <- select (flip (,) <$> query1 <*> query2)+ asserting $ listsEqualOn a (map (\(x, y) -> (y, x)) b) id++ itDb "works with joins in subselect" $ do+ select $+ from $ \(p `InnerJoin` r) -> do+ on $ p ^. PersonId ==. r ^. ReplyGuy+ pure . (,) (p ^. PersonName) $+ subSelect $+ from $ \(c `InnerJoin` bp) -> do+ on $ bp ^. BlogPostId ==. c ^. CommentBlog+ pure (c ^. CommentBody)+ asserting noExceptions++ describe "works with nested joins" $ do+ itDb "unnested" $ do+ selectRethrowingQuery $+ from $ \(f `InnerJoin` b `LeftOuterJoin` baz `InnerJoin` shoop) -> do+ on $ f ^. FooId ==. b ^. BarQuux+ on $ f ^. FooId ==. baz ^. BazBlargh+ on $ baz ^. BazId ==. shoop ^. ShoopBaz+ pure ( f ^. FooName)+ asserting noExceptions++ itDb "leftmost nesting" $ do+ selectRethrowingQuery $+ from $ \((f `InnerJoin` b) `LeftOuterJoin` baz `InnerJoin` shoop) -> do+ on $ f ^. FooId ==. b ^. BarQuux+ on $ f ^. FooId ==. baz ^. BazBlargh+ on $ baz ^. BazId ==. shoop ^. ShoopBaz+ pure ( f ^. FooName)+ asserting noExceptions+ describe "middle nesting" $ do+ itDb "direct association" $ do+ selectRethrowingQuery $+ from $ \(p `InnerJoin` (bp `LeftOuterJoin` c) `LeftOuterJoin` cr) -> do+ on $ p ^. PersonId ==. bp ^. BlogPostAuthorId+ on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog+ on $ c ?. CommentId ==. cr ?. CommentReplyComment+ pure (p,bp,c,cr)+ asserting noExceptions+ itDb "indirect association" $ do+ selectRethrowingQuery $+ from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf) -> do+ on $ f ^. FooId ==. b ^. BarQuux+ on $ f ^. FooId ==. baz ^. BazBlargh+ on $ baz ^. BazId ==. shoop ^. ShoopBaz+ on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId+ pure (f ^. FooName)+ asserting noExceptions+ itDb "indirect association across" $ do+ selectRethrowingQuery $+ from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf `InnerJoin` another `InnerJoin` yetAnother) -> do+ on $ f ^. FooId ==. b ^. BarQuux+ on $ f ^. FooId ==. baz ^. BazBlargh+ on $ baz ^. BazId ==. shoop ^. ShoopBaz+ on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId+ on $ another ^. AnotherWhy ==. baz ^. BazId+ on $ yetAnother ^. YetAnotherArgh ==. shoop ^. ShoopId+ pure (f ^. FooName)+ asserting noExceptions++ describe "rightmost nesting" $ do+ itDb "direct associations" $ do+ selectRethrowingQuery $+ from $ \(p `InnerJoin` bp `LeftOuterJoin` (c `LeftOuterJoin` cr)) -> do+ on $ p ^. PersonId ==. bp ^. BlogPostAuthorId+ on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog+ on $ c ?. CommentId ==. cr ?. CommentReplyComment+ pure (p,bp,c,cr)+ asserting noExceptions++ itDb "indirect association" $ do+ selectRethrowingQuery $+ from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop)) -> do+ on $ f ^. FooId ==. b ^. BarQuux+ on $ f ^. FooId ==. baz ^. BazBlargh+ on $ baz ^. BazId ==. shoop ^. ShoopBaz+ pure (f ^. FooName)+ asserting noExceptions++testExperimentalFrom :: SpecDb+testExperimentalFrom = do+ describe "Experimental From" $ do+ itDb "supports basic table queries" $ do+ p1e <- insert' p1+ _ <- insert' p2+ p3e <- insert' p3+ peopleWithAges <- select $ do+ people <- Experimental.from $ Table @Person+ where_ $ not_ $ isNothing $ people ^. PersonAge+ return people+ asserting $ peopleWithAges `shouldMatchList` [p1e, p3e]++ itDb "supports inner joins" $ do+ l1e <- insert' l1+ _ <- insert l2+ d1e <- insert' $ Deed "1" (entityKey l1e)+ d2e <- insert' $ Deed "2" (entityKey l1e)+ lordDeeds <- select $ do+ (lords :& deeds) <-+ Experimental.from $ Table @Lord+ `InnerJoin` Table @Deed+ `Experimental.on` (\(l :& d) -> l ^. LordId ==. d ^. DeedOwnerId)+ pure (lords, deeds)+ asserting $ lordDeeds `shouldMatchList` [ (l1e, d1e)+ , (l1e, d2e)+ ]++ itDb "supports outer joins" $ do+ l1e <- insert' l1+ l2e <- insert' l2+ d1e <- insert' $ Deed "1" (entityKey l1e)+ d2e <- insert' $ Deed "2" (entityKey l1e)+ lordDeeds <- select $ do+ (lords :& deeds) <-+ Experimental.from $ Table @Lord+ `LeftOuterJoin` Table @Deed+ `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)++ pure (lords, deeds)+ asserting $ lordDeeds `shouldMatchList` [ (l1e, Just d1e)+ , (l1e, Just d2e)+ , (l2e, Nothing)+ ]+ itDb "supports delete" $ do+ insert_ l1+ insert_ l2+ insert_ l3+ delete $ void $ Experimental.from $ Table @Lord+ lords <- select $ Experimental.from $ Table @Lord+ asserting $ lords `shouldMatchList` []++ itDb "supports implicit cross joins" $ do+ l1e <- insert' l1+ l2e <- insert' l2+ ret <- select $ do+ lords1 <- Experimental.from $ Table @Lord+ lords2 <- Experimental.from $ Table @Lord+ pure (lords1, lords2)+ ret2 <- select $ do+ (lords1 :& lords2) <- Experimental.from $ Table @Lord `CrossJoin` Table @Lord+ pure (lords1,lords2)+ asserting $ ret `shouldMatchList` ret2+ asserting $ ret `shouldMatchList` [ (l1e, l1e)+ , (l1e, l2e)+ , (l2e, l1e)+ , (l2e, l2e)+ ]++ itDb "compiles" $ do+ let q = do+ (persons :& profiles :& posts) <-+ Experimental.from $ Table @Person+ `InnerJoin` Table @Profile+ `Experimental.on` (\(people :& profiles) ->+ people ^. PersonId ==. profiles ^. ProfilePerson)+ `LeftOuterJoin` Table @BlogPost+ `Experimental.on` (\(people :& _ :& posts) ->+ just (people ^. PersonId) ==. posts ?. BlogPostAuthorId)+ pure (persons, posts, profiles)+ asserting noExceptions++ itDb "can call functions on aliased values" $ do+ insert_ p1+ insert_ p3+ -- Pretend this isnt all posts+ upperNames <- select $ do+ author <- Experimental.from $ Experimental.from $ Table @Person+ pure $ upper_ $ author ^. PersonName++ asserting $ upperNames `shouldMatchList` [ Value "JOHN"+ , Value "MIKE"+ ]+ itDb "allows re-using (:&) joined tables" $ do+ let q = do+ result@(persons :& profiles :& posts) <-+ Experimental.from $ Table @Person+ `InnerJoin` Table @Profile+ `Experimental.on` (\(people :& profiles) ->+ people ^. PersonId ==. profiles ^. ProfilePerson)+ `InnerJoin` Table @BlogPost+ `Experimental.on` (\(people :& _ :& posts) ->+ people ^. PersonId ==. posts ^. BlogPostAuthorId)+ pure result+ rows <- select $ do+ (persons :& profiles :& posts) <- Experimental.from $ q+ pure (persons ^. PersonId, profiles ^. ProfileId, posts ^. BlogPostId)+ let result = rows :: [(Value PersonId, Value ProfileId, Value BlogPostId)]+ -- We don't care about the result of the query, only that it+ -- rendered & executed.+ asserting noExceptions++listsEqualOn :: (HasCallStack, Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) -> Expectation+listsEqualOn a b f = map f a `shouldBe` map f b++tests :: SpecDb+tests =+ describe "Esqueleto" $ do+ testSelect+ testGetTable+ testSubSelect+ testSelectOne+ testSelectSource+ testSelectFrom+ testSelectJoin+ testSelectSubQuery+ testSelectWhere+ testSelectOrderBy+ testSelectDistinct+ testCoasleceDefault+ testDelete+ testUpdate+ testListOfValues+ testListFields+ testInsertsBySelect+ testMathFunctions+ testCase+ testCountingRows+ testRenderSql+ testOnClauseOrder+ testExperimentalFrom+ testLocking+ testOverloadedRecordDot+ testDeriveEsqueletoRecord+ CTESpec.testCTE++insert' :: ( Functor m+ , BaseBackend backend ~ PersistEntityBackend val+ , PersistStore backend+ , MonadIO m+#if MIN_VERSION_persistent(2,14,0)+ , SafeToInsert val+#endif+ , PersistEntity val )+ => val -> ReaderT backend m (Entity val)+insert' v = flip Entity v <$> insert v+++-- With SQLite and in-memory databases, a separate connection implies a+-- separate database. With 'actual databases', the data is persistent and+-- thus must be cleaned after each test.+-- TODO: there is certainly a better way...+cleanDB+ :: forall m. _+ => SqlPersistT m ()+cleanDB = do+ delete $ from $ \(_ :: SqlExpr (Entity Bar)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity Foo)) -> return ()++ delete $ from $ \(_ :: SqlExpr (Entity Reply)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity Comment)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity Profile)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity BlogPost)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity Follow)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity Person)) -> return ()++ delete $ from $ \(_ :: SqlExpr (Entity Deed)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity Lord)) -> return ()++ delete $ from $ \(_ :: SqlExpr (Entity CcList)) -> return ()++ delete $ from $ \(_ :: SqlExpr (Entity ArticleTag)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity ArticleMetadata)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity Article)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity Article2)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity Tag)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity Frontcover)) -> return ()++ delete $ from $ \(_ :: SqlExpr (Entity Circle)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity Point)) -> return ()++ delete $ from $ \(_ :: SqlExpr (Entity Numbers)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity JoinMany)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity JoinFour)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity JoinThree)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity JoinTwo)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity JoinOne)) -> return ()+ delete $ from $ \(_ :: SqlExpr (Entity JoinOther)) -> return ()++ delete $ from $ \(_ :: SqlExpr (Entity DateTruncTest)) -> pure ()+++cleanUniques+ :: forall m. MonadIO m+ => SqlPersistT m ()+cleanUniques =+ delete $ from $ \(_ :: SqlExpr (Entity OneUnique)) -> return ()++selectRethrowingQuery+ :: (MonadIO m, EI.SqlSelect a r, MonadUnliftIO m)+ => SqlQuery a+ -> SqlPersistT m [r]+selectRethrowingQuery query =+ select query+ `catch` \(SomeException e) -> do+ (text, _) <- renderQuerySelect query+ liftIO . throwIO . userError $ Text.unpack text <> "\n\n" <> show e++updateRethrowingQuery+ ::+ ( MonadUnliftIO m+ , PersistEntity val+ , BackendCompatible SqlBackend (PersistEntityBackend val)+ )+ => (SqlExpr (Entity val) -> SqlQuery ())+ -> SqlWriteT m ()+updateRethrowingQuery k =+ update k+ `catch` \(SomeException e) -> do+ (text, _) <- renderQueryUpdate (from k)+ liftIO . throwIO . userError $ Text.unpack text <> "\n\n" <> show e++shouldBeOnClauseWithoutMatchingJoinException+ :: (HasCallStack, Show a)+ => Either SomeException a+ -> Expectation+shouldBeOnClauseWithoutMatchingJoinException ea =+ case ea of+ Left (fromException -> Just OnClauseWithoutMatchingJoinException {}) ->+ pure ()+ _ ->+ expectationFailure $ "Expected OnClauseWithMatchingJoinException, got: " <> show ea++testOverloadedRecordDot :: SpecDb+testOverloadedRecordDot = describe "OverloadedRecordDot" $ do+#if __GLASGOW_HASKELL__ >= 902+ describe "with SqlExpr (Entity rec)" $ do+ itDb "lets you project from a record" $ do+ select $ do+ bp <- Experimental.from $ table @BlogPost+ pure bp.title+ describe "with SqlExpr (Maybe (Entity rec))" $ do+ itDb "lets you project from a Maybe record" $ do+ void $ select $ do+ p :& mbp <- Experimental.from $+ table @Person+ `leftJoin` table @BlogPost+ `Experimental.on` do+ \(p :& mbp) ->+ just p.id ==. mbp.authorId+ pure (p.id, mbp.title)++ itDb "joins Maybe together" $ do+ void $ select $ do+ deed :& lord <-+ Experimental.from $+ table @Deed+ `leftJoin` table @Lord+ `Experimental.on` do+ \(deed :& lord) ->+ lord.id ==. just deed.ownerId+ where_ $ lord.dogs >=. just (val 10)+ where_ $ joinV lord.dogs >=. just (just (val 10))+ where_ $ lord.dogs >=. just (val (Just 10))++ itDb "i didn't bork ?." $ do+ weights <- select $ do+ (pro :& per) <- Experimental.from $+ table @Profile+ `leftJoin` table @Person+ `Experimental.on` do+ \(pro :& per) ->+ just (pro ^. #person) ==. per ?. #id+ &&. just pro.person ==. per ?. PersonId+ pure $ per ?. #weight+ asserting $ do+ weights `shouldBe` ([] :: [Value (Maybe Int)])++++#else+ it "is only supported in GHC 9.2 or above" $ \_ -> do+ pending+#endif++testGetTable :: SpecDb+testGetTable =+ describe "GetFirstTable" $ do+ itDb "works to make long join chains easier" $ do+ select $ do+ (person :& blogPost :& profile :& reply) <-+ Experimental.from $+ table @Person+ `leftJoin` table @BlogPost+ `Experimental.on` do+ \(p :& bp) ->+ just (p ^. PersonId) ==. bp ?. BlogPostAuthorId+ `leftJoin` table @Profile+ `Experimental.on` do+ \((getTable @Person -> p) :& profile) ->+ just (p ^. PersonId) ==. profile ?. ProfilePerson+ `leftJoin` table @Reply+ `Experimental.on` do+ \((getTable @Person -> p) :& reply) ->+ just (p ^. PersonId) ==. reply ?. ReplyGuy+ pure (person, blogPost, profile, reply)+ asserting noExceptions++assertJust :: HasCallStack => Maybe a -> IO a+assertJust = maybe (expectationFailure "Expected Just, got Nothing" >> error "asdf") pure
+ test/Common/Test/CTE.hs view
@@ -0,0 +1,35 @@+{-# language TypeApplications #-}++module Common.Test.CTE where++import Common.Test.Models+import Common.Test.Import+import Database.Persist.TH++testCTE :: SpecDb+testCTE = describe "CTE" $ do+ itDb "can refer to the same CTE twice" $ do+ let q :: SqlQuery (SqlExpr (Value Int), SqlExpr (Value Int))+ q = do+ bCte <- with $ do+ b <- from $ table @B+ pure b++ a :& b1 :& b2 <- from $+ table @A+ `innerJoin` bCte+ `on` do+ \(a :& b) ->+ a ^. AK ==. b ^. BK+ `innerJoin` bCte+ `on` do+ \(a :& _ :& b2) ->+ a ^. AK ==. b2 ^. BK+ pure (a ^. AK, a ^. AV +. b1 ^. BV +. b2 ^. BV)+ insert_ $ A { aK = 1, aV = 2 }+ insert_ $ B { bK = 1, bV = 3 }+ ret <- select q+ asserting $ do+ ret `shouldMatchList`+ [ (Value 1, Value (2 + 3 + 3))+ ]
+ test/Common/Test/Import.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP, AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module Common.Test.Import+ ( module Common.Test.Import+ , module X+ ) where++import System.Environment+import Control.Applicative+import Common.Test.Models as X+import Database.Esqueleto.Experimental as X hiding (random_)+import Test.Hspec as X+import UnliftIO as X+import Control.Monad+import Test.QuickCheck+import Data.Text as X (Text)+import Control.Monad.Trans.Reader as X (ReaderT, mapReaderT, ask)++type SpecDb = SpecWith ConnectionPool++asserting :: MonadIO f => IO () -> SqlPersistT f ()+asserting a = liftIO a++noExceptions :: Expectation+noExceptions = pure ()++itDb+ :: (HasCallStack)+ => String+ -> SqlPersistT IO x+ -> SpecDb+itDb message action = do+ it message $ \connection -> do+ void $ testDb connection action++propDb+ :: (HasCallStack, Testable a)+ => String+ -> ((SqlPersistT IO () -> IO ()) -> a )+ -> SpecDb+propDb message action = do+ it message $ \connection -> do+ property (action (testDb connection))++testDb :: ConnectionPool -> SqlPersistT IO a -> IO a+testDb conn action =+ liftIO $ flip runSqlPool conn $ do+ a <- action+ transactionUndo+ pure a++setDatabaseState+ :: SqlPersistT IO a+ -> SqlPersistT IO ()+ -> SpecWith ConnectionPool+ -> SpecWith ConnectionPool+setDatabaseState create clean test =+ beforeWith (\conn -> runSqlPool create conn >> pure conn) $+ after (\conn -> runSqlPool clean conn) $+ test++isCI :: IO Bool+isCI = do+ env <- getEnvironment+ return $ case lookup "TRAVIS" env <|> lookup "CI" env of+ Just "true" -> True+ _ -> False
+ test/Common/Test/Models.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module Common.Test.Models where++import Data.Time+import Database.Esqueleto.Experimental+import Database.Persist.Sql+import Database.Persist.TH++share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|+ Foo+ name Int+ Primary name+ deriving Show Eq Ord+ Bar+ quux FooId+ deriving Show Eq Ord+ Baz+ blargh FooId+ deriving Show Eq+ Shoop+ baz BazId+ deriving Show Eq+ Asdf+ shoop ShoopId+ deriving Show Eq+ Another+ why BazId+ YetAnother+ argh ShoopId++ Person+ name String+ age Int Maybe+ weight Int Maybe+ favNum Int+ deriving Eq Show Ord+ BlogPost+ title String+ authorId PersonId+ deriving Eq Show+ Comment+ body String+ blog BlogPostId+ deriving Eq Show+ CommentReply+ body String+ comment CommentId+ Profile+ name String+ person PersonId+ deriving Eq Show+ Reply+ guy PersonId+ body String+ deriving Eq Show++ Lord+ county String maxlen=100+ dogs Int Maybe+ Primary county+ deriving Eq Show++ Deed+ contract String maxlen=100+ ownerId LordId maxlen=100+ Primary contract+ deriving Eq Show++ Follow+ follower PersonId+ followed PersonId+ deriving Eq Show++ CcList+ names [String]++ Frontcover+ number Int+ title String+ Primary number+ deriving Eq Show+ Article+ title String+ frontcoverNumber Int+ Foreign Frontcover fkfrontcover frontcoverNumber+ deriving Eq Show+ ArticleMetadata+ articleId ArticleId+ Primary articleId+ deriving Eq Show+ Tag+ name String maxlen=100+ Primary name+ deriving Eq Show+ ArticleTag+ articleId ArticleId+ tagId TagId maxlen=100+ Primary articleId tagId+ deriving Eq Show+ Article2+ title String+ frontcoverId FrontcoverId+ deriving Eq Show+ Point+ x Int+ y Int+ name String+ Primary x y+ deriving Eq Show+ Circle+ centerX Int+ centerY Int+ name String+ Foreign Point fkpoint centerX centerY+ deriving Eq Show+ Numbers+ int Int+ double Double+ deriving Eq Show++ JoinOne+ name String+ deriving Eq Show++ JoinTwo+ joinOne JoinOneId+ name String+ deriving Eq Show++ JoinThree+ joinTwo JoinTwoId+ name String+ deriving Eq Show++ JoinFour+ name String+ joinThree JoinThreeId+ deriving Eq Show++ JoinOther+ name String+ deriving Eq Show++ JoinMany+ name String+ joinOther JoinOtherId+ joinOne JoinOneId+ deriving Eq Show++ DateTruncTest+ created UTCTime+ deriving Eq Show++ User+ address AddressId Maybe+ name String+ deriving Show+ deriving Eq++ Address+ address String+ deriving Show+ deriving Eq++ A+ k Int+ v Int+ Primary k++ B+ k Int+ v Int+ Primary k+|]++-- Unique Test schema+share [mkPersist sqlSettings, mkMigrate "migrateUnique"] [persistUpperCase|+ OneUnique+ name String+ value Int+ UniqueValue value+ deriving Eq Show+|]+++instance ToBaseId ArticleMetadata where+ type BaseEnt ArticleMetadata = Article+ toBaseIdWitness articleId = ArticleMetadataKey articleId
+ test/Common/Test/Select.hs view
@@ -0,0 +1,22 @@+module Common.Test.Select where++import Common.Test.Import++testSelect :: SpecDb+testSelect = do+ describe "select" $ do+ itDb "works for a single value" $ do+ ret <- select $ return $ val (3 :: Int)+ asserting $ ret `shouldBe` [ Value 3 ]++ itDb "works for a pair of a single value and ()" $ do+ ret <- select $ return (val (3 :: Int), ())+ asserting $ ret `shouldBe` [ (Value 3, ()) ]++ itDb "works for a single ()" $ do+ ret <- select $ return ()+ asserting $ ret `shouldBe` [ () ]++ itDb "works for a single NULL value" $ do+ ret <- select $ return nothing+ asserting $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ]
test/MySQL/Test.hs view
@@ -1,47 +1,42 @@-{-# LANGUAGE ScopedTypeVariables- , FlexibleContexts- , RankNTypes- , TypeFamilies- , TypeApplications-#-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} -module Main (main) where+module MySQL.Test where +import Common.Test.Import hiding (from, on)++import Control.Applicative import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT)-import Control.Monad.Trans.Reader (ReaderT)-import Database.Persist.MySQL ( withMySQLConn- , connectHost- , connectDatabase- , connectUser- , connectPassword- , defaultConnectInfo)+import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)+import Control.Monad.Trans.Reader (ReaderT, mapReaderT)+import qualified Control.Monad.Trans.Resource as R import Database.Esqueleto import Database.Esqueleto.Experimental hiding (from, on) import qualified Database.Esqueleto.Experimental as Experimental-import qualified Control.Monad.Trans.Resource as R+import Database.Persist.MySQL+ ( connectDatabase+ , connectHost+ , connectPassword+ , connectPort+ , connectUser+ , createMySQLPool+ , defaultConnectInfo+ , withMySQLConn+ )+ import Test.Hspec import Common.Test----- testMysqlRandom :: Spec--- testMysqlRandom = do--- -- This is known not to work until--- -- we can differentiate behavior by database--- it "works with random_" $--- run $ do--- _ <- select $ return (random_ :: SqlExpr (Value Double))--- return ()---+import Data.Maybe (fromMaybe)+import System.Environment (lookupEnv) -testMysqlSum :: Spec+testMysqlSum :: SpecDb testMysqlSum = do- it "works with sum_" $- run $ do+ itDb "works with sum_" $ do _ <- insert' p1 _ <- insert' p2 _ <- insert' p3@@ -51,13 +46,9 @@ return $ joinV $ sum_ (p ^. PersonAge) liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Double ) ] ----testMysqlTwoAscFields :: Spec+testMysqlTwoAscFields :: SpecDb testMysqlTwoAscFields = do- it "works with two ASC fields (one call)" $- run $ do+ itDb "works with two ASC fields (one call)" $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3@@ -68,13 +59,9 @@ return p liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ] ----testMysqlOneAscOneDesc :: Spec+testMysqlOneAscOneDesc :: SpecDb testMysqlOneAscOneDesc = do- it "works with one ASC and one DESC field (two calls)" $- run $ do+ itDb "works with one ASC and one DESC field (two calls)" $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3@@ -89,10 +76,9 @@ -testMysqlCoalesce :: Spec+testMysqlCoalesce :: SpecDb testMysqlCoalesce = do- it "works on PostgreSQL and MySQL with <2 arguments" $- run $ do+ itDb "works on PostgreSQL and MySQL with <2 arguments" $ do _ :: [Value (Maybe Int)] <- select $ from $ \p -> do@@ -102,10 +88,9 @@ -testMysqlUpdate :: Spec+testMysqlUpdate :: SpecDb testMysqlUpdate = do- it "works on a simple example" $- run $ do+ itDb "works on a simple example" $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3@@ -128,20 +113,13 @@ , Entity p1k (Person anon (Just 73) Nothing 1) , Entity p3k p3 ] ----nameContains :: (BaseBackend backend ~ SqlBackend,- BackendCompatible SqlBackend backend,- MonadIO m, SqlString s,- IsPersistBackend backend, PersistQueryRead backend,- PersistUniqueRead backend)+nameContains :: (SqlString s) => (SqlExpr (Value [Char]) -> SqlExpr (Value s) -> SqlExpr (Value Bool)) -> s -> [Entity Person]- -> ReaderT backend m ()+ -> SqlPersistT IO () nameContains f t expected = do ret <- select $ from $ \p -> do@@ -153,22 +131,20 @@ liftIO $ ret `shouldBe` expected -testMysqlTextFunctions :: Spec+testMysqlTextFunctions :: SpecDb testMysqlTextFunctions = do describe "text functions" $ do- it "like, (%) and (++.) work on a simple example" $- run $ do+ itDb "like, (%) and (++.) work on a simple example" $ do [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] nameContains like "h" [p1e, p2e] nameContains like "i" [p4e, p3e] nameContains like "iv" [p4e] -testMysqlUnionWithLimits :: Spec+testMysqlUnionWithLimits :: SpecDb testMysqlUnionWithLimits = do describe "MySQL Union" $ do- it "supports limit/orderBy by parenthesizing" $ do- run $ do+ itDb "supports limit/orderBy by parenthesizing" $ do mapM_ (insert . Foo) [1..6] let q1 = do@@ -186,61 +162,65 @@ pure $ foo ^. FooName - ret <- select $ Experimental.from $ SelectQuery q1 `Union` SelectQuery q2+ ret <- select $ Experimental.from $ q1 `union_` q2 liftIO $ ret `shouldMatchList` [Value 1, Value 2, Value 4, Value 5] --main :: IO ()-main = do- hspec $ do- tests run-- describe "Test MySQL locking" $ do- testLocking withConn+spec :: Spec+spec = beforeAll mkConnectionPool $ do+ tests describe "MySQL specific tests" $ do- -- definitely doesn't work at the moment- -- testMysqlRandom- testMysqlSum- testMysqlTwoAscFields- testMysqlOneAscOneDesc- testMysqlCoalesce- testMysqlUpdate- testMysqlTextFunctions- testMysqlUnionWithLimits-----run, runSilent, runVerbose :: Run-runSilent act = runNoLoggingT $ run_worker act-runVerbose act = runStderrLoggingT $ run_worker act-run =- if verbose- then runVerbose- else runSilent-+ -- definitely doesn't work at the moment+ -- testMysqlRandom+ testMysqlSum+ testMysqlTwoAscFields+ testMysqlOneAscOneDesc+ testMysqlCoalesce+ testMysqlUpdate+ testMysqlTextFunctions+ testMysqlUnionWithLimits verbose :: Bool verbose = False --run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a-run_worker act = withConn $ runSqlConn (migrateIt >> act)---migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) ()+migrateIt :: R.MonadUnliftIO m => SqlPersistT m () migrateIt = do- void $ runMigrationSilent migrateAll+ mapReaderT R.runResourceT $ void $ runMigrationSilent migrateAll cleanDB +mkConnectionPool :: IO ConnectionPool+mkConnectionPool = do+ ci <- isCI+ mysqlHost <- (fromMaybe "localhost" <$> lookupEnv "MYSQL_HOST")+ let connInfo+ | ci =+ defaultConnectInfo+ { connectHost = "127.0.0.1"+ , connectUser = "travis"+ , connectPassword = "esqutest"+ , connectDatabase = "esqutest"+ , connectPort = 33306+ }+ | otherwise =+ defaultConnectInfo+ { connectHost = mysqlHost+ , connectUser = "travis"+ , connectPassword = "esqutest"+ , connectDatabase = "esqutest"+ , connectPort = 3306+ }+ pool <-+ if verbose+ then+ runStderrLoggingT $+ createMySQLPool connInfo 4+ else+ runNoLoggingT $+ createMySQLPool connInfo 4 -withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a-withConn =- R.runResourceT .- withMySQLConn defaultConnectInfo- { connectHost = "localhost"- , connectUser = "travis"- , connectPassword = ""- , connectDatabase = "esqutest"- }++ flip runSqlPool pool $ do+ migrateIt+ cleanDB++ pure pool
test/PostgreSQL/MigrateJSON.hs view
@@ -1,36 +1,36 @@-{-# LANGUAGE FlexibleContexts- , GADTs- , GeneralizedNewtypeDeriving- , DerivingStrategies- , StandaloneDeriving- , MultiParamTypeClasses- , OverloadedStrings- , QuasiQuotes- , RankNTypes- , ScopedTypeVariables- , TemplateHaskell- , TypeFamilies- , UndecidableInstances- #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+ module PostgreSQL.MigrateJSON where -import Control.Monad.Trans.Resource (ResourceT)+import Common.Test.Import hiding (Value, from, on)+ import Data.Aeson (Value)-import Database.Esqueleto (SqlExpr, delete, from)+import Database.Esqueleto.Legacy (from) import Database.Esqueleto.PostgreSQL.JSON (JSONB)-import Database.Persist (Entity)-import Database.Persist.Sql (SqlPersistT) import Database.Persist.TH -import Common.Test (RunDbMonad)- -- JSON Table for PostgreSQL share [mkPersist sqlSettings, mkMigrate "migrateJSON"] [persistUpperCase| Json value (JSONB Value)+ deriving Show |] cleanJSON- :: (forall m. RunDbMonad m- => SqlPersistT (ResourceT m) ())+ :: forall m. MonadIO m+ => SqlPersistT m () cleanJSON = delete $ from $ \(_ :: SqlExpr (Entity Json)) -> return ()
test/PostgreSQL/Test.hs view
@@ -1,1270 +1,1827 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# LANGUAGE FlexibleContexts- , LambdaCase- , NamedFieldPuns- , OverloadedStrings- , RankNTypes- , ScopedTypeVariables- , TypeApplications- , TypeFamilies- , PartialTypeSignatures- #-}-module Main (main) where--import Data.Coerce-import Data.Foldable-import qualified Data.Map.Strict as Map-import Data.Map (Map)-import Data.Time-import Control.Arrow ((&&&))-import Control.Monad (void, when)-import Control.Monad.Catch (MonadCatch, catch)-import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT)-import Control.Monad.Trans.Reader (ReaderT, ask)-import qualified Control.Monad.Trans.Resource as R-import Data.Aeson hiding (Value)-import qualified Data.Aeson as A (Value)-import Data.ByteString (ByteString)-import qualified Data.Char as Char-import qualified Data.List as L-import Data.Ord (comparing)-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import Data.Time.Clock (getCurrentTime, diffUTCTime, UTCTime)-import Database.Esqueleto hiding (random_)-import qualified Database.Esqueleto.Internal.Sql as ES-import Database.Esqueleto.PostgreSQL (random_)-import qualified Database.Esqueleto.PostgreSQL as EP-import Database.Esqueleto.PostgreSQL.JSON hiding ((?.), (-.), (||.))-import qualified Database.Esqueleto.PostgreSQL.JSON as JSON-import Database.Persist.Postgresql (withPostgresqlConn)-import Database.PostgreSQL.Simple (SqlError(..), ExecStatus(..))-import System.Environment-import Test.Hspec-import Test.Hspec.QuickCheck--import Common.Test-import PostgreSQL.MigrateJSON----testPostgresqlCoalesce :: Spec-testPostgresqlCoalesce = do- it "works on PostgreSQL and MySQL with <2 arguments" $- run $ do- _ :: [Value (Maybe Int)] <-- select $- from $ \p -> do- return (coalesce [p ^. PersonAge])- return ()--nameContains :: (BaseBackend backend ~ SqlBackend,- BackendCompatible SqlBackend backend,- MonadIO m, SqlString s,- IsPersistBackend backend, PersistQueryRead backend,- PersistUniqueRead backend)- => (SqlExpr (Value [Char])- -> SqlExpr (Value s)- -> SqlExpr (Value Bool))- -> s- -> [Entity Person]- -> ReaderT backend m ()-nameContains f t expected = do- ret <- select $- from $ \p -> do- where_ (f- (p ^. PersonName)- ((%) ++. val t ++. (%)))- orderBy [asc (p ^. PersonName)]- return p- liftIO $ ret `shouldBe` expected---testPostgresqlTextFunctions :: Spec-testPostgresqlTextFunctions = do- describe "text functions" $ do- it "like, (%) and (++.) work on a simple example" $- run $ do- [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]- nameContains like "h" [p1e, p2e]- nameContains like "i" [p4e, p3e]- nameContains like "iv" [p4e]-- it "ilike, (%) and (++.) work on a simple example on PostgreSQL" $- run $ do- [p1e, _, p3e, _, p5e] <- mapM insert' [p1, p2, p3, p4, p5]- let nameContains' t expected = do- ret <- select $- from $ \p -> do- where_ (p ^. PersonName `ilike` (%) ++. val t ++. (%))- orderBy [asc (p ^. PersonName)]- return p- liftIO $ ret `shouldBe` expected- nameContains' "mi" [p3e, p5e]- nameContains' "JOHN" [p1e]------testPostgresqlUpdate :: Spec-testPostgresqlUpdate = do- it "works on a simple example" $- run $ do- p1k <- insert p1- p2k <- insert p2- p3k <- insert p3- let anon = "Anonymous"- () <- update $ \p -> do- set p [ PersonName =. val anon- , PersonAge *=. just (val 2) ]- where_ (p ^. PersonName !=. val "Mike")- n <- updateCount $ \p -> do- set p [ PersonAge +=. just (val 1) ]- where_ (p ^. PersonName !=. val "Mike")- ret <- select $- from $ \p -> do- orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ]- return p- -- PostgreSQL: nulls are bigger than data, and update returns- -- matched rows, not actually changed rows.- liftIO $ n `shouldBe` 2- liftIO $ ret `shouldBe` [ Entity p1k (Person anon (Just 73) Nothing 1)- , Entity p2k (Person anon Nothing (Just 37) 2)- , Entity p3k p3 ]------testPostgresqlRandom :: Spec-testPostgresqlRandom = do- it "works with random_" $- run $ do- _ <- select $ return (random_ :: SqlExpr (Value Double))- return ()------testPostgresqlSum :: Spec-testPostgresqlSum = do- it "works with sum_" $- run $ do- _ <- insert' p1- _ <- insert' p2- _ <- insert' p3- _ <- insert' p4- ret <- select $- from $ \p->- return $ joinV $ sum_ (p ^. PersonAge)- liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Rational ) ]------testPostgresqlTwoAscFields :: Spec-testPostgresqlTwoAscFields = do- it "works with two ASC fields (one call)" $- run $ do- p1e <- insert' p1- p2e <- insert' p2- p3e <- insert' p3- p4e <- insert' p4- ret <- select $- from $ \p -> do- orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)]- return p- -- in PostgreSQL nulls are bigger than everything- liftIO $ ret `shouldBe` [ p4e, p3e, p1e , p2e ]------testPostgresqlOneAscOneDesc :: Spec-testPostgresqlOneAscOneDesc = do- it "works with one ASC and one DESC field (two calls)" $- run $ do- p1e <- insert' p1- p2e <- insert' p2- p3e <- insert' p3- p4e <- insert' p4- ret <- select $- from $ \p -> do- orderBy [desc (p ^. PersonAge)]- orderBy [asc (p ^. PersonName)]- return p- liftIO $ ret `shouldBe` [ p2e, p1e, p4e, p3e ]------testSelectDistinctOn :: Spec-testSelectDistinctOn = do- describe "SELECT DISTINCT ON" $ do- it "works on a simple example" $ do- run $ do- [p1k, p2k, _] <- mapM insert [p1, p2, p3]- [_, bpB, bpC] <- mapM insert'- [ BlogPost "A" p1k- , BlogPost "B" p1k- , BlogPost "C" p2k ]- ret <- select $- from $ \bp ->- distinctOn [don (bp ^. BlogPostAuthorId)] $ do- orderBy [asc (bp ^. BlogPostAuthorId), desc (bp ^. BlogPostTitle)]- return bp- liftIO $ ret `shouldBe` L.sortBy (comparing (blogPostAuthorId . entityVal)) [bpB, bpC]-- let slightlyLessSimpleTest q =- run $ do- [p1k, p2k, _] <- mapM insert [p1, p2, p3]- [bpA, bpB, bpC] <- mapM insert'- [ BlogPost "A" p1k- , BlogPost "B" p1k- , BlogPost "C" p2k ]- ret <- select $- from $ \bp ->- q bp $ return bp- let cmp = (blogPostAuthorId &&& blogPostTitle) . entityVal- liftIO $ ret `shouldBe` L.sortBy (comparing cmp) [bpA, bpB, bpC]-- it "works on a slightly less simple example (two distinctOn calls, orderBy)" $- slightlyLessSimpleTest $ \bp act ->- distinctOn [don (bp ^. BlogPostAuthorId)] $- distinctOn [don (bp ^. BlogPostTitle)] $ do- orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)]- act-- it "works on a slightly less simple example (one distinctOn call, orderBy)" $ do- slightlyLessSimpleTest $ \bp act ->- distinctOn [don (bp ^. BlogPostAuthorId), don (bp ^. BlogPostTitle)] $ do- orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)]- act-- it "works on a slightly less simple example (distinctOnOrderBy)" $ do- slightlyLessSimpleTest $ \bp ->- distinctOnOrderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)]------testArrayAggWith :: Spec-testArrayAggWith = do- describe "ALL, no ORDER BY" $ do- it "creates sane SQL" $ run $ do- (query, args) <- showQuery ES.SELECT $ from $ \p ->- return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge) [])- liftIO $ query `shouldBe`- "SELECT array_agg(\"Person\".\"age\")\n\- \FROM \"Person\"\n"- liftIO $ args `shouldBe` []-- it "works on an example" $ run $ do- let people = [p1, p2, p3, p4, p5]- mapM_ insert people- [Value (Just ret)] <-- select . from $ \p ->- return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) [])- liftIO $ L.sort ret `shouldBe` L.sort (map personName people)-- describe "DISTINCT, no ORDER BY" $ do- it "creates sane SQL" $ run $ do- (query, args) <- showQuery ES.SELECT $ from $ \p ->- return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) [])- liftIO $ query `shouldBe`- "SELECT array_agg(DISTINCT \"Person\".\"age\")\n\- \FROM \"Person\"\n"- liftIO $ args `shouldBe` []-- it "works on an example" $ run $ do- let people = [p1, p2, p3, p4, p5]- mapM_ insert people- [Value (Just ret)] <-- select . from $ \p ->- return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) [])- liftIO $ L.sort ret `shouldBe` [Nothing, Just 17, Just 36]-- describe "ALL, ORDER BY" $ do- it "creates sane SQL" $ run $ do- (query, args) <- showQuery ES.SELECT $ from $ \p ->- return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge)- [ asc $ p ^. PersonName- , desc $ p ^. PersonFavNum- ])- liftIO $ query `shouldBe`- "SELECT array_agg(\"Person\".\"age\" \- \ORDER BY \"Person\".\"name\" ASC, \"Person\".\"favNum\" DESC)\n\- \FROM \"Person\"\n"- liftIO $ args `shouldBe` []-- it "works on an example" $ run $ do- let people = [p1, p2, p3, p4, p5]- mapM_ insert people- [Value (Just ret)] <-- select . from $ \p ->- return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) [])- liftIO $ L.sort ret `shouldBe` L.sort (map personName people)-- describe "DISTINCT, ORDER BY" $ do- it "creates sane SQL" $ run $ do- (query, args) <- showQuery ES.SELECT $ from $ \p ->- return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge)- [asc $ p ^. PersonAge])- liftIO $ query `shouldBe`- "SELECT array_agg(DISTINCT \"Person\".\"age\" \- \ORDER BY \"Person\".\"age\" ASC)\n\- \FROM \"Person\"\n"- liftIO $ args `shouldBe` []-- it "works on an example" $ run $ do- let people = [p1, p2, p3, p4, p5]- mapM_ insert people- [Value (Just ret)] <-- select . from $ \p ->- return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge)- [asc $ p ^. PersonAge])- liftIO $ ret `shouldBe` [Just 17, Just 36, Nothing]------testStringAggWith :: Spec-testStringAggWith = do- describe "ALL, no ORDER BY" $ do- it "creates sane SQL" $ run $ do- (query, args) <- showQuery ES.SELECT $ from $ \p ->- return (EP.stringAggWith EP.AggModeAll (p ^. PersonName)- (val " ") [])- liftIO $ query `shouldBe`- "SELECT string_agg(\"Person\".\"name\", ?)\n\- \FROM \"Person\"\n"- liftIO $ args `shouldBe` [PersistText " "]-- it "works on an example" $ run $ do- let people = [p1, p2, p3, p4, p5]- mapM_ insert people- [Value (Just ret)] <-- select . from $ \p ->- return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[])- liftIO $ (L.sort $ words ret) `shouldBe` L.sort (map personName people)-- it "works with zero rows" $ run $ do- [Value ret] <-- select . from $ \p ->- return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[])- liftIO $ ret `shouldBe` Nothing-- describe "DISTINCT, no ORDER BY" $ do- it "creates sane SQL" $ run $ do- (query, args) <- showQuery ES.SELECT $ from $ \p ->- return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName)- (val " ") []- liftIO $ query `shouldBe`- "SELECT string_agg(DISTINCT \"Person\".\"name\", ?)\n\- \FROM \"Person\"\n"- liftIO $ args `shouldBe` [PersistText " "]-- it "works on an example" $ run $ do- let people = [p1, p2, p3 {personName = "John"}, p4, p5]- mapM_ insert people- [Value (Just ret)] <-- select . from $ \p ->- return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ")- []- liftIO $ (L.sort $ words ret) `shouldBe`- (L.sort . L.nub $ map personName people)-- describe "ALL, ORDER BY" $ do- it "creates sane SQL" $ run $ do- (query, args) <- showQuery ES.SELECT $ from $ \p ->- return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")- [ asc $ p ^. PersonName- , desc $ p ^. PersonFavNum- ])- liftIO $ query `shouldBe`- "SELECT string_agg(\"Person\".\"name\", ? \- \ORDER BY \"Person\".\"name\" ASC, \"Person\".\"favNum\" DESC)\n\- \FROM \"Person\"\n"- liftIO $ args `shouldBe` [PersistText " "]-- it "works on an example" $ run $ do- let people = [p1, p2, p3, p4, p5]- mapM_ insert people- [Value (Just ret)] <-- select . from $ \p ->- return $ EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")- [desc $ p ^. PersonName]- liftIO $ (words ret)- `shouldBe` (L.reverse . L.sort $ map personName people)-- describe "DISTINCT, ORDER BY" $ do- it "creates sane SQL" $ run $ do- (query, args) <- showQuery ES.SELECT $ from $ \p ->- return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName)- (val " ") [desc $ p ^. PersonName]- liftIO $ query `shouldBe`- "SELECT string_agg(DISTINCT \"Person\".\"name\", ? \- \ORDER BY \"Person\".\"name\" DESC)\n\- \FROM \"Person\"\n"- liftIO $ args `shouldBe` [PersistText " "]-- it "works on an example" $ run $ do- let people = [p1, p2, p3 {personName = "John"}, p4, p5]- mapM_ insert people- [Value (Just ret)] <-- select . from $ \p ->- return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ")- [desc $ p ^. PersonName]- liftIO $ (words ret) `shouldBe`- (L.reverse . L.sort . L.nub $ map personName people)------testAggregateFunctions :: Spec-testAggregateFunctions = do- describe "arrayAgg" $ do- it "looks sane" $ run $ do- let people = [p1, p2, p3, p4, p5]- mapM_ insert people- [Value (Just ret)] <-- select . from $ \p -> return (EP.arrayAgg (p ^. PersonName))- liftIO $ L.sort ret `shouldBe` L.sort (map personName people)-- it "works on zero rows" $ run $ do- [Value ret] <-- select . from $ \p -> return (EP.arrayAgg (p ^. PersonName))- liftIO $ ret `shouldBe` Nothing- describe "arrayAggWith" testArrayAggWith- describe "stringAgg" $ do- it "looks sane" $- run $ do- let people = [p1, p2, p3, p4, p5]- mapM_ insert people- [Value (Just ret)] <-- select $- from $ \p -> do- return (EP.stringAgg (p ^. PersonName) (val " "))- liftIO $ L.sort (words ret) `shouldBe` L.sort (map personName people)- it "works on zero rows" $ run $ do- [Value ret] <-- select . from $ \p -> return (EP.stringAgg (p ^. PersonName) (val " "))- liftIO $ ret `shouldBe` Nothing- describe "stringAggWith" testStringAggWith-- describe "array_remove (NULL)" $ do- it "removes NULL from arrays from nullable fields" $ run $ do- mapM_ insert [ Person "1" Nothing Nothing 1- , Person "2" (Just 7) Nothing 1- , Person "3" (Nothing) Nothing 1- , Person "4" (Just 8) Nothing 2- , Person "5" (Just 9) Nothing 2- ]- ret <- select . from $ \(person :: SqlExpr (Entity Person)) -> do- groupBy (person ^. PersonFavNum)- return . EP.arrayRemoveNull . EP.maybeArray . EP.arrayAgg- $ person ^. PersonAge- liftIO $ (L.sort $ map (L.sort . unValue) ret)- `shouldBe` [[7], [8,9]]-- describe "maybeArray" $ do- it "Coalesces NULL into an empty array" $ run $ do- [Value ret] <-- select . from $ \p ->- return (EP.maybeArray $ EP.arrayAgg (p ^. PersonName))- liftIO $ ret `shouldBe` []------testPostgresModule :: Spec-testPostgresModule = do- describe "date_trunc" $ modifyMaxSuccess (`div` 10) $ do- prop "works" $ \listOfDateParts -> run $ do- let- utcTimes =- map- (\(y, m, d, s) ->- fromInteger s- `addUTCTime`- UTCTime (fromGregorian (2000 + y) m d) 0- )- listOfDateParts- truncateDate- :: SqlExpr (Value String) -- ^ .e.g (val "day")- -> SqlExpr (Value UTCTime) -- ^ input field- -> SqlExpr (Value UTCTime) -- ^ truncated date- truncateDate datePart expr =- ES.unsafeSqlFunction "date_trunc" (datePart, expr)- vals =- zip (map (DateTruncTestKey . fromInteger) [1..]) utcTimes- for_ vals $ \(idx, utcTime) -> do- insertKey idx (DateTruncTest utcTime)-- -- Necessary to get the test to pass; see the discussion in- -- https://github.com/bitemyapp/esqueleto/pull/180- rawExecute "SET TIME ZONE 'UTC'" []- ret <-- fmap (Map.fromList . coerce :: _ -> Map DateTruncTestId (UTCTime, UTCTime)) $- select $- from $ \dt -> do- pure- ( dt ^. DateTruncTestId- , ( dt ^. DateTruncTestCreated- , truncateDate (val "day") (dt ^. DateTruncTestCreated)- )- )-- liftIO $ for_ vals $ \(idx, utcTime) -> do- case Map.lookup idx ret of- Nothing ->- expectationFailure "index not found"- Just (original, truncated) -> do- utcTime `shouldBe` original- if utctDay utcTime == utctDay truncated- then- utctDay utcTime `shouldBe` utctDay truncated- else- -- use this if/else to get a better error message- utcTime `shouldBe` truncated-- describe "PostgreSQL module" $ do- describe "Aggregate functions" testAggregateFunctions- it "chr looks sane" $- run $ do- [Value (ret :: String)] <- select $ return (EP.chr (val 65))- liftIO $ ret `shouldBe` "A"-- it "allows unit for functions" $ do- vals <- run $ do- let- fn :: SqlExpr (Value UTCTime)- fn = ES.unsafeSqlFunction "now" ()- select $ pure fn- vals `shouldSatisfy` ((1 ==) . length)-- it "works with now" $- run $ do- nowDb <- select $ return EP.now_- nowUtc <- liftIO getCurrentTime- let halfSecond = realToFrac (0.5 :: Double)-- -- | Check the result is not null- liftIO $ nowDb `shouldSatisfy` (not . null)-- -- | Unpack the now value- let (Value now: _) = nowDb-- -- | Get the time diff and check it's less than half a second- liftIO $ diffUTCTime nowUtc now `shouldSatisfy` (< halfSecond)------------------ JSON --------------- JSON --------------- JSON ------------------------------- JSON --------------- JSON --------------- JSON ------------------------------- JSON --------------- JSON --------------- JSON -----------------testJSONInsertions :: Spec-testJSONInsertions =- describe "JSON Insertions" $ do- it "adds scalar values" $ do- run $ do- insertIt Null- insertIt $ Bool True- insertIt $ Number 1- insertIt $ String "test"- it "adds arrays" $ do- run $ do- insertIt $ toJSON ([] :: [A.Value])- insertIt $ toJSON [Number 1, Bool True, Null]- insertIt $ toJSON [String "test",object ["a" .= Number 3.14], Null, Bool True]- it "adds objects" $ do- run $ do- insertIt $ object ["a" .= (1 :: Int), "b" .= False]- insertIt $ object ["a" .= object ["b" .= object ["c" .= String "message"]]]- where insertIt :: MonadIO m => A.Value -> SqlPersistT m ()- insertIt = insert_ . Json . JSONB---testJSONOperators :: Spec-testJSONOperators =- describe "JSON Operators" $ do- testArrowOperators- testFilterOperators- testConcatDeleteOperators--testArrowOperators :: Spec-testArrowOperators =- describe "Arrow Operators" $ do- testArrowJSONB- testArrowText- testHashArrowJSONB- testHashArrowText--testArrowJSONB :: Spec-testArrowJSONB =- describe "Single Arrow (JSONB)" $ do- it "creates sane SQL" $- createSaneSQL @JSONValue- (jsonbVal (object ["a" .= True]) ->. "a")- "SELECT (? -> ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":true}"- , PersistText "a" ]- it "creates sane SQL (chained)" $ do- let obj = object ["a" .= [1 :: Int,2,3]]- createSaneSQL @JSONValue- (jsonbVal obj ->. "a" ->. 1)- "SELECT ((? -> ?) -> ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":[1,2,3]}"- , PersistText "a"- , PersistInt64 1 ]- it "works as expected" $ run $ do- x <- selectJSONwhere $ \v -> v ->. "b" ==. jsonbVal (Bool False)- y <- selectJSONwhere $ \v -> v ->. 1 ==. jsonbVal (Bool True)- z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->. "c" ==. jsonbVal (String "message")- liftIO $ length x `shouldBe` 1- liftIO $ length y `shouldBe` 1- liftIO $ length z `shouldBe` 1--testArrowText :: Spec-testArrowText =- describe "Single Arrow (Text)" $ do- it "creates sane SQL" $- createSaneSQL- (jsonbVal (object ["a" .= True]) ->>. "a")- "SELECT (? ->> ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":true}"- , PersistText "a" ]- it "creates sane SQL (chained)" $ do- let obj = object ["a" .= [1 :: Int,2,3]]- createSaneSQL- (jsonbVal obj ->. "a" ->>. 1)- "SELECT ((? -> ?) ->> ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":[1,2,3]}"- , PersistText "a"- , PersistInt64 1 ]- it "works as expected" $ run $ do- x <- selectJSONwhere $ \v -> v ->>. "b" ==. just (val "false")- y <- selectJSONwhere $ \v -> v ->>. 1 ==. just (val "true")- z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->>. "c" ==. just (val "message")- liftIO $ length x `shouldBe` 1- liftIO $ length y `shouldBe` 1- liftIO $ length z `shouldBe` 1--testHashArrowJSONB :: Spec-testHashArrowJSONB =- describe "Double Arrow (JSONB)" $ do- it "creates sane SQL" $ do- let list = ["a","b","c"]- createSaneSQL @JSONValue- (jsonbVal (object ["a" .= True]) #>. list)- "SELECT (? #> ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":true}"- , persistTextArray list ]- it "creates sane SQL (chained)" $ do- let obj = object ["a" .= [object ["b" .= True]]]- createSaneSQL @JSONValue- (jsonbVal obj #>. ["a","1"] #>. ["b"])- "SELECT ((? #> ?) #> ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":[{\"b\":true}]}"- , persistTextArray ["a","1"]- , persistTextArray ["b"] ]- it "works as expected" $ run $ do- x <- selectJSONwhere $ \v -> v #>. ["a","b","c"] ==. jsonbVal (String "message")- y <- selectJSONwhere $ \v -> v #>. ["1","a"] ==. jsonbVal (Number 3.14)- z <- selectJSONwhere $ \v -> v #>. ["1"] #>. ["a"] ==. jsonbVal (Number 3.14)- liftIO $ length x `shouldBe` 1- liftIO $ length y `shouldBe` 1- liftIO $ length z `shouldBe` 1--testHashArrowText :: Spec-testHashArrowText =- describe "Double Arrow (Text)" $ do- it "creates sane SQL" $ do- let list = ["a","b","c"]- createSaneSQL- (jsonbVal (object ["a" .= True]) #>>. list)- "SELECT (? #>> ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":true}"- , persistTextArray list ]- it "creates sane SQL (chained)" $ do- let obj = object ["a" .= [object ["b" .= True]]]- createSaneSQL- (jsonbVal obj #>. ["a","1"] #>>. ["b"])- "SELECT ((? #> ?) #>> ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":[{\"b\":true}]}"- , persistTextArray ["a","1"]- , persistTextArray ["b"] ]- it "works as expected" $ run $ do- x <- selectJSONwhere $ \v -> v #>>. ["a","b","c"] ==. just (val "message")- y <- selectJSONwhere $ \v -> v #>>. ["1","a"] ==. just (val "3.14")- z <- selectJSONwhere $ \v -> v #>. ["1"] #>>. ["a"] ==. just (val "3.14")- liftIO $ length x `shouldBe` 1- liftIO $ length y `shouldBe` 1- liftIO $ length z `shouldBe` 1---testFilterOperators :: Spec-testFilterOperators =- describe "Filter Operators" $ do- testInclusion- testQMark- testQMarkAny- testQMarkAll--testInclusion :: Spec-testInclusion = do- describe "@>" $ do- it "creates sane SQL" $- createSaneSQL- (jsonbVal (object ["a" .= False, "b" .= True]) @>. jsonbVal (object ["a" .= False]))- "SELECT (? @> ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":false,\"b\":true}"- , PersistDbSpecific "{\"a\":false}" ]- it "creates sane SQL (chained)" $ do- let obj = object ["a" .= [object ["b" .= True]]]- createSaneSQL- (jsonbVal obj ->. "a" @>. jsonbVal (object ["b" .= True]))- "SELECT ((? -> ?) @> ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":[{\"b\":true}]}"- , PersistText "a"- , PersistDbSpecific "{\"b\":true}" ]- it "works as expected" $ run $ do- x <- selectJSONwhere $ \v -> v @>. jsonbVal (Number 1)- y <- selectJSONwhere $ \v -> v @>. jsonbVal (toJSON [object ["a" .= Number 3.14]])- z <- selectJSONwhere $ \v -> v ->. 1 @>. jsonbVal (object ["a" .= Number 3.14])- liftIO $ length x `shouldBe` 2- liftIO $ length y `shouldBe` 1- liftIO $ length z `shouldBe` 1- describe "<@" $ do- it "creates sane SQL" $- createSaneSQL- (jsonbVal (object ["a" .= False]) <@. jsonbVal (object ["a" .= False, "b" .= True]))- "SELECT (? <@ ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":false}"- , PersistDbSpecific "{\"a\":false,\"b\":true}" ]- it "creates sane SQL (chained)" $ do- let obj = object ["a" .= [object ["b" .= True]]]- createSaneSQL- (jsonbVal obj ->. "a" <@. jsonbVal (object ["b" .= True, "c" .= Null]))- "SELECT ((? -> ?) <@ ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":[{\"b\":true}]}"- , PersistText "a"- , PersistDbSpecific "{\"b\":true,\"c\":null}" ]- it "works as expected" $ run $ do- x <- selectJSONwhere $ \v -> v <@. jsonbVal (toJSON [Number 1])- y <- selectJSONwhere $ \v -> v <@. jsonbVal (object ["a" .= (1 :: Int), "b" .= False, "c" .= Null])- z <- selectJSONwhere $ \v -> v #>. ["a","b"] <@. jsonbVal (object ["b" .= False, "c" .= String "message"])- liftIO $ length x `shouldBe` 2- liftIO $ length y `shouldBe` 1- liftIO $ length z `shouldBe` 1--testQMark :: Spec-testQMark =- describe "Question Mark" $ do- it "creates sane SQL" $- createSaneSQL- (jsonbVal (object ["a" .= False, "b" .= True]) JSON.?. "a")- "SELECT (? ?? ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":false,\"b\":true}"- , PersistText "a" ]- it "creates sane SQL (chained)" $ do- let obj = object ["a" .= [object ["b" .= True]]]- createSaneSQL- (jsonbVal obj #>. ["a","0"] JSON.?. "b")- "SELECT ((? #> ?) ?? ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":[{\"b\":true}]}"- , persistTextArray ["a","0"]- , PersistText "b" ]- it "works as expected" $ run $ do- x <- selectJSONwhere (JSON.?. "a")- y <- selectJSONwhere (JSON.?. "test")- z <- selectJSONwhere $ \v -> v ->. "a" JSON.?. "b"- liftIO $ length x `shouldBe` 2- liftIO $ length y `shouldBe` 2- liftIO $ length z `shouldBe` 1--testQMarkAny :: Spec-testQMarkAny =- describe "Question Mark (Any)" $ do- it "creates sane SQL" $- createSaneSQL- (jsonbVal (object ["a" .= False, "b" .= True]) ?|. ["a","c"])- "SELECT (? ??| ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":false,\"b\":true}"- , persistTextArray ["a","c"] ]- it "creates sane SQL (chained)" $ do- let obj = object ["a" .= [object ["b" .= True]]]- createSaneSQL- (jsonbVal obj #>. ["a","0"] ?|. ["b","c"])- "SELECT ((? #> ?) ??| ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":[{\"b\":true}]}"- , persistTextArray ["a","0"]- , persistTextArray ["b","c"] ]- it "works as expected" $ run $ do- x <- selectJSONwhere (?|. ["b","test"])- y <- selectJSONwhere (?|. ["a"])- z <- selectJSONwhere $ \v -> v ->. (-3) ?|. ["a"]- w <- selectJSONwhere (?|. [])- liftIO $ length x `shouldBe` 3- liftIO $ length y `shouldBe` 2- liftIO $ length z `shouldBe` 1- liftIO $ length w `shouldBe` 0--testQMarkAll :: Spec-testQMarkAll =- describe "Question Mark (All)" $ do- it "creates sane SQL" $- createSaneSQL- (jsonbVal (object ["a" .= False, "b" .= True]) ?&. ["a","c"])- "SELECT (? ??& ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":false,\"b\":true}"- , persistTextArray ["a","c"] ]- it "creates sane SQL (chained)" $ do- let obj = object ["a" .= [object ["b" .= True]]]- createSaneSQL- (jsonbVal obj #>. ["a","0"] ?&. ["b","c"])- "SELECT ((? #> ?) ??& ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":[{\"b\":true}]}"- , persistTextArray ["a","0"]- , persistTextArray ["b","c"] ]- it "works as expected" $ run $ do- x <- selectJSONwhere (?&. ["test"])- y <- selectJSONwhere (?&. ["a","b"])- z <- selectJSONwhere $ \v -> v ->. "a" ?&. ["b"]- w <- selectJSONwhere (?&. [])- liftIO $ length x `shouldBe` 2- liftIO $ length y `shouldBe` 1- liftIO $ length z `shouldBe` 1- liftIO $ length w `shouldBe` 9---testConcatDeleteOperators :: Spec-testConcatDeleteOperators = do- describe "Concatenation Operator" testConcatenationOperator- describe "Deletion Operators" $ do- testMinusOperator- testMinusOperatorV10- testHashMinusOperator--testConcatenationOperator :: Spec-testConcatenationOperator =- describe "Concatenation" $ do- it "creates sane SQL" $- createSaneSQL @JSONValue- (jsonbVal (object ["a" .= False, "b" .= True])- JSON.||. jsonbVal (object ["c" .= Null]))- "SELECT (? || ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":false,\"b\":true}"- , PersistDbSpecific "{\"c\":null}" ]- it "creates sane SQL (chained)" $ do- let obj = object ["a" .= [object ["b" .= True]]]- createSaneSQL @JSONValue- (jsonbVal obj ->. "a" JSON.||. jsonbVal (toJSON [Null]))- "SELECT ((? -> ?) || ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":[{\"b\":true}]}"- , PersistText "a"- , PersistDbSpecific "[null]" ]- it "works as expected" $ run $ do- x <- selectJSON $ \v -> do- where_ $ v @>. jsonbVal (object [])- where_ $ v JSON.||. jsonbVal (object ["x" .= True])- @>. jsonbVal (object ["x" .= True])- y <- selectJSONwhere $ \v ->- v JSON.||. jsonbVal (toJSON [String "a", String "b"])- ->>. 4 ==. just (val "b")- z <- selectJSONwhere $ \v ->- v JSON.||. jsonbVal (toJSON [Bool False])- ->. 0 JSON.@>. jsonbVal (Number 1)- w <- selectJSON $ \v -> do- where_ . not_ $ v @>. jsonbVal (object [])- where_ $ jsonbVal (String "test1") JSON.||. v ->>. 0 ==. just (val "test1")- liftIO $ length x `shouldBe` 2- liftIO $ length y `shouldBe` 1- liftIO $ length z `shouldBe` 2- liftIO $ length w `shouldBe` 7- sqlFailWith "22023" $ selectJSONwhere $ \v ->- v JSON.||. jsonbVal (toJSON $ String "test")- @>. jsonbVal (String "test")--testMinusOperator :: Spec-testMinusOperator =- describe "Minus Operator" $ do- it "creates sane SQL" $- createSaneSQL @JSONValue- (jsonbVal (object ["a" .= False, "b" .= True]) JSON.-. "a")- "SELECT (? - ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":false,\"b\":true}"- , PersistText "a" ]- it "creates sane SQL (chained)" $ do- let obj = object ["a" .= [object ["b" .= True]]]- createSaneSQL @JSONValue- (jsonbVal obj ->. "a" JSON.-. 0)- "SELECT ((? -> ?) - ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":[{\"b\":true}]}"- , PersistText "a"- , PersistInt64 0 ]- it "works as expected" $ run $ do- x <- selectJSON $ \v -> do- where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))- where_ $ v JSON.-. 0 @>. jsonbVal (toJSON [Bool True])- y <- selectJSON $ \v -> do- where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))- where_ $ v JSON.-. (-1) @>. jsonbVal (toJSON [Null])- z <- selectJSON_ $ \v -> v JSON.-. "b" ?&. ["a", "b"]- w <- selectJSON_ $ \v -> do- v JSON.-. "test" @>. jsonbVal (toJSON [String "test"])- liftIO $ length x `shouldBe` 2- liftIO $ length y `shouldBe` 1- liftIO $ length z `shouldBe` 0- liftIO $ length w `shouldBe` 0- sqlFailWith "22023" $ selectJSONwhere $ \v ->- v JSON.-. 0 @>. jsonbVal (toJSON ([] :: [Int]))- where selectJSON_ f = selectJSON $ \v -> do- where_ $ v @>. jsonbVal (object [])- ||. v @>. jsonbVal (toJSON ([] :: [Int]))- where_ $ f v--testMinusOperatorV10 :: Spec-testMinusOperatorV10 =- describe "Minus Operator (PSQL >= v10)" $ do- it "creates sane SQL" $- createSaneSQL @JSONValue- (jsonbVal (object ["a" .= False, "b" .= True]) --. ["a","b"])- "SELECT (? - ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":false,\"b\":true}"- , persistTextArray ["a","b"] ]- it "creates sane SQL (chained)" $ do- let obj = object ["a" .= [object ["b" .= True]]]- createSaneSQL @JSONValue- (jsonbVal obj #>. ["a","0"] --. ["b"])- "SELECT ((? #> ?) - ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":[{\"b\":true}]}"- , persistTextArray ["a","0"]- , persistTextArray ["b"] ]- it "works as expected" $ run $ do- x <- selectJSON $ \v -> do- where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))- where_ $ v --. ["test","a"] @>. jsonbVal (toJSON [String "test"])- y <- selectJSON $ \v -> do- where_ $ v @>. jsonbVal (object [])- where_ $ v --. ["a","b"] <@. jsonbVal (object [])- z <- selectJSON_ $ \v -> v --. ["b"] <@. jsonbVal (object ["a" .= (1 :: Int)])- w <- selectJSON_ $ \v -> do- v --. ["test"] @>. jsonbVal (toJSON [String "test"])- liftIO $ length x `shouldBe` 0- liftIO $ length y `shouldBe` 2- liftIO $ length z `shouldBe` 1- liftIO $ length w `shouldBe` 0- sqlFailWith "22023" $ selectJSONwhere $ \v ->- v --. ["a"] @>. jsonbVal (toJSON ([] :: [Int]))- where selectJSON_ f = selectJSON $ \v -> do- where_ $ v @>. jsonbVal (object [])- ||. v @>. jsonbVal (toJSON ([] :: [Int]))- where_ $ f v--testHashMinusOperator :: Spec-testHashMinusOperator =- describe "Hash-Minus Operator" $ do- it "creates sane SQL" $- createSaneSQL @JSONValue- (jsonbVal (object ["a" .= False, "b" .= True]) #-. ["a"])- "SELECT (? #- ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":false,\"b\":true}"- , persistTextArray ["a"] ]- it "creates sane SQL (chained)" $ do- let obj = object ["a" .= [object ["b" .= True]]]- createSaneSQL @JSONValue- (jsonbVal obj ->. "a" #-. ["0","b"])- "SELECT ((? -> ?) #- ?)\nFROM \"Json\"\n"- [ PersistDbSpecific "{\"a\":[{\"b\":true}]}"- , PersistText "a"- , persistTextArray ["0","b"] ]- it "works as expected" $ run $ do- x <- selectJSON $ \v -> do- where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))- where_ $ v #-. ["1","a"] @>. jsonbVal (toJSON [object []])- y <- selectJSON $ \v -> do- where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))- where_ $ v #-. ["-3","a"] @>. jsonbVal (toJSON [object []])- z <- selectJSON_ $ \v -> v #-. ["a","b","c"]- @>. jsonbVal (object ["a" .= object ["b" .= object ["c" .= String "message"]]])- w <- selectJSON_ $ \v -> v #-. ["a","b"] JSON.?. "b"- liftIO $ length x `shouldBe` 1- liftIO $ length y `shouldBe` 1- liftIO $ length z `shouldBe` 0- liftIO $ length w `shouldBe` 1- sqlFailWith "22023" $ selectJSONwhere $ \v ->- v #-. ["0"] @>. jsonbVal (toJSON ([] :: [Int]))- where selectJSON_ f = selectJSON $ \v -> do- where_ $ v @>. jsonbVal (object [])- where_ $ f v--testInsertUniqueViolation :: Spec-testInsertUniqueViolation =- describe "Unique Violation on Insert" $- it "Unique throws exception" $ run (do- _ <- insert u1- _ <- insert u2- insert u3) `shouldThrow` (==) exception- where- exception = SqlError {- sqlState = "23505",- sqlExecStatus = FatalError,- sqlErrorMsg = "duplicate key value violates unique constraint \"UniqueValue\"",- sqlErrorDetail = "Key (value)=(0) already exists.",- sqlErrorHint = ""}--testUpsert :: Spec-testUpsert =- describe "Upsert test" $ do- it "Upsert can insert like normal" $ run $ do- u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"]- liftIO $ entityVal u1e `shouldBe` u1- it "Upsert performs update on collision" $ run $ do- u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"]- liftIO $ entityVal u1e `shouldBe` u1- u2e <- EP.upsert u2 [OneUniqueName =. val "fifth"]- liftIO $ entityVal u2e `shouldBe` u2- u3e <- EP.upsert u3 [OneUniqueName =. val "fifth"]- liftIO $ entityVal u3e `shouldBe` u1{oneUniqueName="fifth"}--testInsertSelectWithConflict :: Spec-testInsertSelectWithConflict =- describe "insertSelectWithConflict test" $ do- it "Should do Nothing when no updates set" $ run $ do- _ <- insert p1- _ <- insert p2- _ <- insert p3- n1 <- EP.insertSelectWithConflictCount UniqueValue (- from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)- )- (\current excluded -> [])- uniques1 <- select $ from $ \u -> return u- n2 <- EP.insertSelectWithConflictCount UniqueValue (- from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)- )- (\current excluded -> [])- uniques2 <- select $ from $ \u -> return u- liftIO $ n1 `shouldBe` 3- liftIO $ n2 `shouldBe` 0- let test = map (OneUnique "test" . personFavNum) [p1,p2,p3]- liftIO $ map entityVal uniques1 `shouldBe` test- liftIO $ map entityVal uniques2 `shouldBe` test- it "Should update a value if given an update on conflict" $ run $ do- _ <- insert p1- _ <- insert p2- _ <- insert p3- -- Note, have to sum 4 so that the update does not conflicts again with another row.- n1 <- EP.insertSelectWithConflictCount UniqueValue (- from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)- )- (\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)])- uniques1 <- select $ from $ \u -> return u- n2 <- EP.insertSelectWithConflictCount UniqueValue (- from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)- )- (\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)])- uniques2 <- select $ from $ \u -> return u- liftIO $ n1 `shouldBe` 3- liftIO $ n2 `shouldBe` 3- let test = map (OneUnique "test" . personFavNum) [p1,p2,p3]- test2 = map (OneUnique "test" . (+4) . (*2) . personFavNum) [p1,p2,p3]- liftIO $ map entityVal uniques1 `shouldBe` test- liftIO $ map entityVal uniques2 `shouldBe` test2--testFilterWhere :: Spec-testFilterWhere =- describe "filterWhere" $ do- it "adds a filter clause to count aggregation" $ run $ do- -- Person "John" (Just 36) Nothing 1- _ <- insert p1- -- Person "Rachel" Nothing (Just 37) 2- _ <- insert p2- -- Person "Mike" (Just 17) Nothing 3- _ <- insert p3- -- Person "Livia" (Just 17) (Just 18) 4- _ <- insert p4- -- Person "Mitch" Nothing Nothing 5- _ <- insert p5-- usersByAge <- (fmap . fmap) (\(Value a, Value b, Value c) -> (a, b, c)) <$> select $ from $ \users -> do- groupBy $ users ^. PersonAge- return- ( users ^. PersonAge- -- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = 2- -- Just 36: [John { favNum = 1 } (excluded)] = 0- -- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = 2- , count (users ^. PersonId) `EP.filterWhere` (users ^. PersonFavNum >=. val 2)- -- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = 0- -- Just 36: [John { favNum = 1 }] = 1- -- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = 0- , count (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2)- )-- liftIO $ usersByAge `shouldMatchList`- ( [ (Nothing, 2, 0)- , (Just 36, 0, 1)- , (Just 17, 2, 0)- ] :: [(Maybe Int, Int, Int)]- )-- it "adds a filter clause to sum aggregation" $ run $ do- -- Person "John" (Just 36) Nothing 1- _ <- insert p1- -- Person "Rachel" Nothing (Just 37) 2- _ <- insert p2- -- Person "Mike" (Just 17) Nothing 3- _ <- insert p3- -- Person "Livia" (Just 17) (Just 18) 4- _ <- insert p4- -- Person "Mitch" Nothing Nothing 5- _ <- insert p5-- usersByAge <- (fmap . fmap) (\(Value a, Value b, Value c) -> (a, b, c)) <$> select $ from $ \users -> do- groupBy $ users ^. PersonAge- return- ( users ^. PersonAge- -- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = Just 7- -- Just 36: [John { favNum = 1 } (excluded)] = Nothing- -- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = Just 7- , sum_ (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum >=. val 2)- -- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = Nothing- -- Just 36: [John { favNum = 1 }] = Just 1- -- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = Nothing- , sum_ (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2)- )-- liftIO $ usersByAge `shouldMatchList`- ( [ (Nothing, Just 7, Nothing)- , (Just 36, Nothing, Just 1)- , (Just 17, Just 7, Nothing)- ] :: [(Maybe Int, Maybe Rational, Maybe Rational)]- )--type JSONValue = Maybe (JSONB A.Value)--createSaneSQL :: (PersistField a) => SqlExpr (Value a) -> T.Text -> [PersistValue] -> IO ()-createSaneSQL act q vals = run $ do- (query, args) <- showQuery ES.SELECT $ fromValue act- liftIO $ query `shouldBe` q- liftIO $ args `shouldBe` vals--fromValue :: (PersistField a) => SqlExpr (Value a) -> SqlQuery (SqlExpr (Value a))-fromValue act = from $ \x -> do- let _ = x :: SqlExpr (Entity Json)- return act--persistTextArray :: [T.Text] -> PersistValue-persistTextArray = PersistArray . fmap PersistText--sqlFailWith :: (MonadCatch m, MonadIO m) => ByteString -> SqlPersistT (R.ResourceT m) a -> SqlPersistT (R.ResourceT m) ()-sqlFailWith errState f = do- p <- (f >> return True) `catch` success- when p failed- where success SqlError{sqlState}- | sqlState == errState = return False- | otherwise = do- liftIO $ expectationFailure $ T.unpack $ T.concat- [ "should fail with: ", errStateT- , ", but received: ", TE.decodeUtf8 sqlState- ]- return False- failed = liftIO $ expectationFailure $ "should fail with: " `mappend` T.unpack errStateT- errStateT = TE.decodeUtf8 errState--selectJSONwhere- :: MonadIO m- => (JSONBExpr A.Value -> SqlExpr (Value Bool))- -> SqlPersistT m [Entity Json]-selectJSONwhere f = selectJSON $ where_ . f--selectJSON- :: MonadIO m- => (JSONBExpr A.Value -> SqlQuery ())- -> SqlPersistT m [Entity Json]-selectJSON f = select $ from $ \v -> do- f $ just (v ^. JsonValue)- return v----------------- JSON --------------- JSON --------------- JSON ------------------------------- JSON --------------- JSON --------------- JSON ------------------------------- JSON --------------- JSON --------------- JSON -------------------main :: IO ()-main = do- hspec $ do- tests run-- describe "Test PostgreSQL locking" $ do- testLocking withConn-- describe "PostgreSQL specific tests" $ do- testAscRandom random_ run- testRandomMath run- testSelectDistinctOn- testPostgresModule- testPostgresqlOneAscOneDesc- testPostgresqlTwoAscFields- testPostgresqlSum- testPostgresqlRandom- testPostgresqlUpdate- testPostgresqlCoalesce- testPostgresqlTextFunctions- testInsertUniqueViolation- testUpsert- testInsertSelectWithConflict- testFilterWhere- describe "PostgreSQL JSON tests" $ do- -- NOTE: We only clean the table once, so we- -- can use its contents across all JSON tests- it "MIGRATE AND CLEAN JSON TABLE" $ run $ do- void $ runMigrationSilent migrateJSON- cleanJSON- testJSONInsertions- testJSONOperators---run, runSilent, runVerbose :: Run-runSilent act = runNoLoggingT $ run_worker act-runVerbose act = runStderrLoggingT $ run_worker act-run f = do- verbose' <- lookupEnv "VERBOSE" >>= \case- Nothing -> return verbose- Just x | map Char.toLower x == "true" -> return True- | null x -> return True- | otherwise -> return False- if verbose'- then runVerbose f- else runSilent f--verbose :: Bool-verbose = False--run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a-run_worker act = withConn $ runSqlConn (migrateIt >> act)--migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) ()-migrateIt = do- void $ runMigrationSilent migrateAll- void $ runMigrationSilent migrateUnique- cleanDB- cleanUniques--withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a-withConn =- R.runResourceT . withPostgresqlConn "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest"+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module PostgreSQL.Test where++import Control.Arrow ((&&&))+import Control.Concurrent (forkIO)+import Control.Monad (void, when)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)+import Control.Monad.Trans.Reader (ReaderT, ask, mapReaderT, runReaderT)+import qualified Control.Monad.Trans.Resource as R+import Data.Aeson hiding (Value)+import qualified Data.Aeson as A (Value)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Char as Char+import Data.Coerce+import Data.Foldable+import qualified Data.List as L+import qualified Data.List.NonEmpty as NE+import Data.Map (Map)+import qualified Data.Map.Strict as Map+import Data.Ord (comparing)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import Data.Time+import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)+import Database.Esqueleto hiding (random_)+import Database.Esqueleto.Experimental hiding (from, on, random_)+import qualified Database.Esqueleto.Experimental as Experimental+import qualified Database.Esqueleto.Internal.Internal as ES+import Database.Esqueleto.PostgreSQL+ (random_, withMaterialized, withNotMaterialized)+import qualified Database.Esqueleto.PostgreSQL as EP+import Database.Esqueleto.PostgreSQL.JSON hiding ((-.), (?.), (||.))+import qualified Database.Esqueleto.PostgreSQL.JSON as JSON+import qualified Database.Persist.Class as P+import Database.Persist.Postgresql (createPostgresqlPool, withPostgresqlConn)+import Database.PostgreSQL.Simple (ExecStatus(..), SqlError(..))+import System.Environment+import Test.Hspec+import Test.Hspec.Core.Spec (sequential)+import Test.Hspec.QuickCheck++import Common.Test+import Common.Test.Import hiding (from, on)+import PostgreSQL.MigrateJSON++spec :: Spec+spec = beforeAll mkConnectionPool $ do+ tests++ describe "PostgreSQL specific tests" $ do+ testAscRandom random_+ testSelectDistinctOn+ testPostgresModule+ testPostgresqlOneAscOneDesc+ testPostgresqlTwoAscFields+ testPostgresqlSum+ testPostgresqlRandom+ testPostgresqlUpdate+ testPostgresqlCoalesce+ testPostgresqlTextFunctions+ testInsertUniqueViolation+ testUpsert+ testInsertSelectWithConflict+ testFilterWhere+ testCommonTableExpressions+ setDatabaseState insertJsonValues cleanJSON+ $ describe "PostgreSQL JSON tests" $ do+ testJSONInsertions+ testJSONOperators+ testLateralQuery+ testValuesExpression+ testSubselectAliasingBehavior+ testPostgresqlLocking+ testPostgresqlNullsOrdering+++returningType :: forall a m . m a -> m a+returningType a = a++testPostgresqlCoalesce :: SpecDb+testPostgresqlCoalesce = do+ itDb "works on PostgreSQL and MySQL with <2 arguments" $ do+ void $ returningType @[Value (Maybe Int)] $+ select $+ from $ \p -> do+ return (coalesce [p ^. PersonAge])+ asserting noExceptions++testPostgresqlTextFunctions :: SpecDb+testPostgresqlTextFunctions = do+ describe "text functions" $ do+ itDb "like, (%) and (++.) work on a simple example" $ do+ let nameContains t =+ select $+ from $ \p -> do+ where_+ (like+ (p ^. PersonName)+ ((%) ++. val t ++. (%)))+ orderBy [asc (p ^. PersonName)]+ return p+ [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]+ h <- nameContains "h"+ i <- nameContains "i"+ iv <- nameContains "iv"+ asserting $ do+ h `shouldBe` [p1e, p2e]+ i `shouldBe` [p4e, p3e]+ iv `shouldBe` [p4e]++ itDb "ilike, (%) and (++.) work on a simple example on PostgreSQL" $ do+ [p1e, _, p3e, _, p5e] <- mapM insert' [p1, p2, p3, p4, p5]+ let nameContains t = do+ select $+ from $ \p -> do+ where_ (p ^. PersonName `ilike` (%) ++. val t ++. (%))+ orderBy [asc (p ^. PersonName)]+ return p+ mi <- nameContains "mi"+ john <- nameContains "JOHN"+ asserting $ do+ mi `shouldBe` [p3e, p5e]+ john `shouldBe` [p1e]++testPostgresqlUpdate :: SpecDb+testPostgresqlUpdate = do+ itDb "works on a simple example" $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ let anon = "Anonymous"+ () <- update $ \p -> do+ set p [ PersonName =. val anon+ , PersonAge *=. just (val 2) ]+ where_ (p ^. PersonName !=. val "Mike")+ n <- updateCount $ \p -> do+ set p [ PersonAge +=. just (val 1) ]+ where_ (p ^. PersonName !=. val "Mike")+ ret <- select $+ from $ \p -> do+ orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ]+ return p+ -- PostgreSQL: nulls are bigger than data, and update returns+ -- matched rows, not actually changed rows.+ asserting $ do+ n `shouldBe` 2+ ret `shouldBe`+ [ Entity p1k (Person anon (Just 73) Nothing 1)+ , Entity p2k (Person anon Nothing (Just 37) 2)+ , Entity p3k p3+ ]++testPostgresqlRandom :: SpecDb+testPostgresqlRandom = do+ itDb "works with random_" $ do+ _ <- select $ return (random_ :: SqlExpr (Value Double))+ asserting noExceptions++testPostgresqlSum :: SpecDb+testPostgresqlSum = do+ itDb "works with sum_" $ do+ _ <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ _ <- insert' p4+ ret <- select $+ from $ \p->+ return $ joinV $ sum_ (p ^. PersonAge)+ asserting $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Rational ) ]++testPostgresqlTwoAscFields :: SpecDb+testPostgresqlTwoAscFields = do+ itDb "works with two ASC fields (one call)" $ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ p4e <- insert' p4+ ret <- select $+ from $ \p -> do+ orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)]+ return p+ -- in PostgreSQL nulls are bigger than everything+ asserting $ ret `shouldBe` [ p4e, p3e, p1e , p2e ]++testPostgresqlOneAscOneDesc :: SpecDb+testPostgresqlOneAscOneDesc = do+ itDb "works with one ASC and one DESC field (two calls)" $+ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ p4e <- insert' p4+ ret <- select $+ from $ \p -> do+ orderBy [desc (p ^. PersonAge)]+ orderBy [asc (p ^. PersonName)]+ return p+ asserting $ ret `shouldBe` [ p2e, p1e, p4e, p3e ]++testSelectDistinctOn :: SpecDb+testSelectDistinctOn = do+ describe "SELECT DISTINCT ON" $ do+ itDb "works on a simple example" $ do+ do+ [p1k, p2k, _] <- mapM insert [p1, p2, p3]+ [_, bpB, bpC] <- mapM insert'+ [ BlogPost "A" p1k+ , BlogPost "B" p1k+ , BlogPost "C" p2k ]+ ret <- select $+ from $ \bp ->+ distinctOn [don (bp ^. BlogPostAuthorId)] $ do+ orderBy [asc (bp ^. BlogPostAuthorId), desc (bp ^. BlogPostTitle)]+ return bp+ liftIO $ ret `shouldBe` L.sortBy (comparing (blogPostAuthorId . entityVal)) [bpB, bpC]++ let slightlyLessSimpleTest q =+ do+ [p1k, p2k, _] <- mapM insert [p1, p2, p3]+ [bpA, bpB, bpC] <- mapM insert'+ [ BlogPost "A" p1k+ , BlogPost "B" p1k+ , BlogPost "C" p2k ]+ ret <- select $+ from $ \bp ->+ q bp $ return bp+ let cmp = (blogPostAuthorId &&& blogPostTitle) . entityVal+ liftIO $ ret `shouldBe` L.sortBy (comparing cmp) [bpA, bpB, bpC]++ itDb "works on a slightly less simple example (two distinctOn calls, orderBy)" $+ slightlyLessSimpleTest $ \bp act ->+ distinctOn [don (bp ^. BlogPostAuthorId)] $+ distinctOn [don (bp ^. BlogPostTitle)] $ do+ orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)]+ act++ itDb "works on a slightly less simple example (one distinctOn call, orderBy)" $ do+ slightlyLessSimpleTest $ \bp act ->+ distinctOn [don (bp ^. BlogPostAuthorId), don (bp ^. BlogPostTitle)] $ do+ orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)]+ act++ itDb "works on a slightly less simple example (distinctOnOrderBy)" $ do+ slightlyLessSimpleTest $ \bp ->+ distinctOnOrderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)]++ itDb "generates correct sql with nested expression (distinctOnOrderBy)" $ do+ let query = do+ let orderVal = coalesce [nothing, just $ val (10 :: Int)]+ distinctOnOrderBy [ asc orderVal, desc orderVal ] $ pure orderVal+ select query+ asserting noExceptions+++++testArrayAggWith :: SpecDb+testArrayAggWith = do+ describe "ALL, no ORDER BY" $ do+ itDb "creates sane SQL" $ do+ (query, args) <- showQuery ES.SELECT $ from $ \p ->+ return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge) [])+ liftIO $ query `shouldBe`+ "SELECT array_agg(\"Person\".\"age\")\n\+ \FROM \"Person\"\n"+ liftIO $ args `shouldBe` []++ itDb "works on an example" $ do+ let people = [p1, p2, p3, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p ->+ return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) [])+ liftIO $ L.sort ret `shouldBe` L.sort (map personName people)++ describe "DISTINCT, no ORDER BY" $ do+ itDb "creates sane SQL" $ do+ (query, args) <- showQuery ES.SELECT $ from $ \p ->+ return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) [])+ liftIO $ query `shouldBe`+ "SELECT array_agg(DISTINCT \"Person\".\"age\")\n\+ \FROM \"Person\"\n"+ liftIO $ args `shouldBe` []++ itDb "works on an example" $ do+ let people = [p1, p2, p3, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p ->+ return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) [])+ liftIO $ L.sort ret `shouldBe` [Nothing, Just 17, Just 36]++ describe "ALL, ORDER BY" $ do+ itDb "creates sane SQL" $ do+ (query, args) <- showQuery ES.SELECT $ from $ \p ->+ return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge)+ [ asc $ p ^. PersonName+ , desc $ p ^. PersonFavNum+ ])+ liftIO $ query `shouldBe`+ "SELECT array_agg(\"Person\".\"age\" \+ \ORDER BY \"Person\".\"name\" ASC, \"Person\".\"favNum\" DESC)\n\+ \FROM \"Person\"\n"+ liftIO $ args `shouldBe` []++ itDb "works on an example" $ do+ let people = [p1, p2, p3, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p ->+ return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) [])+ liftIO $ L.sort ret `shouldBe` L.sort (map personName people)++ describe "DISTINCT, ORDER BY" $ do+ itDb "creates sane SQL" $ do+ (query, args) <- showQuery ES.SELECT $ from $ \p ->+ return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge)+ [asc $ p ^. PersonAge])+ liftIO $ query `shouldBe`+ "SELECT array_agg(DISTINCT \"Person\".\"age\" \+ \ORDER BY \"Person\".\"age\" ASC)\n\+ \FROM \"Person\"\n"+ liftIO $ args `shouldBe` []++ itDb "works on an example" $ do+ let people = [p1, p2, p3, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p ->+ return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge)+ [asc $ p ^. PersonAge])+ liftIO $ ret `shouldBe` [Just 17, Just 36, Nothing]++++++testStringAggWith :: SpecDb+testStringAggWith = do+ describe "ALL, no ORDER BY" $ do+ itDb "creates sane SQL" $ do+ (query, args) <- showQuery ES.SELECT $ from $ \p ->+ return (EP.stringAggWith EP.AggModeAll (p ^. PersonName)+ (val " ") [])+ liftIO $ query `shouldBe`+ "SELECT string_agg(\"Person\".\"name\", ?)\n\+ \FROM \"Person\"\n"+ liftIO $ args `shouldBe` [PersistText " "]++ itDb "works on an example" $ do+ let people = [p1, p2, p3, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p ->+ return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[])+ liftIO $ (L.sort $ words ret) `shouldBe` L.sort (map personName people)++ itDb "works with zero rows" $ do+ [Value ret] <-+ select $ from $ \p ->+ return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[])+ liftIO $ ret `shouldBe` Nothing++ describe "DISTINCT, no ORDER BY" $ do+ itDb "creates sane SQL" $ do+ (query, args) <- showQuery ES.SELECT $ from $ \p ->+ return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName)+ (val " ") []+ liftIO $ query `shouldBe`+ "SELECT string_agg(DISTINCT \"Person\".\"name\", ?)\n\+ \FROM \"Person\"\n"+ liftIO $ args `shouldBe` [PersistText " "]++ itDb "works on an example" $ do+ let people = [p1, p2, p3 {personName = "John"}, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p ->+ return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ")+ []+ liftIO $ (L.sort $ words ret) `shouldBe`+ (L.sort . L.nub $ map personName people)++ describe "ALL, ORDER BY" $ do+ itDb "creates sane SQL" $ do+ (query, args) <- showQuery ES.SELECT $ from $ \p ->+ return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")+ [ asc $ p ^. PersonName+ , desc $ p ^. PersonFavNum+ ])+ liftIO $ query `shouldBe`+ "SELECT string_agg(\"Person\".\"name\", ? \+ \ORDER BY \"Person\".\"name\" ASC, \"Person\".\"favNum\" DESC)\n\+ \FROM \"Person\"\n"+ liftIO $ args `shouldBe` [PersistText " "]++ itDb "works on an example" $ do+ let people = [p1, p2, p3, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p ->+ return $ EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")+ [desc $ p ^. PersonName]+ liftIO $ (words ret)+ `shouldBe` (L.reverse . L.sort $ map personName people)++ describe "DISTINCT, ORDER BY" $ do+ itDb "creates sane SQL" $ do+ (query, args) <- showQuery ES.SELECT $ from $ \p ->+ return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName)+ (val " ") [desc $ p ^. PersonName]+ liftIO $ query `shouldBe`+ "SELECT string_agg(DISTINCT \"Person\".\"name\", ? \+ \ORDER BY \"Person\".\"name\" DESC)\n\+ \FROM \"Person\"\n"+ liftIO $ args `shouldBe` [PersistText " "]++ itDb "works on an example" $ do+ let people = [p1, p2, p3 {personName = "John"}, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p ->+ return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ")+ [desc $ p ^. PersonName]+ liftIO $ (words ret) `shouldBe`+ (L.reverse . L.sort . L.nub $ map personName people)++++++testAggregateFunctions :: SpecDb+testAggregateFunctions = do+ describe "arrayAgg" $ do+ itDb "looks sane" $ do+ let people = [p1, p2, p3, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName))+ liftIO $ L.sort ret `shouldBe` L.sort (map personName people)++ itDb "works on zero rows" $ do+ [Value ret] <-+ select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName))+ liftIO $ ret `shouldBe` Nothing+ describe "arrayAggWith" testArrayAggWith+ describe "stringAgg" $ do+ itDb "looks sane" $+ do+ let people = [p1, p2, p3, p4, p5]+ mapM_ insert people+ [Value (Just ret)] <-+ select $+ from $ \p -> do+ return (EP.stringAgg (p ^. PersonName) (val " "))+ liftIO $ L.sort (words ret) `shouldBe` L.sort (map personName people)+ itDb "works on zero rows" $ do+ [Value ret] <-+ select $ from $ \p -> return (EP.stringAgg (p ^. PersonName) (val " "))+ liftIO $ ret `shouldBe` Nothing+ describe "stringAggWith" testStringAggWith++ describe "array_remove (NULL)" $ do+ itDb "removes NULL from arrays from nullable fields" $ do+ mapM_ insert [ Person "1" Nothing Nothing 1+ , Person "2" (Just 7) Nothing 1+ , Person "3" (Nothing) Nothing 1+ , Person "4" (Just 8) Nothing 2+ , Person "5" (Just 9) Nothing 2+ ]+ ret <- select $ from $ \(person :: SqlExpr (Entity Person)) -> do+ groupBy (person ^. PersonFavNum)+ return . EP.arrayRemoveNull . EP.maybeArray . EP.arrayAgg+ $ person ^. PersonAge+ liftIO $ (L.sort $ map (L.sort . unValue) ret)+ `shouldBe` [[7], [8,9]]++ describe "maybeArray" $ do+ itDb "Coalesces NULL into an empty array" $ do+ [Value ret] <-+ select $ from $ \p ->+ return (EP.maybeArray $ EP.arrayAgg (p ^. PersonName))+ liftIO $ ret `shouldBe` []++testPostgresModule :: SpecDb+testPostgresModule = do+ describe "date_trunc" $ modifyMaxSuccess (`div` 10) $ do+ propDb "works" $ \run listOfDateParts -> run $ do+ let+ utcTimes =+ map+ (\(y, m, d, s) ->+ fromInteger s+ `addUTCTime`+ UTCTime (fromGregorian (2000 + y) m d) 0+ )+ listOfDateParts+ truncateDate+ :: SqlExpr (Value String) -- ^ .e.g (val "day")+ -> SqlExpr (Value UTCTime) -- ^ input field+ -> SqlExpr (Value UTCTime) -- ^ truncated date+ truncateDate datePart expr =+ ES.unsafeSqlFunction "date_trunc" (datePart, expr)+ vals =+ zip (map (DateTruncTestKey . fromInteger) [1..]) utcTimes+ for_ vals $ \(idx, utcTime) -> do+ insertKey idx (DateTruncTest utcTime)++ -- Necessary to get the test to pass; see the discussion in+ -- https://github.com/bitemyapp/esqueleto/pull/180+ rawExecute "SET TIME ZONE 'UTC'" []+ ret <-+ fmap (Map.fromList . coerce :: _ -> Map DateTruncTestId (UTCTime, UTCTime)) $+ select $+ from $ \dt -> do+ pure+ ( dt ^. DateTruncTestId+ , ( dt ^. DateTruncTestCreated+ , truncateDate (val "day") (dt ^. DateTruncTestCreated)+ )+ )++ asserting $ for_ vals $ \(idx, utcTime) -> do+ case Map.lookup idx ret of+ Nothing ->+ expectationFailure "index not found"+ Just (original, truncated) -> do+ utcTime `shouldBe` original+ if utctDay utcTime == utctDay truncated+ then+ utctDay utcTime `shouldBe` utctDay truncated+ else+ -- use this if/else to get a better error message+ utcTime `shouldBe` truncated++ describe "PostgreSQL module" $ do+ describe "Aggregate functions" testAggregateFunctions+ itDb "chr looks sane" $ do+ [Value (ret :: String)] <- select $ return (EP.chr (val 65))+ liftIO $ ret `shouldBe` "A"++ itDb "allows unit for functions" $ do+ let+ fn :: SqlExpr (Value UTCTime)+ fn = ES.unsafeSqlFunction "now" ()+ vals <- select $ pure fn+ liftIO $ vals `shouldSatisfy` ((1 ==) . length)++ itDb "works with now" $+ do+ nowDb <- select $ return EP.now_+ nowUtc <- liftIO getCurrentTime+ let oneSecond = realToFrac (1 :: Double)++ -- | Check the result is not null+ liftIO $ nowDb `shouldSatisfy` (not . null)++ -- | Unpack the now value+ let (Value now: _) = nowDb++ -- | Get the time diff and check it's less than a second+ liftIO $ diffUTCTime nowUtc now `shouldSatisfy` (< oneSecond)++testJSONInsertions :: SpecDb+testJSONInsertions =+ describe "JSON Insertions" $ do+ itDb "adds scalar values" $ do+ insertIt Null+ insertIt $ Bool True+ insertIt $ Number 1+ insertIt $ String "test"+ itDb "adds arrays" $ do+ insertIt $ toJSON ([] :: [A.Value])+ insertIt $ toJSON [Number 1, Bool True, Null]+ insertIt $ toJSON [String "test",object ["a" .= Number 3.14], Null, Bool True]+ itDb "adds objects" $ do+ insertIt $ object ["a" .= (1 :: Int), "b" .= False]+ insertIt $ object ["a" .= object ["b" .= object ["c" .= String "message"]]]+ where+ insertIt :: MonadIO m => A.Value -> SqlPersistT m ()+ insertIt = insert_ . Json . JSONB++testJSONOperators :: SpecDb+testJSONOperators =+ describe "JSON Operators" $ do+ testArrowOperators+ testFilterOperators+ testConcatDeleteOperators++testArrowOperators :: SpecDb+testArrowOperators =+ describe "Arrow Operators" $ do+ testArrowJSONB+ testArrowText+ testHashArrowJSONB+ testHashArrowText++testArrowJSONB :: SpecDb+testArrowJSONB =+ describe "Single Arrow (JSONB)" $ do+ itDb "creates sane SQL" $+ createSaneSQL @JSONValue+ (jsonbVal (object ["a" .= True]) ->. "a")+ "SELECT (? -> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":true}"+ , PersistText "a"+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [1 :: Int,2,3]]+ createSaneSQL @JSONValue+ (jsonbVal obj ->. "a" ->. 1)+ "SELECT ((? -> ?) -> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":[1,2,3]}"+ , PersistText "a"+ , PersistInt64 1 ]+ itDb "works as expected" $ do+ x <- selectJSONwhere $ \v -> v ->. "b" ==. jsonbVal (Bool False)+ y <- selectJSONwhere $ \v -> v ->. 1 ==. jsonbVal (Bool True)+ z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->. "c" ==. jsonbVal (String "message")+ asserting $ do+ length x `shouldBe` 1+ length y `shouldBe` 1+ length z `shouldBe` 1++testArrowText :: SpecDb+testArrowText =+ describe "Single Arrow (Text)" $ do+ itDb "creates sane SQL" $+ createSaneSQL+ (jsonbVal (object ["a" .= True]) ->>. "a")+ "SELECT (? ->> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":true}"+ , PersistText "a" ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [1 :: Int,2,3]]+ createSaneSQL+ (jsonbVal obj ->. "a" ->>. 1)+ "SELECT ((? -> ?) ->> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":[1,2,3]}"+ , PersistText "a"+ , PersistInt64 1 ]+ itDb "works as expected" $ do+ x <- selectJSONwhere $ \v -> v ->>. "b" ==. just (val "false")+ y <- selectJSONwhere $ \v -> v ->>. 1 ==. just (val "true")+ z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->>. "c" ==. just (val "message")+ liftIO $ length x `shouldBe` 1+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 1++testHashArrowJSONB :: SpecDb+testHashArrowJSONB =+ describe "Double Arrow (JSONB)" $ do+ itDb "creates sane SQL" $ do+ let list = ["a","b","c"]+ createSaneSQL @JSONValue+ (jsonbVal (object ["a" .= True]) #>. list)+ "SELECT (? #> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":true}"+ , persistTextArray list ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ createSaneSQL @JSONValue+ (jsonbVal obj #>. ["a","1"] #>. ["b"])+ "SELECT ((? #> ?) #> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}"+ , persistTextArray ["a","1"]+ , persistTextArray ["b"] ]+ itDb "works as expected" $ do+ x <- selectJSONwhere $ \v -> v #>. ["a","b","c"] ==. jsonbVal (String "message")+ y <- selectJSONwhere $ \v -> v #>. ["1","a"] ==. jsonbVal (Number 3.14)+ z <- selectJSONwhere $ \v -> v #>. ["1"] #>. ["a"] ==. jsonbVal (Number 3.14)+ liftIO $ length x `shouldBe` 1+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 1++testHashArrowText :: SpecDb+testHashArrowText =+ describe "Double Arrow (Text)" $ do+ itDb "creates sane SQL" $ do+ let list = ["a","b","c"]+ createSaneSQL+ (jsonbVal (object ["a" .= True]) #>>. list)+ "SELECT (? #>> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":true}"+ , persistTextArray list ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ createSaneSQL+ (jsonbVal obj #>. ["a","1"] #>>. ["b"])+ "SELECT ((? #> ?) #>> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}"+ , persistTextArray ["a","1"]+ , persistTextArray ["b"] ]+ itDb "works as expected" $ do+ x <- selectJSONwhere $ \v -> v #>>. ["a","b","c"] ==. just (val "message")+ y <- selectJSONwhere $ \v -> v #>>. ["1","a"] ==. just (val "3.14")+ z <- selectJSONwhere $ \v -> v #>. ["1"] #>>. ["a"] ==. just (val "3.14")+ liftIO $ length x `shouldBe` 1+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 1+++testFilterOperators :: SpecDb+testFilterOperators =+ describe "Filter Operators" $ do+ testInclusion+ testQMark+ testQMarkAny+ testQMarkAll++testInclusion :: SpecDb+testInclusion = do+ describe "@>" $ do+ itDb "creates sane SQL" $ do+ let obj = object ["a" .= False, "b" .= True]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal obj @>. jsonbVal (object ["a" .= False]))+ "SELECT (? @> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , PersistLiteralEscaped "{\"a\":false}"+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal obj ->. "a" @>. jsonbVal (object ["b" .= True]))+ "SELECT ((? -> ?) @> ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , PersistText "a"+ , PersistLiteralEscaped "{\"b\":true}"+ ]+ itDb "works as expected" $ do+ x <- selectJSONwhere $ \v -> v @>. jsonbVal (Number 1)+ y <- selectJSONwhere $ \v -> v @>. jsonbVal (toJSON [object ["a" .= Number 3.14]])+ z <- selectJSONwhere $ \v -> v ->. 1 @>. jsonbVal (object ["a" .= Number 3.14])+ liftIO $ length x `shouldBe` 2+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 1+ describe "<@" $ do+ itDb "creates sane SQL" $ do+ let obj = object ["a" .= False, "b" .= True]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal (object ["a" .= False]) <@. jsonbVal obj )+ "SELECT (? <@ ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":false}"+ , PersistLiteralEscaped encoded+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ obj' = object ["b" .= True, "c" .= Null]+ encoded = BSL.toStrict $ encode obj'+ createSaneSQL+ (jsonbVal obj ->. "a" <@. jsonbVal obj')+ "SELECT ((? -> ?) <@ ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}"+ , PersistText "a"+ , PersistLiteralEscaped encoded+ ]+ itDb "works as expected" $ do+ x <- selectJSONwhere $ \v -> v <@. jsonbVal (toJSON [Number 1])+ y <- selectJSONwhere $ \v -> v <@. jsonbVal (object ["a" .= (1 :: Int), "b" .= False, "c" .= Null])+ z <- selectJSONwhere $ \v -> v #>. ["a","b"] <@. jsonbVal (object ["b" .= False, "c" .= String "message"])+ liftIO $ length x `shouldBe` 2+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 1++testQMark :: SpecDb+testQMark = do+ describe "Question Mark" $ do+ itDb "creates sane SQL" $ do+ let obj = object ["a" .= False, "b" .= True]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal obj JSON.?. "a")+ "SELECT (? ?? ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , PersistText "a"+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal obj #>. ["a","0"] JSON.?. "b")+ "SELECT ((? #> ?) ?? ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , persistTextArray ["a","0"]+ , PersistText "b"+ ]+ itDb "works as expected" $ do+ x <- selectJSONwhere (JSON.?. "a")+ y <- selectJSONwhere (JSON.?. "test")+ z <- selectJSONwhere $ \v -> v ->. "a" JSON.?. "b"+ liftIO $ length x `shouldBe` 2+ liftIO $ length y `shouldBe` 2+ liftIO $ length z `shouldBe` 1++testQMarkAny :: SpecDb+testQMarkAny = do+ describe "Question Mark (Any)" $ do+ itDb "creates sane SQL" $ do+ let obj = (object ["a" .= False, "b" .= True])+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal obj ?|. ["a","c"])+ "SELECT (? ??| ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , persistTextArray ["a","c"]+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal obj #>. ["a","0"] ?|. ["b","c"])+ "SELECT ((? #> ?) ??| ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , persistTextArray ["a","0"]+ , persistTextArray ["b","c"]+ ]+ itDb "works as expected" $ do+ x <- selectJSONwhere (?|. ["b","test"])+ y <- selectJSONwhere (?|. ["a"])+ z <- selectJSONwhere $ \v -> v ->. (-3) ?|. ["a"]+ w <- selectJSONwhere (?|. [])+ liftIO $ length x `shouldBe` 3+ liftIO $ length y `shouldBe` 2+ liftIO $ length z `shouldBe` 1+ liftIO $ length w `shouldBe` 0++testQMarkAll :: SpecDb+testQMarkAll = do+ describe "Question Mark (All)" $ do+ itDb "creates sane SQL" $ do+ let obj = object ["a" .= False, "b" .= True]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal obj ?&. ["a","c"])+ "SELECT (? ??& ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , persistTextArray ["a","c"]+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL+ (jsonbVal obj #>. ["a","0"] ?&. ["b","c"])+ "SELECT ((? #> ?) ??& ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , persistTextArray ["a","0"]+ , persistTextArray ["b","c"]+ ]+ itDb "works as expected" $ do+ x <- selectJSONwhere (?&. ["test"])+ y <- selectJSONwhere (?&. ["a","b"])+ z <- selectJSONwhere $ \v -> v ->. "a" ?&. ["b"]+ w <- selectJSONwhere (?&. [])+ liftIO $ length x `shouldBe` 2+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 1+ liftIO $ length w `shouldBe` 9++testConcatDeleteOperators :: SpecDb+testConcatDeleteOperators = do+ describe "Concatenation Operator" testConcatenationOperator+ describe "Deletion Operators" $ do+ testMinusOperator+ testMinusOperatorV10+ testHashMinusOperator++testConcatenationOperator :: SpecDb+testConcatenationOperator = do+ describe "Concatenation" $ do+ itDb "creates sane SQL" $ do+ let objAB = object ["a" .= False, "b" .= True]+ objC = object ["c" .= Null]+ createSaneSQL @JSONValue+ (jsonbVal objAB+ JSON.||. jsonbVal objC)+ "SELECT (? || ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped $ BSL.toStrict $ encode objAB+ , PersistLiteralEscaped $ BSL.toStrict $ encode objC+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL @JSONValue+ (jsonbVal obj ->. "a" JSON.||. jsonbVal (toJSON [Null]))+ "SELECT ((? -> ?) || ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , PersistText "a"+ , PersistLiteralEscaped "[null]"+ ]+ itDb "works as expected" $ do+ x <- selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (object [])+ where_ $ v JSON.||. jsonbVal (object ["x" .= True])+ @>. jsonbVal (object ["x" .= True])+ y <- selectJSONwhere $ \v ->+ v JSON.||. jsonbVal (toJSON [String "a", String "b"])+ ->>. 4 ==. just (val "b")+ z <- selectJSONwhere $ \v ->+ v JSON.||. jsonbVal (toJSON [Bool False])+ ->. 0 JSON.@>. jsonbVal (Number 1)+ w <- selectJSON $ \v -> do+ where_ . not_ $ v @>. jsonbVal (object [])+ where_ $ jsonbVal (String "test1") JSON.||. v ->>. 0 ==. just (val "test1")+ liftIO $ length x `shouldBe` 2+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 2+ liftIO $ length w `shouldBe` 7++testMinusOperator :: SpecDb+testMinusOperator =+ describe "Minus Operator" $ do+ itDb "creates sane SQL" $ do+ let obj = object ["a" .= False, "b" .= True]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL @JSONValue+ (jsonbVal obj JSON.-. "a")+ "SELECT (? - ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , PersistText "a"+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL @JSONValue+ (jsonbVal obj ->. "a" JSON.-. 0)+ "SELECT ((? -> ?) - ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , PersistText "a"+ , PersistInt64 0+ ]+ itDb "works as expected" $ do+ x <- selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))+ where_ $ v JSON.-. 0 @>. jsonbVal (toJSON [Bool True])+ y <- selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))+ where_ $ v JSON.-. (-1) @>. jsonbVal (toJSON [Null])+ z <- selectJSON_ $ \v -> v JSON.-. "b" ?&. ["a", "b"]+ w <- selectJSON_ $ \v -> do+ v JSON.-. "test" @>. jsonbVal (toJSON [String "test"])+ liftIO $ length x `shouldBe` 2+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 0+ liftIO $ length w `shouldBe` 0+ sqlFailWith "22023" $ selectJSONwhere $ \v ->+ v JSON.-. 0 @>. jsonbVal (toJSON ([] :: [Int]))+ where+ selectJSON_ f = selectJSON $ \v -> do+ where_+ $ v @>. jsonbVal (object [])+ ||. v @>. jsonbVal (toJSON ([] :: [Int]))+ where_ $ f v++testMinusOperatorV10 :: SpecDb+testMinusOperatorV10 = do+ describe "Minus Operator (PSQL >= v10)" $ do+ itDb "creates sane SQL" $ do+ let obj = object ["a" .= False, "b" .= True]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL @JSONValue+ (jsonbVal obj --. ["a","b"])+ "SELECT (? - ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , persistTextArray ["a","b"]+ ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ encoded = BSL.toStrict $ encode obj+ createSaneSQL @JSONValue+ (jsonbVal obj #>. ["a","0"] --. ["b"])+ "SELECT ((? #> ?) - ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped encoded+ , persistTextArray ["a","0"]+ , persistTextArray ["b"]+ ]+ itDb "works as expected" $ do+ x <- selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))+ where_ $ v --. ["test","a"] @>. jsonbVal (toJSON [String "test"])+ y <- selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (object [])+ where_ $ v --. ["a","b"] <@. jsonbVal (object [])+ z <- selectJSON_ $ \v -> v --. ["b"] <@. jsonbVal (object ["a" .= (1 :: Int)])+ w <- selectJSON_ $ \v -> do+ v --. ["test"] @>. jsonbVal (toJSON [String "test"])+ liftIO $ length x `shouldBe` 0+ liftIO $ length y `shouldBe` 2+ liftIO $ length z `shouldBe` 1+ liftIO $ length w `shouldBe` 0+ sqlFailWith "22023" $ selectJSONwhere $ \v ->+ v --. ["a"] @>. jsonbVal (toJSON ([] :: [Int]))+ where+ selectJSON_ f = selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (object [])+ ||. v @>. jsonbVal (toJSON ([] :: [Int]))+ where_ $ f v++testHashMinusOperator :: SpecDb+testHashMinusOperator =+ describe "Hash-Minus Operator" $ do+ itDb "creates sane SQL" $+ createSaneSQL @JSONValue+ (jsonbVal (object ["a" .= False, "b" .= True]) #-. ["a"])+ "SELECT (? #- ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped (BSL.toStrict $ encode $ object ["a" .= False, "b" .= True])+ , persistTextArray ["a"] ]+ itDb "creates sane SQL (chained)" $ do+ let obj = object ["a" .= [object ["b" .= True]]]+ createSaneSQL @JSONValue+ (jsonbVal obj ->. "a" #-. ["0","b"])+ "SELECT ((? -> ?) #- ?)\nFROM \"Json\"\n"+ [ PersistLiteralEscaped (BSL.toStrict $ encode obj)+ , PersistText "a"+ , persistTextArray ["0","b"] ]+ itDb "works as expected" $ do+ x <- selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))+ where_ $ v #-. ["1","a"] @>. jsonbVal (toJSON [object []])+ y <- selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (toJSON ([] :: [Int]))+ where_ $ v #-. ["-3","a"] @>. jsonbVal (toJSON [object []])+ z <- selectJSON_ $ \v -> v #-. ["a","b","c"]+ @>. jsonbVal (object ["a" .= object ["b" .= object ["c" .= String "message"]]])+ w <- selectJSON_ $ \v -> v #-. ["a","b"] JSON.?. "b"+ liftIO $ length x `shouldBe` 1+ liftIO $ length y `shouldBe` 1+ liftIO $ length z `shouldBe` 0+ liftIO $ length w `shouldBe` 1+ sqlFailWith "22023" $ selectJSONwhere $ \v ->+ v #-. ["0"] @>. jsonbVal (toJSON ([] :: [Int]))+ where selectJSON_ f = selectJSON $ \v -> do+ where_ $ v @>. jsonbVal (object [])+ where_ $ f v++testInsertUniqueViolation :: SpecDb+testInsertUniqueViolation =+ describe "Unique Violation on Insert" $+ itDb "Unique throws exception" $ do+ eres <-+ try $ do+ _ <- insert u1+ _ <- insert u2+ insert u3+ liftIO $ case eres of+ Left err | err == exception ->+ pure ()+ _ ->+ expectationFailure $ "Expected a SQL exception, got: " <>+ show eres++ where+ exception = SqlError {+ sqlState = "23505",+ sqlExecStatus = FatalError,+ sqlErrorMsg = "duplicate key value violates unique constraint \"UniqueValue\"",+ sqlErrorDetail = "Key (value)=(0) already exists.",+ sqlErrorHint = ""}++testUpsert :: SpecDb+testUpsert = describe "Upsert test" $ do+ itDb "Upsert can insert like normal" $ do+ u1e <- EP.upsert u1 (pure (OneUniqueName =. val "fifth"))+ liftIO $ entityVal u1e `shouldBe` u1+ itDb "Upsert performs update on collision" $ do+ u1e <- EP.upsert u1 (pure (OneUniqueName =. val "fifth"))+ liftIO $ entityVal u1e `shouldBe` u1+ u2e <- EP.upsert u2 (pure (OneUniqueName =. val "fifth"))+ liftIO $ entityVal u2e `shouldBe` u2+ u3e <- EP.upsert u3 (pure (OneUniqueName =. val "fifth"))+ liftIO $ entityVal u3e `shouldBe` u1{oneUniqueName="fifth"}+ describe "With no updates" $ do+ itDb "Works with no updates" $ do+ _ <- EP.upsertMaybe u1 []+ pure ()+ itDb "Works with no updates, twice" $ do+ mu1 <- EP.upsertMaybe u1 []+ Entity u1Key u1' <- liftIO $ assertJust mu1+ mu2 <- EP.upsertMaybe u1 { oneUniqueName = "Something Else" } []+ asserting $ do+ mu2 `shouldBe` Nothing+ -- liftIO $ do+ -- u1 `shouldBe` u1'++testInsertSelectWithConflict :: SpecDb+testInsertSelectWithConflict =+ describe "insertSelectWithConflict test" $ do+ itDb "Should do Nothing when no updates set" $ do+ _ <- insert p1+ _ <- insert p2+ _ <- insert p3+ n1 <- EP.insertSelectWithConflictCount UniqueValue (+ from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)+ )+ (\current excluded -> [])+ uniques1 <- select $ from $ \u -> return u+ n2 <- EP.insertSelectWithConflictCount UniqueValue (+ from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)+ )+ (\current excluded -> [])+ uniques2 <- select $ from $ \u -> return u+ liftIO $ n1 `shouldBe` 3+ liftIO $ n2 `shouldBe` 0+ let test = map (OneUnique "test" . personFavNum) [p1,p2,p3]+ liftIO $ map entityVal uniques1 `shouldBe` test+ liftIO $ map entityVal uniques2 `shouldBe` test+ itDb "Should update a value if given an update on conflict" $ do+ _ <- insert p1+ _ <- insert p2+ _ <- insert p3+ -- Note, have to sum 4 so that the update does not conflicts again with another row.+ n1 <- EP.insertSelectWithConflictCount UniqueValue (+ from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)+ )+ (\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)])+ uniques1 <- select $ from $ \u -> return u+ n2 <- EP.insertSelectWithConflictCount UniqueValue (+ from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)+ )+ (\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)])+ uniques2 <- select $ from $ \u -> return u+ liftIO $ n1 `shouldBe` 3+ liftIO $ n2 `shouldBe` 3+ let test = map (OneUnique "test" . personFavNum) [p1,p2,p3]+ test2 = map (OneUnique "test" . (+4) . (*2) . personFavNum) [p1,p2,p3]+ liftIO $ map entityVal uniques1 `shouldBe` test+ liftIO $ map entityVal uniques2 `shouldBe` test2++testFilterWhere :: SpecDb+testFilterWhere =+ describe "filterWhere" $ do+ itDb "adds a filter clause to count aggregation" $ do+ -- Person "John" (Just 36) Nothing 1+ _ <- insert p1+ -- Person "Rachel" Nothing (Just 37) 2+ _ <- insert p2+ -- Person "Mike" (Just 17) Nothing 3+ _ <- insert p3+ -- Person "Livia" (Just 17) (Just 18) 4+ _ <- insert p4+ -- Person "Mitch" Nothing Nothing 5+ _ <- insert p5++ usersByAge <- fmap coerce <$> do+ select $ from $ \users -> do+ groupBy $ users ^. PersonAge+ return+ ( users ^. PersonAge :: SqlExpr (Value (Maybe Int))+ -- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = 2+ -- Just 36: [John { favNum = 1 } (excluded)] = 0+ -- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = 2+ , count (users ^. PersonId) `EP.filterWhere` (users ^. PersonFavNum >=. val 2)+ :: SqlExpr (Value Int)+ -- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = 0+ -- Just 36: [John { favNum = 1 }] = 1+ -- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = 0+ , count (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2)+ :: SqlExpr (Value Int)+ )++ liftIO $ usersByAge `shouldMatchList`+ ( [ (Nothing, 2, 0)+ , (Just 36, 0, 1)+ , (Just 17, 2, 0)+ ] :: [(Maybe Int, Int, Int)]+ )++ itDb "adds a filter clause to sum aggregation" $ do+ -- Person "John" (Just 36) Nothing 1+ _ <- insert p1+ -- Person "Rachel" Nothing (Just 37) 2+ _ <- insert p2+ -- Person "Mike" (Just 17) Nothing 3+ _ <- insert p3+ -- Person "Livia" (Just 17) (Just 18) 4+ _ <- insert p4+ -- Person "Mitch" Nothing Nothing 5+ _ <- insert p5++ usersByAge <- fmap (\(Value a, Value b, Value c) -> (a, b, c)) <$> do+ select $ from $ \users -> do+ groupBy $ users ^. PersonAge+ return+ ( users ^. PersonAge+ -- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = Just 7+ -- Just 36: [John { favNum = 1 } (excluded)] = Nothing+ -- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = Just 7+ , sum_ (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum >=. val 2)+ -- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = Nothing+ -- Just 36: [John { favNum = 1 }] = Just 1+ -- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = Nothing+ , sum_ (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2)+ )++ liftIO $ usersByAge `shouldMatchList`+ ( [ (Nothing, Just 7, Nothing)+ , (Just 36, Nothing, Just 1)+ , (Just 17, Just 7, Nothing)+ ] :: [(Maybe Int, Maybe Rational, Maybe Rational)]+ )++testCommonTableExpressions :: SpecDb+testCommonTableExpressions = do+ describe "You can run them" $ do+ itDb "will run" $ do+ void $ select $ do+ limitedLordsCte <-+ Experimental.with $ do+ lords <- Experimental.from $ Experimental.table @Lord+ limit 10+ pure lords+ lords <- Experimental.from limitedLordsCte+ orderBy [asc $ lords ^. LordId]+ pure lords++ asserting noExceptions++ itDb "can do multiple recursive queries" $ do+ let+ oneToTen =+ Experimental.withRecursive+ (pure $ val (1 :: Int))+ Experimental.unionAll_+ (\self -> do+ v <- Experimental.from self+ where_ $ v <. val 10+ pure $ v +. val 1+ )++ vals <- select $ do+ cte <- oneToTen+ cte2 <- oneToTen+ res1 <- Experimental.from cte+ res2 <- Experimental.from cte2+ pure (res1, res2)+ asserting $ vals `shouldBe` (((,) <$> fmap Value [1..10] <*> fmap Value [1..10]))++ itDb "passing previous query works" $ do+ let+ oneToTen =+ Experimental.withRecursive+ (pure $ val (1 :: Int))+ Experimental.unionAll_+ (\self -> do+ v <- Experimental.from self+ where_ $ v <. val 10+ pure $ v +. val 1+ )++ oneMore q =+ Experimental.with $ do+ v <- Experimental.from q+ pure $ v +. val 1+ vals <- select $ do+ cte <- oneToTen+ cte2 <- oneMore cte+ res <- Experimental.from cte2+ pure res+ asserting $ vals `shouldBe` fmap Value [2..11]++ describe "MATERIALIZED CTEs" $ do+ describe "withNotMaterialized" $ do+ itDb "successfully executes query" $ do+ void $ select $ do+ limitedLordsCte <-+ withNotMaterialized $ do+ lords <- Experimental.from $ Experimental.table @Lord+ limit 10+ pure lords+ lords <- Experimental.from limitedLordsCte+ orderBy [asc $ lords ^. LordId]+ pure lords++ asserting noExceptions++ itDb "generates the expected SQL" $ do+ (sql, _) <- showQuery ES.SELECT $ do+ limitedLordsCte <-+ withNotMaterialized $ do+ lords <- Experimental.from $ Experimental.table @Lord+ limit 10+ pure lords+ lords <- Experimental.from limitedLordsCte+ orderBy [asc $ lords ^. LordId]+ pure lords++ asserting $ sql `shouldBe` T.unlines+ [ "WITH \"cte\" AS NOT MATERIALIZED (SELECT \"Lord\".\"county\" AS \"v_county\", \"Lord\".\"dogs\" AS \"v_dogs\""+ , "FROM \"Lord\""+ , " LIMIT 10"+ , ")"+ , "SELECT \"cte\".\"v_county\", \"cte\".\"v_dogs\""+ , "FROM \"cte\""+ , "ORDER BY \"cte\".\"v_county\" ASC"+ ]+ asserting noExceptions+++ describe "withMaterialized" $ do+ itDb "generates the expected SQL" $ do+ (sql, _) <- showQuery ES.SELECT $ do+ limitedLordsCte <-+ withMaterialized $ do+ lords <- Experimental.from $ Experimental.table @Lord+ limit 10+ pure lords+ lords <- Experimental.from limitedLordsCte+ orderBy [asc $ lords ^. LordId]+ pure lords++ asserting $ sql `shouldBe` T.unlines+ [ "WITH \"cte\" AS MATERIALIZED (SELECT \"Lord\".\"county\" AS \"v_county\", \"Lord\".\"dogs\" AS \"v_dogs\""+ , "FROM \"Lord\""+ , " LIMIT 10"+ , ")"+ , "SELECT \"cte\".\"v_county\", \"cte\".\"v_dogs\""+ , "FROM \"cte\""+ , "ORDER BY \"cte\".\"v_county\" ASC"+ ]+ asserting noExceptions++ itDb "successfully executes query" $ do+ void $ select $ do+ limitedLordsCte <-+ withMaterialized $ do+ lords <- Experimental.from $ Experimental.table @Lord+ limit 10+ pure lords+ lords <- Experimental.from limitedLordsCte+ orderBy [asc $ lords ^. LordId]+ pure lords++ asserting noExceptions++testPostgresqlLocking :: SpecDb+testPostgresqlLocking = do+ describe "Monoid instance" $ do+ let toText conn q =+ let (tlb, _) = ES.toRawSql ES.SELECT (conn, ES.initialIdentState) q+ in TLB.toLazyText tlb+ itDb "concatenates postgres locking clauses" $ do+ let multipleLockingQuery = do+ p <- Experimental.from $ table @Person+ EP.forUpdateOf p EP.skipLocked+ EP.forUpdateOf p EP.skipLocked+ EP.forNoKeyUpdateOf p EP.skipLocked+ EP.forShareOf p EP.skipLocked+ EP.forKeyShareOf p EP.skipLocked+ conn <- ask+ let res1 = toText conn multipleLockingQuery+ resExpected =+ TL.unlines+ [+ "SELECT 1"+ ,"FROM \"Person\""+ ,"FOR UPDATE OF \"Person\" SKIP LOCKED"+ ,"FOR UPDATE OF \"Person\" SKIP LOCKED"+ ,"FOR NO KEY UPDATE OF \"Person\" SKIP LOCKED"+ ,"FOR SHARE OF \"Person\" SKIP LOCKED"+ ,"FOR KEY SHARE OF \"Person\" SKIP LOCKED"+ ]++ asserting $ res1 `shouldBe` resExpected++ describe "For update skip locked locking" $ sequential $ do+ let mkInitialStateForLockingTest connection =+ flip runSqlPool connection $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ blogPosts <- mapM insert'+ [ BlogPost "A" p1k+ , BlogPost "B" p2k+ , BlogPost "C" p3k ]+ pure ([p1k, p2k, p3k], entityKey <$> blogPosts)+ cleanupLockingTest connection (personKeys, blogPostKeys) =+ flip runSqlPool connection $ do+ forM_ blogPostKeys P.delete+ forM_ personKeys P.delete+ aroundWith (\testAction connection -> do+ bracket (mkInitialStateForLockingTest connection) (cleanupLockingTest connection) $ \(personKeys, blogPostKeys) ->+ testAction (connection, personKeys, blogPostKeys)+ ) $ do+ it "skips locked rows for a locking select" $ \(connection, _, _) -> do+ waitMainThread <- newEmptyMVar++ let sideThread :: IO Expectation+ sideThread = do+ flip runSqlPool connection $ do++ _ <- takeMVar waitMainThread+ nonLockedRowsNonSpecified <-+ select $ do+ p <- Experimental.from $ table @Person+ EP.forUpdateOf p EP.skipLocked+ return p++ nonLockedRowsSpecifiedTable <-+ select $ do+ from $ \(p `LeftOuterJoin` b) -> do+ on (p ^. PersonId ==. b ^. BlogPostAuthorId)+ EP.forUpdateOf p EP.skipLocked+ return p++ nonLockedRowsSpecifyAllTables <-+ select $ do+ from $ \(p `InnerJoin` b) -> do+ on (p ^. PersonId ==. b ^. BlogPostAuthorId)+ EP.forUpdateOf (p :& b) EP.skipLocked+ return p++ pure $ do+ nonLockedRowsNonSpecified `shouldBe` []+ nonLockedRowsSpecifiedTable `shouldBe` []+ nonLockedRowsSpecifyAllTables `shouldBe` []++ withAsync sideThread $ \sideThreadAsync -> do+ void $ flip runSqlPool connection $ do+ void $ select $ do+ person <- Experimental.from $ table @Person+ locking ForUpdate+ pure $ person ^. PersonId++ _ <- putMVar waitMainThread ()+ sideThreadAsserts <- wait sideThreadAsync+ nonLockedRowsAfterUpdate <- select $ do+ from $ \(p `LeftOuterJoin` b) -> do+ on (p ^. PersonId ==. b ^. BlogPostAuthorId)+ EP.forUpdateOf p EP.skipLocked+ return p++ asserting sideThreadAsserts+ asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3++ it "skips locked rows for a subselect update" $ \(connection, _, _)-> do+ waitMainThread <- newEmptyMVar++ let sideThread :: IO Expectation+ sideThread =+ flip runSqlPool connection $ do+ _ <- liftIO $ takeMVar waitMainThread++ nonLockedRowsSpecifiedTable <-+ select $ do+ from $ \(p `LeftOuterJoin` b) -> do+ on (p ^. PersonId ==. b ^. BlogPostAuthorId)+ EP.forUpdateOf p EP.skipLocked+ return p++ pure $ length nonLockedRowsSpecifiedTable `shouldBe` 2++ withAsync sideThread $ \sideThreadAsync -> do+ void $ flip runSqlPool connection $ do+ update $ \p -> do+ set p [ PersonName =. val "ChangedName1" ]+ where_ $ p ^. PersonId+ `in_` subList_select (do+ person <- Experimental.from $ table @Person+ where_ (person ^. PersonName ==. val "Rachel")+ limit 1+ locking ForUpdate+ pure $ person ^. PersonId)+++ _ <- putMVar waitMainThread ()+ sideThreadAsserts <- wait sideThreadAsync+ nonLockedRowsAfterUpdate <- select $ do+ from $ \(p `LeftOuterJoin` b) -> do+ on (p ^. PersonId ==. b ^. BlogPostAuthorId)+ EP.forUpdateOf p EP.skipLocked+ return p++ asserting sideThreadAsserts+ asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3++ it "skips locked rows for a subselect join update" $ \(connection, _, _) -> do+ waitMainThread <- newEmptyMVar++ let sideThread :: IO Expectation+ sideThread =+ flip runSqlPool connection $ do+ liftIO $ takeMVar waitMainThread+ lockedRows <-+ select $ do+ from $ \(p `LeftOuterJoin` b) -> do+ on (p ^. PersonId ==. b ^. BlogPostAuthorId)+ where_ (b ^. BlogPostTitle ==. val "A")+ EP.forUpdateOf p EP.skipLocked+ return p++ nonLockedRows <-+ select $ do+ from $ \(p `LeftOuterJoin` b) -> do+ on (p ^. PersonId ==. b ^. BlogPostAuthorId)+ EP.forUpdateOf p EP.skipLocked+ return p++ pure $ do+ lockedRows `shouldBe` []+ length nonLockedRows `shouldBe` 2++ withAsync sideThread $ \sideThreadAsync -> do+ void $ flip runSqlPool connection $ do+ update $ \p -> do+ set p [ PersonName =. val "ChangedName" ]+ where_ $ p ^. PersonId+ `in_` subList_select (do+ (people :& blogPosts) <-+ Experimental.from $ table @Person+ `Experimental.leftJoin` table @BlogPost+ `Experimental.on` (\(people :& blogPosts) ->+ just (people ^. PersonId) ==. blogPosts ?. BlogPostAuthorId)+ where_ (blogPosts ?. BlogPostTitle ==. just (val "A"))+ pure $ people ^. PersonId+ )++ liftIO $ putMVar waitMainThread ()+ sideThreadAsserts <- wait sideThreadAsync+ nonLockedRowsAfterUpdate <- select $ do+ from $ \(p `LeftOuterJoin` b) -> do+ on (p ^. PersonId ==. b ^. BlogPostAuthorId)+ EP.forUpdateOf p EP.skipLocked+ return p++ asserting sideThreadAsserts+ asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3++ describe "noWait" $ do+ itDb "doesn't crash" $ do+ select $ do+ t <- Experimental.from $ table @Person+ EP.forUpdateOf t EP.noWait+ pure t++ asserting noExceptions++-- Since lateral queries arent supported in Sqlite or older versions of mysql+-- the test is in the Postgres module+testLateralQuery :: SpecDb+testLateralQuery = do+ describe "Lateral queries" $ do+ itDb "supports CROSS JOIN LATERAL" $ do+ _ <- do+ select $ do+ l :& c <-+ Experimental.from $ table @Lord+ `CrossJoin` \lord -> do+ deed <- Experimental.from $ table @Deed+ where_ $ lord ^. LordId ==. deed ^. DeedOwnerId+ pure $ countRows @Int+ pure (l, c)+ liftIO $ True `shouldBe` True++ itDb "supports INNER JOIN LATERAL" $ do+ let subquery lord = do+ deed <- Experimental.from $ table @Deed+ where_ $ lord ^. LordId ==. deed ^. DeedOwnerId+ pure $ countRows @Int+ res <- select $ do+ l :& c <- Experimental.from $ table @Lord+ `InnerJoin` subquery+ `Experimental.on` (const $ val True)+ pure (l, c)++ let _ = res :: [(Entity Lord, Value Int)]+ asserting noExceptions++ itDb "supports LEFT JOIN LATERAL" $ do+ res <- select $ do+ l :& c <- Experimental.from $ table @Lord+ `LeftOuterJoin` (\lord -> do+ deed <- Experimental.from $ table @Deed+ where_ $ lord ^. LordId ==. deed ^. DeedOwnerId+ pure $ countRows @Int)+ `Experimental.on` (const $ val True)+ pure (l, c)++ let _ = res :: [(Entity Lord, Value (Maybe Int))]+ asserting noExceptions++testValuesExpression :: SpecDb+testValuesExpression = do+ describe "(VALUES (..)) query" $ do+ itDb "works with joins and other sql expressions" $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ let exprs :: NE.NonEmpty (SqlExpr (Value Int), SqlExpr (Value Text))+ exprs = (val 10, val "ten")+ NE.:| [ (val 20, val "twenty")+ , (val 30, val "thirty") ]+ query = do+ (bound, boundName) :& person <- Experimental.from $+ EP.values exprs+ `Experimental.InnerJoin` table @Person+ `Experimental.on` (\((bound, boundName) :& person) -> person^.PersonAge >=. just bound)+ groupBy bound+ orderBy [ asc bound ]+ pure (bound, count @Int $ person^.PersonName)+ result <- select query+ liftIO $ result `shouldBe` [ (Value 10, Value 2)+ , (Value 20, Value 1)+ , (Value 30, Value 1) ]++ itDb "supports single-column query" $ do+ let query = do+ vInt <- Experimental.from $ EP.values $ val 1 NE.:| [ val 2, val 3 ]+ pure (vInt :: SqlExpr (Value Int))+ result <- select query+ asserting noExceptions+ liftIO $ result `shouldBe` [ Value 1, Value 2, Value 3 ]++ itDb "supports multi-column query (+ nested simple expression and null)" $ do+ let query = do+ (vInt, vStr, vDouble) <- Experimental.from+ $ EP.values $ (val 1, val "str1", coalesce [just $ val 1.0, nothing])+ NE.:| [ (val 2, val "str2", just $ val 2.5)+ , (val 3, val "str3", nothing) ]+ pure ( vInt :: SqlExpr (Value Int)+ , vStr :: SqlExpr (Value Text)+ , vDouble :: SqlExpr (Value (Maybe Double)) )+ result <- select query+ asserting noExceptions+ liftIO $ result `shouldBe` [ (Value 1, Value "str1", Value $ Just 1.0)+ , (Value 2, Value "str2", Value $ Just 2.5)+ , (Value 3, Value "str3", Value Nothing) ]++testSubselectAliasingBehavior :: SpecDb+testSubselectAliasingBehavior = do+ describe "Aliasing behavior" $ do+ itDb "correctly realiases entities accross multiple subselects" $ do+ _ <- select $ do+ Experimental.from $ Experimental.from $ Experimental.from $ table @Lord+ asserting noExceptions++ itDb "doesnt erroneously repeat variable names when using subselect + union" $ do+ let lordQuery = do+ l <- Experimental.from $ table @Lord+ pure (l ^. LordCounty, l ^. LordDogs)+ personQuery = do+ p <- Experimental.from $ table @Person+ pure (p ^. PersonName, just $ p ^. PersonFavNum)+ _ <- select $+ Experimental.from $ do+ (str, _) <- Experimental.from $ lordQuery `union_` personQuery+ pure (str, val @Int 1)+ asserting noExceptions++testPostgresqlNullsOrdering :: SpecDb+testPostgresqlNullsOrdering = do+ describe "Postgresql NULLS orderings work" $ do+ itDb "ASC NULLS FIRST works" $ do+ p1e <- insert' p1+ p2e <- insert' p2 -- p2 has a null age+ p3e <- insert' p3+ p4e <- insert' p4+ ret <- select $+ from $ \p -> do+ orderBy [EP.ascNullsFirst (p ^. PersonAge), EP.ascNullsFirst (p ^. PersonFavNum)]+ return p+ -- nulls come first+ asserting $ ret `shouldBe` [ p2e, p3e, p4e, p1e ]+ itDb "ASC NULLS LAST works" $ do+ p1e <- insert' p1+ p2e <- insert' p2 -- p2 has a null age+ p3e <- insert' p3+ p4e <- insert' p4+ ret <- select $+ from $ \p -> do+ orderBy [EP.ascNullsLast (p ^. PersonAge), EP.ascNullsLast (p ^. PersonFavNum)]+ return p+ -- nulls come last+ asserting $ ret `shouldBe` [ p3e, p4e, p1e, p2e ]+ itDb "DESC NULLS FIRST works" $ do+ p1e <- insert' p1+ p2e <- insert' p2 -- p2 has a null age+ p3e <- insert' p3+ p4e <- insert' p4+ ret <- select $+ from $ \p -> do+ orderBy [EP.descNullsFirst (p ^. PersonAge), EP.descNullsFirst (p ^. PersonFavNum)]+ return p+ -- nulls come first+ asserting $ ret `shouldBe` [ p2e, p1e, p4e, p3e ]+ itDb "DESC NULLS LAST works" $ do+ p1e <- insert' p1+ p2e <- insert' p2 -- p2 has a null age+ p3e <- insert' p3+ p4e <- insert' p4+ ret <- select $+ from $ \p -> do+ orderBy [EP.descNullsLast (p ^. PersonAge), EP.descNullsLast (p ^. PersonFavNum)]+ return p+ -- nulls come last+ asserting $ ret `shouldBe` [ p1e, p4e, p3e, p2e ]+++type JSONValue = Maybe (JSONB A.Value)++createSaneSQL :: (PersistField a, MonadIO m) => SqlExpr (Value a) -> T.Text -> [PersistValue] -> SqlPersistT m ()+createSaneSQL act q vals = do+ (query, args) <- showQuery ES.SELECT $ fromValue act+ liftIO $ do+ query `shouldBe` q+ args `shouldBe` vals++fromValue :: (PersistField a) => SqlExpr (Value a) -> SqlQuery (SqlExpr (Value a))+fromValue act = from $ \x -> do+ let _ = x :: SqlExpr (Entity Json)+ return act++persistTextArray :: [T.Text] -> PersistValue+persistTextArray = PersistArray . fmap PersistText++sqlFailWith+ :: (HasCallStack, MonadUnliftIO m, Show a)+ => ByteString+ -> SqlPersistT m a+ -> SqlPersistT m ()+sqlFailWith errState f = do+ eres <- try f+ case eres of+ Left err ->+ success err+ Right a ->+ liftIO $ expectationFailure $ mconcat+ [ "should fail with error code: "+ , T.unpack errStateT+ , ", but got: "+ , show a+ ]+ where+ success SqlError{sqlState}+ | sqlState == errState =+ pure ()+ | otherwise = do+ liftIO $ expectationFailure $ T.unpack $ T.concat+ [ "should fail with: ", errStateT+ , ", but received: ", TE.decodeUtf8 sqlState+ ]+ errStateT =+ TE.decodeUtf8 errState++selectJSONwhere+ :: MonadIO m+ => (JSONBExpr A.Value -> SqlExpr (Value Bool))+ -> SqlPersistT m [Entity Json]+selectJSONwhere f = selectJSON $ where_ . f++selectJSON+ :: MonadIO m+ => (JSONBExpr A.Value -> SqlQuery ())+ -> SqlPersistT m [Entity Json]+selectJSON f = select $ from $ \v -> do+ f $ just (v ^. JsonValue)+ return v++insertJsonValues :: SqlPersistT IO ()+insertJsonValues = do+ insertIt Null+ insertIt $ Bool True+ insertIt $ Number 1+ insertIt $ String "test"+ insertIt $ toJSON ([] :: [A.Value])+ insertIt $ toJSON [Number 1, Bool True, Null]+ insertIt $ toJSON [String "test",object ["a" .= Number 3.14], Null, Bool True]+ insertIt $ object ["a" .= (1 :: Int), "b" .= False]+ insertIt $ object ["a" .= object ["b" .= object ["c" .= String "message"]]]+ where+ insertIt :: MonadIO m => A.Value -> SqlPersistT m ()+ insertIt = insert_ . Json . JSONB++verbose :: Bool+verbose = False++migrateIt :: _ => SqlPersistT m ()+migrateIt = mapReaderT runNoLoggingT $ do+ void $ runMigrationSilent $ do+ migrateAll+ migrateUnique+ migrateJSON+ cleanDB+ cleanUniques++mkConnectionPool :: IO ConnectionPool+mkConnectionPool = do+ verbose' <- lookupEnv "VERBOSE" >>= \case+ Nothing ->+ return verbose+ Just x+ | map Char.toLower x == "true" -> return True+ | null x -> return True+ | otherwise -> return False+ pool <- if verbose'+ then+ runStderrLoggingT $+ createPostgresqlPool+ "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest"+ 4+ else+ runNoLoggingT $+ createPostgresqlPool+ "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest"+ 4+ flip runSqlPool pool $ do+ migrateIt+ pure pool -- | Show the SQL generated by a query showQuery :: (Monad m, ES.SqlSelect a r, BackendCompatible SqlBackend backend)
test/SQLite/Test.hs view
@@ -1,181 +1,139 @@-{-# LANGUAGE ScopedTypeVariables- , FlexibleContexts- , RankNTypes- , TypeFamilies- , OverloadedStrings-#-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} -module Main (main) where+module SQLite.Test where +import Common.Test.Import hiding (from, on)+ import Control.Monad (void)-import Control.Monad.IO.Class (MonadIO(liftIO))-import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT)-import Control.Monad.Trans.Reader (ReaderT)-import Database.Persist.Sqlite (withSqliteConn)-import Database.Sqlite (SqliteException)-import Database.Esqueleto hiding (random_)+import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)+import Database.Esqueleto.Legacy hiding (random_) import Database.Esqueleto.SQLite (random_)-import qualified Control.Monad.Trans.Resource as R-import Test.Hspec+import Database.Persist.Sqlite (createSqlitePool)+import Database.Sqlite (SqliteException) import Common.Test ----testSqliteRandom :: Spec+testSqliteRandom :: SpecDb testSqliteRandom = do- it "works with random_" $- run $ do- _ <- select $ return (random_ :: SqlExpr (Value Int))- return ()----+ itDb "works with random_" $ do+ _ <- select $ return (random_ :: SqlExpr (Value Int))+ asserting noExceptions -testSqliteSum :: Spec+testSqliteSum :: SpecDb testSqliteSum = do- it "works with sum_" $- run $ do- _ <- insert' p1- _ <- insert' p2- _ <- insert' p3- _ <- insert' p4- ret <- select $- from $ \p->- return $ joinV $ sum_ (p ^. PersonAge)- liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Int) ]+ itDb "works with sum_" $ do+ _ <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ _ <- insert' p4+ ret <- select $+ from $ \p->+ return $ joinV $ sum_ (p ^. PersonAge)+ asserting $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Int) ] -testSqliteTwoAscFields :: Spec+testSqliteTwoAscFields :: SpecDb testSqliteTwoAscFields = do- it "works with two ASC fields (one call)" $- run $ do- p1e <- insert' p1- p2e <- insert' p2- p3e <- insert' p3- p4e <- insert' p4- ret <- select $- from $ \p -> do- orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)]- return p- -- in SQLite and MySQL, its the reverse- liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ]----+ itDb "works with two ASC fields (one call)" $ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ p4e <- insert' p4+ ret <- select $+ from $ \p -> do+ orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)]+ return p+ -- in SQLite and MySQL, its the reverse+ asserting $ ret `shouldBe` [ p2e, p4e, p3e, p1e ] -testSqliteOneAscOneDesc :: Spec+testSqliteOneAscOneDesc :: SpecDb testSqliteOneAscOneDesc = do- it "works with one ASC and one DESC field (two calls)" $- run $ do- p1e <- insert' p1- p2e <- insert' p2- p3e <- insert' p3- p4e <- insert' p4- ret <- select $- from $ \p -> do- orderBy [desc (p ^. PersonAge)]- orderBy [asc (p ^. PersonName)]- return p- liftIO $ ret `shouldBe` [ p1e, p4e, p3e, p2e ]----+ itDb "works with one ASC and one DESC field (two calls)" $ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ p4e <- insert' p4+ ret <- select $+ from $ \p -> do+ orderBy [desc (p ^. PersonAge)]+ orderBy [asc (p ^. PersonName)]+ return p+ asserting $ ret `shouldBe` [ p1e, p4e, p3e, p2e ] -testSqliteCoalesce :: Spec+testSqliteCoalesce :: SpecDb testSqliteCoalesce = do- it "throws an exception on SQLite with <2 arguments" $- run (select $- from $ \p -> do- return (coalesce [p ^. PersonAge]) :: SqlQuery (SqlExpr (Value (Maybe Int))))- `shouldThrow` (\(_ :: SqliteException) -> True)----+ itDb "throws an exception on SQLite with <2 arguments" $ do+ eres <- try $ select $+ from $ \p -> do+ return (coalesce [p ^. PersonAge]) :: SqlQuery (SqlExpr (Value (Maybe Int)))+ asserting $ case eres of+ Left (_ :: SqliteException) ->+ pure ()+ Right _ ->+ expectationFailure "Expected SqliteException with <2 args to coalesce" -testSqliteUpdate :: Spec+testSqliteUpdate :: SpecDb testSqliteUpdate = do- it "works on a simple example" $- run $ do- p1k <- insert p1- p2k <- insert p2- p3k <- insert p3- let anon = "Anonymous"- () <- update $ \p -> do- set p [ PersonName =. val anon- , PersonAge *=. just (val 2) ]- where_ (p ^. PersonName !=. val "Mike")- n <- updateCount $ \p -> do- set p [ PersonAge +=. just (val 1) ]- where_ (p ^. PersonName !=. val "Mike")- ret <- select $- from $ \p -> do- orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ]- return p- -- SQLite: nulls appear first, update returns matched rows.- liftIO $ n `shouldBe` 2- liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing (Just 37) 2)- , Entity p1k (Person anon (Just 73) Nothing 1)- , Entity p3k p3 ]------nameContains :: (BaseBackend backend ~ SqlBackend,- BackendCompatible SqlBackend backend,- MonadIO m, SqlString s,- IsPersistBackend backend, PersistQueryRead backend,- PersistUniqueRead backend)- => (SqlExpr (Value [Char])- -> SqlExpr (Value s)- -> SqlExpr (Value Bool))- -> s- -> [Entity Person]- -> ReaderT backend m ()-nameContains f t expected = do- ret <- select $- from $ \p -> do- where_ (f- (p ^. PersonName)- ((%) ++. val t ++. (%)))- orderBy [asc (p ^. PersonName)]- return p- liftIO $ ret `shouldBe` expected+ itDb "works on a simple example" $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ let anon = "Anonymous" :: String+ () <- update $ \p -> do+ set p [ PersonName =. val anon+ , PersonAge *=. just (val 2) ]+ where_ (p ^. PersonName !=. val "Mike")+ n <- updateCount $ \p -> do+ set p [ PersonAge +=. just (val 1) ]+ where_ (p ^. PersonName !=. val "Mike")+ ret <- select $+ from $ \p -> do+ orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ]+ return p+ -- SQLite: nulls appear first, update returns matched rows.+ asserting $ do+ n `shouldBe` 2+ ret `shouldMatchList`+ [ Entity p2k (Person anon Nothing (Just 37) 2)+ , Entity p1k (Person anon (Just 73) Nothing 1)+ , Entity p3k p3+ ] -testSqliteTextFunctions :: Spec+testSqliteTextFunctions :: SpecDb testSqliteTextFunctions = do- describe "text functions" $ do- it "like, (%) and (++.) work on a simple example" $- run $ do- [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]- nameContains like "h" [p1e, p2e]- nameContains like "i" [p4e, p3e]- nameContains like "iv" [p4e]------main :: IO ()-main = do- hspec $ do- tests run+ describe "text functions" $ do+ itDb "like, (%) and (++.) work on a simple example" $ do+ let query :: String -> SqlPersistT IO [Entity Person]+ query t =+ select $+ from $ \p -> do+ where_ (like+ (p ^. PersonName)+ ((%) ++. val t ++. (%)))+ orderBy [asc (p ^. PersonName)]+ return p+ [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4]+ r0 <- query "h"+ r1 <- query "i"+ r2 <- query "iv"+ asserting $ do+ r0 `shouldBe` [p1e, p2e]+ r1 `shouldBe` [p4e, p3e]+ r2 `shouldBe` [p4e] - describe "Test SQLite locking" $ do- testLocking withConn+spec :: HasCallStack => Spec+spec = beforeAll mkConnectionPool $ do+ tests describe "SQLite specific tests" $ do- testAscRandom random_ run- testRandomMath run+ testAscRandom random_ testSqliteRandom testSqliteSum testSqliteTwoAscFields@@ -184,32 +142,23 @@ testSqliteUpdate testSqliteTextFunctions -----run, runSilent, runVerbose :: Run-runSilent act = runNoLoggingT $ run_worker act-runVerbose act = runStderrLoggingT $ run_worker act-run =- if verbose- then runVerbose- else runSilent+mkConnectionPool :: IO ConnectionPool+mkConnectionPool = do+ conn <-+ if verbose+ then runStderrLoggingT $+ createSqlitePool ".esqueleto-test.sqlite" 4+ else runNoLoggingT $+ createSqlitePool ".esqueleto-test.sqlite" 4+ flip runSqlPool conn $ do+ migrateIt + pure conn verbose :: Bool verbose = False --run_worker :: RunDbMonad m => SqlPersistT (R.ResourceT m) a -> m a-run_worker act = withConn $ runSqlConn (migrateIt >> act)---migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) ()+migrateIt :: MonadUnliftIO m => SqlPersistT m () migrateIt = do void $ runMigrationSilent migrateAll---withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a-withConn =- R.runResourceT . withSqliteConn ":memory:"+ cleanDB
+ test/Spec.hs view
@@ -0,0 +1,21 @@+module Main where++import Test.Hspec+import Test.Hspec.Core.Spec++import qualified SQLite.Test as SQLite+import qualified MySQL.Test as MySQL+import qualified PostgreSQL.Test as Postgres++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ parallel $ describe "Esqueleto" $ do+ describe "SQLite" $ do+ sequential $ SQLite.spec+ describe "MySQL" $ do+ sequential $ MySQL.spec+ describe "Postgresql" $ do+ sequential $ Postgres.spec