diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 8f4e14e87..40b6d9041 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -33,12 +33,22 @@ jobs: strategy: matrix: cabal: ["3.10.2.1"] - ghc: ["8.6.5", "8.8.4", "8.10.4", "9.0.2", "9.2.2", "9.4.5", "9.6.2", "9.8.1"] + ghc: + - "8.6" + - "8.8" + - "8.10" + - "9.0" + - "9.2" + - "9.4" + - "9.6" + - "9.8" + - "9.10" + # - "9.12" env: CONFIG: "--enable-tests --enable-benchmarks " steps: - - uses: actions/checkout@v2 - - uses: haskell/actions/setup@v2 + - uses: actions/checkout@v4 + - uses: haskell-actions/setup@v2 id: setup-haskell-cabal with: ghc-version: ${{ matrix.ghc }} @@ -59,9 +69,10 @@ jobs: # mysql database: 'esqutest' # Optional, default value is "test". The specified database which will be create # mysql user: 'travis' # Required if "mysql root password" is empty, default is empty. The superuser for the specified database. Can use secrets, too # mysql password: 'esqutest' # Required if "mysql user" exists. The password for the "mysql user" + - run: sudo apt-get update && sudo apt-get install -y libpcre3-dev - run: cabal v2-update - run: cabal v2-freeze $CONFIG - - uses: actions/cache@v2 + - uses: actions/cache@v4 with: path: | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} @@ -72,6 +83,6 @@ jobs: ${{ runner.os }}-${{ matrix.ghc }}- - run: cabal v2-build --disable-optimization -j $CONFIG - run: cabal v2-test --disable-optimization -j $CONFIG --test-options "--fail-on-focus" - - if: ${{ matrix.ghc != '8.6.5' }} + - if: ${{ matrix.ghc != '8.6' }} run: cabal v2-haddock -j $CONFIG - run: cabal v2-sdist diff --git a/Makefile b/Makefile index f0b35becc..7ac864507 100644 --- a/Makefile +++ b/Makefile @@ -58,6 +58,7 @@ clean: $(STACK) clean .PHONY: init-pgsql + init-pgsql: sudo -u postgres -- createuser -s esqutest diff --git a/changelog.md b/changelog.md index 5113ea968..3f8349f0f 100644 --- a/changelog.md +++ b/changelog.md @@ -6,6 +6,135 @@ - Change SqlExpr type to alias for new SqlExpr_ allowing for value "contexts". Currently used by window functions to avoid allowing double windowing. This change lays the groundwork for aggregate values as being contextually different from single values. - Add support for window functions in Postgres module +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 diff --git a/esqueleto.cabal b/esqueleto.cabal index 0822af6be..ef475c4a6 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -1,7 +1,6 @@ cabal-version: 1.12 name: esqueleto - version: 4.0.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. @@ -56,7 +55,7 @@ library hs-source-dirs: src/ build-depends: - base >=4.8 && <5.0 + base >=4.12 && <5.0 , aeson >=1.0 , attoparsec >= 0.13 && < 0.15 , blaze-html @@ -84,6 +83,8 @@ library -Wcpp-undef -Wcpp-undef default-language: Haskell2010 + default-extensions: + TypeOperators test-suite specs type: exitcode-stdio-1.0 @@ -91,6 +92,7 @@ test-suite specs other-modules: Common.Test Common.LegacyTest + Common.Test.CTE Common.Test.Models Common.Test.Import Common.Test.Select diff --git a/examples/Main.hs b/examples/Main.hs index f4cabebb1..78d58791a 100644 --- a/examples/Main.hs +++ b/examples/Main.hs @@ -28,6 +28,7 @@ import Control.Monad.Reader (MonadReader(..), runReaderT) import Control.Monad.Trans.Control (MonadBaseControl) import Database.Esqueleto.Experimental import Database.Persist.Postgresql (ConnectionString, withPostgresqlConn) +import qualified Database.Persist.Sql as Persistent import Database.Persist.TH ( mkMigrate , mkPersist @@ -36,7 +37,6 @@ import Database.Persist.TH , sqlSettings ) - share [ mkPersist sqlSettings , mkMigrate "migrateAll"] [persistLowerCase| Person diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index fccb46835..2d3f7f683 100644 --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -57,9 +57,45 @@ module Database.Esqueleto from , table , Table(..) - , SubQuery(..) , selectQuery + -- * @esqueleto@'s Language + , where_, on, groupBy, orderBy, asc, desc, limit, offset + , distinct, distinctOn, don, distinctOnOrderBy, having, locking + , (^.), (?.) + , val, isNothing, 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, toBaseIdMaybe, fromBaseIdMaybe + , subSelect + , subSelectMaybe + , subSelectCount + , subSelectForeign + , subSelectList + , subSelectUnsafe + , ToBaseId(..) + , when_ + , then_ + , else_ + , from + , Value(..) + , ValueList(..) + , OrderBy + , DistinctOn + , LockingKind(..) + , forUpdate + , forUpdateSkipLocked + , LockableEntity(..) + , SqlString -- ** Joins , (:&)(..) , on @@ -75,14 +111,9 @@ module Database.Esqueleto -- ** Set Operations -- $sql-set-operations , union_ - , Union(..) , unionAll_ - , UnionAll(..) , except_ - , Except(..) , intersect_ - , Intersect(..) - , pattern SelectQuery -- ** Common Table Expressions , with @@ -92,16 +123,14 @@ module Database.Esqueleto , From(..) , ToMaybe(..) , ToAlias(..) - , ToAliasT , ToAliasReference(..) - , ToAliasReferenceT , ToSqlSetOperation(..) -- * The Normal Stuff , where_ , groupBy + , groupBy_ , orderBy - , rand , asc , desc , limit @@ -114,12 +143,12 @@ module Database.Esqueleto , having , locking - , sub_select , (^.) , (?.) , val , isNothing + , isNothing_ , just , nothing , joinV diff --git a/src/Database/Esqueleto/Experimental.hs b/src/Database/Esqueleto/Experimental.hs index de08c880f..21c5a1b74 100644 --- a/src/Database/Esqueleto/Experimental.hs +++ b/src/Database/Esqueleto/Experimental.hs @@ -22,7 +22,6 @@ module Database.Esqueleto.Experimental {-# WARNING "This module will be removed from , table , Table(..) - , SubQuery(..) , selectQuery -- ** Joins @@ -40,14 +39,9 @@ module Database.Esqueleto.Experimental {-# WARNING "This module will be removed -- ** Set Operations -- $sql-set-operations , union_ - , Union(..) , unionAll_ - , UnionAll(..) , except_ - , Except(..) , intersect_ - , Intersect(..) - , pattern SelectQuery -- ** Common Table Expressions , with @@ -57,17 +51,16 @@ module Database.Esqueleto.Experimental {-# WARNING "This module will be removed , From(..) , ToMaybe(..) , ToAlias(..) - , ToAliasT , ToAliasReference(..) - , ToAliasReferenceT , ToSqlSetOperation(..) + , SqlSelect + , Nullable -- * The Normal Stuff , where_ , groupBy , groupBy_ , orderBy - , rand , asc , desc , limit @@ -79,8 +72,9 @@ module Database.Esqueleto.Experimental {-# WARNING "This module will be removed , distinctOnOrderBy , having , locking + , forUpdate + , forUpdateSkipLocked - , sub_select , (^.) , (?.) @@ -88,8 +82,10 @@ module Database.Esqueleto.Experimental {-# WARNING "This module will be removed , isNothing , isNothing_ , just + , just' , nothing , joinV + , joinV' , withNonNull , countRows @@ -160,6 +156,9 @@ module Database.Esqueleto.Experimental {-# WARNING "This module will be removed , case_ , toBaseId + , toBaseIdMaybe + , fromBaseId + , fromBaseIdMaybe , subSelect , subSelectMaybe , subSelectCount diff --git a/src/Database/Esqueleto/Experimental/From.hs b/src/Database/Esqueleto/Experimental/From.hs index 266250078..17ab9f774 100644 --- a/src/Database/Esqueleto/Experimental/From.hs +++ b/src/Database/Esqueleto/Experimental/From.hs @@ -98,10 +98,6 @@ table = From $ do ) -{-# DEPRECATED SubQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SubQuery@" #-} -newtype SubQuery a = SubQuery a -instance (SqlSelectCols a, ToAlias a, ToAliasReference a a') => ToFrom (SubQuery (SqlQuery a)) a' where - toFrom (SubQuery q) = selectQuery q instance (SqlSelectCols a, ToAlias a, ToAliasReference a a') => ToFrom (SqlQuery a) a' where toFrom = selectQuery diff --git a/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs b/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs index 7e56809d2..d71a18809 100644 --- a/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs +++ b/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs @@ -38,11 +38,13 @@ import Database.Esqueleto.Internal.Internal hiding (From(..), from, on) -- 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. +-- 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 a' + , ToAliasReference a' a' , SqlSelect a r ) => SqlQuery a -> SqlQuery (From a') with query = do @@ -50,10 +52,14 @@ with query = do 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) + let clause = CommonTableExpressionClause NormalCommonTableExpression (\_ _ -> "") ident (\info -> toRawSql SELECT info aliasedQuery) Q $ W.tell mempty{sdCteClause = [clause]} ref <- toAliasReference ident aliasedValue - pure $ From $ pure (ref, (\_ info -> (useIdent info ident, mempty))) + 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. @@ -103,7 +109,8 @@ withRecursive baseCase unionKind recursiveCase = do ref <- toAliasReference ident aliasedValue let refFrom = From (pure (ref, (\_ info -> (useIdent info ident, mempty)))) let recursiveQuery = recursiveCase refFrom - let clause = CommonTableExpressionClause RecursiveCommonTableExpression ident + let noModifier _ _ = "" + let clause = CommonTableExpressionClause RecursiveCommonTableExpression noModifier ident (\info -> (toRawSql SELECT info aliasedQuery) <> ("\n" <> (unUnionKind unionKind) <> "\n", mempty) <> (toRawSql SELECT info recursiveQuery) diff --git a/src/Database/Esqueleto/Experimental/From/Join.hs b/src/Database/Esqueleto/Experimental/From/Join.hs index a4789ed0e..0726d2f00 100644 --- a/src/Database/Esqueleto/Experimental/From/Join.hs +++ b/src/Database/Esqueleto/Experimental/From/Join.hs @@ -66,6 +66,7 @@ instance ValidOnClause (a -> SqlQuery b) instance (SqlSelectCols a, SqlSelectCols b) => SqlSelectCols (a :& b) where sqlSelectCols esc (a :& b) = sqlSelectCols esc (a, b) sqlSelectColCount = sqlSelectColCount . toTupleP + instance (SqlSelect a ra, SqlSelect b rb) => SqlSelect (a :& b) (ra :& rb) where sqlSelectProcessRow p = fmap (uncurry (:&)) . sqlSelectProcessRow (toTupleP p) diff --git a/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs b/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs index c532ac86d..6c7f9535c 100644 --- a/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs +++ b/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs @@ -74,11 +74,6 @@ mkSetOperation operation lhs rhs = SqlSetOperation $ \p -> do (_, rightClause) <- unSqlSetOperation (toSqlSetOperation rhs) p pure (leftValue, \info -> leftClause info <> (operation, mempty) <> rightClause info) -{-# DEPRECATED Union "/Since: 3.4.0.0/ - Use the 'union_' function instead of the 'Union' data constructor" #-} -data Union a b = a `Union` b -instance ToSqlSetOperation a a' => ToSqlSetOperation (Union a a) a' where - toSqlSetOperation (Union a b) = union_ a b - -- | Overloaded @union_@ function to support use in both 'SqlSetOperation' -- and 'withRecursive' -- @@ -102,30 +97,10 @@ instance (ToSqlSetOperation a c, ToSqlSetOperation b c, res ~ SqlSetOperation c) => UnionAll_ (a -> b -> res) where unionAll_ = mkSetOperation " UNION ALL " -{-# DEPRECATED UnionAll "/Since: 3.4.0.0/ - Use the 'unionAll_' function instead of the 'UnionAll' data constructor" #-} -data UnionAll a b = a `UnionAll` b -instance ToSqlSetOperation a a' => ToSqlSetOperation (UnionAll a a) a' where - toSqlSetOperation (UnionAll a b) = unionAll_ a b - -{-# DEPRECATED Except "/Since: 3.4.0.0/ - Use the 'except_' function instead of the 'Except' data constructor" #-} -data Except a b = a `Except` b -instance ToSqlSetOperation a a' => ToSqlSetOperation (Except a a) a' where - toSqlSetOperation (Except a b) = except_ a b - -- | @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 " -{-# DEPRECATED Intersect "/Since: 3.4.0.0/ - Use the 'intersect_' function instead of the 'Intersect' data constructor" #-} -data Intersect a b = a `Intersect` b -instance ToSqlSetOperation a a' => ToSqlSetOperation (Intersect a a) a' where - toSqlSetOperation (Intersect a b) = intersect_ a b - -- | @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 " - -{-# DEPRECATED SelectQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SelectQuery@" #-} -pattern SelectQuery :: p -> p -pattern SelectQuery a = a - diff --git a/src/Database/Esqueleto/Experimental/ToAlias.hs b/src/Database/Esqueleto/Experimental/ToAlias.hs index d1eea9a9e..0810f3764 100644 --- a/src/Database/Esqueleto/Experimental/ToAlias.hs +++ b/src/Database/Esqueleto/Experimental/ToAlias.hs @@ -8,9 +8,6 @@ module Database.Esqueleto.Experimental.ToAlias import Database.Esqueleto.Internal.Internal hiding (From, from, on) import Database.Esqueleto.Internal.PersistentImport -{-# DEPRECATED ToAliasT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-} -type ToAliasT a = a - -- Tedious tuple magic class ToAlias a where toAlias :: a -> SqlQuery a diff --git a/src/Database/Esqueleto/Experimental/ToAliasReference.hs b/src/Database/Esqueleto/Experimental/ToAliasReference.hs index 9af0d2b83..ed92680e4 100644 --- a/src/Database/Esqueleto/Experimental/ToAliasReference.hs +++ b/src/Database/Esqueleto/Experimental/ToAliasReference.hs @@ -10,9 +10,6 @@ module Database.Esqueleto.Experimental.ToAliasReference import Database.Esqueleto.Internal.Internal hiding (From, from, on) import Database.Esqueleto.Internal.PersistentImport -{-# DEPRECATED ToAliasReferenceT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-} -type ToAliasReferenceT a = a - -- more tedious tuple magic class ToAliasReference a a' | a -> a' where toAliasReference :: Ident -> a -> SqlQuery a' @@ -32,12 +29,7 @@ instance ToAliasReference (SqlExpr_ ctx (Entity a)) (SqlExpr_ ValueContext (Enti instance ToAliasReference (SqlExpr_ ctx (Maybe (Entity a))) (SqlExpr_ ValueContext (Maybe (Entity a))) where toAliasReference aliasSource e = - let maybelizeExpr :: SqlExpr_ ctx (Maybe (Entity a)) -> SqlExpr_ ctx (Entity a) - maybelizeExpr = veryUnsafeCoerceSqlExpr - unmaybelizeExpr :: SqlExpr_ ctx (Entity a) -> SqlExpr_ ctx (Maybe (Entity a)) - unmaybelizeExpr = veryUnsafeCoerceSqlExpr - in - unmaybelizeExpr <$> toAliasReference aliasSource (maybelizeExpr e) + veryUnsafeCoerceSqlExpr <$> toAliasReference aliasSource (veryUnsafeCoerceSqlExpr e :: SqlExpr (Entity a)) instance (ToAliasReference a a', ToAliasReference b b') => ToAliasReference (a, b) (a', b') where diff --git a/src/Database/Esqueleto/Experimental/ToMaybe.hs b/src/Database/Esqueleto/Experimental/ToMaybe.hs index 641a6e83b..84bdc1fbe 100644 --- a/src/Database/Esqueleto/Experimental/ToMaybe.hs +++ b/src/Database/Esqueleto/Experimental/ToMaybe.hs @@ -2,15 +2,14 @@ {-# 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(..)) -type family Nullable a where - Nullable (Maybe a) = a - Nullable a = a - class ToMaybe a where type ToMaybeT a toMaybe :: a -> ToMaybeT a diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 4e18636a1..e18ae0413 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# language AllowAmbiguousTypes #-} {-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} @@ -7,6 +9,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} @@ -34,6 +37,7 @@ -- tracker so we can safely support it. module Database.Esqueleto.Internal.Internal where +import Data.Coerce (Coercible) import Control.Applicative ((<|>)) import Control.Arrow (first, (***)) import Control.Exception (Exception, throw, throwIO) @@ -54,6 +58,7 @@ 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 @@ -70,7 +75,6 @@ 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 @@ -121,8 +125,8 @@ fromStartMaybe fromStartMaybe = maybelize <$> fromStart where maybelize - :: PreprocessedFrom (SqlExpr_ ctx (Entity a)) - -> PreprocessedFrom (SqlExpr_ ctx (Maybe (Entity a))) + :: PreprocessedFrom (SqlExpr (Entity a)) + -> PreprocessedFrom (SqlExpr (Maybe (Entity a))) maybelize (PreprocessedFrom e f') = PreprocessedFrom (veryUnsafeCoerceSqlExpr e) f' -- | (Internal) Do a @JOIN@. @@ -359,6 +363,8 @@ distinct act = Q (W.tell mempty { sdDistinctClause = DistinctStandard }) >> act 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'. -- @@ -398,12 +404,6 @@ distinctOnOrderBy exprs act = $ TLB.toLazyText b , vals ) --- | @ORDER BY random()@ clause. --- --- @since 1.3.10 -rand :: SqlExpr OrderBy -rand = ERaw noMeta $ \_ _ -> ("RANDOM()", []) - -- | @HAVING@. -- -- @since 1.2.2 @@ -427,29 +427,6 @@ locking kind = putLocking $ LegacyLockingClause kind putLocking :: LockingClause -> SqlQuery () putLocking clause = Q $ W.tell mempty { sdLockingClause = clause } -{-# - 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_ ctx (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 @@ -467,9 +444,9 @@ sub_select = sub SELECT -- -- @since 3.2.0 subSelect - :: PersistField a + :: (PersistField a, NullableFieldProjection a a') => SqlQuery (SqlExpr_ ctx (Value a)) - -> SqlExpr (Value (Maybe a)) + -> SqlExpr (Value (Maybe a')) subSelect query = just (subSelectUnsafe (query <* limit 1)) -- | Execute a subquery @SELECT@ in a 'SqlExpr'. This function is a shorthand @@ -626,12 +603,28 @@ 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. -(?.) :: ( PersistEntity val , PersistField typ) - => SqlExpr (Maybe (Entity val)) - -> EntityField val typ - -> SqlExpr (Value (Maybe typ)) -ERaw m f ?. field = just (ERaw m f ^. field) +-- +-- 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 :: forall typ ctx. PersistField typ => typ -> SqlExpr_ ctx (Value typ) @@ -677,25 +670,60 @@ isNothing v = -- "Data.Maybe" 'Data.Maybe.isNothing'. -- -- @since 3.5.10.0 -isNothing_ :: PersistField typ => SqlExpr (Value (Maybe typ)) -> SqlExpr (Value Bool) +isNothing_ :: PersistField typ => SqlExpr_ ctx (Value (Maybe typ)) -> SqlExpr_ ctx (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'@. -just :: SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value (Maybe typ)) +-- +-- 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_ ctx (Value typ) -> SqlExpr_ ctx (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. -joinV :: SqlExpr_ ctx (Value (Maybe (Maybe typ))) -> SqlExpr_ ctx (Value (Maybe typ)) +-- +-- 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_ ctx (Value (Maybe typ)) + -> SqlExpr_ ctx (Value (Maybe typ')) joinV = veryUnsafeCoerceSqlExprValue -countHelper :: Num a => TLB.Builder -> TLB.Builder -> SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx' (Value a) +-- | 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_ ctx (Value typ) -> SqlExpr_ ctx (Value a) countHelper open close v = case v of ERaw meta f -> @@ -712,100 +740,177 @@ countRows :: Num a => SqlExpr_ ctx (Value a) countRows = unsafeSqlValue "COUNT(*)" -- | @COUNT@. -count :: Num a => SqlExpr (Value typ) -> SqlExpr_ ctx (Value a) +count :: Num a => SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value a) count = countHelper "" "" -- | @COUNT(DISTINCT x)@. -- -- @since 2.4.1 -countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr_ ctx (Value a) +countDistinct :: Num a => SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value a) countDistinct = countHelper "(DISTINCT " ")" not_ :: SqlExpr_ ctx (Value Bool) -> SqlExpr_ ctx (Value Bool) -not_ v = ERaw noMeta $ \p info -> first ("NOT " <>) $ x p info +not_ v = ERaw noMeta (const $ first ("NOT " <>) . x) where - x p info = + x info = case v of ERaw m f -> if hasCompositeKeyMeta m then throw (CompositeKeyErr NotError) else - let (b, vals) = f Never info - in (parensM p b, vals) + f Parens info -(==.) :: (PersistField a) - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value Bool) +-- | 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_ ctx (Value typ) -> SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value Bool) (==.) = unsafeSqlBinOpComposite " = " " AND " -(>=.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value Bool) +-- | This operator translates to the SQL operator @>=@. +-- +-- Example: +-- +-- @ +-- where_ $ user ^. UserAge >=. val 21 +-- @ +(>=.) :: PersistField typ => SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value Bool) (>=.) = unsafeSqlBinOp " >= " -(>.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value Bool) +-- | This operator translates to the SQL operator @>@. +-- +-- Example: +-- +-- @ +-- where_ $ user ^. UserAge >. val 20 +-- @ +(>.) :: PersistField typ => SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value Bool) (>.) = unsafeSqlBinOp " > " -(<=.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value Bool) +-- | This operator translates to the SQL operator @<=@. +-- +-- Example: +-- +-- @ +-- where_ $ val 21 <=. user ^. UserAge +-- @ +(<=.) :: PersistField typ => SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value Bool) (<=.) = unsafeSqlBinOp " <= " -(<.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value Bool) -(<.) = unsafeSqlBinOp " < " +-- | This operator translates to the SQL operator @<@. +-- +-- Example: +-- +-- @ +-- where_ $ val 20 <. user ^. UserAge +-- @ +(<.) :: PersistField typ => SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value Bool) +(<.) = unsafeSqlBinOp " < " -(!=.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value Bool) +-- | This operator translates to the SQL operator @!=@. +-- +-- Example: +-- +-- @ +-- where_ $ user ^. UserName !=. val "Bob" +-- @ +(!=.) :: PersistField typ => SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value Bool) (!=.) = unsafeSqlBinOpComposite " != " " OR " -(&&.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value Bool) +-- | This operator translates to the SQL operator @AND@. +-- +-- Example: +-- +-- @ +-- where_ $ +-- user ^. UserName ==. val "Matt" +-- &&. user ^. UserAge >=. val 21 +-- @ +(&&.) :: SqlExpr_ ctx (Value Bool) -> SqlExpr_ ctx (Value Bool) -> SqlExpr_ ctx (Value Bool) (&&.) = unsafeSqlBinOp " AND " -(||.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value Bool) +-- | This operator translates to the SQL operator @AND@. +-- +-- Example: +-- +-- @ +-- where_ $ +-- user ^. UserName ==. val "Matt" +-- ||. user ^. UserName ==. val "John" +-- @ +(||.) :: SqlExpr_ ctx (Value Bool) -> SqlExpr_ ctx (Value Bool) -> SqlExpr_ ctx (Value Bool) (||.) = unsafeSqlBinOp " OR " -(+.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) +-- | 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_ ctx (Value a) -> SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value a) (+.) = unsafeSqlBinOp " + " -(-.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) +-- | 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_ ctx (Value a) -> SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value a) (-.) = unsafeSqlBinOp " - " -(/.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) +-- | 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_ ctx (Value a) -> SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value a) (/.) = unsafeSqlBinOp " / " -(*.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) +-- | 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_ ctx (Value a) -> SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value a) (*.) = unsafeSqlBinOp " * " --- | @BETWEEN@. +-- | @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 @@ -814,9 +919,6 @@ between :: PersistField a -> SqlExpr_ ctx (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_ ctx (Value a) -> SqlExpr_ ctx (Value b) round_ = unsafeSqlFunction "ROUND" @@ -828,12 +930,21 @@ floor_ = unsafeSqlFunction "FLOOR" sum_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr_ ctx (Value (Maybe b)) sum_ = unsafeSqlFunction "SUM" -min_ :: (PersistField a) => SqlExpr (Value a) -> SqlExpr_ ctx (Value (Maybe a)) -min_ = unsafeSqlFunction "MIN" -max_ :: (PersistField a) => SqlExpr (Value a) -> SqlExpr_ ctx (Value (Maybe a)) -max_ = unsafeSqlFunction "MAX" -avg_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr_ ctx (Value (Maybe b)) -avg_ = unsafeSqlFunction "AVG" + +min_ + :: (PersistField a) + => SqlExpr (Value a) + -> SqlExpr_ ctx (Value (Maybe (Nullable a))) +min_ = unsafeSqlFunction "MIN" + +max_ + :: (PersistField a) + => SqlExpr (Value a) + -> SqlExpr_ ctx (Value (Maybe (Nullable a))) +max_ = unsafeSqlFunction "MAX" + +avg_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr_ ctx (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, @@ -868,8 +979,11 @@ castNumM = veryUnsafeCoerceSqlExprValue -- documentation. -- -- @since 1.4.3 -coalesce :: PersistField a => [SqlExpr_ ctx (Value (Maybe a))] -> SqlExpr_ ctx (Value (Maybe a)) -coalesce = unsafeSqlFunctionParens "COALESCE" +coalesce + :: (PersistField a, NullableFieldProjection a a') + => [SqlExpr_ ctx (Value (Maybe a))] + -> SqlExpr_ ctx (Value (Maybe a')) +coalesce = unsafeSqlFunctionParens "COALESCE" -- | Like @coalesce@, but takes a non-nullable SqlExpression -- placed at the end of the SqlExpression list, which guarantees @@ -927,7 +1041,8 @@ like = unsafeSqlBinOp " LIKE " -- | @ILIKE@ operator (case-insensitive @LIKE@). -- --- Supported by PostgreSQL only. +-- 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 @@ -936,6 +1051,8 @@ ilike :: SqlString s -> SqlExpr_ ctx (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, @@ -948,13 +1065,19 @@ ilike = unsafeSqlBinOp " ILIKE " (%) = unsafeSqlValue "'%'" -- | The @CONCAT@ function with a variable number of --- parameters. Supported by MySQL and PostgreSQL. +-- 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_ ctx (Value s)] -> SqlExpr_ ctx (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 . (++.) :: SqlString s => SqlExpr_ ctx (Value s) -> SqlExpr_ ctx (Value s) @@ -1104,13 +1227,13 @@ field /=. expr = setAux field (\ent -> ent ^. field /. expr) -- 'from' $ \\p -> do -- 'where_' (p '^.' PersonName '==.' 'val' \"Mike\")) -- 'then_' --- ('sub_select' $ +-- ('subSelect' $ -- 'from' $ \\v -> do -- let sub = -- 'from' $ \\c -> do -- 'where_' (c '^.' PersonName '==.' 'val' \"Mike\") -- return (c '^.' PersonFavNum) --- 'where_' (v '^.' PersonFavNum >. 'sub_select' sub) +-- 'where_' ('just' (v '^.' PersonFavNum) >. 'subSelect' sub) -- return $ 'count' (v '^.' PersonName) +. 'val' (1 :: Int)) ] -- ('else_' $ 'val' (-1)) -- @ @@ -1176,12 +1299,67 @@ case_ = unsafeSqlCase 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_'" #-} +-- | 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 -{-# 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." #-} +-- | 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 9 ^., ?. infixl 7 *., /. infixl 6 +., -. infixr 5 ++. @@ -1210,11 +1388,8 @@ 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) +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) @@ -1493,9 +1668,15 @@ data Insertion a -- 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) + 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 @@ -1525,6 +1706,32 @@ data LockingKind -- -- @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 @@ -1539,7 +1746,9 @@ data PostgresLockingKind = -- Arranged in order of lock strength data PostgresRowLevelLockStrength = PostgresForUpdate + | PostgresForNoKeyUpdate | PostgresForShare + | PostgresForKeyShare deriving (Ord, Eq) data LockingOfClause where @@ -1939,8 +2148,10 @@ data CommonTableExpressionKind | NormalCommonTableExpression deriving Eq -data CommonTableExpressionClause = - CommonTableExpressionClause CommonTableExpressionKind Ident (IdentInfo -> (TLB.Builder, [PersistValue])) +type CommonTableExpressionModifierAfterAs = CommonTableExpressionClause -> IdentInfo -> TLB.Builder + +data CommonTableExpressionClause + = CommonTableExpressionClause CommonTableExpressionKind CommonTableExpressionModifierAfterAs Ident (IdentInfo -> (TLB.Builder, [PersistValue])) data SubQueryType = NormalSubQuery @@ -2316,6 +2527,49 @@ type SqlExpr a = SqlExpr_ ValueContext a -- | Helper type denoting a value that should only be treated as an aggregate type SqlAgg a = SqlExpr_ AggregateContext a +-- | 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 :: forall a b ctx0 ctx1. SqlExpr_ ctx0 a -> SqlExpr_ ctx1 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 @@ -2431,11 +2685,43 @@ instance -- -- @since 3.5.4.0 instance - (PersistEntity rec, PersistField typ, SymbolToField sym rec typ) + (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))) + HasField sym (SqlExpr (Maybe (Entity rec))) (SqlExpr (Value (Maybe typ'))) where - getField expr = expr ?. symbolToField @sym + 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 @@ -2786,19 +3072,20 @@ instance ( UnsafeSqlFunctionArgument a -- | (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 :: forall a b ctx. SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (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 :: forall a ctx. SqlExpr_ ctx (ValueList a) -> SqlExpr_ ctx (Value a) veryUnsafeCoerceSqlExprValueList = veryUnsafeCoerceSqlExpr --- | (Internal) Coerce a 'SqlExpr_' into any other kind of 'SqlExlr_'. You --- should /not/ use this function unless you know what you're doing! -veryUnsafeCoerceSqlExpr :: forall a b ctx ctx2. SqlExpr_ ctx a -> SqlExpr_ ctx2 b -veryUnsafeCoerceSqlExpr (ERaw m k) = ERaw m k - ---------------------------------------------------------------------- -- | (Internal) Execute an @esqueleto@ @SELECT@ 'SqlQuery' inside @@ -3177,14 +3464,15 @@ makeCte info cteClauses = | hasRecursive = "WITH RECURSIVE " | otherwise = "WITH " where + hasRecursive = elem RecursiveCommonTableExpression - $ fmap (\(CommonTableExpressionClause cteKind _ _) -> cteKind) + $ fmap (\(CommonTableExpressionClause cteKind _ _ _) -> cteKind) $ cteClauses - cteClauseToText (CommonTableExpressionClause _ cteIdent cteFn) = + cteClauseToText clause@(CommonTableExpressionClause _ cteModifier cteIdent cteFn) = first - (\tlb -> useIdent info cteIdent <> " AS " <> parens tlb) + (\tlb -> useIdent info cteIdent <> " AS " <> cteModifier clause info <> parens tlb) (cteFn info) cteBody = @@ -3341,7 +3629,9 @@ makeLocking info (PostgresLockingClauses clauses) = <> 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" @@ -3469,6 +3759,7 @@ instance PersistEntity a => SqlSelectCols (SqlExpr_ ctx (Entity a)) where in (process, mempty) sqlSelectColCount = entityColumnCount . entityDef . getEntityVal + instance PersistEntity a => SqlSelect (SqlExpr_ ctx (Entity a)) (Entity a) where sqlSelectProcessRow _ = parseEntityValues ed where @@ -3483,6 +3774,7 @@ instance PersistEntity a => SqlSelectCols (SqlExpr_ ctx (Maybe (Entity a))) wher where fromEMaybe :: Proxy (SqlExpr_ ctx (Maybe e)) -> Proxy (SqlExpr_ ctx e) fromEMaybe = const Proxy + -- | You may return a possibly-@NULL@ 'Entity' from a 'select' query. instance PersistEntity a => SqlSelect (SqlExpr_ ctx (Maybe (Entity a))) (Maybe (Entity a)) where sqlSelectProcessRow _ cols @@ -3858,6 +4150,15 @@ instance ( SqlSelectCols a ] sqlSelectColCount = sqlSelectColCount . from11P +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 @@ -3872,15 +4173,6 @@ instance ( SqlSelect a ra ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk) where sqlSelectProcessRow p = fmap to11 . sqlSelectProcessRow (from11P p) -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 ( SqlSelectCols a , SqlSelectCols b , SqlSelectCols c @@ -3911,6 +4203,15 @@ instance ( SqlSelectCols a ] sqlSelectColCount = sqlSelectColCount . from12P +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 @@ -3926,15 +4227,6 @@ instance ( SqlSelect a ra ) => 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 sqlSelectProcessRow p = fmap to12 . sqlSelectProcessRow (from12P p) -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 ( SqlSelectCols a , SqlSelectCols b , SqlSelectCols c @@ -3967,6 +4259,15 @@ instance ( SqlSelectCols a ] sqlSelectColCount = sqlSelectColCount . from13P +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 @@ -3983,15 +4284,6 @@ instance ( SqlSelect a ra ) => 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 sqlSelectProcessRow p = fmap to13 . sqlSelectProcessRow (from13P p) -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) - -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) - instance ( SqlSelectCols a , SqlSelectCols b , SqlSelectCols c @@ -4026,6 +4318,15 @@ instance ( SqlSelectCols a ] sqlSelectColCount = sqlSelectColCount . from14P +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 @@ -4043,15 +4344,6 @@ instance ( SqlSelect a ra ) => 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 sqlSelectProcessRow p = fmap to14 . sqlSelectProcessRow (from14P p) -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 ( SqlSelectCols a , SqlSelectCols b , SqlSelectCols c @@ -4088,6 +4380,12 @@ instance ( SqlSelectCols a ] sqlSelectColCount = sqlSelectColCount . from15P +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) + instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc @@ -4106,12 +4404,6 @@ instance ( SqlSelect a ra ) => 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 sqlSelectProcessRow p = fmap to15 . sqlSelectProcessRow (from15P p) -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) @@ -4374,3 +4666,7 @@ associateJoin = foldr f start (\(oneOld, manyOld) (_, manyNew) -> (oneOld, manyNew ++ manyOld )) (entityKey one) (entityVal one, [many]) + +type family Nullable a where + Nullable (Maybe a) = a + Nullable a = a diff --git a/src/Database/Esqueleto/Legacy.hs b/src/Database/Esqueleto/Legacy.hs index df1f27a2c..e6c7579a2 100644 --- a/src/Database/Esqueleto/Legacy.hs +++ b/src/Database/Esqueleto/Legacy.hs @@ -52,14 +52,14 @@ module Database.Esqueleto.Legacy {-# WARNING "This module will be removed in the -- $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_ @@ -67,7 +67,7 @@ module Database.Esqueleto.Legacy {-# WARNING "This module will be removed in the , subList_select, valList, justList , in_, notIn, exists, notExists , set, (=.), (+=.), (-=.), (*=.), (/=.) - , case_, toBaseId + , case_, toBaseId, fromBaseId, fromBaseIdMaybe, toBaseIdMaybe , subSelect , subSelectMaybe , subSelectCount @@ -84,6 +84,8 @@ module Database.Esqueleto.Legacy {-# WARNING "This module will be removed in the , OrderBy , DistinctOn , LockingKind(..) + , forUpdate + , forUpdateSkipLocked , LockableEntity(..) , SqlString -- ** Joins diff --git a/src/Database/Esqueleto/MySQL.hs b/src/Database/Esqueleto/MySQL.hs index e9384a20e..44553fec9 100644 --- a/src/Database/Esqueleto/MySQL.hs +++ b/src/Database/Esqueleto/MySQL.hs @@ -5,6 +5,7 @@ -- @since 2.2.8 module Database.Esqueleto.MySQL ( random_ + , lockInShareMode ) where import Database.Esqueleto.Internal.Internal hiding (random_) @@ -13,6 +14,18 @@ import Database.Esqueleto.Internal.PersistentImport -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. -- --- /Since: 2.6.0/ -random_ :: (PersistField a, Num a) => SqlExpr_ ValueContext (Value a) +-- @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 diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 6fc9ac558..22b536f31 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -9,7 +9,7 @@ -- | This module contain PostgreSQL-specific functions. -- --- @since: 2.2.8 +-- @since 2.2.8 module Database.Esqueleto.PostgreSQL ( AggMode(..) , arrayAggDistinct @@ -24,41 +24,64 @@ module Database.Esqueleto.PostgreSQL , 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 , unsafeSqlExprAggregateFunction ) where -#if __GLASGOW_HASKELL__ < 804 -import Data.Semigroup -#endif 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 Database.Esqueleto.Internal.Internal hiding (random_) +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()`. @@ -67,6 +90,69 @@ import Database.Persist.SqlBackend 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 "'{}'" @@ -184,6 +270,15 @@ chr = unsafeSqlFunction "chr" now_ :: SqlExpr_ ctx (Value UTCTime) now_ = unsafeSqlFunction "NOW" () +-- | 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 @@ -194,17 +289,57 @@ upsert ) => record -- ^ new record to insert - -> [SqlExpr_ ValueContext (Entity record) -> SqlExpr_ ValueContext Update] + -> NE.NonEmpty (SqlExpr_ ValueContext (Entity record) -> SqlExpr_ ValueContext 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 +-- | 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_ ValueContext (Entity record) -> SqlExpr_ ValueContext 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 + ( MonadIO m , PersistEntity record , IsPersistBackend (PersistEntityBackend record) ) @@ -214,9 +349,9 @@ upsertBy -- ^ new record to insert -> [SqlExpr_ ValueContext (Entity record) -> SqlExpr_ ValueContext Update] -- ^ updates to perform if the record already exists - -> R.ReaderT SqlBackend m (Entity record) + -> R.ReaderT SqlBackend m (Maybe (Entity record)) -- ^ the record in the database after the operation -upsertBy uniqueKey record updates = do +upsertMaybeBy uniqueKey record updates = do sqlB <- R.ask case getConnUpsertSql sqlB of Nothing -> @@ -226,25 +361,62 @@ upsertBy uniqueKey record updates = do Just upsertSql -> handler sqlB upsertSql where - addVals l = map toPersistValue (toPersistFields record) ++ l ++ persistUniqueToValues uniqueKey - entDef = entityDef (Just record) - updatesText conn = first builderToText $ renderUpdates conn updates -#if MIN_VERSION_persistent(2,11,0) + 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 - queryText = + 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 (head xs) -#else - uDef = toUniqueDef uniqueKey - handler conn f = fmap head $ uncurry rawSql $ - (***) (f entDef (uDef :| [])) addVals $ updatesText conn -#endif + 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. @@ -252,10 +424,7 @@ upsertBy uniqueKey record updates = do -- Example of usage: -- -- @ --- share [ mkPersist sqlSettings --- , mkDeleteCascade sqlSettings --- , mkMigrate "migrate" --- ] [persistLowerCase| +-- 'mkPersist' 'sqlSettings' ['persistLowerCase'| -- Bar -- num Int -- deriving Eq Show @@ -265,17 +434,19 @@ upsertBy uniqueKey record updates = do -- 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 @@ -484,11 +655,147 @@ 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 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 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" diff --git a/src/Database/Esqueleto/Record.hs b/src/Database/Esqueleto/Record.hs index 62f95e89f..377905eef 100644 --- a/src/Database/Esqueleto/Record.hs +++ b/src/Database/Esqueleto/Record.hs @@ -23,7 +23,7 @@ module Database.Esqueleto.Record import Control.Monad.Trans.State.Strict (StateT(..), evalStateT) import Data.Proxy (Proxy(..)) -import Database.Esqueleto.Experimental +import Database.Esqueleto (Entity, PersistValue, SqlExpr, Value(..), (:&)(..)) import Database.Esqueleto.Internal.Internal (SqlSelectCols(..), SqlSelect(..)) import Database.Esqueleto.Experimental.ToAlias (ToAlias(..)) @@ -36,8 +36,7 @@ import Data.Text (Text) import Control.Monad (forM) import Data.Foldable (foldl') import GHC.Exts (IsString(fromString)) -import Data.Maybe (mapMaybe, fromMaybe, listToMaybe) -import Debug.Trace +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 @@ -190,17 +189,23 @@ deriveEsqueletoRecordWith settings originalName = do 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 $ concat - [ [recordDec] + [ recordDec , sqlSelectInstanceDec - , pure sqlMaybeRecordDec - , pure toMaybeInstanceDec + , sqlMaybeRecordDec + , toMaybeInstanceDec + , sqlMaybeToMaybeInstanceDec , sqlMaybeRecordSelectInstanceDec - , pure toAliasInstanceDec - , pure toAliasReferenceInstanceDec + , toAliasInstanceDec + , sqlMaybeToAliasInstanceDec + , toAliasReferenceInstanceDec + , sqlMaybeToAliasReferenceInstanceDec ] -- | Information about a record we need to generate the declarations. @@ -284,7 +289,6 @@ getRecordInfo settings name = do toSqlMaybeField (fieldName', ty) = do let modifier = mkName . sqlMaybeFieldModifier settings . nameBase sqlTy <- sqlMaybeFieldType ty - let result = (modifier fieldName', sqlTy) pure (modifier fieldName', sqlTy) -- | Create a new name by prefixing @Sql@ to a given name. @@ -359,11 +363,11 @@ sqlMaybeFieldType fieldType = do -- | Generates the declaration for an @Sql@-prefixed record, given the original -- record's information. -makeSqlRecord :: RecordInfo -> Q Dec +makeSqlRecord :: RecordInfo -> Q [Dec] makeSqlRecord RecordInfo {..} = do let newConstructor = RecC sqlConstructorName (makeField `map` sqlFields) derivingClauses = [] - pure $ DataD constraints sqlName typeVarBinders kind [newConstructor] derivingClauses + pure $ pure $ DataD constraints sqlName typeVarBinders kind [newConstructor] derivingClauses where makeField (fieldName', fieldType) = (fieldName', Bang NoSourceUnpackedness NoSourceStrictness, fieldType) @@ -372,24 +376,27 @@ makeSqlRecord RecordInfo {..} = do -- @Sql@-prefixed variant. makeSqlSelectInstance :: RecordInfo -> Q [Dec] makeSqlSelectInstance info@RecordInfo {..} = do - sqlSelectColsDec' <- sqlSelectColsDec info - sqlSelectColCountDec' <- sqlSelectColCountDec info - sqlSelectProcessRowDec' <- sqlSelectProcessRowDec info - let overlap = Nothing - instanceConstraints = [] - sqlSelectColsType = - AppT (ConT ''SqlSelectCols) (ConT sqlName) - instanceType = - (ConT ''SqlSelect) - `AppT` (ConT sqlName) - `AppT` (ConT name) - - pure [ InstanceD overlap instanceConstraints sqlSelectColsType [ sqlSelectColsDec', sqlSelectColCountDec'] - , InstanceD overlap instanceConstraints instanceType [ sqlSelectProcessRowDec'] - ] + sqlSelectColsDec' <- sqlSelectColsDec info + sqlSelectColCountDec' <- sqlSelectColCountDec info + sqlSelectProcessRowDec' <- sqlSelectProcessRowDec info + let overlap = Nothing + instanceConstraints = [] + sqlSelectColsType = + AppT (ConT ''SqlSelectCols) (ConT sqlName) + sqlSelectType = + (ConT ''SqlSelect) + `AppT` (ConT sqlName) + `AppT` (ConT name) + + pure + [ InstanceD overlap instanceConstraints sqlSelectColsType + (concat [ sqlSelectColsDec', sqlSelectColCountDec']) + , InstanceD overlap instanceConstraints sqlSelectType + [ sqlSelectProcessRowDec'] + ] -- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance. -sqlSelectColsDec :: RecordInfo -> Q Dec +sqlSelectColsDec :: RecordInfo -> Q [Dec] sqlSelectColsDec RecordInfo {..} = do -- Pairs of record field names and local variable names. fieldNames <- forM sqlFields $ \(name', typ) -> do @@ -415,26 +422,12 @@ sqlSelectColsDec RecordInfo {..} = do in foldl' helper (VarE f1) rest identInfo <- newName "identInfo" - -- Roughly: - -- sqlSelectCols $identInfo SqlFoo{..} = sqlSelectCols $identInfo $joinedFields - pure $ - FunD - 'sqlSelectCols - [ Clause - [ VarP identInfo - , RecP sqlName fieldPatterns - ] - ( NormalB $ - (VarE 'sqlSelectCols) - `AppE` (VarE identInfo) - `AppE` (ParensE joinedFields) - ) - -- `where` clause. - [] - ] + [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 -> Q [Dec] sqlSelectColCountDec RecordInfo {..} = do let joinedTypes = case snd `map` sqlFields of @@ -444,81 +437,68 @@ sqlSelectColCountDec RecordInfo {..} = do InfixT lhs ''(:&) ty in foldl' helper t1 rest - -- Roughly: - -- sqlSelectColCount _ = sqlSelectColCount (Proxy @($joinedTypes)) - pure $ - FunD - 'sqlSelectColCount - [ Clause - [WildP] - ( NormalB $ - AppE (VarE 'sqlSelectColCount) $ - ParensE $ - AppTypeE - (ConE 'Proxy) - joinedTypes - ) - -- `where` clause. - [] - ] + [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) - )) + -- 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" + 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)) - |] + -- Roughly: + -- sqlSelectProcessRow $proxy $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)) + |] + processType <- + [t| StateT [PersistValue] (Either Text) $(conT name) |] - pure $ - FunD - 'sqlSelectProcessRow - [ Clause - [WildP, VarP colsName] - (NormalB bodyExp) - -- `where` clause - [ ValD - (VarP processName) - ( NormalB $ - DoE + pure $ + FunD + 'sqlSelectProcessRow + [ Clause + [WildP, VarP colsName] + (NormalB bodyExp) + -- `where` clause + [ SigD processName processType + , ValD + (VarP processName) + ( NormalB $ + DoE #if MIN_VERSION_template_haskell(2,17,0) - Nothing + Nothing #endif - (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE constructorName fieldExps)]) - ) - [] - ] - ] + (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`. @@ -543,11 +523,7 @@ sqlSelectProcessRowPat fieldType var = do `AppT` ((ConT ((==) ''Entity -> True)) `AppT` _innerType) -> pure $ VarP var -- x -> Value var -#if MIN_VERSION_template_haskell(2,18,0) - _ -> pure $ ConP 'Value [] [VarP var] -#else - _ -> pure $ ConP 'Value [VarP var] -#endif + _ -> [p| Value $(varP var) |] -- Given a type, find the corresponding SQL type. -- @@ -653,20 +629,24 @@ nonRecordConstructorMessage con = (GadtC names _fields _ret) -> head names (RecGadtC names _fields _ret) -> head names -makeToAliasInstance :: RecordInfo -> Q Dec -makeToAliasInstance info@RecordInfo {..} = do - toAliasDec' <- toAliasDec info +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 sqlName) - pure $ InstanceD overlap instanceConstraints instanceType [toAliasDec'] + instanceType = (ConT ''ToAlias) `AppT` (ConT name) + pure $ pure $ InstanceD overlap instanceConstraints instanceType [toAliasDec'] -toAliasDec :: RecordInfo -> Q Dec -toAliasDec RecordInfo {..} = do +toAliasDec :: Name -> [(Name, Type)] -> Q Dec +toAliasDec name fields = do (statements, fieldPatterns, fieldExps) <- - unzip3 <$> forM sqlFields (\(fieldName', _) -> do + unzip3 <$> forM fields (\(fieldName', _) -> do fieldPatternName <- newName (nameBase fieldName') boundValueName <- newName (nameBase fieldName') pure @@ -681,36 +661,40 @@ toAliasDec RecordInfo {..} = do FunD 'toAlias [ Clause - [ RecP sqlName fieldPatterns + [ RecP name fieldPatterns ] ( NormalB $ DoE #if MIN_VERSION_template_haskell(2,17,0) Nothing #endif - (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE sqlName fieldExps)]) + (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE name fieldExps)]) ) -- `where` clause. [] ] -makeToAliasReferenceInstance :: RecordInfo -> Q Dec -makeToAliasReferenceInstance info@RecordInfo {..} = do - toAliasReferenceDec' <- toAliasReferenceDec info +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 sqlName - `AppT` ConT sqlName - pure $ InstanceD overlap instanceConstraints instanceType [toAliasReferenceDec'] - -toAliasReferenceDec :: RecordInfo -> Q Dec -toAliasReferenceDec RecordInfo {..} = do + instanceType = (ConT ''ToAliasReference) `AppT` (ConT name) `AppT` (ConT name) + pure $ pure $ InstanceD overlap instanceConstraints instanceType [toAliasReferenceDec'] + +toAliasReferenceDec :: Name -> [(Name, Type)] -> Q Dec +toAliasReferenceDec name fields = do identInfo <- newName "identInfo" (statements, fieldPatterns, fieldExps) <- - unzip3 <$> forM sqlFields (\(fieldName', _) -> do + unzip3 <$> forM fields (\(fieldName', _) -> do fieldPatternName <- newName (nameBase fieldName') boundValueName <- newName (nameBase fieldName') pure @@ -726,14 +710,14 @@ toAliasReferenceDec RecordInfo {..} = do 'toAliasReference [ Clause [ VarP identInfo - , RecP sqlName fieldPatterns + , RecP name fieldPatterns ] ( NormalB $ DoE #if MIN_VERSION_template_haskell(2,17,0) Nothing #endif - (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE sqlName fieldExps)]) + (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE name fieldExps)]) ) -- `where` clause. [] @@ -741,44 +725,44 @@ toAliasReferenceDec RecordInfo {..} = do -- | Generates the declaration for an @SqlMaybe@-prefixed record, given the original -- record's information. -makeSqlMaybeRecord :: RecordInfo -> Q Dec +makeSqlMaybeRecord :: RecordInfo -> Q [Dec] makeSqlMaybeRecord RecordInfo {..} = do let newConstructor = RecC sqlMaybeConstructorName (makeField `map` sqlMaybeFields) derivingClauses = [] - pure $ DataD constraints sqlMaybeName typeVarBinders kind [newConstructor] derivingClauses + pure $ 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 :: RecordInfo -> Q [Dec] makeToMaybeInstance info@RecordInfo {..} = do - toMaybeTDec' <- toMaybeTDec info + toMaybeTDec' <- toMaybeTDec sqlName sqlMaybeName toMaybeDec' <- toMaybeDec info let overlap = Nothing instanceConstraints = [] instanceType = (ConT ''ToMaybe) `AppT` (ConT sqlName) - pure $ InstanceD overlap instanceConstraints instanceType [toMaybeTDec', toMaybeDec'] + pure $ pure $ InstanceD overlap instanceConstraints instanceType (toMaybeTDec' ++ toMaybeDec') --- | Generates a `type ToMaybeT ... = ...` declaration for the given record. -toMaybeTDec :: RecordInfo -> Q Dec -toMaybeTDec RecordInfo {..} = do - pure $ mkTySynInstD ''ToMaybeT (ConT sqlName) (ConT sqlMaybeName) - where - mkTySynInstD className lhsArg rhs = -#if MIN_VERSION_template_haskell(2,15,0) - let binders = Nothing - lhs = ConT className `AppT` lhsArg - in - TySynInstD $ TySynEqn binders lhs rhs -#else - TySynInstD className $ TySynEqn [lhsArg] rhs -#endif +-- | 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 $ 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 -> Q [Dec] toMaybeDec RecordInfo {..} = do (fieldPatterns, fieldExps) <- unzip <$> forM (zip sqlFields sqlMaybeFields) (\((fieldName', _), (maybeFieldName', _)) -> do @@ -788,41 +772,36 @@ toMaybeDec RecordInfo {..} = do , (maybeFieldName', VarE 'toMaybe `AppE` VarE fieldPatternName) )) - pure $ - FunD - 'toMaybe - [ Clause - [ RecP sqlName fieldPatterns - ] - (NormalB $ RecConE sqlMaybeName fieldExps) - [] - ] + [d| $(varP 'toMaybe) = \ $(pure $ RecP sqlName fieldPatterns) -> + $(pure $ RecConE sqlMaybeName fieldExps) + |] --- | Generates an `SqlSelect` and 'SqlSelectCols' instance for the given record and its +-- | 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 = - (ConT ''SqlSelect) - `AppT` (ConT sqlMaybeName) - `AppT` (AppT (ConT ''Maybe) (ConT name)) - - pure - [ InstanceD overlap instanceConstraints instanceType [sqlSelectProcessRowDec'] - , InstanceD overlap instanceConstraints (ConT ''SqlSelectCols `AppT` ConT sqlMaybeName) - [ sqlSelectColsDec' - , sqlSelectColCountDec' - ] + 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 + [ sqlSelectProcessRowDec' + ] + , InstanceD overlap instanceConstraints + (ConT ''SqlSelectCols `AppT` ConT sqlMaybeName) + (concat + [ sqlSelectColsDec' + , sqlSelectColCountDec' + ] + ) - ] + ] -- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance. -sqlMaybeSelectColsDec :: RecordInfo -> Q Dec +sqlMaybeSelectColsDec :: RecordInfo -> Q [Dec] sqlMaybeSelectColsDec RecordInfo {..} = do -- Pairs of record field names and local variable names. fieldNames <- forM sqlMaybeFields (\(name', _type) -> do @@ -848,116 +827,75 @@ sqlMaybeSelectColsDec RecordInfo {..} = do in foldl' helper (VarE f1) rest identInfo <- newName "identInfo" - -- Roughly: - -- sqlSelectCols $identInfo SqlFoo{..} = sqlSelectCols $identInfo $joinedFields - pure $ - FunD - 'sqlSelectCols - [ Clause - [ VarP identInfo - , RecP sqlMaybeName fieldPatterns - ] - ( NormalB $ - (VarE 'sqlSelectCols) - `AppE` (VarE identInfo) - `AppE` (ParensE joinedFields) - ) - -- `where` clause. - [] - ] + [d| $(varP 'sqlSelectCols) = \ $(varP identInfo) $(pure $ RecP sqlMaybeName fieldPatterns) -> + sqlSelectCols $(varE identInfo) $(pure joinedFields) + |] -- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect` --- instance. +-- instance for a SqlMaybe. sqlMaybeSelectProcessRowDec :: RecordInfo -> Q Dec sqlMaybeSelectProcessRowDec RecordInfo {..} = do - let sqlOp x t = - case x of - -- AppT (ConT ((==) ''Entity -> True)) _innerType -> id - -- (ConT ((==) ''Maybe -> True)) `AppT` ((ConT ((==) ''Entity -> True)) `AppT` _innerType) -> (AppE (VarE 'pure)) - -- inner@((ConT ((==) ''Maybe -> True)) `AppT` _inner) -> (AppE (VarE 'unValue)) - (AppT (ConT ((==) ''SqlExpr -> True)) (AppT (ConT ((==) ''Value -> True)) inner)) - | AppT (ConT m) _ <- inner -> - case () of - () - | ''Maybe == m -> do - [e| (pure . unValue) $(pure t) |] - | otherwise -> do - pure (AppE (VarE 'unValue) t) - | otherwise -> - pure (AppE (VarE 'unValue) t) - (AppT (ConT ((==) ''SqlExpr -> True)) (AppT (ConT ((==) ''Entity -> True)) _)) -> - pure t - (AppT (ConT ((==) ''SqlExpr -> True)) (AppT (ConT ((==) ''Maybe -> True)) _)) -> do - pure (AppE (VarE 'pure) t) - (ConT _) -> - pure t - _ -> - fail $ show t + -- 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) + )) - fieldNames <- forM sqlFields $ \(name', typ) -> do - var <- newName $ nameBase name' - newTy <- sqlOp typ (VarE var) - pure (name', var, newTy) + colsName <- newName "columns" + processName <- newName "process" - let joinedFields = - case map (\(_,x,_) -> x) fieldNames of - [] -> TupP [] - [f1] -> VarP f1 - f1 : rest -> - let helper lhs field = - InfixP - lhs - '(:&) - (VarP field) - in foldl' helper (VarP f1) rest - - fieldTypes = map snd sqlMaybeFields - - toMaybeT t = ConT ''ToMaybeT `AppT` t - - tupleType = - case fieldTypes of - [] -> - ConT '() - (x:xs) -> - foldl' (\acc t -> - ConT ''(:&) - `AppT` acc - `AppT` t) x xs - - proxy <- [e| Proxy :: Proxy $(pure tupleType) |] - colsName <- newName "columns" - proxyName <- newName "proxy" + bodyExp <- [e| + first (fromString ("Failed to parse " ++ $(lift $ nameBase sqlMaybeName) ++ ": ") <>) + (evalStateT $(varE processName) $(varE colsName)) + |] - let + pure $ + FunD + 'sqlSelectProcessRow + [ Clause + [WildP, VarP colsName] + (NormalB bodyExp) + -- `where` + [ ValD + (VarP processName) + (NormalB $ + DoE #if MIN_VERSION_template_haskell(2,17,0) - bodyExp = DoE Nothing -#else - bodyExp = DoE + Nothing #endif - [ BindS joinedFields (VarE 'sqlSelectProcessRow `AppE` proxy `AppE` VarE colsName) - , NoBindS - $ AppE (VarE 'pure) ( - case fieldNames of - [] -> ConE constructorName - (_,_,e):xs -> foldl' - (\acc (_,_,e2) -> AppE (AppE (VarE '(<*>)) acc) e2) - (AppE (AppE (VarE 'fmap) (ConE constructorName)) e) - xs - ) - ] - - pure $ - FunD - 'sqlSelectProcessRow - [ Clause - [WildP, VarP colsName] - (NormalB bodyExp) - [] - ] + (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 -> Q [Dec] sqlMaybeSelectColCountDec RecordInfo {..} = do let joinedTypes = case snd `map` sqlMaybeFields of @@ -967,23 +905,7 @@ sqlMaybeSelectColCountDec RecordInfo {..} = do InfixT lhs ''(:&) ty in foldl' helper t1 rest - -- Roughly: - -- sqlSelectColCount _ = sqlSelectColCount (Proxy @($joinedTypes)) - pure $ - FunD - 'sqlSelectColCount - [ Clause - [WildP] - ( NormalB $ - AppE (VarE 'sqlSelectColCount) $ - ParensE $ - AppTypeE - (ConE 'Proxy) - joinedTypes - ) - -- `where` clause. - [] - ] + [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` diff --git a/stack-8.10.yaml b/stack-8.10.yaml index 585337b26..d793586b2 100644 --- a/stack-8.10.yaml +++ b/stack-8.10.yaml @@ -9,3 +9,6 @@ allow-newer: true extra-deps: - lift-type-0.1.0.1 - persistent-2.14.0.2 + +nix: + packages: [zlib, libmysqlclient, pcre, postgresql] diff --git a/stack-8.2.yaml b/stack-8.2.yaml index 3577eef90..c0f7c0af8 100644 --- a/stack-8.2.yaml +++ b/stack-8.2.yaml @@ -23,3 +23,6 @@ extra-deps: - scientific-0.3.6.2 - text-1.2.3.0 - unliftio-0.2.0.0 + +nix: + packages: [zlib, libmysqlclient, pcre, postgresql] diff --git a/stack-8.4.yaml b/stack-8.4.yaml index 23839a735..48f810395 100644 --- a/stack-8.4.yaml +++ b/stack-8.4.yaml @@ -13,3 +13,6 @@ extra-deps: - postgresql-libpq-0.9.4.2 - postgresql-simple-0.6.1 - transformers-0.5.5.2 + +nix: + packages: [zlib, libmysqlclient, pcre, postgresql] diff --git a/stack-8.6.yaml b/stack-8.6.yaml index 938fc3d8f..5f2764468 100644 --- a/stack-8.6.yaml +++ b/stack-8.6.yaml @@ -19,3 +19,6 @@ extra-deps: - lift-type-0.1.0.1 - th-lift-instances-0.1.19 - th-lift-0.8.2 + +nix: + packages: [zlib, libmysqlclient, pcre, postgresql] diff --git a/stack-8.8.yaml b/stack-8.8.yaml index e794cdb91..c38f620c4 100644 --- a/stack-8.8.yaml +++ b/stack-8.8.yaml @@ -10,3 +10,6 @@ extra-deps: - persistent-mysql-2.12.0.0 - persistent-postgresql-2.12.0.0 - persistent-sqlite-2.12.0.0 + +nix: + packages: [zlib, libmysqlclient, pcre, postgresql] diff --git a/stack-9.0.yaml b/stack-9.0.yaml index ba4a9c379..067a3735e 100644 --- a/stack-9.0.yaml +++ b/stack-9.0.yaml @@ -1,4 +1,4 @@ -resolver: lts-19.13 +resolver: lts-23.1 packages: - '.' @@ -8,4 +8,6 @@ allow-newer: true extra-deps: - lift-type-0.1.0.1 -- persistent-2.14.0.2 + +nix: + packages: [zlib, libmysqlclient, pcre, postgresql] diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 7ce4cc13a..6c1a6662b 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -12,3 +12,6 @@ extra-deps: - process-1.6.14.0 - Cabal-3.6.3.0 - unix-2.7.2.2 + +nix: + packages: [zlib, libmysqlclient, pcre, postgresql] diff --git a/test/Common/LegacyTest.hs b/test/Common/LegacyTest.hs index 0b37380bd..f8c606069 100644 --- a/test/Common/LegacyTest.hs +++ b/test/Common/LegacyTest.hs @@ -32,7 +32,6 @@ module Common.LegacyTest ( tests , testLocking , testAscRandom - , testRandomMath , migrateAll , migrateUnique , cleanDB @@ -158,19 +157,8 @@ testSubSelect = do pure (n ^. NumbersInt) setup res <- select $ pure $ subSelect query - eres <- try $ do - select $ pure $ sub_select query asserting $ do res `shouldBe` [Value (Just 1)] - 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] itDb "is safe for queries that may not return anything" $ do let query = @@ -182,21 +170,8 @@ testSubSelect = do res <- select $ pure $ subSelect query transactionUndo - eres <- try $ do - select $ pure $ sub_select query - asserting $ do res `shouldBe` [Value $ Just 1] - case eres of - Left (_ :: PersistException) -> - -- We expect to receive this exception. However, sqlite evidently has - -- no problems with itDb, 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 itDb "is safe on empty databases as well as good databases" $ do @@ -379,7 +354,7 @@ testSelectFrom = do , (p2e, p2e) ] - itDb "works for a self-join via sub_select" $ do + itDb "works for a self-join via subSelect" $ do p1k <- insert p1 p2k <- insert p2 _f1k <- insert (Follow p1k p2k) @@ -390,7 +365,7 @@ testSelectFrom = do from $ \followB -> do where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed return $ followB ^. FollowFollower - where_ $ followA ^. FollowFollowed ==. sub_select subquery + where_ $ just (followA ^. FollowFollowed) ==. subSelect subquery return followA asserting $ length ret `shouldBe` 2 @@ -930,15 +905,15 @@ testSelectOrderBy = describe "select/orderBy" $ do return p asserting $ ret `shouldBe` [ p1e, p3e, p2e ] - itDb "works with a sub_select" $ do + 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 $ sub_select $ + orderBy [desc $ subSelect $ from $ \p -> do - where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) - return (p ^. PersonName) + where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) + return (p ^. PersonName) ] return (b ^. BlogPostId) asserting $ ret `shouldBe` (Value <$> [b2k, b3k, b4k, b1k]) @@ -1040,7 +1015,7 @@ testCoasleceDefault = describe "coalesce/coalesceDefault" $ do from $ \p -> do where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) return $ p ^. PersonAge - return $ coalesceDefault [sub_select sub] (val (42 :: Int)) + return $ coalesceDefault [subSelect sub] (val (42 :: Int)) asserting $ ret `shouldBe` [ Value (36 :: Int) , Value 42 , Value 17 @@ -1083,7 +1058,7 @@ testUpdate = describe "update" $ do where_ (b ^. BlogPostAuthorId ==. p ^. PersonId) return countRows () <- update $ \p -> do - set p [ PersonAge =. just (sub_select (blogPostsBy p)) ] + set p [ PersonAge =. just (subSelect (blogPostsBy p)) ] ret <- select $ from $ \p -> do orderBy [ asc (p ^. PersonName) ] @@ -1352,31 +1327,6 @@ testInsertsBySelectReturnsCount = do asserting $ ret `shouldBe` [Value (3::Int)] asserting $ cnt `shouldBe` 3 - - - -testRandomMath :: SpecDb -testRandomMath = describe "random_ math" $ - itDb "rand returns result in random order" $ - 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) - - asserting $ (ret1 == ret2) `shouldBe` False - testMathFunctions :: SpecDb testMathFunctions = do describe "Math-related functions" $ do @@ -1434,16 +1384,16 @@ testCase = do (exists $ from $ \p -> do where_ (p ^. PersonName ==. val "Mike")) then_ - (sub_select $ from $ \v -> do + (subSelect $ from $ \v -> do let sub = from $ \c -> do where_ (c ^. PersonName ==. val "Mike") return (c ^. PersonFavNum) - where_ (v ^. PersonFavNum >. sub_select sub) + where_ (just (v ^. PersonFavNum) >. subSelect sub) return $ count (v ^. PersonName) +. val (1 :: Int)) ] - (else_ $ val (-1)) + (else_ $ just $ val (-1)) - asserting $ ret `shouldBe` [ Value (3) ] + asserting $ ret `shouldBe` [ Value (Just 3) ] testLocking :: SpecDb testLocking = do diff --git a/test/Common/Record.hs b/test/Common/Record.hs index 398b59023..0444d8120 100644 --- a/test/Common/Record.hs +++ b/test/Common/Record.hs @@ -20,11 +20,9 @@ {-# OPTIONS_GHC -ddump-splices #-} -- Tests for `Database.Esqueleto.Record`. -module Common.Record (testDeriveEsqueletoRecord) where +module Common.Record where import Common.Test.Import hiding (from, on) -import Control.Monad.Trans.State.Strict (StateT(..), evalStateT) -import Data.Bifunctor (first) import Data.List (sortOn) import Database.Esqueleto import Database.Esqueleto.Record @@ -33,18 +31,6 @@ import Database.Esqueleto.Record , deriveEsqueletoRecord , deriveEsqueletoRecordWith ) -import Data.Maybe (catMaybes) -import Data.Proxy (Proxy(..)) -import Database.Esqueleto.Experimental -import Database.Esqueleto.Internal.Internal (SqlSelect(..)) -import Database.Esqueleto.Record ( - DeriveEsqueletoRecordSettings(..), - defaultDeriveEsqueletoRecordSettings, - deriveEsqueletoRecord, - deriveEsqueletoRecordWith, - takeColumns, - takeMaybeColumns, - ) import GHC.Records data MySimpleRecord = MySimpleRecord { mySimpleAge :: Maybe Int } @@ -80,10 +66,16 @@ myRecordQuery = do 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 @@ -102,6 +94,32 @@ myNestedRecordQuery = do , 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 = @@ -211,6 +229,107 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do } -> 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 @@ -284,9 +403,9 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) } )) -> True - _ -> True) + _ -> False) - itDb "can can handle joins on records with Nothing" $ do + itDb "can handle joins on records with Nothing" $ do setup records <- select $ do from @@ -301,10 +420,10 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do liftIO $ sortedRecords !! 1 `shouldSatisfy` (\case ( _ :& Just ( MyRecord { myName = "Some Guy" - , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) + , myAddress = (Just (Entity _addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) } )) -> True - _ -> True) + _ -> False) itDb "can left join on nested records" $ do setup @@ -322,10 +441,10 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do liftIO $ sortedRecords !! 1 `shouldSatisfy` (\case ( _ :& Just ( MyNestedRecord { myRecord = MyRecord { myName = "Some Guy" - , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) + , myAddress = (Just (Entity _addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) } })) -> True - _ -> True) + _ -> False) itDb "can handle multiple left joins on the same record" $ do setup @@ -335,16 +454,16 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do `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) + `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"})) + , myAddress = (Just (Entity _addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) } })) -> True - _ -> True) + _ -> False) liftIO $ sortedRecords !! 1 `shouldSatisfy` (\case (_ :& _ :& Just (MyNestedRecord {myRecord = MyRecord {myName = "Rebecca", myAddress = Nothing}})) -> True diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 7c6ffc8f5..42cc83ced 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} @@ -32,7 +33,6 @@ module Common.Test ( tests , testLocking , testAscRandom - , testRandomMath , migrateAll , migrateUnique , cleanDB @@ -65,6 +65,7 @@ module Common.Test , DateTruncTest(..) , DateTruncTestId , Key(..) + , assertJust ) where import Common.Test.Import hiding (from, on) @@ -88,6 +89,7 @@ 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 @@ -156,19 +158,8 @@ testSubSelect = do pure (n ^. NumbersInt) setup res <- select $ pure $ subSelect query - eres <- try $ do - select $ pure $ sub_select query asserting $ do res `shouldBe` [Value (Just 1)] - 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] itDb "is safe for queries that may not return anything" $ do let query = do @@ -180,21 +171,8 @@ testSubSelect = do res <- select $ pure $ subSelect query transactionUndo - eres <- try $ do - select $ pure $ sub_select query - asserting $ do res `shouldBe` [Value $ Just 1] - case eres of - Left (_ :: PersistException) -> - -- We expect to receive this exception. However, sqlite evidently has - -- no problems with itDb, 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 itDb "is safe on empty databases as well as good databases" $ do @@ -369,7 +347,7 @@ testSelectFrom = do asserting $ ret `shouldBe` [ p1e ] - itDb "works for a self-join via sub_select" $ do + itDb "works for a self-join via subSelect" $ do p1k <- insert p1 p2k <- insert p2 _f1k <- insert (Follow p1k p2k) @@ -380,7 +358,7 @@ testSelectFrom = do followB <- from $ table @Follow where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed return $ followB ^. FollowFollower - where_ $ followA ^. FollowFollowed ==. sub_select subquery + where_ $ just (followA ^. FollowFollowed) ==. subSelect subquery return followA asserting $ length ret `shouldBe` 2 @@ -694,14 +672,6 @@ testSelectSubQuery = describe "select subquery" $ do ret <- select $ from q asserting $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ] - itDb "works with SubQuery wrapper" $ do - _ <- insert' p1 - let q = do - p <- from $ table @Person - return ( p ^. PersonName, p ^. PersonAge) - ret <- select $ from $ SubQuery q - asserting $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ] - itDb "supports sub-selecting Maybe entities" $ do l1e <- insert' l1 l3e <- insert' l3 @@ -877,16 +847,6 @@ testSelectWhere = describe "select where_" $ do return p asserting $ ret `shouldBe` [ p1e ] - itDb "works for a simple example with (>.) and not_ [uses just . val]" $ do - _ <- insert' p1 - _ <- insert' p2 - p3e <- insert' p3 - ret <- select $ do - p <- from $ table @Person - where_ (not_ $ p ^. PersonAge >. just (val 17)) - return p - asserting $ ret `shouldBe` [ p3e ] - describe "when using between" $ do itDb "works for a simple example with [uses just . val]" $ do p1e <- insert' p1 @@ -919,6 +879,51 @@ testSelectWhere = describe "select where_" $ do , 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 $ do + p <- from $ table @Person + 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 $ do + p <- from $ table @Person + where_ (not_ $ p ^. PersonName ==. val "John" ||. p ^. PersonName ==. val "Rachel") + pure p + asserting $ ret `shouldBe` [ p3e ] + itDb "works with (>.), (<.) and (&&.) [uses just . val]" $ do + p1e <- insert' p1 + _ <- insert' p2 + _ <- insert' p3 + ret <- select $ do + p <- from $ table @Person + where_ (not_ $ (p ^. PersonAge >. just (val 10)) &&. (p ^. PersonAge <. just (val 30))) + pure p + asserting $ ret `shouldBe` [ p1e ] + itDb "works with between [uses just . val]" $ do + _ <- insert' p1 + _ <- insert' p2 + p3e <- insert' p3 + ret <- select $ do + p <- from $ table @Person + where_ (not_ $ (p ^. PersonAge) `between` (just $ val 20, just $ val 40)) + pure p + asserting $ ret `shouldBe` [ p3e ] + itDb "works with avg_" $ do _ <- insert' p1 _ <- insert' p2 @@ -1091,12 +1096,12 @@ testSelectOrderBy = describe "select/orderBy" $ do return p asserting $ ret `shouldBe` [ p1e, p3e, p2e ] - itDb "works with a sub_select" $ do + 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 $ do b <- from $ table @BlogPost - orderBy [desc $ sub_select $ do + orderBy [desc $ subSelect $ do p <- from $ table @Person where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) return (p ^. PersonName) @@ -1534,33 +1539,6 @@ testInsertsBySelectReturnsCount = do asserting $ ret `shouldBe` [Value (3::Int)] asserting $ cnt `shouldBe` 3 - - - -testRandomMath :: SpecDb -testRandomMath = describe "random_ math" $ - itDb "rand returns result in random order" $ - 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 $ do - p <- from $ table @Person - orderBy [rand] - return (p ^. PersonId) - ret2 <- fmap (map unValue) $ select $ do - p <- from $ table @Person - orderBy [rand] - return (p ^. PersonId) - - asserting $ (ret1 == ret2) `shouldBe` False - testMathFunctions :: SpecDb testMathFunctions = do describe "Math-related functions" $ do @@ -1784,7 +1762,117 @@ testRenderSql = do expr <- ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1)) asserting $ expr `shouldBe` "? = ?" +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 <- 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) <- + from $ Table @Lord + `innerJoin` Table @Deed + `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) <- + from $ Table @Lord + `leftJoin` Table @Deed + `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 $ from $ table @Lord + lords <- select $ from $ table @Lord + asserting $ lords `shouldMatchList` [] + + itDb "supports implicit cross joins" $ do + l1e <- insert' l1 + l2e <- insert' l2 + ret <- select $ do + lords1 <- from $ table @Lord + lords2 <- from $ table @Lord + pure (lords1, lords2) + ret2 <- select $ do + (lords1 :& lords2) <- 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) <- + from $ table @Person + `innerJoin` Table @Profile + `on` (\(people :& profiles) -> + people ^. PersonId ==. profiles ^. ProfilePerson) + `leftJoin` Table @BlogPost + `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 <- from $ 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) <- + from $ Table @Person + `InnerJoin` Table @Profile + `on` (\(people :& profiles) -> + people ^. PersonId ==. profiles ^. ProfilePerson) + `InnerJoin` Table @BlogPost + `on` (\(people :& _ :& posts) -> + people ^. PersonId ==. posts ^. BlogPostAuthorId) + pure result + rows <- select $ do + (persons :& profiles :& posts) <- 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 @@ -1816,6 +1904,7 @@ tests = testLocking testOverloadedRecordDot testDeriveEsqueletoRecord + CTESpec.testCTE insert' :: ( Functor m , BaseBackend backend ~ PersistEntityBackend val @@ -1931,6 +2020,34 @@ testOverloadedRecordDot = describe "OverloadedRecordDot" $ do just p.id ==. mbp.authorId pure (p.id, mbp.title) + itDb "joins Maybe together" $ do + void $ select $ do + deed :& lord <- + from $ + table @Deed + `leftJoin` table @Lord + `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) <- from $ + table @Profile + `leftJoin` table @Person + `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 @@ -1959,3 +2076,5 @@ testGetTable = pure (person, blogPost, profile, reply) asserting noExceptions +assertJust :: HasCallStack => Maybe a -> IO a +assertJust = maybe (expectationFailure "Expected Just, got Nothing" >> error "asdf") pure diff --git a/test/Common/Test/CTE.hs b/test/Common/Test/CTE.hs new file mode 100644 index 000000000..7243a5662 --- /dev/null +++ b/test/Common/Test/CTE.hs @@ -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)) + ] diff --git a/test/Common/Test/Models.hs b/test/Common/Test/Models.hs index fb29de769..d2237cd27 100644 --- a/test/Common/Test/Models.hs +++ b/test/Common/Test/Models.hs @@ -182,6 +182,16 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| address String deriving Show deriving Eq + + A + k Int + v Int + Primary k + + B + k Int + v Int + Primary k |] -- Unique Test schema @@ -197,4 +207,3 @@ share [mkPersist sqlSettings, mkMigrate "migrateUnique"] [persistUpperCase| instance ToBaseId ArticleMetadata where type BaseEnt ArticleMetadata = Article toBaseIdWitness articleId = ArticleMetadataKey articleId - diff --git a/test/MySQL/Test.hs b/test/MySQL/Test.hs index 3d8be3e3c..64d9c574a 100644 --- a/test/MySQL/Test.hs +++ b/test/MySQL/Test.hs @@ -29,6 +29,8 @@ import Database.Persist.MySQL import Test.Hspec import Common.Test +import Data.Maybe (fromMaybe) +import System.Environment (lookupEnv) testMysqlSum :: SpecDb testMysqlSum = do @@ -184,6 +186,7 @@ migrateIt = do mkConnectionPool :: IO ConnectionPool mkConnectionPool = do ci <- isCI + mysqlHost <- (fromMaybe "localhost" <$> lookupEnv "MYSQL_HOST") let connInfo | ci = defaultConnectInfo @@ -195,7 +198,7 @@ mkConnectionPool = do } | otherwise = defaultConnectInfo - { connectHost = "localhost" + { connectHost = mysqlHost , connectUser = "travis" , connectPassword = "esqutest" , connectDatabase = "esqutest" diff --git a/test/PostgreSQL/LegacyTest.hs b/test/PostgreSQL/LegacyTest.hs index e3840a4a4..18c95b551 100644 --- a/test/PostgreSQL/LegacyTest.hs +++ b/test/PostgreSQL/LegacyTest.hs @@ -1045,14 +1045,14 @@ testUpsert :: SpecDb testUpsert = describe "Upsert test" $ do itDb "Upsert can insert like normal" $ do - u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"] + u1e <- EP.upsert u1 (pure ( OneUniqueName =. val "fifth" )) liftIO $ entityVal u1e `shouldBe` u1 itDb "Upsert performs update on collision" $ do - u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"] + u1e <- EP.upsert u1 (pure (OneUniqueName =. val "fifth")) liftIO $ entityVal u1e `shouldBe` u1 - u2e <- EP.upsert u2 [OneUniqueName =. val "fifth"] + u2e <- EP.upsert u2 $ pure (OneUniqueName =. val "fifth") liftIO $ entityVal u2e `shouldBe` u2 - u3e <- EP.upsert u3 [OneUniqueName =. val "fifth"] + u3e <- EP.upsert u3 $ pure (OneUniqueName =. val "fifth") liftIO $ entityVal u3e `shouldBe` u1{oneUniqueName="fifth"} @@ -1060,7 +1060,7 @@ testFilterWhere :: SpecDb testFilterWhere = describe "filterWhere" $ do itDb "adds a filter clause to count aggregation" $ do - -- Person "John" (Just 36) Nothing 1 + -- Person "John" [Just 36] Nothing 1 _ <- insert p1 -- Person "Rachel" Nothing (Just 37) 2 _ <- insert p2 @@ -1201,7 +1201,6 @@ spec = beforeAll mkConnectionPool $ do describe "PostgreSQL specific tests" $ do testAscRandom random_ - testRandomMath testSelectDistinctOn testPostgresModule testPostgresqlOneAscOneDesc diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 5e3d18a73..f888a7b8f 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -12,7 +12,6 @@ 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) @@ -35,10 +34,11 @@ 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 Database.Esqueleto import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) -import Database.Esqueleto hiding (random_) import qualified Database.Esqueleto.Internal.Internal as ES -import Database.Esqueleto.PostgreSQL (random_, (%.)) +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 @@ -48,13 +48,43 @@ 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 Common.Test.Import hiding (from, on, ilike, distinctOn) 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 @@ -226,7 +256,7 @@ testSelectDistinctOn = do let query = do let orderVal = coalesce [nothing, just $ val (10 :: Int)] distinctOnOrderBy [ asc orderVal, desc orderVal ] $ pure orderVal - select query + _ <- select query asserting noExceptions @@ -508,7 +538,7 @@ testPostgresModule = do -- https://github.com/bitemyapp/esqueleto/pull/180 rawExecute "SET TIME ZONE 'UTC'" [] ret <- - fmap (Map.fromList . coerce :: _ -> Map DateTruncTestId (UTCTime, UTCTime)) $ + fmap (Map.fromList . coerce @_ @([(DateTruncTestId, (UTCTime, UTCTime))])) $ select $ do dt <- from $ table @DateTruncTest pure @@ -1059,18 +1089,28 @@ testInsertUniqueViolation = sqlErrorHint = ""} testUpsert :: SpecDb -testUpsert = - describe "Upsert test" $ do +testUpsert = describe "Upsert test" $ do itDb "Upsert can insert like normal" $ do - u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"] - liftIO $ entityVal u1e `shouldBe` u1 + u1e <- EP.upsert u1 (pure (OneUniqueName =. val "fifth")) + liftIO $ entityVal u1e `shouldBe` u1 itDb "Upsert performs update on collision" $ 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"} + 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 + u1 `shouldBe` u1' testInsertSelectWithConflict :: SpecDb testInsertSelectWithConflict = @@ -1260,6 +1300,80 @@ testCommonTableExpressions = do 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 <- from $ table @Lord + limit 10 + pure lords + lords <- 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 <- from $ table @Lord + limit 10 + pure lords + lords <- 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 <- from $ table @Lord + limit 10 + pure lords + lords <- 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 <- from $ table @Lord + limit 10 + pure lords + lords <- from limitedLordsCte + orderBy [asc $ lords ^. LordId] + pure lords + + asserting noExceptions + testPostgresqlLocking :: SpecDb testPostgresqlLocking = do describe "Monoid instance" $ do @@ -1271,7 +1385,9 @@ testPostgresqlLocking = do p <- 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 = @@ -1281,7 +1397,9 @@ testPostgresqlLocking = do ,"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 @@ -1374,7 +1492,6 @@ testPostgresqlLocking = do EP.forUpdateOf p EP.skipLocked return p - liftIO $ print nonLockedRowsSpecifiedTable pure $ length nonLockedRowsSpecifiedTable `shouldBe` 2 withAsync sideThread $ \sideThreadAsync -> do @@ -1396,7 +1513,6 @@ testPostgresqlLocking = do EP.forUpdateOf p EP.skipLocked return p - liftIO $ print nonLockedRowsAfterUpdate asserting sideThreadAsserts asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3 @@ -1797,6 +1913,54 @@ testSubselectAliasingBehavior = do 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 $ do + p <- from $ table @Person + orderBy [EP.ascNullsFirst (p ^. PersonAge), EP.ascNullsFirst (p ^. PersonFavNum)] + pure 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 $ do + p <- from $ table @Person + orderBy [EP.ascNullsLast (p ^. PersonAge), EP.ascNullsLast (p ^. PersonFavNum)] + pure 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 $ do + p <- from $ table @Person + orderBy [EP.descNullsFirst (p ^. PersonAge), EP.descNullsFirst (p ^. PersonFavNum)] + pure 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 $ do + p <- from $ table @Person + orderBy [EP.descNullsLast (p ^. PersonAge), EP.descNullsLast (p ^. PersonFavNum)] + return (p :: SqlExpr (Entity Person)) + -- 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 () @@ -1858,43 +2022,6 @@ selectJSON f = select $ do f $ just (v ^. JsonValue) return v ---------------- JSON --------------- JSON --------------- JSON --------------- ---------------- JSON --------------- JSON --------------- JSON --------------- ---------------- JSON --------------- JSON --------------- JSON --------------- - - - -spec :: Spec -spec = beforeAll mkConnectionPool $ do - tests - - describe "PostgreSQL specific tests" $ do - testAscRandom random_ - testRandomMath - 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 - testWindowFunctions - testSubselectAliasingBehavior - testPostgresqlLocking - insertJsonValues :: SqlPersistT IO () insertJsonValues = do insertIt Null diff --git a/test/SQLite/LegacyTest.hs b/test/SQLite/LegacyTest.hs index 185c3f69c..51ebe3b19 100644 --- a/test/SQLite/LegacyTest.hs +++ b/test/SQLite/LegacyTest.hs @@ -134,7 +134,6 @@ spec = beforeAll mkConnectionPool $ do describe "SQLite specific tests" $ do testAscRandom random_ - testRandomMath testSqliteRandom testSqliteSum testSqliteTwoAscFields diff --git a/test/SQLite/Test.hs b/test/SQLite/Test.hs index b432a4a64..e56a54fa3 100644 --- a/test/SQLite/Test.hs +++ b/test/SQLite/Test.hs @@ -135,7 +135,6 @@ spec = beforeAll mkConnectionPool $ do describe "SQLite specific tests" $ do testAscRandom random_ - testRandomMath testSqliteRandom testSqliteSum testSqliteTwoAscFields diff --git a/test/Spec.hs b/test/Spec.hs index 33f1300ef..72357cd84 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -28,4 +28,3 @@ spec = do sequential $ LegacyPostgres.spec describe "Postgresql" $ do sequential $ Postgres.spec - diff --git a/test/docker-compose.yml b/test/docker-compose.yml new file mode 100644 index 000000000..6bea6e0ea --- /dev/null +++ b/test/docker-compose.yml @@ -0,0 +1,28 @@ +# docker-compose file for running postgres and mysql DBMS + +# If using this to run the tests, +# while these containers are running (i.e. after something like) +# (cd test; docker-compose up -d) +# the tests must be told to use the hostname via MYSQL_HOST environment variable +# e.g. something like: +# MYSQL_HOST=127.0.0.1 stack test + +version: '3' +services: + postgres: + image: 'postgres:15.2-alpine' + environment: + POSTGRES_USER: esqutest + POSTGRES_PASSWORD: esqutest + POSTGRES_DB: esqutest + ports: + - 5432:5432 + mysql: + image: 'mysql:8.0.32' + environment: + MYSQL_USER: travis + MYSQL_PASSWORD: esqutest + MYSQL_ROOT_PASSWORD: esqutest + MYSQL_DATABASE: esqutest + ports: + - 3306:3306