diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 642759783..8f4e14e87 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -32,13 +32,13 @@ jobs: --health-retries=3 strategy: matrix: - cabal: ["3.6"] - ghc: ["8.6.5", "8.8.4", "8.10.4", "9.0.2", "9.2.2"] + 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"] env: CONFIG: "--enable-tests --enable-benchmarks " steps: - uses: actions/checkout@v2 - - uses: haskell/actions/setup@v1 + - uses: haskell/actions/setup@v2 id: setup-haskell-cabal with: ghc-version: ${{ matrix.ghc }} diff --git a/README.md b/README.md index fc347f18e..3bd07f800 100644 --- a/README.md +++ b/README.md @@ -219,7 +219,7 @@ Advantages: - `ON` clause is attached directly to the relevant join, so you never need to worry about how they're ordered, nor will you ever run into bugs where the `on` clause is on the wrong `JOIN` -- The `ON` clause lambda will all the available tables in it. This forbids +- The `ON` clause lambda will exclusively have all the available tables in it. This forbids runtime errors where an `ON` clause refers to a table that isn't in scope yet. - You can join on a table twice, and the aliases work out fine with the `ON` clause. diff --git a/changelog.md b/changelog.md index 642bb288e..5113ea968 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,66 @@ +4.0.0.0 +======= +- @belevy + - Change Database.Esqueleto to use the new syntax, add warning to Database.Esqueleto.Experimental/Legacy mentioning their deprecation. + - Split SqlSelectCols typeclass out of SqlSelect, simplifying subquery type inference + - 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.5.11.2 +======== +- @arguri + - [#387](https://github.com/bitemyapp/esqueleto/pull/387) + - Fix build for ghc 9.8.1 / template-haskell 2.18 + +3.5.11.0 +======== +- @9999years, @halogenandtoast + - [#378](https://github.com/bitemyapp/esqueleto/pull/378) + - `ToMaybe` instances are now derived for records so you can now left + join them in queries + +3.5.10.3 +======== +- @ttuegel + - [#377](https://github.com/bitemyapp/esqueleto/pull/377) + - Fix Postgres syntax for `noWait` + +3.5.10.2 +======== +- @parsonsmatt + - [#376](https://github.com/bitemyapp/esqueleto/pull/376) + - When using Postgres 15, `LIMIT`, and the `locking` functions, you + could accidentally construct SQL code like: + + > ... LIMIT 1FOR UPDATE ... + + This parsed on Postgres <15, but the new Postgres parser is more + strict, and fails to parse. This PR introduces newlines between each + query chunk, which fixes the issue. + +3.5.10.1 +======== +- @9999years + - [#369](https://github.com/bitemyapp/esqueleto/pull/369) + - Fix `myAge` type in `deriveEsqueletoRecord` documentation + +3.5.10.0 +======== +- @ivanbakel + - [#328](https://github.com/bitemyapp/esqueleto/pull/328) + - Add `ToAlias` instances for 9- to 16-tuples + - Add `ToAliasReference` instances for 9- to 16-tuples +- @parsonsmatt + - [#365](https://github.com/bitemyapp/esqueleto/pull/365) + - Add `isNothing_` and `groupBy_` to avoid name conflicts with + `Data.List` and `Data.Maybe`. + +3.5.9.1 +======= +- @duplode + - [#363](https://github.com/bitemyapp/esqueleto/pull/363) + - Add missing `just` to left join examples in the Haddocks + 3.5.9.0 ======= - @9999years diff --git a/esqueleto.cabal b/esqueleto.cabal index 56c96681f..0822af6be 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.5.9.0 +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. . @@ -36,6 +36,9 @@ library Database.Esqueleto.Internal.ExprParser Database.Esqueleto.MySQL Database.Esqueleto.PostgreSQL + Database.Esqueleto.PostgreSQL.Window + Database.Esqueleto.PostgreSQL.WindowFunction + Database.Esqueleto.PostgreSQL.Window.Frame Database.Esqueleto.PostgreSQL.JSON Database.Esqueleto.Record Database.Esqueleto.SQLite @@ -65,7 +68,7 @@ library , resourcet >=1.2 , tagged >=0.2 , template-haskell - , text >=0.11 && <2.1 + , text >=0.11 && <2.2 , time >=1.5.0.1 && <=1.13 , transformers >=0.2 , unliftio @@ -87,14 +90,18 @@ test-suite specs main-is: Spec.hs other-modules: Common.Test + Common.LegacyTest Common.Test.Models Common.Test.Import Common.Test.Select Common.Record PostgreSQL.MigrateJSON SQLite.Test + SQLite.LegacyTest PostgreSQL.Test + PostgreSQL.LegacyTest MySQL.Test + MySQL.LegacyTest default-extensions: RankNTypes hs-source-dirs: diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index b4b4c9812..fccb46835 100644 --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} -- | The @esqueleto@ EDSL (embedded domain specific language). @@ -37,100 +38,227 @@ -- in this module will be replaced with those at the 4.0.0.0 version, so you are -- encouraged to migrate to the new method. -- --- This module has an attached WARNING message indicating that the Experimental --- syntax will become the default. If you want to continue using the old syntax, --- please refer to "Database.Esqueleto.Legacy" as a drop-in replacement. -module Database.Esqueleto {-# WARNING "This module will switch over to the Experimental syntax in an upcoming major version release. Please migrate to the Database.Esqueleto.Legacy module to continue using the old syntax, or translate to the new and improved syntax in Database.Esqueleto.Experimental." #-} - ( -- * Setup - -- $setup - - -- * Introduction - -- $introduction - - -- * Getting started - -- $gettingstarted - - -- * @esqueleto@'s Language - where_, on, groupBy, orderBy, rand, asc, desc, limit, offset - , distinct, distinctOn, don, distinctOnOrderBy, having, locking - , sub_select, (^.), (?.) - , val, isNothing, just, nothing, joinV, withNonNull - , countRows, count, countDistinct - , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) - , between, (+.), (-.), (/.), (*.) - , random_, round_, ceiling_, floor_ - , min_, max_, sum_, avg_, castNum, castNumM - , coalesce, coalesceDefault - , lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_ - , like, ilike, (%), concat_, (++.), castString - , subList_select, valList, justList - , in_, notIn, exists, notExists - , set, (=.), (+=.), (-=.), (*=.), (/=.) - , case_, toBaseId - , subSelect - , subSelectMaybe - , subSelectCount - , subSelectForeign - , subSelectList - , subSelectUnsafe - , ToBaseId(..) - , when_ - , then_ - , else_ - , from - , Value(..) - , ValueList(..) - , OrderBy - , DistinctOn - , LockingKind(..) - , LockableEntity(..) - , SqlString +-- This module now exports the new syntax. If you want to continue using the old syntax for a while longer, +-- please refer to "Database.Esqueleto.Legacy" as a drop-in replacement. The legacy syntax will be dropped +-- at the next major release. +module Database.Esqueleto + ( -- * Setup + -- $setup + + -- * Introduction + -- $introduction + + -- * A New Syntax + -- $new-syntax + + -- * Documentation + + -- ** Basic Queries + from + , table + , Table(..) + , SubQuery(..) + , selectQuery + -- ** Joins - , InnerJoin(..) - , CrossJoin(..) - , LeftOuterJoin(..) - , RightOuterJoin(..) - , FullOuterJoin(..) - , JoinKind(..) - , OnClauseWithoutMatchingJoinException(..) - -- * SQL backend - , SqlQuery - , SqlExpr - , SqlEntity - , select - , selectOne - , selectSource - , delete - , deleteCount - , update - , updateCount - , insertSelect - , insertSelectCount - , (<#) - , (<&>) - -- ** Rendering Queries - , renderQueryToText - , renderQuerySelect - , renderQueryUpdate - , renderQueryDelete - , renderQueryInsertInto - -- * Internal.Language - , From - -- * RDBMS-specific modules - -- $rdbmsSpecificModules - - -- * Helpers - , valkey - , valJ - , associateJoin - - -- * Re-exports - -- $reexports - , deleteKey - , module Database.Esqueleto.Internal.PersistentImport - ) where - -import Database.Esqueleto.Legacy + , (:&)(..) + , on + , innerJoin + , innerJoinLateral + , leftJoin + , leftJoinLateral + , rightJoin + , fullOuterJoin + , crossJoin + , crossJoinLateral + + -- ** Set Operations + -- $sql-set-operations + , union_ + , Union(..) + , unionAll_ + , UnionAll(..) + , except_ + , Except(..) + , intersect_ + , Intersect(..) + , pattern SelectQuery + + -- ** Common Table Expressions + , with + , withRecursive + + -- ** Internals + , From(..) + , ToMaybe(..) + , ToAlias(..) + , ToAliasT + , ToAliasReference(..) + , ToAliasReferenceT + , ToSqlSetOperation(..) + + -- * The Normal Stuff + , where_ + , groupBy + , orderBy + , rand + , asc + , desc + , limit + , offset + + , distinct + , distinctOn + , don + , distinctOnOrderBy + , having + , locking + + , sub_select + , (^.) + , (?.) + + , val + , isNothing + , just + , nothing + , joinV + , withNonNull + + , countRows + , count + , countDistinct + + , not_ + , (==.) + , (>=.) + , (>.) + , (<=.) + , (<.) + , (!=.) + , (&&.) + , (||.) + + , between + , (+.) + , (-.) + , (/.) + , (*.) + + , round_ + , ceiling_ + , floor_ + + , min_ + , max_ + , sum_ + , avg_ + , castNum + , castNumM + + , coalesce + , coalesceDefault + + , lower_ + , upper_ + , trim_ + , ltrim_ + , rtrim_ + , length_ + , left_ + , right_ + + , like + , ilike + , (%) + , concat_ + , (++.) + , castString + + , subList_select + , valList + , justList + + , in_ + , notIn + , exists + , notExists + + , set + , (=.) + , (+=.) + , (-=.) + , (*=.) + , (/=.) + + , case_ + , toBaseId + , subSelect + , subSelectMaybe + , subSelectCount + , subSelectForeign + , subSelectList + , subSelectUnsafe + , ToBaseId(..) + , when_ + , then_ + , else_ + , Value(..) + , ValueList(..) + , OrderBy + , DistinctOn + , LockingKind(..) + , LockableEntity(..) + , SqlString + + -- ** Joins + , InnerJoin(..) + , CrossJoin(..) + , LeftOuterJoin(..) + , RightOuterJoin(..) + , FullOuterJoin(..) + , JoinKind(..) + , OnClauseWithoutMatchingJoinException(..) + -- *** Join Helpers + , getTable + , getTableMaybe + , GetFirstTable(..) + + -- ** SQL backend + , SqlQuery + , SqlExpr + , SqlEntity + , select + , selectOne + , selectSource + , delete + , deleteCount + , update + , updateCount + , insertSelect + , insertSelectCount + , (<#) + , (<&>) + + -- ** Rendering Queries + , renderQueryToText + , renderQuerySelect + , renderQueryUpdate + , renderQueryDelete + , renderQueryInsertInto + + -- ** Helpers + , valkey + , valJ + , associateJoin + + -- ** Re-exports + -- $reexports + , deleteKey + , module Database.Esqueleto.Internal.PersistentImport + ) where + +import Database.Esqueleto.Experimental import Database.Esqueleto.Internal.PersistentImport diff --git a/src/Database/Esqueleto/Experimental.hs b/src/Database/Esqueleto/Experimental.hs index 607473505..de08c880f 100644 --- a/src/Database/Esqueleto/Experimental.hs +++ b/src/Database/Esqueleto/Experimental.hs @@ -6,7 +6,7 @@ -- -- This syntax will become the default syntax exported from the library in -- version @3.6.0.0@. To use the old syntax, see "Database.Esqueleto.Legacy". -module Database.Esqueleto.Experimental +module Database.Esqueleto.Experimental {-# WARNING "This module will be removed in the next major release as the Expermintal syntax is now the default behavior. Please import the Database.Esqueleto module instead." #-} ( -- * Setup -- $setup @@ -65,6 +65,7 @@ module Database.Esqueleto.Experimental -- * The Normal Stuff , where_ , groupBy + , groupBy_ , orderBy , rand , asc @@ -85,6 +86,7 @@ module Database.Esqueleto.Experimental , val , isNothing + , isNothing_ , just , nothing , joinV @@ -110,7 +112,6 @@ module Database.Esqueleto.Experimental , (/.) , (*.) - , random_ , round_ , ceiling_ , floor_ @@ -339,8 +340,8 @@ import Database.Esqueleto.Experimental.ToMaybe -- @ -- select $ -- from $ \\(people \`LeftOuterJoin\` blogPosts) -> do --- on (people ^. PersonId ==. blogPosts ?. BlogPostAuthorId) --- where_ (people ^. PersonAge >. val 18) +-- on (just (people ^. PersonId) ==. blogPosts ?. BlogPostAuthorId) +-- where_ (people ^. PersonAge >. just (val 18)) -- pure (people, blogPosts) -- @ -- @@ -354,8 +355,8 @@ import Database.Esqueleto.Experimental.ToMaybe -- from $ table \@Person -- \`leftJoin\` table \@BlogPost -- \`on\` (\\(people :& blogPosts) -> --- people ^. PersonId ==. blogPosts ?. BlogPostAuthorId) --- where_ (people ^. PersonAge >. val 18) +-- just (people ^. PersonId) ==. blogPosts ?. BlogPostAuthorId) +-- where_ (people ^. PersonAge >. just (val 18)) -- pure (people, blogPosts) -- @ -- diff --git a/src/Database/Esqueleto/Experimental/From.hs b/src/Database/Esqueleto/Experimental/From.hs index e9d391899..266250078 100644 --- a/src/Database/Esqueleto/Experimental/From.hs +++ b/src/Database/Esqueleto/Experimental/From.hs @@ -71,7 +71,7 @@ instance ToFrom (From a) a where {-# DEPRECATED Table "@since 3.5.0.0 - use 'table' instead" #-} data Table a = Table -instance PersistEntity ent => ToFrom (Table ent) (SqlExpr (Entity ent)) where +instance PersistEntity ent => ToFrom (Table ent) (SqlExpr_ ValueContext (Entity ent)) where toFrom _ = table -- | Bring a PersistEntity into scope from a table @@ -81,7 +81,7 @@ instance PersistEntity ent => ToFrom (Table ent) (SqlExpr (Entity ent)) where -- @ -- -- @since 3.5.0.0 -table :: forall ent. PersistEntity ent => From (SqlExpr (Entity ent)) +table :: forall ent. PersistEntity ent => From (SqlExpr_ ValueContext (Entity ent)) table = From $ do let ed = entityDef (Proxy @ent) ident <- newIdentFor (coerce $ getEntityDBName ed) @@ -100,9 +100,9 @@ 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 (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SubQuery (SqlQuery a)) a where +instance (SqlSelectCols a, ToAlias a, ToAliasReference a a') => ToFrom (SubQuery (SqlQuery a)) a' where toFrom (SubQuery q) = selectQuery q -instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SqlQuery a) a where +instance (SqlSelectCols a, ToAlias a, ToAliasReference a a') => ToFrom (SqlQuery a) a' where toFrom = selectQuery -- | Select from a subquery, often used in conjuction with joins but can be @@ -120,7 +120,8 @@ instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SqlQuery a) a -- @ -- -- @since 3.5.0.0 -selectQuery :: (SqlSelect a r, ToAlias a, ToAliasReference a) => SqlQuery a -> From a +selectQuery :: (SqlSelectCols a, ToAlias a, ToAliasReference a a') + => SqlQuery a -> From a' selectQuery subquery = From $ do -- We want to update the IdentState without writing the query to side data (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery diff --git a/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs b/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs index a0d72b9f0..7e56809d2 100644 --- a/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs +++ b/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs @@ -42,9 +42,9 @@ import Database.Esqueleto.Internal.Internal hiding (From(..), from, on) -- -- /Since: 3.4.0.0/ with :: ( ToAlias a - , ToAliasReference a + , ToAliasReference a a' , SqlSelect a r - ) => SqlQuery a -> SqlQuery (From a) + ) => SqlQuery a -> SqlQuery (From a') with query = do (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ query aliasedValue <- toAlias ret @@ -88,7 +88,7 @@ with query = do -- -- /Since: 3.4.0.0/ withRecursive :: ( ToAlias a - , ToAliasReference a + , ToAliasReference a a , SqlSelect a r ) => SqlQuery a diff --git a/src/Database/Esqueleto/Experimental/From/Join.hs b/src/Database/Esqueleto/Experimental/From/Join.hs index 6a4122aa9..a4789ed0e 100644 --- a/src/Database/Esqueleto/Experimental/From/Join.hs +++ b/src/Database/Esqueleto/Experimental/From/Join.hs @@ -53,7 +53,7 @@ import GHC.TypeLits instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where type ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b) - toMaybe (a :& b) = (toMaybe a :& toMaybe b) + toMaybe (a :& b) = toMaybe a :& toMaybe b class ValidOnClause a instance {-# OVERLAPPABLE #-} ToFrom a a' => ValidOnClause a @@ -63,14 +63,14 @@ instance ValidOnClause (a -> SqlQuery b) -- identical to the tuple instance, but is provided for convenience. -- -- @since 3.5.2.0 -instance (SqlSelect a ra, SqlSelect b rb) => SqlSelect (a :& b) (ra :& rb) where +instance (SqlSelectCols a, SqlSelectCols b) => SqlSelectCols (a :& b) where sqlSelectCols esc (a :& b) = sqlSelectCols esc (a, b) - sqlSelectColCount = sqlSelectColCount . toTuple - where - toTuple :: Proxy (a :& b) -> Proxy (a, b) - toTuple = const Proxy - sqlSelectProcessRow = fmap (uncurry (:&)) . sqlSelectProcessRow + sqlSelectColCount = sqlSelectColCount . toTupleP +instance (SqlSelect a ra, SqlSelect b rb) => SqlSelect (a :& b) (ra :& rb) where + sqlSelectProcessRow p = fmap (uncurry (:&)) . sqlSelectProcessRow (toTupleP p) +toTupleP :: Proxy (a :& b) -> Proxy (a, b) +toTupleP = const Proxy -- | Identical to the tuple instance and provided for convenience. -- -- @since 3.5.3.0 @@ -80,8 +80,10 @@ instance (ToAlias a, ToAlias b) => ToAlias (a :& b) where -- | Identical to the tuple instance and provided for convenience. -- -- @since 3.5.3.0 -instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a :& b) where - toAliasReference ident (a :& b) = (:&) <$> (toAliasReference ident a) <*> (toAliasReference ident b) +instance (ToAliasReference a a', ToAliasReference b b') => ToAliasReference (a :& b) (a' :& b') where + toAliasReference ident (a :& b) = + (:&) <$> toAliasReference ident a + <*> toAliasReference ident b -- | An @ON@ clause that describes how two tables are related. This should be -- used as an infix operator after a 'JOIN'. For example, @@ -93,7 +95,7 @@ instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a :& b) w -- \`on\` (\\(p :& bP) -> -- p ^. PersonId ==. bP ^. BlogPostAuthorId) -- @ -on :: ValidOnClause a => a -> (b -> SqlExpr (Value Bool)) -> (a, b -> SqlExpr (Value Bool)) +on :: ValidOnClause a => a -> (b -> SqlExpr_ ValueContext (Value Bool)) -> (a, b -> SqlExpr_ ValueContext (Value Bool)) on = (,) infix 9 `on` @@ -101,7 +103,7 @@ type family ErrorOnLateral a :: Constraint where ErrorOnLateral (a -> SqlQuery b) = TypeError ('Text "LATERAL can only be used for INNER, LEFT, and CROSS join kinds.") ErrorOnLateral _ = () -fromJoin :: TLB.Builder -> RawFn -> RawFn -> Maybe (SqlExpr (Value Bool)) -> RawFn +fromJoin :: TLB.Builder -> RawFn -> RawFn -> Maybe (SqlExpr_ ValueContext (Value Bool)) -> RawFn fromJoin joinKind lhs rhs monClause = \paren info -> first (parensM paren) $ @@ -114,14 +116,14 @@ fromJoin joinKind lhs rhs monClause = makeOnClause info (ERaw _ f) = first (" ON " <>) (f Never info) type family HasOnClause actual expected :: Constraint where - HasOnClause (a, b -> SqlExpr (Value Bool)) c = () -- Let the compiler handle the type mismatch + HasOnClause (a, b -> SqlExpr_ ValueContext (Value Bool)) c = () -- Let the compiler handle the type mismatch HasOnClause a expected = TypeError ( 'Text "Missing ON clause for join with" ':$$: 'ShowType a ':$$: 'Text "" ':$$: 'Text "Expected: " ':$$: 'ShowType a - ':$$: 'Text "`on` " ':<>: 'ShowType (expected -> SqlExpr (Value Bool)) + ':$$: 'Text "`on` " ':<>: 'ShowType (expected -> SqlExpr_ ValueContext (Value Bool)) ':$$: 'Text "" ) @@ -142,13 +144,13 @@ type family HasOnClause actual expected :: Constraint where innerJoin :: ( ToFrom a a' , ToFrom b b' , HasOnClause rhs (a' :& b') - , rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool)) + , rhs ~ (b, (a' :& b') -> SqlExpr_ ValueContext (Value Bool)) ) => a -> rhs -> From (a' :& b') innerJoin lhs (rhs, on') = From $ do (leftVal, leftFrom) <- unFrom (toFrom lhs) (rightVal, rightFrom) <- unFrom (toFrom rhs) let ret = leftVal :& rightVal - pure $ (ret, fromJoin " INNER JOIN " leftFrom rightFrom (Just $ on' ret)) + pure (ret, fromJoin " INNER JOIN " leftFrom rightFrom (Just $ on' ret)) -- | INNER JOIN LATERAL @@ -163,17 +165,17 @@ innerJoin lhs (rhs, on') = From $ do -- @since 3.5.0.0 innerJoinLateral :: ( ToFrom a a' , HasOnClause rhs (a' :& b) - , SqlSelect b r + , SqlSelectCols b , ToAlias b - , ToAliasReference b - , rhs ~ (a' -> SqlQuery b, (a' :& b) -> SqlExpr (Value Bool)) + , ToAliasReference b b' + , rhs ~ (a' -> SqlQuery b, (a' :& b') -> SqlExpr_ ValueContext (Value Bool)) ) - => a -> rhs -> From (a' :& b) + => a -> rhs -> From (a' :& b') innerJoinLateral lhs (rhsFn, on') = From $ do (leftVal, leftFrom) <- unFrom (toFrom lhs) (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal)) let ret = leftVal :& rightVal - pure $ (ret, fromJoin " INNER JOIN LATERAL " leftFrom rightFrom (Just $ on' ret)) + pure (ret, fromJoin " INNER JOIN LATERAL " leftFrom rightFrom (Just $ on' ret)) -- | CROSS JOIN -- @@ -193,7 +195,7 @@ crossJoin lhs rhs = From $ do (leftVal, leftFrom) <- unFrom (toFrom lhs) (rightVal, rightFrom) <- unFrom (toFrom rhs) let ret = leftVal :& rightVal - pure $ (ret, fromJoin " CROSS JOIN " leftFrom rightFrom Nothing) + pure (ret, fromJoin " CROSS JOIN " leftFrom rightFrom Nothing) -- | CROSS JOIN LATERAL -- @@ -206,16 +208,16 @@ crossJoin lhs rhs = From $ do -- -- @since 3.5.0.0 crossJoinLateral :: ( ToFrom a a' - , SqlSelect b r + , SqlSelectCols b , ToAlias b - , ToAliasReference b + , ToAliasReference b b' ) - => a -> (a' -> SqlQuery b) -> From (a' :& b) + => a -> (a' -> SqlQuery b) -> From (a' :& b') crossJoinLateral lhs rhsFn = From $ do (leftVal, leftFrom) <- unFrom (toFrom lhs) (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal)) let ret = leftVal :& rightVal - pure $ (ret, fromJoin " CROSS JOIN LATERAL " leftFrom rightFrom Nothing) + pure (ret, fromJoin " CROSS JOIN LATERAL " leftFrom rightFrom Nothing) -- | LEFT OUTER JOIN -- @@ -230,7 +232,7 @@ crossJoinLateral lhs rhsFn = From $ do -- from $ table \@Person -- \`leftJoin\` table \@BlogPost -- \`on\` (\\(p :& bp) -> --- p ^. PersonId ==. bp ?. BlogPostAuthorId) +-- just (p ^. PersonId) ==. bp ?. BlogPostAuthorId) -- @ -- -- @since 3.5.0.0 @@ -238,13 +240,13 @@ leftJoin :: ( ToFrom a a' , ToFrom b b' , ToMaybe b' , HasOnClause rhs (a' :& ToMaybeT b') - , rhs ~ (b, (a' :& ToMaybeT b') -> SqlExpr (Value Bool)) + , rhs ~ (b, (a' :& ToMaybeT b') -> SqlExpr_ ValueContext (Value Bool)) ) => a -> rhs -> From (a' :& ToMaybeT b') leftJoin lhs (rhs, on') = From $ do (leftVal, leftFrom) <- unFrom (toFrom lhs) (rightVal, rightFrom) <- unFrom (toFrom rhs) let ret = leftVal :& toMaybe rightVal - pure $ (ret, fromJoin " LEFT OUTER JOIN " leftFrom rightFrom (Just $ on' ret)) + pure (ret, fromJoin " LEFT OUTER JOIN " leftFrom rightFrom (Just $ on' ret)) -- | LEFT OUTER JOIN LATERAL -- @@ -259,19 +261,19 @@ leftJoin lhs (rhs, on') = From $ do -- -- @since 3.5.0.0 leftJoinLateral :: ( ToFrom a a' - , SqlSelect b r + , SqlSelectCols b , HasOnClause rhs (a' :& ToMaybeT b) , ToAlias b - , ToAliasReference b - , ToMaybe b - , rhs ~ (a' -> SqlQuery b, (a' :& ToMaybeT b) -> SqlExpr (Value Bool)) + , ToAliasReference b b' + , ToMaybe b' + , rhs ~ (a' -> SqlQuery b, (a' :& ToMaybeT b') -> SqlExpr_ ValueContext (Value Bool)) ) - => a -> rhs -> From (a' :& ToMaybeT b) + => a -> rhs -> From (a' :& ToMaybeT b') leftJoinLateral lhs (rhsFn, on') = From $ do (leftVal, leftFrom) <- unFrom (toFrom lhs) (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal)) let ret = leftVal :& toMaybe rightVal - pure $ (ret, fromJoin " LEFT OUTER JOIN LATERAL " leftFrom rightFrom (Just $ on' ret)) + pure (ret, fromJoin " LEFT OUTER JOIN LATERAL " leftFrom rightFrom (Just $ on' ret)) -- | RIGHT OUTER JOIN -- @@ -294,13 +296,13 @@ rightJoin :: ( ToFrom a a' , ToFrom b b' , ToMaybe a' , HasOnClause rhs (ToMaybeT a' :& b') - , rhs ~ (b, (ToMaybeT a' :& b') -> SqlExpr (Value Bool)) + , rhs ~ (b, (ToMaybeT a' :& b') -> SqlExpr_ ValueContext (Value Bool)) ) => a -> rhs -> From (ToMaybeT a' :& b') rightJoin lhs (rhs, on') = From $ do (leftVal, leftFrom) <- unFrom (toFrom lhs) (rightVal, rightFrom) <- unFrom (toFrom rhs) let ret = toMaybe leftVal :& rightVal - pure $ (ret, fromJoin " RIGHT OUTER JOIN " leftFrom rightFrom (Just $ on' ret)) + pure (ret, fromJoin " RIGHT OUTER JOIN " leftFrom rightFrom (Just $ on' ret)) -- | FULL OUTER JOIN -- @@ -323,7 +325,7 @@ fullOuterJoin :: ( ToFrom a a' , ToMaybe a' , ToMaybe b' , HasOnClause rhs (ToMaybeT a' :& ToMaybeT b') - , rhs ~ (b, (ToMaybeT a' :& ToMaybeT b') -> SqlExpr (Value Bool)) + , rhs ~ (b, (ToMaybeT a' :& ToMaybeT b') -> SqlExpr_ ValueContext (Value Bool)) ) => a -> rhs -> From (ToMaybeT a' :& ToMaybeT b') fullOuterJoin lhs (rhs, on') = From $ do (leftVal, leftFrom) <- unFrom (toFrom lhs) @@ -495,16 +497,16 @@ class DoInnerJoin lateral lhs rhs res | lateral rhs lhs -> res where instance ( ToFrom a a' , ToFrom b b' , HasOnClause rhs (a' :& b') - , rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool)) + , rhs ~ (b, (a' :& b') -> SqlExpr_ ValueContext (Value Bool)) ) => DoInnerJoin NotLateral a rhs (a' :& b') where doInnerJoin _ = innerJoin instance ( ToFrom a a' - , SqlSelect b r + , SqlSelectCols b , ToAlias b - , ToAliasReference b - , d ~ (a' :& b) - ) => DoInnerJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where + , ToAliasReference b b' + , d ~ (a' :& b') + ) => DoInnerJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr_ ValueContext (Value Bool)) d where doInnerJoin _ = innerJoinLateral instance ( DoInnerJoin lateral lhs rhs r, lateral ~ IsLateral rhs ) @@ -519,17 +521,17 @@ instance ( ToFrom a a' , ToMaybe b' , ToMaybeT b' ~ mb , HasOnClause rhs (a' :& mb) - , rhs ~ (b, (a' :& mb) -> SqlExpr (Value Bool)) + , rhs ~ (b, (a' :& mb) -> SqlExpr_ ValueContext (Value Bool)) ) => DoLeftJoin NotLateral a rhs (a' :& mb) where doLeftJoin _ = leftJoin instance ( ToFrom a a' - , ToMaybe b - , d ~ (a' :& ToMaybeT b) - , SqlSelect b r + , ToMaybe b' + , d ~ (a' :& ToMaybeT b') + , SqlSelectCols b , ToAlias b - , ToAliasReference b - ) => DoLeftJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where + , ToAliasReference b b' + ) => DoLeftJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr_ ValueContext (Value Bool)) d where doLeftJoin _ = leftJoinLateral instance ( DoLeftJoin lateral lhs rhs r, lateral ~ IsLateral rhs ) @@ -541,8 +543,8 @@ class DoCrossJoin lateral lhs rhs res | lateral lhs rhs -> res where instance (ToFrom a a', ToFrom b b') => DoCrossJoin NotLateral a b (a' :& b') where doCrossJoin _ = crossJoin -instance (ToFrom a a', SqlSelect b r, ToAlias b, ToAliasReference b) - => DoCrossJoin Lateral a (a' -> SqlQuery b) (a' :& b) where +instance (ToFrom a a', SqlSelectCols b, ToAlias b, ToAliasReference b b') + => DoCrossJoin Lateral a (a' -> SqlQuery b) (a' :& b') where doCrossJoin _ = crossJoinLateral instance (DoCrossJoin lateral lhs rhs r, IsLateral rhs ~ lateral) @@ -555,7 +557,7 @@ instance ( ToFrom a a' , ToMaybeT a' ~ ma , HasOnClause rhs (ma :& b') , ErrorOnLateral b - , rhs ~ (b, (ma :& b') -> SqlExpr (Value Bool)) + , rhs ~ (b, (ma :& b') -> SqlExpr_ ValueContext (Value Bool)) ) => ToFrom (RightOuterJoin a rhs) (ma :& b') where toFrom (RightOuterJoin a b) = rightJoin a b @@ -567,6 +569,6 @@ instance ( ToFrom a a' , ToMaybeT b' ~ mb , HasOnClause rhs (ma :& mb) , ErrorOnLateral b - , rhs ~ (b, (ma :& mb) -> SqlExpr (Value Bool)) + , rhs ~ (b, (ma :& mb) -> SqlExpr_ ValueContext (Value Bool)) ) => ToFrom (FullOuterJoin a rhs) (ma :& mb) where toFrom (FullOuterJoin a b) = fullOuterJoin a b diff --git a/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs b/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs index c4e9145a2..c532ac86d 100644 --- a/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs +++ b/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs @@ -32,7 +32,7 @@ import Database.Esqueleto.Internal.PersistentImport (PersistValue) newtype SqlSetOperation a = SqlSetOperation { unSqlSetOperation :: NeedParens -> SqlQuery (a, IdentInfo -> (TLB.Builder, [PersistValue]))} -instance ToAliasReference a => ToFrom (SqlSetOperation a) a where +instance ToAliasReference a a' => ToFrom (SqlSetOperation a) a' where toFrom setOperation = From $ do ident <- newIdentFor (DBName "u") (a, fromClause) <- unSqlSetOperation setOperation Never @@ -46,7 +46,7 @@ class ToSqlSetOperation a r | a -> r where toSqlSetOperation :: a -> SqlSetOperation r instance ToSqlSetOperation (SqlSetOperation a) a where toSqlSetOperation = id -instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToSqlSetOperation (SqlQuery a) a where +instance (SqlSelectCols a, ToAlias a, ToAliasReference a a') => ToSqlSetOperation (SqlQuery a) a where toSqlSetOperation subquery = SqlSetOperation $ \p -> do (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery diff --git a/src/Database/Esqueleto/Experimental/ToAlias.hs b/src/Database/Esqueleto/Experimental/ToAlias.hs index b6ab99193..d1eea9a9e 100644 --- a/src/Database/Esqueleto/Experimental/ToAlias.hs +++ b/src/Database/Esqueleto/Experimental/ToAlias.hs @@ -15,21 +15,21 @@ type ToAliasT a = a class ToAlias a where toAlias :: a -> SqlQuery a -instance ToAlias (SqlExpr (Value a)) where +instance ToAlias (SqlExpr_ ctx (Value a)) where toAlias e@(ERaw m f) | Just _ <- sqlExprMetaAlias m = pure e | otherwise = do ident <- newIdentFor (DBName "v") pure $ ERaw noMeta{sqlExprMetaAlias = Just ident} f -instance ToAlias (SqlExpr (Entity a)) where +instance ToAlias (SqlExpr_ ctx (Entity a)) where toAlias e@(ERaw m f) | Just _ <- sqlExprMetaAlias m = pure e | otherwise = do ident <- newIdentFor (DBName "v") pure $ ERaw m{sqlExprMetaIsReference = False, sqlExprMetaAlias = Just ident} f -instance ToAlias (SqlExpr (Maybe (Entity a))) where +instance ToAlias (SqlExpr_ ctx (Maybe (Entity a))) where -- FIXME: Code duplication because the compiler doesnt like half final encoding toAlias e@(ERaw m f) | Just _ <- sqlExprMetaAlias m = pure e @@ -90,3 +90,127 @@ instance ( ToAlias a , ToAlias h ) => ToAlias (a,b,c,d,e,f,g,h) where toAlias x = to8 <$> (toAlias $ from8 x) + +instance ( ToAlias a + , ToAlias b + , ToAlias c + , ToAlias d + , ToAlias e + , ToAlias f + , ToAlias g + , ToAlias h + , ToAlias i + ) => ToAlias (a,b,c,d,e,f,g,h,i) where + toAlias x = to9 <$> (toAlias $ from9 x) + +instance ( ToAlias a + , ToAlias b + , ToAlias c + , ToAlias d + , ToAlias e + , ToAlias f + , ToAlias g + , ToAlias h + , ToAlias i + , ToAlias j + ) => ToAlias (a,b,c,d,e,f,g,h,i,j) where + toAlias x = to10 <$> (toAlias $ from10 x) + +instance ( ToAlias a + , ToAlias b + , ToAlias c + , ToAlias d + , ToAlias e + , ToAlias f + , ToAlias g + , ToAlias h + , ToAlias i + , ToAlias j + , ToAlias k + ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k) where + toAlias x = to11 <$> (toAlias $ from11 x) + +instance ( ToAlias a + , ToAlias b + , ToAlias c + , ToAlias d + , ToAlias e + , ToAlias f + , ToAlias g + , ToAlias h + , ToAlias i + , ToAlias j + , ToAlias k + , ToAlias l + ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k,l) where + toAlias x = to12 <$> (toAlias $ from12 x) + +instance ( ToAlias a + , ToAlias b + , ToAlias c + , ToAlias d + , ToAlias e + , ToAlias f + , ToAlias g + , ToAlias h + , ToAlias i + , ToAlias j + , ToAlias k + , ToAlias l + , ToAlias m + ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k,l,m) where + toAlias x = to13 <$> (toAlias $ from13 x) + +instance ( ToAlias a + , ToAlias b + , ToAlias c + , ToAlias d + , ToAlias e + , ToAlias f + , ToAlias g + , ToAlias h + , ToAlias i + , ToAlias j + , ToAlias k + , ToAlias l + , ToAlias m + , ToAlias n + ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where + toAlias x = to14 <$> (toAlias $ from14 x) + +instance ( ToAlias a + , ToAlias b + , ToAlias c + , ToAlias d + , ToAlias e + , ToAlias f + , ToAlias g + , ToAlias h + , ToAlias i + , ToAlias j + , ToAlias k + , ToAlias l + , ToAlias m + , ToAlias n + , ToAlias o + ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where + toAlias x = to15 <$> (toAlias $ from15 x) + +instance ( ToAlias a + , ToAlias b + , ToAlias c + , ToAlias d + , ToAlias e + , ToAlias f + , ToAlias g + , ToAlias h + , ToAlias i + , ToAlias j + , ToAlias k + , ToAlias l + , ToAlias m + , ToAlias n + , ToAlias o + , ToAlias p + ) => ToAlias (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where + toAlias x = to16 <$> (toAlias $ from16 x) diff --git a/src/Database/Esqueleto/Experimental/ToAliasReference.hs b/src/Database/Esqueleto/Experimental/ToAliasReference.hs index 4d843ad86..9af0d2b83 100644 --- a/src/Database/Esqueleto/Experimental/ToAliasReference.hs +++ b/src/Database/Esqueleto/Experimental/ToAliasReference.hs @@ -1,11 +1,12 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Database.Esqueleto.Experimental.ToAliasReference where -import Data.Coerce import Database.Esqueleto.Internal.Internal hiding (From, from, on) import Database.Esqueleto.Internal.PersistentImport @@ -13,78 +14,206 @@ import Database.Esqueleto.Internal.PersistentImport type ToAliasReferenceT a = a -- more tedious tuple magic -class ToAliasReference a where - toAliasReference :: Ident -> a -> SqlQuery a +class ToAliasReference a a' | a -> a' where + toAliasReference :: Ident -> a -> SqlQuery a' -instance ToAliasReference (SqlExpr (Value a)) where +instance ToAliasReference (SqlExpr_ ctx (Value a)) (SqlExpr_ ValueContext (Value a)) where toAliasReference aliasSource (ERaw m _) | Just alias <- sqlExprMetaAlias m = pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info -> (useIdent info aliasSource <> "." <> useIdent info alias, []) - toAliasReference _ e = pure e + toAliasReference _ e = pure $ veryUnsafeCoerceSqlExpr e -instance ToAliasReference (SqlExpr (Entity a)) where +instance ToAliasReference (SqlExpr_ ctx (Entity a)) (SqlExpr_ ValueContext (Entity a)) where toAliasReference aliasSource (ERaw m _) | Just _ <- sqlExprMetaAlias m = pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info -> (useIdent info aliasSource, []) - toAliasReference _ e = pure e + toAliasReference _ e = pure $ veryUnsafeCoerceSqlExpr e -instance ToAliasReference (SqlExpr (Maybe (Entity a))) where +instance ToAliasReference (SqlExpr_ ctx (Maybe (Entity a))) (SqlExpr_ ValueContext (Maybe (Entity a))) where toAliasReference aliasSource e = - coerce <$> toAliasReference aliasSource (coerce e :: SqlExpr (Entity a)) + 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) -instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a, b) where - toAliasReference ident (a,b) = (,) <$> (toAliasReference ident a) <*> (toAliasReference ident b) +instance (ToAliasReference a a', ToAliasReference b b') => ToAliasReference (a, b) (a', b') where + toAliasReference ident (a,b) = (,) <$> toAliasReference ident a <*> toAliasReference ident b -instance ( ToAliasReference a - , ToAliasReference b - , ToAliasReference c - ) => ToAliasReference (a,b,c) where +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + ) => ToAliasReference (a,b,c) (a',b',c') where toAliasReference ident x = fmap to3 $ toAliasReference ident $ from3 x -instance ( ToAliasReference a - , ToAliasReference b - , ToAliasReference c - , ToAliasReference d - ) => ToAliasReference (a,b,c,d) where +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + ) => ToAliasReference (a,b,c,d) (a',b',c',d') where toAliasReference ident x = fmap to4 $ toAliasReference ident $ from4 x -instance ( ToAliasReference a - , ToAliasReference b - , ToAliasReference c - , ToAliasReference d - , ToAliasReference e - ) => ToAliasReference (a,b,c,d,e) where +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + ) => ToAliasReference (a,b,c,d,e) (a',b',c',d',e') where toAliasReference ident x = fmap to5 $ toAliasReference ident $ from5 x -instance ( ToAliasReference a - , ToAliasReference b - , ToAliasReference c - , ToAliasReference d - , ToAliasReference e - , ToAliasReference f - ) => ToAliasReference (a,b,c,d,e,f) where +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + ) => ToAliasReference (a,b,c,d,e,f) (a',b',c',d',e',f') where toAliasReference ident x = to6 <$> (toAliasReference ident $ from6 x) -instance ( ToAliasReference a - , ToAliasReference b - , ToAliasReference c - , ToAliasReference d - , ToAliasReference e - , ToAliasReference f - , ToAliasReference g - ) => ToAliasReference (a,b,c,d,e,f,g) where +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + ) => ToAliasReference (a,b,c,d,e,f,g) (a',b',c',d',e',f',g') where toAliasReference ident x = to7 <$> (toAliasReference ident $ from7 x) -instance ( ToAliasReference a - , ToAliasReference b - , ToAliasReference c - , ToAliasReference d - , ToAliasReference e - , ToAliasReference f - , ToAliasReference g - , ToAliasReference h - ) => ToAliasReference (a,b,c,d,e,f,g,h) where +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + ) => ToAliasReference (a,b,c,d,e,f,g,h) (a',b',c',d',e',f',g',h') where toAliasReference ident x = to8 <$> (toAliasReference ident $ from8 x) +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + , ToAliasReference i i' + ) => ToAliasReference (a,b,c,d,e,f,g,h,i) (a',b',c',d',e',f',g',h',i') where + toAliasReference ident x = to9 <$> (toAliasReference ident $ from9 x) + +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + , ToAliasReference i i' + , ToAliasReference j j' + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j) (a',b',c',d',e',f',g',h',i',j') where + toAliasReference ident x = to10 <$> (toAliasReference ident $ from10 x) + +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + , ToAliasReference i i' + , ToAliasReference j j' + , ToAliasReference k k' + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k) (a',b',c',d',e',f',g',h',i',j',k') where + toAliasReference ident x = to11 <$> (toAliasReference ident $ from11 x) + +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + , ToAliasReference i i' + , ToAliasReference j j' + , ToAliasReference k k' + , ToAliasReference l l' + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l) (a',b',c',d',e',f',g',h',i',j',k',l') where + toAliasReference ident x = to12 <$> (toAliasReference ident $ from12 x) + +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + , ToAliasReference i i' + , ToAliasReference j j' + , ToAliasReference k k' + , ToAliasReference l l' + , ToAliasReference m m' + ) => ToAliasReference (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') where + toAliasReference ident x = to13 <$> (toAliasReference ident $ from13 x) + +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + , ToAliasReference i i' + , ToAliasReference j j' + , ToAliasReference k k' + , ToAliasReference l l' + , ToAliasReference m m' + , ToAliasReference n n' + ) => ToAliasReference (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') where + toAliasReference ident x = to14 <$> (toAliasReference ident $ from14 x) + +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + , ToAliasReference i i' + , ToAliasReference j j' + , ToAliasReference k k' + , ToAliasReference l l' + , ToAliasReference m m' + , ToAliasReference n n' + , ToAliasReference o o' + ) => ToAliasReference (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') where + toAliasReference ident x = to15 <$> (toAliasReference ident $ from15 x) + +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + , ToAliasReference i i' + , ToAliasReference j j' + , ToAliasReference k k' + , ToAliasReference l l' + , ToAliasReference m m' + , ToAliasReference n n' + , ToAliasReference o o' + , ToAliasReference p p' + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) (a',b',c',d',e',f',g',h',i',j',k',l',m',n',o',p') where + toAliasReference ident x = to16 <$> (toAliasReference ident $ from16 x) diff --git a/src/Database/Esqueleto/Experimental/ToMaybe.hs b/src/Database/Esqueleto/Experimental/ToMaybe.hs index 0677bfb9c..641a6e83b 100644 --- a/src/Database/Esqueleto/Experimental/ToMaybe.hs +++ b/src/Database/Esqueleto/Experimental/ToMaybe.hs @@ -15,16 +15,16 @@ class ToMaybe a where type ToMaybeT a toMaybe :: a -> ToMaybeT a -instance ToMaybe (SqlExpr (Maybe a)) where - type ToMaybeT (SqlExpr (Maybe a)) = SqlExpr (Maybe a) +instance ToMaybe (SqlExpr_ ctx (Maybe a)) where + type ToMaybeT (SqlExpr_ ctx (Maybe a)) = SqlExpr_ ctx (Maybe a) toMaybe = id -instance ToMaybe (SqlExpr (Entity a)) where - type ToMaybeT (SqlExpr (Entity a)) = SqlExpr (Maybe (Entity a)) - toMaybe (ERaw f m) = (ERaw f m) +instance ToMaybe (SqlExpr_ ctx (Entity a)) where + type ToMaybeT (SqlExpr_ ctx (Entity a)) = SqlExpr_ ctx (Maybe (Entity a)) + toMaybe (ERaw f m) = ERaw f m -instance ToMaybe (SqlExpr (Value a)) where - type ToMaybeT (SqlExpr (Value a)) = SqlExpr (Value (Maybe (Nullable a))) +instance ToMaybe (SqlExpr_ ctx (Value a)) where + type ToMaybeT (SqlExpr_ ctx (Value a)) = SqlExpr_ ctx (Value (Maybe (Nullable a))) toMaybe = veryUnsafeCoerceSqlExprValue diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 2690ea15b..4e18636a1 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} @@ -60,7 +61,6 @@ import qualified Data.HashSet as HS import Data.Kind (Type) import qualified Data.List as List import qualified Data.Map.Strict as Map -import qualified Data.Monoid as Monoid import Data.Proxy (Proxy(..)) import Data.Set (Set) import qualified Data.Set as Set @@ -121,9 +121,9 @@ fromStartMaybe fromStartMaybe = maybelize <$> fromStart where maybelize - :: PreprocessedFrom (SqlExpr (Entity a)) - -> PreprocessedFrom (SqlExpr (Maybe (Entity a))) - maybelize (PreprocessedFrom e f') = PreprocessedFrom (coerce e) f' + :: PreprocessedFrom (SqlExpr_ ctx (Entity a)) + -> PreprocessedFrom (SqlExpr_ ctx (Maybe (Entity a))) + maybelize (PreprocessedFrom e f') = PreprocessedFrom (veryUnsafeCoerceSqlExpr e) f' -- | (Internal) Do a @JOIN@. fromJoin @@ -261,6 +261,13 @@ on expr = Q $ W.tell mempty { sdFromClause = [OnClause expr] } groupBy :: (ToSomeValues a) => a -> SqlQuery () groupBy expr = Q $ W.tell mempty { sdGroupByClause = GroupBy $ toSomeValues expr } +-- | An alias for 'groupBy' that avoids conflict with the term from "Data.List" +-- 'Data.List.groupBy'. +-- +-- @since 3.5.10.0 +groupBy_ :: (ToSomeValues a) => a -> SqlQuery () +groupBy_ = groupBy + -- | @ORDER BY@ clause. See also 'asc' and 'desc'. -- -- Multiple calls to 'orderBy' get concatenated on the final @@ -269,14 +276,14 @@ orderBy :: [SqlExpr OrderBy] -> SqlQuery () orderBy exprs = Q $ W.tell mempty { sdOrderByClause = exprs } -- | Ascending order of this field or SqlExpression. -asc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy +asc :: PersistField a => SqlExpr_ ctx (Value a) -> SqlExpr OrderBy asc = orderByExpr " ASC" -- | Descending order of this field or SqlExpression. -desc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy +desc :: PersistField a => SqlExpr_ ctx (Value a) -> SqlExpr OrderBy desc = orderByExpr " DESC" -orderByExpr :: TLB.Builder -> SqlExpr (Value a) -> SqlExpr OrderBy +orderByExpr :: TLB.Builder -> SqlExpr_ ctx (Value a) -> SqlExpr OrderBy orderByExpr orderByType (ERaw m f) | Just fields <- sqlExprMetaCompositeFields m = ERaw noMeta $ \_ info -> @@ -357,7 +364,7 @@ distinctOn exprs act = Q (W.tell mempty { sdDistinctClause = DistinctOn exprs }) -- -- @since 2.2.4 don :: SqlExpr (Value a) -> SqlExpr DistinctOn -don = coerce +don = veryUnsafeCoerceSqlExpr -- | A convenience function that calls both 'distinctOn' and -- 'orderBy'. In other words, @@ -400,8 +407,8 @@ rand = ERaw noMeta $ \_ _ -> ("RANDOM()", []) -- | @HAVING@. -- -- @since 1.2.2 -having :: SqlExpr (Value Bool) -> SqlQuery () -having expr = Q $ W.tell mempty { sdHavingClause = Where expr } +having :: SqlExpr_ ctx (Value Bool) -> SqlQuery () +having expr = Q $ W.tell mempty { sdHavingClause = Where $ veryUnsafeCoerceSqlExpr expr } -- | Add a locking clause to the query. Please read -- 'LockingKind' documentation and your RDBMS manual. @@ -440,7 +447,7 @@ SQL error.\n\n Instead, consider using one of the following alternatives: \n \ -- is guaranteed to return just one row. -- -- Deprecated in 3.2.0. -sub_select :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) +sub_select :: 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 @@ -461,7 +468,7 @@ sub_select = sub SELECT -- @since 3.2.0 subSelect :: PersistField a - => SqlQuery (SqlExpr (Value a)) + => SqlQuery (SqlExpr_ ctx (Value a)) -> SqlExpr (Value (Maybe a)) subSelect query = just (subSelectUnsafe (query <* limit 1)) @@ -475,7 +482,7 @@ subSelect query = just (subSelectUnsafe (query <* limit 1)) -- @since 3.2.0 subSelectMaybe :: PersistField a - => SqlQuery (SqlExpr (Value (Maybe a))) + => SqlQuery (SqlExpr_ ctx (Value (Maybe a))) -> SqlExpr (Value (Maybe a)) subSelectMaybe = joinV . subSelect @@ -499,7 +506,7 @@ subSelectCount query = -- @since 3.2.0 subSelectList :: PersistField a - => SqlQuery (SqlExpr (Value a)) + => SqlQuery (SqlExpr_ ctx (Value a)) -> SqlExpr (ValueList a) subSelectList = subList_select @@ -560,15 +567,21 @@ subSelectForeign expr foreignKey k = -- 'subSelectMaybe'. For the most common safe use of this, see 'subSelectCount'. -- -- @since 3.2.0 -subSelectUnsafe :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) +subSelectUnsafe :: PersistField a => SqlQuery (SqlExpr_ ctx (Value a)) -> SqlExpr (Value a) subSelectUnsafe = sub SELECT -- | Project a field of an entity. -(^.) :: forall typ val . (PersistEntity val, PersistField typ) - => SqlExpr (Entity val) - -> EntityField val typ - -> SqlExpr (Value typ) -ERaw m f ^. field +(^.) :: forall typ val. (PersistEntity val, PersistField typ) + => SqlExpr (Entity val) + -> EntityField val typ + -> SqlExpr (Value typ) +(^.) = getSqlField + +getSqlField :: forall typ val ctx. (PersistEntity val, PersistField typ) + => SqlExpr_ ctx (Entity val) + -> EntityField val typ + -> SqlExpr_ ctx (Value typ) +getSqlField (ERaw m f) field | isIdField field = idFieldValue | Just alias <- sqlExprMetaAlias m = ERaw noMeta $ \_ info -> @@ -591,12 +604,12 @@ ERaw m f ^. field in ERaw noMeta{ sqlExprMetaCompositeFields = Just renderedFields} $ \p info -> (parensM p $ uncommas $ renderedFields info, []) - ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) + ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr_ ctx (Entity val))) dot info fieldDef' = sourceIdent info <> "." <> fieldIdent where - sourceIdent = fmap fst $ f Never + sourceIdent = fst <$> f Never fieldIdent | Just baseI <- sqlExprMetaAlias m = useIdent info $ aliasedEntityColumnIdent baseI fieldDef' @@ -615,13 +628,13 @@ withNonNull field f = do -- | 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)) + => SqlExpr (Maybe (Entity val)) + -> EntityField val typ + -> SqlExpr (Value (Maybe typ)) ERaw m f ?. field = just (ERaw m f ^. field) -- | Lift a constant value from Haskell-land to the query. -val :: PersistField typ => typ -> SqlExpr (Value typ) +val :: forall typ ctx. PersistField typ => typ -> SqlExpr_ ctx (Value typ) val v = ERaw noMeta $ \_ _ -> ("?", [toPersistValue v]) -- | @IS NULL@ comparison. @@ -645,7 +658,7 @@ val v = ERaw noMeta $ \_ _ -> ("?", [toPersistValue v]) -- > - error: {lhs: v Database.Esqueleto.==. Database.Esqueleto.val Nothing, rhs: Database.Esqueleto.isNothing v, name: Use Esqueleto's isNothing} -- > - error: {lhs: v Database.Esqueleto.!=. Database.Esqueleto.nothing, rhs: not_ (Database.Esqueleto.isNothing v), name: Use Esqueleto's not isNothing} -- > - error: {lhs: v Database.Esqueleto.!=. Database.Esqueleto.val Nothing, rhs: not_ (Database.Esqueleto.isNothing v), name: Use Esqueleto's not isNothing} -isNothing :: PersistField typ => SqlExpr (Value (Maybe typ)) -> SqlExpr (Value Bool) +isNothing :: PersistField typ => SqlExpr_ ctx (Value (Maybe typ)) -> SqlExpr_ ctx (Value Bool) isNothing v = case v of ERaw m f -> @@ -658,12 +671,19 @@ isNothing v = first (parensM p) . isNullExpr $ f Never info where isNullExpr :: (TLB.Builder, a) -> (TLB.Builder, a) - isNullExpr = first ((<> " IS NULL")) + isNullExpr = first (<> " IS NULL") + +-- | An alias for 'isNothing' that avoids clashing with the function from +-- "Data.Maybe" 'Data.Maybe.isNothing'. +-- +-- @since 3.5.10.0 +isNothing_ :: PersistField typ => SqlExpr (Value (Maybe typ)) -> SqlExpr (Value Bool) +isNothing_ = isNothing -- | Analogous to 'Just', promotes a value of type @typ@ into -- one of type @Maybe typ@. It should hold that @'val' . Just -- === just . 'val'@. -just :: SqlExpr (Value typ) -> SqlExpr (Value (Maybe typ)) +just :: SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value (Maybe typ)) just = veryUnsafeCoerceSqlExprValue -- | @NULL@ value. @@ -672,11 +692,10 @@ nothing = unsafeSqlValue "NULL" -- | Join nested 'Maybe's in a 'Value' into one. This is useful when -- calling aggregate functions on nullable fields. -joinV :: SqlExpr (Value (Maybe (Maybe typ))) -> SqlExpr (Value (Maybe typ)) +joinV :: SqlExpr_ ctx (Value (Maybe (Maybe typ))) -> SqlExpr_ ctx (Value (Maybe typ)) joinV = veryUnsafeCoerceSqlExprValue - -countHelper :: Num a => TLB.Builder -> TLB.Builder -> SqlExpr (Value typ) -> SqlExpr (Value a) +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 -> @@ -685,24 +704,24 @@ countHelper open close v = else countRawSql (f Never) where - countRawSql :: (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) + countRawSql :: (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr_ ctx (Value a) countRawSql x = ERaw noMeta $ \_ -> first (\b -> "COUNT" <> open <> parens b <> close) . x -- | @COUNT(*)@ value. -countRows :: Num a => SqlExpr (Value a) +countRows :: Num a => SqlExpr_ ctx (Value a) countRows = unsafeSqlValue "COUNT(*)" -- | @COUNT@. -count :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a) +count :: Num a => SqlExpr (Value typ) -> SqlExpr_ ctx (Value a) count = countHelper "" "" -- | @COUNT(DISTINCT x)@. -- -- @since 2.4.1 -countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a) +countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr_ ctx (Value a) countDistinct = countHelper "(DISTINCT " ")" -not_ :: SqlExpr (Value Bool) -> SqlExpr (Value Bool) +not_ :: SqlExpr_ ctx (Value Bool) -> SqlExpr_ ctx (Value Bool) not_ v = ERaw noMeta $ \p info -> first ("NOT " <>) $ x p info where x p info = @@ -714,66 +733,106 @@ not_ v = ERaw noMeta $ \p info -> first ("NOT " <>) $ x p info let (b, vals) = f Never info in (parensM p b, vals) -(==.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) +(==.) :: (PersistField a) + => SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value Bool) (==.) = unsafeSqlBinOpComposite " = " " AND " -(>=.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) +(>=.) :: PersistField a + => SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value Bool) (>=.) = unsafeSqlBinOp " >= " -(>.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) +(>.) :: PersistField a + => SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value Bool) (>.) = unsafeSqlBinOp " > " -(<=.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) +(<=.) :: PersistField a + => SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value Bool) (<=.) = unsafeSqlBinOp " <= " -(<.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) -(<.) = unsafeSqlBinOp " < " -(!=.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) +(<.) :: PersistField a + => SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value Bool) +(<.) = unsafeSqlBinOp " < " + +(!=.) :: PersistField a + => SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value Bool) (!=.) = unsafeSqlBinOpComposite " != " " OR " -(&&.) :: SqlExpr (Value Bool) -> SqlExpr (Value Bool) -> SqlExpr (Value Bool) +(&&.) :: PersistField a + => SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value Bool) (&&.) = unsafeSqlBinOp " AND " -(||.) :: SqlExpr (Value Bool) -> SqlExpr (Value Bool) -> SqlExpr (Value Bool) +(||.) :: PersistField a + => SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value Bool) (||.) = unsafeSqlBinOp " OR " -(+.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a) +(+.) :: PersistField a + => SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) (+.) = unsafeSqlBinOp " + " -(-.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a) +(-.) :: PersistField a + => SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) (-.) = unsafeSqlBinOp " - " -(/.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a) +(/.) :: PersistField a + => SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) (/.) = unsafeSqlBinOp " / " -(*.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a) +(*.) :: PersistField a + => SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) (*.) = unsafeSqlBinOp " * " -- | @BETWEEN@. -- -- @since: 3.1.0 -between :: PersistField a => SqlExpr (Value a) -> (SqlExpr (Value a), SqlExpr (Value a)) -> SqlExpr (Value Bool) +between :: PersistField a + => SqlExpr_ ctx (Value a) + -> (SqlExpr_ ctx (Value a), SqlExpr_ ctx (Value 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 (Value a) -> SqlExpr (Value b) +round_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value b) round_ = unsafeSqlFunction "ROUND" -ceiling_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr (Value a) -> SqlExpr (Value b) +ceiling_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value b) ceiling_ = unsafeSqlFunction "CEILING" -floor_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr (Value a) -> SqlExpr (Value b) +floor_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value b) floor_ = unsafeSqlFunction "FLOOR" -sum_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr (Value (Maybe b)) +sum_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr_ ctx (Value (Maybe b)) sum_ = unsafeSqlFunction "SUM" -min_ :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe a)) +min_ :: (PersistField a) => SqlExpr (Value a) -> SqlExpr_ ctx (Value (Maybe a)) min_ = unsafeSqlFunction "MIN" -max_ :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe a)) +max_ :: (PersistField a) => SqlExpr (Value a) -> SqlExpr_ ctx (Value (Maybe a)) max_ = unsafeSqlFunction "MAX" -avg_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr (Value (Maybe b)) +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 @@ -793,13 +852,13 @@ avg_ = unsafeSqlFunction "AVG" -- not being able to parse it. -- -- @since 2.2.9 -castNum :: (Num a, Num b) => SqlExpr (Value a) -> SqlExpr (Value b) +castNum :: (Num a, Num b) => SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value b) castNum = veryUnsafeCoerceSqlExprValue -- | Same as 'castNum', but for nullable values. -- -- @since 2.2.9 -castNumM :: (Num a, Num b) => SqlExpr (Value (Maybe a)) -> SqlExpr (Value (Maybe b)) +castNumM :: (Num a, Num b) => SqlExpr_ ctx (Value (Maybe a)) -> SqlExpr_ ctx (Value (Maybe b)) castNumM = veryUnsafeCoerceSqlExprValue -- | @COALESCE@ function. Evaluates the arguments in order and @@ -809,67 +868,73 @@ castNumM = veryUnsafeCoerceSqlExprValue -- documentation. -- -- @since 1.4.3 -coalesce :: PersistField a => [SqlExpr (Value (Maybe a))] -> SqlExpr (Value (Maybe a)) -coalesce = unsafeSqlFunctionParens "COALESCE" +coalesce :: PersistField 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 -- a non-NULL result. -- -- @since 1.4.3 -coalesceDefault :: PersistField a => [SqlExpr (Value (Maybe a))] -> SqlExpr (Value a) -> SqlExpr (Value a) +coalesceDefault :: PersistField a => [SqlExpr_ ctx (Value (Maybe a))] -> SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value a) coalesceDefault exprs = unsafeSqlFunctionParens "COALESCE" . (exprs ++) . return . just -- | @LOWER@ function. -lower_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) +lower_ :: SqlString s => SqlExpr_ ctx (Value s) -> SqlExpr_ ctx (Value s) lower_ = unsafeSqlFunction "LOWER" -- | @UPPER@ function. -- @since 3.3.0 -upper_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) +upper_ :: SqlString s => SqlExpr_ ctx (Value s) -> SqlExpr_ ctx (Value s) upper_ = unsafeSqlFunction "UPPER" -- | @TRIM@ function. -- @since 3.3.0 -trim_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) +trim_ :: SqlString s => SqlExpr_ ctx (Value s) -> SqlExpr_ ctx (Value s) trim_ = unsafeSqlFunction "TRIM" -- | @RTRIM@ function. -- @since 3.3.0 -rtrim_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) +rtrim_ :: SqlString s => SqlExpr_ ctx (Value s) -> SqlExpr_ ctx (Value s) rtrim_ = unsafeSqlFunction "RTRIM" -- | @LTRIM@ function. -- @since 3.3.0 -ltrim_ :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) +ltrim_ :: SqlString s => SqlExpr_ ctx (Value s) -> SqlExpr_ ctx (Value s) ltrim_ = unsafeSqlFunction "LTRIM" -- | @LENGTH@ function. -- @since 3.3.0 -length_ :: (SqlString s, Num a) => SqlExpr (Value s) -> SqlExpr (Value a) +length_ :: (SqlString s, Num a) => SqlExpr_ ctx (Value s) -> SqlExpr_ ctx (Value a) length_ = unsafeSqlFunction "LENGTH" -- | @LEFT@ function. -- @since 3.3.0 -left_ :: (SqlString s, Num a) => (SqlExpr (Value s), SqlExpr (Value a)) -> SqlExpr (Value s) +left_ :: (SqlString s, Num a) => (SqlExpr_ ctx (Value s), SqlExpr_ ctx (Value a)) -> SqlExpr_ ctx (Value s) left_ = unsafeSqlFunction "LEFT" -- | @RIGHT@ function. -- @since 3.3.0 -right_ :: (SqlString s, Num a) => (SqlExpr (Value s), SqlExpr (Value a)) -> SqlExpr (Value s) +right_ :: (SqlString s, Num a) => (SqlExpr_ ctx (Value s), SqlExpr_ ctx (Value a)) -> SqlExpr_ ctx (Value s) right_ = unsafeSqlFunction "RIGHT" -- | @LIKE@ operator. -like :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value Bool) -like = unsafeSqlBinOp " LIKE " +like :: SqlString s + => SqlExpr_ ctx (Value s) + -> SqlExpr_ ctx (Value s) + -> SqlExpr_ ctx (Value Bool) +like = unsafeSqlBinOp " LIKE " -- | @ILIKE@ operator (case-insensitive @LIKE@). -- -- Supported by PostgreSQL only. -- -- @since 2.2.3 -ilike :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value Bool) -ilike = unsafeSqlBinOp " ILIKE " +ilike :: SqlString s + => SqlExpr_ ctx (Value s) + -> SqlExpr_ ctx (Value s) + -> SqlExpr_ ctx (Value Bool) +ilike = unsafeSqlBinOp " ILIKE " -- | The string @'%'@. May be useful while using 'like' and -- concatenation ('concat_' or '++.', depending on your @@ -879,19 +944,22 @@ ilike = unsafeSqlBinOp " ILIKE " -- @ -- name `'like`` (%) ++. 'val' \"John\" ++. (%) -- @ -(%) :: SqlString s => SqlExpr (Value s) -(%) = unsafeSqlValue "'%'" +(%) :: SqlString s => SqlExpr_ ctx (Value s) +(%) = unsafeSqlValue "'%'" -- | The @CONCAT@ function with a variable number of -- parameters. Supported by MySQL and PostgreSQL. -concat_ :: SqlString s => [SqlExpr (Value s)] -> SqlExpr (Value s) +concat_ :: 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. -(++.) :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value s) -(++.) = unsafeSqlBinOp " || " +(++.) :: SqlString s + => SqlExpr_ ctx (Value s) + -> SqlExpr_ ctx (Value s) + -> SqlExpr_ ctx (Value s) +(++.) = unsafeSqlBinOp " || " -- | Cast a string type into 'Text'. This function -- is very useful if you want to use @newtype@s, or if you want @@ -903,17 +971,17 @@ concat_ = unsafeSqlFunction "CONCAT" -- since 'Maybe' is an instance of 'SqlString', it's possible -- to turn a nullable value into a non-nullable one. Avoid -- using this function if possible. -castString :: (SqlString s, SqlString r) => SqlExpr (Value s) -> SqlExpr (Value r) +castString :: (SqlString s, SqlString r) => SqlExpr_ ctx (Value s) -> SqlExpr_ ctx (Value r) castString = veryUnsafeCoerceSqlExprValue -- | Execute a subquery @SELECT@ in an SqlExpression. Returns a -- list of values. -subList_select :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (ValueList a) +subList_select :: PersistField a => SqlQuery (SqlExpr_ ctx (Value a)) -> SqlExpr (ValueList a) subList_select query = ERaw noMeta $ \_ info -> first parens $ toRawSql SELECT info query -- | Lift a list of constant value from Haskell-land to the query. -valList :: PersistField typ => [typ] -> SqlExpr (ValueList typ) +valList :: PersistField typ => [typ] -> SqlExpr_ ctx (ValueList typ) valList [] = ERaw noMeta $ \_ _ -> ("()", []) valList vals = ERaw noMeta $ \p -> const (parensM p (uncommas ("?" <$ vals)), map toPersistValue vals ) @@ -922,7 +990,7 @@ valList vals = ERaw noMeta $ \p -> const (parensM p (uncommas ("?" <$ vals)), ma -- inside 'subList_select' or 'Just' from inside 'valList'. -- -- @since 2.2.12 -justList :: SqlExpr (ValueList typ) -> SqlExpr (ValueList (Maybe typ)) +justList :: SqlExpr_ ctx (ValueList typ) -> SqlExpr_ ctx (ValueList (Maybe typ)) justList (ERaw m f) = ERaw m f -- | @IN@ operator. For example if you want to select all @Person@s by a list @@ -944,7 +1012,7 @@ justList (ERaw m f) = ERaw m f -- @ -- -- Where @personIds@ is of type @[Key Person]@. -in_ :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (ValueList typ) -> SqlExpr (Value Bool) +in_ :: PersistField typ => SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (ValueList typ) -> SqlExpr_ ctx (Value Bool) (ERaw _ v) `in_` (ERaw _ list) = ERaw noMeta $ \_ info -> let (b1, vals1) = v Parens info @@ -956,7 +1024,7 @@ in_ :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (ValueList typ) -> Sql (b1 <> " IN " <> b2, vals1 <> vals2) -- | @NOT IN@ operator. -notIn :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (ValueList typ) -> SqlExpr (Value Bool) +notIn :: PersistField typ => SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (ValueList typ) -> SqlExpr_ ctx (Value Bool) (ERaw _ v) `notIn` (ERaw _ list) = ERaw noMeta $ \_ info -> let (b1, vals1) = v Parens info @@ -1066,7 +1134,7 @@ field /=. expr = setAux field (\ent -> ent ^. field /. expr) -- reproduce this via 'nothing'. -- -- @since 2.1.2 -case_ :: PersistField a => [(SqlExpr (Value Bool), SqlExpr (Value a))] -> SqlExpr (Value a) -> SqlExpr (Value a) +case_ :: forall a ctx. PersistField a => [(SqlExpr_ ctx (Value Bool), SqlExpr_ ctx (Value a))] -> SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value a) case_ = unsafeSqlCase -- | Convert an entity's key into another entity's. @@ -1518,13 +1586,13 @@ makeLockableEntity info lockableEntity = uncommas' $ Set.toList . Set.fromList $ (\(LockableSqlExpr (ERaw _ f)) -> f Never info) <$> NEL.toList (flattenLockableEntity lockableEntity) instance PersistEntity val => LockableEntity (SqlExpr (Entity val)) where - flattenLockableEntity e = LockableSqlExpr e :| [] + flattenLockableEntity e = pure $ LockableSqlExpr e instance (LockableEntity a, LockableEntity b) => LockableEntity (a :& b) where flattenLockableEntity (a :& b) = flattenLockableEntity a <> flattenLockableEntity b data LockableSqlExpr where - LockableSqlExpr :: PersistEntity val => (SqlExpr (Entity val)) -> LockableSqlExpr + LockableSqlExpr :: SqlExpr e -> LockableSqlExpr -- | Phantom class of data types that are treated as strings by the -- RDBMS. It has no methods because it's only used to avoid type @@ -1644,45 +1712,46 @@ from = (from_ >>=) class From a where from_ :: SqlQuery a -instance - ( FromPreprocess (SqlExpr (Entity val)) - ) +instance ( FromPreprocess (SqlExpr (Entity val)) ) => From (SqlExpr (Entity val)) where from_ = fromPreprocess >>= fromFinish -instance - ( FromPreprocess (SqlExpr (Maybe (Entity val))) - ) +instance ( FromPreprocess (SqlExpr (Maybe (Entity val)) )) => From (SqlExpr (Maybe (Entity val))) where from_ = fromPreprocess >>= fromFinish -instance - ( FromPreprocess (InnerJoin a b) - ) +instance (FromPreprocess (InnerJoin a b)) => From (InnerJoin a b) where from_ = fromPreprocess >>= fromFinish -instance - ( FromPreprocess (CrossJoin a b) - ) +instance (FromPreprocess (LeftOuterJoin a b)) => - From (CrossJoin a b) + From (LeftOuterJoin a b) where from_ = fromPreprocess >>= fromFinish -instance (FromPreprocess (LeftOuterJoin a b)) => From (LeftOuterJoin a b) where +instance (FromPreprocess (CrossJoin a b)) + => + From ( (CrossJoin a b)) + where from_ = fromPreprocess >>= fromFinish -instance (FromPreprocess (RightOuterJoin a b)) => From (RightOuterJoin a b) where +instance (FromPreprocess (RightOuterJoin a b)) + => + From (RightOuterJoin a b) + where from_ = fromPreprocess >>= fromFinish -instance (FromPreprocess (FullOuterJoin a b)) => From (FullOuterJoin a b) where +instance (FromPreprocess (FullOuterJoin a b)) + => + From (FullOuterJoin a b) + where from_ = fromPreprocess >>= fromFinish instance (From a, From b) => From (a, b) where @@ -1741,15 +1810,23 @@ instance where fromPreprocess = fromStartMaybe -instance - (FromPreprocess a, FromPreprocess b, IsJoinKind join) - => - FromPreprocess (join a b) - where - fromPreprocess = do - a <- fromPreprocess - b <- fromPreprocess - fromJoin a b +fromPreprocessJoin :: (IsJoinKind join, FromPreprocess a, FromPreprocess b) + => SqlQuery (PreprocessedFrom (join a b)) +fromPreprocessJoin = do + a <- fromPreprocess + b <- fromPreprocess + fromJoin a b + +instance (FromPreprocess a, FromPreprocess b) => FromPreprocess (InnerJoin a b) where + fromPreprocess = fromPreprocessJoin +instance (FromPreprocess a, FromPreprocess b) => FromPreprocess (CrossJoin a b) where + fromPreprocess = fromPreprocessJoin +instance (FromPreprocess a, FromPreprocess b) => FromPreprocess (LeftOuterJoin a b) where + fromPreprocess = fromPreprocessJoin +instance (FromPreprocess a, FromPreprocess b) => FromPreprocess (RightOuterJoin a b) where + fromPreprocess = fromPreprocessJoin +instance (FromPreprocess a, FromPreprocess b) => FromPreprocess (FullOuterJoin a b) where + fromPreprocess = fromPreprocessJoin -- | Exception data type for @esqueleto@ internal errors data EsqueletoError @@ -2202,12 +2279,12 @@ hasCompositeKeyMeta = Maybe.isJust . sqlExprMetaCompositeFields entityAsValue :: SqlExpr (Entity val) -> SqlExpr (Value (Entity val)) -entityAsValue = coerce +entityAsValue = veryUnsafeCoerceSqlExpr entityAsValueMaybe :: SqlExpr (Maybe (Entity val)) -> SqlExpr (Value (Maybe (Entity val))) -entityAsValueMaybe = coerce +entityAsValueMaybe = veryUnsafeCoerceSqlExpr -- | An expression on the SQL backend. -- @@ -2217,7 +2294,27 @@ entityAsValueMaybe = coerce -- connection (mainly for escaping names) and returns both an -- string ('TLB.Builder') and a list of values to be -- interpolated by the SQL backend. -data SqlExpr a = ERaw SqlExprMeta (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])) +-- +-- All expressions have a context associated with them. This is primarily used by window functions +-- to prevent windowing an already windowed value at compile time. +-- +-- Values that come from a from clause are considered to be in the "ValueContext". +-- Values that come from an aggregation should be in the "AggregateContext" but for backwards compatibility they are treated as having an undefined context and can be used in both Value and Aggregate contexts. +-- Values that come from a window function are in the "WindowContext" +data SqlExpr_ ctx a = ERaw SqlExprMeta (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])) + +-- Without this, you can `coerce` at will. This is a pretty gnarly and bad +-- thing. +type role SqlExpr_ nominal nominal + +data ValueContext +data AggregateContext + +-- | Helper type for backwards compatibility and ease of reading +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 -- | Folks often want the ability to promote a Haskell function into the -- 'SqlExpr' expression language - and naturally reach for 'fmap'. @@ -2245,7 +2342,7 @@ data SqlExpr a = ERaw SqlExprMeta (NeedParens -> IdentInfo -> (TLB.Builder, [Per -- it with 'unsafeSqlFunction' or 'unsafeSqlBinOp'. -- -- @since 3.5.8.2 -instance TypeError SqlExprFunctorMessage => Functor SqlExpr where +instance TypeError SqlExprFunctorMessage => Functor (SqlExpr_ ctx) where fmap = error "impossible" -- | The type error message given when you try to do 'fmap' on a 'SqlExpr'. This @@ -2374,8 +2471,9 @@ setAux field value = \ent -> ERaw noMeta $ \_ info -> (valueToSet, valueVals) = valueF Parens info in (fieldName info field <> " = " <> valueToSet, valueVals) -sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) -sub mode query = ERaw noMeta $ \_ info -> first parens $ toRawSql mode info query +sub :: forall a ctx. PersistField a => Mode -> SqlQuery (SqlExpr_ ctx (Value a)) -> SqlExpr (Value a) +sub mode query = ERaw noMeta $ \_ info -> + first parens $ toRawSql mode info (fmap veryUnsafeCoerceSqlExpr query :: SqlQuery (SqlExpr (Value a))) fromDBName :: IdentInfo -> DBName -> TLB.Builder fromDBName (conn, _) = TLB.fromText . flip getEscapedRawName conn . unDBName @@ -2389,7 +2487,7 @@ existsHelper = sub SELECT . (>> return true) -- | (Internal) Create a case statement. -- -- Since: 2.1.1 -unsafeSqlCase :: PersistField a => [(SqlExpr (Value Bool), SqlExpr (Value a))] -> SqlExpr (Value a) -> SqlExpr (Value a) +unsafeSqlCase :: forall a ctx. PersistField a => [(SqlExpr_ ctx (Value Bool), SqlExpr_ ctx (Value a))] -> SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value a) unsafeSqlCase when v = ERaw noMeta buildCase where buildCase :: NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) @@ -2398,18 +2496,18 @@ unsafeSqlCase when v = ERaw noMeta buildCase (whenText, whenVals) = mapWhen when Parens info in ( "CASE" <> whenText <> " ELSE " <> elseText <> " END", whenVals <> elseVals) - mapWhen :: [(SqlExpr (Value Bool), SqlExpr (Value a))] -> NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) + mapWhen :: [(SqlExpr_ ctx (Value Bool), SqlExpr_ ctx (Value a))] -> NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) mapWhen [] _ _ = throw (UnexpectedCaseErr UnsafeSqlCaseError) mapWhen when' p info = foldl (foldHelp p info) (mempty, mempty) when' - foldHelp :: NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr (Value Bool), SqlExpr (Value a)) -> (TLB.Builder, [PersistValue]) + foldHelp :: NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr_ ctx (Value Bool), SqlExpr_ ctx (Value a)) -> (TLB.Builder, [PersistValue]) foldHelp p info (b0, vals0) (v1, v2) = let (b1, vals1) = valueToSql v1 p info (b2, vals2) = valueToSql v2 p info in ( b0 <> " WHEN " <> b1 <> " THEN " <> b2, vals0 <> vals1 <> vals2 ) - valueToSql :: SqlExpr (Value a) -> NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) + valueToSql :: forall v. SqlExpr_ ctx (Value v) -> NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) valueToSql (ERaw _ f) p = f p -- | (Internal) Create a custom binary operator. You /should/ @@ -2424,7 +2522,7 @@ unsafeSqlCase when v = ERaw noMeta buildCase -- -- In the example above, we constraint the arguments to be of the -- same type and constraint the result to be a boolean value. -unsafeSqlBinOp :: TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c) +unsafeSqlBinOp :: TLB.Builder -> SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value b) -> SqlExpr_ ctx (Value c) unsafeSqlBinOp op (ERaw m1 f1) (ERaw m2 f2) | not (hasCompositeKeyMeta m1 || hasCompositeKeyMeta m2) = ERaw noMeta f where @@ -2437,7 +2535,7 @@ unsafeSqlBinOp op (ERaw m1 f1) (ERaw m2 f2) ) unsafeSqlBinOp op a b = unsafeSqlBinOp op (construct a) (construct b) where - construct :: SqlExpr (Value a) -> SqlExpr (Value a) + construct :: SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value a) construct (ERaw m f) = case sqlExprMetaCompositeFields m of Just fields -> @@ -2475,15 +2573,15 @@ unsafeSqlBinOp op a b = unsafeSqlBinOp op (construct a) (construct b) -- - If it is not a single placeholder, then it's assumed to be -- a foreign (composite or not) key, so we enforce that it has -- no placeholders and split it on the commas. -unsafeSqlBinOpComposite :: TLB.Builder -> TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c) +unsafeSqlBinOpComposite :: TLB.Builder -> TLB.Builder -> SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value b) -> SqlExpr_ ctx (Value c) unsafeSqlBinOpComposite op sep a b | isCompositeKey a || isCompositeKey b = ERaw noMeta $ const $ compose (listify a) (listify b) | otherwise = unsafeSqlBinOp op a b where - isCompositeKey :: SqlExpr (Value x) -> Bool + isCompositeKey :: SqlExpr_ ctx (Value x) -> Bool isCompositeKey (ERaw m _) = hasCompositeKeyMeta m - listify :: SqlExpr (Value x) -> IdentInfo -> ([TLB.Builder], [PersistValue]) + listify :: SqlExpr_ ctx (Value x) -> IdentInfo -> ([TLB.Builder], [PersistValue]) listify (ERaw m f) | Just k <- sqlExprMetaCompositeFields m = flip (,) [] . k | otherwise = deconstruct . f Parens @@ -2506,7 +2604,7 @@ unsafeSqlBinOpComposite op sep a b -- | (Internal) A raw SQL value. The same warning from -- 'unsafeSqlBinOp' applies to this function as well. -unsafeSqlValue :: TLB.Builder -> SqlExpr (Value a) +unsafeSqlValue :: TLB.Builder -> SqlExpr_ ctx (Value a) unsafeSqlValue v = ERaw noMeta $ \_ _ -> (v, mempty) {-# INLINE unsafeSqlValue #-} @@ -2521,7 +2619,7 @@ valueToFunctionArg info (ERaw _ f) = f Never info -- from 'unsafeSqlBinOp' applies to this function as well. unsafeSqlFunction :: UnsafeSqlFunctionArgument a - => TLB.Builder -> a -> SqlExpr (Value b) + => TLB.Builder -> a -> SqlExpr_ ctx (Value b) unsafeSqlFunction name arg = ERaw noMeta $ \_ info -> let (argsTLB, argsVals) = @@ -2547,7 +2645,7 @@ unsafeSqlExtractSubField subField arg = -- See 'unsafeSqlBinOp' for warnings. unsafeSqlFunctionParens :: UnsafeSqlFunctionArgument a - => TLB.Builder -> a -> SqlExpr (Value b) + => TLB.Builder -> a -> SqlExpr_ ctx (Value b) unsafeSqlFunctionParens name arg = ERaw noMeta $ \_ info -> let valueToFunctionArgParens (ERaw _ f) = f Never info @@ -2557,7 +2655,7 @@ unsafeSqlFunctionParens name arg = -- | (Internal) An explicit SQL type cast using CAST(value as type). -- See 'unsafeSqlBinOp' for warnings. -unsafeSqlCastAs :: T.Text -> SqlExpr (Value a) -> SqlExpr (Value b) +unsafeSqlCastAs :: forall a b ctx. T.Text -> SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value b) unsafeSqlCastAs t (ERaw _ f) = ERaw noMeta $ \_ -> ((first (\value -> "CAST" <> parens (value <> " AS " <> TLB.fromText t))) . f Never) -- | (Internal) This class allows 'unsafeSqlFunction' to work with different @@ -2568,7 +2666,7 @@ unsafeSqlCastAs t (ERaw _ f) = ERaw noMeta $ \_ -> ((first (\value -> "CAST" <> -- also nest tuples, as e.g. @toArgList ((a,b),(c,d))@ is the same as -- @toArgList (a,b,c,d)@. class UnsafeSqlFunctionArgument a where - toArgList :: a -> [SqlExpr (Value ())] + toArgList :: a -> [SqlExpr_ ctx (Value ())] -- | Useful for 0-argument functions, like @now@ in Postgresql. -- @@ -2576,8 +2674,8 @@ class UnsafeSqlFunctionArgument a where instance UnsafeSqlFunctionArgument () where toArgList _ = [] -instance (a ~ Value b) => UnsafeSqlFunctionArgument (SqlExpr a) where - toArgList = (:[]) . veryUnsafeCoerceSqlExprValue +instance (a ~ Value b) => UnsafeSqlFunctionArgument (SqlExpr_ ctx a) where + toArgList = (:[]) . veryUnsafeCoerceSqlExpr instance UnsafeSqlFunctionArgument a => UnsafeSqlFunctionArgument [a] where toArgList = concatMap toArgList @@ -2688,22 +2786,25 @@ 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! -veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b) -veryUnsafeCoerceSqlExprValue = coerce - +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. -veryUnsafeCoerceSqlExprValueList :: SqlExpr (ValueList a) -> SqlExpr (Value a) -veryUnsafeCoerceSqlExprValueList = coerce +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 -- @persistent@'s 'SqlPersistT' monad. rawSelectSource - :: + :: forall a r m1 m2 backend. ( SqlSelect a r , MonadIO m1 , MonadIO m2 @@ -2725,7 +2826,7 @@ rawSelectSource mode query = do massage = do mrow <- C.await - case sqlSelectProcessRow <$> mrow of + case sqlSelectProcessRow (Proxy :: Proxy a) <$> mrow of Just (Right r) -> C.yield r >> massage Just (Left err) -> liftIO $ throwIO $ PersistMarshalError err Nothing -> return () @@ -2942,13 +3043,22 @@ builderToText = TL.toStrict . TLB.toLazyTextWith defaultChunkSize -- possible but tedious), see the 'renderQueryToText' function (along with -- 'renderQuerySelect', 'renderQueryUpdate', etc). toRawSql - :: (SqlSelect a r, BackendCompatible SqlBackend backend) + :: (SqlSelectCols a, BackendCompatible SqlBackend backend) => Mode -> (backend, IdentState) -> SqlQuery a -> (TLB.Builder, [PersistValue]) toRawSql mode (conn, firstIdentState) query = let ((ret, sd), finalIdentState) = flip S.runState firstIdentState $ W.runWriterT $ unQ query + deleteRepeatedNewlines txt = + let + (preNewlines, rest) = TL.break (== '\n') txt + (_, rest') = TL.break (/= '\n') rest + in + if TL.null rest' + then preNewlines <> "\n" + else preNewlines <> "\n" <> deleteRepeatedNewlines rest' + SideData distinctClause fromClauses setClauses @@ -2964,7 +3074,7 @@ toRawSql mode (conn, firstIdentState) query = -- that no name clashes will occur on subqueries that may -- appear on the expressions below. info = (projectBackend conn, finalIdentState) - in mconcat + in (\(x, t) -> (TLB.fromLazyText $ deleteRepeatedNewlines $ TL.strip $ TLB.toLazyText x, t)) $ mconcat $ intersperse ("\n", []) [ makeCte info cteClause , makeInsertInto info mode ret , makeSelect info mode distinctClause ret @@ -2978,6 +3088,7 @@ toRawSql mode (conn, firstIdentState) query = , makeLocking info lockingClause ] + -- | Renders a 'SqlQuery' into a 'Text' value along with the list of -- 'PersistValue's that would be supplied to the database for @?@ placeholders. -- @@ -3087,11 +3198,11 @@ makeCte info cteClauses = _ -> first (\tlb -> withCteText <> tlb <> "\n") cteBody -makeInsertInto :: SqlSelect a r => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue]) +makeInsertInto :: SqlSelectCols a => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue]) makeInsertInto info INSERT_INTO ret = sqlInsertInto info ret makeInsertInto _ _ _ = mempty -makeSelect :: SqlSelect a r => IdentInfo -> Mode -> DistinctClause -> a -> (TLB.Builder, [PersistValue]) +makeSelect :: SqlSelectCols a => IdentInfo -> Mode -> DistinctClause -> a -> (TLB.Builder, [PersistValue]) makeSelect info mode_ distinctClause ret = process mode_ where process mode = @@ -3108,7 +3219,7 @@ makeSelect info mode_ distinctClause ret = process mode_ first (("SELECT DISTINCT ON (" <>) . (<> ") ")) $ uncommas' (processExpr <$> exprs) where - processExpr e = materializeExpr info (coerce e :: SqlExpr (Value a)) + processExpr e = materializeExpr info e withCols v = v <> sqlSelectCols info ret plain v = (v, []) @@ -3157,7 +3268,7 @@ makeFrom info mode fs = ret makeOnClause (ERaw _ f) = first (" ON " <>) (f Never info) - mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException + mkExc :: SqlExpr_ ctx (Value Bool) -> OnClauseWithoutMatchingJoinException mkExc (ERaw _ f) = OnClauseWithoutMatchingJoinException $ TL.unpack $ TLB.toLazyText $ fst (f Never info) @@ -3199,11 +3310,11 @@ makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue]) makeOrderBy _ [] = mempty makeOrderBy info is = let (tlb, vals) = makeOrderByNoNewline info is - in ("\n" <> tlb, vals) + in (tlb, vals) makeLimit :: IdentInfo -> LimitClause -> (TLB.Builder, [PersistValue]) makeLimit (conn, _) (Limit ml mo) = - let limitRaw = getConnLimitOffset (v ml, v mo) "\n" conn + let limitRaw = getConnLimitOffset (v ml, v mo) "" conn v :: Maybe Int64 -> Int v = maybe 0 fromIntegral in (TLB.fromText limitRaw, mempty) @@ -3233,7 +3344,7 @@ makeLocking info (PostgresLockingClauses clauses) = makeLockingStrength PostgresForShare = plain "FOR SHARE" makeLockingBehavior :: OnLockedBehavior -> (TLB.Builder, [PersistValue]) - makeLockingBehavior NoWait = plain "NO WAIT" + makeLockingBehavior NoWait = plain "NOWAIT" makeLockingBehavior SkipLocked = plain "SKIP LOCKED" makeLockingBehavior Wait = plain "" @@ -3255,13 +3366,7 @@ aliasedColumnName :: Ident -> IdentInfo -> T.Text -> TLB.Builder aliasedColumnName (I baseIdent) info columnName = useIdent info (I (baseIdent <> "_" <> columnName)) --- | (Internal) Class for mapping results coming from 'SqlQuery' --- into actual results. --- --- This looks very similar to @RawSql@, and it is! However, --- there are some crucial differences and ultimately they're --- different classes. -class SqlSelect a r | a -> r, r -> a where +class SqlSelectCols a where -- | Creates the variable part of the @SELECT@ query and -- returns the list of 'PersistValue's that will be given to -- 'rawQuery'. @@ -3270,16 +3375,26 @@ class SqlSelect a r | a -> r, r -> a where -- | Number of columns that will be consumed. sqlSelectColCount :: Proxy a -> Int - -- | Transform a row of the result into the data type. - sqlSelectProcessRow :: [PersistValue] -> Either T.Text r - -- | Create @INSERT INTO@ clause instead. sqlInsertInto :: IdentInfo -> a -> (TLB.Builder, [PersistValue]) sqlInsertInto = throw (UnexpectedCaseErr UnsupportedSqlInsertIntoType) +-- | (Internal) Class for mapping results coming from 'SqlQuery' +-- into actual results. +-- +-- This looks very similar to @RawSql@, and it is! However, +-- there are some crucial differences and ultimately they're +-- different classes. +class SqlSelectCols a => SqlSelect a r | a -> r where + -- | Transform a row of the result into the data type. + sqlSelectProcessRow :: Proxy a -> [PersistValue] -> Either T.Text r + + -- | @INSERT INTO@ hack. -instance PersistEntity e => SqlSelect (SqlExpr (Insertion e)) (Insertion e) where +instance PersistEntity e => SqlSelectCols (SqlExpr (Insertion e)) where + sqlSelectCols info (ERaw _ f) = f Never info + sqlSelectColCount = const 0 sqlInsertInto info e = let fields = uncommas $ @@ -3294,16 +3409,17 @@ instance PersistEntity e => SqlSelect (SqlExpr (Insertion e)) (Insertion e) wher fromDBName info . DBName . coerce . getEntityDBName . entityDef . proxy in ("INSERT INTO " <> table e <> parens fields <> "\n", []) - sqlSelectCols info (ERaw _ f) = f Never info - sqlSelectColCount = const 0 - sqlSelectProcessRow = + +instance PersistEntity e => SqlSelect (SqlExpr (Insertion e)) (Insertion e) where + sqlSelectProcessRow _ = const (Right (throw (UnexpectedCaseErr InsertionFinalError))) -- | Not useful for 'select', but used for 'update' and 'delete'. -instance SqlSelect () () where +instance SqlSelectCols () where sqlSelectCols _ _ = ("1", []) sqlSelectColCount _ = 1 - sqlSelectProcessRow _ = Right () +instance SqlSelect () () where + sqlSelectProcessRow _ _ = Right () unescapedColumnNames :: EntityDef -> [DBName] unescapedColumnNames ent = @@ -3319,7 +3435,7 @@ unescapedColumnNames ent = id -- | You may return an 'Entity' from a 'select' query. -instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where +instance PersistEntity a => SqlSelectCols (SqlExpr_ ctx (Entity a)) where sqlSelectCols info expr@(ERaw m f) | Just baseIdent <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m = let process = uncommas $ @@ -3353,35 +3469,39 @@ instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where in (process, mempty) sqlSelectColCount = entityColumnCount . entityDef . getEntityVal - sqlSelectProcessRow = parseEntityValues ed +instance PersistEntity a => SqlSelect (SqlExpr_ ctx (Entity a)) (Entity a) where + sqlSelectProcessRow _ = parseEntityValues ed where ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity a))) -getEntityVal :: Proxy (SqlExpr (Entity a)) -> Proxy a +getEntityVal :: Proxy (SqlExpr_ ctx (Entity a)) -> Proxy a getEntityVal = const Proxy --- | You may return a possibly-@NULL@ 'Entity' from a 'select' query. -instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where - sqlSelectCols info e = sqlSelectCols info (coerce e :: SqlExpr (Entity a)) +instance PersistEntity a => SqlSelectCols (SqlExpr_ ctx (Maybe (Entity a))) where + sqlSelectCols info e = sqlSelectCols info (veryUnsafeCoerceSqlExpr e :: SqlExpr (Entity a)) sqlSelectColCount = sqlSelectColCount . fromEMaybe where - fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e) + fromEMaybe :: Proxy (SqlExpr_ ctx (Maybe e)) -> Proxy (SqlExpr_ ctx e) fromEMaybe = const Proxy - sqlSelectProcessRow cols +-- | 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 | all (== PersistNull) cols = return Nothing - | otherwise = Just <$> sqlSelectProcessRow cols + | otherwise = Just <$> sqlSelectProcessRow (Proxy :: Proxy (SqlExpr (Entity a))) cols -- | You may return any single value (i.e. a single column) from -- a 'select' query. -instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where +instance PersistField a => SqlSelectCols (SqlExpr_ ctx (Value a)) where sqlSelectCols = materializeExpr sqlSelectColCount = const 1 - sqlSelectProcessRow [pv] = Value <$> fromPersistValue pv - sqlSelectProcessRow pvs = Value <$> fromPersistValue (PersistList pvs) + +instance PersistField a => SqlSelect (SqlExpr_ ctx (Value a)) (Value a) where + sqlSelectProcessRow _ [pv] = Value <$> fromPersistValue pv + sqlSelectProcessRow _ pvs = Value <$> fromPersistValue (PersistList pvs) -- | Materialize a @SqlExpr (Value a)@. -materializeExpr :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue]) +materializeExpr :: IdentInfo -> SqlExpr_ ctx a -> (TLB.Builder, [PersistValue]) materializeExpr info (ERaw m f) | Just fields <- sqlExprMetaCompositeFields m = (uncommas $ fmap parens $ fields info, []) | Just alias <- sqlExprMetaAlias m @@ -3391,7 +3511,7 @@ materializeExpr info (ERaw m f) -- | You may return tuples (up to 16-tuples) and tuples of tuples -- from a 'select' query. -instance (SqlSelect a ra, SqlSelect b rb) => SqlSelect (a, b) (ra, rb) where +instance (SqlSelectCols a, SqlSelectCols b) => SqlSelectCols (a, b) where sqlSelectCols esc (a, b) = uncommas' [ sqlSelectCols esc a @@ -3401,7 +3521,8 @@ instance (SqlSelect a ra, SqlSelect b rb) => SqlSelect (a, b) (ra, rb) where where fromTuple :: Proxy (a,b) -> (Proxy a, Proxy b) fromTuple = const (Proxy, Proxy) - sqlSelectProcessRow = +instance (SqlSelect a ra, SqlSelect b rb) => SqlSelect (a, b) (ra, rb) where + sqlSelectProcessRow _ = let x = getType processRow getType :: SqlSelect a r => (z -> Either y (r,x)) -> Proxy a getType = const Proxy @@ -3410,16 +3531,16 @@ instance (SqlSelect a ra, SqlSelect b rb) => SqlSelect (a, b) (ra, rb) where processRow row = let (rowFst, rowSnd) = splitAt colCountFst row - in (,) <$> sqlSelectProcessRow rowFst - <*> sqlSelectProcessRow rowSnd + in (,) <$> sqlSelectProcessRow (Proxy :: Proxy a) rowFst + <*> sqlSelectProcessRow (Proxy :: Proxy b) rowSnd in colCountFst `seq` processRow -- Avoids recalculating 'colCountFst'. -instance ( SqlSelect a ra - , SqlSelect b rb - , SqlSelect c rc - ) => SqlSelect (a, b, c) (ra, rb, rc) where +instance ( SqlSelectCols a + , SqlSelectCols b + , SqlSelectCols c + ) => SqlSelectCols (a, b, c) where sqlSelectCols esc (a, b, c) = uncommas' [ sqlSelectCols esc a @@ -3427,7 +3548,12 @@ instance ( SqlSelect a ra , sqlSelectCols esc c ] sqlSelectColCount = sqlSelectColCount . from3P - sqlSelectProcessRow = fmap to3 . sqlSelectProcessRow + +instance ( SqlSelect a ra + , SqlSelect b rb + , SqlSelect c rc + ) => SqlSelect (a, b, c) (ra, rb, rc) where + sqlSelectProcessRow p = fmap to3 . sqlSelectProcessRow (from3P p) from3P :: Proxy (a,b,c) -> Proxy ((a,b),c) from3P = const Proxy @@ -3438,11 +3564,11 @@ from3 (a,b,c) = ((a,b),c) to3 :: ((a,b),c) -> (a,b,c) to3 ((a,b),c) = (a,b,c) -instance ( SqlSelect a ra - , SqlSelect b rb - , SqlSelect c rc - , SqlSelect d rd - ) => SqlSelect (a, b, c, d) (ra, rb, rc, rd) where +instance ( SqlSelectCols a + , SqlSelectCols b + , SqlSelectCols c + , SqlSelectCols d + ) => SqlSelectCols (a, b, c, d) where sqlSelectCols esc (a, b, c, d) = uncommas' [ sqlSelectCols esc a @@ -3451,7 +3577,12 @@ instance ( SqlSelect a ra , sqlSelectCols esc d ] sqlSelectColCount = sqlSelectColCount . from4P - sqlSelectProcessRow = fmap to4 . sqlSelectProcessRow +instance ( SqlSelect a ra + , SqlSelect b rb + , SqlSelect c rc + , SqlSelect d rd + ) => SqlSelect (a, b, c, d) (ra, rb, rc, rd) where + sqlSelectProcessRow p = fmap to4 . sqlSelectProcessRow (from4P p) from4P :: Proxy (a,b,c,d) -> Proxy ((a,b),(c,d)) from4P = const Proxy @@ -3462,12 +3593,12 @@ from4 (a,b,c,d) = ((a,b),(c,d)) to4 :: ((a,b),(c,d)) -> (a,b,c,d) to4 ((a,b),(c,d)) = (a,b,c,d) -instance ( SqlSelect a ra - , SqlSelect b rb - , SqlSelect c rc - , SqlSelect d rd - , SqlSelect e re - ) => SqlSelect (a, b, c, d, e) (ra, rb, rc, rd, re) where +instance ( SqlSelectCols a + , SqlSelectCols b + , SqlSelectCols c + , SqlSelectCols d + , SqlSelectCols e + ) => SqlSelectCols (a, b, c, d, e) where sqlSelectCols esc (a, b, c, d, e) = uncommas' [ sqlSelectCols esc a @@ -3477,7 +3608,13 @@ instance ( SqlSelect a ra , sqlSelectCols esc e ] sqlSelectColCount = sqlSelectColCount . from5P - sqlSelectProcessRow = fmap to5 . sqlSelectProcessRow +instance ( SqlSelect a ra + , SqlSelect b rb + , SqlSelect c rc + , SqlSelect d rd + , SqlSelect e re + ) => SqlSelect (a, b, c, d, e) (ra, rb, rc, rd, re) where + sqlSelectProcessRow p = fmap to5 . sqlSelectProcessRow (from5P p) from5P :: Proxy (a,b,c,d,e) -> Proxy ((a,b),(c,d),e) from5P = const Proxy @@ -3488,13 +3625,13 @@ from5 (a,b,c,d,e) = ((a,b),(c,d),e) to5 :: ((a,b),(c,d),e) -> (a,b,c,d,e) to5 ((a,b),(c,d),e) = (a,b,c,d,e) -instance ( SqlSelect a ra - , SqlSelect b rb - , SqlSelect c rc - , SqlSelect d rd - , SqlSelect e re - , SqlSelect f rf - ) => SqlSelect (a, b, c, d, e, f) (ra, rb, rc, rd, re, rf) where +instance ( SqlSelectCols a + , SqlSelectCols b + , SqlSelectCols c + , SqlSelectCols d + , SqlSelectCols e + , SqlSelectCols f + ) => SqlSelectCols (a, b, c, d, e, f) where sqlSelectCols esc (a, b, c, d, e, f) = uncommas' [ sqlSelectCols esc a @@ -3505,7 +3642,14 @@ instance ( SqlSelect a ra , sqlSelectCols esc f ] sqlSelectColCount = sqlSelectColCount . from6P - sqlSelectProcessRow = fmap to6 . sqlSelectProcessRow +instance ( SqlSelect a ra + , SqlSelect b rb + , SqlSelect c rc + , SqlSelect d rd + , SqlSelect e re + , SqlSelect f rf + ) => SqlSelect (a, b, c, d, e, f) (ra, rb, rc, rd, re, rf) where + sqlSelectProcessRow p = fmap to6 . sqlSelectProcessRow (from6P p) from6P :: Proxy (a,b,c,d,e,f) -> Proxy ((a,b),(c,d),(e,f)) from6P = const Proxy @@ -3516,14 +3660,14 @@ from6 (a,b,c,d,e,f) = ((a,b),(c,d),(e,f)) to6 :: ((a,b),(c,d),(e,f)) -> (a,b,c,d,e,f) to6 ((a,b),(c,d),(e,f)) = (a,b,c,d,e,f) -instance ( SqlSelect a ra - , SqlSelect b rb - , SqlSelect c rc - , SqlSelect d rd - , SqlSelect e re - , SqlSelect f rf - , SqlSelect g rg - ) => SqlSelect (a, b, c, d, e, f, g) (ra, rb, rc, rd, re, rf, rg) where +instance ( SqlSelectCols a + , SqlSelectCols b + , SqlSelectCols c + , SqlSelectCols d + , SqlSelectCols e + , SqlSelectCols f + , SqlSelectCols g + ) => SqlSelectCols (a, b, c, d, e, f, g) where sqlSelectCols esc (a, b, c, d, e, f, g) = uncommas' [ sqlSelectCols esc a @@ -3535,7 +3679,15 @@ instance ( SqlSelect a ra , sqlSelectCols esc g ] sqlSelectColCount = sqlSelectColCount . from7P - sqlSelectProcessRow = fmap to7 . sqlSelectProcessRow +instance ( SqlSelect a ra + , SqlSelect b rb + , SqlSelect c rc + , SqlSelect d rd + , SqlSelect e re + , SqlSelect f rf + , SqlSelect g rg + ) => SqlSelect (a, b, c, d, e, f, g) (ra, rb, rc, rd, re, rf, rg) where + sqlSelectProcessRow p = fmap to7 . sqlSelectProcessRow (from7P p) from7P :: Proxy (a,b,c,d,e,f,g) -> Proxy ((a,b),(c,d),(e,f),g) from7P = const Proxy @@ -3546,15 +3698,15 @@ from7 (a,b,c,d,e,f,g) = ((a,b),(c,d),(e,f),g) to7 :: ((a,b),(c,d),(e,f),g) -> (a,b,c,d,e,f,g) to7 ((a,b),(c,d),(e,f),g) = (a,b,c,d,e,f,g) -instance ( SqlSelect a ra - , SqlSelect b rb - , SqlSelect c rc - , SqlSelect d rd - , SqlSelect e re - , SqlSelect f rf - , SqlSelect g rg - , SqlSelect h rh - ) => SqlSelect (a, b, c, d, e, f, g, h) (ra, rb, rc, rd, re, rf, rg, rh) where +instance ( SqlSelectCols a + , SqlSelectCols b + , SqlSelectCols c + , SqlSelectCols d + , SqlSelectCols e + , SqlSelectCols f + , SqlSelectCols g + , SqlSelectCols h + ) => SqlSelectCols (a, b, c, d, e, f, g, h) where sqlSelectCols esc (a, b, c, d, e, f, g, h) = uncommas' [ sqlSelectCols esc a @@ -3567,7 +3719,16 @@ instance ( SqlSelect a ra , sqlSelectCols esc h ] sqlSelectColCount = sqlSelectColCount . from8P - sqlSelectProcessRow = fmap to8 . sqlSelectProcessRow +instance ( SqlSelect a ra + , SqlSelect b rb + , SqlSelect c rc + , SqlSelect d rd + , SqlSelect e re + , SqlSelect f rf + , SqlSelect g rg + , SqlSelect h rh + ) => SqlSelect (a, b, c, d, e, f, g, h) (ra, rb, rc, rd, re, rf, rg, rh) where + sqlSelectProcessRow p = fmap to8 . sqlSelectProcessRow (from8P p) from8P :: Proxy (a,b,c,d,e,f,g,h) -> Proxy ((a,b),(c,d),(e,f),(g,h)) from8P = const Proxy @@ -3578,16 +3739,16 @@ from8 (a,b,c,d,e,f,g,h) = ((a,b),(c,d),(e,f),(g,h)) to8 :: ((a,b),(c,d),(e,f),(g,h)) -> (a,b,c,d,e,f,g,h) to8 ((a,b),(c,d),(e,f),(g,h)) = (a,b,c,d,e,f,g,h) -instance ( SqlSelect a ra - , SqlSelect b rb - , SqlSelect c rc - , SqlSelect d rd - , SqlSelect e re - , SqlSelect f rf - , SqlSelect g rg - , SqlSelect h rh - , SqlSelect i ri - ) => SqlSelect (a, b, c, d, e, f, g, h, i) (ra, rb, rc, rd, re, rf, rg, rh, ri) where +instance ( SqlSelectCols a + , SqlSelectCols b + , SqlSelectCols c + , SqlSelectCols d + , SqlSelectCols e + , SqlSelectCols f + , SqlSelectCols g + , SqlSelectCols h + , SqlSelectCols i + ) => SqlSelectCols (a, b, c, d, e, f, g, h, i) where sqlSelectCols esc (a, b, c, d, e, f, g, h, i) = uncommas' [ sqlSelectCols esc a @@ -3601,7 +3762,17 @@ instance ( SqlSelect a ra , sqlSelectCols esc i ] sqlSelectColCount = sqlSelectColCount . from9P - sqlSelectProcessRow = fmap to9 . sqlSelectProcessRow +instance ( SqlSelect a ra + , SqlSelect b rb + , SqlSelect c rc + , SqlSelect d rd + , SqlSelect e re + , SqlSelect f rf + , SqlSelect g rg + , SqlSelect h rh + , SqlSelect i ri + ) => SqlSelect (a, b, c, d, e, f, g, h, i) (ra, rb, rc, rd, re, rf, rg, rh, ri) where + sqlSelectProcessRow p = fmap to9 . sqlSelectProcessRow (from9P p) from9P :: Proxy (a,b,c,d,e,f,g,h,i) -> Proxy ((a,b),(c,d),(e,f),(g,h),i) from9P = const Proxy @@ -3612,17 +3783,17 @@ from9 (a,b,c,d,e,f,g,h,i) = ((a,b),(c,d),(e,f),(g,h),i) to9 :: ((a,b),(c,d),(e,f),(g,h),i) -> (a,b,c,d,e,f,g,h,i) to9 ((a,b),(c,d),(e,f),(g,h),i) = (a,b,c,d,e,f,g,h,i) -instance ( SqlSelect a ra - , SqlSelect b rb - , SqlSelect c rc - , SqlSelect d rd - , SqlSelect e re - , SqlSelect f rf - , SqlSelect g rg - , SqlSelect h rh - , SqlSelect i ri - , SqlSelect j rj - ) => SqlSelect (a, b, c, d, e, f, g, h, i, j) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj) where +instance ( SqlSelectCols a + , SqlSelectCols b + , SqlSelectCols c + , SqlSelectCols d + , SqlSelectCols e + , SqlSelectCols f + , SqlSelectCols g + , SqlSelectCols h + , SqlSelectCols i + , SqlSelectCols j + ) => SqlSelectCols (a, b, c, d, e, f, g, h, i, j) where sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j) = uncommas' [ sqlSelectCols esc a @@ -3637,17 +3808,6 @@ instance ( SqlSelect a ra , sqlSelectCols esc j ] sqlSelectColCount = sqlSelectColCount . from10P - sqlSelectProcessRow = fmap to10 . sqlSelectProcessRow - -from10P :: Proxy (a,b,c,d,e,f,g,h,i,j) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j)) -from10P = const Proxy - -from10 :: (a,b,c,d,e,f,g,h,i,j) -> ((a,b),(c,d),(e,f),(g,h),(i,j)) -from10 (a,b,c,d,e,f,g,h,i,j) = ((a,b),(c,d),(e,f),(g,h),(i,j)) - -to10 :: ((a,b),(c,d),(e,f),(g,h),(i,j)) -> (a,b,c,d,e,f,g,h,i,j) -to10 ((a,b),(c,d),(e,f),(g,h),(i,j)) = (a,b,c,d,e,f,g,h,i,j) - instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc @@ -3658,8 +3818,30 @@ instance ( SqlSelect a ra , SqlSelect h rh , SqlSelect i ri , SqlSelect j rj - , SqlSelect k rk - ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk) where + ) => SqlSelect (a, b, c, d, e, f, g, h, i, j) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj) where + sqlSelectProcessRow p = fmap to10 . sqlSelectProcessRow (from10P p) + +from10P :: Proxy (a,b,c,d,e,f,g,h,i,j) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j)) +from10P = const Proxy + +from10 :: (a,b,c,d,e,f,g,h,i,j) -> ((a,b),(c,d),(e,f),(g,h),(i,j)) +from10 (a,b,c,d,e,f,g,h,i,j) = ((a,b),(c,d),(e,f),(g,h),(i,j)) + +to10 :: ((a,b),(c,d),(e,f),(g,h),(i,j)) -> (a,b,c,d,e,f,g,h,i,j) +to10 ((a,b),(c,d),(e,f),(g,h),(i,j)) = (a,b,c,d,e,f,g,h,i,j) + +instance ( SqlSelectCols a + , SqlSelectCols b + , SqlSelectCols c + , SqlSelectCols d + , SqlSelectCols e + , SqlSelectCols f + , SqlSelectCols g + , SqlSelectCols h + , SqlSelectCols i + , SqlSelectCols j + , SqlSelectCols k + ) => SqlSelectCols (a, b, c, d, e, f, g, h, i, j, k) where sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k) = uncommas' [ sqlSelectCols esc a @@ -3675,13 +3857,6 @@ instance ( SqlSelect a ra , sqlSelectCols esc k ] sqlSelectColCount = sqlSelectColCount . from11P - sqlSelectProcessRow = fmap to11 . sqlSelectProcessRow - -from11P :: Proxy (a,b,c,d,e,f,g,h,i,j,k) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),k) -from11P = const Proxy - -to11 :: ((a,b),(c,d),(e,f),(g,h),(i,j),k) -> (a,b,c,d,e,f,g,h,i,j,k) -to11 ((a,b),(c,d),(e,f),(g,h),(i,j),k) = (a,b,c,d,e,f,g,h,i,j,k) instance ( SqlSelect a ra , SqlSelect b rb @@ -3694,8 +3869,31 @@ instance ( SqlSelect a ra , SqlSelect i ri , SqlSelect j rj , SqlSelect k rk - , SqlSelect l rl - ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl) where + ) => 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 + , SqlSelectCols d + , SqlSelectCols e + , SqlSelectCols f + , SqlSelectCols g + , SqlSelectCols h + , SqlSelectCols i + , SqlSelectCols j + , SqlSelectCols k + , SqlSelectCols l + ) => SqlSelectCols (a, b, c, d, e, f, g, h, i, j, k, l) where sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l) = uncommas' [ sqlSelectCols esc a @@ -3712,13 +3910,6 @@ instance ( SqlSelect a ra , sqlSelectCols esc l ] sqlSelectColCount = sqlSelectColCount . from12P - sqlSelectProcessRow = fmap to12 . sqlSelectProcessRow - -from12P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) -from12P = const Proxy - -to12 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) -> (a,b,c,d,e,f,g,h,i,j,k,l) -to12 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) = (a,b,c,d,e,f,g,h,i,j,k,l) instance ( SqlSelect a ra , SqlSelect b rb @@ -3732,8 +3923,32 @@ instance ( SqlSelect a ra , SqlSelect j rj , SqlSelect k rk , SqlSelect l rl - , SqlSelect m rm - ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm) where + ) => 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 + , SqlSelectCols d + , SqlSelectCols e + , SqlSelectCols f + , SqlSelectCols g + , SqlSelectCols h + , SqlSelectCols i + , SqlSelectCols j + , SqlSelectCols k + , SqlSelectCols l + , SqlSelectCols m + ) => SqlSelectCols (a, b, c, d, e, f, g, h, i, j, k, l, m) where sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m) = uncommas' [ sqlSelectCols esc a @@ -3751,13 +3966,6 @@ instance ( SqlSelect a ra , sqlSelectCols esc m ] sqlSelectColCount = sqlSelectColCount . from13P - sqlSelectProcessRow = fmap to13 . sqlSelectProcessRow - -from13P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) -from13P = const Proxy - -to13 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) -> (a,b,c,d,e,f,g,h,i,j,k,l,m) -to13 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) = (a,b,c,d,e,f,g,h,i,j,k,l,m) instance ( SqlSelect a ra , SqlSelect b rb @@ -3772,8 +3980,33 @@ instance ( SqlSelect a ra , SqlSelect k rk , SqlSelect l rl , SqlSelect m rm - , SqlSelect n rn - ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn) where + ) => 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 + , SqlSelectCols d + , SqlSelectCols e + , SqlSelectCols f + , SqlSelectCols g + , SqlSelectCols h + , SqlSelectCols i + , SqlSelectCols j + , SqlSelectCols k + , SqlSelectCols l + , SqlSelectCols m + , SqlSelectCols n + ) => SqlSelectCols (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = uncommas' [ sqlSelectCols esc a @@ -3792,13 +4025,6 @@ instance ( SqlSelect a ra , sqlSelectCols esc n ] sqlSelectColCount = sqlSelectColCount . from14P - sqlSelectProcessRow = fmap to14 . sqlSelectProcessRow - -from14P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) -from14P = const Proxy - -to14 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -to14 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n) instance ( SqlSelect a ra , SqlSelect b rb @@ -3814,8 +4040,34 @@ instance ( SqlSelect a ra , SqlSelect l rl , SqlSelect m rm , SqlSelect n rn - , SqlSelect o ro - ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn, ro) where + ) => 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 + , SqlSelectCols d + , SqlSelectCols e + , SqlSelectCols f + , SqlSelectCols g + , SqlSelectCols h + , SqlSelectCols i + , SqlSelectCols j + , SqlSelectCols k + , SqlSelectCols l + , SqlSelectCols m + , SqlSelectCols n + , SqlSelectCols o + ) => SqlSelectCols (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = uncommas' [ sqlSelectCols esc a @@ -3835,13 +4087,6 @@ instance ( SqlSelect a ra , sqlSelectCols esc o ] sqlSelectColCount = sqlSelectColCount . from15P - sqlSelectProcessRow = fmap to15 . sqlSelectProcessRow - -from15P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n, o) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) -from15P = const Proxy - -to15 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) -to15 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) instance ( SqlSelect a ra , SqlSelect b rb @@ -3858,8 +4103,35 @@ instance ( SqlSelect a ra , SqlSelect m rm , SqlSelect n rn , SqlSelect o ro - , SqlSelect p rp - ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn, ro, rp) where + ) => 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) + +instance ( SqlSelectCols a + , SqlSelectCols b + , SqlSelectCols c + , SqlSelectCols d + , SqlSelectCols e + , SqlSelectCols f + , SqlSelectCols g + , SqlSelectCols h + , SqlSelectCols i + , SqlSelectCols j + , SqlSelectCols k + , SqlSelectCols l + , SqlSelectCols m + , SqlSelectCols n + , SqlSelectCols o + , SqlSelectCols p + ) => SqlSelectCols (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where sqlSelectCols esc (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = uncommas' [ sqlSelectCols esc a @@ -3880,11 +4152,31 @@ instance ( SqlSelect a ra , sqlSelectCols esc p ] sqlSelectColCount = sqlSelectColCount . from16P - sqlSelectProcessRow = fmap to16 . sqlSelectProcessRow +instance ( SqlSelect a ra + , SqlSelect b rb + , SqlSelect c rc + , SqlSelect d rd + , SqlSelect e re + , SqlSelect f rf + , SqlSelect g rg + , SqlSelect h rh + , SqlSelect i ri + , SqlSelect j rj + , SqlSelect k rk + , SqlSelect l rl + , SqlSelect m rm + , SqlSelect n rn + , SqlSelect o ro + , SqlSelect p rp + ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn, ro, rp) where + sqlSelectProcessRow p = fmap to16 . sqlSelectProcessRow (from16P p) from16P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) from16P = const Proxy +from16 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) +from16 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) + to16 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) to16 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) @@ -3908,7 +4200,7 @@ insertSelectCount a = rawEsqueleto INSERT_INTO a -- representation of the clauses passed to an "On" clause. -- -- @since 3.2.0 -renderExpr :: SqlBackend -> SqlExpr (Value Bool) -> T.Text +renderExpr :: SqlBackend -> SqlExpr_ ctx (Value Bool) -> T.Text renderExpr sqlBackend e = case e of ERaw _ mkBuilderValues -> let (builder, _) = mkBuilderValues Never (sqlBackend, initialIdentState) diff --git a/src/Database/Esqueleto/Legacy.hs b/src/Database/Esqueleto/Legacy.hs index debe44ce3..df1f27a2c 100644 --- a/src/Database/Esqueleto/Legacy.hs +++ b/src/Database/Esqueleto/Legacy.hs @@ -41,7 +41,7 @@ -- -- Other than identifier name clashes, @esqueleto@ does not -- conflict with @persistent@ in any way. -module Database.Esqueleto.Legacy +module Database.Esqueleto.Legacy {-# WARNING "This module will be removed in the next major release. Please migrate to the new syntax in the Database.Esqueleto module if you wish to upgrade." #-} ( -- * Setup -- $setup diff --git a/src/Database/Esqueleto/MySQL.hs b/src/Database/Esqueleto/MySQL.hs index 4182fc67c..e9384a20e 100644 --- a/src/Database/Esqueleto/MySQL.hs +++ b/src/Database/Esqueleto/MySQL.hs @@ -14,5 +14,5 @@ import Database.Esqueleto.Internal.PersistentImport -- because MySQL uses `rand()`. -- -- /Since: 2.6.0/ -random_ :: (PersistField a, Num a) => SqlExpr (Value a) +random_ :: (PersistField a, Num a) => SqlExpr_ ValueContext (Value a) random_ = unsafeSqlValue "RAND()" diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 11197b064..6fc9ac558 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -34,8 +34,9 @@ module Database.Esqueleto.PostgreSQL , forShareOf , filterWhere , values + , (%.) -- * Internal - , unsafeSqlAggregateFunction + , unsafeSqlExprAggregateFunction ) where #if __GLASGOW_HASKELL__ < 804 @@ -73,9 +74,9 @@ emptyArray = unsafeSqlValue "'{}'" -- | Coalesce an array with an empty default value maybeArray :: (PersistField a, PersistField [a]) - => SqlExpr (Value (Maybe [a])) - -> SqlExpr (Value [a]) -maybeArray x = coalesceDefault [x] (emptyArray) + => SqlExpr_ ctx (Value (Maybe [a])) + -> SqlExpr_ ctx (Value [a]) +maybeArray x = coalesceDefault [x] (veryUnsafeCoerceSqlExpr emptyArray) -- | Aggregate mode data AggMode @@ -87,14 +88,14 @@ data AggMode -- -- /Do/ /not/ use this function directly, instead define a new function and give -- it a type (see `unsafeSqlBinOp`) -unsafeSqlAggregateFunction +unsafeSqlExprAggregateFunction :: UnsafeSqlFunctionArgument a => TLB.Builder -> AggMode -> a -> [OrderByClause] - -> SqlExpr (Value b) -unsafeSqlAggregateFunction name mode args orderByClauses = ERaw noMeta $ \_ info -> + -> SqlExpr_ ctx (Value b) +unsafeSqlExprAggregateFunction name mode args orderByClauses = ERaw noMeta $ \_ info -> let (orderTLB, orderVals) = makeOrderByNoNewline info orderByClauses -- Don't add a space if we don't have order by clauses orderTLBSpace = @@ -119,12 +120,12 @@ arrayAggWith :: AggMode -> SqlExpr (Value a) -> [OrderByClause] - -> SqlExpr (Value (Maybe [a])) -arrayAggWith = unsafeSqlAggregateFunction "array_agg" + -> SqlExpr_ ctx (Value (Maybe [a])) +arrayAggWith = unsafeSqlExprAggregateFunction "array_agg" --- | (@array_agg@) Concatenate input values, including @NULL@s, --- into an array. -arrayAgg :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe [a])) +arrayAgg :: (PersistField a) => SqlExpr (Value a) -> SqlExpr_ ctx (Value (Maybe [a])) arrayAgg x = arrayAggWith AggModeAll x [] -- | (@array_agg@) Concatenate distinct input values, including @NULL@s, into @@ -134,18 +135,18 @@ arrayAgg x = arrayAggWith AggModeAll x [] arrayAggDistinct :: (PersistField a, PersistField [a]) => SqlExpr (Value a) - -> SqlExpr (Value (Maybe [a])) + -> SqlExpr_ ctx' (Value (Maybe [a])) arrayAggDistinct x = arrayAggWith AggModeDistinct x [] -- | (@array_remove@) Remove all elements equal to the given value from the -- array. -- -- @since 2.5.3 -arrayRemove :: SqlExpr (Value [a]) -> SqlExpr (Value a) -> SqlExpr (Value [a]) +arrayRemove :: SqlExpr_ ctx (Value [a]) -> SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value [a]) arrayRemove arr elem' = unsafeSqlFunction "array_remove" (arr, elem') -- | Remove @NULL@ values from an array -arrayRemoveNull :: SqlExpr (Value [Maybe a]) -> SqlExpr (Value [a]) +arrayRemoveNull :: SqlExpr_ ctx (Value [Maybe a]) -> SqlExpr_ ctx (Value [a]) -- This can't be a call to arrayRemove because it changes the value type arrayRemoveNull x = unsafeSqlFunction "array_remove" (x, unsafeSqlValue "NULL") @@ -158,9 +159,9 @@ stringAggWith :: -> SqlExpr (Value s) -- ^ Input values. -> SqlExpr (Value s) -- ^ Delimiter. -> [OrderByClause] -- ^ ORDER BY clauses - -> SqlExpr (Value (Maybe s)) -- ^ Concatenation. + -> SqlExpr_ ctx (Value (Maybe s)) -- ^ Concatenation. stringAggWith mode expr delim os = - unsafeSqlAggregateFunction "string_agg" mode (expr, delim) os + unsafeSqlExprAggregateFunction "string_agg" mode (expr, delim) os -- | (@string_agg@) Concatenate input values separated by a -- delimiter. @@ -170,17 +171,17 @@ stringAgg :: SqlString s => SqlExpr (Value s) -- ^ Input values. -> SqlExpr (Value s) -- ^ Delimiter. - -> SqlExpr (Value (Maybe s)) -- ^ Concatenation. + -> SqlExpr_ ctx (Value (Maybe s)) -- ^ Concatenation. stringAgg expr delim = stringAggWith AggModeAll expr delim [] -- | (@chr@) Translate the given integer to a character. (Note the result will -- depend on the character set of your database.) -- -- @since 2.2.11 -chr :: SqlString s => SqlExpr (Value Int) -> SqlExpr (Value s) +chr :: SqlString s => SqlExpr_ ctx (Value Int) -> SqlExpr_ ctx (Value s) chr = unsafeSqlFunction "chr" -now_ :: SqlExpr (Value UTCTime) +now_ :: SqlExpr_ ctx (Value UTCTime) now_ = unsafeSqlFunction "NOW" () upsert @@ -193,7 +194,7 @@ upsert ) => record -- ^ new record to insert - -> [SqlExpr (Entity record) -> SqlExpr Update] + -> [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 @@ -211,7 +212,7 @@ upsertBy -- ^ uniqueness constraint to find by -> record -- ^ new record to insert - -> [SqlExpr (Entity record) -> SqlExpr Update] + -> [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 @@ -285,9 +286,9 @@ insertSelectWithConflict -- ^ Unique constructor or a unique, this is used just to get the name of -- the postgres constraint, the value(s) is(are) never used, so if you have -- a unique "MyUnique 0", "MyUnique undefined" would work as well. - -> SqlQuery (SqlExpr (Insertion val)) + -> SqlQuery (SqlExpr_ ValueContext (Insertion val)) -- ^ Insert query. - -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update]) + -> (SqlExpr_ ValueContext (Entity val) -> SqlExpr_ ValueContext (Entity val) -> [SqlExpr_ ValueContext (Entity val) -> SqlExpr_ ValueContext Update]) -- ^ A list of updates to be applied in case of the constraint being -- violated. The expression takes the current and excluded value to produce -- the updates. @@ -303,8 +304,8 @@ insertSelectWithConflictCount . (FinalResult a, KnowResult a ~ Unique val, MonadIO m, PersistEntity val, SqlBackendCanWrite backend) => a - -> SqlQuery (SqlExpr (Insertion val)) - -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update]) + -> SqlQuery (SqlExpr_ ValueContext (Insertion val)) + -> (SqlExpr_ ValueContext (Entity val) -> SqlExpr_ ValueContext (Entity val) -> [SqlExpr_ ValueContext (Entity val) -> SqlExpr_ ValueContext Update]) -> R.ReaderT backend m Int64 insertSelectWithConflictCount unique query conflictQuery = do conn <- R.ask @@ -362,11 +363,11 @@ insertSelectWithConflictCount unique query conflictQuery = do -- -- @since 3.3.3.3 filterWhere - :: SqlExpr (Value a) + :: SqlExpr_ ctx (Value a) -- ^ Aggregate function -> SqlExpr (Value Bool) -- ^ Filter clause - -> SqlExpr (Value a) + -> SqlExpr_ ctx (Value a) filterWhere aggExpr clauseExpr = ERaw noMeta $ \_ info -> let (aggBuilder, aggValues) = case aggExpr of ERaw _ aggF -> aggF Never info @@ -405,7 +406,7 @@ filterWhere aggExpr clauseExpr = ERaw noMeta $ \_ info -> -- @ -- -- @since 3.5.2.3 -values :: (ToSomeValues a, Ex.ToAliasReference a, Ex.ToAlias a) => NE.NonEmpty a -> Ex.From a +values :: (ToSomeValues a, Ex.ToAliasReference a a, Ex.ToAlias a) => NE.NonEmpty a -> Ex.From a values exprs = Ex.From $ do ident <- newIdentFor $ DBName "vq" alias <- Ex.toAlias $ NE.head exprs @@ -441,7 +442,21 @@ values exprs = Ex.From $ do , params ) --- | `NO WAIT` syntax for postgres locking +-- | Modulo operator for postgres. +-- +-- @ +-- select $ do +-- pure (val 10 %. val 2) +-- @ +(%.) + :: (PersistFieldSql a, Num a) + => SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) + -> SqlExpr_ ctx (Value a) +(%.) = unsafeSqlBinOp " % " + +-- | `NOWAIT` syntax for postgres locking +-- -- error will be thrown if locked rows are attempted to be selected -- -- @since 3.5.9.0 diff --git a/src/Database/Esqueleto/PostgreSQL/JSON.hs b/src/Database/Esqueleto/PostgreSQL/JSON.hs index 7ae5a7a6c..8fc61e37e 100644 --- a/src/Database/Esqueleto/PostgreSQL/JSON.hs +++ b/src/Database/Esqueleto/PostgreSQL/JSON.hs @@ -188,7 +188,7 @@ infixl 6 ||., -., --., #-. -- @ -- -- @since 3.1.0 -(->>.) :: JSONBExpr a -> JSONAccessor -> SqlExpr (Value (Maybe Text)) +(->>.) :: JSONBExpr a -> JSONAccessor -> SqlExpr_ ValueContext (Value (Maybe Text)) (->>.) value (JSONKey txt) = unsafeSqlBinOp " ->> " value $ val txt (->>.) value (JSONIndex i) = unsafeSqlBinOp " ->> " value $ val i @@ -252,7 +252,7 @@ infixl 6 ||., -., --., #-. -- @ -- -- @since 3.1.0 -(#>>.) :: JSONBExpr a -> [Text] -> SqlExpr (Value (Maybe Text)) +(#>>.) :: JSONBExpr a -> [Text] -> SqlExpr_ ValueContext (Value (Maybe Text)) (#>>.) value = unsafeSqlBinOp " #>> " value . mkTextArray -- | /Requires PostgreSQL version >= 9.4/ @@ -274,7 +274,7 @@ infixl 6 ||., -., --., #-. -- @ -- -- @since 3.1.0 -(@>.) :: JSONBExpr a -> JSONBExpr b -> SqlExpr (Value Bool) +(@>.) :: JSONBExpr a -> JSONBExpr b -> SqlExpr_ ValueContext (Value Bool) (@>.) = unsafeSqlBinOp " @> " -- | /Requires PostgreSQL version >= 9.4/ @@ -296,7 +296,7 @@ infixl 6 ||., -., --., #-. -- @ -- -- @since 3.1.0 -(<@.) :: JSONBExpr a -> JSONBExpr b -> SqlExpr (Value Bool) +(<@.) :: JSONBExpr a -> JSONBExpr b -> SqlExpr_ ValueContext (Value Bool) (<@.) = unsafeSqlBinOp " <@ " -- | /Requires PostgreSQL version >= 9.4/ @@ -319,7 +319,7 @@ infixl 6 ||., -., --., #-. -- @ -- -- @since 3.1.0 -(?.) :: JSONBExpr a -> Text -> SqlExpr (Value Bool) +(?.) :: JSONBExpr a -> Text -> SqlExpr_ ValueContext (Value Bool) (?.) value = unsafeSqlBinOp " ?? " value . val -- | /Requires PostgreSQL version >= 9.4/ @@ -342,7 +342,7 @@ infixl 6 ||., -., --., #-. -- @ -- -- @since 3.1.0 -(?|.) :: JSONBExpr a -> [Text] -> SqlExpr (Value Bool) +(?|.) :: JSONBExpr a -> [Text] -> SqlExpr_ ValueContext (Value Bool) (?|.) value = unsafeSqlBinOp " ??| " value . mkTextArray -- | /Requires PostgreSQL version >= 9.4/ @@ -365,7 +365,7 @@ infixl 6 ||., -., --., #-. -- @ -- -- @since 3.1.0 -(?&.) :: JSONBExpr a -> [Text] -> SqlExpr (Value Bool) +(?&.) :: JSONBExpr a -> [Text] -> SqlExpr_ ValueContext (Value Bool) (?&.) value = unsafeSqlBinOp " ??& " value . mkTextArray -- | /Requires PostgreSQL version >= 9.5/ @@ -578,5 +578,5 @@ infixl 6 ||., -., --., #-. (#-.) :: JSONBExpr a -> [Text] -> JSONBExpr b (#-.) value = unsafeSqlBinOp " #- " value . mkTextArray -mkTextArray :: [Text] -> SqlExpr (Value PersistValue) +mkTextArray :: [Text] -> SqlExpr_ ValueContext (Value PersistValue) mkTextArray = val . PersistArray . fmap toPersistValue diff --git a/src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs b/src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs index 8ec123d72..76b77fe13 100644 --- a/src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs +++ b/src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs @@ -16,7 +16,7 @@ import Data.Text (Text) import qualified Data.Text as T (concat, pack) import qualified Data.Text.Encoding as TE (decodeUtf8, encodeUtf8) import Database.Esqueleto.Internal.PersistentImport -import Database.Esqueleto.Internal.Internal (SqlExpr, Value, just, val) +import Database.Esqueleto.Internal.Internal (SqlExpr_, ValueContext, Value, just, val) import GHC.Generics (Generic) -- | Newtype wrapper around any type with a JSON representation. @@ -41,7 +41,7 @@ newtype JSONB a = JSONB { unJSONB :: a } -- | 'SqlExpr' of a NULL-able 'JSONB' value. Hence the 'Maybe'. -- -- Note: NULL here is a PostgreSQL NULL, not a JSON 'null' -type JSONBExpr a = SqlExpr (Value (Maybe (JSONB a))) +type JSONBExpr a = SqlExpr_ ValueContext (Value (Maybe (JSONB a))) -- | Convenience function to lift a regular value into -- a 'JSONB' expression. diff --git a/src/Database/Esqueleto/PostgreSQL/Window.hs b/src/Database/Esqueleto/PostgreSQL/Window.hs new file mode 100644 index 000000000..75c44d697 --- /dev/null +++ b/src/Database/Esqueleto/PostgreSQL/Window.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Esqueleto.PostgreSQL.Window + ( Window, Frame, PartitionBy + , RenderWindow(..) + , frame_, partitionBy_, orderBy_ + , range, rows, groups + , excludeCurrentRow, excludeGroup, excludeTies, excludeNoOthers + , between_, unboundedFollowing, unboundedPreceding, preceding, following, currentRow + ) + where + +import Data.Bifunctor (first) +import Data.Semigroup (First(..)) +import qualified Data.Text.Lazy.Builder as TLB +import Database.Esqueleto.Internal.Internal + ( IdentInfo + , NeedParens(..) + , OrderBy + , SomeValue(..) + , SqlExpr_(..) + , ToSomeValues(..) + , ValueContext + , noMeta + , uncommas' + ) +import Database.Esqueleto.Internal.PersistentImport (PersistValue) +import Database.Esqueleto.PostgreSQL.Window.Frame + ( Frame + , ToFrame(..) + , between_ + , currentRow + , excludeCurrentRow + , excludeGroup + , excludeNoOthers + , excludeTies + , following + , groups + , preceding + , range + , renderFrame + , rows + , unboundedFollowing + , unboundedPreceding + ) + +-- | A monoidal representation of a Window to be used with a Window Function +-- +-- A window is defined using the helper functions 'partitionBy_', 'orderBy_' and 'frame_' +data Window = Window + { windowPartitionBy :: Maybe (First (SqlExpr_ ValueContext PartitionBy)) + , windowOrderBy :: Maybe [SqlExpr_ ValueContext OrderBy] + , windowFrame :: Maybe (First Frame) + } + +instance Semigroup Window where + (Window a b c) <> (Window a' b' c') = Window (a <> a') (b <> b') (c <> c') + +instance Monoid Window where + mempty = Window mempty mempty mempty + mappend = (<>) + +-- Phantom helper type +data PartitionBy + +-- | PARTITION BY +-- +-- Used to divide the result set into partitions for the window function to operate over. +-- +-- For examples, see the tests in @test/PostgreSQL/Test.hs@. +-- +-- Quick usage: +-- +-- @ +-- let isEven_ n = +-- n %. val 2 ==. val 0 +-- select $ do +-- n <- from $ table @Numbers +-- pure +-- ( n ^. NumbersInt +-- , rowNumber_ +-- `over_` +-- partitionBy_ (isEven_ (n ^. NumbersInt)) +-- ) +-- @ +-- +-- This will return the row number for each row, as it relates to the partition +-- expression. Here we're concerned with whether or not the @NumbersInt@ field +-- is even or odd, so the @NumbersInt@ will be returned along with what it's +-- place in line is among other even/odd numbers. +partitionBy_ :: ToSomeValues a => a -> Window +partitionBy_ expr = + mempty{ windowPartitionBy = Just $ First $ ERaw noMeta $ const impl } + + where + impl info = + let (b, v) = renderSomeValues info (toSomeValues expr) + in ("PARTITION BY " <> b, v) + + renderSomeValues info someValues = + uncommas' $ fmap (\(SomeValue (ERaw _ f)) -> f Never info) someValues + +-- | ORDER BY +-- +-- Order the values in the given partition. +-- +-- This is useful in the right-hand side of 'over_', but not in a general +-- 'SqlQuery'. +-- +-- Example: +-- +-- @ +-- insertMany_ +-- [ Numbers 1 2 +-- , Numbers 2 4 +-- , Numbers 3 5 +-- , Numbers 6 7 +-- ] +-- select $ do +-- n <- Experimental.from $ table @Numbers +-- pure ( n ^. NumbersInt +-- , n ^. NumbersDouble +-- , sum_ @_ @Double (n ^. NumbersDouble) +-- `over_` ( +-- orderBy_ [asc (n ^. NumbersInt)] +-- <> frame_ unboundedPreceding +-- ) +-- ) +-- @ +-- +-- This query will sum the @n ^. NumbersDouble@ for all rows prior to the +-- current one. For the given insert, it'll return the following results: +-- +-- +------------+---------------+---------------+ +-- | NumbersInt | NumbersDouble | sum preceding | +-- +============+===============+---------------+ +-- | 1 | 2 | 2 | +-- | 2 | 4 | 6 | +-- | 3 | 5 | 11 | +-- | 6 | 7 | 18 | +-- +------------+---------------+---------------| +-- +-- Each row contains the running total, ordered by the @NumbersInt@ column. +orderBy_ :: [SqlExpr_ ValueContext OrderBy] -> Window +orderBy_ [] = mempty +orderBy_ exprs = mempty{ windowOrderBy = Just exprs } + +-- | FRAME +-- +-- Defines a set of rows relative to the current row to include in the window +-- +-- e.g. +-- @ +-- 'frame_' ('between_' ('preceding' 10) ('following' 10)) +-- @ +frame_ :: ToFrame frame => frame -> Window +frame_ f = mempty{windowFrame = Just $ First $ toFrame f} + +class RenderWindow a where + renderWindow :: IdentInfo -> a -> (TLB.Builder, [PersistValue]) +instance RenderWindow () where + renderWindow _ = mempty +instance RenderWindow Window where + renderWindow info window = + let (partition, partitionVal) = maybe mempty ((\(ERaw _ f) -> f Never info) . getFirst) (windowPartitionBy window) + (order, orderVal) = maybe mempty (first ((<>) " ORDER BY ") . uncommas' . fmap (\(ERaw _ f) -> f Never info)) (windowOrderBy window) + (frame, frameVal) = maybe mempty (renderFrame info . getFirst) (windowFrame window) + in (partition <> order <> frame, partitionVal <> orderVal <> frameVal) diff --git a/src/Database/Esqueleto/PostgreSQL/Window/Frame.hs b/src/Database/Esqueleto/PostgreSQL/Window/Frame.hs new file mode 100644 index 000000000..4055172ae --- /dev/null +++ b/src/Database/Esqueleto/PostgreSQL/Window/Frame.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE OverloadedStrings #-} +module Database.Esqueleto.PostgreSQL.Window.Frame + ( Frame + , ToFrame(..) + , FrameRange + , renderFrame + , range, rows, groups + , excludeCurrentRow, excludeGroup, excludeTies, excludeNoOthers + , between_, unboundedFollowing, unboundedPreceding, preceding, following, currentRow + ) + where + +import Data.Int (Int64) +import qualified Data.Text.Lazy.Builder as TLB +import Database.Esqueleto.Internal.Internal (IdentInfo) +import Database.Esqueleto.Internal.PersistentImport (PersistValue(..)) + +data Frame = Frame (Maybe FrameKind) FrameBody (Maybe FrameExclusion) + +class ToFrame a where + toFrame :: a -> Frame + +instance ToFrame Frame where + toFrame = id + +renderFrame :: IdentInfo -> Frame -> (TLB.Builder, [PersistValue]) +renderFrame info (Frame mKind frameBody mExclusion) = + let (kind, kindVals) = maybe ("ROWS ", []) (renderFrameKind info) mKind + (exclusion, exclusionVals) = maybe mempty (renderFrameExclusion info) mExclusion + (body, bodyVals) = renderFrameBody info frameBody + in (" " <> kind <> body <> exclusion, kindVals <> bodyVals <> exclusionVals) + + +newtype FrameKind = FrameKind { unFrameKind :: (TLB.Builder, [PersistValue]) } + +renderFrameKind :: IdentInfo -> FrameKind -> (TLB.Builder, [PersistValue]) +renderFrameKind _ = unFrameKind + +frameKind :: ToFrame frame => TLB.Builder -> frame -> Frame +frameKind tlb frame = + let Frame _ b e = toFrame frame + in Frame (Just (FrameKind (tlb <> " ", []))) b e + +-- use a RANGE frame kind +range :: ToFrame frame => frame -> Frame +range = frameKind "RANGE" + +-- use a ROWS frame kind (This is the default behavior) +rows :: ToFrame frame => frame -> Frame +rows = frameKind "ROWS" + +-- use a GROUPS frame kind +groups :: ToFrame frame => frame -> Frame +groups = frameKind "GROUPS" + +newtype FrameExclusion = FrameExclusion { unFrameExclusion :: (TLB.Builder, [PersistValue]) } + +renderFrameExclusion :: IdentInfo -> FrameExclusion -> (TLB.Builder, [PersistValue]) +renderFrameExclusion _ = unFrameExclusion + +frameExclusion :: ToFrame frame => TLB.Builder -> frame -> Frame +frameExclusion tlb frame = + let Frame k b _ = toFrame frame + in Frame k b (Just $ FrameExclusion (" EXCLUDE " <> tlb, [])) + +excludeCurrentRow :: ToFrame frame => frame -> Frame +excludeCurrentRow = frameExclusion "CURRENT ROW" + +excludeGroup :: ToFrame frame => frame -> Frame +excludeGroup = frameExclusion "GROUP" + +excludeTies :: ToFrame frame => frame -> Frame +excludeTies = frameExclusion "TIES" + +excludeNoOthers :: ToFrame frame => frame -> Frame +excludeNoOthers = frameExclusion "NO OTHERS" + +-- In order to prevent runtime errors we do some magic rewriting of queries that wouldn't be valid SQL. +-- In the case of an implicit frame end `following 10` would become BETWEEN 10 FOLLOWING AND CURRENT ROW +-- This is illegal so `following 10` instead becomes `BETWEEN CURRENT_ROW AND 10 FOLLOWING` +-- Additionally `BETWEEN` requires that the frame start be before the frame end. +-- To prevent this error the frame will be flipped automatically. +-- i.e. `between (following 10) (preceding 10)` becomes `BETWEEEN 10 PRECEEDING AND 10 FOLLOWING` +-- therefore `between (following 10) (preceding 10) === between (preceding 10) (following 10) +data FrameBody + = FrameStart FrameRange + | FrameBetween FrameRange FrameRange + +instance ToFrame FrameBody where + toFrame b = Frame Nothing b Nothing + +renderFrameBody :: IdentInfo -> FrameBody -> (TLB.Builder, [PersistValue]) +renderFrameBody info (FrameStart (FrameRangeFollowing b)) = + renderFrameBody info (FrameBetween FrameRangeCurrentRow (FrameRangeFollowing b)) +renderFrameBody info (FrameStart f) = + renderFrameRange info f +renderFrameBody info (FrameBetween startRange endRange) = + if startRange > endRange then + renderFrameBody info (FrameBetween endRange startRange) + else + let (b, v) = renderFrameRange info startRange + (b', v') = renderFrameRange info endRange + in ("BETWEEN " <> b <> " AND " <> b', v <> v') + +instance ToFrame FrameRange where + toFrame r = Frame Nothing (FrameStart r) Nothing + +renderFrameRange :: IdentInfo -> FrameRange -> (TLB.Builder, [PersistValue]) +renderFrameRange _ FrameRangeCurrentRow = ("CURRENT ROW", []) +renderFrameRange _ (FrameRangePreceding bounds) = renderBounds bounds <> (" PRECEDING", []) +renderFrameRange _ (FrameRangeFollowing bounds) = renderBounds bounds <> (" FOLLOWING", []) + +renderBounds :: FrameRangeBound -> (TLB.Builder, [PersistValue]) +renderBounds (FrameRangeUnbounded) = ("UNBOUNDED", []) +renderBounds (FrameRangeBounded i) = ("?", [PersistInt64 i]) + +data FrameRange + = FrameRangePreceding FrameRangeBound + | FrameRangeCurrentRow + | FrameRangeFollowing FrameRangeBound + deriving Eq + +instance Ord FrameRange where + FrameRangePreceding b1 <= FrameRangePreceding b2 = b1 <= b2 + FrameRangePreceding _ <= FrameRangeCurrentRow = True + FrameRangePreceding _ <= FrameRangeFollowing _ = True + FrameRangeCurrentRow <= FrameRangePreceding _ = False + FrameRangeCurrentRow <= FrameRangeCurrentRow = True + FrameRangeCurrentRow <= FrameRangeFollowing _ = True + FrameRangeFollowing _ <= FrameRangePreceding _ = False + FrameRangeFollowing _ <= FrameRangeCurrentRow = False + FrameRangeFollowing b1 <= FrameRangeFollowing b2 = b1 <= b2 + +data FrameRangeBound + = FrameRangeUnbounded + | FrameRangeBounded Int64 + deriving Eq + +instance Ord FrameRangeBound where + FrameRangeUnbounded <= FrameRangeBounded _ = False + FrameRangeUnbounded <= FrameRangeUnbounded = True + FrameRangeBounded _ <= FrameRangeUnbounded = True + FrameRangeBounded a <= FrameRangeBounded b = a <= b + +between_ :: FrameRange -> FrameRange -> FrameBody +between_ = FrameBetween + +unboundedPreceding :: FrameRange +unboundedPreceding = FrameRangePreceding FrameRangeUnbounded + +preceding :: Int64 -> FrameRange +preceding offset = FrameRangePreceding (FrameRangeBounded offset) + +following :: Int64 -> FrameRange +following offset = FrameRangeFollowing (FrameRangeBounded offset) + +unboundedFollowing :: FrameRange +unboundedFollowing = FrameRangeFollowing FrameRangeUnbounded + +currentRow :: FrameRange +currentRow = FrameRangeCurrentRow diff --git a/src/Database/Esqueleto/PostgreSQL/WindowFunction.hs b/src/Database/Esqueleto/PostgreSQL/WindowFunction.hs new file mode 100644 index 000000000..8e96bf539 --- /dev/null +++ b/src/Database/Esqueleto/PostgreSQL/WindowFunction.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Database.Esqueleto.PostgreSQL.WindowFunction + ( Window, Frame, PartitionBy + , WindowExpr, sqlExprToWindowContext + , SqlWindow + , over_, rowNumber_ + , frame_, partitionBy_, orderBy_ + , lag_, lagWithDefault_ + , range, rows, groups + , excludeCurrentRow, excludeGroup, excludeTies, excludeNoOthers + , between_, unboundedFollowing, unboundedPreceding, preceding, following, currentRow + ) + where + +import Data.Int +import Data.Maybe (fromMaybe) +import Database.Esqueleto.Internal.Internal + ( AggregateContext + , NeedParens(..) + , SqlExpr + , SqlExpr_(..) + , Value(..) + , noMeta + , parens + , parensM + , unsafeSqlFunction + , unsafeSqlValue + , val + , veryUnsafeCoerceSqlExpr + ) +import Database.Esqueleto.PostgreSQL.Window + ( Frame + , PartitionBy + , RenderWindow(..) + , Window + , between_ + , currentRow + , excludeCurrentRow + , excludeGroup + , excludeNoOthers + , excludeTies + , following + , frame_ + , groups + , orderBy_ + , partitionBy_ + , preceding + , range + , rows + , unboundedFollowing + , unboundedPreceding + ) + +-- | A datatype tag indicating that the given 'SqlExpr_' is in a window context. +data WindowContext + +-- | Coerce a 'SqlExpr' value into a 'SqlWindow' value. +sqlExprToWindowContext :: SqlExpr a -> SqlWindow a +sqlExprToWindowContext = veryUnsafeCoerceSqlExpr + +-- | Helper type indicating that the 'SqlExpr_' is for a 'WindowContext'. +type SqlWindow = SqlExpr_ WindowContext + +-- | A 'WindowExpr' is an expression that should only be used when combined with +-- 'over_' to form a 'SqlWindow' expression. +newtype WindowExpr a = WindowExpr { unWindowExpr :: SqlExpr a } + +-- | Return the row number for the given item in the partition. +-- +-- Example: +-- +-- @ +-- 'insertMany_' +-- [ Numbers { numbersInt = 1, numbersDouble = 2 } +-- , Numbers 2 4 +-- , Numbers 3 5 +-- , Numbers 6 7 +-- ] +-- select $ do +-- n <- 'from' $ 'table' @Numbers +-- 'orderBy' ['asc' $ n ^. NumbersInt] +-- pure ( n ^. NumbersInt +-- , 'rowNumber_' `Window.over_` () +-- ) +-- @ +-- +-- This would return +-- +-- +------------+-----------+ +-- | NumbersInt | rowNumber | +-- +============+===========+ +-- | 1 | 1 | +-- | 2 | 2 | +-- | 3 | 3 | +-- | 6 | 4 | +-- +------------+-----------+ +-- +-- If we use a 'partitionBy_', then it'll return the row number for the given +-- partition. With the above dataset, and changing the query slightly to do +-- 'partitionBy_' whether or not the @NumbersInt@ is even, then we'd have this +-- query: +-- +-- @ +-- let isEven_ n = +-- n %. val 2 == val 0 +-- select $ do +-- n <- 'from' $ 'table' @Numbers +-- 'orderBy' ['asc' $ n ^. NumbersInt] +-- pure ( n ^. NumbersInt +-- , 'rowNumber_' `Window.over_` +-- 'partitionBy_' isEven_ (n ^. NumbersInt) +-- ) +-- @ +-- +-- with these results: +-- +-- +------------+-----------+ +-- | NumbersInt | rowNumber `over_` partitionBy isEven | +-- +============+===========+ +-- | 1 | 1 | +-- | 2 | 1 | +-- | 3 | 2 | +-- | 6 | 2 | +-- +------------+-----------+ +-- +-- 1 and 2 are the first odd and even number, and so get "row number" of 1. 3 is +-- the second odd number, and has now number 2. 6 is the second even number, and +-- has the row number 2 as well. +rowNumber_ :: WindowExpr (Value Int64) +rowNumber_ = WindowExpr $ unsafeSqlValue "ROW_NUMBER()" + +-- | Like 'lag_', but can accept a default value for the first value in +-- a partition. +lagWithDefault_ + :: SqlExpr (Value a) + -- ^ The 'SqlExpr' to lag behind. + -> Maybe (SqlExpr (Value Int64)) + -- ^ The offset. If 'Nothing' is provided, this is @1@. + -> SqlExpr (Value a) + -- ^ The default value. Used for the first element in a partition. + -> WindowExpr (Value a) +lagWithDefault_ v moffset defaultVal = + WindowExpr $ unsafeSqlFunction "LAG" (v, offset', defaultVal) + where + offset' = fromMaybe (val 1) moffset + +-- | Include a value from a previous row. +-- +-- @ +-- insertMany_ +-- [ Numbers { numbersInt = 1, numbersDouble = 2 } +-- , Numbers 2 4 +-- , Numbers 3 5 +-- , Numbers 6 7 +-- ] +-- 'select' $ do +-- n <- 'from' $ 'table' @Numbers +-- orderBy ['asc' $ n ^. NumbersInt] +-- pure ( n ^. NumbersInt +-- , 'lag_' (n ^. NumbersInt) Nothing +-- `over_` () +-- ) +-- @ +-- +-- We're ordering by the @NumbersInt@. This is the result we get: +-- +-- +------------+-----------+ +-- | NumbersInt | lag_ NumbersInt | +-- +============+===========+ +-- | 1 | NULL | +-- | 2 | 1 | +-- | 3 | 2 | +-- | 6 | 3 | +-- +------------+-----------+ +-- +-- The first row returns @NULL@, since there's nothing before. The second row +-- returns the value from the first row, and the third returns the value from +-- the second row. +lag_ + :: SqlExpr (Value a) + -- ^ The value to show for a previous row. + -> Maybe (SqlExpr (Value Int64)) + -- ^ How far back to look. If 'Nothing' is provided, it defaults to 1. + -> WindowExpr (Value (Maybe a)) +lag_ v mOffset = + WindowExpr $ unsafeSqlFunction "LAG" (v, offset') + where + offset' = fromMaybe (val 1) mOffset + +class WindowExprC expr where + over_ :: RenderWindow window => expr a -> window -> SqlExpr_ WindowContext a + +instance WindowExprC WindowExpr where + over_ windowExpr window = overImpl (unWindowExpr windowExpr) window + +instance (ctx ~ AggregateContext) => WindowExprC (SqlExpr_ ctx) where + over_ = overImpl + +overImpl :: RenderWindow window => SqlExpr_ ctx a -> window -> SqlExpr_ WindowContext a +overImpl (ERaw _ f) window = + ERaw noMeta $ \p info -> + let (b, v) = f Never info + (w, vw) = renderWindow info window + in (parensM p $ b <> " OVER " <> parens w , v <> vw) +{-- + +--( "LAG(?) OVER (PARTITION BY ?, ? ORDER BY ? ASC ROWS BETWEEN ? PRECEEDING AND UNBOUNDED FOLLOWING)" +--, [PersistInt64 10,PersistInt64 10,PersistBool True,PersistInt64 10,PersistInt64 1] +--) + +example = + lag_ (val @Int64 10) Nothing Nothing `over_` + ( partitionBy_ (val @Int64 10, val True) + <> frame_ (rows $ between (preceeding 1) unboundedFollowing) + <> orderBy_ [asc (val @Int64 10)] + ) + +example2 = countRows_ @Int64 `over_` () + +lag :: SqlExpr_ ValueContext (Value a) -> WindowExpr a +lag v = lag_ v Nothing Nothing + +lag_ :: SqlExpr_ ValueContext a -> Maybe (SqlExpr_ ValueContext Int64) -> Maybe (SqlExpr_ ValueContext a) -> WindowExpr a +lag_ v mOffset mDefaultVal = + coerce $ + case (mOffset, mDefaultVal) of + (Just offset, Just defaultVal) -> + unsafeSqlFunction "LAG" (v, offset, defaultVal) + (Just offset, Nothing) -> + unsafeSqlFunction "LAG" (v, offset) + (Nothing, _) -> + unsafeSqlFunction "LAG" v +--} diff --git a/src/Database/Esqueleto/Record.hs b/src/Database/Esqueleto/Record.hs index 27905acd6..62f95e89f 100644 --- a/src/Database/Esqueleto/Record.hs +++ b/src/Database/Esqueleto/Record.hs @@ -1,7 +1,11 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} @@ -13,15 +17,18 @@ module Database.Esqueleto.Record , DeriveEsqueletoRecordSettings(..) , defaultDeriveEsqueletoRecordSettings + , takeColumns + , takeMaybeColumns ) where import Control.Monad.Trans.State.Strict (StateT(..), evalStateT) import Data.Proxy (Proxy(..)) import Database.Esqueleto.Experimental (Entity, PersistValue, SqlExpr, Value(..), (:&)(..)) +import Database.Esqueleto.Internal.Internal (SqlSelectCols(..), SqlSelect(..)) import Database.Esqueleto.Experimental.ToAlias (ToAlias(..)) +import Database.Esqueleto.Experimental.ToMaybe (ToMaybe(..)) import Database.Esqueleto.Experimental.ToAliasReference (ToAliasReference(..)) -import Database.Esqueleto.Internal.Internal (SqlSelect(..)) import Language.Haskell.TH import Language.Haskell.TH.Syntax import Data.Bifunctor (first) @@ -30,6 +37,7 @@ import Control.Monad (forM) import Data.Foldable (foldl') import GHC.Exts (IsString(fromString)) import Data.Maybe (mapMaybe, fromMaybe, listToMaybe) +import Debug.Trace -- | 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 @@ -57,7 +65,7 @@ import Data.Maybe (mapMaybe, fromMaybe, listToMaybe) -- @ -- data SqlMyRecord = -- SqlMyRecord { myName :: 'SqlExpr' ('Value' Text) --- , myAge :: 'SqlExpr' ('Value' Int) +-- , myAge :: 'SqlExpr' ('Value' ('Maybe' Int)) -- , myUser :: 'SqlExpr' ('Entity' User) -- , myAddress :: 'SqlExpr' ('Maybe' ('Entity' Address)) -- } @@ -75,7 +83,7 @@ import Data.Maybe (mapMaybe, fromMaybe, listToMaybe) -- 'sqlSelectColCount' _ = -- 'sqlSelectColCount' -- ('Proxy' \@( ('SqlExpr' ('Value' Text)) --- :& ('SqlExpr' ('Value' Int)) +-- :& ('SqlExpr' ('Value' ('Maybe' Int))) -- :& ('SqlExpr' ('Entity' User)) -- :& ('SqlExpr' ('Maybe' ('Entity' Address))))) -- @@ -85,7 +93,7 @@ import Data.Maybe (mapMaybe, fromMaybe, listToMaybe) -- where -- process = do -- 'Value' myName <- 'takeColumns' \@('SqlExpr' ('Value' Text)) --- 'Value' myAge <- 'takeColumns' \@('SqlExpr' ('Value' Int)) +-- 'Value' myAge <- 'takeColumns' \@('SqlExpr' ('Value' ('Maybe' Int))) -- myUser <- 'takeColumns' \@('SqlExpr' ('Entity' User)) -- myAddress <- 'takeColumns' \@('SqlExpr' ('Maybe' ('Entity' Address))) -- 'pure' MyRecord { myName = myName @@ -130,11 +138,21 @@ data DeriveEsqueletoRecordSettings = DeriveEsqueletoRecordSettings -- name to produce the SQL record's type name and constructor name. -- -- @since 3.5.8.0 + , sqlMaybeNameModifier :: String -> String + -- ^ Function applied to the Haskell record's type name and constructor + -- name to produce the 'ToMaybe' record's type name and constructor name. + -- + -- @since 3.5.11.0 , sqlFieldModifier :: String -> String -- ^ Function applied to the Haskell record's field names to produce the -- SQL record's field names. -- -- @since 3.5.8.0 + , sqlMaybeFieldModifier :: String -> String + -- ^ Function applied to the Haskell record's field names to produce the + -- 'ToMaybe' SQL record's field names. + -- + -- @since 3.5.11.0 } -- | The default codegen settings for 'deriveEsqueletoRecord'. @@ -148,7 +166,9 @@ data DeriveEsqueletoRecordSettings = DeriveEsqueletoRecordSettings defaultDeriveEsqueletoRecordSettings :: DeriveEsqueletoRecordSettings defaultDeriveEsqueletoRecordSettings = DeriveEsqueletoRecordSettings { sqlNameModifier = ("Sql" ++) + , sqlMaybeNameModifier = ("SqlMaybe" ++) , sqlFieldModifier = id + , sqlMaybeFieldModifier = id } -- | Takes the name of a Haskell record type and creates a variant of that @@ -168,13 +188,19 @@ deriveEsqueletoRecordWith settings originalName = do -- instance is available in GHC 8. recordDec <- makeSqlRecord info sqlSelectInstanceDec <- makeSqlSelectInstance info + sqlMaybeRecordDec <- makeSqlMaybeRecord info + toMaybeInstanceDec <- makeToMaybeInstance info + sqlMaybeRecordSelectInstanceDec <- makeSqlMaybeRecordSelectInstance info toAliasInstanceDec <- makeToAliasInstance info toAliasReferenceInstanceDec <- makeToAliasReferenceInstance info - pure - [ recordDec + pure $ concat + [ [recordDec] , sqlSelectInstanceDec - , toAliasInstanceDec - , toAliasReferenceInstanceDec + , pure sqlMaybeRecordDec + , pure toMaybeInstanceDec + , sqlMaybeRecordSelectInstanceDec + , pure toAliasInstanceDec + , pure toAliasReferenceInstanceDec ] -- | Information about a record we need to generate the declarations. @@ -185,11 +211,15 @@ data RecordInfo = RecordInfo name :: Name , -- | The generated SQL record's name. sqlName :: Name + , -- | The generated SQL 'ToMaybe' record's name. + sqlMaybeName :: Name , -- | The original record's constraints. If this isn't empty it'll probably -- cause problems, but it's easy to pass around so might as well. constraints :: Cxt , -- | The original record's type-variable-binders. -#if MIN_VERSION_template_haskell(2,17,0) +#if MIN_VERSION_template_haskell(2,21,0) + typeVarBinders :: [TyVarBndr BndrVis] +#elif MIN_VERSION_template_haskell(2,17,0) typeVarBinders :: [TyVarBndr ()] #else typeVarBinders :: [TyVarBndr] @@ -200,12 +230,17 @@ data RecordInfo = RecordInfo constructorName :: Name , -- | The generated SQL record's constructor name. sqlConstructorName :: Name + , -- | The generated SQL 'ToMaybe' record's constructor name. + sqlMaybeConstructorName :: Name , -- | The original record's field names and types, derived from the -- constructors. fields :: [(Name, Type)] , -- | The generated SQL record's field names and types, computed -- with 'sqlFieldType'. sqlFields :: [(Name, Type)] + , -- | The generated SQL 'ToMaybe' record's field names and types, computed + -- with 'sqlMaybeFieldType'. + sqlMaybeFields :: [(Name, Type)] } -- | Get a `RecordInfo` instance for the given record name. @@ -228,9 +263,12 @@ getRecordInfo settings name = do con -> error $ nonRecordConstructorMessage con fields = getFields constructor sqlName = makeSqlName settings name + sqlMaybeName = makeSqlMaybeName settings name sqlConstructorName = makeSqlName settings constructorName + sqlMaybeConstructorName = makeSqlMaybeName settings constructorName sqlFields <- mapM toSqlField fields + sqlMaybeFields <- mapM toSqlMaybeField fields pure RecordInfo {..} where @@ -243,10 +281,20 @@ getRecordInfo settings name = do sqlTy <- sqlFieldType ty pure (modifier fieldName', sqlTy) + 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. makeSqlName :: DeriveEsqueletoRecordSettings -> Name -> Name makeSqlName settings name = mkName $ sqlNameModifier settings $ nameBase name +-- | Create a new name by prefixing @SqlMaybe@ to a given name. +makeSqlMaybeName :: DeriveEsqueletoRecordSettings -> Name -> Name +makeSqlMaybeName settings name = mkName $ sqlMaybeNameModifier settings $ nameBase name + -- | Transforms a record field type into a corresponding `SqlExpr` type. -- -- * @'Entity' x@ is transformed into @'SqlExpr' ('Entity' x)@. @@ -275,6 +323,40 @@ sqlFieldType fieldType = do `AppT` ((ConT ''Value) `AppT` fieldType) +-- | Transforms a record field type into a corresponding `SqlExpr` `ToMaybe` type. +-- +-- * @'Entity' x@ is transformed into @'SqlExpr' ('Maybe' ('Entity' x))@. +-- * @'Maybe' ('Entity' x)@ is transformed into @'SqlExpr' ('Maybe' ('Maybe' ('Entity' x)))@. +-- * @x@ is transformed into @'SqlExpr' ('Value' ('Maybe' x))@. +-- * If there exists an instance @'SqlSelect' sql x@, then @x@ is transformed into @sql@. +-- +-- This function should match `sqlSelectProcessRowPat`. +sqlMaybeFieldType :: Type -> Q Type +sqlMaybeFieldType fieldType = do + maybeSqlType <- reifySqlSelectType fieldType + + pure $ maybe convertFieldType convertSqlType maybeSqlType + where + convertSqlType = ((ConT ''ToMaybeT) `AppT`) + convertFieldType = case fieldType of + -- Entity x -> SqlExpr (Entity x) -> SqlExpr (Maybe (Entity x)) + AppT (ConT ((==) ''Entity -> True)) _innerType -> + (ConT ''SqlExpr) `AppT` ((ConT ''Maybe) `AppT` fieldType) + + -- Maybe (Entity x) -> SqlExpr (Maybe (Entity x)) -> SqlExpr (Maybe (Entity x)) + (ConT ((==) ''Maybe -> True)) + `AppT` ((ConT ((==) ''Entity -> True)) + `AppT` _innerType) -> + (ConT ''SqlExpr) `AppT` fieldType + + -- Maybe x -> SqlExpr (Value (Maybe x)) -> SqlExpr (Value (Maybe x)) + inner@((ConT ((==) ''Maybe -> True)) `AppT` _inner) -> (ConT ''SqlExpr) `AppT` ((ConT ''Value) `AppT` inner) + + -- x -> SqlExpr (Value x) -> SqlExpr (Value (Maybe x)) + _ -> (ConT ''SqlExpr) + `AppT` ((ConT ''Value) + `AppT` ((ConT ''Maybe) `AppT` fieldType)) + -- | Generates the declaration for an @Sql@-prefixed record, given the original -- record's information. makeSqlRecord :: RecordInfo -> Q Dec @@ -288,64 +370,68 @@ makeSqlRecord RecordInfo {..} = do -- | Generates an `SqlSelect` instance for the given record and its -- @Sql@-prefixed variant. -makeSqlSelectInstance :: RecordInfo -> Q Dec +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 instanceType [sqlSelectColsDec', sqlSelectColCountDec', sqlSelectProcessRowDec'] + pure [ InstanceD overlap instanceConstraints sqlSelectColsType [ sqlSelectColsDec', sqlSelectColCountDec'] + , InstanceD overlap instanceConstraints instanceType [ sqlSelectProcessRowDec'] + ] -- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance. sqlSelectColsDec :: RecordInfo -> Q Dec sqlSelectColsDec RecordInfo {..} = do - -- Pairs of record field names and local variable names. - fieldNames <- forM sqlFields (\(name', _type) -> do - var <- newName $ nameBase name' - pure (name', var)) - - -- Patterns binding record fields to local variables. - let fieldPatterns :: [FieldPat] - fieldPatterns = [(name', VarP var) | (name', var) <- fieldNames] - - -- Local variables for fields joined with `:&` in a single expression. - joinedFields :: Exp - joinedFields = - case snd `map` fieldNames of - [] -> TupE [] - [f1] -> VarE f1 - f1 : rest -> - let helper lhs field = - InfixE - (Just lhs) - (ConE '(:&)) - (Just $ VarE field) - in foldl' helper (VarE f1) rest - - identInfo <- newName "identInfo" - -- 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. - [] - ] + -- Pairs of record field names and local variable names. + fieldNames <- forM sqlFields $ \(name', typ) -> do + var <- newName $ nameBase name' + pure (name', var, typ) + + -- Patterns binding record fields to local variables. + let fieldPatterns :: [FieldPat] + fieldPatterns = [(name', VarP var) | (name', var, _typ) <- fieldNames] + + -- Local variables for fields joined with `:&` in a single expression. + joinedFields :: Exp + joinedFields = + case map (\(_, v, _) -> v) fieldNames of + [] -> TupE [] + [f1] -> VarE f1 + f1 : rest -> + let helper lhs field = + InfixE + (Just lhs) + (ConE '(:&)) + (Just $ VarE field) + in foldl' helper (VarE f1) rest + + identInfo <- newName "identInfo" + -- 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. + [] + ] -- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance. sqlSelectColCountDec :: RecordInfo -> Q Dec @@ -418,7 +504,7 @@ sqlSelectProcessRowDec RecordInfo {..} = do FunD 'sqlSelectProcessRow [ Clause - [VarP colsName] + [WildP, VarP colsName] (NormalB bodyExp) -- `where` clause [ ValD @@ -530,7 +616,7 @@ takeColumns = StateT (\pvs -> splitAt targetColCount pvs in if length target == targetColCount then do - value <- sqlSelectProcessRow target + value <- sqlSelectProcessRow (Proxy @a) target Right (value, other) else Left "Insufficient columns when trying to parse a column") @@ -614,8 +700,9 @@ makeToAliasReferenceInstance info@RecordInfo {..} = do let overlap = Nothing instanceConstraints = [] instanceType = - (ConT ''ToAliasReference) - `AppT` (ConT sqlName) + ConT ''ToAliasReference + `AppT` ConT sqlName + `AppT` ConT sqlName pure $ InstanceD overlap instanceConstraints instanceType [toAliasReferenceDec'] toAliasReferenceDec :: RecordInfo -> Q Dec @@ -652,3 +739,269 @@ toAliasReferenceDec RecordInfo {..} = do [] ] +-- | Generates the declaration for an @SqlMaybe@-prefixed record, given the original +-- record's information. +makeSqlMaybeRecord :: RecordInfo -> Q Dec +makeSqlMaybeRecord RecordInfo {..} = do + let newConstructor = RecC sqlMaybeConstructorName (makeField `map` sqlMaybeFields) + derivingClauses = [] + pure $ DataD constraints sqlMaybeName typeVarBinders kind [newConstructor] derivingClauses + where + makeField (fieldName', fieldType) = + (fieldName', Bang NoSourceUnpackedness NoSourceStrictness, fieldType) + + +-- | Generates a `ToMaybe` instance for the given record. +makeToMaybeInstance :: RecordInfo -> Q Dec +makeToMaybeInstance info@RecordInfo {..} = do + toMaybeTDec' <- toMaybeTDec info + toMaybeDec' <- toMaybeDec info + let overlap = Nothing + instanceConstraints = [] + instanceType = (ConT ''ToMaybe) `AppT` (ConT sqlName) + + 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 value = ...` declaration for the given record. +toMaybeDec :: RecordInfo -> Q Dec +toMaybeDec RecordInfo {..} = do + (fieldPatterns, fieldExps) <- + unzip <$> forM (zip sqlFields sqlMaybeFields) (\((fieldName', _), (maybeFieldName', _)) -> do + fieldPatternName <- newName (nameBase fieldName') + pure + ( (fieldName', VarP fieldPatternName) + , (maybeFieldName', VarE 'toMaybe `AppE` VarE fieldPatternName) + )) + + pure $ + FunD + 'toMaybe + [ Clause + [ RecP sqlName fieldPatterns + ] + (NormalB $ RecConE sqlMaybeName fieldExps) + [] + ] + +-- | Generates an `SqlSelect` and 'SqlSelectCols' 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' + ] + + ] + +-- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance. +sqlMaybeSelectColsDec :: RecordInfo -> Q Dec +sqlMaybeSelectColsDec RecordInfo {..} = do + -- Pairs of record field names and local variable names. + fieldNames <- forM sqlMaybeFields (\(name', _type) -> do + var <- newName $ nameBase name' + pure (name', var)) + + -- Patterns binding record fields to local variables. + let fieldPatterns :: [FieldPat] + fieldPatterns = [(name', VarP var) | (name', var) <- fieldNames] + + -- Local variables for fields joined with `:&` in a single expression. + joinedFields :: Exp + joinedFields = + case snd `map` fieldNames of + [] -> TupE [] + [f1] -> VarE f1 + f1 : rest -> + let helper lhs field = + InfixE + (Just lhs) + (ConE '(:&)) + (Just $ VarE field) + in foldl' helper (VarE f1) rest + + identInfo <- newName "identInfo" + -- 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. + [] + ] + +-- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect` +-- instance. +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 + + fieldNames <- forM sqlFields $ \(name', typ) -> do + var <- newName $ nameBase name' + newTy <- sqlOp typ (VarE var) + pure (name', var, newTy) + + 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" + + let +#if MIN_VERSION_template_haskell(2,17,0) + bodyExp = DoE Nothing +#else + bodyExp = DoE +#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) + [] + ] + +-- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance. +sqlMaybeSelectColCountDec :: RecordInfo -> Q Dec +sqlMaybeSelectColCountDec RecordInfo {..} = do + let joinedTypes = + case snd `map` sqlMaybeFields of + [] -> TupleT 0 + t1 : rest -> + let helper lhs ty = + InfixT lhs ''(:&) ty + in foldl' helper t1 rest + + -- Roughly: + -- sqlSelectColCount _ = sqlSelectColCount (Proxy @($joinedTypes)) + pure $ + FunD + 'sqlSelectColCount + [ Clause + [WildP] + ( NormalB $ + AppE (VarE 'sqlSelectColCount) $ + ParensE $ + AppTypeE + (ConE 'Proxy) + joinedTypes + ) + -- `where` clause. + [] + ] + +-- | Statefully parse some number of columns from a list of `PersistValue`s, +-- where the number of columns to parse is determined by `sqlSelectColCount` +-- for @a@. +-- +-- This is used to implement `sqlSelectProcessRow` for records created with +-- `deriveEsqueletoRecord`. +takeMaybeColumns :: + forall a b. + (SqlSelect a (ToMaybeT b)) => + StateT [PersistValue] (Either Text) (ToMaybeT b) +takeMaybeColumns = StateT (\pvs -> + let targetColCount = + sqlSelectColCount (Proxy @a) + (target, other) = + splitAt targetColCount pvs + in if length target == targetColCount + then do + value <- sqlSelectProcessRow (Proxy @a) target + Right (value, other) + else Left "Insufficient columns when trying to parse a column") diff --git a/src/Database/Esqueleto/SQLite.hs b/src/Database/Esqueleto/SQLite.hs index f7adc1b5e..ff70e5e51 100644 --- a/src/Database/Esqueleto/SQLite.hs +++ b/src/Database/Esqueleto/SQLite.hs @@ -14,5 +14,5 @@ import Database.Esqueleto.Internal.PersistentImport -- because MySQL uses `rand()`. -- -- /Since: 2.6.0/ -random_ :: (PersistField a, Num a) => SqlExpr (Value a) +random_ :: (PersistField a, Num a) => SqlExpr_ ValueContext (Value a) random_ = unsafeSqlValue "RANDOM()" diff --git a/test/Common/LegacyTest.hs b/test/Common/LegacyTest.hs new file mode 100644 index 000000000..0b37380bd --- /dev/null +++ b/test/Common/LegacyTest.hs @@ -0,0 +1,2163 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +#if __GLASGOW_HASKELL__ >= 902 +{-# LANGUAGE OverloadedRecordDot #-} +#endif + +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} +module Common.LegacyTest + ( tests + , testLocking + , testAscRandom + , testRandomMath + , migrateAll + , migrateUnique + , cleanDB + , cleanUniques + , updateRethrowingQuery + , selectRethrowingQuery + , p1, p2, p3, p4, p5 + , l1, l2, l3 + , u1, u2, u3, u4 + , insert' + , EntityField (..) + , Foo (..) + , Bar (..) + , Person (..) + , BlogPost (..) + , Lord (..) + , Deed (..) + , Follow (..) + , CcList (..) + , Frontcover (..) + , Article (..) + , Tag (..) + , ArticleTag (..) + , Article2 (..) + , Point (..) + , Circle (..) + , Numbers (..) + , OneUnique(..) + , Unique(..) + , DateTruncTest(..) + , DateTruncTestId + , Key(..) + ) where + +import Common.Test.Import hiding (from, on) + +import Control.Monad (forM_, replicateM, replicateM_, void) +import qualified Data.Attoparsec.Text as AP +import Data.Char (toLower, toUpper) +import Data.Either +import Database.Esqueleto.Legacy + +import Data.Conduit (ConduitT, runConduit, (.|)) +import qualified Data.Conduit.List as CL +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.Text as Text +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Internal.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified Database.Esqueleto.Internal.ExprParser as P +import qualified Database.Esqueleto.Internal.Internal as EI +import Database.Persist.Class.PersistEntity +import qualified UnliftIO.Resource as R + +import Common.Record (testDeriveEsqueletoRecord) +import Common.Test.Select + +-- Test schema +-- | this could be achieved with S.fromList, but not all lists +-- have Ord instances +sameElementsAs :: Eq a => [a] -> [a] -> Bool +sameElementsAs l1' l2' = null (l1' L.\\ l2') + +-- | Helper for rounding to a specific digit +-- Prelude> map (flip roundTo 12.3456) [0..5] +-- [12.0, 12.3, 12.35, 12.346, 12.3456, 12.3456] +roundTo :: (Fractional a, RealFrac a1, Integral b) => b -> a1 -> a +roundTo n f = + (fromInteger $ round $ f * (10^n)) / (10.0^^n) + +p1 :: Person +p1 = Person "John" (Just 36) Nothing 1 + +p2 :: Person +p2 = Person "Rachel" Nothing (Just 37) 2 + +p3 :: Person +p3 = Person "Mike" (Just 17) Nothing 3 + +p4 :: Person +p4 = Person "Livia" (Just 17) (Just 18) 4 + +p5 :: Person +p5 = Person "Mitch" Nothing Nothing 5 + +l1 :: Lord +l1 = Lord "Cornwall" (Just 36) + +l2 :: Lord +l2 = Lord "Dorset" Nothing + +l3 :: Lord +l3 = Lord "Chester" (Just 17) + +u1 :: OneUnique +u1 = OneUnique "First" 0 + +u2 :: OneUnique +u2 = OneUnique "Second" 1 + +u3 :: OneUnique +u3 = OneUnique "Third" 0 + +u4 :: OneUnique +u4 = OneUnique "First" 2 + +testSubSelect :: SpecDb +testSubSelect = do + let setup :: MonadIO m => SqlPersistT m () + setup = do + _ <- insert $ Numbers 1 2 + _ <- insert $ Numbers 2 4 + _ <- insert $ Numbers 3 5 + _ <- insert $ Numbers 6 7 + pure () + + describe "subSelect" $ do + itDb "is safe for queries that may return multiple results" $ do + let query = + from $ \n -> do + orderBy [asc (n ^. NumbersInt)] + pure (n ^. NumbersInt) + setup + res <- select $ pure $ subSelect query + 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 = + from $ \n -> do + orderBy [asc (n ^. NumbersInt)] + limit 1 + pure (n ^. NumbersInt) + setup + 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 + let query = + from $ \n -> do + where_ $ n ^. NumbersInt `in_` do + subSelectList $ + from $ \n' -> do + where_ $ n' ^. NumbersInt >=. val 3 + pure (n' ^. NumbersInt) + pure n + empty <- select query + + full <- do + setup + select query + + asserting $ do + empty `shouldBe` [] + full `shouldSatisfy` (not . null) + + describe "subSelectMaybe" $ do + itDb "is equivalent to joinV . subSelect" $ do + let query selector = + from $ \n -> do + pure $ + selector $ + from $ \n' -> do + where_ $ n' ^. NumbersDouble >=. n ^. NumbersDouble + pure (max_ (n' ^. NumbersInt)) + + setup + a <- select (query subSelectMaybe) + b <- select (query (joinV . subSelect)) + asserting $ a `shouldBe` b + + describe "subSelectCount" $ do + itDb "is a safe way to do a countRows" $ do + setup + xs0 <- + select $ + from $ \n -> do + pure $ (,) n $ + subSelectCount @Int $ + from $ \n' -> do + where_ $ n' ^. NumbersInt >=. n ^. NumbersInt + + xs1 <- + select $ + from $ \n -> do + pure $ (,) n $ + subSelectUnsafe $ + from $ \n' -> do + where_ $ n' ^. NumbersInt >=. n ^. NumbersInt + pure countRows + + let getter (Entity _ a, b) = (a, b) + asserting $ + map getter xs0 `shouldBe` map getter xs1 + + describe "subSelectUnsafe" $ do + itDb "throws exceptions on multiple results" $ do + setup + eres <- try $ do + bad <- select $ + from $ \n -> do + pure $ (,) (n ^. NumbersInt) $ + subSelectUnsafe $ + from $ \n' -> do + pure (just (n' ^. NumbersDouble)) + good <- select $ + from $ \n -> do + pure $ (,) (n ^. NumbersInt) $ + subSelect $ + from $ \n' -> do + pure (n' ^. NumbersDouble) + pure (bad, good) + asserting $ case eres of + Left (SomeException _) -> + -- Must use SomeException because the database libraries throw their + -- own errors. + pure () + Right (bad, good) -> do + -- SQLite just takes the first element of the sub-select. lol. + bad `shouldBe` good + + itDb "throws exceptions on null results" $ do + setup + eres <- try $ do + select $ + from $ \n -> do + pure $ (,) (n ^. NumbersInt) $ + subSelectUnsafe $ + from $ \n' -> do + where_ $ val False + pure (n' ^. NumbersDouble) + asserting $ case eres of + Left (_ :: PersistException) -> + pure () + Right xs -> + xs `shouldBe` [] + +testSelectSource :: SpecDb +testSelectSource = do + describe "selectSource" $ do + itDb "works for a simple example" $ do + let query + :: ConduitT () (Entity Person) (SqlPersistT (R.ResourceT IO)) () + query = + selectSource $ + from $ \person -> + return (person :: SqlExpr (Entity Person)) + p1e <- insert' p1 + ret <- mapReaderT R.runResourceT $ runConduit $ query .| CL.consume + asserting $ ret `shouldBe` [ p1e ] + + itDb "can run a query many times" $ do + let query + :: ConduitT () (Entity Person) (SqlPersistT (R.ResourceT IO)) () + query = + selectSource $ + from $ \person -> + return (person :: SqlExpr (Entity Person)) + p1e <- insert' p1 + ret0 <- mapReaderT R.runResourceT $ runConduit $ query .| CL.consume + ret1 <- mapReaderT R.runResourceT $ runConduit $ query .| CL.consume + asserting $ do + ret0 `shouldBe` [ p1e ] + ret1 `shouldBe` [ p1e ] + + itDb "works on repro" $ do + let selectPerson :: R.MonadResource m => String -> ConduitT () (Key Person) (SqlPersistT m) () + selectPerson name = do + let source = + selectSource $ from $ \person -> do + where_ $ person ^. PersonName ==. val name + return $ person ^. PersonId + source .| CL.map unValue + p1e <- insert' p1 + p2e <- insert' p2 + r1 <- mapReaderT R.runResourceT $ runConduit $ selectPerson (personName p1) .| CL.consume + r2 <- mapReaderT R.runResourceT $ runConduit $ selectPerson (personName p2) .| CL.consume + asserting $ do + r1 `shouldBe` [ entityKey p1e ] + r2 `shouldBe` [ entityKey p2e ] + +testSelectFrom :: SpecDb +testSelectFrom = do + describe "select/from" $ do + itDb "works for a simple example" $ do + p1e <- insert' p1 + ret <- + select $ + from $ \person -> + return (person :: SqlExpr (Entity Person)) + asserting $ ret `shouldBe` [ p1e ] + + itDb "works for a simple self-join (one entity)" $ do + p1e <- insert' p1 + ret <- + select $ + from $ \(person1, person2) -> + return (person1 :: SqlExpr (Entity Person), person2 :: SqlExpr (Entity Person)) + asserting $ ret `shouldBe` [ (p1e, p1e) ] + + itDb "works for a simple self-join (two entities)" $ do + p1e <- insert' p1 + p2e <- insert' p2 + ret <- + select $ + from $ \(person1, person2) -> + return (person1 :: SqlExpr (Entity Person), person2 :: SqlExpr (Entity Person)) + asserting $ + ret + `shouldSatisfy` + sameElementsAs + [ (p1e, p1e) + , (p1e, p2e) + , (p2e, p1e) + , (p2e, p2e) + ] + + itDb "works for a self-join via sub_select" $ do + p1k <- insert p1 + p2k <- insert p2 + _f1k <- insert (Follow p1k p2k) + _f2k <- insert (Follow p2k p1k) + ret <- select $ + from $ \followA -> do + let subquery = + from $ \followB -> do + where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed + return $ followB ^. FollowFollower + where_ $ followA ^. FollowFollowed ==. sub_select subquery + return followA + asserting $ length ret `shouldBe` 2 + + itDb "works for a self-join via exists" $ do + p1k <- insert p1 + p2k <- insert p2 + _f1k <- insert (Follow p1k p2k) + _f2k <- insert (Follow p2k p1k) + ret <- select $ + from $ \followA -> do + where_ $ exists $ + from $ \followB -> + where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed + return followA + asserting $ length ret `shouldBe` 2 + + + itDb "works for a simple projection" $ do + p1k <- insert p1 + p2k <- insert p2 + ret <- select $ + from $ \p -> + return (p ^. PersonId, p ^. PersonName) + asserting $ ret `shouldBe` [ (Value p1k, Value (personName p1)) + , (Value p2k, Value (personName p2)) ] + + itDb "works for a simple projection with a simple implicit self-join" $ do + _ <- insert p1 + _ <- insert p2 + ret <- select $ + from $ \(pa, pb) -> + return (pa ^. PersonName, pb ^. PersonName) + asserting $ ret `shouldSatisfy` sameElementsAs + [ (Value (personName p1), Value (personName p1)) + , (Value (personName p1), Value (personName p2)) + , (Value (personName p2), Value (personName p1)) + , (Value (personName p2), Value (personName p2)) ] + + itDb "works with many kinds of LIMITs and OFFSETs" $ do + [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] + let people = + from $ \p -> do + orderBy [asc (p ^. PersonName)] + return p + ret1 <- + select $ do + p <- people + limit 2 + limit 1 + return p + asserting $ ret1 `shouldBe` [ p1e ] + ret2 <- + select $ do + p <- people + limit 1 + limit 2 + return p + asserting $ ret2 `shouldBe` [ p1e, p4e ] + ret3 <- + select $ do + p <- people + offset 3 + offset 2 + return p + asserting $ ret3 `shouldBe` [ p3e, p2e ] + ret4 <- + select $ do + p <- people + offset 3 + limit 5 + offset 2 + limit 3 + offset 1 + limit 2 + return p + asserting $ ret4 `shouldBe` [ p4e, p3e ] + ret5 <- + select $ do + p <- people + offset 1000 + limit 1 + limit 1000 + offset 0 + return p + asserting $ ret5 `shouldBe` [ p1e, p4e, p3e, p2e ] + + itDb "works when returning a custom non-composite primary key from a query" $ do + let name = "foo" + t = Tag name + Right thePk = keyFromValues [toPersistValue name] + tagPk <- insert t + [Value ret] <- select $ from $ \t' -> return (t'^.TagId) + asserting $ do + ret `shouldBe` thePk + thePk `shouldBe` tagPk + + itDb "works when returning a composite primary key from a query" $ do + let p = Point 10 20 "" + thePk <- insert p + [Value ppk] <- select $ from $ \p' -> return (p'^.PointId) + asserting $ ppk `shouldBe` thePk + +testSelectJoin :: SpecDb +testSelectJoin = do + describe "select:JOIN" $ do + itDb "works with a LEFT OUTER JOIN" $ + do + p1e <- insert' p1 + p2e <- insert' p2 + p3e <- insert' p3 + p4e <- insert' p4 + b12e <- insert' $ BlogPost "b" (entityKey p1e) + b11e <- insert' $ BlogPost "a" (entityKey p1e) + b31e <- insert' $ BlogPost "c" (entityKey p3e) + ret <- select $ + from $ \(p `LeftOuterJoin` mb) -> do + on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) + orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ] + return (p, mb) + asserting $ ret `shouldBe` [ (p1e, Just b11e) + , (p1e, Just b12e) + , (p4e, Nothing) + , (p3e, Just b31e) + , (p2e, Nothing) ] + + itDb "typechecks (A LEFT OUTER JOIN (B LEFT OUTER JOIN C))" $ + let + _x :: SqlPersistT IO _ + _x = + select $ + from $ \(a `LeftOuterJoin` (b `LeftOuterJoin` c)) -> + let _ = [a, b, c] :: [ SqlExpr (Entity Person) ] + in return a + in asserting noExceptions + + itDb "typechecks ((A LEFT OUTER JOIN B) LEFT OUTER JOIN C)" $ + let _x :: SqlPersistT IO _ + _x = + select $ + from $ \((a `LeftOuterJoin` b) `LeftOuterJoin` c) -> + let _ = [a, b, c] :: [ SqlExpr (Entity Person) ] + in return a + in asserting noExceptions + + itDb "throws an error for using on without joins" $ do + eres <- try $ select $ + from $ \(p, mb) -> do + on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) + orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ] + return (p, mb) + asserting $ shouldBeOnClauseWithoutMatchingJoinException eres + + itDb "throws an error for using too many ons" $ do + eres <- try $ select $ + from $ \(p `FullOuterJoin` mb) -> do + on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) + on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) + orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ] + return (p, mb) + asserting $ shouldBeOnClauseWithoutMatchingJoinException eres + + itDb "works with ForeignKey to a non-id primary key returning one entity" $ + do + let fc = Frontcover number "" + article = Article "Esqueleto supports composite pks!" number + number = 101 + Right thePk = keyFromValues [toPersistValue number] + fcPk <- insert fc + insert_ article + [Entity _ retFc] <- select $ + from $ \(a `InnerJoin` f) -> do + on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber) + return f + asserting $ do + retFc `shouldBe` fc + fcPk `shouldBe` thePk + itDb "allows using a primary key that is itself a key of another table" $ + do + let number = 101 + insert_ $ Frontcover number "" + articleId <- insert $ Article "title" number + articleMetaE <- insert' (ArticleMetadata articleId) + result <- select $ from $ \articleMetadata -> do + where_ $ (articleMetadata ^. ArticleMetadataId) ==. (val ((ArticleMetadataKey articleId))) + pure articleMetadata + asserting $ [articleMetaE] `shouldBe` result + itDb "allows joining between a primary key that is itself a key of another table, using ToBaseId" $ do + do + let number = 101 + insert_ $ Frontcover number "" + articleE@(Entity articleId _) <- insert' $ Article "title" number + articleMetaE <- insert' (ArticleMetadata articleId) + + articlesAndMetadata <- select $ + from $ \(article `InnerJoin` articleMetadata) -> do + on (toBaseId (articleMetadata ^. ArticleMetadataId) ==. article ^. ArticleId) + return (article, articleMetadata) + asserting $ [(articleE, articleMetaE)] `shouldBe` articlesAndMetadata + + itDb "works with a ForeignKey to a non-id primary key returning both entities" $ + do + let fc = Frontcover number "" + article = Article "Esqueleto supports composite pks!" number + number = 101 + Right thePk = keyFromValues [toPersistValue number] + fcPk <- insert fc + insert_ article + [(Entity _ retFc, Entity _ retArt)] <- select $ + from $ \(a `InnerJoin` f) -> do + on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber) + return (f, a) + asserting $ do + retFc `shouldBe` fc + retArt `shouldBe` article + fcPk `shouldBe` thePk + articleFkfrontcover retArt `shouldBe` thePk + + itDb "works with a non-id primary key returning one entity" $ + do + let fc = Frontcover number "" + article = Article2 "Esqueleto supports composite pks!" thePk + number = 101 + Right thePk = keyFromValues [toPersistValue number] + fcPk <- insert fc + insert_ article + [Entity _ retFc] <- select $ + from $ \(a `InnerJoin` f) -> do + on (f^.FrontcoverId ==. a^.Article2FrontcoverId) + return f + asserting $ do + retFc `shouldBe` fc + fcPk `shouldBe` thePk + + it "works with a composite primary key" $ \_ -> + pendingWith "Persistent does not create the CircleFkPoint constructor. See: https://github.com/yesodweb/persistent/issues/341" + {- + do + let p = Point x y "" + c = Circle x y "" + x = 10 + y = 15 + Right thePk = keyFromValues [toPersistValue x, toPersistValue y] + pPk <- insert p + insert_ c + [Entity _ ret] <- select $ from $ \(c' `InnerJoin` p') -> do + on (p'^.PointId ==. c'^.CircleFkpoint) + return p' + asserting $ do + ret `shouldBe` p + pPk `shouldBe` thePk + -} + + itDb "works when joining via a non-id primary key" $ + do + let fc = Frontcover number "" + article = Article "Esqueleto supports composite pks!" number + tag = Tag "foo" + otherTag = Tag "ignored" + number = 101 + insert_ fc + insert_ otherTag + artId <- insert article + tagId <- insert tag + insert_ $ ArticleTag artId tagId + [(Entity _ retArt, Entity _ retTag)] <- select $ + from $ \(a `InnerJoin` at `InnerJoin` t) -> do + on (t^.TagId ==. at^.ArticleTagTagId) + on (a^.ArticleId ==. at^.ArticleTagArticleId) + return (a, t) + asserting $ do + retArt `shouldBe` article + retTag `shouldBe` tag + + itDb "respects the associativity of joins" $ + do + void $ insert p1 + ps <- select $ from $ + \((p :: SqlExpr (Entity Person)) + `LeftOuterJoin` + ((_q :: SqlExpr (Entity Person)) + `InnerJoin` (_r :: SqlExpr (Entity Person)))) -> do + on (val False) -- Inner join is empty + on (val True) + return p + asserting $ (entityVal <$> ps) `shouldBe` [p1] + +testSelectWhere :: SpecDb +testSelectWhere = describe "select where_" $ do + itDb "works for a simple example with (==.)" $ do + p1e <- insert' p1 + _ <- insert' p2 + _ <- insert' p3 + ret <- select $ + from $ \p -> do + where_ (p ^. PersonName ==. val "John") + return p + asserting $ ret `shouldBe` [ p1e ] + + itDb "works for a simple example with (==.) and (||.)" $ do + p1e <- insert' p1 + p2e <- insert' p2 + _ <- insert' p3 + ret <- select $ + from $ \p -> do + where_ (p ^. PersonName ==. val "John" ||. p ^. PersonName ==. val "Rachel") + return p + asserting $ ret `shouldBe` [ p1e, p2e ] + + itDb "works for a simple example with (>.) [uses val . Just]" $ do + p1e <- insert' p1 + _ <- insert' p2 + _ <- insert' p3 + ret <- select $ + from $ \p -> do + where_ (p ^. PersonAge >. val (Just 17)) + return p + asserting $ ret `shouldBe` [ p1e ] + + itDb "works for a simple example with (>.) and not_ [uses just . val]" $ do + _ <- insert' p1 + _ <- insert' p2 + p3e <- insert' p3 + ret <- select $ + from $ \p -> do + where_ (not_ $ p ^. PersonAge >. just (val 17)) + return p + asserting $ ret `shouldBe` [ p3e ] + + describe "when using between" $ do + itDb "works for a simple example with [uses just . val]" $ do + p1e <- insert' p1 + _ <- insert' p2 + _ <- insert' p3 + ret <- select $ + from $ \p -> do + where_ ((p ^. PersonAge) `between` (just $ val 20, just $ val 40)) + return p + asserting $ ret `shouldBe` [ p1e ] + itDb "works for a proyected fields value" $ do + _ <- insert' p1 >> insert' p2 >> insert' p3 + ret <- + select $ + from $ \p -> do + where_ $ + just (p ^. PersonFavNum) + `between` + (p ^. PersonAge, p ^. PersonWeight) + asserting $ ret `shouldBe` [] + describe "when projecting composite keys" $ do + itDb "works when using composite keys with val" $ do + insert_ $ Point 1 2 "" + ret <- + select $ + from $ \p -> do + where_ $ + p ^. PointId + `between` + ( val $ PointKey 1 2 + , val $ PointKey 5 6 ) + asserting $ ret `shouldBe` [()] + + itDb "works with avg_" $ do + _ <- insert' p1 + _ <- insert' p2 + _ <- insert' p3 + _ <- insert' p4 + ret <- select $ + from $ \p-> + return $ joinV $ avg_ (p ^. PersonAge) + let testV :: Double + testV = roundTo (4 :: Integer) $ (36 + 17 + 17) / (3 :: Double) + + retV :: [Value (Maybe Double)] + retV = map (Value . fmap (roundTo (4 :: Integer)) . unValue) (ret :: [Value (Maybe Double)]) + asserting $ retV `shouldBe` [ Value $ Just testV ] + + itDb "works with min_" $ + do + _ <- insert' p1 + _ <- insert' p2 + _ <- insert' p3 + _ <- insert' p4 + ret <- select $ + from $ \p-> + return $ joinV $ min_ (p ^. PersonAge) + asserting $ ret `shouldBe` [ Value $ Just (17 :: Int) ] + + itDb "works with max_" $ do + _ <- insert' p1 + _ <- insert' p2 + _ <- insert' p3 + _ <- insert' p4 + ret <- select $ + from $ \p-> + return $ joinV $ max_ (p ^. PersonAge) + asserting $ ret `shouldBe` [ Value $ Just (36 :: Int) ] + + itDb "works with lower_" $ do + p1e <- insert' p1 + p2e@(Entity _ bob) <- insert' $ Person "bob" (Just 36) Nothing 1 + + -- lower(name) == 'john' + ret1 <- select $ + from $ \p-> do + where_ (lower_ (p ^. PersonName) ==. val (map toLower $ personName p1)) + return p + asserting $ ret1 `shouldBe` [ p1e ] + + -- name == lower('BOB') + ret2 <- select $ + from $ \p-> do + where_ (p ^. PersonName ==. lower_ (val $ map toUpper $ personName bob)) + return p + asserting $ ret2 `shouldBe` [ p2e ] + + itDb "works with round_" $ do + ret <- select $ return $ round_ (val (16.2 :: Double)) + asserting $ ret `shouldBe` [ Value (16 :: Double) ] + + itDb "works with isNothing" $ do + _ <- insert' p1 + p2e <- insert' p2 + _ <- insert' p3 + ret <- select $ + from $ \p -> do + where_ $ isNothing (p ^. PersonAge) + return p + asserting $ ret `shouldBe` [ p2e ] + + itDb "works with not_ . isNothing" $ do + p1e <- insert' p1 + _ <- insert' p2 + ret <- select $ + from $ \p -> do + where_ $ not_ (isNothing (p ^. PersonAge)) + return p + asserting $ ret `shouldBe` [ p1e ] + + itDb "works for a many-to-many implicit join" $ + do + p1e@(Entity p1k _) <- insert' p1 + p2e@(Entity p2k _) <- insert' p2 + _ <- insert' p3 + p4e@(Entity p4k _) <- insert' p4 + f12 <- insert' (Follow p1k p2k) + f21 <- insert' (Follow p2k p1k) + f42 <- insert' (Follow p4k p2k) + f11 <- insert' (Follow p1k p1k) + ret <- select $ + from $ \(follower, follows, followed) -> do + where_ $ follower ^. PersonId ==. follows ^. FollowFollower &&. + followed ^. PersonId ==. follows ^. FollowFollowed + orderBy [ asc (follower ^. PersonName) + , asc (followed ^. PersonName) ] + return (follower, follows, followed) + asserting $ ret `shouldBe` [ (p1e, f11, p1e) + , (p1e, f12, p2e) + , (p4e, f42, p2e) + , (p2e, f21, p1e) ] + + itDb "works for a many-to-many explicit join" $ do + p1e@(Entity p1k _) <- insert' p1 + p2e@(Entity p2k _) <- insert' p2 + _ <- insert' p3 + p4e@(Entity p4k _) <- insert' p4 + f12 <- insert' (Follow p1k p2k) + f21 <- insert' (Follow p2k p1k) + f42 <- insert' (Follow p4k p2k) + f11 <- insert' (Follow p1k p1k) + ret <- select $ + from $ \(follower `InnerJoin` follows `InnerJoin` followed) -> do + on $ followed ^. PersonId ==. follows ^. FollowFollowed + on $ follower ^. PersonId ==. follows ^. FollowFollower + orderBy [ asc (follower ^. PersonName) + , asc (followed ^. PersonName) ] + return (follower, follows, followed) + asserting $ ret `shouldBe` [ (p1e, f11, p1e) + , (p1e, f12, p2e) + , (p4e, f42, p2e) + , (p2e, f21, p1e) ] + + itDb "works for a many-to-many explicit join and on order doesn't matter" $ do + void $ + selectRethrowingQuery $ + from $ \(person `InnerJoin` blog `InnerJoin` comment) -> do + on $ person ^. PersonId ==. blog ^. BlogPostAuthorId + on $ blog ^. BlogPostId ==. comment ^. CommentBlog + pure (person, comment) + + -- we only care that we don't have a SQL error + asserting noExceptions + + itDb "works for a many-to-many explicit join with LEFT OUTER JOINs" $ do + p1e@(Entity p1k _) <- insert' p1 + p2e@(Entity p2k _) <- insert' p2 + p3e <- insert' p3 + p4e@(Entity p4k _) <- insert' p4 + f12 <- insert' (Follow p1k p2k) + f21 <- insert' (Follow p2k p1k) + f42 <- insert' (Follow p4k p2k) + f11 <- insert' (Follow p1k p1k) + ret <- select $ + from $ \(follower `LeftOuterJoin` mfollows `LeftOuterJoin` mfollowed) -> do + on $ mfollowed ?. PersonId ==. mfollows ?. FollowFollowed + on $ just (follower ^. PersonId) ==. mfollows ?. FollowFollower + orderBy [ asc ( follower ^. PersonName) + , asc (mfollowed ?. PersonName) ] + return (follower, mfollows, mfollowed) + asserting $ ret `shouldBe` [ (p1e, Just f11, Just p1e) + , (p1e, Just f12, Just p2e) + , (p4e, Just f42, Just p2e) + , (p3e, Nothing, Nothing) + , (p2e, Just f21, Just p1e) ] + + itDb "works with a composite primary key" $ do + let p = Point x y "" + x = 10 + y = 15 + Right thePk = keyFromValues [toPersistValue x, toPersistValue y] + pPk <- insert p + [Entity _ ret] <- select $ from $ \p' -> do + where_ (p'^.PointId ==. val pPk) + return p' + asserting $ do + ret `shouldBe` p + pPk `shouldBe` thePk + +testSelectOrderBy :: SpecDb +testSelectOrderBy = describe "select/orderBy" $ do + itDb "works with a single ASC field" $ do + p1e <- insert' p1 + p2e <- insert' p2 + p3e <- insert' p3 + ret <- select $ + from $ \p -> do + orderBy [asc $ p ^. PersonName] + return p + asserting $ ret `shouldBe` [ p1e, p3e, p2e ] + + itDb "works with a sub_select" $ do + [p1k, p2k, p3k, p4k] <- mapM insert [p1, p2, p3, p4] + [b1k, b2k, b3k, b4k] <- mapM (insert . BlogPost "") [p1k, p2k, p3k, p4k] + ret <- select $ + from $ \b -> do + orderBy [desc $ sub_select $ + from $ \p -> do + where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) + return (p ^. PersonName) + ] + return (b ^. BlogPostId) + asserting $ ret `shouldBe` (Value <$> [b2k, b3k, b4k, b1k]) + + itDb "works on a composite primary key" $ do + let ps = [Point 2 1 "", Point 1 2 ""] + mapM_ insert ps + eps <- select $ + from $ \p' -> do + orderBy [asc (p'^.PointId)] + return p' + asserting $ map entityVal eps `shouldBe` reverse ps + +testAscRandom :: SqlExpr (Value Double) -> SpecDb +testAscRandom rand' = describe "random_" $ + itDb "asc random_ works" $ do + _p1e <- insert' p1 + _p2e <- insert' p2 + _p3e <- insert' p3 + _p4e <- insert' p4 + rets <- + fmap S.fromList $ + replicateM 11 $ + select $ + from $ \p -> do + orderBy [asc (rand' :: SqlExpr (Value Double))] + return (p ^. PersonId :: SqlExpr (Value PersonId)) + -- There are 2^4 = 16 possible orderings. The chance + -- of 11 random samplings returning the same ordering + -- is 1/2^40, so this test should pass almost everytime. + asserting $ S.size rets `shouldSatisfy` (>2) + +testSelectDistinct :: SpecDb +testSelectDistinct = do + describe "SELECT DISTINCT" $ do + let selDistTest + :: + ( SqlQuery (SqlExpr (Value String)) + -> SqlPersistT IO [Value String] + ) + -> SqlPersistT IO () + selDistTest q = do + p1k <- insert p1 + let (t1, t2, t3) = ("a", "b", "c") + mapM_ (insert . flip BlogPost p1k) [t1, t3, t2, t2, t1] + ret <- q $ + from $ \b -> do + let title = b ^. BlogPostTitle + orderBy [asc title] + return title + asserting $ ret `shouldBe` [ Value t1, Value t2, Value t3 ] + + itDb "works on a simple example (select . distinct)" $ + selDistTest (\a -> select $ distinct a) + + itDb "works on a simple example (distinct (return ()))" $ + selDistTest (\act -> select $ distinct (return ()) >> act) + + + +testCoasleceDefault :: SpecDb +testCoasleceDefault = describe "coalesce/coalesceDefault" $ do + itDb "works on a simple example" $ do + mapM_ insert' [p1, p2, p3, p4, p5] + ret1 <- select $ + from $ \p -> do + orderBy [asc (p ^. PersonId)] + return (coalesce [p ^. PersonAge, p ^. PersonWeight]) + asserting $ ret1 `shouldBe` [ Value (Just (36 :: Int)) + , Value (Just 37) + , Value (Just 17) + , Value (Just 17) + , Value Nothing + ] + + ret2 <- select $ + from $ \p -> do + orderBy [asc (p ^. PersonId)] + return (coalesceDefault [p ^. PersonAge, p ^. PersonWeight] (p ^. PersonFavNum)) + asserting $ ret2 `shouldBe` [ Value (36 :: Int) + , Value 37 + , Value 17 + , Value 17 + , Value 5 + ] + + itDb "works with sub-queries" $ do + p1id <- insert p1 + p2id <- insert p2 + p3id <- insert p3 + _ <- insert p4 + _ <- insert p5 + _ <- insert $ BlogPost "a" p1id + _ <- insert $ BlogPost "b" p2id + _ <- insert $ BlogPost "c" p3id + ret <- select $ + from $ \b -> do + let sub = + from $ \p -> do + where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) + return $ p ^. PersonAge + return $ coalesceDefault [sub_select sub] (val (42 :: Int)) + asserting $ ret `shouldBe` [ Value (36 :: Int) + , Value 42 + , Value 17 + ] + + +testDelete :: SpecDb +testDelete = describe "delete" $ do + itDb "works on a simple example" $ do + p1e <- insert' p1 + p2e <- insert' p2 + p3e <- insert' p3 + let getAll = select $ + from $ \p -> do + orderBy [asc (p ^. PersonName)] + return p + ret1 <- getAll + asserting $ ret1 `shouldBe` [ p1e, p3e, p2e ] + () <- delete $ + from $ \p -> + where_ (p ^. PersonName ==. val (personName p1)) + ret2 <- getAll + asserting $ ret2 `shouldBe` [ p3e, p2e ] + n <- deleteCount $ + from $ \p -> + return ((p :: SqlExpr (Entity Person)) `seq` ()) + ret3 <- getAll + asserting $ (n, ret3) `shouldBe` (2, []) + +testUpdate :: SpecDb +testUpdate = describe "update" $ do + itDb "works with a subexpression having COUNT(*)" $ do + p1k <- insert p1 + p2k <- insert p2 + p3k <- insert p3 + replicateM_ 3 (insert $ BlogPost "" p1k) + replicateM_ 7 (insert $ BlogPost "" p3k) + let blogPostsBy p = + from $ \b -> do + where_ (b ^. BlogPostAuthorId ==. p ^. PersonId) + return countRows + () <- update $ \p -> do + set p [ PersonAge =. just (sub_select (blogPostsBy p)) ] + ret <- select $ + from $ \p -> do + orderBy [ asc (p ^. PersonName) ] + return p + asserting $ ret `shouldBe` [ Entity p1k p1 { personAge = Just 3 } + , Entity p3k p3 { personAge = Just 7 } + , Entity p2k p2 { personAge = Just 0 } ] + + it "works with a composite primary key" $ \_ -> + pendingWith "Need refactor to support composite pks on ESet" + {- + do + let p = Point x y "" + x = 10 + y = 15 + newX = 20 + newY = 25 + Right newPk = keyFromValues [toPersistValue newX, toPersistValue newY] + insert_ p + () <- update $ \p' -> do + set p' [PointId =. val newPk] + [Entity _ ret] <- select $ from $ return + asserting $ do + ret `shouldBe` Point newX newY [] + -} + + itDb "GROUP BY works with COUNT" $ do + p1k <- insert p1 + p2k <- insert p2 + p3k <- insert p3 + replicateM_ 3 (insert $ BlogPost "" p1k) + replicateM_ 7 (insert $ BlogPost "" p3k) + ret <- select $ + from $ \(p `LeftOuterJoin` b) -> do + on (p ^. PersonId ==. b ^. BlogPostAuthorId) + groupBy (p ^. PersonId) + let cnt = count (b ^. BlogPostId) + orderBy [ asc cnt ] + return (p, cnt) + asserting $ ret `shouldBe` [ (Entity p2k p2, Value (0 :: Int)) + , (Entity p1k p1, Value 3) + , (Entity p3k p3, Value 7) ] + + itDb "GROUP BY works with composite primary key" $ do + p1k <- insert $ Point 1 2 "asdf" + p2k <- insert $ Point 2 3 "asdf" + ret <- + selectRethrowingQuery $ + from $ \point -> do + where_ $ point ^. PointName ==. val "asdf" + groupBy (point ^. PointId) + pure (point ^. PointId) + asserting $ do + ret `shouldMatchList` + map Value [p1k, p2k] + + + + itDb "GROUP BY works with COUNT and InnerJoin" $ do + l1k <- insert l1 + l3k <- insert l3 + mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int]) + + mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) + + (ret :: [(Value (Key Lord), Value Int)]) <- select $ from $ + \ ( lord `InnerJoin` deed ) -> do + on $ lord ^. LordId ==. deed ^. DeedOwnerId + groupBy (lord ^. LordId) + return (lord ^. LordId, count $ deed ^. DeedId) + asserting $ ret `shouldMatchList` [ (Value l3k, Value 7) + , (Value l1k, Value 3) ] + + itDb "GROUP BY works with nested tuples" $ do + l1k <- insert l1 + l3k <- insert l3 + mapM_ (\k -> insert $ Deed k l1k) (map show [1..3 :: Int]) + + mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) + + (ret :: [(Value (Key Lord), Value Int)]) <- select $ from $ + \ ( lord `InnerJoin` deed ) -> do + on $ lord ^. LordId ==. deed ^. DeedOwnerId + groupBy ((lord ^. LordId, lord ^. LordDogs), deed ^. DeedContract) + return (lord ^. LordId, count $ deed ^. DeedId) + asserting $ length ret `shouldBe` 10 + + itDb "GROUP BY works with HAVING" $ do + p1k <- insert p1 + _p2k <- insert p2 + p3k <- insert p3 + replicateM_ 3 (insert $ BlogPost "" p1k) + replicateM_ 7 (insert $ BlogPost "" p3k) + ret <- select $ + from $ \(p `LeftOuterJoin` b) -> do + on (p ^. PersonId ==. b ^. BlogPostAuthorId) + let cnt = count (b ^. BlogPostId) + groupBy (p ^. PersonId) + having (cnt >. (val 0)) + orderBy [ asc cnt ] + return (p, cnt) + asserting $ ret `shouldBe` [ (Entity p1k p1, Value (3 :: Int)) + , (Entity p3k p3, Value 7) ] + +-- we only care that this compiles. check that SqlWriteT doesn't fail on +-- updates. +testSqlWriteT :: MonadIO m => SqlWriteT m () +testSqlWriteT = + update $ \p -> do + set p [ PersonAge =. just (val 6) ] + +-- we only care that this compiles. checks that the SqlWriteT monad can run +-- select queries. +testSqlWriteTRead :: MonadIO m => SqlWriteT m [(Value (Key Lord), Value Int)] +testSqlWriteTRead = + select $ + from $ \ ( lord `InnerJoin` deed ) -> do + on $ lord ^. LordId ==. deed ^. DeedOwnerId + groupBy (lord ^. LordId) + return (lord ^. LordId, count $ deed ^. DeedId) + +-- we only care that this compiles checks that SqlReadT allows +testSqlReadT :: MonadIO m => SqlReadT m [(Value (Key Lord), Value Int)] +testSqlReadT = + select $ + from $ \ ( lord `InnerJoin` deed ) -> do + on $ lord ^. LordId ==. deed ^. DeedOwnerId + groupBy (lord ^. LordId) + return (lord ^. LordId, count $ deed ^. DeedId) + +testListOfValues :: SpecDb +testListOfValues = describe "lists of values" $ do + itDb "IN works for valList" $ do + p1k <- insert p1 + p2k <- insert p2 + _p3k <- insert p3 + ret <- select $ + from $ \p -> do + where_ (p ^. PersonName `in_` valList (personName <$> [p1, p2])) + return p + asserting $ ret `shouldBe` [ Entity p1k p1 + , Entity p2k p2 ] + + itDb "IN works for valList (null list)" $ do + _p1k <- insert p1 + _p2k <- insert p2 + _p3k <- insert p3 + ret <- select $ + from $ \p -> do + where_ (p ^. PersonName `in_` valList []) + return p + asserting $ ret `shouldBe` [] + + itDb "IN works for subList_select" $ do + p1k <- insert p1 + _p2k <- insert p2 + p3k <- insert p3 + _ <- insert (BlogPost "" p1k) + _ <- insert (BlogPost "" p3k) + ret <- select $ + from $ \p -> do + let subquery = + from $ \bp -> do + orderBy [ asc (bp ^. BlogPostAuthorId) ] + return (bp ^. BlogPostAuthorId) + where_ (p ^. PersonId `in_` subList_select subquery) + return p + asserting $ L.sort ret `shouldBe` L.sort [Entity p1k p1, Entity p3k p3] + + itDb "NOT IN works for subList_select" $ do + p1k <- insert p1 + p2k <- insert p2 + p3k <- insert p3 + _ <- insert (BlogPost "" p1k) + _ <- insert (BlogPost "" p3k) + ret <- select $ + from $ \p -> do + let subquery = + from $ \bp -> + return (bp ^. BlogPostAuthorId) + where_ (p ^. PersonId `notIn` subList_select subquery) + return p + asserting $ ret `shouldBe` [ Entity p2k p2 ] + + itDb "NOT IN works for valList (null list)" $ do + p1k <- insert p1 + p2k <- insert p2 + p3k <- insert p3 + ret <- select $ + from $ \p -> do + where_ (p ^. PersonName `notIn` valList []) + return p + asserting $ ret `shouldMatchList` [ Entity p1k p1 + , Entity p2k p2 + , Entity p3k p3 + ] + + itDb "EXISTS works for subList_select" $ do + p1k <- insert p1 + _p2k <- insert p2 + p3k <- insert p3 + _ <- insert (BlogPost "" p1k) + _ <- insert (BlogPost "" p3k) + ret <- select $ + from $ \p -> do + where_ $ exists $ + from $ \bp -> do + where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId) + orderBy [asc (p ^. PersonName)] + return p + asserting $ ret `shouldBe` [ Entity p1k p1 + , Entity p3k p3 ] + + itDb "EXISTS works for subList_select" $ do + p1k <- insert p1 + p2k <- insert p2 + p3k <- insert p3 + _ <- insert (BlogPost "" p1k) + _ <- insert (BlogPost "" p3k) + ret <- select $ + from $ \p -> do + where_ $ notExists $ + from $ \bp -> do + where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId) + return p + asserting $ ret `shouldBe` [ Entity p2k p2 ] + +testListFields :: SpecDb +testListFields = describe "list fields" $ do + -- + itDb "can update list fields" $ do + cclist <- insert $ CcList [] + update $ \p -> do + set p [ CcListNames =. val ["fred"]] + where_ (p ^. CcListId ==. val cclist) + asserting noExceptions + +testInsertsBySelect :: SpecDb +testInsertsBySelect = do + describe "inserts by select" $ do + itDb "IN works for insertSelect" $ + do + _ <- insert p1 + _ <- insert p2 + _ <- insert p3 + insertSelect $ from $ \p -> do + return $ BlogPost <# val "FakePost" <&> (p ^. PersonId) + ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows) + asserting $ ret `shouldBe` [Value (3::Int)] + + + + + +testInsertsBySelectReturnsCount :: SpecDb +testInsertsBySelectReturnsCount = do + describe "inserts by select, returns count" $ do + itDb "IN works for insertSelectCount" $ + do + _ <- insert p1 + _ <- insert p2 + _ <- insert p3 + cnt <- insertSelectCount $ from $ \p -> do + return $ BlogPost <# val "FakePost" <&> (p ^. PersonId) + ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows) + asserting $ ret `shouldBe` [Value (3::Int)] + asserting $ cnt `shouldBe` 3 + + + + +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 + itDb "castNum works for multiplying Int and Double" $ + do + mapM_ insert [Numbers 2 3.4, Numbers 7 1.1] + ret <- + select $ + from $ \n -> do + let r = castNum (n ^. NumbersInt) *. n ^. NumbersDouble + orderBy [asc r] + return r + asserting $ length ret `shouldBe` 2 + let [Value a, Value b] = ret + asserting $ max (abs (a - 6.8)) (abs (b - 7.7)) `shouldSatisfy` (< 0.01) + + + + + +testCase :: SpecDb +testCase = do + describe "case" $ do + itDb "Works for a simple value based when - False" $ + do + ret <- select $ + return $ + case_ + [ when_ (val False) then_ (val (1 :: Int)) ] + (else_ (val 2)) + + asserting $ ret `shouldBe` [ Value 2 ] + + itDb "Works for a simple value based when - True" $ + do + ret <- select $ + return $ + case_ + [ when_ (val True) then_ (val (1 :: Int)) ] + (else_ (val 2)) + + asserting $ ret `shouldBe` [ Value 1 ] + + itDb "works for a semi-complicated query" $ + do + _ <- insert p1 + _ <- insert p2 + _ <- insert p3 + _ <- insert p4 + _ <- insert p5 + ret <- select $ + return $ + case_ + [ when_ + (exists $ from $ \p -> do + where_ (p ^. PersonName ==. val "Mike")) + then_ + (sub_select $ from $ \v -> do + let sub = + from $ \c -> do + where_ (c ^. PersonName ==. val "Mike") + return (c ^. PersonFavNum) + where_ (v ^. PersonFavNum >. sub_select sub) + return $ count (v ^. PersonName) +. val (1 :: Int)) ] + (else_ $ val (-1)) + + asserting $ ret `shouldBe` [ Value (3) ] + +testLocking :: SpecDb +testLocking = do + let toText conn q = + let (tlb, _) = EI.toRawSql EI.SELECT (conn, EI.initialIdentState) q + in TLB.toLazyText tlb + complexQuery = + from $ \(p1' `InnerJoin` p2') -> do + on (p1' ^. PersonName ==. p2' ^. PersonName) + where_ (p1' ^. PersonFavNum >. val 2) + orderBy [desc (p2' ^. PersonAge)] + limit 3 + offset 9 + groupBy (p1' ^. PersonId) + having (countRows <. val (0 :: Int)) + return (p1', p2') + describe "locking" $ do + -- The locking clause is the last one, so try to use many + -- others to test if it's at the right position. We don't + -- care about the text of the rest, nor with the RDBMS' + -- reaction to the clause. + let sanityCheck kind syntax = do + let queryWithClause1 = do + r <- complexQuery + locking kind + return r + queryWithClause2 = do + locking ForUpdate + r <- complexQuery + locking ForShare + locking kind + return r + queryWithClause3 = do + locking kind + complexQuery + conn <- ask + [complex, with1, with2, with3] <- + return $ + map (toText conn) [complexQuery, queryWithClause1, queryWithClause2, queryWithClause3] + let expected = complex <> syntax + asserting $ do + TL.strip with1 `shouldBe` expected + TL.strip with2 `shouldBe` expected + TL.strip with3 `shouldBe` expected + itDb "looks sane for ForUpdate" $ sanityCheck ForUpdate "FOR UPDATE" + itDb "looks sane for ForUpdateSkipLocked" $ sanityCheck ForUpdateSkipLocked "FOR UPDATE SKIP LOCKED" + itDb "looks sane for ForShare" $ sanityCheck ForShare "FOR SHARE" + itDb "looks sane for LockInShareMode" $ sanityCheck LockInShareMode "LOCK IN SHARE MODE" + +testCountingRows :: SpecDb +testCountingRows = do + describe "counting rows" $ do + let cases = + [ ("count (test A)", count . (^. PersonAge), 4) + , ("count (test B)", count . (^. PersonWeight), 5) + , ("countRows", const countRows, 5) + , ("countDistinct", countDistinct . (^. PersonAge), 2) + ] + forM_ cases $ \(title, countKind, expected) -> do + itDb (title ++ " works as expected") $ do + insertMany_ + [ Person "" (Just 1) (Just 1) 1 + , Person "" (Just 2) (Just 1) 1 + , Person "" (Just 2) (Just 1) 1 + , Person "" (Just 2) (Just 2) 1 + , Person "" Nothing (Just 3) 1 + ] + [Value n] <- select $ from $ return . countKind + asserting $ (n :: Int) `shouldBe` expected + +testRenderSql :: SpecDb +testRenderSql = do + describe "testRenderSql" $ do + itDb "works" $ do + (queryText, queryVals) <- renderQuerySelect $ + from $ \p -> do + where_ $ p ^. PersonName ==. val "Johhny Depp" + pure (p ^. PersonName, p ^. PersonAge) + -- the different backends use different quote marks, so I filter them out + -- here instead of making a duplicate test + asserting $ do + Text.filter (\c -> c `notElem` ['`', '"']) queryText + `shouldBe` + Text.unlines + [ "SELECT Person.name, Person.age" + , "FROM Person" + , "WHERE Person.name = ?" + ] + queryVals + `shouldBe` + [toPersistValue ("Johhny Depp" :: TL.Text)] + + describe "renderExpr" $ do + itDb "renders a value" $ do + (c, expr) <- do + conn <- ask + let Right c = P.mkEscapeChar conn + let user = EI.unsafeSqlEntity (EI.I "user") + blogPost = EI.unsafeSqlEntity (EI.I "blog_post") + pure $ (,) c $ EI.renderExpr conn $ + user ^. PersonId ==. blogPost ^. BlogPostAuthorId + asserting $ do + expr + `shouldBe` + Text.intercalate (Text.singleton c) ["", "user", ".", "id", ""] + <> + " = " + <> + Text.intercalate (Text.singleton c) ["", "blog_post", ".", "authorId", ""] + + itDb "renders ? for a val" $ do + expr <- ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1)) + asserting $ expr `shouldBe` "? = ?" + + beforeWith (\_ -> pure ()) $ describe "ExprParser" $ do + let parse parser = AP.parseOnly (parser '#') + describe "parseEscapedChars" $ do + let subject = parse P.parseEscapedChars + it "parses words" $ do + subject "hello world" + `shouldBe` + Right "hello world" + it "only returns a single escape-char if present" $ do + subject "i_am##identifier##" + `shouldBe` + Right "i_am#identifier#" + describe "parseEscapedIdentifier" $ do + let subject = parse P.parseEscapedIdentifier + it "parses the quotes out" $ do + subject "#it's a me, mario#" + `shouldBe` + Right "it's a me, mario" + it "requires a beginning and end quote" $ do + subject "#alas, i have no end" + `shouldSatisfy` + isLeft + describe "parseTableAccess" $ do + let subject = parse P.parseTableAccess + it "parses a table access" $ do + subject "#foo#.#bar#" + `shouldBe` + Right P.TableAccess + { P.tableAccessTable = "foo" + , P.tableAccessColumn = "bar" + } + describe "onExpr" $ do + let subject = parse P.onExpr + it "works" $ do + subject "#foo#.#bar# = #bar#.#baz#" + `shouldBe` do + Right $ S.fromList + [ P.TableAccess + { P.tableAccessTable = "foo" + , P.tableAccessColumn = "bar" + } + , P.TableAccess + { P.tableAccessTable = "bar" + , P.tableAccessColumn = "baz" + } + ] + it "also works with other nonsense" $ do + subject "#foo#.#bar# = 3" + `shouldBe` do + Right $ S.fromList + [ P.TableAccess + { P.tableAccessTable = "foo" + , P.tableAccessColumn = "bar" + } + ] + it "handles a conjunction" $ do + subject "#foo#.#bar# = #bar#.#baz# AND #bar#.#baz# > 10" + `shouldBe` do + Right $ S.fromList + [ P.TableAccess + { P.tableAccessTable = "foo" + , P.tableAccessColumn = "bar" + } + , P.TableAccess + { P.tableAccessTable = "bar" + , P.tableAccessColumn = "baz" + } + ] + it "handles ? okay" $ do + subject "#foo#.#bar# = ?" + `shouldBe` do + Right $ S.fromList + [ P.TableAccess + { P.tableAccessTable = "foo" + , P.tableAccessColumn = "bar" + } + ] + it "handles degenerate cases" $ do + subject "false" `shouldBe` pure mempty + subject "true" `shouldBe` pure mempty + subject "1 = 1" `shouldBe` pure mempty + it "works even if an identifier isn't first" $ do + subject "true and #foo#.#bar# = 2" + `shouldBe` do + Right $ S.fromList + [ P.TableAccess + { P.tableAccessTable = "foo" + , P.tableAccessColumn = "bar" + } + ] + +testOnClauseOrder :: SpecDb +testOnClauseOrder = describe "On Clause Ordering" $ do + let + setup :: MonadIO m => SqlPersistT m () + setup = do + ja1 <- insert (JoinOne "j1 hello") + ja2 <- insert (JoinOne "j1 world") + jb1 <- insert (JoinTwo ja1 "j2 hello") + jb2 <- insert (JoinTwo ja1 "j2 world") + jb3 <- insert (JoinTwo ja2 "j2 foo") + _ <- insert (JoinTwo ja2 "j2 bar") + jc1 <- insert (JoinThree jb1 "j3 hello") + jc2 <- insert (JoinThree jb1 "j3 world") + _ <- insert (JoinThree jb2 "j3 foo") + _ <- insert (JoinThree jb3 "j3 bar") + _ <- insert (JoinThree jb3 "j3 baz") + _ <- insert (JoinFour "j4 foo" jc1) + _ <- insert (JoinFour "j4 bar" jc2) + jd1 <- insert (JoinOther "foo") + jd2 <- insert (JoinOther "bar") + _ <- insert (JoinMany "jm foo hello" jd1 ja1) + _ <- insert (JoinMany "jm foo world" jd1 ja2) + _ <- insert (JoinMany "jm bar hello" jd2 ja1) + _ <- insert (JoinMany "jm bar world" jd2 ja2) + pure () + describe "identical results for" $ do + itDb "three tables" $ do + setup + abcs <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c) -> do + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + pure (a, b, c) + acbs <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c) -> do + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + pure (a, b, c) + + asserting $ do + listsEqualOn abcs acbs $ \(Entity _ j1, Entity _ j2, Entity _ j3) -> + (joinOneName j1, joinTwoName j2, joinThreeName j3) + + itDb "four tables" $ do + setup + xs0 <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + pure (a, b, c, d) + xs1 <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + pure (a, b, c, d) + xs2 <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + pure (a, b, c, d) + xs3 <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + pure (a, b, c, d) + xs4 <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + pure (a, b, c, d) + + let + getNames (j1, j2, j3, j4) = + ( joinOneName (entityVal j1) + , joinTwoName (entityVal j2) + , joinThreeName (entityVal j3) + , joinFourName (entityVal j4) + ) + asserting $ do + listsEqualOn xs0 xs1 getNames + listsEqualOn xs0 xs2 getNames + listsEqualOn xs0 xs3 getNames + listsEqualOn xs0 xs4 getNames + + itDb "associativity of innerjoin" $ do + setup + xs0 <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + pure (a, b, c, d) + + xs1 <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` (c `InnerJoin` d)) -> do + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + pure (a, b, c, d) + + xs2 <- + select $ + from $ \(a `InnerJoin` (b `InnerJoin` c) `InnerJoin` d) -> do + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + pure (a, b, c, d) + + xs3 <- + select $ + from $ \(a `InnerJoin` (b `InnerJoin` c `InnerJoin` d)) -> do + on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) + on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) + on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) + pure (a, b, c, d) + + let getNames (j1, j2, j3, j4) = + ( joinOneName (entityVal j1) + , joinTwoName (entityVal j2) + , joinThreeName (entityVal j3) + , joinFourName (entityVal j4) + ) + asserting $ do + listsEqualOn xs0 xs1 getNames + listsEqualOn xs0 xs2 getNames + listsEqualOn xs0 xs3 getNames + + itDb "inner join on two entities" $ do + (xs0, xs1) <- do + pid <- insert $ Person "hello" Nothing Nothing 3 + _ <- insert $ BlogPost "good poast" pid + _ <- insert $ Profile "cool" pid + xs0 <- selectRethrowingQuery $ + from $ \(p `InnerJoin` b `InnerJoin` pr) -> do + on $ p ^. PersonId ==. b ^. BlogPostAuthorId + on $ p ^. PersonId ==. pr ^. ProfilePerson + pure (p, b, pr) + xs1 <- selectRethrowingQuery $ + from $ \(p `InnerJoin` b `InnerJoin` pr) -> do + on $ p ^. PersonId ==. pr ^. ProfilePerson + on $ p ^. PersonId ==. b ^. BlogPostAuthorId + pure (p, b, pr) + pure (xs0, xs1) + asserting $ listsEqualOn xs0 xs1 $ \(Entity _ p, Entity _ b, Entity _ pr) -> + (personName p, blogPostTitle b, profileName pr) + itDb "inner join on three entities" $ do + res <- do + pid <- insert $ Person "hello" Nothing Nothing 3 + _ <- insert $ BlogPost "good poast" pid + _ <- insert $ BlogPost "good poast #2" pid + _ <- insert $ Profile "cool" pid + _ <- insert $ Reply pid "u wot m8" + _ <- insert $ Reply pid "how dare you" + + bprr <- selectRethrowingQuery $ + from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do + on $ p ^. PersonId ==. b ^. BlogPostAuthorId + on $ p ^. PersonId ==. pr ^. ProfilePerson + on $ p ^. PersonId ==. r ^. ReplyGuy + pure (p, b, pr, r) + + brpr <- selectRethrowingQuery $ + from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do + on $ p ^. PersonId ==. b ^. BlogPostAuthorId + on $ p ^. PersonId ==. r ^. ReplyGuy + on $ p ^. PersonId ==. pr ^. ProfilePerson + pure (p, b, pr, r) + + prbr <- selectRethrowingQuery $ + from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do + on $ p ^. PersonId ==. pr ^. ProfilePerson + on $ p ^. PersonId ==. b ^. BlogPostAuthorId + on $ p ^. PersonId ==. r ^. ReplyGuy + pure (p, b, pr, r) + + prrb <- selectRethrowingQuery $ + from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do + on $ p ^. PersonId ==. pr ^. ProfilePerson + on $ p ^. PersonId ==. r ^. ReplyGuy + on $ p ^. PersonId ==. b ^. BlogPostAuthorId + pure (p, b, pr, r) + + rprb <- selectRethrowingQuery $ + from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do + on $ p ^. PersonId ==. r ^. ReplyGuy + on $ p ^. PersonId ==. pr ^. ProfilePerson + on $ p ^. PersonId ==. b ^. BlogPostAuthorId + pure (p, b, pr, r) + + rbpr <- selectRethrowingQuery $ + from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do + on $ p ^. PersonId ==. r ^. ReplyGuy + on $ p ^. PersonId ==. b ^. BlogPostAuthorId + on $ p ^. PersonId ==. pr ^. ProfilePerson + pure (p, b, pr, r) + + pure [bprr, brpr, prbr, prrb, rprb, rbpr] + asserting $ forM_ (zip res (drop 1 (cycle res))) $ \(a, b) -> a `shouldBe` b + + itDb "many-to-many" $ do + setup + ac <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c) -> do + on (a ^. JoinOneId ==. b ^. JoinManyJoinOne) + on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther) + pure (a, c) + + ca <- + select $ + from $ \(a `InnerJoin` b `InnerJoin` c) -> do + on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther) + on (a ^. JoinOneId ==. b ^. JoinManyJoinOne) + pure (a, c) + + asserting $ listsEqualOn ac ca $ \(Entity _ a, Entity _ b) -> + (joinOneName a, joinOtherName b) + + itDb "left joins on order" $ do + setup + ca <- + select $ + from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do + on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) + on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) + orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] + pure (a, c) + ac <- + select $ + from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do + on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) + on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) + orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] + pure (a, c) + + asserting $ listsEqualOn ac ca $ \(Entity _ a, b) -> + (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b) + + itDb "doesn't require an on for a crossjoin" $ do + void $ + select $ + from $ \(a `CrossJoin` b) -> do + pure (a :: SqlExpr (Entity JoinOne), b :: SqlExpr (Entity JoinTwo)) + asserting noExceptions + + itDb "errors with an on for a crossjoin" $ do + eres <- + try $ + select $ + from $ \(a `CrossJoin` b) -> do + on $ a ^. JoinOneId ==. b ^. JoinTwoJoinOne + pure (a, b) + asserting $ + case eres of + Left (OnClauseWithoutMatchingJoinException _) -> + pure () + Right _ -> + expectationFailure "Expected OnClause exception" + + itDb "left joins associativity" $ do + setup + ca <- + select $ + from $ \(a `LeftOuterJoin` (b `InnerJoin` c)) -> do + on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) + on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) + orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] + pure (a, c) + ca' <- + select $ + from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do + on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) + on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) + orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] + pure (a, c) + + asserting $ listsEqualOn ca ca' $ \(Entity _ a, b) -> + (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b) + + itDb "composes queries still" $ do + let + query1 = + from $ \(foo `InnerJoin` bar) -> do + on (foo ^. FooId ==. bar ^. BarQuux) + pure (foo, bar) + query2 = + from $ \(p `LeftOuterJoin` bp) -> do + on (p ^. PersonId ==. bp ^. BlogPostAuthorId) + pure (p, bp) + fid <- insert $ Foo 5 + _ <- insert $ Bar fid + pid <- insert $ Person "hey" Nothing Nothing 30 + _ <- insert $ BlogPost "WHY" pid + a <- select ((,) <$> query1 <*> query2) + b <- select (flip (,) <$> query1 <*> query2) + asserting $ listsEqualOn a (map (\(x, y) -> (y, x)) b) id + + itDb "works with joins in subselect" $ do + select $ + from $ \(p `InnerJoin` r) -> do + on $ p ^. PersonId ==. r ^. ReplyGuy + pure . (,) (p ^. PersonName) $ + subSelect $ + from $ \(c `InnerJoin` bp) -> do + on $ bp ^. BlogPostId ==. c ^. CommentBlog + pure (c ^. CommentBody) + asserting noExceptions + + describe "works with nested joins" $ do + itDb "unnested" $ do + selectRethrowingQuery $ + from $ \(f `InnerJoin` b `LeftOuterJoin` baz `InnerJoin` shoop) -> do + on $ f ^. FooId ==. b ^. BarQuux + on $ f ^. FooId ==. baz ^. BazBlargh + on $ baz ^. BazId ==. shoop ^. ShoopBaz + pure ( f ^. FooName) + asserting noExceptions + + itDb "leftmost nesting" $ do + selectRethrowingQuery $ + from $ \((f `InnerJoin` b) `LeftOuterJoin` baz `InnerJoin` shoop) -> do + on $ f ^. FooId ==. b ^. BarQuux + on $ f ^. FooId ==. baz ^. BazBlargh + on $ baz ^. BazId ==. shoop ^. ShoopBaz + pure ( f ^. FooName) + asserting noExceptions + describe "middle nesting" $ do + itDb "direct association" $ do + selectRethrowingQuery $ + from $ \(p `InnerJoin` (bp `LeftOuterJoin` c) `LeftOuterJoin` cr) -> do + on $ p ^. PersonId ==. bp ^. BlogPostAuthorId + on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog + on $ c ?. CommentId ==. cr ?. CommentReplyComment + pure (p,bp,c,cr) + asserting noExceptions + itDb "indirect association" $ do + selectRethrowingQuery $ + from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf) -> do + on $ f ^. FooId ==. b ^. BarQuux + on $ f ^. FooId ==. baz ^. BazBlargh + on $ baz ^. BazId ==. shoop ^. ShoopBaz + on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId + pure (f ^. FooName) + asserting noExceptions + itDb "indirect association across" $ do + selectRethrowingQuery $ + from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf `InnerJoin` another `InnerJoin` yetAnother) -> do + on $ f ^. FooId ==. b ^. BarQuux + on $ f ^. FooId ==. baz ^. BazBlargh + on $ baz ^. BazId ==. shoop ^. ShoopBaz + on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId + on $ another ^. AnotherWhy ==. baz ^. BazId + on $ yetAnother ^. YetAnotherArgh ==. shoop ^. ShoopId + pure (f ^. FooName) + asserting noExceptions + + describe "rightmost nesting" $ do + itDb "direct associations" $ do + selectRethrowingQuery $ + from $ \(p `InnerJoin` bp `LeftOuterJoin` (c `LeftOuterJoin` cr)) -> do + on $ p ^. PersonId ==. bp ^. BlogPostAuthorId + on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog + on $ c ?. CommentId ==. cr ?. CommentReplyComment + pure (p,bp,c,cr) + asserting noExceptions + + itDb "indirect association" $ do + selectRethrowingQuery $ + from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop)) -> do + on $ f ^. FooId ==. b ^. BarQuux + on $ f ^. FooId ==. baz ^. BazBlargh + on $ baz ^. BazId ==. shoop ^. ShoopBaz + pure (f ^. FooName) + asserting noExceptions + +listsEqualOn :: (HasCallStack, Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) -> Expectation +listsEqualOn a b f = map f a `shouldBe` map f b + +tests :: SpecDb +tests = + describe "Esqueleto" $ do + testSelect + testSubSelect + testSelectSource + testSelectFrom + testSelectJoin + testSelectWhere + testSelectOrderBy + testSelectDistinct + testCoasleceDefault + testDelete + testUpdate + testListOfValues + testListFields + testInsertsBySelect + testMathFunctions + testCase + testCountingRows + testRenderSql + testOnClauseOrder + testLocking + +insert' :: ( Functor m + , BaseBackend backend ~ PersistEntityBackend val + , PersistStore backend + , MonadIO m +#if MIN_VERSION_persistent(2,14,0) + , SafeToInsert val +#endif + , PersistEntity val ) + => val -> ReaderT backend m (Entity val) +insert' v = flip Entity v <$> insert v + + +-- With SQLite and in-memory databases, a separate connection implies a +-- separate database. With 'actual databases', the data is persistent and +-- thus must be cleaned after each test. +-- TODO: there is certainly a better way... +cleanDB + :: forall m. _ + => SqlPersistT m () +cleanDB = do + delete $ from $ \(_ :: SqlExpr (Entity Bar)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity Foo)) -> return () + + delete $ from $ \(_ :: SqlExpr (Entity Reply)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity Comment)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity Profile)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity BlogPost)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity Follow)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity Person)) -> return () + + delete $ from $ \(_ :: SqlExpr (Entity Deed)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity Lord)) -> return () + + delete $ from $ \(_ :: SqlExpr (Entity CcList)) -> return () + + delete $ from $ \(_ :: SqlExpr (Entity ArticleTag)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity ArticleMetadata)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity Article)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity Article2)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity Tag)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity Frontcover)) -> return () + + delete $ from $ \(_ :: SqlExpr (Entity Circle)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity Point)) -> return () + + delete $ from $ \(_ :: SqlExpr (Entity Numbers)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity JoinMany)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity JoinFour)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity JoinThree)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity JoinTwo)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity JoinOne)) -> return () + delete $ from $ \(_ :: SqlExpr (Entity JoinOther)) -> return () + + delete $ from $ \(_ :: SqlExpr (Entity DateTruncTest)) -> pure () + + +cleanUniques + :: forall m. MonadIO m + => SqlPersistT m () +cleanUniques = + delete $ from $ \(_ :: SqlExpr (Entity OneUnique)) -> return () + +selectRethrowingQuery + :: (MonadIO m, EI.SqlSelect a r, MonadUnliftIO m) + => SqlQuery a + -> SqlPersistT m [r] +selectRethrowingQuery query = + select query + `catch` \(SomeException e) -> do + (text, _) <- renderQuerySelect query + liftIO . throwIO . userError $ Text.unpack text <> "\n\n" <> show e + +updateRethrowingQuery + :: + ( MonadUnliftIO m + , PersistEntity val + , BackendCompatible SqlBackend (PersistEntityBackend val) + ) + => (SqlExpr (Entity val) -> SqlQuery ()) + -> SqlWriteT m () +updateRethrowingQuery k = + update k + `catch` \(SomeException e) -> do + (text, _) <- renderQueryUpdate (from k) + liftIO . throwIO . userError $ Text.unpack text <> "\n\n" <> show e + +shouldBeOnClauseWithoutMatchingJoinException + :: (HasCallStack, Show a) + => Either SomeException a + -> Expectation +shouldBeOnClauseWithoutMatchingJoinException ea = + case ea of + Left (fromException -> Just OnClauseWithoutMatchingJoinException {}) -> + pure () + _ -> + expectationFailure $ "Expected OnClauseWithMatchingJoinException, got: " <> show ea diff --git a/test/Common/Record.hs b/test/Common/Record.hs index 5cb1599ed..398b59023 100644 --- a/test/Common/Record.hs +++ b/test/Common/Record.hs @@ -14,20 +14,42 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -ddump-splices #-} + -- Tests for `Database.Esqueleto.Record`. module Common.Record (testDeriveEsqueletoRecord) 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.Experimental +import Database.Esqueleto import Database.Esqueleto.Record - ( DeriveEsqueletoRecordSettings(..) - , defaultDeriveEsqueletoRecordSettings - , deriveEsqueletoRecord - , deriveEsqueletoRecordWith - ) + ( DeriveEsqueletoRecordSettings(..) + , defaultDeriveEsqueletoRecordSettings + , 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 } + deriving (Show, Eq) +$(deriveEsqueletoRecord ''MySimpleRecord) data MyRecord = MyRecord @@ -112,6 +134,15 @@ myModifiedRecordQuery = do , myModifiedAddressSql = address } +mySubselectRecordQuery :: SqlQuery (SqlExpr (Maybe (Entity Address))) +mySubselectRecordQuery = do + _ :& record <- from $ + table @User + `leftJoin` + myRecordQuery + `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" record ?. #id) + pure $ getField @"myAddress" record + testDeriveEsqueletoRecord :: SpecDb testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do let setup :: MonadIO m => SqlPersistT m () @@ -208,7 +239,6 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do } -> addr1 == addr2 -- The keys should match. _ -> False) - itDb "can select user-modified records" $ do setup records <- select myModifiedRecordQuery @@ -235,3 +265,87 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do , myModifiedAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"}) } -> addr1 == addr2 -- The keys should match. _ -> False) + + itDb "can left join on records" $ do + setup + records <- select $ do + from + ( table @User + `leftJoin` myRecordQuery `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" record ?. #id) + ) + let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case (_ :& Just (MyRecord {myName = "Rebecca", myAddress = Nothing})) -> True + _ -> False) + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case ( _ :& Just ( MyRecord { myName = "Some Guy" + , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) + } + )) -> True + _ -> True) + + itDb "can can handle joins on records with Nothing" $ do + setup + records <- select $ do + from + ( table @User + `leftJoin` myRecordQuery `on` (do \(user :& record) -> user ^. #address ==. getField @"myAddress" record ?. #id) + ) + let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case (_ :& Nothing) -> True + _ -> False) + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case ( _ :& Just ( MyRecord { myName = "Some Guy" + , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) + } + )) -> True + _ -> True) + + itDb "can left join on nested records" $ do + setup + records <- select $ do + from + ( table @User + `leftJoin` myNestedRecordQuery + `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" (getField @"myRecord" record) ?. #id) + ) + let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case (_ :& Just (MyNestedRecord {myRecord = MyRecord {myName = "Rebecca", myAddress = Nothing}})) -> True + _ -> False) + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case ( _ :& Just ( MyNestedRecord { myRecord = MyRecord { myName = "Some Guy" + , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) + } + })) -> True + _ -> True) + + itDb "can handle multiple left joins on the same record" $ do + setup + records <- select $ do + from + ( table @User + `leftJoin` myNestedRecordQuery + `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" (getField @"myRecord" record) ?. #id) + `leftJoin` myNestedRecordQuery + `on` (do \(user :& record1 :& record2) -> getField @"myUser" (getField @"myRecord" record1) ?. #id !=. getField @"myUser" (getField @"myRecord" record2) ?. #id) + ) + let sortedRecords = sortOn (\(Entity _ user :& _ :& _) -> getField @"userName" user) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case ( _ :& _ :& Just ( MyNestedRecord { myRecord = MyRecord { myName = "Some Guy" + , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) + } + })) -> True + _ -> True) + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case (_ :& _ :& Just (MyNestedRecord {myRecord = MyRecord {myName = "Rebecca", myAddress = Nothing}})) -> True + _ -> False) diff --git a/test/Common/Test.hs b/test/Common/Test.hs index e08584b91..7c6ffc8f5 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -70,11 +70,8 @@ module Common.Test import Common.Test.Import hiding (from, on) import Control.Monad (forM_, replicateM, replicateM_, void) -import qualified Data.Attoparsec.Text as AP import Data.Char (toLower, toUpper) -import Data.Either import Database.Esqueleto -import qualified Database.Esqueleto.Experimental as Experimental import Data.Conduit (ConduitT, runConduit, (.|)) import qualified Data.Conduit.List as CL @@ -153,10 +150,10 @@ testSubSelect = do describe "subSelect" $ do itDb "is safe for queries that may return multiple results" $ do - let query = - from $ \n -> do - orderBy [asc (n ^. NumbersInt)] - pure (n ^. NumbersInt) + let query = do + n <- from $ table @Numbers + orderBy [asc (n ^. NumbersInt)] + pure (n ^. NumbersInt) setup res <- select $ pure $ subSelect query eres <- try $ do @@ -174,8 +171,8 @@ testSubSelect = do v `shouldBe` [Value 1] itDb "is safe for queries that may not return anything" $ do - let query = - from $ \n -> do + let query = do + n <- from $ table @Numbers orderBy [asc (n ^. NumbersInt)] limit 1 pure (n ^. NumbersInt) @@ -201,11 +198,11 @@ testSubSelect = do describe "subSelectList" $ do itDb "is safe on empty databases as well as good databases" $ do - let query = - from $ \n -> do + let query = do + n <- from $ table @Numbers where_ $ n ^. NumbersInt `in_` do - subSelectList $ - from $ \n' -> do + subSelectList $ do + n' <- from $ table @Numbers where_ $ n' ^. NumbersInt >=. val 3 pure (n' ^. NumbersInt) pure n @@ -221,14 +218,11 @@ testSubSelect = do describe "subSelectMaybe" $ do itDb "is equivalent to joinV . subSelect" $ do - let query - :: (SqlQuery (SqlExpr (Value (Maybe Int))) -> SqlExpr (Value (Maybe Int))) - -> SqlQuery (SqlExpr (Value (Maybe Int))) - query selector = - from $ \n -> do + let query selector = do + n <- from $ table @Numbers pure $ - selector $ - from $ \n' -> do + selector $ do + n' <- from $ table @Numbers where_ $ n' ^. NumbersDouble >=. n ^. NumbersDouble pure (max_ (n' ^. NumbersInt)) @@ -241,21 +235,21 @@ testSubSelect = do itDb "is a safe way to do a countRows" $ do setup xs0 <- - select $ - from $ \n -> do + select $ do + n <- from $ table @Numbers pure $ (,) n $ - subSelectCount @Int $ - from $ \n' -> do + subSelectCount @Int $ do + n' <- from $ table @Numbers where_ $ n' ^. NumbersInt >=. n ^. NumbersInt xs1 <- - select $ - from $ \n -> do + select $ do + n <- from $ table @Numbers pure $ (,) n $ - subSelectUnsafe $ - from $ \n' -> do + subSelectUnsafe $ do + n' <- from $ table @Numbers where_ $ n' ^. NumbersInt >=. n ^. NumbersInt - pure (countRows :: SqlExpr (Value Int)) + pure countRows let getter (Entity _ a, b) = (a, b) asserting $ @@ -265,17 +259,17 @@ testSubSelect = do itDb "throws exceptions on multiple results" $ do setup eres <- try $ do - bad <- select $ - from $ \n -> do + bad <- select $ do + n <- from $ table @Numbers pure $ (,) (n ^. NumbersInt) $ - subSelectUnsafe $ - from $ \n' -> do + subSelectUnsafe $ do + n' <- from $ table @Numbers pure (just (n' ^. NumbersDouble)) - good <- select $ - from $ \n -> do + good <- select $ do + n <- from $ table @Numbers pure $ (,) (n ^. NumbersInt) $ - subSelect $ - from $ \n' -> do + subSelect $ do + n' <- from $ table @Numbers pure (n' ^. NumbersDouble) pure (bad, good) asserting $ case eres of @@ -290,11 +284,11 @@ testSubSelect = do itDb "throws exceptions on null results" $ do setup eres <- try $ do - select $ - from $ \n -> do + select $ do + n <- from $ table @Numbers pure $ (,) (n ^. NumbersInt) $ - subSelectUnsafe $ - from $ \n' -> do + subSelectUnsafe $ do + n' <- from $ table @Numbers where_ $ val False pure (n' ^. NumbersDouble) asserting $ case eres of @@ -308,7 +302,7 @@ testSelectOne = describe "selectOne" $ do let personQuery = selectOne $ do - person <- Experimental.from $ Experimental.table @Person + person <- from $ table @Person where_ $ person ^. PersonFavNum >=. val 1 orderBy [asc (person ^. PersonId)] return $ person ^. PersonId @@ -328,23 +322,15 @@ testSelectSource :: SpecDb testSelectSource = do describe "selectSource" $ do itDb "works for a simple example" $ do - let query - :: ConduitT () (Entity Person) (SqlPersistT (R.ResourceT IO)) () - query = - selectSource $ - from $ \person -> - return person + let query :: ConduitT () (Entity Person) (SqlPersistT (R.ResourceT IO)) () + query = selectSource $ from $ table @Person p1e <- insert' p1 ret <- mapReaderT R.runResourceT $ runConduit $ query .| CL.consume asserting $ ret `shouldBe` [ p1e ] itDb "can run a query many times" $ do - let query - :: ConduitT () (Entity Person) (SqlPersistT (R.ResourceT IO)) () - query = - selectSource $ - from $ \person -> - return person + let query :: ConduitT () (Entity Person) (SqlPersistT (R.ResourceT IO)) () + query = selectSource $ from $ table @Person p1e <- insert' p1 ret0 <- mapReaderT R.runResourceT $ runConduit $ query .| CL.consume ret1 <- mapReaderT R.runResourceT $ runConduit $ query .| CL.consume @@ -356,9 +342,10 @@ testSelectSource = do let selectPerson :: R.MonadResource m => String -> ConduitT () (Key Person) (SqlPersistT m) () selectPerson name = do let source = - selectSource $ from $ \person -> do - where_ $ person ^. PersonName ==. val name - return $ person ^. PersonId + selectSource $ do + person <- from $ table @Person + where_ $ person ^. PersonName ==. val name + return $ person ^. PersonId source .| CL.map unValue p1e <- insert' p1 p2e <- insert' p2 @@ -373,50 +360,28 @@ testSelectFrom = do describe "select/from" $ do itDb "works for a simple example" $ do p1e <- insert' p1 - ret <- - select $ - from $ \person -> - return person + ret <- select $ from $ table @Person asserting $ ret `shouldBe` [ p1e ] - itDb "works for a simple self-join (one entity)" $ do + itDb "works for a simple example using Table" $ do p1e <- insert' p1 - ret <- - select $ - from $ \(person1, person2) -> - return (person1, person2) - asserting $ ret `shouldBe` [ (p1e, p1e) ] + ret <- select $ from $ Table @Person + asserting $ ret `shouldBe` [ p1e ] - itDb "works for a simple self-join (two entities)" $ do - p1e <- insert' p1 - p2e <- insert' p2 - ret <- - select $ - from $ \(person1, person2) -> - return (person1, person2) - asserting $ - ret - `shouldSatisfy` - sameElementsAs - [ (p1e, p1e) - , (p1e, p2e) - , (p2e, p1e) - , (p2e, p2e) - ] itDb "works for a self-join via sub_select" $ do p1k <- insert p1 p2k <- insert p2 _f1k <- insert (Follow p1k p2k) _f2k <- insert (Follow p2k p1k) - ret <- select $ - from $ \followA -> do - let subquery = - from $ \followB -> do + ret <- select $ do + followA <- from $ table @Follow + let subquery = do + followB <- from $ table @Follow where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed return $ followB ^. FollowFollower - where_ $ followA ^. FollowFollowed ==. sub_select subquery - return followA + where_ $ followA ^. FollowFollowed ==. sub_select subquery + return followA asserting $ length ret `shouldBe` 2 itDb "works for a self-join via exists" $ do @@ -424,40 +389,29 @@ testSelectFrom = do p2k <- insert p2 _f1k <- insert (Follow p1k p2k) _f2k <- insert (Follow p2k p1k) - ret <- select $ - from $ \followA -> do - where_ $ exists $ - from $ \followB -> - where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed - return followA + ret <- select $ do + followA <- from $ table @Follow + where_ $ exists $ do + followB <- from $ table @Follow + where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed + return followA asserting $ length ret `shouldBe` 2 itDb "works for a simple projection" $ do p1k <- insert p1 p2k <- insert p2 - ret <- select $ - from $ \p -> - return (p ^. PersonId, p ^. PersonName) + ret <- select $ do + p <- from $ table @Person + return (p ^. PersonId, p ^. PersonName) asserting $ ret `shouldBe` [ (Value p1k, Value (personName p1)) , (Value p2k, Value (personName p2)) ] - itDb "works for a simple projection with a simple implicit self-join" $ do - _ <- insert p1 - _ <- insert p2 - ret <- select $ - from $ \(pa, pb) -> - return (pa ^. PersonName, pb ^. PersonName) - asserting $ ret `shouldSatisfy` sameElementsAs - [ (Value (personName p1), Value (personName p1)) - , (Value (personName p1), Value (personName p2)) - , (Value (personName p2), Value (personName p1)) - , (Value (personName p2), Value (personName p2)) ] itDb "works with many kinds of LIMITs and OFFSETs" $ do [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] - let people = - from $ \p -> do + let people = do + p <- from $ table @Person orderBy [asc (p ^. PersonName)] return p ret1 <- @@ -507,7 +461,7 @@ testSelectFrom = do number = 101 :: Int Right thePk = keyFromValues [toPersistValue number] fcPk <- insert fc - [Entity _ ret] <- select $ from return + [Entity _ ret] <- select $ from $ table @Frontcover asserting $ do ret `shouldBe` fc fcPk `shouldBe` thePk @@ -517,7 +471,9 @@ testSelectFrom = do t = Tag name Right thePk = keyFromValues [toPersistValue name] tagPk <- insert t - [Value ret] <- select $ from $ \t' -> return (t'^.TagId) + [Value ret] <- select $ do + t' <- from $ table @Tag + return (t'^.TagId) asserting $ do ret `shouldBe` thePk thePk `shouldBe` tagPk @@ -525,7 +481,9 @@ testSelectFrom = do itDb "works when returning a composite primary key from a query" $ do let p = Point 10 20 "" thePk <- insert p - [Value ppk] <- select $ from $ \p' -> return (p'^.PointId) + [Value ppk] <- select $ do + p' <- from $ table @Point + return (p'^.PointId) asserting $ ppk `shouldBe` thePk testSelectJoin :: SpecDb @@ -540,11 +498,12 @@ testSelectJoin = do b12e <- insert' $ BlogPost "b" (entityKey p1e) b11e <- insert' $ BlogPost "a" (entityKey p1e) b31e <- insert' $ BlogPost "c" (entityKey p3e) - ret <- select $ - from $ \(p `LeftOuterJoin` mb) -> do - on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) - orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ] - return (p, mb) + ret <- select $ do + (p :& mb) <- from $ table @Person `leftJoin` table @BlogPost + `on` (\(p :& mb) -> + just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) + orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ] + return (p, mb) asserting $ ret `shouldBe` [ (p1e, Just b11e) , (p1e, Just b12e) , (p4e, Nothing) @@ -553,40 +512,33 @@ testSelectJoin = do itDb "typechecks (A LEFT OUTER JOIN (B LEFT OUTER JOIN C))" $ let - _x :: SqlPersistT IO _ + _x :: SqlPersistT IO [Entity Person] _x = - select $ - from $ \(a `LeftOuterJoin` (b `LeftOuterJoin` c)) -> - let _ = [a, b, c] :: [ SqlExpr (Entity Person) ] - in return a + select $ do + (a :& _) <- from $ table @Person + `leftJoin` (table @Person + `leftJoin` table @Person + `on` (\(person2 :& person3) -> just (person2 ^. PersonId) ==. person3 ?. PersonId)) + `on` (\(person1 :& (person2 :& _)) -> + just (person1 ^. PersonId) ==. person2 ?. PersonId) + + return a in asserting noExceptions itDb "typechecks ((A LEFT OUTER JOIN B) LEFT OUTER JOIN C)" $ - let _x :: SqlPersistT IO _ + let _x :: SqlPersistT IO [Entity Person] _x = - select $ - from $ \((a `LeftOuterJoin` b) `LeftOuterJoin` c) -> - let _ = [a, b, c] :: [ SqlExpr (Entity Person) ] - in return a + select $ do + (a :& _ :& _) <- + from $ (table @Person + `leftJoin` table @Person + `on` (\(person1 :& person2) -> + just (person1 ^. PersonId) ==. person2 ?. PersonId)) + `leftJoin` table @Person + `on` (\(_ :& person2 :& person3) -> person2 ?. PersonId ==. person3 ?. PersonId) + return a in asserting noExceptions - itDb "throws an error for using on without joins" $ do - eres <- try $ select $ - from $ \(p, mb) -> do - on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) - orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ] - return (p, mb) - asserting $ shouldBeOnClauseWithoutMatchingJoinException eres - - itDb "throws an error for using too many ons" $ do - eres <- try $ select $ - from $ \(p `FullOuterJoin` mb) -> do - on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) - on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) - orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ] - return (p, mb) - asserting $ shouldBeOnClauseWithoutMatchingJoinException eres - itDb "works with ForeignKey to a non-id primary key returning one entity" $ do let fc = Frontcover number "" @@ -595,23 +547,29 @@ testSelectJoin = do Right thePk = keyFromValues [toPersistValue number] fcPk <- insert fc insert_ article - [Entity _ retFc] <- select $ - from $ \(a `InnerJoin` f) -> do - on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber) + [Entity _ retFc] <- select $ do + (_a :& f) <- + from $ table @Article + `innerJoin` table @Frontcover + `on` (\(a :& f) -> + f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber) return f asserting $ do retFc `shouldBe` fc fcPk `shouldBe` thePk + itDb "allows using a primary key that is itself a key of another table" $ do let number = 101 insert_ $ Frontcover number "" articleId <- insert $ Article "title" number articleMetaE <- insert' (ArticleMetadata articleId) - result <- select $ from $ \articleMetadata -> do - where_ $ (articleMetadata ^. ArticleMetadataId) ==. (val ((ArticleMetadataKey articleId))) - pure articleMetadata + result <- select $ do + articleMetadata <- from $ table @ArticleMetadata + where_ $ articleMetadata ^. ArticleMetadataId ==. (val (ArticleMetadataKey articleId)) + pure articleMetadata asserting $ [articleMetaE] `shouldBe` result + itDb "allows joining between a primary key that is itself a key of another table, using ToBaseId" $ do do let number = 101 @@ -619,10 +577,13 @@ testSelectJoin = do articleE@(Entity articleId _) <- insert' $ Article "title" number articleMetaE <- insert' (ArticleMetadata articleId) - articlesAndMetadata <- select $ - from $ \(article `InnerJoin` articleMetadata) -> do - on (toBaseId (articleMetadata ^. ArticleMetadataId) ==. article ^. ArticleId) - return (article, articleMetadata) + articlesAndMetadata <- select $ do + (article :& articleMetadata) <- + from $ table @Article + `innerJoin` table @ArticleMetadata + `on` (\(article :& articleMetadata) -> + toBaseId (articleMetadata ^. ArticleMetadataId) ==. article ^. ArticleId) + return (article, articleMetadata) asserting $ [(articleE, articleMetaE)] `shouldBe` articlesAndMetadata itDb "works with a ForeignKey to a non-id primary key returning both entities" $ @@ -633,9 +594,12 @@ testSelectJoin = do Right thePk = keyFromValues [toPersistValue number] fcPk <- insert fc insert_ article - [(Entity _ retFc, Entity _ retArt)] <- select $ - from $ \(a `InnerJoin` f) -> do - on (f^.FrontcoverNumber ==. a^.ArticleFrontcoverNumber) + [(Entity _ retFc, Entity _ retArt)] <- select $ do + (a :& f) <- + from $ table @Article + `innerJoin` table @Frontcover + `on` (\(a :& f) -> + f ^. FrontcoverNumber ==. a ^. ArticleFrontcoverNumber) return (f, a) asserting $ do retFc `shouldBe` fc @@ -651,9 +615,12 @@ testSelectJoin = do Right thePk = keyFromValues [toPersistValue number] fcPk <- insert fc insert_ article - [Entity _ retFc] <- select $ - from $ \(a `InnerJoin` f) -> do - on (f^.FrontcoverId ==. a^.Article2FrontcoverId) + [Entity _ retFc] <- select $ do + (_a :& f) <- + from $ table @Article2 + `innerJoin` table @Frontcover + `on` (\(a :& f) -> + f ^. FrontcoverId ==. a ^. Article2FrontcoverId) return f asserting $ do retFc `shouldBe` fc @@ -690,10 +657,15 @@ testSelectJoin = do artId <- insert article tagId <- insert tag insert_ $ ArticleTag artId tagId - [(Entity _ retArt, Entity _ retTag)] <- select $ - from $ \(a `InnerJoin` at `InnerJoin` t) -> do - on (t^.TagId ==. at^.ArticleTagTagId) - on (a^.ArticleId ==. at^.ArticleTagArticleId) + [(Entity _ retArt, Entity _ retTag)] <- select $ do + (a :& _ :& t) <- + from $ table @Article + `innerJoin` table @ArticleTag + `on` (\(a :& at) -> + a ^. ArticleId ==. at ^. ArticleTagArticleId) + `innerJoin` table @Tag + `on` (\(_ :& at :& t) -> + t ^. TagId ==. at ^. ArticleTagTagId) return (a, t) asserting $ do retArt `shouldBe` article @@ -702,13 +674,13 @@ testSelectJoin = do itDb "respects the associativity of joins" $ do void $ insert p1 - ps <- select $ from $ - \((p :: SqlExpr (Entity Person)) - `LeftOuterJoin` - ((_q :: SqlExpr (Entity Person)) - `InnerJoin` (_r :: SqlExpr (Entity Person)))) -> do - on (val False) -- Inner join is empty - on (val True) + ps <- select $ do + (p :& _) <- + from $ table @Person + `leftJoin` (table @Person + `innerJoin` table @Person + `on` (\_ -> val False)) + `on` (\_ -> val True) return p asserting $ (entityVal <$> ps) `shouldBe` [p1] @@ -717,9 +689,17 @@ testSelectSubQuery = describe "select subquery" $ do itDb "works" $ do _ <- insert' p1 let q = do - p <- Experimental.from $ Table @Person + p <- from $ table @Person + return ( p ^. PersonName, p ^. PersonAge) + 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 $ Experimental.from q + ret <- select $ from $ SubQuery q asserting $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ] itDb "supports sub-selecting Maybe entities" $ do @@ -728,11 +708,11 @@ testSelectSubQuery = describe "select subquery" $ do l1Deeds <- mapM (\k -> insert' $ Deed k (entityKey l1e)) (map show [1..3 :: Int]) let l1WithDeeds = do d <- l1Deeds pure (l1e, Just d) - let q = Experimental.from $ do + let q = from $ do (lords :& deeds) <- - Experimental.from $ Table @Lord - `LeftOuterJoin` Table @Deed - `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId) + from $ table @Lord + `LeftOuterJoin` table @Deed + `on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId) pure (lords, deeds) ret <- select q @@ -743,8 +723,8 @@ testSelectSubQuery = describe "select subquery" $ do _ <- insert' p3 let q = do (name, age) <- - Experimental.from $ SubQuery $ do - p <- Experimental.from $ Table @Person + from $ do + p <- from $ table @Person return ( p ^. PersonName, p ^. PersonAge) orderBy [ asc age ] pure name @@ -758,13 +738,13 @@ testSelectSubQuery = describe "select subquery" $ do mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) let q = do - (lord :& deed) <- Experimental.from $ Table @Lord - `InnerJoin` Table @Deed - `Experimental.on` (\(lord :& deed) -> + (lord :& deed) <- from $ table @Lord + `InnerJoin` table @Deed + `on` (\(lord :& deed) -> lord ^. LordId ==. deed ^. DeedOwnerId) return (lord ^. LordId, deed ^. DeedId) q' = do - (lordId, deedId) <- Experimental.from $ SubQuery q + (lordId, deedId) <- from q groupBy (lordId) return (lordId, count deedId) (ret :: [(Value (Key Lord), Value Int)]) <- select q' @@ -779,15 +759,15 @@ testSelectSubQuery = describe "select subquery" $ do mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) let q = do - (lord :& deed) <- Experimental.from $ Table @Lord - `InnerJoin` Table @Deed - `Experimental.on` (\(lord :& deed) -> + (lord :& deed) <- from $ table @Lord + `InnerJoin` table @Deed + `on` (\(lord :& deed) -> lord ^. LordId ==. deed ^. DeedOwnerId) groupBy (lord ^. LordId) return (lord ^. LordId, count (deed ^. DeedId)) (ret :: [(Value Int)]) <- select $ do - (lordId, deedCount) <- Experimental.from $ SubQuery q + (lordId, deedCount) <- from q where_ $ deedCount >. val (3 :: Int) return (count lordId) @@ -800,9 +780,9 @@ testSelectSubQuery = describe "select subquery" $ do mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) let q = do - (lord :& deed) <- Experimental.from $ Table @Lord - `InnerJoin` (Experimental.from $ Table @Deed) - `Experimental.on` (\(lord :& deed) -> + (lord :& deed) <- from $ table @Lord + `InnerJoin` (from $ table @Deed) + `on` (\(lord :& deed) -> lord ^. LordId ==. deed ^. DeedOwnerId) groupBy (lord ^. LordId) return (lord ^. LordId, count (deed ^. DeedId)) @@ -814,11 +794,11 @@ testSelectSubQuery = describe "select subquery" $ do l1k <- insert l1 l3k <- insert l3 let q = do - (lord :& (_, dogCounts)) <- Experimental.from $ Table @Lord + (lord :& (_, dogCounts)) <- from $ table @Lord `LeftOuterJoin` do - lord <- Experimental.from $ Table @Lord + lord <- from $ table @Lord pure (lord ^. LordId, lord ^. LordDogs) - `Experimental.on` (\(lord :& (lordId, _)) -> + `on` (\(lord :& (lordId, _)) -> just (lord ^. LordId) ==. lordId) groupBy (lord ^. LordId, dogCounts) return (lord ^. LordId, dogCounts) @@ -828,32 +808,51 @@ testSelectSubQuery = describe "select subquery" $ do itDb "unions" $ do _ <- insert p1 _ <- insert p2 - let q = Experimental.from $ + let q = from $ (do - p <- Experimental.from $ Table @Person + p <- from $ table @Person where_ $ not_ $ isNothing $ p ^. PersonAge return (p ^. PersonName)) `union_` (do - p <- Experimental.from $ Table @Person + p <- from $ table @Person where_ $ isNothing $ p ^. PersonAge return (p ^. PersonName)) `union_` (do - p <- Experimental.from $ Table @Person + p <- from $ table @Person where_ $ isNothing $ p ^. PersonAge return (p ^. PersonName)) names <- select q asserting $ names `shouldMatchList` [ (Value $ personName p1) , (Value $ personName p2) ] + + 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) + -- We don't care about the result of the query, only that it + -- rendered & executed. + asserting noExceptions + testSelectWhere :: SpecDb testSelectWhere = describe "select where_" $ do itDb "works for a simple example with (==.)" $ do p1e <- insert' p1 _ <- insert' p2 _ <- insert' p3 - ret <- select $ - from $ \p -> do + ret <- select $ do + p <- from $ table @Person where_ (p ^. PersonName ==. val "John") return p asserting $ ret `shouldBe` [ p1e ] @@ -862,30 +861,30 @@ testSelectWhere = describe "select where_" $ do p1e <- insert' p1 p2e <- insert' p2 _ <- insert' p3 - ret <- select $ - from $ \p -> do - where_ (p ^. PersonName ==. val "John" ||. p ^. PersonName ==. val "Rachel") - return p + ret <- select $ do + p <- from $ table @Person + where_ (p ^. PersonName ==. val "John" ||. p ^. PersonName ==. val "Rachel") + return p asserting $ ret `shouldBe` [ p1e, p2e ] itDb "works for a simple example with (>.) [uses val . Just]" $ do p1e <- insert' p1 _ <- insert' p2 _ <- insert' p3 - ret <- select $ - from $ \p -> do - where_ (p ^. PersonAge >. val (Just 17)) - return p + ret <- select $ do + p <- from $ table @Person + where_ (p ^. PersonAge >. val (Just 17)) + 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 $ - from $ \p -> do - where_ (not_ $ p ^. PersonAge >. just (val 17)) - return p + 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 @@ -893,18 +892,17 @@ testSelectWhere = describe "select where_" $ do p1e <- insert' p1 _ <- insert' p2 _ <- insert' p3 - ret <- select $ - from $ \p -> do + ret <- select $ do + p <- from $ table @Person where_ ((p ^. PersonAge) `between` (just $ val 20, just $ val 40)) return p asserting $ ret `shouldBe` [ p1e ] itDb "works for a proyected fields value" $ do _ <- insert' p1 >> insert' p2 >> insert' p3 ret <- - select $ - from $ \p -> do - where_ $ - just (p ^. PersonFavNum) + select $ do + p <- from $ table @Person + where_ $ just (p ^. PersonFavNum) `between` (p ^. PersonAge, p ^. PersonWeight) asserting $ ret `shouldBe` [] @@ -912,13 +910,13 @@ testSelectWhere = describe "select where_" $ do itDb "works when using composite keys with val" $ do insert_ $ Point 1 2 "" ret <- - select $ - from $ \p -> do - where_ $ - p ^. PointId - `between` - ( val $ PointKey 1 2 - , val $ PointKey 5 6 ) + select $ do + p <- from $ table @Point + where_ $ + p ^. PointId + `between` + ( val $ PointKey 1 2 + , val $ PointKey 5 6 ) asserting $ ret `shouldBe` [()] itDb "works with avg_" $ do @@ -926,8 +924,8 @@ testSelectWhere = describe "select where_" $ do _ <- insert' p2 _ <- insert' p3 _ <- insert' p4 - ret <- select $ - from $ \p-> + ret <- select $ do + p <- from $ table @Person return $ joinV $ avg_ (p ^. PersonAge) let testV :: Double testV = roundTo (4 :: Integer) $ (36 + 17 + 17) / (3 :: Double) @@ -942,8 +940,8 @@ testSelectWhere = describe "select where_" $ do _ <- insert' p2 _ <- insert' p3 _ <- insert' p4 - ret <- select $ - from $ \p-> + ret <- select $ do + p <- from $ table @Person return $ joinV $ min_ (p ^. PersonAge) asserting $ ret `shouldBe` [ Value $ Just (17 :: Int) ] @@ -952,8 +950,8 @@ testSelectWhere = describe "select where_" $ do _ <- insert' p2 _ <- insert' p3 _ <- insert' p4 - ret <- select $ - from $ \p-> + ret <- select $ do + p <- from $ table @Person return $ joinV $ max_ (p ^. PersonAge) asserting $ ret `shouldBe` [ Value $ Just (36 :: Int) ] @@ -962,15 +960,15 @@ testSelectWhere = describe "select where_" $ do p2e@(Entity _ bob) <- insert' $ Person "bob" (Just 36) Nothing 1 -- lower(name) == 'john' - ret1 <- select $ - from $ \p-> do + ret1 <- select $ do + p <- from $ table @Person where_ (lower_ (p ^. PersonName) ==. val (map toLower $ personName p1)) return p asserting $ ret1 `shouldBe` [ p1e ] -- name == lower('BOB') - ret2 <- select $ - from $ \p-> do + ret2 <- select $ do + p <- from $ table @Person where_ (p ^. PersonName ==. lower_ (val $ map toUpper $ personName bob)) return p asserting $ ret2 `shouldBe` [ p2e ] @@ -983,43 +981,21 @@ testSelectWhere = describe "select where_" $ do _ <- insert' p1 p2e <- insert' p2 _ <- insert' p3 - ret <- select $ - from $ \p -> do - where_ $ isNothing (p ^. PersonAge) - return p + ret <- select $ do + p <- from $ table @Person + where_ $ isNothing (p ^. PersonAge) + return p asserting $ ret `shouldBe` [ p2e ] itDb "works with not_ . isNothing" $ do p1e <- insert' p1 _ <- insert' p2 - ret <- select $ - from $ \p -> do - where_ $ not_ (isNothing (p ^. PersonAge)) - return p + ret <- select $ do + p <- from $ table @Person + where_ $ not_ (isNothing (p ^. PersonAge)) + return p asserting $ ret `shouldBe` [ p1e ] - itDb "works for a many-to-many implicit join" $ - do - p1e@(Entity p1k _) <- insert' p1 - p2e@(Entity p2k _) <- insert' p2 - _ <- insert' p3 - p4e@(Entity p4k _) <- insert' p4 - f12 <- insert' (Follow p1k p2k) - f21 <- insert' (Follow p2k p1k) - f42 <- insert' (Follow p4k p2k) - f11 <- insert' (Follow p1k p1k) - ret <- select $ - from $ \(follower, follows, followed) -> do - where_ $ follower ^. PersonId ==. follows ^. FollowFollower &&. - followed ^. PersonId ==. follows ^. FollowFollowed - orderBy [ asc (follower ^. PersonName) - , asc (followed ^. PersonName) ] - return (follower, follows, followed) - asserting $ ret `shouldBe` [ (p1e, f11, p1e) - , (p1e, f12, p2e) - , (p4e, f42, p2e) - , (p2e, f21, p1e) ] - itDb "works for a many-to-many explicit join" $ do p1e@(Entity p1k _) <- insert' p1 p2e@(Entity p2k _) <- insert' p2 @@ -1029,13 +1005,18 @@ testSelectWhere = describe "select where_" $ do f21 <- insert' (Follow p2k p1k) f42 <- insert' (Follow p4k p2k) f11 <- insert' (Follow p1k p1k) - ret <- select $ - from $ \(follower `InnerJoin` follows `InnerJoin` followed) -> do - on $ followed ^. PersonId ==. follows ^. FollowFollowed - on $ follower ^. PersonId ==. follows ^. FollowFollower - orderBy [ asc (follower ^. PersonName) - , asc (followed ^. PersonName) ] - return (follower, follows, followed) + ret <- select $ do + (follower :& follows :& followed) <- + from $ table @Person + `innerJoin` table @Follow + `on` (\(follower :& follows) -> + follower ^. PersonId ==. follows ^. FollowFollower) + `innerJoin` table @Person + `on` (\(_ :& follows :& followed) -> + followed ^. PersonId ==. follows ^. FollowFollowed) + orderBy [ asc (follower ^. PersonName) + , asc (followed ^. PersonName) ] + return (follower, follows, followed) asserting $ ret `shouldBe` [ (p1e, f11, p1e) , (p1e, f12, p2e) , (p4e, f42, p2e) @@ -1043,11 +1024,16 @@ testSelectWhere = describe "select where_" $ do itDb "works for a many-to-many explicit join and on order doesn't matter" $ do void $ - selectRethrowingQuery $ - from $ \(person `InnerJoin` blog `InnerJoin` comment) -> do - on $ person ^. PersonId ==. blog ^. BlogPostAuthorId - on $ blog ^. BlogPostId ==. comment ^. CommentBlog - pure (person, comment) + selectRethrowingQuery $ do + (person :& _blog :& comment) <- + from $ table @Person + `innerJoin` table @BlogPost + `on` (\(person :& blog) -> + person ^. PersonId ==. blog ^. BlogPostAuthorId) + `innerJoin` table @Comment + `on` (\(_ :& blog :& comment) -> + blog ^. BlogPostId ==. comment ^. CommentBlog) + pure (person, comment) -- we only care that we don't have a SQL error asserting noExceptions @@ -1061,13 +1047,18 @@ testSelectWhere = describe "select where_" $ do f21 <- insert' (Follow p2k p1k) f42 <- insert' (Follow p4k p2k) f11 <- insert' (Follow p1k p1k) - ret <- select $ - from $ \(follower `LeftOuterJoin` mfollows `LeftOuterJoin` mfollowed) -> do - on $ mfollowed ?. PersonId ==. mfollows ?. FollowFollowed - on $ just (follower ^. PersonId) ==. mfollows ?. FollowFollower - orderBy [ asc ( follower ^. PersonName) - , asc (mfollowed ?. PersonName) ] - return (follower, mfollows, mfollowed) + ret <- select $ do + (follower :& mfollows :& mfollowed) <- + from $ table @Person + `leftJoin` table @Follow + `on` (\(follower :& mfollows) -> + just (follower ^. PersonId) ==. mfollows ?. FollowFollower) + `leftJoin` table @Person + `on` (\(_ :& mfollows :& mfollowed) -> + mfollowed ?. PersonId ==. mfollows ?. FollowFollowed) + orderBy [ asc ( follower ^. PersonName) + , asc (mfollowed ?. PersonName) ] + return (follower, mfollows, mfollowed) asserting $ ret `shouldBe` [ (p1e, Just f11, Just p1e) , (p1e, Just f12, Just p2e) , (p4e, Just f42, Just p2e) @@ -1080,9 +1071,10 @@ testSelectWhere = describe "select where_" $ do y = 15 Right thePk = keyFromValues [toPersistValue x, toPersistValue y] pPk <- insert p - [Entity _ ret] <- select $ from $ \p' -> do - where_ (p'^.PointId ==. val pPk) - return p' + [Entity _ ret] <- select $ do + p' <- from $ table @Point + where_ (p'^.PointId ==. val pPk) + return p' asserting $ do ret `shouldBe` p pPk `shouldBe` thePk @@ -1093,19 +1085,19 @@ testSelectOrderBy = describe "select/orderBy" $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 - ret <- select $ - from $ \p -> do - orderBy [asc $ p ^. PersonName] - return p + ret <- select $ do + p <- from $ table @Person + orderBy [asc $ p ^. PersonName] + return p asserting $ ret `shouldBe` [ p1e, p3e, p2e ] itDb "works with a sub_select" $ do [p1k, p2k, p3k, p4k] <- mapM insert [p1, p2, p3, p4] [b1k, b2k, b3k, b4k] <- mapM (insert . BlogPost "") [p1k, p2k, p3k, p4k] - ret <- select $ - from $ \b -> do - orderBy [desc $ sub_select $ - from $ \p -> do + ret <- select $ do + b <- from $ table @BlogPost + orderBy [desc $ sub_select $ do + p <- from $ table @Person where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) return (p ^. PersonName) ] @@ -1115,10 +1107,10 @@ testSelectOrderBy = describe "select/orderBy" $ do itDb "works on a composite primary key" $ do let ps = [Point 2 1 "", Point 1 2 ""] mapM_ insert ps - eps <- select $ - from $ \p' -> do - orderBy [asc (p'^.PointId)] - return p' + eps <- select $ do + p' <- from $ table @Point + orderBy [asc (p'^.PointId)] + return p' asserting $ map entityVal eps `shouldBe` reverse ps testAscRandom :: SqlExpr (Value Double) -> SpecDb @@ -1131,10 +1123,10 @@ testAscRandom rand' = describe "random_" $ rets <- fmap S.fromList $ replicateM 11 $ - select $ - from $ \p -> do - orderBy [asc (rand' :: SqlExpr (Value Double))] - return (p ^. PersonId :: SqlExpr (Value PersonId)) + select $ do + p <- from $ table @Person + orderBy [asc (rand' :: SqlExpr (Value Double))] + return (p ^. PersonId :: SqlExpr (Value PersonId)) -- There are 2^4 = 16 possible orderings. The chance -- of 11 random samplings returning the same ordering -- is 1/2^40, so this test should pass almost everytime. @@ -1153,8 +1145,8 @@ testSelectDistinct = do p1k <- insert p1 let (t1, t2, t3) = ("a", "b", "c") mapM_ (insert . flip BlogPost p1k) [t1, t3, t2, t2, t1] - ret <- q $ - from $ \b -> do + ret <- q $ do + b <- from $ table @BlogPost let title = b ^. BlogPostTitle orderBy [asc title] return title @@ -1172,8 +1164,8 @@ testCoasleceDefault :: SpecDb testCoasleceDefault = describe "coalesce/coalesceDefault" $ do itDb "works on a simple example" $ do mapM_ insert' [p1, p2, p3, p4, p5] - ret1 <- select $ - from $ \p -> do + ret1 <- select $ do + p <- from $ table @Person orderBy [asc (p ^. PersonId)] return (coalesce [p ^. PersonAge, p ^. PersonWeight]) asserting $ ret1 `shouldBe` [ Value (Just (36 :: Int)) @@ -1183,8 +1175,8 @@ testCoasleceDefault = describe "coalesce/coalesceDefault" $ do , Value Nothing ] - ret2 <- select $ - from $ \p -> do + ret2 <- select $ do + p <- from $ table @Person orderBy [asc (p ^. PersonId)] return (coalesceDefault [p ^. PersonAge, p ^. PersonWeight] (p ^. PersonFavNum)) asserting $ ret2 `shouldBe` [ Value (36 :: Int) @@ -1203,13 +1195,13 @@ testCoasleceDefault = describe "coalesce/coalesceDefault" $ do _ <- insert $ BlogPost "a" p1id _ <- insert $ BlogPost "b" p2id _ <- insert $ BlogPost "c" p3id - ret <- select $ - from $ \b -> do - let sub = - from $ \p -> do - where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) - return $ p ^. PersonAge - return $ coalesceDefault [sub_select sub] (val (42 :: Int)) + ret <- select $ do + b <- from $ table @BlogPost + let sub = do + p <- from $ table @Person + where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) + return $ p ^. PersonAge + return $ coalesceDefault [subSelectMaybe sub] (val (42 :: Int)) asserting $ ret `shouldBe` [ Value (36 :: Int) , Value 42 , Value 17 @@ -1222,20 +1214,18 @@ testDelete = describe "delete" $ do p1e <- insert' p1 p2e <- insert' p2 p3e <- insert' p3 - let getAll = select $ - from $ \p -> do - orderBy [asc (p ^. PersonName)] - return p + let getAll = select $ do + p <- from $ table @Person + orderBy [asc (p ^. PersonName)] + return p ret1 <- getAll asserting $ ret1 `shouldBe` [ p1e, p3e, p2e ] - () <- delete $ - from $ \p -> - where_ (p ^. PersonName ==. val (personName p1)) + delete $ do + p <- from $ table @Person + where_ (p ^. PersonName ==. val (personName p1)) ret2 <- getAll asserting $ ret2 `shouldBe` [ p3e, p2e ] - n <- deleteCount $ - from $ \p -> - return ((p :: SqlExpr (Entity Person)) `seq` ()) + n <- deleteCount $ void $ from $ table @Person ret3 <- getAll asserting $ (n, ret3) `shouldBe` (2, []) @@ -1247,16 +1237,15 @@ testUpdate = describe "update" $ do p3k <- insert p3 replicateM_ 3 (insert $ BlogPost "" p1k) replicateM_ 7 (insert $ BlogPost "" p3k) - let blogPostsBy p = - from $ \b -> do - where_ (b ^. BlogPostAuthorId ==. p ^. PersonId) - return countRows + let blogPostsBy p = do + b <- from $ table @BlogPost + where_ (b ^. BlogPostAuthorId ==. p ^. PersonId) () <- update $ \p -> do - set p [ PersonAge =. just (sub_select (blogPostsBy p)) ] - ret <- select $ - from $ \p -> do - orderBy [ asc (p ^. PersonName) ] - return p + set p [ PersonAge =. just (subSelectCount (blogPostsBy p)) ] + ret <- select $ do + p <- from $ table @Person + orderBy [ asc (p ^. PersonName) ] + return p asserting $ ret `shouldBe` [ Entity p1k p1 { personAge = Just 3 } , Entity p3k p3 { personAge = Just 7 } , Entity p2k p2 { personAge = Just 0 } ] @@ -1274,7 +1263,7 @@ testUpdate = describe "update" $ do insert_ p () <- update $ \p' -> do set p' [PointId =. val newPk] - [Entity _ ret] <- select $ from $ return + [Entity _ ret] <- select $ from $ table @Point asserting $ do ret `shouldBe` Point newX newY [] -} @@ -1285,13 +1274,16 @@ testUpdate = describe "update" $ do p3k <- insert p3 replicateM_ 3 (insert $ BlogPost "" p1k) replicateM_ 7 (insert $ BlogPost "" p3k) - ret <- select $ - from $ \(p `LeftOuterJoin` b) -> do - on (p ^. PersonId ==. b ^. BlogPostAuthorId) - groupBy (p ^. PersonId) - let cnt = count (b ^. BlogPostId) - orderBy [ asc cnt ] - return (p, cnt) + ret <- select $ do + (p :& b) <- + from $ table @Person + `leftJoin` table @BlogPost + `on` (\(p :& b) -> + just (p ^. PersonId) ==. b ?. BlogPostAuthorId) + groupBy (p ^. PersonId) + let cnt = count (b ?. BlogPostId) + orderBy [ asc cnt ] + return (p, cnt) asserting $ ret `shouldBe` [ (Entity p2k p2, Value (0 :: Int)) , (Entity p1k p1, Value 3) , (Entity p3k p3, Value 7) ] @@ -1300,8 +1292,8 @@ testUpdate = describe "update" $ do p1k <- insert $ Point 1 2 "asdf" p2k <- insert $ Point 2 3 "asdf" ret <- - selectRethrowingQuery $ - from $ \point -> do + selectRethrowingQuery $ do + point <- from $ table @Point where_ $ point ^. PointName ==. val "asdf" groupBy (point ^. PointId) pure (point ^. PointId) @@ -1318,13 +1310,16 @@ testUpdate = describe "update" $ do mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) - (ret :: [(Value (Key Lord), Value Int)]) <- select $ from $ - \ ( lord `InnerJoin` deed ) -> do - on $ lord ^. LordId ==. deed ^. DeedOwnerId - groupBy (lord ^. LordId) - return (lord ^. LordId, count $ deed ^. DeedId) + ret <- select $ do + (lord :& deed) <- + from $ table @Lord + `innerJoin` table @Deed + `on` (\(lord :& deed) -> + lord ^. LordId ==. deed ^. DeedOwnerId) + groupBy (lord ^. LordId) + return (lord ^. LordId, count @Int $ deed ^. DeedId) asserting $ ret `shouldMatchList` [ (Value l3k, Value 7) - , (Value l1k, Value 3) ] + , (Value l1k, Value 3) ] itDb "GROUP BY works with nested tuples" $ do l1k <- insert l1 @@ -1333,11 +1328,14 @@ testUpdate = describe "update" $ do mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) - (ret :: [(Value (Key Lord), Value Int)]) <- select $ from $ - \ ( lord `InnerJoin` deed ) -> do - on $ lord ^. LordId ==. deed ^. DeedOwnerId - groupBy ((lord ^. LordId, lord ^. LordDogs), deed ^. DeedContract) - return (lord ^. LordId, count $ deed ^. DeedId) + ret <- select $ do + (lord :& deed) <- + from $ table @Lord + `innerJoin` table @Deed + `on` (\(lord :& deed) -> + lord ^. LordId ==. deed ^. DeedOwnerId) + groupBy ((lord ^. LordId, lord ^. LordDogs), deed ^. DeedContract) + return (lord ^. LordId, count @Int $ deed ^. DeedId) asserting $ length ret `shouldBe` 10 itDb "GROUP BY works with HAVING" $ do @@ -1346,14 +1344,17 @@ testUpdate = describe "update" $ do p3k <- insert p3 replicateM_ 3 (insert $ BlogPost "" p1k) replicateM_ 7 (insert $ BlogPost "" p3k) - ret <- select $ - from $ \(p `LeftOuterJoin` b) -> do - on (p ^. PersonId ==. b ^. BlogPostAuthorId) - let cnt = count (b ^. BlogPostId) - groupBy (p ^. PersonId) - having (cnt >. (val 0)) - orderBy [ asc cnt ] - return (p, cnt) + ret <- select $ do + (p :& b) <- + from $ table @Person + `leftJoin` table @BlogPost + `on` (\(p :& b) -> + just (p ^. PersonId) ==. b ?. BlogPostAuthorId) + let cnt = count (b ?. BlogPostId) + groupBy (p ^. PersonId) + having (cnt >. (val 0)) + orderBy [ asc cnt ] + return (p, cnt) asserting $ ret `shouldBe` [ (Entity p1k p1, Value (3 :: Int)) , (Entity p3k p3, Value 7) ] @@ -1368,20 +1369,26 @@ testSqlWriteT = -- select queries. testSqlWriteTRead :: MonadIO m => SqlWriteT m [(Value (Key Lord), Value Int)] testSqlWriteTRead = - select $ - from $ \ ( lord `InnerJoin` deed ) -> do - on $ lord ^. LordId ==. deed ^. DeedOwnerId - groupBy (lord ^. LordId) - return (lord ^. LordId, count $ deed ^. DeedId) + select $ do + (lord :& deed) <- + from $ table @Lord + `innerJoin` table @Deed + `on` (\(lord :& deed) -> + lord ^. LordId ==. deed ^. DeedOwnerId) + groupBy (lord ^. LordId) + return (lord ^. LordId, count $ deed ^. DeedId) -- we only care that this compiles checks that SqlReadT allows testSqlReadT :: MonadIO m => SqlReadT m [(Value (Key Lord), Value Int)] testSqlReadT = - select $ - from $ \ ( lord `InnerJoin` deed ) -> do - on $ lord ^. LordId ==. deed ^. DeedOwnerId - groupBy (lord ^. LordId) - return (lord ^. LordId, count $ deed ^. DeedId) + select $ do + (lord :& deed) <- + from $ table @Lord + `innerJoin` table @Deed + `on` (\(lord :& deed) -> + lord ^. LordId ==. deed ^. DeedOwnerId) + groupBy (lord ^. LordId) + return (lord ^. LordId, count $ deed ^. DeedId) testListOfValues :: SpecDb testListOfValues = describe "lists of values" $ do @@ -1389,8 +1396,8 @@ testListOfValues = describe "lists of values" $ do p1k <- insert p1 p2k <- insert p2 _p3k <- insert p3 - ret <- select $ - from $ \p -> do + ret <- select $ do + p <- from $ table @Person where_ (p ^. PersonName `in_` valList (personName <$> [p1, p2])) return p asserting $ ret `shouldBe` [ Entity p1k p1 @@ -1400,10 +1407,10 @@ testListOfValues = describe "lists of values" $ do _p1k <- insert p1 _p2k <- insert p2 _p3k <- insert p3 - ret <- select $ - from $ \p -> do - where_ (p ^. PersonName `in_` valList []) - return p + ret <- select $ do + p <- from $ table @Person + where_ (p ^. PersonName `in_` valList []) + return p asserting $ ret `shouldBe` [] itDb "IN works for subList_select" $ do @@ -1412,10 +1419,10 @@ testListOfValues = describe "lists of values" $ do p3k <- insert p3 _ <- insert (BlogPost "" p1k) _ <- insert (BlogPost "" p3k) - ret <- select $ - from $ \p -> do - let subquery = - from $ \bp -> do + ret <- select $ do + p <- from $ table @Person + let subquery = do + bp <- from $ table @BlogPost orderBy [ asc (bp ^. BlogPostAuthorId) ] return (bp ^. BlogPostAuthorId) where_ (p ^. PersonId `in_` subList_select subquery) @@ -1428,23 +1435,23 @@ testListOfValues = describe "lists of values" $ do p3k <- insert p3 _ <- insert (BlogPost "" p1k) _ <- insert (BlogPost "" p3k) - ret <- select $ - from $ \p -> do - let subquery = - from $ \bp -> + ret <- select $ do + p <- from $ table @Person + let subquery = do + bp <- from $ table @BlogPost return (bp ^. BlogPostAuthorId) - where_ (p ^. PersonId `notIn` subList_select subquery) - return p + where_ (p ^. PersonId `notIn` subSelectList subquery) + return p asserting $ ret `shouldBe` [ Entity p2k p2 ] itDb "NOT IN works for valList (null list)" $ do p1k <- insert p1 p2k <- insert p2 p3k <- insert p3 - ret <- select $ - from $ \p -> do - where_ (p ^. PersonName `notIn` valList []) - return p + ret <- select $ do + p <- from $ table @Person + where_ (p ^. PersonName `notIn` valList []) + return p asserting $ ret `shouldMatchList` [ Entity p1k p1 , Entity p2k p2 , Entity p3k p3 @@ -1456,13 +1463,13 @@ testListOfValues = describe "lists of values" $ do p3k <- insert p3 _ <- insert (BlogPost "" p1k) _ <- insert (BlogPost "" p3k) - ret <- select $ - from $ \p -> do - where_ $ exists $ - from $ \bp -> do - where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId) - orderBy [asc (p ^. PersonName)] - return p + ret <- select $ do + p <- from $ table @Person + where_ $ exists $ do + bp <- from $ table @BlogPost + where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId) + orderBy [asc (p ^. PersonName)] + return p asserting $ ret `shouldBe` [ Entity p1k p1 , Entity p3k p3 ] @@ -1472,12 +1479,12 @@ testListOfValues = describe "lists of values" $ do p3k <- insert p3 _ <- insert (BlogPost "" p1k) _ <- insert (BlogPost "" p3k) - ret <- select $ - from $ \p -> do - where_ $ notExists $ - from $ \bp -> do + ret <- select $ do + p <- from $ table @Person + where_ $ notExists $ do + bp <- from $ table @BlogPost where_ (bp ^. BlogPostAuthorId ==. p ^. PersonId) - return p + return p asserting $ ret `shouldBe` [ Entity p2k p2 ] testListFields :: SpecDb @@ -1498,9 +1505,12 @@ testInsertsBySelect = do _ <- insert p1 _ <- insert p2 _ <- insert p3 - insertSelect $ from $ \p -> do + insertSelect $ do + p <- from $ table @Person return $ BlogPost <# val "FakePost" <&> (p ^. PersonId) - ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows) + ret <- select $ do + _ <- from $ table @BlogPost + return countRows asserting $ ret `shouldBe` [Value (3::Int)] @@ -1515,9 +1525,12 @@ testInsertsBySelectReturnsCount = do _ <- insert p1 _ <- insert p2 _ <- insert p3 - cnt <- insertSelectCount $ from $ \p -> do - return $ BlogPost <# val "FakePost" <&> (p ^. PersonId) - ret <- select $ from (\(_::(SqlExpr (Entity BlogPost))) -> return countRows) + cnt <- insertSelectCount $ do + p <- from $ table @Person + return $ BlogPost <# val "FakePost" <&> (p ^. PersonId) + ret <- select $ do + _ <- from $ table @BlogPost + return countRows asserting $ ret `shouldBe` [Value (3::Int)] asserting $ cnt `shouldBe` 3 @@ -1537,10 +1550,12 @@ testRandomMath = describe "random_ math" $ _ <- 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 + ret1 <- fmap (map unValue) $ select $ do + p <- from $ table @Person orderBy [rand] return (p ^. PersonId) - ret2 <- fmap (map unValue) $ select $ from $ \p -> do + ret2 <- fmap (map unValue) $ select $ do + p <- from $ table @Person orderBy [rand] return (p ^. PersonId) @@ -1553,19 +1568,15 @@ testMathFunctions = do do mapM_ insert [Numbers 2 3.4, Numbers 7 1.1] ret <- - select $ - from $ \n -> do - let r = castNum (n ^. NumbersInt) *. n ^. NumbersDouble - orderBy [asc r] - return r + select $ do + n <- from $ table @Numbers + let r = castNum (n ^. NumbersInt) *. n ^. NumbersDouble + orderBy [asc r] + return r asserting $ length ret `shouldBe` 2 let [Value a, Value b] = ret asserting $ max (abs (a - 6.8)) (abs (b - 7.7)) `shouldSatisfy` (< 0.01) - - - - testCase :: SpecDb testCase = do describe "case" $ do @@ -1600,35 +1611,39 @@ testCase = do return $ case_ [ when_ - (exists $ from $ \p -> do + (exists $ do + p <- from $ table @Person where_ (p ^. PersonName ==. val "Mike")) then_ - (sub_select $ from $ \v -> do - let sub = - from $ \c -> do - where_ (c ^. PersonName ==. val "Mike") - return (c ^. PersonFavNum) - where_ (v ^. PersonFavNum >. sub_select sub) + (subSelect $ do + v <- from $ table @Person + let sub = do + c <- from $ table @Person + where_ (c ^. PersonName ==. val "Mike") + return (c ^. PersonFavNum) + 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 let toText conn q = let (tlb, _) = EI.toRawSql EI.SELECT (conn, EI.initialIdentState) q in TLB.toLazyText tlb - complexQuery = - from $ \(p1' `InnerJoin` p2') -> do - on (p1' ^. PersonName ==. p2' ^. PersonName) - where_ (p1' ^. PersonFavNum >. val 2) - orderBy [desc (p2' ^. PersonAge)] - limit 3 - offset 9 - groupBy (p1' ^. PersonId) - having (countRows <. val (0 :: Int)) - return (p1', p2') + complexQuery = do + (p1' :& p2') <- from $ table @Person + `innerJoin` table @Person + `on` (\(p1' :& p2') -> + p1' ^. PersonName ==. p2' ^. PersonName) + where_ (p1' ^. PersonFavNum >. val 2) + orderBy [desc (p2' ^. PersonAge)] + limit 3 + offset 9 + groupBy (p1' ^. PersonId) + having (countRows <. val (0 :: Int)) + return (p1', p2') describe "locking" $ do -- The locking clause is the last one, so try to use many -- others to test if it's at the right position. We don't @@ -1652,9 +1667,11 @@ testLocking = do [complex, with1, with2, with3] <- return $ map (toText conn) [complexQuery, queryWithClause1, queryWithClause2, queryWithClause3] - let expected = complex <> "\n" <> syntax - asserting $ - (with1, with2, with3) `shouldBe` (expected, expected, expected) + let expected = complex <> syntax <> "\n" + asserting $ do + with1 `shouldBe` expected + with2 `shouldBe` expected + with3 `shouldBe` expected itDb "looks sane for ForUpdate" $ sanityCheck ForUpdate "FOR UPDATE" itDb "looks sane for ForUpdateSkipLocked" $ sanityCheck ForUpdateSkipLocked "FOR UPDATE SKIP LOCKED" itDb "looks sane for ForShare" $ sanityCheck ForShare "FOR SHARE" @@ -1672,23 +1689,23 @@ testLocking = do locking ForUpdate multipleLockingQueryPostgresLast = do - p <- Experimental.from $ table @Person + p <- from $ table @Person multipleLegacyLockingClauses multiplePostgresLockingClauses p multipleLockingQueryLegacyLast = do - p <- Experimental.from $ table @Person + p <- from $ table @Person multiplePostgresLockingClauses p multipleLegacyLockingClauses expectedPostgresQuery = do - p <- Experimental.from $ table @Person + p <- from $ table @Person EP.forUpdateOf p EP.skipLocked EP.forUpdateOf p EP.skipLocked EP.forShareOf p EP.skipLocked expectedLegacyQuery = do - p <- Experimental.from $ table @Person + _p <- from $ table @Person locking ForUpdate itDb "prioritizes last grouping of locks when mixing legacy and postgres specific locks" $ do @@ -1718,17 +1735,19 @@ testCountingRows = do , Person "" (Just 2) (Just 1) 1 , Person "" (Just 2) (Just 2) 1 , Person "" Nothing (Just 3) 1] - [Value n] <- select $ from $ return . countKind + [Value n] <- select $ do + p <- from $ table @Person + return $ countKind p asserting $ (n :: Int) `shouldBe` expected testRenderSql :: SpecDb testRenderSql = do describe "testRenderSql" $ do itDb "works" $ do - (queryText, queryVals) <- renderQuerySelect $ - from $ \p -> do - where_ $ p ^. PersonName ==. val "Johhny Depp" - pure (p ^. PersonName, p ^. PersonAge) + (queryText, queryVals) <- renderQuerySelect $ do + p <- from $ table @Person + where_ $ p ^. PersonName ==. val "Johhny Depp" + pure (p ^. PersonName, p ^. PersonAge) -- the different backends use different quote marks, so I filter them out -- here instead of making a duplicate test asserting $ do @@ -1765,597 +1784,7 @@ testRenderSql = do expr <- ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1)) asserting $ expr `shouldBe` "? = ?" - beforeWith (\_ -> pure ()) $ describe "ExprParser" $ do - let parse parser = AP.parseOnly (parser '#') - describe "parseEscapedChars" $ do - let subject = parse P.parseEscapedChars - it "parses words" $ do - subject "hello world" - `shouldBe` - Right "hello world" - it "only returns a single escape-char if present" $ do - subject "i_am##identifier##" - `shouldBe` - Right "i_am#identifier#" - describe "parseEscapedIdentifier" $ do - let subject = parse P.parseEscapedIdentifier - it "parses the quotes out" $ do - subject "#it's a me, mario#" - `shouldBe` - Right "it's a me, mario" - it "requires a beginning and end quote" $ do - subject "#alas, i have no end" - `shouldSatisfy` - isLeft - describe "parseTableAccess" $ do - let subject = parse P.parseTableAccess - it "parses a table access" $ do - subject "#foo#.#bar#" - `shouldBe` - Right P.TableAccess - { P.tableAccessTable = "foo" - , P.tableAccessColumn = "bar" - } - describe "onExpr" $ do - let subject = parse P.onExpr - it "works" $ do - subject "#foo#.#bar# = #bar#.#baz#" - `shouldBe` do - Right $ S.fromList - [ P.TableAccess - { P.tableAccessTable = "foo" - , P.tableAccessColumn = "bar" - } - , P.TableAccess - { P.tableAccessTable = "bar" - , P.tableAccessColumn = "baz" - } - ] - it "also works with other nonsense" $ do - subject "#foo#.#bar# = 3" - `shouldBe` do - Right $ S.fromList - [ P.TableAccess - { P.tableAccessTable = "foo" - , P.tableAccessColumn = "bar" - } - ] - it "handles a conjunction" $ do - subject "#foo#.#bar# = #bar#.#baz# AND #bar#.#baz# > 10" - `shouldBe` do - Right $ S.fromList - [ P.TableAccess - { P.tableAccessTable = "foo" - , P.tableAccessColumn = "bar" - } - , P.TableAccess - { P.tableAccessTable = "bar" - , P.tableAccessColumn = "baz" - } - ] - it "handles ? okay" $ do - subject "#foo#.#bar# = ?" - `shouldBe` do - Right $ S.fromList - [ P.TableAccess - { P.tableAccessTable = "foo" - , P.tableAccessColumn = "bar" - } - ] - it "handles degenerate cases" $ do - subject "false" `shouldBe` pure mempty - subject "true" `shouldBe` pure mempty - subject "1 = 1" `shouldBe` pure mempty - it "works even if an identifier isn't first" $ do - subject "true and #foo#.#bar# = 2" - `shouldBe` do - Right $ S.fromList - [ P.TableAccess - { P.tableAccessTable = "foo" - , P.tableAccessColumn = "bar" - } - ] - -testOnClauseOrder :: SpecDb -testOnClauseOrder = describe "On Clause Ordering" $ do - let - setup :: MonadIO m => SqlPersistT m () - setup = do - ja1 <- insert (JoinOne "j1 hello") - ja2 <- insert (JoinOne "j1 world") - jb1 <- insert (JoinTwo ja1 "j2 hello") - jb2 <- insert (JoinTwo ja1 "j2 world") - jb3 <- insert (JoinTwo ja2 "j2 foo") - _ <- insert (JoinTwo ja2 "j2 bar") - jc1 <- insert (JoinThree jb1 "j3 hello") - jc2 <- insert (JoinThree jb1 "j3 world") - _ <- insert (JoinThree jb2 "j3 foo") - _ <- insert (JoinThree jb3 "j3 bar") - _ <- insert (JoinThree jb3 "j3 baz") - _ <- insert (JoinFour "j4 foo" jc1) - _ <- insert (JoinFour "j4 bar" jc2) - jd1 <- insert (JoinOther "foo") - jd2 <- insert (JoinOther "bar") - _ <- insert (JoinMany "jm foo hello" jd1 ja1) - _ <- insert (JoinMany "jm foo world" jd1 ja2) - _ <- insert (JoinMany "jm bar hello" jd2 ja1) - _ <- insert (JoinMany "jm bar world" jd2 ja2) - pure () - describe "identical results for" $ do - itDb "three tables" $ do - setup - abcs <- - select $ - from $ \(a `InnerJoin` b `InnerJoin` c) -> do - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - pure (a, b, c) - acbs <- - select $ - from $ \(a `InnerJoin` b `InnerJoin` c) -> do - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - pure (a, b, c) - asserting $ do - listsEqualOn abcs acbs $ \(Entity _ j1, Entity _ j2, Entity _ j3) -> - (joinOneName j1, joinTwoName j2, joinThreeName j3) - - itDb "four tables" $ do - setup - xs0 <- - select $ - from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - pure (a, b, c, d) - xs1 <- - select $ - from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - pure (a, b, c, d) - xs2 <- - select $ - from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - pure (a, b, c, d) - xs3 <- - select $ - from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - pure (a, b, c, d) - xs4 <- - select $ - from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - pure (a, b, c, d) - - let - getNames (j1, j2, j3, j4) = - ( joinOneName (entityVal j1) - , joinTwoName (entityVal j2) - , joinThreeName (entityVal j3) - , joinFourName (entityVal j4) - ) - asserting $ do - listsEqualOn xs0 xs1 getNames - listsEqualOn xs0 xs2 getNames - listsEqualOn xs0 xs3 getNames - listsEqualOn xs0 xs4 getNames - - itDb "associativity of innerjoin" $ do - setup - xs0 <- - select $ - from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - pure (a, b, c, d) - - xs1 <- - select $ - from $ \(a `InnerJoin` b `InnerJoin` (c `InnerJoin` d)) -> do - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - pure (a, b, c, d) - - xs2 <- - select $ - from $ \(a `InnerJoin` (b `InnerJoin` c) `InnerJoin` d) -> do - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - pure (a, b, c, d) - - xs3 <- - select $ - from $ \(a `InnerJoin` (b `InnerJoin` c `InnerJoin` d)) -> do - on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne) - on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo) - on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree) - pure (a, b, c, d) - - let getNames (j1, j2, j3, j4) = - ( joinOneName (entityVal j1) - , joinTwoName (entityVal j2) - , joinThreeName (entityVal j3) - , joinFourName (entityVal j4) - ) - asserting $ do - listsEqualOn xs0 xs1 getNames - listsEqualOn xs0 xs2 getNames - listsEqualOn xs0 xs3 getNames - - itDb "inner join on two entities" $ do - (xs0, xs1) <- do - pid <- insert $ Person "hello" Nothing Nothing 3 - _ <- insert $ BlogPost "good poast" pid - _ <- insert $ Profile "cool" pid - xs0 <- selectRethrowingQuery $ - from $ \(p `InnerJoin` b `InnerJoin` pr) -> do - on $ p ^. PersonId ==. b ^. BlogPostAuthorId - on $ p ^. PersonId ==. pr ^. ProfilePerson - pure (p, b, pr) - xs1 <- selectRethrowingQuery $ - from $ \(p `InnerJoin` b `InnerJoin` pr) -> do - on $ p ^. PersonId ==. pr ^. ProfilePerson - on $ p ^. PersonId ==. b ^. BlogPostAuthorId - pure (p, b, pr) - pure (xs0, xs1) - asserting $ listsEqualOn xs0 xs1 $ \(Entity _ p, Entity _ b, Entity _ pr) -> - (personName p, blogPostTitle b, profileName pr) - itDb "inner join on three entities" $ do - res <- do - pid <- insert $ Person "hello" Nothing Nothing 3 - _ <- insert $ BlogPost "good poast" pid - _ <- insert $ BlogPost "good poast #2" pid - _ <- insert $ Profile "cool" pid - _ <- insert $ Reply pid "u wot m8" - _ <- insert $ Reply pid "how dare you" - - bprr <- selectRethrowingQuery $ - from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do - on $ p ^. PersonId ==. b ^. BlogPostAuthorId - on $ p ^. PersonId ==. pr ^. ProfilePerson - on $ p ^. PersonId ==. r ^. ReplyGuy - pure (p, b, pr, r) - - brpr <- selectRethrowingQuery $ - from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do - on $ p ^. PersonId ==. b ^. BlogPostAuthorId - on $ p ^. PersonId ==. r ^. ReplyGuy - on $ p ^. PersonId ==. pr ^. ProfilePerson - pure (p, b, pr, r) - - prbr <- selectRethrowingQuery $ - from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do - on $ p ^. PersonId ==. pr ^. ProfilePerson - on $ p ^. PersonId ==. b ^. BlogPostAuthorId - on $ p ^. PersonId ==. r ^. ReplyGuy - pure (p, b, pr, r) - - prrb <- selectRethrowingQuery $ - from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do - on $ p ^. PersonId ==. pr ^. ProfilePerson - on $ p ^. PersonId ==. r ^. ReplyGuy - on $ p ^. PersonId ==. b ^. BlogPostAuthorId - pure (p, b, pr, r) - - rprb <- selectRethrowingQuery $ - from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do - on $ p ^. PersonId ==. r ^. ReplyGuy - on $ p ^. PersonId ==. pr ^. ProfilePerson - on $ p ^. PersonId ==. b ^. BlogPostAuthorId - pure (p, b, pr, r) - - rbpr <- selectRethrowingQuery $ - from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do - on $ p ^. PersonId ==. r ^. ReplyGuy - on $ p ^. PersonId ==. b ^. BlogPostAuthorId - on $ p ^. PersonId ==. pr ^. ProfilePerson - pure (p, b, pr, r) - - pure [bprr, brpr, prbr, prrb, rprb, rbpr] - asserting $ forM_ (zip res (drop 1 (cycle res))) $ \(a, b) -> a `shouldBe` b - - itDb "many-to-many" $ do - setup - ac <- - select $ - from $ \(a `InnerJoin` b `InnerJoin` c) -> do - on (a ^. JoinOneId ==. b ^. JoinManyJoinOne) - on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther) - pure (a, c) - - ca <- - select $ - from $ \(a `InnerJoin` b `InnerJoin` c) -> do - on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther) - on (a ^. JoinOneId ==. b ^. JoinManyJoinOne) - pure (a, c) - - asserting $ listsEqualOn ac ca $ \(Entity _ a, Entity _ b) -> - (joinOneName a, joinOtherName b) - - itDb "left joins on order" $ do - setup - ca <- - select $ - from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do - on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) - on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) - orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] - pure (a, c) - ac <- - select $ - from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do - on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) - on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) - orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] - pure (a, c) - - asserting $ listsEqualOn ac ca $ \(Entity _ a, b) -> - (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b) - - itDb "doesn't require an on for a crossjoin" $ do - void $ - select $ - from $ \(a `CrossJoin` b) -> do - pure (a :: SqlExpr (Entity JoinOne), b :: SqlExpr (Entity JoinTwo)) - asserting noExceptions - - itDb "errors with an on for a crossjoin" $ do - eres <- - try $ - select $ - from $ \(a `CrossJoin` b) -> do - on $ a ^. JoinOneId ==. b ^. JoinTwoJoinOne - pure (a, b) - asserting $ - case eres of - Left (OnClauseWithoutMatchingJoinException _) -> - pure () - Right _ -> - expectationFailure "Expected OnClause exception" - - itDb "left joins associativity" $ do - setup - ca <- - select $ - from $ \(a `LeftOuterJoin` (b `InnerJoin` c)) -> do - on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) - on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) - orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] - pure (a, c) - ca' <- - select $ - from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do - on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther) - on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne) - orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId] - pure (a, c) - - asserting $ listsEqualOn ca ca' $ \(Entity _ a, b) -> - (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b) - - itDb "composes queries still" $ do - let - query1 = - from $ \(foo `InnerJoin` bar) -> do - on (foo ^. FooId ==. bar ^. BarQuux) - pure (foo, bar) - query2 = - from $ \(p `LeftOuterJoin` bp) -> do - on (p ^. PersonId ==. bp ^. BlogPostAuthorId) - pure (p, bp) - fid <- insert $ Foo 5 - _ <- insert $ Bar fid - pid <- insert $ Person "hey" Nothing Nothing 30 - _ <- insert $ BlogPost "WHY" pid - a <- select ((,) <$> query1 <*> query2) - b <- select (flip (,) <$> query1 <*> query2) - asserting $ listsEqualOn a (map (\(x, y) -> (y, x)) b) id - - itDb "works with joins in subselect" $ do - select $ - from $ \(p `InnerJoin` r) -> do - on $ p ^. PersonId ==. r ^. ReplyGuy - pure . (,) (p ^. PersonName) $ - subSelect $ - from $ \(c `InnerJoin` bp) -> do - on $ bp ^. BlogPostId ==. c ^. CommentBlog - pure (c ^. CommentBody) - asserting noExceptions - - describe "works with nested joins" $ do - itDb "unnested" $ do - selectRethrowingQuery $ - from $ \(f `InnerJoin` b `LeftOuterJoin` baz `InnerJoin` shoop) -> do - on $ f ^. FooId ==. b ^. BarQuux - on $ f ^. FooId ==. baz ^. BazBlargh - on $ baz ^. BazId ==. shoop ^. ShoopBaz - pure ( f ^. FooName) - asserting noExceptions - - itDb "leftmost nesting" $ do - selectRethrowingQuery $ - from $ \((f `InnerJoin` b) `LeftOuterJoin` baz `InnerJoin` shoop) -> do - on $ f ^. FooId ==. b ^. BarQuux - on $ f ^. FooId ==. baz ^. BazBlargh - on $ baz ^. BazId ==. shoop ^. ShoopBaz - pure ( f ^. FooName) - asserting noExceptions - describe "middle nesting" $ do - itDb "direct association" $ do - selectRethrowingQuery $ - from $ \(p `InnerJoin` (bp `LeftOuterJoin` c) `LeftOuterJoin` cr) -> do - on $ p ^. PersonId ==. bp ^. BlogPostAuthorId - on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog - on $ c ?. CommentId ==. cr ?. CommentReplyComment - pure (p,bp,c,cr) - asserting noExceptions - itDb "indirect association" $ do - selectRethrowingQuery $ - from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf) -> do - on $ f ^. FooId ==. b ^. BarQuux - on $ f ^. FooId ==. baz ^. BazBlargh - on $ baz ^. BazId ==. shoop ^. ShoopBaz - on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId - pure (f ^. FooName) - asserting noExceptions - itDb "indirect association across" $ do - selectRethrowingQuery $ - from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf `InnerJoin` another `InnerJoin` yetAnother) -> do - on $ f ^. FooId ==. b ^. BarQuux - on $ f ^. FooId ==. baz ^. BazBlargh - on $ baz ^. BazId ==. shoop ^. ShoopBaz - on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId - on $ another ^. AnotherWhy ==. baz ^. BazId - on $ yetAnother ^. YetAnotherArgh ==. shoop ^. ShoopId - pure (f ^. FooName) - asserting noExceptions - - describe "rightmost nesting" $ do - itDb "direct associations" $ do - selectRethrowingQuery $ - from $ \(p `InnerJoin` bp `LeftOuterJoin` (c `LeftOuterJoin` cr)) -> do - on $ p ^. PersonId ==. bp ^. BlogPostAuthorId - on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog - on $ c ?. CommentId ==. cr ?. CommentReplyComment - pure (p,bp,c,cr) - asserting noExceptions - - itDb "indirect association" $ do - selectRethrowingQuery $ - from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop)) -> do - on $ f ^. FooId ==. b ^. BarQuux - on $ f ^. FooId ==. baz ^. BazBlargh - on $ baz ^. BazId ==. shoop ^. ShoopBaz - pure (f ^. FooName) - asserting noExceptions - -testExperimentalFrom :: SpecDb -testExperimentalFrom = do - describe "Experimental From" $ do - itDb "supports basic table queries" $ do - p1e <- insert' p1 - _ <- insert' p2 - p3e <- insert' p3 - peopleWithAges <- select $ do - people <- Experimental.from $ Table @Person - where_ $ not_ $ isNothing $ people ^. PersonAge - return people - asserting $ peopleWithAges `shouldMatchList` [p1e, p3e] - - itDb "supports inner joins" $ do - l1e <- insert' l1 - _ <- insert l2 - d1e <- insert' $ Deed "1" (entityKey l1e) - d2e <- insert' $ Deed "2" (entityKey l1e) - lordDeeds <- select $ do - (lords :& deeds) <- - Experimental.from $ Table @Lord - `InnerJoin` Table @Deed - `Experimental.on` (\(l :& d) -> l ^. LordId ==. d ^. DeedOwnerId) - pure (lords, deeds) - asserting $ lordDeeds `shouldMatchList` [ (l1e, d1e) - , (l1e, d2e) - ] - - itDb "supports outer joins" $ do - l1e <- insert' l1 - l2e <- insert' l2 - d1e <- insert' $ Deed "1" (entityKey l1e) - d2e <- insert' $ Deed "2" (entityKey l1e) - lordDeeds <- select $ do - (lords :& deeds) <- - Experimental.from $ Table @Lord - `LeftOuterJoin` Table @Deed - `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId) - - pure (lords, deeds) - asserting $ lordDeeds `shouldMatchList` [ (l1e, Just d1e) - , (l1e, Just d2e) - , (l2e, Nothing) - ] - itDb "supports delete" $ do - insert_ l1 - insert_ l2 - insert_ l3 - delete $ void $ Experimental.from $ Table @Lord - lords <- select $ Experimental.from $ Table @Lord - asserting $ lords `shouldMatchList` [] - - itDb "supports implicit cross joins" $ do - l1e <- insert' l1 - l2e <- insert' l2 - ret <- select $ do - lords1 <- Experimental.from $ Table @Lord - lords2 <- Experimental.from $ Table @Lord - pure (lords1, lords2) - ret2 <- select $ do - (lords1 :& lords2) <- Experimental.from $ Table @Lord `CrossJoin` Table @Lord - pure (lords1,lords2) - asserting $ ret `shouldMatchList` ret2 - asserting $ ret `shouldMatchList` [ (l1e, l1e) - , (l1e, l2e) - , (l2e, l1e) - , (l2e, l2e) - ] - - itDb "compiles" $ do - let q = do - (persons :& profiles :& posts) <- - Experimental.from $ Table @Person - `InnerJoin` Table @Profile - `Experimental.on` (\(people :& profiles) -> - people ^. PersonId ==. profiles ^. ProfilePerson) - `LeftOuterJoin` Table @BlogPost - `Experimental.on` (\(people :& _ :& posts) -> - just (people ^. PersonId) ==. posts ?. BlogPostAuthorId) - pure (persons, posts, profiles) - asserting noExceptions - - itDb "can call functions on aliased values" $ do - insert_ p1 - insert_ p3 - -- Pretend this isnt all posts - upperNames <- select $ do - author <- Experimental.from $ SelectQuery $ Experimental.from $ Table @Person - pure $ upper_ $ author ^. PersonName - - asserting $ upperNames `shouldMatchList` [ Value "JOHN" - , Value "MIKE" - ] - itDb "allows re-using (:&) joined tables" $ do - let q = do - result@(persons :& profiles :& posts) <- - Experimental.from $ Table @Person - `InnerJoin` Table @Profile - `Experimental.on` (\(people :& profiles) -> - people ^. PersonId ==. profiles ^. ProfilePerson) - `InnerJoin` Table @BlogPost - `Experimental.on` (\(people :& _ :& posts) -> - people ^. PersonId ==. posts ^. BlogPostAuthorId) - pure result - rows <- select $ do - (persons :& profiles :& posts) <- Experimental.from $ q - pure (persons ^. PersonId, profiles ^. ProfileId, posts ^. BlogPostId) - let result = rows :: [(Value PersonId, Value ProfileId, Value BlogPostId)] - -- We don't care about the result of the query, only that it - -- rendered & executed. - asserting noExceptions listsEqualOn :: (HasCallStack, Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) -> Expectation listsEqualOn a b f = map f a `shouldBe` map f b @@ -2384,8 +1813,6 @@ tests = testCase testCountingRows testRenderSql - testOnClauseOrder - testExperimentalFrom testLocking testOverloadedRecordDot testDeriveEsqueletoRecord @@ -2406,51 +1833,49 @@ insert' v = flip Entity v <$> insert v -- separate database. With 'actual databases', the data is persistent and -- thus must be cleaned after each test. -- TODO: there is certainly a better way... -cleanDB - :: forall m. _ - => SqlPersistT m () +cleanDB :: MonadIO m => SqlPersistT m () cleanDB = do - delete $ from $ \(_ :: SqlExpr (Entity Bar)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity Foo)) -> return () + delete $ void $ from $ table @Bar + delete $ void $ from $ table @Foo - delete $ from $ \(_ :: SqlExpr (Entity Reply)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity Comment)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity Profile)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity BlogPost)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity Follow)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity Person)) -> return () + delete $ void $ from $ table @Reply + delete $ void $ from $ table @Comment + delete $ void $ from $ table @Profile + delete $ void $ from $ table @BlogPost + delete $ void $ from $ table @Follow + delete $ void $ from $ table @Person - delete $ from $ \(_ :: SqlExpr (Entity Deed)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity Lord)) -> return () + delete $ void $ from $ table @Deed + delete $ void $ from $ table @Lord - delete $ from $ \(_ :: SqlExpr (Entity CcList)) -> return () + delete $ void $ from $ table @CcList - delete $ from $ \(_ :: SqlExpr (Entity ArticleTag)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity ArticleMetadata)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity Article)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity Article2)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity Tag)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity Frontcover)) -> return () + delete $ void $ from $ table @ArticleTag + delete $ void $ from $ table @ArticleMetadata + delete $ void $ from $ table @Article + delete $ void $ from $ table @Article2 + delete $ void $ from $ table @Tag + delete $ void $ from $ table @Frontcover - delete $ from $ \(_ :: SqlExpr (Entity Circle)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity Point)) -> return () + delete $ void $ from $ table @Circle + delete $ void $ from $ table @Point - delete $ from $ \(_ :: SqlExpr (Entity Numbers)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity JoinMany)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity JoinFour)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity JoinThree)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity JoinTwo)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity JoinOne)) -> return () - delete $ from $ \(_ :: SqlExpr (Entity JoinOther)) -> return () + delete $ void $ from $ table @Numbers + delete $ void $ from $ table @JoinMany + delete $ void $ from $ table @JoinFour + delete $ void $ from $ table @JoinThree + delete $ void $ from $ table @JoinTwo + delete $ void $ from $ table @JoinOne + delete $ void $ from $ table @JoinOther - delete $ from $ \(_ :: SqlExpr (Entity DateTruncTest)) -> pure () + delete $ void $ from $ table @DateTruncTest cleanUniques :: forall m. MonadIO m => SqlPersistT m () cleanUniques = - delete $ from $ \(_ :: SqlExpr (Entity OneUnique)) -> return () + delete $ void $ from $ table @OneUnique selectRethrowingQuery :: (MonadIO m, EI.SqlSelect a r, MonadUnliftIO m) @@ -2473,7 +1898,7 @@ updateRethrowingQuery updateRethrowingQuery k = update k `catch` \(SomeException e) -> do - (text, _) <- renderQueryUpdate (from k) + (text, _) <- renderQueryUpdate (from table >>= k) liftIO . throwIO . userError $ Text.unpack text <> "\n\n" <> show e shouldBeOnClauseWithoutMatchingJoinException @@ -2493,15 +1918,15 @@ testOverloadedRecordDot = describe "OverloadedRecordDot" $ do describe "with SqlExpr (Entity rec)" $ do itDb "lets you project from a record" $ do select $ do - bp <- Experimental.from $ table @BlogPost + bp <- from $ table @BlogPost pure bp.title describe "with SqlExpr (Maybe (Entity rec))" $ do itDb "lets you project from a Maybe record" $ do select $ do - p :& mbp <- Experimental.from $ + p :& mbp <- from $ table @Person `leftJoin` table @BlogPost - `Experimental.on` do + `on` do \(p :& mbp) -> just p.id ==. mbp.authorId pure (p.id, mbp.title) @@ -2515,20 +1940,20 @@ testGetTable :: SpecDb testGetTable = describe "GetFirstTable" $ do itDb "works to make long join chains easier" $ do - select $ do + void $ select $ do (person :& blogPost :& profile :& reply) <- - Experimental.from $ + from $ table @Person `leftJoin` table @BlogPost - `Experimental.on` do + `on` do \(p :& bp) -> just (p ^. PersonId) ==. bp ?. BlogPostAuthorId `leftJoin` table @Profile - `Experimental.on` do + `on` do \((getTable @Person -> p) :& profile) -> just (p ^. PersonId) ==. profile ?. ProfilePerson `leftJoin` table @Reply - `Experimental.on` do + `on` do \((getTable @Person -> p) :& reply) -> just (p ^. PersonId) ==. reply ?. ReplyGuy pure (person, blogPost, profile, reply) diff --git a/test/Common/Test/Import.hs b/test/Common/Test/Import.hs index 51d9372c8..8724f3ccb 100644 --- a/test/Common/Test/Import.hs +++ b/test/Common/Test/Import.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP, AllowAmbiguousTypes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} @@ -25,16 +26,16 @@ module Common.Test.Import , module X ) where -import System.Environment -import Control.Applicative import Common.Test.Models as X -import Database.Esqueleto.Experimental as X hiding (random_) -import Test.Hspec as X -import UnliftIO as X +import Control.Applicative import Control.Monad +import Control.Monad.Trans.Reader as X (ReaderT, ask, mapReaderT) +import Data.Text as X (Text) +import Database.Esqueleto as X +import System.Environment +import Test.Hspec as X import Test.QuickCheck -import Data.Text as X (Text) -import Control.Monad.Trans.Reader as X (ReaderT, mapReaderT, ask) +import UnliftIO as X type SpecDb = SpecWith ConnectionPool diff --git a/test/Common/Test/Models.hs b/test/Common/Test/Models.hs index dc6b94530..fb29de769 100644 --- a/test/Common/Test/Models.hs +++ b/test/Common/Test/Models.hs @@ -23,7 +23,7 @@ module Common.Test.Models where import Data.Time -import Database.Esqueleto.Experimental +import Database.Esqueleto import Database.Persist.Sql import Database.Persist.TH diff --git a/test/MySQL/LegacyTest.hs b/test/MySQL/LegacyTest.hs new file mode 100644 index 000000000..203a85ff7 --- /dev/null +++ b/test/MySQL/LegacyTest.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module MySQL.LegacyTest where + +import Common.Test.Import hiding (from, on) + +import Control.Applicative +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT) +import Control.Monad.Trans.Reader (ReaderT, mapReaderT) +import qualified Control.Monad.Trans.Resource as R +import Database.Esqueleto.Legacy +import Database.Persist.MySQL + ( connectDatabase + , connectHost + , connectPassword + , connectPort + , connectUser + , createMySQLPool + , defaultConnectInfo + ) + +import Test.Hspec + +import Common.LegacyTest + +testMysqlSum :: SpecDb +testMysqlSum = do + itDb "works with sum_" $ do + _ <- insert' p1 + _ <- insert' p2 + _ <- insert' p3 + _ <- insert' p4 + ret <- select $ + from $ \p-> + return $ joinV $ sum_ (p ^. PersonAge) + liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Double ) ] + +testMysqlTwoAscFields :: SpecDb +testMysqlTwoAscFields = do + itDb "works with two ASC fields (one call)" $ do + p1e <- insert' p1 + p2e <- insert' p2 + p3e <- insert' p3 + p4e <- insert' p4 + ret <- select $ + from $ \p -> do + orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] + return p + liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ] + +testMysqlOneAscOneDesc :: SpecDb +testMysqlOneAscOneDesc = do + itDb "works with one ASC and one DESC field (two calls)" $ do + p1e <- insert' p1 + p2e <- insert' p2 + p3e <- insert' p3 + p4e <- insert' p4 + ret <- select $ + from $ \p -> do + orderBy [desc (p ^. PersonAge)] + orderBy [asc (p ^. PersonName)] + return p + liftIO $ ret `shouldBe` [ p1e, p4e, p3e, p2e ] + + + + +testMysqlCoalesce :: SpecDb +testMysqlCoalesce = do + itDb "works on PostgreSQL and MySQL with <2 arguments" $ do + _ :: [Value (Maybe Int)] <- + select $ + from $ \p -> do + return (coalesce [p ^. PersonAge]) + return () + + + + +testMysqlUpdate :: SpecDb +testMysqlUpdate = do + itDb "works on a simple example" $ do + p1k <- insert p1 + p2k <- insert p2 + p3k <- insert p3 + let anon = "Anonymous" + () <- update $ \p -> do + set p [ PersonName =. val anon + , PersonAge *=. just (val 2) ] + where_ (p ^. PersonName !=. val "Mike") + n <- updateCount $ \p -> do + set p [ PersonAge +=. just (val 1) ] + where_ (p ^. PersonName !=. val "Mike") + ret <- select $ + from $ \p -> do + orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] + return p + -- MySQL: nulls appear first, and update returns actual number + -- of changed rows + liftIO $ n `shouldBe` 1 + liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing (Just 37) 2) + , Entity p1k (Person anon (Just 73) Nothing 1) + , Entity p3k p3 ] + +nameContains :: (SqlString s) + => (SqlExpr (Value [Char]) + -> SqlExpr (Value s) + -> SqlExpr (Value Bool)) + -> s + -> [Entity Person] + -> SqlPersistT IO () +nameContains f t expected = do + ret <- select $ + from $ \p -> do + where_ (f + (p ^. PersonName) + (concat_ [(%), val t, (%)])) + orderBy [asc (p ^. PersonName)] + return p + liftIO $ ret `shouldBe` expected + + +testMysqlTextFunctions :: SpecDb +testMysqlTextFunctions = do + describe "text functions" $ do + itDb "like, (%) and (++.) work on a simple example" $ do + [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] + nameContains like "h" [p1e, p2e] + nameContains like "i" [p4e, p3e] + nameContains like "iv" [p4e] + + +spec :: Spec +spec = beforeAll mkConnectionPool $ do + tests + + describe "MySQL specific tests" $ do + -- definitely doesn't work at the moment + -- testMysqlRandom + testMysqlSum + testMysqlTwoAscFields + testMysqlOneAscOneDesc + testMysqlCoalesce + testMysqlUpdate + testMysqlTextFunctions + +verbose :: Bool +verbose = False + +migrateIt :: R.MonadUnliftIO m => SqlPersistT m () +migrateIt = do + mapReaderT R.runResourceT $ void $ runMigrationSilent migrateAll + cleanDB + +mkConnectionPool :: IO ConnectionPool +mkConnectionPool = do + ci <- isCI + let connInfo + | ci = + defaultConnectInfo + { connectHost = "127.0.0.1" + , connectUser = "travis" + , connectPassword = "esqutest" + , connectDatabase = "esqutest" + , connectPort = 33306 + } + | otherwise = + defaultConnectInfo + { connectHost = "localhost" + , connectUser = "travis" + , connectPassword = "esqutest" + , connectDatabase = "esqutest" + , connectPort = 3306 + } + pool <- + if verbose + then + runStderrLoggingT $ + createMySQLPool connInfo 4 + else + runNoLoggingT $ + createMySQLPool connInfo 4 + + + flip runSqlPool pool $ do + migrateIt + cleanDB + + pure pool diff --git a/test/MySQL/Test.hs b/test/MySQL/Test.hs index 6941328f9..3d8be3e3c 100644 --- a/test/MySQL/Test.hs +++ b/test/MySQL/Test.hs @@ -15,17 +15,15 @@ import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT) import Control.Monad.Trans.Reader (ReaderT, mapReaderT) import qualified Control.Monad.Trans.Resource as R import Database.Esqueleto -import Database.Esqueleto.Experimental hiding (from, on) -import qualified Database.Esqueleto.Experimental as Experimental import Database.Persist.MySQL ( connectDatabase , connectHost , connectPassword , connectPort , connectUser + , createMySQLPool , defaultConnectInfo , withMySQLConn - , createMySQLPool ) import Test.Hspec @@ -39,8 +37,8 @@ testMysqlSum = do _ <- insert' p2 _ <- insert' p3 _ <- insert' p4 - ret <- select $ - from $ \p-> + ret <- select $ do + p <- from $ table @Person return $ joinV $ sum_ (p ^. PersonAge) liftIO $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Double ) ] @@ -51,8 +49,8 @@ testMysqlTwoAscFields = do p2e <- insert' p2 p3e <- insert' p3 p4e <- insert' p4 - ret <- select $ - from $ \p -> do + ret <- select $ do + p <- from $ table @Person orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] return p liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ] @@ -64,22 +62,19 @@ testMysqlOneAscOneDesc = do p2e <- insert' p2 p3e <- insert' p3 p4e <- insert' p4 - ret <- select $ - from $ \p -> do + ret <- select $ do + p <- from $ table @Person orderBy [desc (p ^. PersonAge)] orderBy [asc (p ^. PersonName)] return p liftIO $ ret `shouldBe` [ p1e, p4e, p3e, p2e ] - - - testMysqlCoalesce :: SpecDb testMysqlCoalesce = do itDb "works on PostgreSQL and MySQL with <2 arguments" $ do _ :: [Value (Maybe Int)] <- - select $ - from $ \p -> do + select $ do + p <- from $ table @Person return (coalesce [p ^. PersonAge]) return () @@ -100,8 +95,8 @@ testMysqlUpdate = do n <- updateCount $ \p -> do set p [ PersonAge +=. just (val 1) ] where_ (p ^. PersonName !=. val "Mike") - ret <- select $ - from $ \p -> do + ret <- select $ do + p <- from $ table @Person orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] return p -- MySQL: nulls appear first, and update returns actual number @@ -119,8 +114,8 @@ nameContains :: (SqlString s) -> [Entity Person] -> SqlPersistT IO () nameContains f t expected = do - ret <- select $ - from $ \p -> do + ret <- select $ do + p <- from $ table @Person where_ (f (p ^. PersonName) (concat_ [(%), val t, (%)])) @@ -146,21 +141,21 @@ testMysqlUnionWithLimits = do mapM_ (insert . Foo) [1..6] let q1 = do - foo <- Experimental.from $ Table @Foo + foo <- from $ table @Foo where_ $ foo ^. FooName <=. val 3 orderBy [asc $ foo ^. FooName] limit 2 pure $ foo ^. FooName let q2 = do - foo <- Experimental.from $ Table @Foo + foo <- from $ table @Foo where_ $ foo ^. FooName >. val 3 orderBy [asc $ foo ^. FooName] limit 2 pure $ foo ^. FooName - ret <- select $ Experimental.from $ q1 `union_` q2 + ret <- select $ from (q1 `union_` q2) liftIO $ ret `shouldMatchList` [Value 1, Value 2, Value 4, Value 5] spec :: Spec diff --git a/test/PostgreSQL/LegacyTest.hs b/test/PostgreSQL/LegacyTest.hs new file mode 100644 index 000000000..e3840a4a4 --- /dev/null +++ b/test/PostgreSQL/LegacyTest.hs @@ -0,0 +1,1279 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module PostgreSQL.LegacyTest where + +import Control.Arrow ((&&&)) +import Control.Concurrent (forkIO) +import Control.Monad (void, when) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT) +import Control.Monad.Trans.Reader (ReaderT, ask, mapReaderT, runReaderT) +import qualified Control.Monad.Trans.Resource as R +import Data.Aeson hiding (Value) +import qualified Data.Aeson as A (Value) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Char as Char +import Data.Coerce +import Data.Foldable +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.Ord (comparing) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import Data.Time +import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) +import qualified Database.Esqueleto.Internal.Internal as ES +import Database.Esqueleto.Legacy hiding (random_) +import Database.Esqueleto.PostgreSQL (random_, (%.)) +import qualified Database.Esqueleto.PostgreSQL as EP +import Database.Esqueleto.PostgreSQL.JSON hiding ((-.), (?.), (||.)) +import qualified Database.Esqueleto.PostgreSQL.JSON as JSON +import qualified Database.Esqueleto.PostgreSQL.WindowFunction as Window +import qualified Database.Persist.Class as P +import Database.Persist.Postgresql (createPostgresqlPool, withPostgresqlConn) +import Database.PostgreSQL.Simple (ExecStatus(..), SqlError(..)) +import System.Environment +import Test.Hspec +import Test.Hspec.Core.Spec (sequential) +import Test.Hspec.QuickCheck + +import Common.LegacyTest +import Common.Test.Import hiding (from, on) +import PostgreSQL.MigrateJSON + +returningType :: forall a m . m a -> m a +returningType a = a + +testPostgresqlCoalesce :: SpecDb +testPostgresqlCoalesce = do + itDb "works on PostgreSQL and MySQL with <2 arguments" $ do + void $ returningType @[Value (Maybe Int)] $ + select $ + from $ \p -> do + return (coalesce [p ^. PersonAge]) + asserting noExceptions + +testPostgresqlTextFunctions :: SpecDb +testPostgresqlTextFunctions = do + describe "text functions" $ do + itDb "like, (%) and (++.) work on a simple example" $ do + let nameContains t = + select $ + from $ \p -> do + where_ + (like + (p ^. PersonName) + ((%) ++. val t ++. (%))) + orderBy [asc (p ^. PersonName)] + return p + [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] + h <- nameContains "h" + i <- nameContains "i" + iv <- nameContains "iv" + asserting $ do + h `shouldBe` [p1e, p2e] + i `shouldBe` [p4e, p3e] + iv `shouldBe` [p4e] + + itDb "ilike, (%) and (++.) work on a simple example on PostgreSQL" $ do + [p1e, _, p3e, _, p5e] <- mapM insert' [p1, p2, p3, p4, p5] + let nameContains t = do + select $ + from $ \p -> do + where_ (p ^. PersonName `ilike` (%) ++. val t ++. (%)) + orderBy [asc (p ^. PersonName)] + return p + mi <- nameContains "mi" + john <- nameContains "JOHN" + asserting $ do + mi `shouldBe` [p3e, p5e] + john `shouldBe` [p1e] + +testPostgresqlUpdate :: SpecDb +testPostgresqlUpdate = do + itDb "works on a simple example" $ do + p1k <- insert p1 + p2k <- insert p2 + p3k <- insert p3 + let anon = "Anonymous" + () <- update $ \p -> do + set p [ PersonName =. val anon + , PersonAge *=. just (val 2) ] + where_ (p ^. PersonName !=. val "Mike") + n <- updateCount $ \p -> do + set p [ PersonAge +=. just (val 1) ] + where_ (p ^. PersonName !=. val "Mike") + ret <- select $ + from $ \p -> do + orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] + return p + -- PostgreSQL: nulls are bigger than data, and update returns + -- matched rows, not actually changed rows. + asserting $ do + n `shouldBe` 2 + ret `shouldBe` + [ Entity p1k (Person anon (Just 73) Nothing 1) + , Entity p2k (Person anon Nothing (Just 37) 2) + , Entity p3k p3 + ] + +testPostgresqlRandom :: SpecDb +testPostgresqlRandom = do + itDb "works with random_" $ do + _ <- select $ return (random_ :: SqlExpr (Value Double)) + asserting noExceptions + +testPostgresqlSum :: SpecDb +testPostgresqlSum = do + itDb "works with sum_" $ do + _ <- insert' p1 + _ <- insert' p2 + _ <- insert' p3 + _ <- insert' p4 + ret <- select $ + from $ \p-> + return $ joinV $ sum_ (p ^. PersonAge) + asserting $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Rational ) ] + +testPostgresqlTwoAscFields :: SpecDb +testPostgresqlTwoAscFields = do + itDb "works with two ASC fields (one call)" $ do + p1e <- insert' p1 + p2e <- insert' p2 + p3e <- insert' p3 + p4e <- insert' p4 + ret <- select $ + from $ \p -> do + orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] + return p + -- in PostgreSQL nulls are bigger than everything + asserting $ ret `shouldBe` [ p4e, p3e, p1e , p2e ] + +testPostgresqlOneAscOneDesc :: SpecDb +testPostgresqlOneAscOneDesc = do + itDb "works with one ASC and one DESC field (two calls)" $ + do + p1e <- insert' p1 + p2e <- insert' p2 + p3e <- insert' p3 + p4e <- insert' p4 + ret <- select $ + from $ \p -> do + orderBy [desc (p ^. PersonAge)] + orderBy [asc (p ^. PersonName)] + return p + asserting $ ret `shouldBe` [ p2e, p1e, p4e, p3e ] + +testSelectDistinctOn :: SpecDb +testSelectDistinctOn = do + describe "SELECT DISTINCT ON" $ do + itDb "works on a simple example" $ do + do + [p1k, p2k, _] <- mapM insert [p1, p2, p3] + [_, bpB, bpC] <- mapM insert' + [ BlogPost "A" p1k + , BlogPost "B" p1k + , BlogPost "C" p2k ] + ret <- select $ + from $ \bp -> + distinctOn [don (bp ^. BlogPostAuthorId)] $ do + orderBy [asc (bp ^. BlogPostAuthorId), desc (bp ^. BlogPostTitle)] + return bp + liftIO $ ret `shouldBe` L.sortBy (comparing (blogPostAuthorId . entityVal)) [bpB, bpC] + + let slightlyLessSimpleTest q = + do + [p1k, p2k, _] <- mapM insert [p1, p2, p3] + [bpA, bpB, bpC] <- mapM insert' + [ BlogPost "A" p1k + , BlogPost "B" p1k + , BlogPost "C" p2k ] + ret <- select $ + from $ \bp -> + q bp $ return bp + let cmp = (blogPostAuthorId &&& blogPostTitle) . entityVal + liftIO $ ret `shouldBe` L.sortBy (comparing cmp) [bpA, bpB, bpC] + + itDb "works on a slightly less simple example (two distinctOn calls, orderBy)" $ + slightlyLessSimpleTest $ \bp act -> + distinctOn [don (bp ^. BlogPostAuthorId)] $ + distinctOn [don (bp ^. BlogPostTitle)] $ do + orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)] + act + + itDb "works on a slightly less simple example (one distinctOn call, orderBy)" $ do + slightlyLessSimpleTest $ \bp act -> + distinctOn [don (bp ^. BlogPostAuthorId), don (bp ^. BlogPostTitle)] $ do + orderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)] + act + + itDb "works on a slightly less simple example (distinctOnOrderBy)" $ do + slightlyLessSimpleTest $ \bp -> + distinctOnOrderBy [asc (bp ^. BlogPostAuthorId), asc (bp ^. BlogPostTitle)] + + itDb "generates correct sql with nested expression (distinctOnOrderBy)" $ do + let query = do + let orderVal = coalesce [nothing, just $ val (10 :: Int)] + distinctOnOrderBy [ asc orderVal, desc orderVal ] $ pure orderVal + select query + asserting noExceptions + + + + +testArrayAggWith :: SpecDb +testArrayAggWith = do + describe "ALL, no ORDER BY" $ do + itDb "creates sane SQL" $ do + (query, args) <- showQuery ES.SELECT $ from $ \p -> + return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge) []) + liftIO $ query `shouldBe` + "SELECT array_agg(\"Person\".\"age\")\n\ + \FROM \"Person\"\n" + liftIO $ args `shouldBe` [] + + itDb "works on an example" $ do + let people = [p1, p2, p3, p4, p5] + mapM_ insert people + [Value (Just ret)] <- + select $ from $ \p -> + return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) []) + liftIO $ L.sort ret `shouldBe` L.sort (map personName people) + + describe "DISTINCT, no ORDER BY" $ do + itDb "creates sane SQL" $ do + (query, args) <- showQuery ES.SELECT $ from $ \p -> + return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) []) + liftIO $ query `shouldBe` + "SELECT array_agg(DISTINCT \"Person\".\"age\")\n\ + \FROM \"Person\"\n" + liftIO $ args `shouldBe` [] + + itDb "works on an example" $ do + let people = [p1, p2, p3, p4, p5] + mapM_ insert people + [Value (Just ret)] <- + select $ from $ \p -> + return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) []) + liftIO $ L.sort ret `shouldBe` [Nothing, Just 17, Just 36] + + describe "ALL, ORDER BY" $ do + itDb "creates sane SQL" $ do + (query, args) <- showQuery ES.SELECT $ from $ \p -> + return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge) + [ asc $ p ^. PersonName + , desc $ p ^. PersonFavNum + ]) + liftIO $ query `shouldBe` + "SELECT array_agg(\"Person\".\"age\" \ + \ORDER BY \"Person\".\"name\" ASC, \"Person\".\"favNum\" DESC)\n\ + \FROM \"Person\"\n" + liftIO $ args `shouldBe` [] + + itDb "works on an example" $ do + let people = [p1, p2, p3, p4, p5] + mapM_ insert people + [Value (Just ret)] <- + select $ from $ \p -> + return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) []) + liftIO $ L.sort ret `shouldBe` L.sort (map personName people) + + describe "DISTINCT, ORDER BY" $ do + itDb "creates sane SQL" $ do + (query, args) <- showQuery ES.SELECT $ from $ \p -> + return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) + [asc $ p ^. PersonAge]) + liftIO $ query `shouldBe` + "SELECT array_agg(DISTINCT \"Person\".\"age\" \ + \ORDER BY \"Person\".\"age\" ASC)\n\ + \FROM \"Person\"\n" + liftIO $ args `shouldBe` [] + + itDb "works on an example" $ do + let people = [p1, p2, p3, p4, p5] + mapM_ insert people + [Value (Just ret)] <- + select $ from $ \p -> + return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) + [asc $ p ^. PersonAge]) + liftIO $ ret `shouldBe` [Just 17, Just 36, Nothing] + + + + + +testStringAggWith :: SpecDb +testStringAggWith = do + describe "ALL, no ORDER BY" $ do + itDb "creates sane SQL" $ do + (query, args) <- showQuery ES.SELECT $ from $ \p -> + return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) + (val " ") []) + liftIO $ query `shouldBe` + "SELECT string_agg(\"Person\".\"name\", ?)\n\ + \FROM \"Person\"\n" + liftIO $ args `shouldBe` [PersistText " "] + + itDb "works on an example" $ do + let people = [p1, p2, p3, p4, p5] + mapM_ insert people + [Value (Just ret)] <- + select $ from $ \p -> + return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[]) + liftIO $ (L.sort $ words ret) `shouldBe` L.sort (map personName people) + + itDb "works with zero rows" $ do + [Value ret] <- + select $ from $ \p -> + return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[]) + liftIO $ ret `shouldBe` Nothing + + describe "DISTINCT, no ORDER BY" $ do + itDb "creates sane SQL" $ do + (query, args) <- showQuery ES.SELECT $ from $ \p -> + return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) + (val " ") [] + liftIO $ query `shouldBe` + "SELECT string_agg(DISTINCT \"Person\".\"name\", ?)\n\ + \FROM \"Person\"\n" + liftIO $ args `shouldBe` [PersistText " "] + + itDb "works on an example" $ do + let people = [p1, p2, p3 {personName = "John"}, p4, p5] + mapM_ insert people + [Value (Just ret)] <- + select $ from $ \p -> + return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") + [] + liftIO $ (L.sort $ words ret) `shouldBe` + (L.sort . L.nub $ map personName people) + + describe "ALL, ORDER BY" $ do + itDb "creates sane SQL" $ do + (query, args) <- showQuery ES.SELECT $ from $ \p -> + return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ") + [ asc $ p ^. PersonName + , desc $ p ^. PersonFavNum + ]) + liftIO $ query `shouldBe` + "SELECT string_agg(\"Person\".\"name\", ? \ + \ORDER BY \"Person\".\"name\" ASC, \"Person\".\"favNum\" DESC)\n\ + \FROM \"Person\"\n" + liftIO $ args `shouldBe` [PersistText " "] + + itDb "works on an example" $ do + let people = [p1, p2, p3, p4, p5] + mapM_ insert people + [Value (Just ret)] <- + select $ from $ \p -> + return $ EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ") + [desc $ p ^. PersonName] + liftIO $ (words ret) + `shouldBe` (L.reverse . L.sort $ map personName people) + + describe "DISTINCT, ORDER BY" $ do + itDb "creates sane SQL" $ do + (query, args) <- showQuery ES.SELECT $ from $ \p -> + return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) + (val " ") [desc $ p ^. PersonName] + liftIO $ query `shouldBe` + "SELECT string_agg(DISTINCT \"Person\".\"name\", ? \ + \ORDER BY \"Person\".\"name\" DESC)\n\ + \FROM \"Person\"\n" + liftIO $ args `shouldBe` [PersistText " "] + + itDb "works on an example" $ do + let people = [p1, p2, p3 {personName = "John"}, p4, p5] + mapM_ insert people + [Value (Just ret)] <- + select $ from $ \p -> + return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") + [desc $ p ^. PersonName] + liftIO $ (words ret) `shouldBe` + (L.reverse . L.sort . L.nub $ map personName people) + + + + + +testAggregateFunctions :: SpecDb +testAggregateFunctions = do + describe "arrayAgg" $ do + itDb "looks sane" $ do + let people = [p1, p2, p3, p4, p5] + mapM_ insert people + [Value (Just ret)] <- + select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName)) + liftIO $ L.sort ret `shouldBe` L.sort (map personName people) + + itDb "works on zero rows" $ do + [Value ret] <- + select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName)) + liftIO $ ret `shouldBe` Nothing + describe "arrayAggWith" testArrayAggWith + describe "stringAgg" $ do + itDb "looks sane" $ + do + let people = [p1, p2, p3, p4, p5] + mapM_ insert people + [Value (Just ret)] <- + select $ + from $ \p -> do + return (EP.stringAgg (p ^. PersonName) (val " ")) + liftIO $ L.sort (words ret) `shouldBe` L.sort (map personName people) + itDb "works on zero rows" $ do + [Value ret] <- + select $ from $ \p -> return (EP.stringAgg (p ^. PersonName) (val " ")) + liftIO $ ret `shouldBe` Nothing + describe "stringAggWith" testStringAggWith + + describe "array_remove (NULL)" $ do + itDb "removes NULL from arrays from nullable fields" $ do + mapM_ insert [ Person "1" Nothing Nothing 1 + , Person "2" (Just 7) Nothing 1 + , Person "3" (Nothing) Nothing 1 + , Person "4" (Just 8) Nothing 2 + , Person "5" (Just 9) Nothing 2 + ] + ret <- select $ from $ \(person :: SqlExpr (Entity Person)) -> do + groupBy (person ^. PersonFavNum) + return . EP.arrayRemoveNull . EP.maybeArray . EP.arrayAgg + $ person ^. PersonAge + liftIO $ (L.sort $ map (L.sort . unValue) ret) + `shouldBe` [[7], [8,9]] + + describe "maybeArray" $ do + itDb "Coalesces NULL into an empty array" $ do + [Value ret] <- + select $ from $ \p -> + return (EP.maybeArray $ EP.arrayAgg (p ^. PersonName)) + liftIO $ ret `shouldBe` [] + +testPostgresModule :: SpecDb +testPostgresModule = do + describe "date_trunc" $ modifyMaxSuccess (`div` 10) $ do + propDb "works" $ \run listOfDateParts -> run $ do + let + utcTimes = + map + (\(y, m, d, s) -> + fromInteger s + `addUTCTime` + UTCTime (fromGregorian (2000 + y) m d) 0 + ) + listOfDateParts + truncateDate + :: SqlExpr (Value String) -- ^ .e.g (val "day") + -> SqlExpr (Value UTCTime) -- ^ input field + -> SqlExpr (Value UTCTime) -- ^ truncated date + truncateDate datePart expr = + ES.unsafeSqlFunction "date_trunc" (datePart, expr) + vals = + zip (map (DateTruncTestKey . fromInteger) [1..]) utcTimes + for_ vals $ \(idx, utcTime) -> do + insertKey idx (DateTruncTest utcTime) + + -- Necessary to get the test to pass; see the discussion in + -- https://github.com/bitemyapp/esqueleto/pull/180 + rawExecute "SET TIME ZONE 'UTC'" [] + ret <- + fmap (Map.fromList . coerce :: _ -> Map DateTruncTestId (UTCTime, UTCTime)) $ + select $ + from $ \dt -> do + pure + ( dt ^. DateTruncTestId + , ( dt ^. DateTruncTestCreated + , truncateDate (val "day") (dt ^. DateTruncTestCreated) + ) + ) + + asserting $ for_ vals $ \(idx, utcTime) -> do + case Map.lookup idx ret of + Nothing -> + expectationFailure "index not found" + Just (original, truncated) -> do + utcTime `shouldBe` original + if utctDay utcTime == utctDay truncated + then + utctDay utcTime `shouldBe` utctDay truncated + else + -- use this if/else to get a better error message + utcTime `shouldBe` truncated + + describe "PostgreSQL module" $ do + describe "Aggregate functions" testAggregateFunctions + itDb "chr looks sane" $ do + [Value (ret :: String)] <- select $ return (EP.chr (val 65)) + liftIO $ ret `shouldBe` "A" + + itDb "allows unit for functions" $ do + let + fn :: SqlExpr (Value UTCTime) + fn = ES.unsafeSqlFunction "now" () + vals <- select $ pure fn + liftIO $ vals `shouldSatisfy` ((1 ==) . length) + + itDb "works with now" $ + do + nowDb <- select $ return EP.now_ + nowUtc <- liftIO getCurrentTime + let oneSecond = realToFrac (1 :: Double) + + -- | Check the result is not null + liftIO $ nowDb `shouldSatisfy` (not . null) + + -- | Unpack the now value + let (Value now: _) = nowDb + + -- | Get the time diff and check it's less than a second + liftIO $ diffUTCTime nowUtc now `shouldSatisfy` (< oneSecond) + +testJSONInsertions :: SpecDb +testJSONInsertions = + describe "JSON Insertions" $ do + itDb "adds scalar values" $ do + insertIt Null + insertIt $ Bool True + insertIt $ Number 1 + insertIt $ String "test" + itDb "adds arrays" $ do + insertIt $ toJSON ([] :: [A.Value]) + insertIt $ toJSON [Number 1, Bool True, Null] + insertIt $ toJSON [String "test",object ["a" .= Number 3.14], Null, Bool True] + itDb "adds objects" $ do + insertIt $ object ["a" .= (1 :: Int), "b" .= False] + insertIt $ object ["a" .= object ["b" .= object ["c" .= String "message"]]] + where + insertIt :: MonadIO m => A.Value -> SqlPersistT m () + insertIt = insert_ . Json . JSONB + +testJSONOperators :: SpecDb +testJSONOperators = + describe "JSON Operators" $ do + testArrowOperators + testFilterOperators + testConcatDeleteOperators + +testArrowOperators :: SpecDb +testArrowOperators = + describe "Arrow Operators" $ do + testArrowJSONB + testArrowText + testHashArrowJSONB + testHashArrowText + +testArrowJSONB :: SpecDb +testArrowJSONB = + describe "Single Arrow (JSONB)" $ do + itDb "creates sane SQL" $ + createSaneSQL @JSONValue + (jsonbVal (object ["a" .= True]) ->. "a") + "SELECT (? -> ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped "{\"a\":true}" + , PersistText "a" + ] + itDb "creates sane SQL (chained)" $ do + let obj = object ["a" .= [1 :: Int,2,3]] + createSaneSQL @JSONValue + (jsonbVal obj ->. "a" ->. 1) + "SELECT ((? -> ?) -> ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped "{\"a\":[1,2,3]}" + , PersistText "a" + , PersistInt64 1 ] + itDb "works as expected" $ do + x <- selectJSONwhere $ \v -> v ->. "b" ==. jsonbVal (Bool False) + y <- selectJSONwhere $ \v -> v ->. 1 ==. jsonbVal (Bool True) + z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->. "c" ==. jsonbVal (String "message") + asserting $ do + length x `shouldBe` 1 + length y `shouldBe` 1 + length z `shouldBe` 1 + +testArrowText :: SpecDb +testArrowText = + describe "Single Arrow (Text)" $ do + itDb "creates sane SQL" $ + createSaneSQL + (jsonbVal (object ["a" .= True]) ->>. "a") + "SELECT (? ->> ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped "{\"a\":true}" + , PersistText "a" ] + itDb "creates sane SQL (chained)" $ do + let obj = object ["a" .= [1 :: Int,2,3]] + createSaneSQL + (jsonbVal obj ->. "a" ->>. 1) + "SELECT ((? -> ?) ->> ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped "{\"a\":[1,2,3]}" + , PersistText "a" + , PersistInt64 1 ] + itDb "works as expected" $ do + x <- selectJSONwhere $ \v -> v ->>. "b" ==. just (val "false") + y <- selectJSONwhere $ \v -> v ->>. 1 ==. just (val "true") + z <- selectJSONwhere $ \v -> v ->. "a" ->. "b" ->>. "c" ==. just (val "message") + liftIO $ length x `shouldBe` 1 + liftIO $ length y `shouldBe` 1 + liftIO $ length z `shouldBe` 1 + +testHashArrowJSONB :: SpecDb +testHashArrowJSONB = + describe "Double Arrow (JSONB)" $ do + itDb "creates sane SQL" $ do + let list = ["a","b","c"] + createSaneSQL @JSONValue + (jsonbVal (object ["a" .= True]) #>. list) + "SELECT (? #> ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped "{\"a\":true}" + , persistTextArray list ] + itDb "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + createSaneSQL @JSONValue + (jsonbVal obj #>. ["a","1"] #>. ["b"]) + "SELECT ((? #> ?) #> ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}" + , persistTextArray ["a","1"] + , persistTextArray ["b"] ] + itDb "works as expected" $ do + x <- selectJSONwhere $ \v -> v #>. ["a","b","c"] ==. jsonbVal (String "message") + y <- selectJSONwhere $ \v -> v #>. ["1","a"] ==. jsonbVal (Number 3.14) + z <- selectJSONwhere $ \v -> v #>. ["1"] #>. ["a"] ==. jsonbVal (Number 3.14) + liftIO $ length x `shouldBe` 1 + liftIO $ length y `shouldBe` 1 + liftIO $ length z `shouldBe` 1 + +testHashArrowText :: SpecDb +testHashArrowText = + describe "Double Arrow (Text)" $ do + itDb "creates sane SQL" $ do + let list = ["a","b","c"] + createSaneSQL + (jsonbVal (object ["a" .= True]) #>>. list) + "SELECT (? #>> ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped "{\"a\":true}" + , persistTextArray list ] + itDb "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + createSaneSQL + (jsonbVal obj #>. ["a","1"] #>>. ["b"]) + "SELECT ((? #> ?) #>> ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}" + , persistTextArray ["a","1"] + , persistTextArray ["b"] ] + itDb "works as expected" $ do + x <- selectJSONwhere $ \v -> v #>>. ["a","b","c"] ==. just (val "message") + y <- selectJSONwhere $ \v -> v #>>. ["1","a"] ==. just (val "3.14") + z <- selectJSONwhere $ \v -> v #>. ["1"] #>>. ["a"] ==. just (val "3.14") + liftIO $ length x `shouldBe` 1 + liftIO $ length y `shouldBe` 1 + liftIO $ length z `shouldBe` 1 + + +testFilterOperators :: SpecDb +testFilterOperators = + describe "Filter Operators" $ do + testInclusion + testQMark + testQMarkAny + testQMarkAll + +testInclusion :: SpecDb +testInclusion = do + describe "@>" $ do + itDb "creates sane SQL" $ do + let obj = object ["a" .= False, "b" .= True] + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal obj @>. jsonbVal (object ["a" .= False])) + "SELECT (? @> ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , PersistLiteralEscaped "{\"a\":false}" + ] + itDb "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal obj ->. "a" @>. jsonbVal (object ["b" .= True])) + "SELECT ((? -> ?) @> ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , PersistText "a" + , PersistLiteralEscaped "{\"b\":true}" + ] + itDb "works as expected" $ do + x <- selectJSONwhere $ \v -> v @>. jsonbVal (Number 1) + y <- selectJSONwhere $ \v -> v @>. jsonbVal (toJSON [object ["a" .= Number 3.14]]) + z <- selectJSONwhere $ \v -> v ->. 1 @>. jsonbVal (object ["a" .= Number 3.14]) + liftIO $ length x `shouldBe` 2 + liftIO $ length y `shouldBe` 1 + liftIO $ length z `shouldBe` 1 + describe "<@" $ do + itDb "creates sane SQL" $ do + let obj = object ["a" .= False, "b" .= True] + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal (object ["a" .= False]) <@. jsonbVal obj ) + "SELECT (? <@ ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped "{\"a\":false}" + , PersistLiteralEscaped encoded + ] + itDb "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + obj' = object ["b" .= True, "c" .= Null] + encoded = BSL.toStrict $ encode obj' + createSaneSQL + (jsonbVal obj ->. "a" <@. jsonbVal obj') + "SELECT ((? -> ?) <@ ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}" + , PersistText "a" + , PersistLiteralEscaped encoded + ] + itDb "works as expected" $ do + x <- selectJSONwhere $ \v -> v <@. jsonbVal (toJSON [Number 1]) + y <- selectJSONwhere $ \v -> v <@. jsonbVal (object ["a" .= (1 :: Int), "b" .= False, "c" .= Null]) + z <- selectJSONwhere $ \v -> v #>. ["a","b"] <@. jsonbVal (object ["b" .= False, "c" .= String "message"]) + liftIO $ length x `shouldBe` 2 + liftIO $ length y `shouldBe` 1 + liftIO $ length z `shouldBe` 1 + +testQMark :: SpecDb +testQMark = do + describe "Question Mark" $ do + itDb "creates sane SQL" $ do + let obj = object ["a" .= False, "b" .= True] + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal obj JSON.?. "a") + "SELECT (? ?? ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , PersistText "a" + ] + itDb "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal obj #>. ["a","0"] JSON.?. "b") + "SELECT ((? #> ?) ?? ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , persistTextArray ["a","0"] + , PersistText "b" + ] + itDb "works as expected" $ do + x <- selectJSONwhere (JSON.?. "a") + y <- selectJSONwhere (JSON.?. "test") + z <- selectJSONwhere $ \v -> v ->. "a" JSON.?. "b" + liftIO $ length x `shouldBe` 2 + liftIO $ length y `shouldBe` 2 + liftIO $ length z `shouldBe` 1 + +testQMarkAny :: SpecDb +testQMarkAny = do + describe "Question Mark (Any)" $ do + itDb "creates sane SQL" $ do + let obj = (object ["a" .= False, "b" .= True]) + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal obj ?|. ["a","c"]) + "SELECT (? ??| ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , persistTextArray ["a","c"] + ] + itDb "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal obj #>. ["a","0"] ?|. ["b","c"]) + "SELECT ((? #> ?) ??| ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , persistTextArray ["a","0"] + , persistTextArray ["b","c"] + ] + itDb "works as expected" $ do + x <- selectJSONwhere (?|. ["b","test"]) + y <- selectJSONwhere (?|. ["a"]) + z <- selectJSONwhere $ \v -> v ->. (-3) ?|. ["a"] + w <- selectJSONwhere (?|. []) + liftIO $ length x `shouldBe` 3 + liftIO $ length y `shouldBe` 2 + liftIO $ length z `shouldBe` 1 + liftIO $ length w `shouldBe` 0 + +testQMarkAll :: SpecDb +testQMarkAll = do + describe "Question Mark (All)" $ do + itDb "creates sane SQL" $ do + let obj = object ["a" .= False, "b" .= True] + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal obj ?&. ["a","c"]) + "SELECT (? ??& ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , persistTextArray ["a","c"] + ] + itDb "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal obj #>. ["a","0"] ?&. ["b","c"]) + "SELECT ((? #> ?) ??& ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , persistTextArray ["a","0"] + , persistTextArray ["b","c"] + ] + itDb "works as expected" $ do + x <- selectJSONwhere (?&. ["test"]) + y <- selectJSONwhere (?&. ["a","b"]) + z <- selectJSONwhere $ \v -> v ->. "a" ?&. ["b"] + w <- selectJSONwhere (?&. []) + liftIO $ length x `shouldBe` 2 + liftIO $ length y `shouldBe` 1 + liftIO $ length z `shouldBe` 1 + liftIO $ length w `shouldBe` 9 + +testConcatDeleteOperators :: SpecDb +testConcatDeleteOperators = do + describe "Concatenation Operator" testConcatenationOperator + describe "Deletion Operators" $ do + testMinusOperator + testMinusOperatorV10 + testHashMinusOperator + +testConcatenationOperator :: SpecDb +testConcatenationOperator = do + describe "Concatenation" $ do + itDb "creates sane SQL" $ do + let objAB = object ["a" .= False, "b" .= True] + objC = object ["c" .= Null] + createSaneSQL @JSONValue + (jsonbVal objAB + JSON.||. jsonbVal objC) + "SELECT (? || ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped $ BSL.toStrict $ encode objAB + , PersistLiteralEscaped $ BSL.toStrict $ encode objC + ] + itDb "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + encoded = BSL.toStrict $ encode obj + createSaneSQL @JSONValue + (jsonbVal obj ->. "a" JSON.||. jsonbVal (toJSON [Null])) + "SELECT ((? -> ?) || ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , PersistText "a" + , PersistLiteralEscaped "[null]" + ] + itDb "works as expected" $ do + x <- selectJSON $ \v -> do + where_ $ v @>. jsonbVal (object []) + where_ $ v JSON.||. jsonbVal (object ["x" .= True]) + @>. jsonbVal (object ["x" .= True]) + y <- selectJSONwhere $ \v -> + v JSON.||. jsonbVal (toJSON [String "a", String "b"]) + ->>. 4 ==. just (val "b") + z <- selectJSONwhere $ \v -> + v JSON.||. jsonbVal (toJSON [Bool False]) + ->. 0 JSON.@>. jsonbVal (Number 1) + w <- selectJSON $ \v -> do + where_ . not_ $ v @>. jsonbVal (object []) + where_ $ jsonbVal (String "test1") JSON.||. v ->>. 0 ==. just (val "test1") + liftIO $ length x `shouldBe` 2 + liftIO $ length y `shouldBe` 1 + liftIO $ length z `shouldBe` 2 + liftIO $ length w `shouldBe` 7 + +testMinusOperator :: SpecDb +testMinusOperator = + describe "Minus Operator" $ do + itDb "creates sane SQL" $ do + let obj = object ["a" .= False, "b" .= True] + encoded = BSL.toStrict $ encode obj + createSaneSQL @JSONValue + (jsonbVal obj JSON.-. "a") + "SELECT (? - ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , PersistText "a" + ] + itDb "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + encoded = BSL.toStrict $ encode obj + createSaneSQL @JSONValue + (jsonbVal obj ->. "a" JSON.-. 0) + "SELECT ((? -> ?) - ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , PersistText "a" + , PersistInt64 0 + ] + itDb "works as expected" $ do + x <- selectJSON $ \v -> do + where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) + where_ $ v JSON.-. 0 @>. jsonbVal (toJSON [Bool True]) + y <- selectJSON $ \v -> do + where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) + where_ $ v JSON.-. (-1) @>. jsonbVal (toJSON [Null]) + z <- selectJSON_ $ \v -> v JSON.-. "b" ?&. ["a", "b"] + w <- selectJSON_ $ \v -> do + v JSON.-. "test" @>. jsonbVal (toJSON [String "test"]) + liftIO $ length x `shouldBe` 2 + liftIO $ length y `shouldBe` 1 + liftIO $ length z `shouldBe` 0 + liftIO $ length w `shouldBe` 0 + sqlFailWith "22023" $ selectJSONwhere $ \v -> + v JSON.-. 0 @>. jsonbVal (toJSON ([] :: [Int])) + where + selectJSON_ f = selectJSON $ \v -> do + where_ + $ v @>. jsonbVal (object []) + ||. v @>. jsonbVal (toJSON ([] :: [Int])) + where_ $ f v + +testMinusOperatorV10 :: SpecDb +testMinusOperatorV10 = do + describe "Minus Operator (PSQL >= v10)" $ do + itDb "creates sane SQL" $ do + let obj = object ["a" .= False, "b" .= True] + encoded = BSL.toStrict $ encode obj + createSaneSQL @JSONValue + (jsonbVal obj --. ["a","b"]) + "SELECT (? - ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , persistTextArray ["a","b"] + ] + itDb "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + encoded = BSL.toStrict $ encode obj + createSaneSQL @JSONValue + (jsonbVal obj #>. ["a","0"] --. ["b"]) + "SELECT ((? #> ?) - ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , persistTextArray ["a","0"] + , persistTextArray ["b"] + ] + itDb "works as expected" $ do + x <- selectJSON $ \v -> do + where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) + where_ $ v --. ["test","a"] @>. jsonbVal (toJSON [String "test"]) + y <- selectJSON $ \v -> do + where_ $ v @>. jsonbVal (object []) + where_ $ v --. ["a","b"] <@. jsonbVal (object []) + z <- selectJSON_ $ \v -> v --. ["b"] <@. jsonbVal (object ["a" .= (1 :: Int)]) + w <- selectJSON_ $ \v -> do + v --. ["test"] @>. jsonbVal (toJSON [String "test"]) + liftIO $ length x `shouldBe` 0 + liftIO $ length y `shouldBe` 2 + liftIO $ length z `shouldBe` 1 + liftIO $ length w `shouldBe` 0 + sqlFailWith "22023" $ selectJSONwhere $ \v -> + v --. ["a"] @>. jsonbVal (toJSON ([] :: [Int])) + where + selectJSON_ f = selectJSON $ \v -> do + where_ $ v @>. jsonbVal (object []) + ||. v @>. jsonbVal (toJSON ([] :: [Int])) + where_ $ f v + +testHashMinusOperator :: SpecDb +testHashMinusOperator = + describe "Hash-Minus Operator" $ do + itDb "creates sane SQL" $ + createSaneSQL @JSONValue + (jsonbVal (object ["a" .= False, "b" .= True]) #-. ["a"]) + "SELECT (? #- ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped (BSL.toStrict $ encode $ object ["a" .= False, "b" .= True]) + , persistTextArray ["a"] ] + itDb "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + createSaneSQL @JSONValue + (jsonbVal obj ->. "a" #-. ["0","b"]) + "SELECT ((? -> ?) #- ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped (BSL.toStrict $ encode obj) + , PersistText "a" + , persistTextArray ["0","b"] ] + itDb "works as expected" $ do + x <- selectJSON $ \v -> do + where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) + where_ $ v #-. ["1","a"] @>. jsonbVal (toJSON [object []]) + y <- selectJSON $ \v -> do + where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) + where_ $ v #-. ["-3","a"] @>. jsonbVal (toJSON [object []]) + z <- selectJSON_ $ \v -> v #-. ["a","b","c"] + @>. jsonbVal (object ["a" .= object ["b" .= object ["c" .= String "message"]]]) + w <- selectJSON_ $ \v -> v #-. ["a","b"] JSON.?. "b" + liftIO $ length x `shouldBe` 1 + liftIO $ length y `shouldBe` 1 + liftIO $ length z `shouldBe` 0 + liftIO $ length w `shouldBe` 1 + sqlFailWith "22023" $ selectJSONwhere $ \v -> + v #-. ["0"] @>. jsonbVal (toJSON ([] :: [Int])) + where selectJSON_ f = selectJSON $ \v -> do + where_ $ v @>. jsonbVal (object []) + where_ $ f v + +testInsertUniqueViolation :: SpecDb +testInsertUniqueViolation = + describe "Unique Violation on Insert" $ + itDb "Unique throws exception" $ do + eres <- + try $ do + _ <- insert u1 + _ <- insert u2 + insert u3 + liftIO $ case eres of + Left err | err == exception -> + pure () + _ -> + expectationFailure $ "Expected a SQL exception, got: " <> + show eres + + where + exception = SqlError { + sqlState = "23505", + sqlExecStatus = FatalError, + sqlErrorMsg = "duplicate key value violates unique constraint \"UniqueValue\"", + sqlErrorDetail = "Key (value)=(0) already exists.", + sqlErrorHint = ""} + +testUpsert :: SpecDb +testUpsert = + describe "Upsert test" $ do + itDb "Upsert can insert like normal" $ do + u1e <- EP.upsert u1 [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"} + + +testFilterWhere :: SpecDb +testFilterWhere = + describe "filterWhere" $ do + itDb "adds a filter clause to count aggregation" $ do + -- Person "John" (Just 36) Nothing 1 + _ <- insert p1 + -- Person "Rachel" Nothing (Just 37) 2 + _ <- insert p2 + -- Person "Mike" (Just 17) Nothing 3 + _ <- insert p3 + -- Person "Livia" (Just 17) (Just 18) 4 + _ <- insert p4 + -- Person "Mitch" Nothing Nothing 5 + _ <- insert p5 + + usersByAge <- do + select $ from $ \users -> do + groupBy $ users ^. PersonAge + return + ( users ^. PersonAge + -- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = 2 + -- Just 36: [John { favNum = 1 } (excluded)] = 0 + -- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = 2 + , count (users ^. PersonId) `EP.filterWhere` (users ^. PersonFavNum >=. val 2) + -- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = 0 + -- Just 36: [John { favNum = 1 }] = 1 + -- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = 0 + , count (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2) + ) + + asserting $ usersByAge `shouldMatchList` + ( + [ (Value Nothing, Value 2, Value 0) + , (Value (Just 36), Value 0, Value 1) + , (Value (Just 17), Value 2, Value 0) + ] :: [(Value (Maybe Int), Value Int, Value Int)] + ) + + + itDb "adds a filter clause to sum aggregation" $ do + -- Person "John" (Just 36) Nothing 1 + _ <- insert p1 + -- Person "Rachel" Nothing (Just 37) 2 + _ <- insert p2 + -- Person "Mike" (Just 17) Nothing 3 + _ <- insert p3 + -- Person "Livia" (Just 17) (Just 18) 4 + _ <- insert p4 + -- Person "Mitch" Nothing Nothing 5 + _ <- insert p5 + + usersByAge <- fmap (\(Value a, Value b, Value c) -> (a, b, c)) <$> do + select $ from $ \users -> do + groupBy $ users ^. PersonAge + return + ( users ^. PersonAge + -- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = Just 7 + -- Just 36: [John { favNum = 1 } (excluded)] = Nothing + -- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = Just 7 + , sum_ (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum >=. val 2) + -- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = Nothing + -- Just 36: [John { favNum = 1 }] = Just 1 + -- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = Nothing + , sum_ (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2) + ) + + liftIO $ usersByAge `shouldMatchList` + ( [ (Nothing, Just 7, Nothing) + , (Just 36, Nothing, Just 1) + , (Just 17, Just 7, Nothing) + ] :: [(Maybe Int, Maybe Rational, Maybe Rational)] + ) + +type JSONValue = Maybe (JSONB A.Value) + +createSaneSQL :: (PersistField a, MonadIO m) => SqlExpr (Value a) -> T.Text -> [PersistValue] -> SqlPersistT m () +createSaneSQL act q vals = do + (query, args) <- showQuery ES.SELECT $ fromValue act + liftIO $ do + query `shouldBe` q + args `shouldBe` vals + +fromValue :: (PersistField a) => SqlExpr (Value a) -> SqlQuery (SqlExpr (Value a)) +fromValue act = from $ \x -> do + let _ = x :: SqlExpr (Entity Json) + return act + +persistTextArray :: [T.Text] -> PersistValue +persistTextArray = PersistArray . fmap PersistText + +sqlFailWith + :: (HasCallStack, MonadUnliftIO m, Show a) + => ByteString + -> SqlPersistT m a + -> SqlPersistT m () +sqlFailWith errState f = do + eres <- try f + case eres of + Left err -> + success err + Right a -> + liftIO $ expectationFailure $ mconcat + [ "should fail with error code: " + , T.unpack errStateT + , ", but got: " + , show a + ] + where + success SqlError{sqlState} + | sqlState == errState = + pure () + | otherwise = do + liftIO $ expectationFailure $ T.unpack $ T.concat + [ "should fail with: ", errStateT + , ", but received: ", TE.decodeUtf8 sqlState + ] + errStateT = + TE.decodeUtf8 errState + +selectJSONwhere + :: MonadIO m + => (JSONBExpr A.Value -> SqlExpr (Value Bool)) + -> SqlPersistT m [Entity Json] +selectJSONwhere f = selectJSON $ where_ . f + +selectJSON + :: MonadIO m + => (JSONBExpr A.Value -> SqlQuery ()) + -> SqlPersistT m [Entity Json] +selectJSON f = select $ from $ \v -> do + f $ just (v ^. JsonValue) + return v + +--------------- 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 + testFilterWhere + setDatabaseState insertJsonValues cleanJSON + $ describe "PostgreSQL JSON tests" $ do + testJSONInsertions + testJSONOperators + +insertJsonValues :: SqlPersistT IO () +insertJsonValues = do + insertIt Null + insertIt $ Bool True + insertIt $ Number 1 + insertIt $ String "test" + insertIt $ toJSON ([] :: [A.Value]) + insertIt $ toJSON [Number 1, Bool True, Null] + insertIt $ toJSON [String "test",object ["a" .= Number 3.14], Null, Bool True] + insertIt $ object ["a" .= (1 :: Int), "b" .= False] + insertIt $ object ["a" .= object ["b" .= object ["c" .= String "message"]]] + where + insertIt :: MonadIO m => A.Value -> SqlPersistT m () + insertIt = insert_ . Json . JSONB + +verbose :: Bool +verbose = False + +migrateIt :: _ => SqlPersistT m () +migrateIt = mapReaderT runNoLoggingT $ do + void $ runMigrationSilent $ do + migrateAll + migrateUnique + migrateJSON + cleanDB + cleanUniques + +mkConnectionPool :: IO ConnectionPool +mkConnectionPool = do + verbose' <- lookupEnv "VERBOSE" >>= \case + Nothing -> + return verbose + Just x + | map Char.toLower x == "true" -> return True + | null x -> return True + | otherwise -> return False + pool <- if verbose' + then + runStderrLoggingT $ + createPostgresqlPool + "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest" + 4 + else + runNoLoggingT $ + createPostgresqlPool + "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest" + 4 + flip runSqlPool pool $ do + migrateIt + pure pool + +-- | Show the SQL generated by a query +showQuery :: (Monad m, ES.SqlSelect a r, BackendCompatible SqlBackend backend) + => ES.Mode -> SqlQuery a -> ReaderT backend m (T.Text, [PersistValue]) +showQuery mode query = do + backend <- ask + let (builder, values) = ES.toRawSql mode (backend, ES.initialIdentState) query + return (ES.builderToText builder, values) diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 3ff87a1da..5e3d18a73 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -37,13 +37,12 @@ import qualified Data.Text.Lazy.Builder as TLB import Data.Time import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) import Database.Esqueleto hiding (random_) -import Database.Esqueleto.Experimental hiding (from, on, random_) -import qualified Database.Esqueleto.Experimental as Experimental import qualified Database.Esqueleto.Internal.Internal as ES -import Database.Esqueleto.PostgreSQL (random_) +import Database.Esqueleto.PostgreSQL (random_, (%.)) import qualified Database.Esqueleto.PostgreSQL as EP import Database.Esqueleto.PostgreSQL.JSON hiding ((-.), (?.), (||.)) import qualified Database.Esqueleto.PostgreSQL.JSON as JSON +import qualified Database.Esqueleto.PostgreSQL.WindowFunction as Window import qualified Database.Persist.Class as P import Database.Persist.Postgresql (createPostgresqlPool, withPostgresqlConn) import Database.PostgreSQL.Simple (ExecStatus(..), SqlError(..)) @@ -62,9 +61,8 @@ returningType a = a testPostgresqlCoalesce :: SpecDb testPostgresqlCoalesce = do itDb "works on PostgreSQL and MySQL with <2 arguments" $ do - void $ returningType @[Value (Maybe Int)] $ - select $ - from $ \p -> do + void $ select $ do + p <- from $ table @Person return (coalesce [p ^. PersonAge]) asserting noExceptions @@ -73,8 +71,8 @@ testPostgresqlTextFunctions = do describe "text functions" $ do itDb "like, (%) and (++.) work on a simple example" $ do let nameContains t = - select $ - from $ \p -> do + select $ do + p <- from $ table @Person where_ (like (p ^. PersonName) @@ -92,12 +90,11 @@ testPostgresqlTextFunctions = do itDb "ilike, (%) and (++.) work on a simple example on PostgreSQL" $ do [p1e, _, p3e, _, p5e] <- mapM insert' [p1, p2, p3, p4, p5] - let nameContains t = do - select $ - from $ \p -> do - where_ (p ^. PersonName `ilike` (%) ++. val t ++. (%)) - orderBy [asc (p ^. PersonName)] - return p + let nameContains t = select $ do + p <- from $ table @Person + where_ (p ^. PersonName `ilike` (%) ++. val t ++. (%)) + orderBy [asc (p ^. PersonName)] + return p mi <- nameContains "mi" john <- nameContains "JOHN" asserting $ do @@ -118,8 +115,8 @@ testPostgresqlUpdate = do n <- updateCount $ \p -> do set p [ PersonAge +=. just (val 1) ] where_ (p ^. PersonName !=. val "Mike") - ret <- select $ - from $ \p -> do + ret <- select $ do + p <- from $ table @Person orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] return p -- PostgreSQL: nulls are bigger than data, and update returns @@ -145,8 +142,8 @@ testPostgresqlSum = do _ <- insert' p2 _ <- insert' p3 _ <- insert' p4 - ret <- select $ - from $ \p-> + ret <- select $ do + p <- from $ table @Person return $ joinV $ sum_ (p ^. PersonAge) asserting $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Rational ) ] @@ -157,8 +154,8 @@ testPostgresqlTwoAscFields = do p2e <- insert' p2 p3e <- insert' p3 p4e <- insert' p4 - ret <- select $ - from $ \p -> do + ret <- select $ do + p <- from $ table @Person orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] return p -- in PostgreSQL nulls are bigger than everything @@ -172,8 +169,8 @@ testPostgresqlOneAscOneDesc = do p2e <- insert' p2 p3e <- insert' p3 p4e <- insert' p4 - ret <- select $ - from $ \p -> do + ret <- select $ do + p <- from $ table @Person orderBy [desc (p ^. PersonAge)] orderBy [asc (p ^. PersonName)] return p @@ -189,11 +186,10 @@ testSelectDistinctOn = do [ BlogPost "A" p1k , BlogPost "B" p1k , BlogPost "C" p2k ] - ret <- select $ - from $ \bp -> - distinctOn [don (bp ^. BlogPostAuthorId)] $ do - orderBy [asc (bp ^. BlogPostAuthorId), desc (bp ^. BlogPostTitle)] - return bp + ret <- select $ do + bp <- from $ table @BlogPost + orderBy [asc (bp ^. BlogPostAuthorId), desc (bp ^. BlogPostTitle)] + distinctOn [don (bp ^. BlogPostAuthorId)] $ pure bp liftIO $ ret `shouldBe` L.sortBy (comparing (blogPostAuthorId . entityVal)) [bpB, bpC] let slightlyLessSimpleTest q = @@ -203,8 +199,8 @@ testSelectDistinctOn = do [ BlogPost "A" p1k , BlogPost "B" p1k , BlogPost "C" p2k ] - ret <- select $ - from $ \bp -> + ret <- select $ do + bp <- from $ table @BlogPost q bp $ return bp let cmp = (blogPostAuthorId &&& blogPostTitle) . entityVal liftIO $ ret `shouldBe` L.sortBy (comparing cmp) [bpA, bpB, bpC] @@ -240,7 +236,8 @@ testArrayAggWith :: SpecDb testArrayAggWith = do describe "ALL, no ORDER BY" $ do itDb "creates sane SQL" $ do - (query, args) <- showQuery ES.SELECT $ from $ \p -> + (query, args) <- showQuery ES.SELECT $ do + p <- from $ table @Person return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge) []) liftIO $ query `shouldBe` "SELECT array_agg(\"Person\".\"age\")\n\ @@ -251,13 +248,15 @@ testArrayAggWith = do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- - select $ from $ \p -> - return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) []) + select $ do + p <- from $ table @Person + return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) []) liftIO $ L.sort ret `shouldBe` L.sort (map personName people) describe "DISTINCT, no ORDER BY" $ do itDb "creates sane SQL" $ do - (query, args) <- showQuery ES.SELECT $ from $ \p -> + (query, args) <- showQuery ES.SELECT $ do + p <- from $ table @Person return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) []) liftIO $ query `shouldBe` "SELECT array_agg(DISTINCT \"Person\".\"age\")\n\ @@ -268,13 +267,15 @@ testArrayAggWith = do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- - select $ from $ \p -> + select $ do + p <- from $ table @Person return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) []) liftIO $ L.sort ret `shouldBe` [Nothing, Just 17, Just 36] describe "ALL, ORDER BY" $ do itDb "creates sane SQL" $ do - (query, args) <- showQuery ES.SELECT $ from $ \p -> + (query, args) <- showQuery ES.SELECT $ do + p <- from $ table @Person return (EP.arrayAggWith EP.AggModeAll (p ^. PersonAge) [ asc $ p ^. PersonName , desc $ p ^. PersonFavNum @@ -289,13 +290,15 @@ testArrayAggWith = do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- - select $ from $ \p -> + select $ do + p <- from $ table @Person return (EP.arrayAggWith EP.AggModeAll (p ^. PersonName) []) liftIO $ L.sort ret `shouldBe` L.sort (map personName people) describe "DISTINCT, ORDER BY" $ do itDb "creates sane SQL" $ do - (query, args) <- showQuery ES.SELECT $ from $ \p -> + (query, args) <- showQuery ES.SELECT $ do + p <- from $ table @Person return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) [asc $ p ^. PersonAge]) liftIO $ query `shouldBe` @@ -308,20 +311,18 @@ testArrayAggWith = do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- - select $ from $ \p -> + select $ do + p <- from $ table @Person return (EP.arrayAggWith EP.AggModeDistinct (p ^. PersonAge) [asc $ p ^. PersonAge]) liftIO $ ret `shouldBe` [Just 17, Just 36, Nothing] - - - - testStringAggWith :: SpecDb testStringAggWith = do describe "ALL, no ORDER BY" $ do itDb "creates sane SQL" $ do - (query, args) <- showQuery ES.SELECT $ from $ \p -> + (query, args) <- showQuery ES.SELECT $ do + p <- from $ table @Person return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ") []) liftIO $ query `shouldBe` @@ -333,19 +334,22 @@ testStringAggWith = do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- - select $ from $ \p -> + select $ do + p <- from $ table @Person return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[]) liftIO $ (L.sort $ words ret) `shouldBe` L.sort (map personName people) itDb "works with zero rows" $ do [Value ret] <- - select $ from $ \p -> - return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[]) + select $ do + p <- from $ table @Person + return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ")[]) liftIO $ ret `shouldBe` Nothing describe "DISTINCT, no ORDER BY" $ do itDb "creates sane SQL" $ do - (query, args) <- showQuery ES.SELECT $ from $ \p -> + (query, args) <- showQuery ES.SELECT $ do + p <- from $ table @Person return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") [] liftIO $ query `shouldBe` @@ -357,15 +361,17 @@ testStringAggWith = do let people = [p1, p2, p3 {personName = "John"}, p4, p5] mapM_ insert people [Value (Just ret)] <- - select $ from $ \p -> - return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") - [] + select $ do + p <- from $ table @Person + return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") + [] liftIO $ (L.sort $ words ret) `shouldBe` (L.sort . L.nub $ map personName people) describe "ALL, ORDER BY" $ do itDb "creates sane SQL" $ do - (query, args) <- showQuery ES.SELECT $ from $ \p -> + (query, args) <- showQuery ES.SELECT $ do + p <- from $ table @Person return (EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ") [ asc $ p ^. PersonName , desc $ p ^. PersonFavNum @@ -380,15 +386,17 @@ testStringAggWith = do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- - select $ from $ \p -> - return $ EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ") + select $ do + p <- from $ table @Person + return $ EP.stringAggWith EP.AggModeAll (p ^. PersonName) (val " ") [desc $ p ^. PersonName] liftIO $ (words ret) `shouldBe` (L.reverse . L.sort $ map personName people) describe "DISTINCT, ORDER BY" $ do itDb "creates sane SQL" $ do - (query, args) <- showQuery ES.SELECT $ from $ \p -> + (query, args) <- showQuery ES.SELECT $ do + p <- from $ table @Person return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") [desc $ p ^. PersonName] liftIO $ query `shouldBe` @@ -401,9 +409,10 @@ testStringAggWith = do let people = [p1, p2, p3 {personName = "John"}, p4, p5] mapM_ insert people [Value (Just ret)] <- - select $ from $ \p -> - return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") - [desc $ p ^. PersonName] + select $ do + p <- from $ table @Person + return $ EP.stringAggWith EP.AggModeDistinct (p ^. PersonName) (val " ") + [desc $ p ^. PersonName] liftIO $ (words ret) `shouldBe` (L.reverse . L.sort . L.nub $ map personName people) @@ -418,12 +427,16 @@ testAggregateFunctions = do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- - select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName)) + select $ do + p <- from $ table @Person + return $ EP.arrayAgg (p ^. PersonName) liftIO $ L.sort ret `shouldBe` L.sort (map personName people) itDb "works on zero rows" $ do [Value ret] <- - select $ from $ \p -> return (EP.arrayAgg (p ^. PersonName)) + select $ do + p <- from $ table @Person + return $ EP.arrayAgg (p ^. PersonName) liftIO $ ret `shouldBe` Nothing describe "arrayAggWith" testArrayAggWith describe "stringAgg" $ do @@ -432,13 +445,15 @@ testAggregateFunctions = do let people = [p1, p2, p3, p4, p5] mapM_ insert people [Value (Just ret)] <- - select $ - from $ \p -> do - return (EP.stringAgg (p ^. PersonName) (val " ")) + select $ do + p <- from $ table @Person + return $ EP.stringAgg (p ^. PersonName) (val " ") liftIO $ L.sort (words ret) `shouldBe` L.sort (map personName people) itDb "works on zero rows" $ do [Value ret] <- - select $ from $ \p -> return (EP.stringAgg (p ^. PersonName) (val " ")) + select $ do + p <- from $ table @Person + return $ EP.stringAgg (p ^. PersonName) (val " ") liftIO $ ret `shouldBe` Nothing describe "stringAggWith" testStringAggWith @@ -450,18 +465,19 @@ testAggregateFunctions = do , Person "4" (Just 8) Nothing 2 , Person "5" (Just 9) Nothing 2 ] - ret <- select $ from $ \(person :: SqlExpr (Entity Person)) -> do - groupBy (person ^. PersonFavNum) - return . EP.arrayRemoveNull . EP.maybeArray . EP.arrayAgg - $ person ^. PersonAge + ret <- select $ do + person <- from $ table @Person + groupBy (person ^. PersonFavNum) + return . EP.arrayRemoveNull . EP.maybeArray . EP.arrayAgg $ person ^. PersonAge liftIO $ (L.sort $ map (L.sort . unValue) ret) `shouldBe` [[7], [8,9]] describe "maybeArray" $ do itDb "Coalesces NULL into an empty array" $ do [Value ret] <- - select $ from $ \p -> - return (EP.maybeArray $ EP.arrayAgg (p ^. PersonName)) + select $ do + p <- from $ table @Person + return $ EP.maybeArray $ EP.arrayAgg (p ^. PersonName) liftIO $ ret `shouldBe` [] testPostgresModule :: SpecDb @@ -493,14 +509,14 @@ testPostgresModule = do rawExecute "SET TIME ZONE 'UTC'" [] ret <- fmap (Map.fromList . coerce :: _ -> Map DateTruncTestId (UTCTime, UTCTime)) $ - select $ - from $ \dt -> do - pure - ( dt ^. DateTruncTestId - , ( dt ^. DateTruncTestCreated - , truncateDate (val "day") (dt ^. DateTruncTestCreated) - ) - ) + select $ do + dt <- from $ table @DateTruncTest + pure + ( dt ^. DateTruncTestId + , ( dt ^. DateTruncTestCreated + , truncateDate (val "day") (dt ^. DateTruncTestCreated) + ) + ) asserting $ for_ vals $ \(idx, utcTime) -> do case Map.lookup idx ret of @@ -1063,16 +1079,20 @@ testInsertSelectWithConflict = _ <- insert p1 _ <- insert p2 _ <- insert p3 - n1 <- EP.insertSelectWithConflictCount UniqueValue ( - from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) - ) - (\current excluded -> []) - uniques1 <- select $ from $ \u -> return u - n2 <- EP.insertSelectWithConflictCount UniqueValue ( - from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) - ) - (\current excluded -> []) - uniques2 <- select $ from $ \u -> return u + n1 <- EP.insertSelectWithConflictCount UniqueValue + (do + p <- from $ table @Person + return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) + ) + (\current excluded -> []) + uniques1 <- select $ from $ table @OneUnique + n2 <- EP.insertSelectWithConflictCount UniqueValue + (do + p <- from $ table @Person + return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) + ) + (\current excluded -> []) + uniques2 <- select $ from $ table @OneUnique liftIO $ n1 `shouldBe` 3 liftIO $ n2 `shouldBe` 0 let test = map (OneUnique "test" . personFavNum) [p1,p2,p3] @@ -1083,16 +1103,22 @@ testInsertSelectWithConflict = _ <- insert p2 _ <- insert p3 -- Note, have to sum 4 so that the update does not conflicts again with another row. - n1 <- EP.insertSelectWithConflictCount UniqueValue ( - from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) - ) - (\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)]) - uniques1 <- select $ from $ \u -> return u - n2 <- EP.insertSelectWithConflictCount UniqueValue ( - from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) - ) - (\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)]) - uniques2 <- select $ from $ \u -> return u + n1 <- EP.insertSelectWithConflictCount UniqueValue + (do + p <- from $ table @Person + return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) + ) + (\current excluded -> + [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)]) + uniques1 <- select $ from $ table @OneUnique + n2 <- EP.insertSelectWithConflictCount UniqueValue + (do + p <- from $ table @Person + return $ OneUnique <# val "test" <&> (p ^. PersonFavNum) + ) + (\current excluded -> + [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)]) + uniques2 <- select $ from $ table @OneUnique liftIO $ n1 `shouldBe` 3 liftIO $ n2 `shouldBe` 3 let test = map (OneUnique "test" . personFavNum) [p1,p2,p3] @@ -1115,29 +1141,30 @@ testFilterWhere = -- Person "Mitch" Nothing Nothing 5 _ <- insert p5 - usersByAge <- fmap coerce <$> do - select $ from $ \users -> do + usersByAge <- do + select $ do + users <- from $ table @Person groupBy $ users ^. PersonAge return - ( users ^. PersonAge :: SqlExpr (Value (Maybe Int)) + ( users ^. PersonAge -- Nothing: [Rachel { favNum = 2 }, Mitch { favNum = 5 }] = 2 -- Just 36: [John { favNum = 1 } (excluded)] = 0 -- Just 17: [Mike { favNum = 3 }, Livia { favNum = 4 }] = 2 , count (users ^. PersonId) `EP.filterWhere` (users ^. PersonFavNum >=. val 2) - :: SqlExpr (Value Int) -- Nothing: [Rachel { favNum = 2 } (excluded), Mitch { favNum = 5 } (excluded)] = 0 -- Just 36: [John { favNum = 1 }] = 1 -- Just 17: [Mike { favNum = 3 } (excluded), Livia { favNum = 4 } (excluded)] = 0 , count (users ^. PersonFavNum) `EP.filterWhere` (users ^. PersonFavNum <. val 2) - :: SqlExpr (Value Int) ) - liftIO $ usersByAge `shouldMatchList` - ( [ (Nothing, 2, 0) - , (Just 36, 0, 1) - , (Just 17, 2, 0) - ] :: [(Maybe Int, Int, Int)] - ) + asserting $ usersByAge `shouldMatchList` + ( + [ (Value Nothing, Value 2, Value 0) + , (Value (Just 36), Value 0, Value 1) + , (Value (Just 17), Value 2, Value 0) + ] :: [(Value (Maybe Int), Value Int, Value Int)] + ) + itDb "adds a filter clause to sum aggregation" $ do -- Person "John" (Just 36) Nothing 1 @@ -1152,7 +1179,8 @@ testFilterWhere = _ <- insert p5 usersByAge <- fmap (\(Value a, Value b, Value c) -> (a, b, c)) <$> do - select $ from $ \users -> do + select $ do + users <- from $ table @Person groupBy $ users ^. PersonAge return ( users ^. PersonAge @@ -1179,11 +1207,11 @@ testCommonTableExpressions = do itDb "will run" $ do void $ select $ do limitedLordsCte <- - Experimental.with $ do - lords <- Experimental.from $ Experimental.table @Lord + with $ do + lords <- from $ table @Lord limit 10 pure lords - lords <- Experimental.from limitedLordsCte + lords <- from limitedLordsCte orderBy [asc $ lords ^. LordId] pure lords @@ -1192,11 +1220,11 @@ testCommonTableExpressions = do itDb "can do multiple recursive queries" $ do let oneToTen = - Experimental.withRecursive + withRecursive (pure $ val (1 :: Int)) - Experimental.unionAll_ + unionAll_ (\self -> do - v <- Experimental.from self + v <- from self where_ $ v <. val 10 pure $ v +. val 1 ) @@ -1204,31 +1232,31 @@ testCommonTableExpressions = do vals <- select $ do cte <- oneToTen cte2 <- oneToTen - res1 <- Experimental.from cte - res2 <- Experimental.from cte2 + res1 <- from cte + res2 <- from cte2 pure (res1, res2) asserting $ vals `shouldBe` (((,) <$> fmap Value [1..10] <*> fmap Value [1..10])) itDb "passing previous query works" $ do let oneToTen = - Experimental.withRecursive + withRecursive (pure $ val (1 :: Int)) - Experimental.unionAll_ + unionAll_ (\self -> do - v <- Experimental.from self + v <- from self where_ $ v <. val 10 pure $ v +. val 1 ) oneMore q = - Experimental.with $ do - v <- Experimental.from q + with $ do + v <- from q pure $ v +. val 1 vals <- select $ do cte <- oneToTen cte2 <- oneMore cte - res <- Experimental.from cte2 + res <- from cte2 pure res asserting $ vals `shouldBe` fmap Value [2..11] @@ -1240,7 +1268,7 @@ testPostgresqlLocking = do in TLB.toLazyText tlb itDb "concatenates postgres locking clauses" $ do let multipleLockingQuery = do - p <- Experimental.from $ table @Person + p <- from $ table @Person EP.forUpdateOf p EP.skipLocked EP.forUpdateOf p EP.skipLocked EP.forShareOf p EP.skipLocked @@ -1259,7 +1287,13 @@ testPostgresqlLocking = do asserting $ res1 `shouldBe` resExpected describe "For update skip locked locking" $ sequential $ do - let mkInitialStateForLockingTest connection = + let allPeopleAndPosts = do + (p :& b) <- from $ table @Person + `innerJoin` table @BlogPost + `on` (\(p :& b) -> + p ^. PersonId ==. b ^. BlogPostAuthorId) + return (p :& b) + mkInitialStateForLockingTest connection = flip runSqlPool connection $ do p1k <- insert p1 p2k <- insert p2 @@ -1287,23 +1321,21 @@ testPostgresqlLocking = do _ <- takeMVar waitMainThread nonLockedRowsNonSpecified <- select $ do - p <- Experimental.from $ table @Person + p <- from $ table @Person EP.forUpdateOf p EP.skipLocked return p nonLockedRowsSpecifiedTable <- select $ do - from $ \(p `LeftOuterJoin` b) -> do - on (p ^. PersonId ==. b ^. BlogPostAuthorId) - EP.forUpdateOf p EP.skipLocked - return p + (p :& b) <- allPeopleAndPosts + EP.forUpdateOf p EP.skipLocked + return p nonLockedRowsSpecifyAllTables <- select $ do - from $ \(p `InnerJoin` b) -> do - on (p ^. PersonId ==. b ^. BlogPostAuthorId) - EP.forUpdateOf (p :& b) EP.skipLocked - return p + (p :& b) <- allPeopleAndPosts + EP.forUpdateOf (p :& b) EP.skipLocked + return p pure $ do nonLockedRowsNonSpecified `shouldBe` [] @@ -1313,17 +1345,17 @@ testPostgresqlLocking = do withAsync sideThread $ \sideThreadAsync -> do void $ flip runSqlPool connection $ do void $ select $ do - person <- Experimental.from $ table @Person + person <- from $ table @Person locking ForUpdate pure $ person ^. PersonId _ <- putMVar waitMainThread () sideThreadAsserts <- wait sideThreadAsync - nonLockedRowsAfterUpdate <- select $ do - from $ \(p `LeftOuterJoin` b) -> do - on (p ^. PersonId ==. b ^. BlogPostAuthorId) - EP.forUpdateOf p EP.skipLocked - return p + nonLockedRowsAfterUpdate <- + select $ do + (p :& b) <- allPeopleAndPosts + EP.forUpdateOf p EP.skipLocked + return p asserting sideThreadAsserts asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3 @@ -1338,10 +1370,9 @@ testPostgresqlLocking = do nonLockedRowsSpecifiedTable <- select $ do - from $ \(p `LeftOuterJoin` b) -> do - on (p ^. PersonId ==. b ^. BlogPostAuthorId) - EP.forUpdateOf p EP.skipLocked - return p + (p :& b) <- allPeopleAndPosts + EP.forUpdateOf p EP.skipLocked + return p liftIO $ print nonLockedRowsSpecifiedTable pure $ length nonLockedRowsSpecifiedTable `shouldBe` 2 @@ -1350,22 +1381,20 @@ testPostgresqlLocking = do void $ flip runSqlPool connection $ do update $ \p -> do set p [ PersonName =. val "ChangedName1" ] - where_ $ p ^. PersonId - `in_` subList_select (do - person <- Experimental.from $ table @Person - where_ (person ^. PersonName ==. val "Rachel") - limit 1 - locking ForUpdate - pure $ person ^. PersonId) + where_ $ exists $ do + person <- from $ table @Person + locking ForUpdate + where_ $ person ^. PersonId ==. p ^. PersonId + &&. person ^. PersonName ==. val "Rachel" _ <- putMVar waitMainThread () sideThreadAsserts <- wait sideThreadAsync - nonLockedRowsAfterUpdate <- select $ do - from $ \(p `LeftOuterJoin` b) -> do - on (p ^. PersonId ==. b ^. BlogPostAuthorId) - EP.forUpdateOf p EP.skipLocked - return p + nonLockedRowsAfterUpdate <- + select $ do + (p :& b) <- allPeopleAndPosts + EP.forUpdateOf p EP.skipLocked + return p liftIO $ print nonLockedRowsAfterUpdate asserting sideThreadAsserts @@ -1378,20 +1407,17 @@ testPostgresqlLocking = do sideThread = flip runSqlPool connection $ do liftIO $ takeMVar waitMainThread - lockedRows <- - select $ do - from $ \(p `LeftOuterJoin` b) -> do - on (p ^. PersonId ==. b ^. BlogPostAuthorId) - where_ (b ^. BlogPostTitle ==. val "A") - EP.forUpdateOf p EP.skipLocked - return p + lockedRows <- select $ do + (p :& b) <- allPeopleAndPosts + EP.forUpdateOf p EP.skipLocked + where_ (b ^. BlogPostTitle ==. val "A") + return p nonLockedRows <- select $ do - from $ \(p `LeftOuterJoin` b) -> do - on (p ^. PersonId ==. b ^. BlogPostAuthorId) - EP.forUpdateOf p EP.skipLocked - return p + (p :& b) <- allPeopleAndPosts + EP.forUpdateOf p EP.skipLocked + return p pure $ do lockedRows `shouldBe` [] @@ -1401,28 +1427,31 @@ testPostgresqlLocking = do void $ flip runSqlPool connection $ do update $ \p -> do set p [ PersonName =. val "ChangedName" ] - where_ $ p ^. PersonId - `in_` subList_select (do - (people :& blogPosts) <- - Experimental.from $ table @Person - `Experimental.leftJoin` table @BlogPost - `Experimental.on` (\(people :& blogPosts) -> - just (people ^. PersonId) ==. blogPosts ?. BlogPostAuthorId) - where_ (blogPosts ?. BlogPostTitle ==. just (val "A")) - pure $ people ^. PersonId - ) + where_ $ exists $ do + (people :& blogPosts) <- allPeopleAndPosts + EP.forUpdateOf people EP.skipLocked + where_ $ blogPosts ^. BlogPostTitle ==. val "A" + &&. p ^. PersonId ==. people ^. PersonId liftIO $ putMVar waitMainThread () sideThreadAsserts <- wait sideThreadAsync nonLockedRowsAfterUpdate <- select $ do - from $ \(p `LeftOuterJoin` b) -> do - on (p ^. PersonId ==. b ^. BlogPostAuthorId) - EP.forUpdateOf p EP.skipLocked - return p + (p :& b) <- allPeopleAndPosts + EP.forUpdateOf p EP.skipLocked + return p asserting sideThreadAsserts asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3 + describe "noWait" $ do + itDb "doesn't crash" $ do + select $ do + t <- from $ table @Person + EP.forUpdateOf t EP.noWait + pure t + + asserting noExceptions + -- Since lateral queries arent supported in Sqlite or older versions of mysql -- the test is in the Postgres module testLateralQuery :: SpecDb @@ -1432,9 +1461,9 @@ testLateralQuery = do _ <- do select $ do l :& c <- - Experimental.from $ table @Lord + from $ table @Lord `CrossJoin` \lord -> do - deed <- Experimental.from $ table @Deed + deed <- from $ table @Deed where_ $ lord ^. LordId ==. deed ^. DeedOwnerId pure $ countRows @Int pure (l, c) @@ -1442,13 +1471,13 @@ testLateralQuery = do itDb "supports INNER JOIN LATERAL" $ do let subquery lord = do - deed <- Experimental.from $ table @Deed + deed <- from $ table @Deed where_ $ lord ^. LordId ==. deed ^. DeedOwnerId pure $ countRows @Int res <- select $ do - l :& c <- Experimental.from $ table @Lord + l :& c <- from $ table @Lord `InnerJoin` subquery - `Experimental.on` (const $ val True) + `on` (const $ val True) pure (l, c) let _ = res :: [(Entity Lord, Value Int)] @@ -1456,12 +1485,12 @@ testLateralQuery = do itDb "supports LEFT JOIN LATERAL" $ do res <- select $ do - l :& c <- Experimental.from $ table @Lord + l :& c <- from $ table @Lord `LeftOuterJoin` (\lord -> do - deed <- Experimental.from $ table @Deed + deed <- from $ table @Deed where_ $ lord ^. LordId ==. deed ^. DeedOwnerId pure $ countRows @Int) - `Experimental.on` (const $ val True) + `on` (const $ val True) pure (l, c) let _ = res :: [(Entity Lord, Value (Maybe Int))] @@ -1479,10 +1508,10 @@ testValuesExpression = do NE.:| [ (val 20, val "twenty") , (val 30, val "thirty") ] query = do - (bound, boundName) :& person <- Experimental.from $ + (bound, boundName) :& person <- from $ EP.values exprs - `Experimental.InnerJoin` table @Person - `Experimental.on` (\((bound, boundName) :& person) -> person^.PersonAge >=. just bound) + `InnerJoin` table @Person + `on` (\((bound, boundName) :& person) -> person^.PersonAge >=. just bound) groupBy bound orderBy [ asc bound ] pure (bound, count @Int $ person^.PersonName) @@ -1493,7 +1522,7 @@ testValuesExpression = do itDb "supports single-column query" $ do let query = do - vInt <- Experimental.from $ EP.values $ val 1 NE.:| [ val 2, val 3 ] + vInt <- from $ EP.values $ val 1 NE.:| [ val 2, val 3 ] pure (vInt :: SqlExpr (Value Int)) result <- select query asserting noExceptions @@ -1501,7 +1530,7 @@ testValuesExpression = do itDb "supports multi-column query (+ nested simple expression and null)" $ do let query = do - (vInt, vStr, vDouble) <- Experimental.from + (vInt, vStr, vDouble) <- from $ EP.values $ (val 1, val "str1", coalesce [just $ val 1.0, nothing]) NE.:| [ (val 2, val "str2", just $ val 2.5) , (val 3, val "str3", nothing) ] @@ -1514,28 +1543,260 @@ testValuesExpression = do , (Value 2, Value "str2", Value $ Just 2.5) , (Value 3, Value "str3", Value Nothing) ] +testWindowFunctions :: SpecDb +testWindowFunctions = do + describe "Window Functions" $ do + + itDb "supports over ()" $ do + _ <- insert $ Numbers 1 2 + _ <- insert $ Numbers 2 4 + _ <- insert $ Numbers 3 5 + _ <- insert $ Numbers 6 7 + let query = do + n <- from $ table @Numbers + pure ( n ^. NumbersInt + , sum_ @_ @Double (n ^. NumbersDouble) `Window.over_` () + ) + result <- select query + asserting noExceptions + asserting $ result `shouldMatchList` + [ (Value 1, Value (Just 18.0)) + , (Value 2, Value (Just 18.0)) + , (Value 3, Value (Just 18.0)) + , (Value 6, Value (Just 18.0))] + + describe "rowNumber_" $ do + itDb "no partition" $ do + insertMany_ + [ Numbers { numbersInt = 1, numbersDouble = 2 } + , Numbers 2 4 + , Numbers 3 5 + , Numbers 6 7 + ] + let query = do + n <- from $ table @Numbers + orderBy [asc $ n ^. NumbersInt] + pure ( n ^. NumbersInt + , Window.rowNumber_ `Window.over_` () + ) + result <- select query + asserting noExceptions + asserting $ result `shouldMatchList` + [ (Value 1, Value 1) + , (Value 2, Value 2) + , (Value 3, Value 3) + , (Value 6, Value 4)] + + itDb "partition" $ do + insertMany_ + [ Numbers { numbersInt = 1, numbersDouble = 2 } + , Numbers 2 4 + , Numbers 3 5 + , Numbers 6 7 + ] + let query = do + n <- from $ table @Numbers + orderBy [asc $ n ^. NumbersInt] + pure ( n ^. NumbersInt + , Window.rowNumber_ `Window.over_` + Window.partitionBy_ (n ^. NumbersInt %. val 2 ==. val 0) + ) + result <- select query + asserting noExceptions + asserting $ result `shouldMatchList` + [ (Value 1, Value 1) + , (Value 2, Value 1) + , (Value 3, Value 2) + , (Value 6, Value 2)] + + describe "lag_" $ do + itDb "over ()" $ do + insertMany_ + [ Numbers { numbersInt = 1, numbersDouble = 2 } + , Numbers 2 4 + , Numbers 3 5 + , Numbers 6 7 + ] + let query = do + n <- from $ table @Numbers + orderBy [asc $ n ^. NumbersInt] + pure ( n ^. NumbersInt + , Window.lag_ (n ^. NumbersInt) Nothing `Window.over_` () + ) + result <- select query + asserting noExceptions + asserting $ result `shouldMatchList` + [ (Value 1, Value Nothing) + , (Value 2, Value (Just 1)) + , (Value 3, Value (Just 2)) + , (Value 6, Value (Just 3)) + ] + + + itDb "can countRows" $ do + _ <- insert $ Numbers 1 2 + _ <- insert $ Numbers 2 4 + _ <- insert $ Numbers 3 5 + _ <- insert $ Numbers 6 7 + let query = do + n <- from $ table @Numbers + pure ( n ^. NumbersInt + , countRows @Int `Window.over_` () + ) + result <- select query + asserting noExceptions + asserting $ result `shouldMatchList` + [ (Value 1, Value 4) + , (Value 2, Value 4) + , (Value 3, Value 4) + , (Value 6, Value 4)] + + itDb "can countRows" $ do + _ <- insert $ Numbers 1 2 + _ <- insert $ Numbers 2 4 + _ <- insert $ Numbers 3 5 + _ <- insert $ Numbers 6 7 + let query = do + n <- from $ table @Numbers + pure ( n ^. NumbersInt + , countRows @Int + `Window.over_` (Window.partitionBy_ (n ^. NumbersInt %. val @Int 2)) + ) + result <- select query + asserting noExceptions + asserting $ result `shouldMatchList` + [ (Value 1, Value 2) + , (Value 2, Value 2) + , (Value 3, Value 2) + , (Value 6, Value 2)] + + itDb "countRows over is OK as null" $ do + _ <- insert $ Numbers 1 2 + _ <- insert $ Numbers 1 3 + _ <- insert $ Numbers 2 4 + _ <- insert $ Numbers 3 5 + _ <- insert $ Numbers 6 7 + let query = do + n <- from $ table @Numbers + pure ( n ^. NumbersInt + , countRows @Int + `Window.over_` (Window.partitionBy_ (n ^. NumbersInt %. val @Int 2)) + ) + result <- select query + asserting noExceptions + asserting $ result `shouldMatchList` + [ (Value 1, Value 3) + , (Value 1, Value 3) + , (Value 2, Value 2) + , (Value 3, Value 3) + , (Value 6, Value 2)] + itDb "supports partitioning" $ do + _ <- insert $ Numbers 1 2 + _ <- insert $ Numbers 2 4 + _ <- insert $ Numbers 3 5 + _ <- insert $ Numbers 6 7 + + let query = do + n <- from $ table @Numbers + pure ( n ^. NumbersInt + , sum_ @_ @Double (n ^. NumbersDouble) + `Window.over_` (Window.partitionBy_ (n ^. NumbersInt %. val @Int 2)) + ) + result <- select query + asserting noExceptions + asserting $ result `shouldMatchList` + [ (Value 1, Value (Just 7.0)) + , (Value 2, Value (Just 11.0)) + , (Value 3, Value (Just 7.0)) + , (Value 6, Value (Just 11.0)) + ] + + itDb "supports running total" $ do + insertMany_ + [ Numbers 1 2 + , Numbers 2 4 + , Numbers 3 5 + , Numbers 6 7 + ] + let query = do + n <- from $ table @Numbers + pure ( n ^. NumbersInt + , n ^. NumbersDouble + , sum_ @_ @Double (n ^. NumbersDouble) + `Window.over_` (Window.orderBy_ [asc (n ^. NumbersInt)] + )-- <> Window.frame_ Window.unboundedPreceding) + ) + result <- select query + asserting noExceptions + asserting $ result `shouldBe` + [ (Value 1, Value 2, Value (Just 2.0)) + , (Value 2, Value 4, Value (Just 6.0)) + , (Value 3, Value 5, Value (Just 11.0)) + , (Value 6, Value 7, Value (Just 18.0)) + ] + + itDb "supports running total excluding current row and addition to sum" $ do + _ <- insert $ Numbers 1 2 + _ <- insert $ Numbers 2 4 + _ <- insert $ Numbers 3 5 + _ <- insert $ Numbers 6 7 + let query = do + n <- from $ table @Numbers + pure ( n ^. NumbersInt + , Window.sqlExprToWindowContext (just (n ^. NumbersDouble)) +. + sum_ (n ^. NumbersDouble) + `Window.over_` (Window.orderBy_ [asc (n ^. NumbersInt)] + <> Window.frame_ (Window.excludeCurrentRow Window.unboundedPreceding) + ) + ) + result <- select query + asserting noExceptions + asserting $ result `shouldBe` [ (Value 1, Value Nothing) + , (Value 2, Value (Just 6.0)) + , (Value 3, Value (Just 11.0)) + , (Value 6, Value (Just 18.0))] + + itDb "supports postgres filter and over clauses" $ do + _ <- insert $ Numbers 1 2 + _ <- insert $ Numbers 2 4 + _ <- insert $ Numbers 3 5 + _ <- insert $ Numbers 6 7 + let query = do + n <- from $ table @Numbers + pure ( n ^. NumbersInt + , sum_ @_ @Double (n ^. NumbersDouble) + `EP.filterWhere` (n ^. NumbersInt >. val 2) + `Window.over_` (Window.frame_ Window.unboundedPreceding) + ) + result <- select query + asserting noExceptions + asserting $ result `shouldBe` [ (Value 1, Value Nothing) + , (Value 2, Value Nothing) + , (Value 3, Value (Just 5.0)) + , (Value 6, Value (Just 12.0))] + + testSubselectAliasingBehavior :: SpecDb testSubselectAliasingBehavior = do describe "Aliasing behavior" $ do itDb "correctly realiases entities accross multiple subselects" $ do _ <- select $ do - Experimental.from $ Experimental.from $ Experimental.from $ table @Lord + from $ from $ from $ table @Lord asserting noExceptions itDb "doesnt erroneously repeat variable names when using subselect + union" $ do let lordQuery = do - l <- Experimental.from $ table @Lord + l <- from $ table @Lord pure (l ^. LordCounty, l ^. LordDogs) personQuery = do - p <- Experimental.from $ table @Person + p <- from $ table @Person pure (p ^. PersonName, just $ p ^. PersonFavNum) _ <- select $ - Experimental.from $ do - (str, _) <- Experimental.from $ lordQuery `union_` personQuery + from $ do + (str, _) <- from $ lordQuery `union_` personQuery pure (str, val @Int 1) asserting noExceptions - type JSONValue = Maybe (JSONB A.Value) createSaneSQL :: (PersistField a, MonadIO m) => SqlExpr (Value a) -> T.Text -> [PersistValue] -> SqlPersistT m () @@ -1546,8 +1807,8 @@ createSaneSQL act q vals = do args `shouldBe` vals fromValue :: (PersistField a) => SqlExpr (Value a) -> SqlQuery (SqlExpr (Value a)) -fromValue act = from $ \x -> do - let _ = x :: SqlExpr (Entity Json) +fromValue act = do + x <- from $ table @Json return act persistTextArray :: [T.Text] -> PersistValue @@ -1592,7 +1853,8 @@ selectJSON :: MonadIO m => (JSONBExpr A.Value -> SqlQuery ()) -> SqlPersistT m [Entity Json] -selectJSON f = select $ from $ \v -> do +selectJSON f = select $ do + v <- from $ table @Json f $ just (v ^. JsonValue) return v @@ -1629,6 +1891,7 @@ spec = beforeAll mkConnectionPool $ do testJSONOperators testLateralQuery testValuesExpression + testWindowFunctions testSubselectAliasingBehavior testPostgresqlLocking diff --git a/test/SQLite/LegacyTest.hs b/test/SQLite/LegacyTest.hs new file mode 100644 index 000000000..185c3f69c --- /dev/null +++ b/test/SQLite/LegacyTest.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module SQLite.LegacyTest where + +import Common.Test.Import hiding (from, on) + +import Control.Monad (void) +import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT) +import Database.Esqueleto.Legacy hiding (random_) +import Database.Esqueleto.SQLite (random_) +import Database.Persist.Sqlite (createSqlitePool) +import Database.Sqlite (SqliteException) + +import Common.LegacyTest + +testSqliteRandom :: SpecDb +testSqliteRandom = do + itDb "works with random_" $ do + _ <- select $ return (random_ :: SqlExpr (Value Int)) + asserting noExceptions + +testSqliteSum :: SpecDb +testSqliteSum = do + itDb "works with sum_" $ do + _ <- insert' p1 + _ <- insert' p2 + _ <- insert' p3 + _ <- insert' p4 + ret <- select $ + from $ \p-> + return $ joinV $ sum_ (p ^. PersonAge) + asserting $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Int) ] + + + + + +testSqliteTwoAscFields :: SpecDb +testSqliteTwoAscFields = do + itDb "works with two ASC fields (one call)" $ do + p1e <- insert' p1 + p2e <- insert' p2 + p3e <- insert' p3 + p4e <- insert' p4 + ret <- select $ + from $ \p -> do + orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] + return p + -- in SQLite and MySQL, its the reverse + asserting $ ret `shouldBe` [ p2e, p4e, p3e, p1e ] + +testSqliteOneAscOneDesc :: SpecDb +testSqliteOneAscOneDesc = do + itDb "works with one ASC and one DESC field (two calls)" $ do + p1e <- insert' p1 + p2e <- insert' p2 + p3e <- insert' p3 + p4e <- insert' p4 + ret <- select $ + from $ \p -> do + orderBy [desc (p ^. PersonAge)] + orderBy [asc (p ^. PersonName)] + return p + asserting $ ret `shouldBe` [ p1e, p4e, p3e, p2e ] + +testSqliteCoalesce :: SpecDb +testSqliteCoalesce = do + itDb "throws an exception on SQLite with <2 arguments" $ do + eres <- try $ select $ + from $ \p -> do + return (coalesce [p ^. PersonAge]) :: SqlQuery (SqlExpr (Value (Maybe Int))) + asserting $ case eres of + Left (_ :: SqliteException) -> + pure () + Right _ -> + expectationFailure "Expected SqliteException with <2 args to coalesce" + +testSqliteUpdate :: SpecDb +testSqliteUpdate = do + itDb "works on a simple example" $ do + p1k <- insert p1 + p2k <- insert p2 + p3k <- insert p3 + let anon = "Anonymous" :: String + () <- update $ \p -> do + set p [ PersonName =. val anon + , PersonAge *=. just (val 2) ] + where_ (p ^. PersonName !=. val "Mike") + n <- updateCount $ \p -> do + set p [ PersonAge +=. just (val 1) ] + where_ (p ^. PersonName !=. val "Mike") + ret <- select $ + from $ \p -> do + orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] + return p + -- SQLite: nulls appear first, update returns matched rows. + asserting $ do + n `shouldBe` 2 + ret `shouldMatchList` + [ Entity p2k (Person anon Nothing (Just 37) 2) + , Entity p1k (Person anon (Just 73) Nothing 1) + , Entity p3k p3 + ] + +testSqliteTextFunctions :: SpecDb +testSqliteTextFunctions = do + describe "text functions" $ do + itDb "like, (%) and (++.) work on a simple example" $ do + let query :: String -> SqlPersistT IO [Entity Person] + query t = + select $ + from $ \p -> do + where_ (like + (p ^. PersonName) + ((%) ++. val t ++. (%))) + orderBy [asc (p ^. PersonName)] + return p + [p1e, p2e, p3e, p4e] <- mapM insert' [p1, p2, p3, p4] + r0 <- query "h" + r1 <- query "i" + r2 <- query "iv" + asserting $ do + r0 `shouldBe` [p1e, p2e] + r1 `shouldBe` [p4e, p3e] + r2 `shouldBe` [p4e] + +spec :: HasCallStack => Spec +spec = beforeAll mkConnectionPool $ do + tests + + describe "SQLite specific tests" $ do + testAscRandom random_ + testRandomMath + testSqliteRandom + testSqliteSum + testSqliteTwoAscFields + testSqliteOneAscOneDesc + testSqliteCoalesce + testSqliteUpdate + testSqliteTextFunctions + +mkConnectionPool :: IO ConnectionPool +mkConnectionPool = do + conn <- + if verbose + then runStderrLoggingT $ + createSqlitePool ".esqueleto-test.sqlite" 4 + else runNoLoggingT $ + createSqlitePool ".esqueleto-test.sqlite" 4 + flip runSqlPool conn $ do + migrateIt + + pure conn + +verbose :: Bool +verbose = False + +migrateIt :: MonadUnliftIO m => SqlPersistT m () +migrateIt = do + void $ runMigrationSilent migrateAll + cleanDB diff --git a/test/SQLite/Test.hs b/test/SQLite/Test.hs index 79818ee01..b432a4a64 100644 --- a/test/SQLite/Test.hs +++ b/test/SQLite/Test.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module SQLite.Test where @@ -10,7 +11,7 @@ import Common.Test.Import hiding (from, on) import Control.Monad (void) import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT) -import Database.Esqueleto.Legacy hiding (random_) +import Database.Esqueleto import Database.Esqueleto.SQLite (random_) import Database.Persist.Sqlite (createSqlitePool) import Database.Sqlite (SqliteException) @@ -30,8 +31,8 @@ testSqliteSum = do _ <- insert' p2 _ <- insert' p3 _ <- insert' p4 - ret <- select $ - from $ \p-> + ret <- select $ do + p <- from $ table @Person return $ joinV $ sum_ (p ^. PersonAge) asserting $ ret `shouldBe` [ Value $ Just (36 + 17 + 17 :: Int) ] @@ -46,8 +47,8 @@ testSqliteTwoAscFields = do p2e <- insert' p2 p3e <- insert' p3 p4e <- insert' p4 - ret <- select $ - from $ \p -> do + ret <- select $ do + p <- from $ table @Person orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)] return p -- in SQLite and MySQL, its the reverse @@ -60,8 +61,8 @@ testSqliteOneAscOneDesc = do p2e <- insert' p2 p3e <- insert' p3 p4e <- insert' p4 - ret <- select $ - from $ \p -> do + ret <- select $ do + p <- from $ table @Person orderBy [desc (p ^. PersonAge)] orderBy [asc (p ^. PersonName)] return p @@ -70,9 +71,9 @@ testSqliteOneAscOneDesc = do testSqliteCoalesce :: SpecDb testSqliteCoalesce = do itDb "throws an exception on SQLite with <2 arguments" $ do - eres <- try $ select $ - from $ \p -> do - return (coalesce [p ^. PersonAge]) :: SqlQuery (SqlExpr (Value (Maybe Int))) + eres <- try $ select $ do + p <- from $ table @Person + return (coalesce [p ^. PersonAge]) :: SqlQuery (SqlExpr (Value (Maybe Int))) asserting $ case eres of Left (_ :: SqliteException) -> pure () @@ -93,8 +94,8 @@ testSqliteUpdate = do n <- updateCount $ \p -> do set p [ PersonAge +=. just (val 1) ] where_ (p ^. PersonName !=. val "Mike") - ret <- select $ - from $ \p -> do + ret <- select $ do + p <- from $ table @Person orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ] return p -- SQLite: nulls appear first, update returns matched rows. @@ -112,8 +113,8 @@ testSqliteTextFunctions = do itDb "like, (%) and (++.) work on a simple example" $ do let query :: String -> SqlPersistT IO [Entity Person] query t = - select $ - from $ \p -> do + select $ do + p <- from $ table @Person where_ (like (p ^. PersonName) ((%) ++. val t ++. (%))) diff --git a/test/Spec.hs b/test/Spec.hs index f6201f104..33f1300ef 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -3,9 +3,12 @@ module Main where import Test.Hspec import Test.Hspec.Core.Spec -import qualified SQLite.Test as SQLite +import qualified MySQL.LegacyTest as LegacyMySQL import qualified MySQL.Test as MySQL +import qualified PostgreSQL.LegacyTest as LegacyPostgres import qualified PostgreSQL.Test as Postgres +import qualified SQLite.LegacyTest as LegacySQLite +import qualified SQLite.Test as SQLite main :: IO () main = hspec spec @@ -13,10 +16,16 @@ main = hspec spec spec :: Spec spec = do parallel $ describe "Esqueleto" $ do + describe "Legacy SQLite" $ do + sequential $ LegacySQLite.spec describe "SQLite" $ do sequential $ SQLite.spec + describe "Legacy MySQL" $ do + sequential $ LegacyMySQL.spec describe "MySQL" $ do sequential $ MySQL.spec + describe "Legacy Postgresql" $ do + sequential $ LegacyPostgres.spec describe "Postgresql" $ do sequential $ Postgres.spec