diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 8f4e14e87..d4ef49c50 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -33,12 +33,31 @@ jobs: strategy: matrix: cabal: ["3.10.2.1"] +<<<<<<< HEAD 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@v2 +======= + ghc: + - "8.6" + - "8.8" + - "8.10" + - "9.0" + - "9.2" + - "9.4" + - "9.6" + - "9.8" + - "9.10" + # - "9.12" + env: + CONFIG: "--enable-tests --enable-benchmarks " + steps: + - uses: actions/checkout@v4 + - uses: haskell-actions/setup@v2 +>>>>>>> master id: setup-haskell-cabal with: ghc-version: ${{ matrix.ghc }} @@ -61,7 +80,7 @@ jobs: # mysql password: 'esqutest' # Required if "mysql user" exists. The password for the "mysql user" - run: cabal v2-update - run: cabal v2-freeze $CONFIG - - uses: actions/cache@v2 + - uses: actions/cache@v4 with: path: | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} @@ -72,6 +91,6 @@ jobs: ${{ runner.os }}-${{ matrix.ghc }}- - run: cabal v2-build --disable-optimization -j $CONFIG - run: cabal v2-test --disable-optimization -j $CONFIG --test-options "--fail-on-focus" - - if: ${{ matrix.ghc != '8.6.5' }} + - if: ${{ matrix.ghc != '8.6' }} run: cabal v2-haddock -j $CONFIG - run: cabal v2-sdist diff --git a/changelog.md b/changelog.md index 5113ea968..104155d2a 100644 --- a/changelog.md +++ b/changelog.md @@ -6,6 +6,57 @@ - 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.14.0 +======== +- @parsonsmatt + - [#415](https://github.com/bitemyapp/esqueleto/pull/415) + - Export the `SqlSelect` type from `Database.Esqueleto.Experimental` + - [#414](https://github.com/bitemyapp/esqueleto/pull/414) + - Derive `Foldable` and `Traversable` for `Value`. + - [#416](https://github.com/bitemyapp/esqueleto/pull/416) + - Derive `Functor` and `Bifunctor` for `:&` +- @matthewbauer + - [#341](https://github.com/bitemyapp/esqueleto/pull/341/) + - Add functions for `NULLS FIRST` and `NULLS LAST` in the Postgresql + module +- @JoelMcCracken + - [#354](https://github.com/bitemyapp/esqueleto/pull/354), [#417](https://github.com/bitemyapp/esqueleto/pull/417) + - Add `withMaterialized`, `withNotMaterialized` to the PostgreSQL module + +3.5.13.2 +======== +- @blujupiter32 + - [#379](https://github.com/bitemyapp/esqueleto/pull/379) + - Fix a bug where `not_ (a &&. b)` would be interpeted as `(not_ a) &&. b` +- @RikvanToor + - [#373](https://github.com/bitemyapp/esqueleto/pull/373), [#410](https://github.com/bitemyapp/esqueleto/pull/410) + - Fix name clashes when using CTEs multiple times +- @TeofilC + - [#394](https://github.com/bitemyapp/esqueleto/pull/394) + - Use TH quotes to eliminate some CPP. +- @parsonsmatt, @jappeace + - [#346](#https://github.com/bitemyapp/esqueleto/pull/346), [#411](https://github.com/bitemyapp/esqueleto/pull/411) + - Add docs for more SQL operators + +3.5.13.1 +======== +- @csamak + - [#405](https://github.com/bitemyapp/esqueleto/pull/405) + - Fix a bug introduced in 3.5.12.0 where deriveEsqueletoRecord incorrectly errors + +3.5.13.0 +======== +- @ac251 + - [#402](https://github.com/bitemyapp/esqueleto/pull/402) + - Add `forNoKeyUpdate` and `forKeyShare` locking kinds for postgres + +3.5.12.0 +======== +- @csamak + - [#405](https://github.com/bitemyapp/esqueleto/pull/405) + - `ToMaybe` instances are now derived for Maybe records. + See [Issue #401](https://github.com/bitemyapp/esqueleto/issues/401). + 3.5.11.2 ======== - @arguri diff --git a/esqueleto.cabal b/esqueleto.cabal index 0822af6be..af2dd7034 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -91,6 +91,7 @@ test-suite specs other-modules: Common.Test Common.LegacyTest + Common.Test.CTE Common.Test.Models Common.Test.Import Common.Test.Select diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index fccb46835..4bf9c035e 100644 --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -101,7 +101,6 @@ module Database.Esqueleto , where_ , groupBy , orderBy - , rand , asc , desc , limit diff --git a/src/Database/Esqueleto/Experimental.hs b/src/Database/Esqueleto/Experimental.hs index de08c880f..9e75888a1 100644 --- a/src/Database/Esqueleto/Experimental.hs +++ b/src/Database/Esqueleto/Experimental.hs @@ -61,13 +61,13 @@ module Database.Esqueleto.Experimental {-# WARNING "This module will be removed , ToAliasReference(..) , ToAliasReferenceT , ToSqlSetOperation(..) + , SqlSelect -- * The Normal Stuff , where_ , groupBy , groupBy_ , orderBy - , rand , asc , desc , limit diff --git a/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs b/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs index 7e56809d2..d71a18809 100644 --- a/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs +++ b/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs @@ -38,11 +38,13 @@ import Database.Esqueleto.Internal.Internal hiding (From(..), from, on) -- PostgreSQL 12, non-recursive and side-effect-free queries may be inlined and -- optimized accordingly if not declared @MATERIALIZED@ to get the previous -- behaviour. See [the PostgreSQL CTE documentation](https://www.postgresql.org/docs/current/queries-with.html#id-1.5.6.12.7), --- section Materialization, for more information. +-- section Materialization, for more information. To use a @MATERIALIZED@ query +-- in Esquelto, see functions 'withMaterialized' and 'withRecursiveMaterialized'. -- -- /Since: 3.4.0.0/ with :: ( ToAlias a , ToAliasReference a a' + , ToAliasReference a' a' , SqlSelect a r ) => SqlQuery a -> SqlQuery (From a') with query = do @@ -50,10 +52,14 @@ with query = do aliasedValue <- toAlias ret let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData) ident <- newIdentFor (DBName "cte") - let clause = CommonTableExpressionClause NormalCommonTableExpression ident (\info -> toRawSql SELECT info aliasedQuery) + let clause = CommonTableExpressionClause NormalCommonTableExpression (\_ _ -> "") ident (\info -> toRawSql SELECT info aliasedQuery) Q $ W.tell mempty{sdCteClause = [clause]} ref <- toAliasReference ident aliasedValue - pure $ From $ pure (ref, (\_ info -> (useIdent info ident, mempty))) + pure $ From $ do + newIdent <- newIdentFor (DBName "cte") + localRef <- toAliasReference newIdent ref + let makeLH info = useIdent info ident <> " AS " <> useIdent info newIdent + pure (localRef, (\_ info -> (makeLH info, mempty))) -- | @WITH@ @RECURSIVE@ allows one to make a recursive subquery, which can -- reference itself. Like @WITH@, this is supported in most modern SQL engines. @@ -103,7 +109,8 @@ withRecursive baseCase unionKind recursiveCase = do ref <- toAliasReference ident aliasedValue let refFrom = From (pure (ref, (\_ info -> (useIdent info ident, mempty)))) let recursiveQuery = recursiveCase refFrom - let clause = CommonTableExpressionClause RecursiveCommonTableExpression ident + let noModifier _ _ = "" + let clause = CommonTableExpressionClause RecursiveCommonTableExpression noModifier ident (\info -> (toRawSql SELECT info aliasedQuery) <> ("\n" <> (unUnionKind unionKind) <> "\n", mempty) <> (toRawSql SELECT info recursiveQuery) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 4e18636a1..809f0f51a 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} @@ -7,6 +8,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} @@ -54,6 +56,7 @@ import qualified Control.Monad.Trans.Reader as R import qualified Control.Monad.Trans.State as S import qualified Control.Monad.Trans.Writer as W import qualified Data.ByteString as B +import Data.Bifunctor (Bifunctor, bimap) import Data.Coerce (coerce) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL @@ -398,12 +401,6 @@ distinctOnOrderBy exprs act = $ TLB.toLazyText b , vals ) --- | @ORDER BY random()@ clause. --- --- @since 1.3.10 -rand :: SqlExpr OrderBy -rand = ERaw noMeta $ \_ _ -> ("RANDOM()", []) - -- | @HAVING@. -- -- @since 1.2.2 @@ -722,90 +719,167 @@ countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr_ ctx (Value a) countDistinct = countHelper "(DISTINCT " ")" not_ :: SqlExpr_ ctx (Value Bool) -> SqlExpr_ ctx (Value Bool) -not_ v = ERaw noMeta $ \p info -> first ("NOT " <>) $ x p info +not_ v = ERaw noMeta (const $ first ("NOT " <>) . x) where - x p info = + x info = case v of ERaw m f -> if hasCompositeKeyMeta m then throw (CompositeKeyErr NotError) else - let (b, vals) = f Never info - in (parensM p b, vals) + f Parens info -(==.) :: (PersistField a) - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value Bool) +-- | This operator produces the SQL operator @=@, which is used to compare +-- values for equality. +-- +-- Example: +-- +-- @ +-- query :: UserId -> SqlPersistT IO [Entity User] +-- query userId = select $ do +-- user <- from $ table \@User +-- where_ (user ^. UserId ==. val userId) +-- pure user +-- @ +-- +-- This would generate the following SQL: +-- +-- @ +-- SELECT user.* +-- FROM user +-- WHERE user.id = ? +-- @ +(==.) :: PersistField typ => SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value Bool) (==.) = unsafeSqlBinOpComposite " = " " AND " -(>=.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value Bool) +-- | This operator translates to the SQL operator @>=@. +-- +-- Example: +-- +-- @ +-- where_ $ user ^. UserAge >=. val 21 +-- @ +(>=.) :: PersistField typ => SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value Bool) (>=.) = unsafeSqlBinOp " >= " -(>.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value Bool) +-- | This operator translates to the SQL operator @>@. +-- +-- Example: +-- +-- @ +-- where_ $ user ^. UserAge >. val 20 +-- @ +(>.) :: PersistField typ => SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value Bool) (>.) = unsafeSqlBinOp " > " -(<=.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value Bool) +-- | This operator translates to the SQL operator @<=@. +-- +-- Example: +-- +-- @ +-- where_ $ val 21 <=. user ^. UserAge +-- @ +(<=.) :: PersistField typ => SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value Bool) (<=.) = unsafeSqlBinOp " <= " -(<.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value Bool) -(<.) = unsafeSqlBinOp " < " +-- | This operator translates to the SQL operator @<@. +-- +-- Example: +-- +-- @ +-- where_ $ val 20 <. user ^. UserAge +-- @ +(<.) :: PersistField typ => SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value Bool) +(<.) = unsafeSqlBinOp " < " -(!=.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value Bool) +-- | This operator translates to the SQL operator @!=@. +-- +-- Example: +-- +-- @ +-- where_ $ user ^. UserName !=. val "Bob" +-- @ +(!=.) :: PersistField typ => SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value typ) -> SqlExpr_ ctx (Value Bool) (!=.) = unsafeSqlBinOpComposite " != " " OR " -(&&.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value Bool) +-- | This operator translates to the SQL operator @AND@. +-- +-- Example: +-- +-- @ +-- where_ $ +-- user ^. UserName ==. val "Matt" +-- &&. user ^. UserAge >=. val 21 +-- @ +(&&.) :: SqlExpr_ ctx (Value Bool) -> SqlExpr_ ctx (Value Bool) -> SqlExpr_ ctx (Value Bool) (&&.) = unsafeSqlBinOp " AND " -(||.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value Bool) +-- | This operator translates to the SQL operator @AND@. +-- +-- Example: +-- +-- @ +-- where_ $ +-- user ^. UserName ==. val "Matt" +-- ||. user ^. UserName ==. val "John" +-- @ +(||.) :: SqlExpr_ ctx (Value Bool) -> SqlExpr_ ctx (Value Bool) -> SqlExpr_ ctx (Value Bool) (||.) = unsafeSqlBinOp " OR " -(+.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) +-- | This operator translates to the SQL operator @+@. +-- +-- This does not require or assume anything about the SQL values. Interpreting +-- what @+.@ means for a given type is left to the database engine. +-- +-- Example: +-- +-- @ +-- user ^. UserAge +. val 10 +-- @ +(+.) :: PersistField a => SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value a) (+.) = unsafeSqlBinOp " + " -(-.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) +-- | This operator translates to the SQL operator @-@. +-- +-- This does not require or assume anything about the SQL values. Interpreting +-- what @-.@ means for a given type is left to the database engine. +-- +-- Example: +-- +-- @ +-- user ^. UserAge -. val 10 +-- @ +(-.) :: PersistField a => SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value a) (-.) = unsafeSqlBinOp " - " -(/.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) +-- | This operator translates to the SQL operator @/@. +-- +-- This does not require or assume anything about the SQL values. Interpreting +-- what @/.@ means for a given type is left to the database engine. +-- +-- Example: +-- +-- @ +-- user ^. UserAge /. val 10 +-- @ +(/.) :: PersistField a => SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value a) (/.) = unsafeSqlBinOp " / " -(*.) :: PersistField a - => SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) - -> SqlExpr_ ctx (Value a) +-- | This operator translates to the SQL operator @*@. +-- +-- This does not require or assume anything about the SQL values. Interpreting +-- what @*.@ means for a given type is left to the database engine. +-- +-- Example: +-- +-- @ +-- user ^. UserAge *. val 10 +-- @ +(*.) :: PersistField a => SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value a) (*.) = unsafeSqlBinOp " * " --- | @BETWEEN@. +-- | @a `between` (b, c)@ translates to the SQL expression @a >= b AND a <= c@. +-- It does not use a SQL @BETWEEN@ operator. -- -- @since: 3.1.0 between :: PersistField a @@ -814,9 +888,6 @@ between :: PersistField a -> SqlExpr_ ctx (Value Bool) a `between` (b, c) = a >=. b &&. a <=. c -random_ :: (PersistField a, Num a) => SqlExpr (Value a) -random_ = unsafeSqlValue "RANDOM()" - round_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr_ ctx (Value a) -> SqlExpr_ ctx (Value b) round_ = unsafeSqlFunction "ROUND" @@ -1176,10 +1247,6 @@ case_ = unsafeSqlCase toBaseId :: ToBaseId ent => SqlExpr (Value (Key ent)) -> SqlExpr (Value (Key (BaseEnt ent))) toBaseId = veryUnsafeCoerceSqlExprValue -{-# DEPRECATED random_ "Since 2.6.0: `random_` is not uniform across all databases! Please use a specific one such as 'Database.Esqueleto.PostgreSQL.random_', 'Database.Esqueleto.MySQL.random_', or 'Database.Esqueleto.SQLite.random_'" #-} - -{-# DEPRECATED rand "Since 2.6.0: `rand` ordering function is not uniform across all databases! To avoid accidental partiality it will be removed in the next major version." #-} - -- Fixity declarations infixl 9 ^. infixl 7 *., /. @@ -1210,11 +1277,8 @@ else_ = id -- | A single value (as opposed to a whole entity). You may use -- @('^.')@ or @('?.')@ to get a 'Value' from an 'Entity'. -newtype Value a = Value { unValue :: a } deriving (Eq, Ord, Show, Typeable) - --- | @since 1.4.4 -instance Functor Value where - fmap f (Value a) = Value (f a) +newtype Value a = Value { unValue :: a } + deriving (Eq, Ord, Show, Typeable, Functor, Foldable, Traversable) instance Applicative Value where (<*>) (Value f) (Value a) = Value (f a) @@ -1493,9 +1557,15 @@ data Insertion a -- See the examples at the beginning of this module to see how this -- operator is used in 'JOIN' operations. data (:&) a b = a :& b - deriving (Eq, Show) + deriving (Eq, Show, Functor) infixl 2 :& +-- | +-- +-- @since 3.5.14.0 +instance Bifunctor (:&) where + bimap f g (a :& b) = f a :& g b + -- | Different kinds of locking clauses supported by 'locking'. -- -- Note that each RDBMS has different locking support. The @@ -1539,7 +1609,9 @@ data PostgresLockingKind = -- Arranged in order of lock strength data PostgresRowLevelLockStrength = PostgresForUpdate + | PostgresForNoKeyUpdate | PostgresForShare + | PostgresForKeyShare deriving (Ord, Eq) data LockingOfClause where @@ -1939,8 +2011,10 @@ data CommonTableExpressionKind | NormalCommonTableExpression deriving Eq -data CommonTableExpressionClause = - CommonTableExpressionClause CommonTableExpressionKind Ident (IdentInfo -> (TLB.Builder, [PersistValue])) +type CommonTableExpressionModifierAfterAs = CommonTableExpressionClause -> IdentInfo -> TLB.Builder + +data CommonTableExpressionClause + = CommonTableExpressionClause CommonTableExpressionKind CommonTableExpressionModifierAfterAs Ident (IdentInfo -> (TLB.Builder, [PersistValue])) data SubQueryType = NormalSubQuery @@ -3177,14 +3251,15 @@ makeCte info cteClauses = | hasRecursive = "WITH RECURSIVE " | otherwise = "WITH " where + hasRecursive = elem RecursiveCommonTableExpression - $ fmap (\(CommonTableExpressionClause cteKind _ _) -> cteKind) + $ fmap (\(CommonTableExpressionClause cteKind _ _ _) -> cteKind) $ cteClauses - cteClauseToText (CommonTableExpressionClause _ cteIdent cteFn) = + cteClauseToText clause@(CommonTableExpressionClause _ cteModifier cteIdent cteFn) = first - (\tlb -> useIdent info cteIdent <> " AS " <> parens tlb) + (\tlb -> useIdent info cteIdent <> " AS " <> cteModifier clause info <> parens tlb) (cteFn info) cteBody = @@ -3341,7 +3416,9 @@ makeLocking info (PostgresLockingClauses clauses) = <> makeLockingBehavior (postgresOnLockedBehavior l) makeLockingStrength :: PostgresRowLevelLockStrength -> (TLB.Builder, [PersistValue]) makeLockingStrength PostgresForUpdate = plain "FOR UPDATE" + makeLockingStrength PostgresForNoKeyUpdate = plain "FOR NO KEY UPDATE" makeLockingStrength PostgresForShare = plain "FOR SHARE" + makeLockingStrength PostgresForKeyShare = plain "FOR KEY SHARE" makeLockingBehavior :: OnLockedBehavior -> (TLB.Builder, [PersistValue]) makeLockingBehavior NoWait = plain "NOWAIT" @@ -3857,6 +3934,16 @@ instance ( SqlSelectCols a , sqlSelectCols esc k ] sqlSelectColCount = sqlSelectColCount . from11P + -- sqlSelectProcessRow = fmap to11 . sqlSelectProcessRow + +from11P :: Proxy (a,b,c,d,e,f,g,h,i,j,k) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),k) +from11P = const Proxy + +from11 :: (a,b,c,d,e,f,g,h,i,j,k) -> ((a,b),(c,d),(e,f),(g,h),(i,j),k) +from11 (a,b,c,d,e,f,g,h,i,j,k) = ((a,b),(c,d),(e,f),(g,h),(i,j),k) + +to11 :: ((a,b),(c,d),(e,f),(g,h),(i,j),k) -> (a,b,c,d,e,f,g,h,i,j,k) +to11 ((a,b),(c,d),(e,f),(g,h),(i,j),k) = (a,b,c,d,e,f,g,h,i,j,k) instance ( SqlSelect a ra , SqlSelect b rb @@ -3872,15 +3959,6 @@ instance ( SqlSelect a ra ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk) where sqlSelectProcessRow p = fmap to11 . sqlSelectProcessRow (from11P p) -from11P :: Proxy (a,b,c,d,e,f,g,h,i,j,k) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),k) -from11P = const Proxy - -from11 :: (a,b,c,d,e,f,g,h,i,j,k) -> ((a,b),(c,d),(e,f),(g,h),(i,j),k) -from11 (a,b,c,d,e,f,g,h,i,j,k) = ((a, b), (c, d), (e, f), (g, h), (i, j), k) - -to11 :: ((a,b),(c,d),(e,f),(g,h),(i,j),k) -> (a,b,c,d,e,f,g,h,i,j,k) -to11 ((a,b),(c,d),(e,f),(g,h),(i,j),k) = (a,b,c,d,e,f,g,h,i,j,k) - instance ( SqlSelectCols a , SqlSelectCols b , SqlSelectCols c @@ -3910,6 +3988,16 @@ instance ( SqlSelectCols a , sqlSelectCols esc l ] sqlSelectColCount = sqlSelectColCount . from12P + -- sqlSelectProcessRow = fmap to12 . sqlSelectProcessRow + +from12P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) +from12P = const Proxy + +from12 :: (a,b,c,d,e,f,g,h,i,j,k,l) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) +from12 (a,b,c,d,e,f,g,h,i,j,k,l) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) + +to12 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) -> (a,b,c,d,e,f,g,h,i,j,k,l) +to12 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) = (a,b,c,d,e,f,g,h,i,j,k,l) instance ( SqlSelect a ra , SqlSelect b rb @@ -3926,15 +4014,6 @@ instance ( SqlSelect a ra ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl) where sqlSelectProcessRow p = fmap to12 . sqlSelectProcessRow (from12P p) -from12P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) -from12P = const Proxy - -from12 :: (a,b,c,d,e,f,g,h,i,j,k,l) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) -from12 (a,b,c,d,e,f,g,h,i,j,k,l) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) - -to12 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) -> (a,b,c,d,e,f,g,h,i,j,k,l) -to12 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) = (a,b,c,d,e,f,g,h,i,j,k,l) - instance ( SqlSelectCols a , SqlSelectCols b , SqlSelectCols c @@ -3966,6 +4045,16 @@ instance ( SqlSelectCols a , sqlSelectCols esc m ] sqlSelectColCount = sqlSelectColCount . from13P + -- sqlSelectProcessRow = fmap to13 . sqlSelectProcessRow + +from13P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) +from13P = const Proxy + +from13 :: (a,b,c,d,e,f,g,h,i,j,k,l,m) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) +from13 (a,b,c,d,e,f,g,h,i,j,k,l,m) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) + +to13 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) -> (a,b,c,d,e,f,g,h,i,j,k,l,m) +to13 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) = (a,b,c,d,e,f,g,h,i,j,k,l,m) instance ( SqlSelect a ra , SqlSelect b rb @@ -3983,15 +4072,6 @@ instance ( SqlSelect a ra ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm) where sqlSelectProcessRow p = fmap to13 . sqlSelectProcessRow (from13P p) -from13P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) -from13P = const Proxy - -to13 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) -> (a,b,c,d,e,f,g,h,i,j,k,l,m) -to13 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) = (a,b,c,d,e,f,g,h,i,j,k,l,m) - -from13 :: (a,b,c,d,e,f,g,h,i,j,k,l,m) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) -from13 (a,b,c,d,e,f,g,h,i,j,k,l,m) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) - instance ( SqlSelectCols a , SqlSelectCols b , SqlSelectCols c @@ -4025,6 +4105,10 @@ instance ( SqlSelectCols a , 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 instance ( SqlSelect a ra , SqlSelect b rb @@ -4043,9 +4127,6 @@ instance ( SqlSelect a ra ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn) where sqlSelectProcessRow p = fmap to14 . sqlSelectProcessRow (from14P p) -from14P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) -from14P = const Proxy - from14 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) from14 (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) @@ -4087,6 +4168,13 @@ instance ( SqlSelectCols a , sqlSelectCols esc o ] sqlSelectColCount = sqlSelectColCount . from15P + -- sqlSelectProcessRow = fmap to15 . sqlSelectProcessRow + +from15P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n, o) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) +from15P = const Proxy + +from15 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) +from15 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) instance ( SqlSelect a ra , SqlSelect b rb @@ -4106,12 +4194,6 @@ instance ( SqlSelect a ra ) => SqlSelect (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) (ra, rb, rc, rd, re, rf, rg, rh, ri, rj, rk, rl, rm, rn, ro) where sqlSelectProcessRow p = fmap to15 . sqlSelectProcessRow (from15P p) -from15P :: Proxy (a,b,c,d,e,f,g,h,i,j,k,l,m,n, o) -> Proxy ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) -from15P = const Proxy - -from15 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) -from15 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) - to15 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) to15 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) diff --git a/src/Database/Esqueleto/Legacy.hs b/src/Database/Esqueleto/Legacy.hs index df1f27a2c..0106d849f 100644 --- a/src/Database/Esqueleto/Legacy.hs +++ b/src/Database/Esqueleto/Legacy.hs @@ -52,14 +52,14 @@ module Database.Esqueleto.Legacy {-# WARNING "This module will be removed in the -- $gettingstarted -- * @esqueleto@'s Language - where_, on, groupBy, orderBy, rand, asc, desc, limit, offset + where_, on, groupBy, orderBy, asc, desc, limit, offset , distinct, distinctOn, don, distinctOnOrderBy, having, locking , sub_select, (^.), (?.) , val, isNothing, just, nothing, joinV, withNonNull , countRows, count, countDistinct , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , between, (+.), (-.), (/.), (*.) - , random_, round_, ceiling_, floor_ + , round_, ceiling_, floor_ , min_, max_, sum_, avg_, castNum, castNumM , coalesce, coalesceDefault , lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_ diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 6fc9ac558..20a6ff2b7 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -31,10 +31,18 @@ module Database.Esqueleto.PostgreSQL , wait , skipLocked , forUpdateOf + , forNoKeyUpdateOf , forShareOf + , forKeyShareOf , filterWhere , values , (%.) + , withMaterialized + , withNotMaterialized + , ascNullsFirst + , ascNullsLast + , descNullsFirst + , descNullsLast -- * Internal , unsafeSqlExprAggregateFunction ) where @@ -47,15 +55,22 @@ import Control.Exception (throw) import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(..)) import qualified Control.Monad.Trans.Reader as R +import qualified Control.Monad.Trans.Writer as W import Data.Int (Int64) import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Proxy (Proxy(..)) import qualified Data.Text.Internal.Builder as TLB import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB import Data.Time.Clock (UTCTime) import qualified Database.Esqueleto.Experimental as Ex -import Database.Esqueleto.Internal.Internal hiding (random_) +import qualified Database.Esqueleto.Experimental.From as Ex +import Database.Esqueleto.Experimental.From.CommonTableExpression +import Database.Esqueleto.Experimental.From.SqlSetOperation +import Database.Esqueleto.Experimental.ToAlias +import Database.Esqueleto.Experimental.ToAliasReference +import Database.Esqueleto.Internal.Internal hiding (From(..), from, on, random_) import Database.Esqueleto.Internal.PersistentImport hiding (uniqueFields, upsert, upsertBy) import Database.Persist.SqlBackend @@ -484,11 +499,128 @@ forUpdateOf :: LockableEntity a => a -> OnLockedBehavior -> SqlQuery () forUpdateOf lockableEntities onLockedBehavior = putLocking $ PostgresLockingClauses [PostgresLockingKind PostgresForUpdate (Just $ LockingOfClause lockableEntities) onLockedBehavior] +-- | `FOR NO KEY UPDATE OF` syntax for postgres locking +-- allows locking of specific tables with a no key update lock in a view or join +-- +-- @since 3.5.13.0 +forNoKeyUpdateOf :: LockableEntity a => a -> OnLockedBehavior -> SqlQuery () +forNoKeyUpdateOf lockableEntities onLockedBehavior = + putLocking $ PostgresLockingClauses [PostgresLockingKind PostgresForNoKeyUpdate (Just $ LockingOfClause lockableEntities) onLockedBehavior] + -- | `FOR SHARE OF` syntax for postgres locking -- allows locking of specific tables with a share lock in a view or join -- -- @since 3.5.9.0 - forShareOf :: LockableEntity a => a -> OnLockedBehavior -> SqlQuery () forShareOf lockableEntities onLockedBehavior = putLocking $ PostgresLockingClauses [PostgresLockingKind PostgresForShare (Just $ LockingOfClause lockableEntities) onLockedBehavior] + +-- | `FOR KEY SHARE OF` syntax for postgres locking +-- allows locking of specific tables with a key share lock in a view or join +-- +-- @since 3.5.13.0 +forKeyShareOf :: LockableEntity a => a -> OnLockedBehavior -> SqlQuery () +forKeyShareOf lockableEntities onLockedBehavior = + putLocking $ PostgresLockingClauses [PostgresLockingKind PostgresForKeyShare (Just $ LockingOfClause lockableEntities) onLockedBehavior] + +-- | @WITH@ @MATERIALIZED@ clause is used to introduce a +-- [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression) +-- with the MATERIALIZED keyword. The MATERIALIZED keyword is only supported in PostgreSQL >= version 12. +-- In Esqueleto, CTEs should be used as a subquery memoization tactic. PostgreSQL treats a materialized CTE as an optimization fence. +-- A materialized CTE is always fully calculated, and is not "inlined" with other table joins. +-- Without the MATERIALIZED keyword, PostgreSQL >= 12 may "inline" the CTE as though it was any other join. +-- You should always verify that using a materialized CTE will in fact improve your performance +-- over a regular subquery. +-- +-- @ +-- select $ do +-- cte <- withMaterialized subQuery +-- cteResult <- from cte +-- where_ $ cteResult ... +-- pure cteResult +-- @ +-- +-- +-- For more information on materialized CTEs, see the PostgreSQL manual documentation on +-- [Common Table Expression Materialization](https://www.postgresql.org/docs/14/queries-with.html#id-1.5.6.12.7). +-- +-- @since 3.5.14.0 +withMaterialized :: ( ToAlias a + , ToAliasReference a a' + , SqlSelect a r + ) => SqlQuery a -> SqlQuery (Ex.From a') +withMaterialized query = do + (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ query + aliasedValue <- toAlias ret + let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData) + ident <- newIdentFor (DBName "cte") + let clause = CommonTableExpressionClause NormalCommonTableExpression (\_ _ -> "MATERIALIZED ") ident (\info -> toRawSql SELECT info aliasedQuery) + Q $ W.tell mempty{sdCteClause = [clause]} + ref <- toAliasReference ident aliasedValue + pure $ Ex.From $ pure (ref, (\_ info -> (useIdent info ident, mempty))) + +-- | @WITH@ @NOT@ @MATERIALIZED@ clause is used to introduce a +-- [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression) +-- with the NOT MATERIALIZED keywords. These are only supported in PostgreSQL >= +-- version 12. In Esqueleto, CTEs should be used as a subquery memoization +-- tactic. PostgreSQL treats a materialized CTE as an optimization fence. A +-- MATERIALIZED CTE is always fully calculated, and is not "inlined" with other +-- table joins. Sometimes, this is undesirable, so postgres provides the NOT +-- MATERIALIZED modifier to prevent this behavior, thus enabling it to possibly +-- decide to treat the CTE as any other join. +-- +-- Given the above, it is unlikely that this function will be useful, as a +-- normal join should be used instead, but is provided for completeness. +-- +-- @ +-- select $ do +-- cte <- withNotMaterialized subQuery +-- cteResult <- from cte +-- where_ $ cteResult ... +-- pure cteResult +-- @ +-- +-- +-- For more information on materialized CTEs, see the PostgreSQL manual documentation on +-- [Common Table Expression Materialization](https://www.postgresql.org/docs/14/queries-with.html#id-1.5.6.12.7). +-- +-- @since 3.5.14.0 +withNotMaterialized :: ( ToAlias a + , ToAliasReference a a' + , SqlSelect a r + ) => SqlQuery a -> SqlQuery (Ex.From a') +withNotMaterialized query = do + (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ query + aliasedValue <- toAlias ret + let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData) + ident <- newIdentFor (DBName "cte") + let clause = CommonTableExpressionClause NormalCommonTableExpression (\_ _ -> "NOT MATERIALIZED ") ident (\info -> toRawSql SELECT info aliasedQuery) + Q $ W.tell mempty{sdCteClause = [clause]} + ref <- toAliasReference ident aliasedValue + pure $ Ex.From $ pure (ref, (\_ info -> (useIdent info ident, mempty))) + +-- | Ascending order of this field or SqlExpression with nulls coming first. +-- +-- @since 3.5.14.0 +ascNullsFirst :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy +ascNullsFirst = orderByExpr " ASC NULLS FIRST" + +-- | Ascending order of this field or SqlExpression with nulls coming last. +-- Note that this is the same as normal ascending ordering in Postgres, but it has been included for completeness. +-- +-- @since 3.5.14.0 +ascNullsLast :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy +ascNullsLast = orderByExpr " ASC NULLS LAST" + +-- | Descending order of this field or SqlExpression with nulls coming first. +-- Note that this is the same as normal ascending ordering in Postgres, but it has been included for completeness. +-- +-- @since 3.5.14.0 +descNullsFirst :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy +descNullsFirst = orderByExpr " DESC NULLS FIRST" + +-- | Descending order of this field or SqlExpression with nulls coming last. +-- +-- @since 3.5.14.0 +descNullsLast :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy +descNullsLast = orderByExpr " DESC NULLS LAST" diff --git a/src/Database/Esqueleto/Record.hs b/src/Database/Esqueleto/Record.hs index 62f95e89f..7d9be64fb 100644 --- a/src/Database/Esqueleto/Record.hs +++ b/src/Database/Esqueleto/Record.hs @@ -36,8 +36,8 @@ import Data.Text (Text) import Control.Monad (forM) import Data.Foldable (foldl') import GHC.Exts (IsString(fromString)) -import Data.Maybe (mapMaybe, fromMaybe, listToMaybe) import Debug.Trace +import Data.Maybe (mapMaybe, fromMaybe, listToMaybe, isJust) -- | Takes the name of a Haskell record type and creates a variant of that -- record prefixed with @Sql@ which can be used in esqueleto expressions. This @@ -190,17 +190,23 @@ deriveEsqueletoRecordWith settings originalName = do sqlSelectInstanceDec <- makeSqlSelectInstance info sqlMaybeRecordDec <- makeSqlMaybeRecord info toMaybeInstanceDec <- makeToMaybeInstance info + sqlMaybeToMaybeInstanceDec <- makeSqlMaybeToMaybeInstance info sqlMaybeRecordSelectInstanceDec <- makeSqlMaybeRecordSelectInstance info toAliasInstanceDec <- makeToAliasInstance info + sqlMaybeToAliasInstanceDec <- makeSqlMaybeToAliasInstance info toAliasReferenceInstanceDec <- makeToAliasReferenceInstance info + sqlMaybeToAliasReferenceInstanceDec <- makeSqlMaybeToAliasReferenceInstance info pure $ concat - [ [recordDec] + [ recordDec , sqlSelectInstanceDec - , pure sqlMaybeRecordDec - , pure toMaybeInstanceDec + , sqlMaybeRecordDec + , toMaybeInstanceDec + , sqlMaybeToMaybeInstanceDec , sqlMaybeRecordSelectInstanceDec - , pure toAliasInstanceDec - , pure toAliasReferenceInstanceDec + , toAliasInstanceDec + , sqlMaybeToAliasInstanceDec + , toAliasReferenceInstanceDec + , sqlMaybeToAliasReferenceInstanceDec ] -- | Information about a record we need to generate the declarations. @@ -284,7 +290,7 @@ getRecordInfo settings name = do toSqlMaybeField (fieldName', ty) = do let modifier = mkName . sqlMaybeFieldModifier settings . nameBase sqlTy <- sqlMaybeFieldType ty - let result = (modifier fieldName', sqlTy) + pure (modifier fieldName', sqlTy) -- | Create a new name by prefixing @Sql@ to a given name. @@ -359,11 +365,11 @@ sqlMaybeFieldType fieldType = do -- | Generates the declaration for an @Sql@-prefixed record, given the original -- record's information. -makeSqlRecord :: RecordInfo -> Q Dec +makeSqlRecord :: RecordInfo -> Q [Dec] makeSqlRecord RecordInfo {..} = do let newConstructor = RecC sqlConstructorName (makeField `map` sqlFields) derivingClauses = [] - pure $ DataD constraints sqlName typeVarBinders kind [newConstructor] derivingClauses + pure $ pure $ DataD constraints sqlName typeVarBinders kind [newConstructor] derivingClauses where makeField (fieldName', fieldType) = (fieldName', Bang NoSourceUnpackedness NoSourceStrictness, fieldType) @@ -377,19 +383,25 @@ makeSqlSelectInstance info@RecordInfo {..} = do sqlSelectProcessRowDec' <- sqlSelectProcessRowDec info let overlap = Nothing instanceConstraints = [] - sqlSelectColsType = - AppT (ConT ''SqlSelectCols) (ConT sqlName) - instanceType = - (ConT ''SqlSelect) - `AppT` (ConT sqlName) - `AppT` (ConT name) +-- <<<<<<< HEAD +-- sqlSelectColsType = +-- AppT (ConT ''SqlSelectCols) (ConT sqlName) +-- instanceType = +-- (ConT ''SqlSelect) +-- `AppT` (ConT sqlName) +-- `AppT` (ConT name) +-- +-- pure [ InstanceD overlap instanceConstraints sqlSelectColsType [ sqlSelectColsDec', sqlSelectColCountDec'] +-- , InstanceD overlap instanceConstraints instanceType [ sqlSelectProcessRowDec'] +-- ] +-- ======= + instanceType <- [t| SqlSelect $(conT sqlName) $(conT name) |] - pure [ InstanceD overlap instanceConstraints sqlSelectColsType [ sqlSelectColsDec', sqlSelectColCountDec'] - , InstanceD overlap instanceConstraints instanceType [ sqlSelectProcessRowDec'] - ] + pure $ pure $ InstanceD overlap instanceConstraints instanceType (sqlSelectColsDec' ++ sqlSelectColCountDec' ++ [ sqlSelectProcessRowDec']) +-- >>>>>>> master -- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance. -sqlSelectColsDec :: RecordInfo -> Q Dec +sqlSelectColsDec :: RecordInfo -> Q [Dec] sqlSelectColsDec RecordInfo {..} = do -- Pairs of record field names and local variable names. fieldNames <- forM sqlFields $ \(name', typ) -> do @@ -414,27 +426,34 @@ sqlSelectColsDec RecordInfo {..} = do (Just $ VarE field) in foldl' helper (VarE f1) rest +-- <<<<<<< HEAD +-- 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. +-- [] +-- ] +-- ======= identInfo <- newName "identInfo" - -- Roughly: - -- sqlSelectCols $identInfo SqlFoo{..} = sqlSelectCols $identInfo $joinedFields - pure $ - FunD - 'sqlSelectCols - [ Clause - [ VarP identInfo - , RecP sqlName fieldPatterns - ] - ( NormalB $ - (VarE 'sqlSelectCols) - `AppE` (VarE identInfo) - `AppE` (ParensE joinedFields) - ) - -- `where` clause. - [] - ] + [d| $(varP 'sqlSelectCols) = \ $(varP identInfo) $(pure $ RecP sqlName fieldPatterns) -> + sqlSelectCols $(varE identInfo) $(pure joinedFields) + |] +-- >>>>>>> master -- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance. -sqlSelectColCountDec :: RecordInfo -> Q Dec +sqlSelectColCountDec :: RecordInfo -> Q [Dec] sqlSelectColCountDec RecordInfo {..} = do let joinedTypes = case snd `map` sqlFields of @@ -444,23 +463,7 @@ sqlSelectColCountDec RecordInfo {..} = do InfixT lhs ''(:&) ty in foldl' helper t1 rest - -- Roughly: - -- sqlSelectColCount _ = sqlSelectColCount (Proxy @($joinedTypes)) - pure $ - FunD - 'sqlSelectColCount - [ Clause - [WildP] - ( NormalB $ - AppE (VarE 'sqlSelectColCount) $ - ParensE $ - AppTypeE - (ConE 'Proxy) - joinedTypes - ) - -- `where` clause. - [] - ] + [d| $(varP 'sqlSelectColCount) = \ _ -> sqlSelectColCount (Proxy @($(pure joinedTypes))) |] -- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect` -- instance. @@ -543,11 +546,7 @@ sqlSelectProcessRowPat fieldType var = do `AppT` ((ConT ((==) ''Entity -> True)) `AppT` _innerType) -> pure $ VarP var -- x -> Value var -#if MIN_VERSION_template_haskell(2,18,0) - _ -> pure $ ConP 'Value [] [VarP var] -#else - _ -> pure $ ConP 'Value [VarP var] -#endif + _ -> [p| Value $(varP var) |] -- Given a type, find the corresponding SQL type. -- @@ -653,20 +652,24 @@ nonRecordConstructorMessage con = (GadtC names _fields _ret) -> head names (RecGadtC names _fields _ret) -> head names -makeToAliasInstance :: RecordInfo -> Q Dec -makeToAliasInstance info@RecordInfo {..} = do - toAliasDec' <- toAliasDec info +makeToAliasInstance :: RecordInfo -> Q [Dec] +makeToAliasInstance RecordInfo {..} = makeToAliasInstanceFor sqlName sqlFields + +makeSqlMaybeToAliasInstance :: RecordInfo -> Q [Dec] +makeSqlMaybeToAliasInstance RecordInfo {..} = makeToAliasInstanceFor sqlMaybeName sqlMaybeFields + +makeToAliasInstanceFor :: Name -> [(Name, Type)] -> Q [Dec] +makeToAliasInstanceFor name fields = do + toAliasDec' <- toAliasDec name fields let overlap = Nothing instanceConstraints = [] - instanceType = - (ConT ''ToAlias) - `AppT` (ConT sqlName) - pure $ InstanceD overlap instanceConstraints instanceType [toAliasDec'] + instanceType = (ConT ''ToAlias) `AppT` (ConT name) + pure $ pure $ InstanceD overlap instanceConstraints instanceType [toAliasDec'] -toAliasDec :: RecordInfo -> Q Dec -toAliasDec RecordInfo {..} = do +toAliasDec :: Name -> [(Name, Type)] -> Q Dec +toAliasDec name fields = do (statements, fieldPatterns, fieldExps) <- - unzip3 <$> forM sqlFields (\(fieldName', _) -> do + unzip3 <$> forM fields (\(fieldName', _) -> do fieldPatternName <- newName (nameBase fieldName') boundValueName <- newName (nameBase fieldName') pure @@ -681,36 +684,40 @@ toAliasDec RecordInfo {..} = do FunD 'toAlias [ Clause - [ RecP sqlName fieldPatterns + [ RecP name fieldPatterns ] ( NormalB $ DoE #if MIN_VERSION_template_haskell(2,17,0) Nothing #endif - (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE sqlName fieldExps)]) + (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE name fieldExps)]) ) -- `where` clause. [] ] -makeToAliasReferenceInstance :: RecordInfo -> Q Dec -makeToAliasReferenceInstance info@RecordInfo {..} = do - toAliasReferenceDec' <- toAliasReferenceDec info +makeToAliasReferenceInstance :: RecordInfo -> Q [Dec] +makeToAliasReferenceInstance RecordInfo {..} = makeToAliasReferenceInstanceFor sqlName sqlFields + +makeSqlMaybeToAliasReferenceInstance :: RecordInfo -> Q [Dec] +makeSqlMaybeToAliasReferenceInstance RecordInfo {..} = + makeToAliasReferenceInstanceFor sqlMaybeName sqlMaybeFields + +makeToAliasReferenceInstanceFor :: Name -> [(Name, Type)] -> Q [Dec] +makeToAliasReferenceInstanceFor name fields = do + toAliasReferenceDec' <- toAliasReferenceDec name fields let overlap = Nothing instanceConstraints = [] - instanceType = - ConT ''ToAliasReference - `AppT` ConT sqlName - `AppT` ConT sqlName - pure $ InstanceD overlap instanceConstraints instanceType [toAliasReferenceDec'] - -toAliasReferenceDec :: RecordInfo -> Q Dec -toAliasReferenceDec RecordInfo {..} = do + instanceType = (ConT ''ToAliasReference) `AppT` (ConT name) `AppT` (ConT name) + pure $ pure $ InstanceD overlap instanceConstraints instanceType [toAliasReferenceDec'] + +toAliasReferenceDec :: Name -> [(Name, Type)] -> Q Dec +toAliasReferenceDec name fields = do identInfo <- newName "identInfo" (statements, fieldPatterns, fieldExps) <- - unzip3 <$> forM sqlFields (\(fieldName', _) -> do + unzip3 <$> forM fields (\(fieldName', _) -> do fieldPatternName <- newName (nameBase fieldName') boundValueName <- newName (nameBase fieldName') pure @@ -726,14 +733,14 @@ toAliasReferenceDec RecordInfo {..} = do 'toAliasReference [ Clause [ VarP identInfo - , RecP sqlName fieldPatterns + , RecP name fieldPatterns ] ( NormalB $ DoE #if MIN_VERSION_template_haskell(2,17,0) Nothing #endif - (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE sqlName fieldExps)]) + (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE name fieldExps)]) ) -- `where` clause. [] @@ -741,44 +748,70 @@ toAliasReferenceDec RecordInfo {..} = do -- | Generates the declaration for an @SqlMaybe@-prefixed record, given the original -- record's information. -makeSqlMaybeRecord :: RecordInfo -> Q Dec +makeSqlMaybeRecord :: RecordInfo -> Q [Dec] makeSqlMaybeRecord RecordInfo {..} = do let newConstructor = RecC sqlMaybeConstructorName (makeField `map` sqlMaybeFields) derivingClauses = [] - pure $ DataD constraints sqlMaybeName typeVarBinders kind [newConstructor] derivingClauses + pure $ pure $ DataD constraints sqlMaybeName typeVarBinders kind [newConstructor] derivingClauses where makeField (fieldName', fieldType) = (fieldName', Bang NoSourceUnpackedness NoSourceStrictness, fieldType) -- | Generates a `ToMaybe` instance for the given record. -makeToMaybeInstance :: RecordInfo -> Q Dec +makeToMaybeInstance :: RecordInfo -> Q [Dec] makeToMaybeInstance info@RecordInfo {..} = do - toMaybeTDec' <- toMaybeTDec info +-- <<<<<<< HEAD +-- toMaybeTDec' <- toMaybeTDec info +-- ======= + toMaybeTDec' <- toMaybeTDec sqlName sqlMaybeName +-- >>>>>>> master toMaybeDec' <- toMaybeDec info let overlap = Nothing instanceConstraints = [] instanceType = (ConT ''ToMaybe) `AppT` (ConT sqlName) - pure $ InstanceD overlap instanceConstraints instanceType [toMaybeTDec', toMaybeDec'] +-- <<<<<<< HEAD +-- 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 +-- ======= + pure $ pure $ InstanceD overlap instanceConstraints instanceType (toMaybeTDec' ++ toMaybeDec') + +-- | Generates a `ToMaybe` instance for the SqlMaybe of the given record. +makeSqlMaybeToMaybeInstance :: RecordInfo -> Q [Dec] +makeSqlMaybeToMaybeInstance RecordInfo {..} = do + sqlMaybeToMaybeTDec' <- toMaybeTDec sqlMaybeName sqlMaybeName + let toMaybeIdDec = FunD 'toMaybe [ Clause [] (NormalB (VarE 'id)) []] + overlap = Nothing + instanceConstraints = [] + instanceType = (ConT ''ToMaybe) `AppT` (ConT sqlMaybeName) + pure $ pure $ InstanceD overlap instanceConstraints instanceType (toMaybeIdDec:sqlMaybeToMaybeTDec') --- | 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 `type ToMaybeT ... = ...` declaration for the given names. +toMaybeTDec :: Name -> Name -> Q [Dec] +toMaybeTDec nameLeft nameRight = + [d| type instance ToMaybeT $(conT nameLeft) = $(conT nameRight) |] -- | Generates a `toMaybe value = ...` declaration for the given record. -toMaybeDec :: RecordInfo -> Q Dec +toMaybeDec :: RecordInfo -> Q [Dec] +-- >>>>>>> master toMaybeDec RecordInfo {..} = do (fieldPatterns, fieldExps) <- unzip <$> forM (zip sqlFields sqlMaybeFields) (\((fieldName', _), (maybeFieldName', _)) -> do @@ -788,17 +821,26 @@ toMaybeDec RecordInfo {..} = do , (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 +-- <<<<<<< HEAD +-- 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] +-- ======= + [d| $(varP 'toMaybe) = \ $(pure $ RecP sqlName fieldPatterns) -> + $(pure $ RecConE sqlMaybeName fieldExps) + |] + +-- | Generates an `SqlSelect` instance for the given record and its -- @Sql@-prefixed variant. makeSqlMaybeRecordSelectInstance :: RecordInfo -> Q [Dec] makeSqlMaybeRecordSelectInstance info@RecordInfo {..} = do @@ -807,22 +849,30 @@ makeSqlMaybeRecordSelectInstance info@RecordInfo {..} = do 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' - ] - - ] +-- <<<<<<< HEAD +-- 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 +-- ======= + instanceType <- [t| SqlSelect $(conT sqlMaybeName) (Maybe $(conT name)) |] + pure $ pure $ InstanceD overlap instanceConstraints instanceType (sqlSelectColsDec' ++ sqlSelectColCountDec' ++ [sqlSelectProcessRowDec']) -- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance. -sqlMaybeSelectColsDec :: RecordInfo -> Q Dec +sqlMaybeSelectColsDec :: RecordInfo -> Q [Dec] +-- >>>>>>> master sqlMaybeSelectColsDec RecordInfo {..} = do -- Pairs of record field names and local variable names. fieldNames <- forM sqlMaybeFields (\(name', _type) -> do @@ -848,116 +898,188 @@ sqlMaybeSelectColsDec RecordInfo {..} = do in foldl' helper (VarE f1) rest identInfo <- newName "identInfo" - -- Roughly: - -- sqlSelectCols $identInfo SqlFoo{..} = sqlSelectCols $identInfo $joinedFields - pure $ - FunD - 'sqlSelectCols - [ Clause - [ VarP identInfo - , RecP sqlMaybeName fieldPatterns - ] - ( NormalB $ - (VarE 'sqlSelectCols) - `AppE` (VarE identInfo) - `AppE` (ParensE joinedFields) - ) - -- `where` clause. - [] - ] +-- <<<<<<< HEAD +-- -- 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 +-- ======= + [d| $(varP 'sqlSelectCols) = \ $(varP identInfo) $(pure $ RecP sqlMaybeName fieldPatterns) -> + sqlSelectCols $(varE identInfo) $(pure joinedFields) + |] -- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect` --- instance. +-- instance for a SqlMaybe. sqlMaybeSelectProcessRowDec :: RecordInfo -> Q Dec sqlMaybeSelectProcessRowDec RecordInfo {..} = do - let sqlOp x t = - case x of - -- AppT (ConT ((==) ''Entity -> True)) _innerType -> id - -- (ConT ((==) ''Maybe -> True)) `AppT` ((ConT ((==) ''Entity -> True)) `AppT` _innerType) -> (AppE (VarE 'pure)) - -- inner@((ConT ((==) ''Maybe -> True)) `AppT` _inner) -> (AppE (VarE 'unValue)) - (AppT (ConT ((==) ''SqlExpr -> True)) (AppT (ConT ((==) ''Value -> True)) inner)) - | AppT (ConT m) _ <- inner -> - case () of - () - | ''Maybe == m -> do - [e| (pure . unValue) $(pure t) |] - | otherwise -> do - pure (AppE (VarE 'unValue) t) - | otherwise -> - pure (AppE (VarE 'unValue) t) - (AppT (ConT ((==) ''SqlExpr -> True)) (AppT (ConT ((==) ''Entity -> True)) _)) -> - pure t - (AppT (ConT ((==) ''SqlExpr -> True)) (AppT (ConT ((==) ''Maybe -> True)) _)) -> do - pure (AppE (VarE 'pure) t) - (ConT _) -> - pure t - _ -> - fail $ show t + -- See sqlSelectProcessRowDec, which is similar but does not have special handling for Maybe + (statements, fieldExps) <- + unzip <$> forM (zip fields sqlMaybeFields) (\((fieldName', fieldType), (_, sqlType')) -> do + valueName <- newName (nameBase fieldName') + pattern <- sqlSelectProcessRowPat fieldType valueName + pure + ( BindS + pattern + (AppTypeE (VarE 'takeColumns) sqlType') + , (valueName, wrapJust fieldType $ VarE valueName) + )) - fieldNames <- forM sqlFields $ \(name', typ) -> do - var <- newName $ nameBase name' - newTy <- sqlOp typ (VarE var) - pure (name', var, newTy) + colsName <- newName "columns" + processName <- newName "process" - let joinedFields = - case map (\(_,x,_) -> x) fieldNames of - [] -> TupP [] - [f1] -> VarP f1 - f1 : rest -> - let helper lhs field = - InfixP - lhs - '(:&) - (VarP field) - in foldl' helper (VarP f1) rest - - fieldTypes = map snd sqlMaybeFields - - toMaybeT t = ConT ''ToMaybeT `AppT` t - - tupleType = - case fieldTypes of - [] -> - ConT '() - (x:xs) -> - foldl' (\acc t -> - ConT ''(:&) - `AppT` acc - `AppT` t) x xs - - proxy <- [e| Proxy :: Proxy $(pure tupleType) |] - colsName <- newName "columns" - proxyName <- newName "proxy" - - let + bodyExp <- [e| + first (fromString ("Failed to parse " ++ $(lift $ nameBase sqlMaybeName) ++ ": ") <>) + (evalStateT $(varE processName) $(varE colsName)) + |] + + pure $ + FunD + 'sqlSelectProcessRow + [ Clause + [VarP colsName] + (NormalB bodyExp) + -- `where` + [ ValD + (VarP processName) + (NormalB $ + DoE #if MIN_VERSION_template_haskell(2,17,0) - bodyExp = DoE Nothing -#else - bodyExp = DoE + Nothing #endif - [ BindS joinedFields (VarE 'sqlSelectProcessRow `AppE` proxy `AppE` VarE colsName) - , NoBindS - $ AppE (VarE 'pure) ( - case fieldNames of - [] -> ConE constructorName - (_,_,e):xs -> foldl' - (\acc (_,_,e2) -> AppE (AppE (VarE '(<*>)) acc) e2) - (AppE (AppE (VarE 'fmap) (ConE constructorName)) e) - xs - ) - ] - - pure $ - FunD - 'sqlSelectProcessRow - [ Clause - [WildP, VarP colsName] - (NormalB bodyExp) - [] - ] + (statements ++ [ + NoBindS $ AppE (VarE 'pure) ( + CondE + (AppE + (VarE 'or) + (ListE $ fmap (\(n, _) -> AppE (VarE 'isJust) (VarE n)) fieldExps)) + (case snd <$> fieldExps of + [] -> ConE constructorName + x:xs -> foldl' + (\a b -> InfixE (Just a) (VarE '(<*>)) (Just b)) + (InfixE (Just $ ConE constructorName) (VarE '(<$>)) (Just x)) + xs) + (ConE 'Nothing) + ) + ] + ) + ) + [] + ] + ] + where + wrapJust x = case x of + ((ConT ((==) ''Maybe -> True)) `AppT` _inner) -> AppE (ConE 'Just) + _ -> id -- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance. -sqlMaybeSelectColCountDec :: RecordInfo -> Q Dec +sqlMaybeSelectColCountDec :: RecordInfo -> Q [Dec] +-- >>>>>>> master sqlMaybeSelectColCountDec RecordInfo {..} = do let joinedTypes = case snd `map` sqlMaybeFields of @@ -967,23 +1089,27 @@ sqlMaybeSelectColCountDec RecordInfo {..} = do InfixT lhs ''(:&) ty in foldl' helper t1 rest - -- Roughly: - -- sqlSelectColCount _ = sqlSelectColCount (Proxy @($joinedTypes)) - pure $ - FunD - 'sqlSelectColCount - [ Clause - [WildP] - ( NormalB $ - AppE (VarE 'sqlSelectColCount) $ - ParensE $ - AppTypeE - (ConE 'Proxy) - joinedTypes - ) - -- `where` clause. - [] - ] +-- <<<<<<< HEAD +-- -- Roughly: +-- -- sqlSelectColCount _ = sqlSelectColCount (Proxy @($joinedTypes)) +-- pure $ +-- FunD +-- 'sqlSelectColCount +-- [ Clause +-- [WildP] +-- ( NormalB $ +-- AppE (VarE 'sqlSelectColCount) $ +-- ParensE $ +-- AppTypeE +-- (ConE 'Proxy) +-- joinedTypes +-- ) +-- -- `where` clause. +-- [] +-- ] +-- ======= + [d| $(varP 'sqlSelectColCount) = \_ -> sqlSelectColCount (Proxy @($(pure joinedTypes))) |] +-- >>>>>>> master -- | Statefully parse some number of columns from a list of `PersistValue`s, -- where the number of columns to parse is determined by `sqlSelectColCount` diff --git a/stack-8.10.yaml b/stack-8.10.yaml index 585337b26..d793586b2 100644 --- a/stack-8.10.yaml +++ b/stack-8.10.yaml @@ -9,3 +9,6 @@ allow-newer: true extra-deps: - lift-type-0.1.0.1 - persistent-2.14.0.2 + +nix: + packages: [zlib, libmysqlclient, pcre, postgresql] diff --git a/stack-8.2.yaml b/stack-8.2.yaml index 3577eef90..c0f7c0af8 100644 --- a/stack-8.2.yaml +++ b/stack-8.2.yaml @@ -23,3 +23,6 @@ extra-deps: - scientific-0.3.6.2 - text-1.2.3.0 - unliftio-0.2.0.0 + +nix: + packages: [zlib, libmysqlclient, pcre, postgresql] diff --git a/stack-8.4.yaml b/stack-8.4.yaml index 23839a735..48f810395 100644 --- a/stack-8.4.yaml +++ b/stack-8.4.yaml @@ -13,3 +13,6 @@ extra-deps: - postgresql-libpq-0.9.4.2 - postgresql-simple-0.6.1 - transformers-0.5.5.2 + +nix: + packages: [zlib, libmysqlclient, pcre, postgresql] diff --git a/stack-8.6.yaml b/stack-8.6.yaml index 938fc3d8f..5f2764468 100644 --- a/stack-8.6.yaml +++ b/stack-8.6.yaml @@ -19,3 +19,6 @@ extra-deps: - lift-type-0.1.0.1 - th-lift-instances-0.1.19 - th-lift-0.8.2 + +nix: + packages: [zlib, libmysqlclient, pcre, postgresql] diff --git a/stack-8.8.yaml b/stack-8.8.yaml index e794cdb91..c38f620c4 100644 --- a/stack-8.8.yaml +++ b/stack-8.8.yaml @@ -10,3 +10,6 @@ extra-deps: - persistent-mysql-2.12.0.0 - persistent-postgresql-2.12.0.0 - persistent-sqlite-2.12.0.0 + +nix: + packages: [zlib, libmysqlclient, pcre, postgresql] diff --git a/stack-9.0.yaml b/stack-9.0.yaml index ba4a9c379..49a504ea7 100644 --- a/stack-9.0.yaml +++ b/stack-9.0.yaml @@ -9,3 +9,6 @@ allow-newer: true extra-deps: - lift-type-0.1.0.1 - persistent-2.14.0.2 + +nix: + packages: [zlib, libmysqlclient, pcre, postgresql] diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 7ce4cc13a..6c1a6662b 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -12,3 +12,6 @@ extra-deps: - process-1.6.14.0 - Cabal-3.6.3.0 - unix-2.7.2.2 + +nix: + packages: [zlib, libmysqlclient, pcre, postgresql] diff --git a/test/Common/Record.hs b/test/Common/Record.hs index 398b59023..92ee01a24 100644 --- a/test/Common/Record.hs +++ b/test/Common/Record.hs @@ -80,10 +80,16 @@ myRecordQuery = do data MyNestedRecord = MyNestedRecord { myName :: Text , myRecord :: MyRecord + , myMaybeRecord :: Maybe MyRecord } deriving (Show, Eq) +data MyNestedMaybeRecord = MyNestedMaybeRecord + {myNestedRecord :: Maybe MyRecord} + deriving (Show, Eq) + $(deriveEsqueletoRecord ''MyNestedRecord) +$(deriveEsqueletoRecord ''MyNestedMaybeRecord) myNestedRecordQuery :: SqlQuery SqlMyNestedRecord myNestedRecordQuery = do @@ -102,6 +108,32 @@ myNestedRecordQuery = do , myUser = user , myAddress = address } + , myMaybeRecord = + SqlMaybeMyRecord + { myName = castString $ user ^. #name + , myAge = val $ Just 10 + , myUser = toMaybe user + , myAddress = address + } + } + +myNestedMaybeRecordQuery :: SqlQuery SqlMyNestedMaybeRecord +myNestedMaybeRecordQuery = do + user :& address <- + from $ + table @User + `leftJoin` table @Address + `on` (do \(user :& address) -> user ^. #address ==. address ?. #id) + pure + SqlMyNestedMaybeRecord + { + myNestedRecord = + SqlMaybeMyRecord + { myName = castString $ user ^. #name + , myAge = val $ Just 10 + , myUser = toMaybe user + , myAddress = address + } } data MyModifiedRecord = @@ -211,6 +243,107 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do } -> addr1 == addr2 -- The keys should match. _ -> False) + itDb "can select nested maybe records" $ do + setup + records <- select myNestedMaybeRecordQuery + let sortedRecords = sortOn (\MyNestedMaybeRecord {myNestedRecord} -> case myNestedRecord of + Just r -> getField @"myName" r + Nothing -> "No name" + ) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case MyNestedMaybeRecord + { + myNestedRecord = Just + MyRecord { myName = "Rebecca" + , myAge = Just 10 + , myUser = Entity _ User { userAddress = Nothing + , userName = "Rebecca" + } + , myAddress = Nothing + } + } -> True + _ -> False) + + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case MyNestedMaybeRecord + { + myNestedRecord = Just + MyRecord { myName = "Some Guy" + , myAge = Just 10 + , myUser = Entity _ User { userAddress = Just addr1 + , userName = "Some Guy" + } + , myAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"}) + } + } -> addr1 == addr2 -- The keys should match. + _ -> False) + + itDb "can select nested nothing records" $ do + setup + records <- select $ do + user :& address <- + from $ table @User `leftJoin` table @Address `on` (do \(_ :& _) -> val False) + pure + SqlMyNestedMaybeRecord + { + myNestedRecord = + SqlMaybeMyRecord + { myName = val Nothing + , myAge = val Nothing + , myUser = toMaybe user + , myAddress = address + } + } + liftIO $ records `shouldBe` + [MyNestedMaybeRecord { myNestedRecord = Nothing }, MyNestedMaybeRecord { myNestedRecord = Nothing}] + + itDb "can left join on nested maybed records" $ do + setup + records <- select $ do + from + ( table @User + `leftJoin` myNestedMaybeRecordQuery + `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" (getField @"myNestedRecord" record) ?. #id) + ) + let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case (_ :& Just (MyNestedMaybeRecord + { + myNestedRecord = Just + MyRecord { myName = "Rebecca", + myAddress = Nothing + } + } + )) -> True + _ -> False) + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case ( _ :& Just (MyNestedMaybeRecord + { myNestedRecord = Just + MyRecord { myName = "Some Guy" + , myAddress = (Just (Entity _ Address {addressAddress = "30-50 Feral Hogs Rd"})) + } + } + )) -> True + _ -> False) + + itDb "can left join on nothing nested records" $ do + setup + records <- select $ do + from (table @User `leftJoin` myNestedMaybeRecordQuery `on` (do \(_ :& _) -> val False)) + let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case (_ :& Nothing) -> True + _ -> False) + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case (_ :& Nothing) -> True + _ -> False) + itDb "can be used in a CTE" $ do setup records <- select $ do @@ -284,9 +417,9 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) } )) -> True - _ -> True) + _ -> False) - itDb "can can handle joins on records with Nothing" $ do + itDb "can handle joins on records with Nothing" $ do setup records <- select $ do from @@ -304,7 +437,7 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) } )) -> True - _ -> True) + _ -> False) itDb "can left join on nested records" $ do setup @@ -325,7 +458,7 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) } })) -> True - _ -> True) + _ -> False) itDb "can handle multiple left joins on the same record" $ do setup @@ -344,7 +477,7 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) } })) -> True - _ -> True) + _ -> False) liftIO $ sortedRecords !! 1 `shouldSatisfy` (\case (_ :& _ :& Just (MyNestedRecord {myRecord = MyRecord {myName = "Rebecca", myAddress = Nothing}})) -> True diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 7c6ffc8f5..1d886c9e1 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -88,6 +88,7 @@ import qualified UnliftIO.Resource as R import Common.Record (testDeriveEsqueletoRecord) import Common.Test.Select +import qualified Common.Test.CTE as CTESpec -- Test schema -- | this could be achieved with S.fromList, but not all lists @@ -877,16 +878,6 @@ testSelectWhere = describe "select where_" $ do return p asserting $ ret `shouldBe` [ p1e ] - itDb "works for a simple example with (>.) and not_ [uses just . val]" $ do - _ <- insert' p1 - _ <- insert' p2 - p3e <- insert' p3 - ret <- select $ do - p <- from $ table @Person - where_ (not_ $ p ^. PersonAge >. just (val 17)) - return p - asserting $ ret `shouldBe` [ p3e ] - describe "when using between" $ do itDb "works for a simple example with [uses just . val]" $ do p1e <- insert' p1 @@ -919,6 +910,51 @@ testSelectWhere = describe "select where_" $ do , val $ PointKey 5 6 ) asserting $ ret `shouldBe` [()] + describe "when using not_" $ do + itDb "works for a single expression" $ do + ret <- + select $ + pure $ not_ $ val True + asserting $ do + ret `shouldBe` [Value False] + + itDb "works for a simple example with (>.) [uses just . val]" $ do + _ <- insert' p1 + _ <- insert' p2 + p3e <- insert' p3 + ret <- select $ + from $ \p -> do + where_ (not_ $ p ^. PersonAge >. just (val 17)) + return p + asserting $ ret `shouldBe` [ p3e ] + itDb "works with (==.) and (||.)" $ do + _ <- insert' p1 + _ <- insert' p2 + p3e <- insert' p3 + ret <- select $ + from $ \p -> do + where_ (not_ $ p ^. PersonName ==. val "John" ||. p ^. PersonName ==. val "Rachel") + return p + asserting $ ret `shouldBe` [ p3e ] + itDb "works with (>.), (<.) and (&&.) [uses just . val]" $ do + p1e <- insert' p1 + _ <- insert' p2 + _ <- insert' p3 + ret <- select $ + from $ \p -> do + where_ (not_ $ (p ^. PersonAge >. just (val 10)) &&. (p ^. PersonAge <. just (val 30))) + return p + asserting $ ret `shouldBe` [ p1e ] + itDb "works with between [uses just . val]" $ do + _ <- insert' p1 + _ <- insert' p2 + p3e <- insert' p3 + ret <- select $ + from $ \p -> do + where_ (not_ $ (p ^. PersonAge) `between` (just $ val 20, just $ val 40)) + return p + asserting $ ret `shouldBe` [ p3e ] + itDb "works with avg_" $ do _ <- insert' p1 _ <- insert' p2 @@ -1816,6 +1852,7 @@ tests = testLocking testOverloadedRecordDot testDeriveEsqueletoRecord + CTESpec.testCTE insert' :: ( Functor m , BaseBackend backend ~ PersistEntityBackend val diff --git a/test/Common/Test/CTE.hs b/test/Common/Test/CTE.hs new file mode 100644 index 000000000..7243a5662 --- /dev/null +++ b/test/Common/Test/CTE.hs @@ -0,0 +1,35 @@ +{-# language TypeApplications #-} + +module Common.Test.CTE where + +import Common.Test.Models +import Common.Test.Import +import Database.Persist.TH + +testCTE :: SpecDb +testCTE = describe "CTE" $ do + itDb "can refer to the same CTE twice" $ do + let q :: SqlQuery (SqlExpr (Value Int), SqlExpr (Value Int)) + q = do + bCte <- with $ do + b <- from $ table @B + pure b + + a :& b1 :& b2 <- from $ + table @A + `innerJoin` bCte + `on` do + \(a :& b) -> + a ^. AK ==. b ^. BK + `innerJoin` bCte + `on` do + \(a :& _ :& b2) -> + a ^. AK ==. b2 ^. BK + pure (a ^. AK, a ^. AV +. b1 ^. BV +. b2 ^. BV) + insert_ $ A { aK = 1, aV = 2 } + insert_ $ B { bK = 1, bV = 3 } + ret <- select q + asserting $ do + ret `shouldMatchList` + [ (Value 1, Value (2 + 3 + 3)) + ] diff --git a/test/Common/Test/Models.hs b/test/Common/Test/Models.hs index fb29de769..7ee3285bc 100644 --- a/test/Common/Test/Models.hs +++ b/test/Common/Test/Models.hs @@ -182,6 +182,16 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| address String deriving Show deriving Eq + + A + k Int + v Int + Primary k + + B + k Int + v Int + Primary k |] -- Unique Test schema diff --git a/test/MySQL/Test.hs b/test/MySQL/Test.hs index 3d8be3e3c..64d9c574a 100644 --- a/test/MySQL/Test.hs +++ b/test/MySQL/Test.hs @@ -29,6 +29,8 @@ import Database.Persist.MySQL import Test.Hspec import Common.Test +import Data.Maybe (fromMaybe) +import System.Environment (lookupEnv) testMysqlSum :: SpecDb testMysqlSum = do @@ -184,6 +186,7 @@ migrateIt = do mkConnectionPool :: IO ConnectionPool mkConnectionPool = do ci <- isCI + mysqlHost <- (fromMaybe "localhost" <$> lookupEnv "MYSQL_HOST") let connInfo | ci = defaultConnectInfo @@ -195,7 +198,7 @@ mkConnectionPool = do } | otherwise = defaultConnectInfo - { connectHost = "localhost" + { connectHost = mysqlHost , connectUser = "travis" , connectPassword = "esqutest" , connectDatabase = "esqutest" diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 5e3d18a73..3d26b2807 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -38,7 +38,8 @@ import Data.Time import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) import Database.Esqueleto hiding (random_) import qualified Database.Esqueleto.Internal.Internal as ES -import Database.Esqueleto.PostgreSQL (random_, (%.)) +import Database.Esqueleto.PostgreSQL + (random_, withMaterialized, withNotMaterialized, (%.)) import qualified Database.Esqueleto.PostgreSQL as EP import Database.Esqueleto.PostgreSQL.JSON hiding ((-.), (?.), (||.)) import qualified Database.Esqueleto.PostgreSQL.JSON as JSON @@ -1260,6 +1261,80 @@ testCommonTableExpressions = do pure res asserting $ vals `shouldBe` fmap Value [2..11] + describe "MATERIALIZED CTEs" $ do + describe "withNotMaterialized" $ do + itDb "successfully executes query" $ do + void $ select $ do + limitedLordsCte <- + withNotMaterialized $ do + lords <- Experimental.from $ Experimental.table @Lord + limit 10 + pure lords + lords <- Experimental.from limitedLordsCte + orderBy [asc $ lords ^. LordId] + pure lords + + asserting noExceptions + + itDb "generates the expected SQL" $ do + (sql, _) <- showQuery ES.SELECT $ do + limitedLordsCte <- + withNotMaterialized $ do + lords <- Experimental.from $ Experimental.table @Lord + limit 10 + pure lords + lords <- Experimental.from limitedLordsCte + orderBy [asc $ lords ^. LordId] + pure lords + + asserting $ sql `shouldBe` T.unlines + [ "WITH \"cte\" AS NOT MATERIALIZED (SELECT \"Lord\".\"county\" AS \"v_county\", \"Lord\".\"dogs\" AS \"v_dogs\"" + , "FROM \"Lord\"" + , " LIMIT 10" + , ")" + , "SELECT \"cte\".\"v_county\", \"cte\".\"v_dogs\"" + , "FROM \"cte\"" + , "ORDER BY \"cte\".\"v_county\" ASC" + ] + asserting noExceptions + + + describe "withMaterialized" $ do + itDb "generates the expected SQL" $ do + (sql, _) <- showQuery ES.SELECT $ do + limitedLordsCte <- + withMaterialized $ do + lords <- Experimental.from $ Experimental.table @Lord + limit 10 + pure lords + lords <- Experimental.from limitedLordsCte + orderBy [asc $ lords ^. LordId] + pure lords + + asserting $ sql `shouldBe` T.unlines + [ "WITH \"cte\" AS MATERIALIZED (SELECT \"Lord\".\"county\" AS \"v_county\", \"Lord\".\"dogs\" AS \"v_dogs\"" + , "FROM \"Lord\"" + , " LIMIT 10" + , ")" + , "SELECT \"cte\".\"v_county\", \"cte\".\"v_dogs\"" + , "FROM \"cte\"" + , "ORDER BY \"cte\".\"v_county\" ASC" + ] + asserting noExceptions + + itDb "successfully executes query" $ do + void $ select $ do + limitedLordsCte <- + withMaterialized $ do + lords <- Experimental.from $ Experimental.table @Lord + limit 10 + pure lords + lords <- Experimental.from limitedLordsCte + orderBy [asc $ lords ^. LordId] + pure lords + + asserting noExceptions + testPostgresqlLocking :: SpecDb testPostgresqlLocking = do describe "Monoid instance" $ do @@ -1271,7 +1346,9 @@ testPostgresqlLocking = do p <- from $ table @Person EP.forUpdateOf p EP.skipLocked EP.forUpdateOf p EP.skipLocked + EP.forNoKeyUpdateOf p EP.skipLocked EP.forShareOf p EP.skipLocked + EP.forKeyShareOf p EP.skipLocked conn <- ask let res1 = toText conn multipleLockingQuery resExpected = @@ -1281,7 +1358,9 @@ testPostgresqlLocking = do ,"FROM \"Person\"" ,"FOR UPDATE OF \"Person\" SKIP LOCKED" ,"FOR UPDATE OF \"Person\" SKIP LOCKED" + ,"FOR NO KEY UPDATE OF \"Person\" SKIP LOCKED" ,"FOR SHARE OF \"Person\" SKIP LOCKED" + ,"FOR KEY SHARE OF \"Person\" SKIP LOCKED" ] asserting $ res1 `shouldBe` resExpected @@ -1374,7 +1453,6 @@ testPostgresqlLocking = do EP.forUpdateOf p EP.skipLocked return p - liftIO $ print nonLockedRowsSpecifiedTable pure $ length nonLockedRowsSpecifiedTable `shouldBe` 2 withAsync sideThread $ \sideThreadAsync -> do @@ -1396,7 +1474,6 @@ testPostgresqlLocking = do EP.forUpdateOf p EP.skipLocked return p - liftIO $ print nonLockedRowsAfterUpdate asserting sideThreadAsserts asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3 @@ -1797,6 +1874,54 @@ testSubselectAliasingBehavior = do pure (str, val @Int 1) asserting noExceptions +testPostgresqlNullsOrdering :: SpecDb +testPostgresqlNullsOrdering = do + describe "Postgresql NULLS orderings work" $ do + itDb "ASC NULLS FIRST works" $ do + p1e <- insert' p1 + p2e <- insert' p2 -- p2 has a null age + p3e <- insert' p3 + p4e <- insert' p4 + ret <- select $ + from $ \p -> do + orderBy [EP.ascNullsFirst (p ^. PersonAge), EP.ascNullsFirst (p ^. PersonFavNum)] + return p + -- nulls come first + asserting $ ret `shouldBe` [ p2e, p3e, p4e, p1e ] + itDb "ASC NULLS LAST works" $ do + p1e <- insert' p1 + p2e <- insert' p2 -- p2 has a null age + p3e <- insert' p3 + p4e <- insert' p4 + ret <- select $ + from $ \p -> do + orderBy [EP.ascNullsLast (p ^. PersonAge), EP.ascNullsLast (p ^. PersonFavNum)] + return p + -- nulls come last + asserting $ ret `shouldBe` [ p3e, p4e, p1e, p2e ] + itDb "DESC NULLS FIRST works" $ do + p1e <- insert' p1 + p2e <- insert' p2 -- p2 has a null age + p3e <- insert' p3 + p4e <- insert' p4 + ret <- select $ + from $ \p -> do + orderBy [EP.descNullsFirst (p ^. PersonAge), EP.descNullsFirst (p ^. PersonFavNum)] + return p + -- nulls come first + asserting $ ret `shouldBe` [ p2e, p1e, p4e, p3e ] + itDb "DESC NULLS LAST works" $ do + p1e <- insert' p1 + p2e <- insert' p2 -- p2 has a null age + p3e <- insert' p3 + p4e <- insert' p4 + ret <- select $ + from $ \p -> do + orderBy [EP.descNullsLast (p ^. PersonAge), EP.descNullsLast (p ^. PersonFavNum)] + return p + -- nulls come last + asserting $ ret `shouldBe` [ p1e, p4e, p3e, p2e ] + type JSONValue = Maybe (JSONB A.Value) createSaneSQL :: (PersistField a, MonadIO m) => SqlExpr (Value a) -> T.Text -> [PersistValue] -> SqlPersistT m () @@ -1894,6 +2019,7 @@ spec = beforeAll mkConnectionPool $ do testWindowFunctions testSubselectAliasingBehavior testPostgresqlLocking + testPostgresqlNullsOrdering insertJsonValues :: SqlPersistT IO () insertJsonValues = do diff --git a/test/docker-compose.yml b/test/docker-compose.yml new file mode 100644 index 000000000..6bea6e0ea --- /dev/null +++ b/test/docker-compose.yml @@ -0,0 +1,28 @@ +# docker-compose file for running postgres and mysql DBMS + +# If using this to run the tests, +# while these containers are running (i.e. after something like) +# (cd test; docker-compose up -d) +# the tests must be told to use the hostname via MYSQL_HOST environment variable +# e.g. something like: +# MYSQL_HOST=127.0.0.1 stack test + +version: '3' +services: + postgres: + image: 'postgres:15.2-alpine' + environment: + POSTGRES_USER: esqutest + POSTGRES_PASSWORD: esqutest + POSTGRES_DB: esqutest + ports: + - 5432:5432 + mysql: + image: 'mysql:8.0.32' + environment: + MYSQL_USER: travis + MYSQL_PASSWORD: esqutest + MYSQL_ROOT_PASSWORD: esqutest + MYSQL_DATABASE: esqutest + ports: + - 3306:3306