From abc718af86e31980edf1be7d63a2d5ed40fb843e Mon Sep 17 00:00:00 2001 From: Daniel Mlot Date: Thu, 8 Jun 2023 12:49:15 -0300 Subject: [PATCH 01/37] Add missing just to left join examples in the Haddocks (#363) * Add just to a couple Haddock left join examples Fixes #307 * Also add just to the old syntax example * Update changelog.md for PR #363 --- changelog.md | 6 ++++++ esqueleto.cabal | 2 +- src/Database/Esqueleto/Experimental.hs | 8 ++++---- src/Database/Esqueleto/Experimental/From/Join.hs | 2 +- 4 files changed, 12 insertions(+), 6 deletions(-) diff --git a/changelog.md b/changelog.md index 642bb288e..d014ed2e0 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +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..b9f3edb4b 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.5.9.0 +version: 3.5.9.1 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. . diff --git a/src/Database/Esqueleto/Experimental.hs b/src/Database/Esqueleto/Experimental.hs index 607473505..15e21585d 100644 --- a/src/Database/Esqueleto/Experimental.hs +++ b/src/Database/Esqueleto/Experimental.hs @@ -339,8 +339,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 +354,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/Join.hs b/src/Database/Esqueleto/Experimental/From/Join.hs index 6a4122aa9..f86e771fb 100644 --- a/src/Database/Esqueleto/Experimental/From/Join.hs +++ b/src/Database/Esqueleto/Experimental/From/Join.hs @@ -230,7 +230,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 From 494fe5ddfe20ae7eacf5a81018a736e0409ab565 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Thu, 8 Jun 2023 10:34:55 -0600 Subject: [PATCH 02/37] Name conflict dodges (#365) * Name conflict dodges * Add changelog link * whoops lmao --- changelog.md | 8 ++++++++ esqueleto.cabal | 2 +- src/Database/Esqueleto/Experimental.hs | 2 ++ src/Database/Esqueleto/Internal/Internal.hs | 14 ++++++++++++++ 4 files changed, 25 insertions(+), 1 deletion(-) diff --git a/changelog.md b/changelog.md index d014ed2e0..1e3e98004 100644 --- a/changelog.md +++ b/changelog.md @@ -1,9 +1,17 @@ +3.5.10.0 +======== +- @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 b9f3edb4b..f15f3b5e0 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.5.9.1 +version: 3.5.10.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. . diff --git a/src/Database/Esqueleto/Experimental.hs b/src/Database/Esqueleto/Experimental.hs index 15e21585d..5caffd403 100644 --- a/src/Database/Esqueleto/Experimental.hs +++ b/src/Database/Esqueleto/Experimental.hs @@ -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 diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 2690ea15b..3cd8c80b8 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -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 @@ -660,6 +667,13 @@ isNothing v = isNullExpr :: (TLB.Builder, a) -> (TLB.Builder, a) isNullExpr = first ((<> " IS NULL")) +-- | An alias for 'isNothing' that avoids clashing with the function from +-- "Data.Maybe" 'Data.Maybe.isNothing'. +-- +-- @since 3.5.10.0 +isNothing_ :: PersistField typ => SqlExpr (Value (Maybe typ)) -> SqlExpr (Value Bool) +isNothing_ = isNothing + -- | Analogous to 'Just', promotes a value of type @typ@ into -- one of type @Maybe typ@. It should hold that @'val' . Just -- === just . 'val'@. From 6f884d804c0e5ce3dab28ccd24a704eca3d0000d Mon Sep 17 00:00:00 2001 From: Isaac van Bakel Date: Thu, 8 Jun 2023 18:35:50 +0200 Subject: [PATCH 03/37] Add `ToAlias`, `ToAliasReference` for <=16-tuples (#328) * Add `ToAlias`, `ToAliasReference` for <=16-tuples This adds a `ToAlias` and `ToAliasReference` instance for every tuple size from 9 to 16. These tuple sizes are supported elsewhere, but those typeclasses only had instances for tuples up to size 8. This also adds `from*` functions for tuples of size 9-16, which didn't exist before. * Add to changelog, bump version for #328 --------- Co-authored-by: Matt Parsons --- changelog.md | 6 +- .../Esqueleto/Experimental/ToAlias.hs | 124 ++++++++++++++++++ .../Experimental/ToAliasReference.hs | 123 +++++++++++++++++ src/Database/Esqueleto/Internal/Internal.hs | 18 +++ 4 files changed, 270 insertions(+), 1 deletion(-) diff --git a/changelog.md b/changelog.md index 1e3e98004..c7c404c93 100644 --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,9 @@ 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 diff --git a/src/Database/Esqueleto/Experimental/ToAlias.hs b/src/Database/Esqueleto/Experimental/ToAlias.hs index b6ab99193..1756fe6bf 100644 --- a/src/Database/Esqueleto/Experimental/ToAlias.hs +++ b/src/Database/Esqueleto/Experimental/ToAlias.hs @@ -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..1f4003b8e 100644 --- a/src/Database/Esqueleto/Experimental/ToAliasReference.hs +++ b/src/Database/Esqueleto/Experimental/ToAliasReference.hs @@ -88,3 +88,126 @@ instance ( ToAliasReference a ) => ToAliasReference (a,b,c,d,e,f,g,h) where toAliasReference ident x = to8 <$> (toAliasReference ident $ from8 x) +instance ( ToAliasReference a + , ToAliasReference b + , ToAliasReference c + , ToAliasReference d + , ToAliasReference e + , ToAliasReference f + , ToAliasReference g + , ToAliasReference h + , ToAliasReference i + ) => ToAliasReference (a,b,c,d,e,f,g,h,i) where + toAliasReference ident x = to9 <$> (toAliasReference ident $ from9 x) + +instance ( ToAliasReference a + , ToAliasReference b + , ToAliasReference c + , ToAliasReference d + , ToAliasReference e + , ToAliasReference f + , ToAliasReference g + , ToAliasReference h + , ToAliasReference i + , ToAliasReference j + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j) where + toAliasReference ident x = to10 <$> (toAliasReference ident $ from10 x) + +instance ( ToAliasReference a + , ToAliasReference b + , ToAliasReference c + , ToAliasReference d + , ToAliasReference e + , ToAliasReference f + , ToAliasReference g + , ToAliasReference h + , ToAliasReference i + , ToAliasReference j + , ToAliasReference k + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k) where + toAliasReference ident x = to11 <$> (toAliasReference ident $ from11 x) + +instance ( ToAliasReference a + , ToAliasReference b + , ToAliasReference c + , ToAliasReference d + , ToAliasReference e + , ToAliasReference f + , ToAliasReference g + , ToAliasReference h + , ToAliasReference i + , ToAliasReference j + , ToAliasReference k + , ToAliasReference l + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l) where + toAliasReference ident x = to12 <$> (toAliasReference ident $ from12 x) + +instance ( ToAliasReference a + , ToAliasReference b + , ToAliasReference c + , ToAliasReference d + , ToAliasReference e + , ToAliasReference f + , ToAliasReference g + , ToAliasReference h + , ToAliasReference i + , ToAliasReference j + , ToAliasReference k + , ToAliasReference l + , ToAliasReference m + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m) where + toAliasReference ident x = to13 <$> (toAliasReference ident $ from13 x) + +instance ( ToAliasReference a + , ToAliasReference b + , ToAliasReference c + , ToAliasReference d + , ToAliasReference e + , ToAliasReference f + , ToAliasReference g + , ToAliasReference h + , ToAliasReference i + , ToAliasReference j + , ToAliasReference k + , ToAliasReference l + , ToAliasReference m + , ToAliasReference n + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where + toAliasReference ident x = to14 <$> (toAliasReference ident $ from14 x) + +instance ( ToAliasReference a + , ToAliasReference b + , ToAliasReference c + , ToAliasReference d + , ToAliasReference e + , ToAliasReference f + , ToAliasReference g + , ToAliasReference h + , ToAliasReference i + , ToAliasReference j + , ToAliasReference k + , ToAliasReference l + , ToAliasReference m + , ToAliasReference n + , ToAliasReference o + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where + toAliasReference ident x = to15 <$> (toAliasReference ident $ from15 x) + +instance ( ToAliasReference a + , ToAliasReference b + , ToAliasReference c + , ToAliasReference d + , ToAliasReference e + , ToAliasReference f + , ToAliasReference g + , ToAliasReference h + , ToAliasReference i + , ToAliasReference j + , ToAliasReference k + , ToAliasReference l + , ToAliasReference m + , ToAliasReference n + , ToAliasReference o + , ToAliasReference p + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where + toAliasReference ident x = to16 <$> (toAliasReference ident $ from16 x) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 3cd8c80b8..9810c84b0 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -3694,6 +3694,9 @@ instance ( SqlSelect a ra 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) @@ -3731,6 +3734,9 @@ instance ( SqlSelect a ra 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) @@ -3770,6 +3776,9 @@ instance ( SqlSelect a ra 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) @@ -3811,6 +3820,9 @@ instance ( SqlSelect a ra 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) @@ -3854,6 +3866,9 @@ instance ( SqlSelect a ra 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) @@ -3899,6 +3914,9 @@ instance ( SqlSelect a ra 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) From b782593c2cbcdf7fb05dbeccb45cb54f3684508c Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Mon, 31 Jul 2023 13:12:07 -0400 Subject: [PATCH 04/37] Fix `myAge` type in `deriveEsqueletoRecord` documentation (#369) * Fix `myAge` type in `deriveEsqueletoRecord` documentation I wrote down the wrong type for some reason, stripping a `Maybe`. * Bump version 3.5.10.0 -> 3.5.10.1 --- changelog.md | 8 +++++++- esqueleto.cabal | 2 +- src/Database/Esqueleto/Record.hs | 6 +++--- 3 files changed, 11 insertions(+), 5 deletions(-) diff --git a/changelog.md b/changelog.md index c7c404c93..a70c9b7cc 100644 --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,11 @@ +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 diff --git a/esqueleto.cabal b/esqueleto.cabal index f15f3b5e0..3262eb58e 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.5.10.0 +version: 3.5.10.1 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. . diff --git a/src/Database/Esqueleto/Record.hs b/src/Database/Esqueleto/Record.hs index 27905acd6..12f4ef831 100644 --- a/src/Database/Esqueleto/Record.hs +++ b/src/Database/Esqueleto/Record.hs @@ -57,7 +57,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 +75,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 +85,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 From e50fed1ddb2f3a6d5f148c5f9148a58517c9d4a8 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Tue, 29 Aug 2023 06:58:20 -0600 Subject: [PATCH 05/37] Newlines between query chunks (#376) * Newlines between query chunks * Fix whitespace newline issues * changelog, cabal, new ghcs * ok * lmao * uhhh --- .github/workflows/haskell.yml | 6 +++--- changelog.md | 13 +++++++++++++ esqueleto.cabal | 2 +- src/Database/Esqueleto/Internal/Internal.hs | 16 +++++++++++++--- test/Common/Test.hs | 8 +++++--- 5 files changed, 35 insertions(+), 10 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 642759783..ffcb2be49 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.8.1.0"] + ghc: ["8.6.5", "8.8.4", "8.10.4", "9.0.2", "9.2.2", "9.4.5", "9.6.2"] 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/changelog.md b/changelog.md index a70c9b7cc..193b5e7f9 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,16 @@ +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 diff --git a/esqueleto.cabal b/esqueleto.cabal index 3262eb58e..d8802dc7f 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.5.10.1 +version: 3.5.10.2 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. . diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 9810c84b0..4707048e8 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -2963,6 +2963,15 @@ toRawSql mode (conn, firstIdentState) query = 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 @@ -2978,7 +2987,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 @@ -2992,6 +3001,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. -- @@ -3213,11 +3223,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) diff --git a/test/Common/Test.hs b/test/Common/Test.hs index e08584b91..b74850143 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -1652,9 +1652,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" From d805bb0b2ff9ccbe8689729a75b1f6903e0ef671 Mon Sep 17 00:00:00 2001 From: Thomas Tuegel Date: Thu, 7 Sep 2023 12:19:54 -0500 Subject: [PATCH 06/37] Fix Postgres syntax for NOWAIT (#377) * Fix Postgres syntax for NOWAIT * Add noWait test for PostgreSQL * Bump version --- changelog.md | 6 ++++++ esqueleto.cabal | 2 +- src/Database/Esqueleto/Internal/Internal.hs | 2 +- src/Database/Esqueleto/PostgreSQL.hs | 2 +- test/PostgreSQL/Test.hs | 9 +++++++++ 5 files changed, 18 insertions(+), 3 deletions(-) diff --git a/changelog.md b/changelog.md index 193b5e7f9..c57d35806 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +3.5.10.3 +======== +- @ttuegel + - [#377](https://github.com/bitemyapp/esqueleto/pull/377) + - Fix Postgres syntax for `noWait` + 3.5.10.2 ======== - @parsonsmatt diff --git a/esqueleto.cabal b/esqueleto.cabal index d8802dc7f..0e9b983b0 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.5.10.2 +version: 3.5.10.3 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. . diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 4707048e8..e46516e30 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -3257,7 +3257,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 "" diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 11197b064..3011741b4 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -441,7 +441,7 @@ values exprs = Ex.From $ do , params ) --- | `NO WAIT` syntax for postgres locking +-- | `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/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 3ff87a1da..9e144e2be 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -1423,6 +1423,15 @@ testPostgresqlLocking = do asserting sideThreadAsserts asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3 + describe "noWait" $ do + itDb "doesn't crash" $ do + select $ do + t <- Experimental.from $ table @Person + EP.forUpdateOf t EP.noWait + pure t + + asserting noExceptions + -- Since lateral queries arent supported in Sqlite or older versions of mysql -- the test is in the Postgres module testLateralQuery :: SpecDb From bd334982bd6d544e95fb11b24d8fbdfe40312a59 Mon Sep 17 00:00:00 2001 From: Daan Rijks Date: Wed, 4 Oct 2023 20:38:58 +0200 Subject: [PATCH 07/37] README.md: Fix missing words (#380) Closes #374 --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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. From a69ce68076bad47a80b265d3d82b6011e0ae2ba6 Mon Sep 17 00:00:00 2001 From: Matthew Mongeau Date: Wed, 25 Oct 2023 02:52:18 +0900 Subject: [PATCH 08/37] Generate `ToMaybe` in `deriveEsqueletoRecord` (#378) * work * Implement ToMaybe instances for SqlRecord * Guard OverloadedRecordDot with CPP pragma * Better formatting for record spec for GHC <9.0.2 * DoE constructor * Update changelog * Test multiple left joins on the same record * Switch left join values * More descript in changelog * Avoid OverloadedRecordDot Usage in Record Specs * Try quick 8.6.5 fix * Another 8.6.5 attempt * Update src/Database/Esqueleto/Record.hs --------- Co-authored-by: Rebecca Turner Co-authored-by: Matt von Hagen --- changelog.md | 7 + esqueleto.cabal | 2 +- src/Database/Esqueleto/Record.hs | 307 +++++++++++++++++++++++++++++++ test/Common/Record.hs | 115 +++++++++++- 4 files changed, 423 insertions(+), 8 deletions(-) diff --git a/changelog.md b/changelog.md index c57d35806..d7ef5ca34 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,10 @@ +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 diff --git a/esqueleto.cabal b/esqueleto.cabal index 0e9b983b0..dfeda1f75 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.5.10.3 +version: 3.5.11.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. . diff --git a/src/Database/Esqueleto/Record.hs b/src/Database/Esqueleto/Record.hs index 12f4ef831..444ab9890 100644 --- a/src/Database/Esqueleto/Record.hs +++ b/src/Database/Esqueleto/Record.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -13,6 +15,8 @@ module Database.Esqueleto.Record , DeriveEsqueletoRecordSettings(..) , defaultDeriveEsqueletoRecordSettings + , takeColumns + , takeMaybeColumns ) where import Control.Monad.Trans.State.Strict (StateT(..), evalStateT) @@ -20,6 +24,7 @@ import Data.Proxy (Proxy(..)) import Database.Esqueleto.Experimental (Entity, PersistValue, SqlExpr, Value(..), (:&)(..)) import Database.Esqueleto.Experimental.ToAlias (ToAlias(..)) +import Database.Esqueleto.Experimental.ToMaybe (ToMaybe(..)) import Database.Esqueleto.Experimental.ToAliasReference (ToAliasReference(..)) import Database.Esqueleto.Internal.Internal (SqlSelect(..)) import Language.Haskell.TH @@ -130,11 +135,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 +163,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,11 +185,17 @@ 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 , sqlSelectInstanceDec + , sqlMaybeRecordDec + , toMaybeInstanceDec + , sqlMaybeRecordSelectInstanceDec , toAliasInstanceDec , toAliasReferenceInstanceDec ] @@ -185,6 +208,8 @@ 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 @@ -200,12 +225,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 +258,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 +276,19 @@ getRecordInfo settings name = do sqlTy <- sqlFieldType ty pure (modifier fieldName', sqlTy) + toSqlMaybeField (fieldName', ty) = do + let modifier = mkName . sqlMaybeFieldModifier settings . nameBase + sqlTy <- sqlMaybeFieldType ty + pure (modifier fieldName', sqlTy) + -- | Create a new name by prefixing @Sql@ to a given name. makeSqlName :: DeriveEsqueletoRecordSettings -> Name -> Name makeSqlName settings name = mkName $ sqlNameModifier settings $ nameBase name +-- | Create a new name by prefixing @SqlMaybe@ to a given name. +makeSqlMaybeName :: DeriveEsqueletoRecordSettings -> Name -> Name +makeSqlMaybeName settings name = mkName $ sqlMaybeNameModifier settings $ nameBase name + -- | Transforms a record field type into a corresponding `SqlExpr` type. -- -- * @'Entity' x@ is transformed into @'SqlExpr' ('Entity' x)@. @@ -275,6 +317,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 @@ -652,3 +728,234 @@ 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` 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 [sqlSelectColsDec', sqlSelectColCountDec', sqlSelectProcessRowDec'] + +-- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance. +sqlMaybeSelectColsDec :: RecordInfo -> Q Dec +sqlMaybeSelectColsDec RecordInfo {..} = do + -- Pairs of record field names and local variable names. + fieldNames <- forM sqlMaybeFields (\(name', _type) -> do + var <- newName $ nameBase name' + pure (name', var)) + + -- Patterns binding record fields to local variables. + let fieldPatterns :: [FieldPat] + fieldPatterns = [(name', VarP var) | (name', var) <- fieldNames] + + -- Local variables for fields joined with `:&` in a single expression. + joinedFields :: Exp + joinedFields = + case snd `map` fieldNames of + [] -> TupE [] + [f1] -> VarE f1 + f1 : rest -> + let helper lhs field = + InfixE + (Just lhs) + (ConE '(:&)) + (Just $ VarE field) + in foldl' helper (VarE f1) rest + + identInfo <- newName "identInfo" + -- 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 = 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)) _)) -> (AppE (VarE 'unValue)) + (AppT (ConT ((==) ''SqlExpr -> True)) (AppT (ConT ((==) ''Entity -> True)) _)) -> id + (AppT (ConT ((==) ''SqlExpr -> True)) (AppT (ConT ((==) ''Maybe -> True)) _)) -> (AppE (VarE 'pure)) + (ConT _) -> id + _ -> error $ show x + + fieldNames <- forM sqlFields (\(name', typ) -> do + var <- newName $ nameBase name' + pure (name', var, sqlOp typ (VarE var))) + + let + joinedFields = + case (\(_,x,_) -> x) `map` fieldNames of + [] -> TupP [] + [f1] -> VarP f1 + f1 : rest -> + let helper lhs field = + InfixP + lhs + '(:&) + (VarP field) + in foldl' helper (VarP f1) rest + + + colsName <- newName "columns" + + let +#if MIN_VERSION_template_haskell(2,17,0) + bodyExp = DoE Nothing +#else + bodyExp = DoE +#endif + [ BindS joinedFields (AppE (VarE 'sqlSelectProcessRow) (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 + [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 target + Right (value, other) + else Left "Insufficient columns when trying to parse a column") diff --git a/test/Common/Record.hs b/test/Common/Record.hs index 5cb1599ed..cac586793 100644 --- a/test/Common/Record.hs +++ b/test/Common/Record.hs @@ -14,20 +14,29 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- Tests for `Database.Esqueleto.Record`. module Common.Record (testDeriveEsqueletoRecord) where import Common.Test.Import hiding (from, on) +import Control.Monad.Trans.State.Strict (StateT(..), evalStateT) +import Data.Bifunctor (first) import Data.List (sortOn) +import Data.Maybe (catMaybes) +import Data.Proxy (Proxy(..)) import Database.Esqueleto.Experimental -import Database.Esqueleto.Record - ( DeriveEsqueletoRecordSettings(..) - , defaultDeriveEsqueletoRecordSettings - , deriveEsqueletoRecord - , deriveEsqueletoRecordWith - ) +import Database.Esqueleto.Internal.Internal (SqlSelect(..)) +import Database.Esqueleto.Record ( + DeriveEsqueletoRecordSettings(..), + defaultDeriveEsqueletoRecordSettings, + deriveEsqueletoRecord, + deriveEsqueletoRecordWith, + takeColumns, + takeMaybeColumns, + ) +import GHC.Records data MyRecord = MyRecord @@ -112,6 +121,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 +226,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 +252,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) From f689e2261a8cf1e887f9bc984ccee1320387a4ce Mon Sep 17 00:00:00 2001 From: "Matt von Hagen (Parsons)" Date: Tue, 2 Jan 2024 16:46:43 -0700 Subject: [PATCH 09/37] Version bump for text (#384) --- esqueleto.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/esqueleto.cabal b/esqueleto.cabal index dfeda1f75..865b72326 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.5.11.0 +version: 3.5.11.1 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. . @@ -65,7 +65,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 From 30a5e80736391e2aa45094f681d4bd329aa16707 Mon Sep 17 00:00:00 2001 From: arguri <65528566+arguri@users.noreply.github.com> Date: Fri, 9 Feb 2024 19:44:34 +0100 Subject: [PATCH 10/37] fix build for ghc 9.8.1 (#386) (#387) * fix build for ghc 9.8.1 (#386) * add information to changelog, fix some formatting and versioning (#386) * move info in changelog to a different section, add ghc 9.8.1 to github workflows (#386) * Apply suggestions from code review --------- Co-authored-by: Christian Berg Co-authored-by: Matt von Hagen (Parsons) --- .github/workflows/haskell.yml | 4 ++-- changelog.md | 6 ++++++ esqueleto.cabal | 2 +- src/Database/Esqueleto/Record.hs | 4 +++- 4 files changed, 12 insertions(+), 4 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index ffcb2be49..8f4e14e87 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -32,8 +32,8 @@ jobs: --health-retries=3 strategy: matrix: - cabal: ["3.8.1.0"] - ghc: ["8.6.5", "8.8.4", "8.10.4", "9.0.2", "9.2.2", "9.4.5", "9.6.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: diff --git a/changelog.md b/changelog.md index d7ef5ca34..1cf09376b 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +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 diff --git a/esqueleto.cabal b/esqueleto.cabal index 865b72326..44ff6fef3 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.5.11.1 +version: 3.5.11.2 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. . diff --git a/src/Database/Esqueleto/Record.hs b/src/Database/Esqueleto/Record.hs index 444ab9890..7bea76564 100644 --- a/src/Database/Esqueleto/Record.hs +++ b/src/Database/Esqueleto/Record.hs @@ -214,7 +214,9 @@ data RecordInfo = RecordInfo -- 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] From eb719e712db46786406697734986be20c26c7962 Mon Sep 17 00:00:00 2001 From: Cameron Samak Date: Thu, 17 Oct 2024 09:17:47 -0700 Subject: [PATCH 11/37] Add dependencies to nix packages in stack.yaml (#403) --- stack-8.10.yaml | 3 +++ stack-8.2.yaml | 3 +++ stack-8.4.yaml | 3 +++ stack-8.6.yaml | 3 +++ stack-8.8.yaml | 3 +++ stack-9.0.yaml | 3 +++ stack-nightly.yaml | 3 +++ 7 files changed, 21 insertions(+) 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] From 603e08346f1f247a91ef129b0ee8b15b58f4402b Mon Sep 17 00:00:00 2001 From: Cameron Samak Date: Thu, 17 Oct 2024 14:48:43 -0700 Subject: [PATCH 12/37] Fix some shouldSatisfy predicates that were always True (#404) * Add dependencies to nix packages in stack.yaml * Fix some shouldSatisfy predicates that were always True --- test/Common/Record.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test/Common/Record.hs b/test/Common/Record.hs index cac586793..cf92b5690 100644 --- a/test/Common/Record.hs +++ b/test/Common/Record.hs @@ -271,7 +271,7 @@ 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 setup @@ -291,7 +291,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 @@ -312,7 +312,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 @@ -331,7 +331,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 From d5df11834405b871987ab6c4e0a874514c9a8ce3 Mon Sep 17 00:00:00 2001 From: Cameron Samak Date: Tue, 22 Oct 2024 15:11:58 -0700 Subject: [PATCH 13/37] Add support for nested Maybe records (#405) Required ToMaybe, ToAlias, ToAliasReference instances for SqlMaybes Also, required implementation changes to the sqlSelectProcessRow for SqlMaybes --- changelog.md | 7 ++ esqueleto.cabal | 2 +- src/Database/Esqueleto/Record.hs | 174 ++++++++++++++++++------------- test/Common/Record.hs | 154 ++++++++++++++++++++++++--- 4 files changed, 249 insertions(+), 88 deletions(-) diff --git a/changelog.md b/changelog.md index 1cf09376b..1f3dc1295 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,10 @@ +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 44ff6fef3..eb42d6c48 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.5.11.2 +version: 3.5.12.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. . diff --git a/src/Database/Esqueleto/Record.hs b/src/Database/Esqueleto/Record.hs index 7bea76564..cdc9913be 100644 --- a/src/Database/Esqueleto/Record.hs +++ b/src/Database/Esqueleto/Record.hs @@ -34,7 +34,7 @@ import Data.Text (Text) import Control.Monad (forM) import Data.Foldable (foldl') import GHC.Exts (IsString(fromString)) -import Data.Maybe (mapMaybe, fromMaybe, listToMaybe) +import 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 @@ -187,17 +187,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 [ recordDec , sqlSelectInstanceDec , sqlMaybeRecordDec , toMaybeInstanceDec + , sqlMaybeToMaybeInstanceDec , sqlMaybeRecordSelectInstanceDec , toAliasInstanceDec + , sqlMaybeToAliasInstanceDec , toAliasReferenceInstanceDec + , sqlMaybeToAliasReferenceInstanceDec ] -- | Information about a record we need to generate the declarations. @@ -646,19 +652,23 @@ nonRecordConstructorMessage con = (RecGadtC names _fields _ret) -> head names makeToAliasInstance :: RecordInfo -> Q Dec -makeToAliasInstance info@RecordInfo {..} = do - toAliasDec' <- toAliasDec info +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) + instanceType = (ConT ''ToAlias) `AppT` (ConT name) 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 @@ -673,35 +683,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 {..} = 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) + instanceType = (ConT ''ToAliasReference) `AppT` (ConT name) pure $ InstanceD overlap instanceConstraints instanceType [toAliasReferenceDec'] -toAliasReferenceDec :: RecordInfo -> Q Dec -toAliasReferenceDec RecordInfo {..} = do +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 @@ -717,14 +732,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. [] @@ -745,7 +760,7 @@ makeSqlMaybeRecord RecordInfo {..} = do -- | Generates a `ToMaybe` instance for the given record. makeToMaybeInstance :: RecordInfo -> Q Dec makeToMaybeInstance info@RecordInfo {..} = do - toMaybeTDec' <- toMaybeTDec info + toMaybeTDec' <- toMaybeTDec sqlName sqlMaybeName toMaybeDec' <- toMaybeDec info let overlap = Nothing instanceConstraints = [] @@ -753,10 +768,20 @@ makeToMaybeInstance info@RecordInfo {..} = do 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) +-- | Generates a `ToMaybe` instance for the SqlMaybe of the given record. +makeSqlMaybeToMaybeInstance :: RecordInfo -> Q Dec +makeSqlMaybeToMaybeInstance RecordInfo {..} = do + sqlMaybeToMaybeTDec' <- toMaybeTDec sqlMaybeName sqlMaybeName + let toMaybeIdDec = FunD 'toMaybe [ Clause [] (NormalB (VarE 'id)) []] + overlap = Nothing + instanceConstraints = [] + instanceType = (ConT ''ToMaybe) `AppT` (ConT sqlMaybeName) + pure $ InstanceD overlap instanceConstraints instanceType [sqlMaybeToMaybeTDec', toMaybeIdDec] + +-- | Generates a `type ToMaybeT ... = ...` declaration for the given names. +toMaybeTDec :: Name -> Name -> Q Dec +toMaybeTDec nameLeft nameRight = do + pure $ mkTySynInstD ''ToMaybeT (ConT nameLeft) (ConT nameRight) where mkTySynInstD className lhsArg rhs = #if MIN_VERSION_template_haskell(2,15,0) @@ -851,57 +876,28 @@ sqlMaybeSelectColsDec RecordInfo {..} = do ] -- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect` --- instance. +-- instance for a SqlMaybe. sqlMaybeSelectProcessRowDec :: RecordInfo -> Q Dec sqlMaybeSelectProcessRowDec RecordInfo {..} = do - let - sqlOp x = 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)) _)) -> (AppE (VarE 'unValue)) - (AppT (ConT ((==) ''SqlExpr -> True)) (AppT (ConT ((==) ''Entity -> True)) _)) -> id - (AppT (ConT ((==) ''SqlExpr -> True)) (AppT (ConT ((==) ''Maybe -> True)) _)) -> (AppE (VarE 'pure)) - (ConT _) -> id - _ -> error $ show x - - fieldNames <- forM sqlFields (\(name', typ) -> do - var <- newName $ nameBase name' - pure (name', var, sqlOp typ (VarE var))) - - let - joinedFields = - case (\(_,x,_) -> x) `map` fieldNames of - [] -> TupP [] - [f1] -> VarP f1 - f1 : rest -> - let helper lhs field = - InfixP - lhs - '(:&) - (VarP field) - in foldl' helper (VarP f1) rest - + -- See sqlSelectProcessRowDec, which is similar but does not have special handling for Maybe + (statements, fieldExps) <- + unzip <$> forM (zip fields sqlMaybeFields) (\((fieldName', fieldType), (_, sqlType')) -> do + valueName <- newName (nameBase fieldName') + pattern <- sqlSelectProcessRowPat fieldType valueName + pure + ( BindS + pattern + (AppTypeE (VarE 'takeColumns) sqlType') + , (valueName, wrapJust fieldType $ VarE valueName) + )) colsName <- newName "columns" + processName <- newName "process" - let -#if MIN_VERSION_template_haskell(2,17,0) - bodyExp = DoE Nothing -#else - bodyExp = DoE -#endif - [ BindS joinedFields (AppE (VarE 'sqlSelectProcessRow) (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 - ) - ] + bodyExp <- [e| + first (fromString ("Failed to parse " ++ $(lift $ nameBase sqlMaybeName) ++ ": ") <>) + (evalStateT $(varE processName) $(varE colsName)) + |] pure $ FunD @@ -909,8 +905,40 @@ sqlMaybeSelectProcessRowDec RecordInfo {..} = do [ Clause [VarP colsName] (NormalB bodyExp) - [] + -- `where` + [ ValD + (VarP processName) + (NormalB $ + DoE +#if MIN_VERSION_template_haskell(2,17,0) + Nothing +#endif + (statements ++ [ + NoBindS $ AppE (VarE 'pure) ( + CondE + (AppE + (VarE 'or) + (ListE $ fmap (\(n, _) -> AppE (VarE 'isJust) (VarE n)) fieldExps)) + (case snd <$> fieldExps of + [] -> ConE constructorName + x:xs -> foldl' + (\a b -> InfixE (Just a) (VarE '(<*>)) (Just b)) + (InfixE (Just $ ConE constructorName) (VarE '(<$>)) (Just x)) + xs) + (ConE 'Nothing) + ) + ] + ) + ) + [] + ] ] + where + wrapJust x = case x of + AppT (ConT ((==) ''Entity -> True)) _innerType -> id + ((ConT ((==) ''Maybe -> True)) `AppT` _inner) -> AppE (ConE 'Just) + (ConT _) -> id + _ -> error $ show x -- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance. sqlMaybeSelectColCountDec :: RecordInfo -> Q Dec diff --git a/test/Common/Record.hs b/test/Common/Record.hs index cf92b5690..7c36b1d80 100644 --- a/test/Common/Record.hs +++ b/test/Common/Record.hs @@ -21,21 +21,14 @@ 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 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 Database.Esqueleto.Record + ( DeriveEsqueletoRecordSettings(..) + , defaultDeriveEsqueletoRecordSettings + , deriveEsqueletoRecord + , deriveEsqueletoRecordWith + ) import GHC.Records data MyRecord = @@ -67,10 +60,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 @@ -89,6 +88,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 = @@ -198,6 +223,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 @@ -273,7 +399,7 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do )) -> 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 From ba43f657a3303ad9dcf2b92086fa11947423892b Mon Sep 17 00:00:00 2001 From: Aaron Cohn Date: Thu, 24 Oct 2024 07:21:37 -0700 Subject: [PATCH 14/37] add all postgres row-level locking options (#402) add FOR NO KEY UPDATE and FOR KEY SHARE --- changelog.md | 6 ++++++ esqueleto.cabal | 2 +- src/Database/Esqueleto/Internal/Internal.hs | 4 ++++ src/Database/Esqueleto/PostgreSQL.hs | 19 ++++++++++++++++++- test/PostgreSQL/Test.hs | 4 ++++ 5 files changed, 33 insertions(+), 2 deletions(-) diff --git a/changelog.md b/changelog.md index 1f3dc1295..6f4dd4674 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +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 diff --git a/esqueleto.cabal b/esqueleto.cabal index eb42d6c48..547741fff 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.5.12.0 +version: 3.5.13.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. . diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index e46516e30..fa9fc19b2 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -1485,7 +1485,9 @@ data PostgresLockingKind = -- Arranged in order of lock strength data PostgresRowLevelLockStrength = PostgresForUpdate + | PostgresForNoKeyUpdate | PostgresForShare + | PostgresForKeyShare deriving (Ord, Eq) data LockingOfClause where @@ -3254,7 +3256,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" diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 3011741b4..052594e81 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -31,7 +31,9 @@ module Database.Esqueleto.PostgreSQL , wait , skipLocked , forUpdateOf + , forNoKeyUpdateOf , forShareOf + , forKeyShareOf , filterWhere , values -- * Internal @@ -469,11 +471,26 @@ 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] diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 9e144e2be..583d89fcb 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -1243,7 +1243,9 @@ testPostgresqlLocking = do p <- Experimental.from $ table @Person EP.forUpdateOf p EP.skipLocked EP.forUpdateOf p EP.skipLocked + EP.forNoKeyUpdateOf p EP.skipLocked EP.forShareOf p EP.skipLocked + EP.forKeyShareOf p EP.skipLocked conn <- ask let res1 = toText conn multipleLockingQuery resExpected = @@ -1253,7 +1255,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 From 2b8f2cfd17849cba4769481bc53c80df37148e75 Mon Sep 17 00:00:00 2001 From: Cameron Samak Date: Thu, 5 Dec 2024 13:22:51 -0800 Subject: [PATCH 15/37] Do not error on any AppT in sqlMaybeSelectProcessRowDec (#406) * Do not error on any AppT in sqlMaybeSelectProcessRowDec No need to be this restrictive in deriveEsqueletoRecord For example, AppT ListT _ and AppT (ConT _) _ are both fine but would throw an error here before this change. * Apply suggestions from code review --------- Co-authored-by: Matt Parsons --- changelog.md | 6 ++++++ esqueleto.cabal | 2 +- src/Database/Esqueleto/Record.hs | 4 +--- 3 files changed, 8 insertions(+), 4 deletions(-) diff --git a/changelog.md b/changelog.md index 6f4dd4674..a36dfe54d 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +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 diff --git a/esqueleto.cabal b/esqueleto.cabal index 547741fff..5d2da3d39 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.5.13.0 +version: 3.5.13.1 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. . diff --git a/src/Database/Esqueleto/Record.hs b/src/Database/Esqueleto/Record.hs index cdc9913be..48b91c1f4 100644 --- a/src/Database/Esqueleto/Record.hs +++ b/src/Database/Esqueleto/Record.hs @@ -935,10 +935,8 @@ sqlMaybeSelectProcessRowDec RecordInfo {..} = do ] where wrapJust x = case x of - AppT (ConT ((==) ''Entity -> True)) _innerType -> id ((ConT ((==) ''Maybe -> True)) `AppT` _inner) -> AppE (ConE 'Just) - (ConT _) -> id - _ -> error $ show x + _ -> id -- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance. sqlMaybeSelectColCountDec :: RecordInfo -> Q Dec From c0a381e43ddb63c65f1c12e3954227236a879046 Mon Sep 17 00:00:00 2001 From: Daniel Trowbridge Date: Thu, 26 Dec 2024 19:49:46 +0000 Subject: [PATCH 16/37] Fix semantics of `not_` applied over `&&.` and `||.` (#379) * Add tests for not_ applied to more complex expressions * Always parenthesize arguments to not_ * Update test/Common/Test.hs --------- Co-authored-by: Matt Parsons --- src/Database/Esqueleto/Internal/Internal.hs | 7 ++- test/Common/Test.hs | 55 +++++++++++++++++---- 2 files changed, 48 insertions(+), 14 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index fa9fc19b2..c750c7cae 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -717,16 +717,15 @@ countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a) countDistinct = countHelper "(DISTINCT " ")" not_ :: SqlExpr (Value Bool) -> SqlExpr (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 typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) (==.) = unsafeSqlBinOpComposite " = " " AND " diff --git a/test/Common/Test.hs b/test/Common/Test.hs index b74850143..f79cafd55 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -878,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 $ - 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 @@ -921,6 +911,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 From 7f77bec99cede4ca2d52c38f923814d772460a59 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Thu, 26 Dec 2024 12:51:20 -0700 Subject: [PATCH 17/37] start 3.5.13.2 --- changelog.md | 7 +++++++ esqueleto.cabal | 2 +- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/changelog.md b/changelog.md index a36dfe54d..648cbb840 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,10 @@ +3.5.13.2 (unreleased) +======== +- @blujupiter32 + - [#379](https://github.com/bitemyapp/esqueleto/pull/379) + - Fix a bug where `not_ (a &&. b)` would be interpeted as `(not_ a) &&. + b` + 3.5.13.1 ======== - @csamak diff --git a/esqueleto.cabal b/esqueleto.cabal index 5d2da3d39..262e92307 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.5.13.1 +version: 3.5.13.2 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. . From a14ec3a38c1123ac66d0d68fb4d75c0b1cbfd3c6 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Thu, 26 Dec 2024 20:11:02 +0000 Subject: [PATCH 18/37] Use TH quotes more to eliminate some CPP (#394) * Remove CPP for ConP * Use quote for toMaybeTDec * Bump version and add chnglog entry * Convert more code to use TH quotes * Fix newName error --------- Co-authored-by: Matt Parsons --- changelog.md | 4 + src/Database/Esqueleto/Record.hs | 139 ++++++------------------------- 2 files changed, 30 insertions(+), 113 deletions(-) diff --git a/changelog.md b/changelog.md index 648cbb840..6e9d99f72 100644 --- a/changelog.md +++ b/changelog.md @@ -4,9 +4,13 @@ - [#379](https://github.com/bitemyapp/esqueleto/pull/379) - Fix a bug where `not_ (a &&. b)` would be interpeted as `(not_ a) &&. b` +- @TeofilC + - [#394](https://github.com/bitemyapp/esqueleto/pull/394) + - Use TH quotes to eliminate some CPP. 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 diff --git a/src/Database/Esqueleto/Record.hs b/src/Database/Esqueleto/Record.hs index 48b91c1f4..17517999c 100644 --- a/src/Database/Esqueleto/Record.hs +++ b/src/Database/Esqueleto/Record.hs @@ -379,15 +379,12 @@ makeSqlSelectInstance info@RecordInfo {..} = do sqlSelectProcessRowDec' <- sqlSelectProcessRowDec info let overlap = Nothing instanceConstraints = [] - instanceType = - (ConT ''SqlSelect) - `AppT` (ConT sqlName) - `AppT` (ConT name) + instanceType <- [t| SqlSelect $(conT sqlName) $(conT name) |] - pure $ InstanceD overlap instanceConstraints instanceType [sqlSelectColsDec', sqlSelectColCountDec', sqlSelectProcessRowDec'] + pure $ InstanceD overlap instanceConstraints instanceType (sqlSelectColsDec' ++ sqlSelectColCountDec' ++ [ sqlSelectProcessRowDec']) -- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance. -sqlSelectColsDec :: RecordInfo -> Q Dec +sqlSelectColsDec :: RecordInfo -> Q [Dec] sqlSelectColsDec RecordInfo {..} = do -- Pairs of record field names and local variable names. fieldNames <- forM sqlFields (\(name', _type) -> do @@ -413,26 +410,12 @@ sqlSelectColsDec RecordInfo {..} = do in foldl' helper (VarE f1) rest identInfo <- newName "identInfo" - -- Roughly: - -- sqlSelectCols $identInfo SqlFoo{..} = sqlSelectCols $identInfo $joinedFields - pure $ - FunD - 'sqlSelectCols - [ Clause - [ VarP identInfo - , RecP sqlName fieldPatterns - ] - ( NormalB $ - (VarE 'sqlSelectCols) - `AppE` (VarE identInfo) - `AppE` (ParensE joinedFields) - ) - -- `where` clause. - [] - ] + [d| $(varP 'sqlSelectCols) = \ $(varP identInfo) $(pure $ RecP sqlName fieldPatterns) -> + sqlSelectCols $(varE identInfo) $(pure joinedFields) + |] -- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance. -sqlSelectColCountDec :: RecordInfo -> Q Dec +sqlSelectColCountDec :: RecordInfo -> Q [Dec] sqlSelectColCountDec RecordInfo {..} = do let joinedTypes = case snd `map` sqlFields of @@ -442,23 +425,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. @@ -541,11 +508,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. -- @@ -766,7 +729,7 @@ makeToMaybeInstance info@RecordInfo {..} = do instanceConstraints = [] instanceType = (ConT ''ToMaybe) `AppT` (ConT sqlName) - pure $ InstanceD overlap instanceConstraints instanceType [toMaybeTDec', toMaybeDec'] + pure $ InstanceD overlap instanceConstraints instanceType (toMaybeTDec' ++ toMaybeDec') -- | Generates a `ToMaybe` instance for the SqlMaybe of the given record. makeSqlMaybeToMaybeInstance :: RecordInfo -> Q Dec @@ -776,25 +739,15 @@ makeSqlMaybeToMaybeInstance RecordInfo {..} = do overlap = Nothing instanceConstraints = [] instanceType = (ConT ''ToMaybe) `AppT` (ConT sqlMaybeName) - pure $ InstanceD overlap instanceConstraints instanceType [sqlMaybeToMaybeTDec', toMaybeIdDec] + pure $ InstanceD overlap instanceConstraints instanceType (toMaybeIdDec:sqlMaybeToMaybeTDec') -- | Generates a `type ToMaybeT ... = ...` declaration for the given names. -toMaybeTDec :: Name -> Name -> Q Dec -toMaybeTDec nameLeft nameRight = do - pure $ mkTySynInstD ''ToMaybeT (ConT nameLeft) (ConT nameRight) - 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 +toMaybeTDec :: Name -> Name -> Q [Dec] +toMaybeTDec nameLeft nameRight = + [d| type instance ToMaybeT $(conT nameLeft) = $(conT nameRight) |] -- | Generates a `toMaybe value = ...` declaration for the given record. -toMaybeDec :: RecordInfo -> Q Dec +toMaybeDec :: RecordInfo -> Q [Dec] toMaybeDec RecordInfo {..} = do (fieldPatterns, fieldExps) <- unzip <$> forM (zip sqlFields sqlMaybeFields) (\((fieldName', _), (maybeFieldName', _)) -> do @@ -804,15 +757,9 @@ toMaybeDec RecordInfo {..} = do , (maybeFieldName', VarE 'toMaybe `AppE` VarE fieldPatternName) )) - pure $ - FunD - 'toMaybe - [ Clause - [ RecP sqlName fieldPatterns - ] - (NormalB $ RecConE sqlMaybeName fieldExps) - [] - ] + [d| $(varP 'toMaybe) = \ $(pure $ RecP sqlName fieldPatterns) -> + $(pure $ RecConE sqlMaybeName fieldExps) + |] -- | Generates an `SqlSelect` instance for the given record and its -- @Sql@-prefixed variant. @@ -823,15 +770,11 @@ 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 [sqlSelectColsDec', sqlSelectColCountDec', sqlSelectProcessRowDec'] + instanceType <- [t| SqlSelect $(conT sqlMaybeName) (Maybe $(conT name)) |] + pure $ InstanceD overlap instanceConstraints instanceType (sqlSelectColsDec' ++ sqlSelectColCountDec' ++ [sqlSelectProcessRowDec']) -- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance. -sqlMaybeSelectColsDec :: RecordInfo -> Q Dec +sqlMaybeSelectColsDec :: RecordInfo -> Q [Dec] sqlMaybeSelectColsDec RecordInfo {..} = do -- Pairs of record field names and local variable names. fieldNames <- forM sqlMaybeFields (\(name', _type) -> do @@ -857,23 +800,9 @@ sqlMaybeSelectColsDec RecordInfo {..} = do in foldl' helper (VarE f1) rest identInfo <- newName "identInfo" - -- Roughly: - -- sqlSelectCols $identInfo SqlFoo{..} = sqlSelectCols $identInfo $joinedFields - pure $ - FunD - 'sqlSelectCols - [ Clause - [ VarP identInfo - , RecP sqlMaybeName fieldPatterns - ] - ( NormalB $ - (VarE 'sqlSelectCols) - `AppE` (VarE identInfo) - `AppE` (ParensE joinedFields) - ) - -- `where` clause. - [] - ] + [d| $(varP 'sqlSelectCols) = \ $(varP identInfo) $(pure $ RecP sqlMaybeName fieldPatterns) -> + sqlSelectCols $(varE identInfo) $(pure joinedFields) + |] -- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect` -- instance for a SqlMaybe. @@ -939,7 +868,7 @@ sqlMaybeSelectProcessRowDec RecordInfo {..} = do _ -> id -- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance. -sqlMaybeSelectColCountDec :: RecordInfo -> Q Dec +sqlMaybeSelectColCountDec :: RecordInfo -> Q [Dec] sqlMaybeSelectColCountDec RecordInfo {..} = do let joinedTypes = case snd `map` sqlMaybeFields of @@ -949,23 +878,7 @@ sqlMaybeSelectColCountDec RecordInfo {..} = do InfixT lhs ''(:&) ty in foldl' helper t1 rest - -- Roughly: - -- sqlSelectColCount _ = sqlSelectColCount (Proxy @($joinedTypes)) - pure $ - FunD - 'sqlSelectColCount - [ Clause - [WildP] - ( NormalB $ - AppE (VarE 'sqlSelectColCount) $ - ParensE $ - AppTypeE - (ConE 'Proxy) - joinedTypes - ) - -- `where` clause. - [] - ] + [d| $(varP 'sqlSelectColCount) = \_ -> sqlSelectColCount (Proxy @($(pure joinedTypes))) |] -- | Statefully parse some number of columns from a list of `PersistValue`s, -- where the number of columns to parse is determined by `sqlSelectColCount` From 96312754ff33635967d05b2284696ca90bd872d0 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Thu, 26 Dec 2024 13:25:32 -0700 Subject: [PATCH 19/37] Update CI (#409) * Update CI * 9.12 has a failing dependency * lol sigh --- .github/workflows/haskell.yml | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 8f4e14e87..7a1d5c20c 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -33,12 +33,22 @@ jobs: strategy: matrix: cabal: ["3.10.2.1"] - ghc: ["8.6.5", "8.8.4", "8.10.4", "9.0.2", "9.2.2", "9.4.5", "9.6.2", "9.8.1"] + ghc: + - "8.6" + - "8.8" + - "8.10" + - "9.0" + - "9.2" + - "9.4" + - "9.6" + - "9.8" + - "9.10" + # - "9.12" env: CONFIG: "--enable-tests --enable-benchmarks " steps: - - uses: actions/checkout@v2 - - uses: haskell/actions/setup@v2 + - uses: actions/checkout@v4 + - uses: haskell-actions/setup@v2 id: setup-haskell-cabal with: ghc-version: ${{ matrix.ghc }} @@ -61,7 +71,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 +82,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 From 7c5cb0e511668eabe3b19746b704b0023b7c190f Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Thu, 26 Dec 2024 13:26:47 -0700 Subject: [PATCH 20/37] Docs on boolean operators (#411) * Docs * changelog * changelog --- changelog.md | 11 +- src/Database/Esqueleto/Internal/Internal.hs | 117 +++++++++++++++++++- 2 files changed, 122 insertions(+), 6 deletions(-) diff --git a/changelog.md b/changelog.md index 6e9d99f72..28a7e50e3 100644 --- a/changelog.md +++ b/changelog.md @@ -2,15 +2,16 @@ ======== - @blujupiter32 - [#379](https://github.com/bitemyapp/esqueleto/pull/379) - - Fix a bug where `not_ (a &&. b)` would be interpeted as `(not_ a) &&. - b` + - Fix a bug where `not_ (a &&. b)` would be interpeted as `(not_ a) &&. b` - @TeofilC - - [#394](https://github.com/bitemyapp/esqueleto/pull/394) - - Use TH quotes to eliminate some CPP. + - [#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 diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index c750c7cae..1982a10e6 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -727,42 +727,157 @@ not_ v = ERaw noMeta (const $ first ("NOT " <>) . x) else f Parens info +-- | This operator produces the SQL operator @=@, which is used to compare +-- values for equality. +-- +-- Example: +-- +-- @ +-- query :: UserId -> SqlPersistT IO [Entity User] +-- query userId = select $ do +-- user <- from $ table \@User +-- where_ (user ^. UserId ==. val userId) +-- pure user +-- @ +-- +-- This would generate the following SQL: +-- +-- @ +-- SELECT user.* +-- FROM user +-- WHERE user.id = ? +-- @ (==.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) (==.) = unsafeSqlBinOpComposite " = " " AND " +-- | This operator translates to the SQL operator @>=@. +-- +-- Example: +-- +-- @ +-- where_ $ user ^. UserAge >=. val 21 +-- @ (>=.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) (>=.) = unsafeSqlBinOp " >= " +-- | This operator translates to the SQL operator @>@. +-- +-- Example: +-- +-- @ +-- where_ $ user ^. UserAge >. val 20 +-- @ (>.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) (>.) = unsafeSqlBinOp " > " +-- | This operator translates to the SQL operator @<=@. +-- +-- Example: +-- +-- @ +-- where_ $ val 21 <=. user ^. UserAge +-- @ (<=.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) (<=.) = unsafeSqlBinOp " <= " +-- | This operator translates to the SQL operator @<@. +-- +-- Example: +-- +-- @ +-- where_ $ val 20 <. user ^. UserAge +-- @ (<.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) (<.) = unsafeSqlBinOp " < " + +-- | This operator translates to the SQL operator @!=@. +-- +-- Example: +-- +-- @ +-- where_ $ user ^. UserName !=. val "Bob" +-- @ (!=.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) (!=.) = unsafeSqlBinOpComposite " != " " OR " +-- | This operator translates to the SQL operator @AND@. +-- +-- Example: +-- +-- @ +-- where_ $ +-- user ^. UserName ==. val "Matt" +-- &&. user ^. UserAge >=. val 21 +-- @ (&&.) :: SqlExpr (Value Bool) -> SqlExpr (Value Bool) -> SqlExpr (Value Bool) (&&.) = unsafeSqlBinOp " AND " +-- | This operator translates to the SQL operator @AND@. +-- +-- Example: +-- +-- @ +-- where_ $ +-- user ^. UserName ==. val "Matt" +-- ||. user ^. UserName ==. val "John" +-- @ (||.) :: SqlExpr (Value Bool) -> SqlExpr (Value Bool) -> SqlExpr (Value Bool) (||.) = unsafeSqlBinOp " OR " +-- | This operator translates to the SQL operator @+@. +-- +-- This does not require or assume anything about the SQL values. Interpreting +-- what @+.@ means for a given type is left to the database engine. +-- +-- Example: +-- +-- @ +-- user ^. UserAge +. val 10 +-- @ (+.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a) (+.) = unsafeSqlBinOp " + " +-- | This operator translates to the SQL operator @-@. +-- +-- This does not require or assume anything about the SQL values. Interpreting +-- what @-.@ means for a given type is left to the database engine. +-- +-- Example: +-- +-- @ +-- user ^. UserAge -. val 10 +-- @ (-.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a) (-.) = unsafeSqlBinOp " - " +-- | This operator translates to the SQL operator @/@. +-- +-- This does not require or assume anything about the SQL values. Interpreting +-- what @/.@ means for a given type is left to the database engine. +-- +-- Example: +-- +-- @ +-- user ^. UserAge /. val 10 +-- @ (/.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a) (/.) = unsafeSqlBinOp " / " +-- | This operator translates to the SQL operator @*@. +-- +-- This does not require or assume anything about the SQL values. Interpreting +-- what @*.@ means for a given type is left to the database engine. +-- +-- Example: +-- +-- @ +-- user ^. UserAge *. val 10 +-- @ (*.) :: PersistField a => SqlExpr (Value a) -> SqlExpr (Value a) -> SqlExpr (Value a) (*.) = unsafeSqlBinOp " * " --- | @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 => SqlExpr (Value a) -> (SqlExpr (Value a), SqlExpr (Value a)) -> SqlExpr (Value Bool) From 2583e743fa13c296faaba40f94bf3c76727f33f7 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Thu, 26 Dec 2024 13:52:24 -0700 Subject: [PATCH 21/37] Mattp/incorporate cte aliasing (#410) * Alias CTEs upon initialising * Bump version, adhere to style guide * Update changelog * Incorporate CTE test --------- Co-authored-by: Rik van Toor --- changelog.md | 3 ++ esqueleto.cabal | 1 + .../From/CommonTableExpression.hs | 6 +++- test/Common/Test.hs | 2 ++ test/Common/Test/CTE.hs | 35 +++++++++++++++++++ test/Common/Test/Models.hs | 10 ++++++ test/PostgreSQL/Test.hs | 2 -- 7 files changed, 56 insertions(+), 3 deletions(-) create mode 100644 test/Common/Test/CTE.hs diff --git a/changelog.md b/changelog.md index 28a7e50e3..374965c31 100644 --- a/changelog.md +++ b/changelog.md @@ -3,6 +3,9 @@ - @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. diff --git a/esqueleto.cabal b/esqueleto.cabal index 262e92307..c4c69c4fa 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -87,6 +87,7 @@ test-suite specs main-is: Spec.hs other-modules: Common.Test + Common.Test.CTE Common.Test.Models Common.Test.Import Common.Test.Select diff --git a/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs b/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs index a0d72b9f0..2a7898b97 100644 --- a/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs +++ b/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs @@ -53,7 +53,11 @@ with query = do 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. diff --git a/test/Common/Test.hs b/test/Common/Test.hs index f79cafd55..823b4c9a7 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -91,6 +91,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 @@ -2426,6 +2427,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 dc6b94530..2a1ada117 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/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 583d89fcb..695a35769 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -1347,7 +1347,6 @@ testPostgresqlLocking = do EP.forUpdateOf p EP.skipLocked return p - liftIO $ print nonLockedRowsSpecifiedTable pure $ length nonLockedRowsSpecifiedTable `shouldBe` 2 withAsync sideThread $ \sideThreadAsync -> do @@ -1371,7 +1370,6 @@ testPostgresqlLocking = do EP.forUpdateOf p EP.skipLocked return p - liftIO $ print nonLockedRowsAfterUpdate asserting sideThreadAsserts asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3 From 91aa8d22ef49cb83bfded9bc3cc0f2ed68f284fc Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Thu, 26 Dec 2024 13:52:49 -0700 Subject: [PATCH 22/37] v3.5.13.2 --- changelog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changelog.md b/changelog.md index 374965c31..e92e7fe5f 100644 --- a/changelog.md +++ b/changelog.md @@ -1,4 +1,4 @@ -3.5.13.2 (unreleased) +3.5.13.2 ======== - @blujupiter32 - [#379](https://github.com/bitemyapp/esqueleto/pull/379) From 235bd9a78899d1da02b28d00c20250ee02d2360e Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Thu, 26 Dec 2024 15:57:32 -0700 Subject: [PATCH 23/37] Derive Traversable for Value (#414) * Derive Traversable for Value * changelog, cabal --- changelog.md | 6 ++++++ esqueleto.cabal | 2 +- src/Database/Esqueleto/Internal/Internal.hs | 8 +++----- 3 files changed, 10 insertions(+), 6 deletions(-) diff --git a/changelog.md b/changelog.md index e92e7fe5f..dea9ace02 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +3.5.14.0 (unreleased) +======== +- @parsonsmatt + - [#414](https://github.com/bitemyapp/esqueleto/pull/414) + - Derive `Foldable` and `Traversable` for `Value`. + 3.5.13.2 ======== - @blujupiter32 diff --git a/esqueleto.cabal b/esqueleto.cabal index c4c69c4fa..f5c40ddb8 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.5.13.2 +version: 3.5.14.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. . diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 1982a10e6..d919ade85 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -6,6 +6,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} @@ -1270,11 +1271,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) From cdece9145dfbf87cadc6df94260aaa2c888a9c16 Mon Sep 17 00:00:00 2001 From: Matthew Bauer Date: Thu, 26 Dec 2024 17:00:24 -0600 Subject: [PATCH 24/37] Add NULLS FIRST / NULLS LAST qualifiers for ordering (#341) * Add NULLS FIRST / NULLS LAST qualifiers for ordering * Fixup * Add tests * Fix test --------- Co-authored-by: Matt Parsons --- src/Database/Esqueleto/PostgreSQL.hs | 32 +++++++++++++++++- test/PostgreSQL/Test.hs | 49 ++++++++++++++++++++++++++++ 2 files changed, 80 insertions(+), 1 deletion(-) diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 052594e81..76d300b28 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -36,6 +36,10 @@ module Database.Esqueleto.PostgreSQL , forKeyShareOf , filterWhere , values + , ascNullsFirst + , ascNullsLast + , descNullsFirst + , descNullsLast -- * Internal , unsafeSqlAggregateFunction ) where @@ -486,7 +490,7 @@ forNoKeyUpdateOf lockableEntities onLockedBehavior = 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 -- @@ -494,3 +498,29 @@ forShareOf lockableEntities onLockedBehavior = forKeyShareOf :: LockableEntity a => a -> OnLockedBehavior -> SqlQuery () forKeyShareOf lockableEntities onLockedBehavior = putLocking $ PostgresLockingClauses [PostgresLockingKind PostgresForKeyShare (Just $ LockingOfClause lockableEntities) onLockedBehavior] + +-- | 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/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 695a35769..c86307181 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -1546,6 +1546,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) @@ -1642,6 +1690,7 @@ spec = beforeAll mkConnectionPool $ do testValuesExpression testSubselectAliasingBehavior testPostgresqlLocking + testPostgresqlNullsOrdering insertJsonValues :: SqlPersistT IO () insertJsonValues = do From 28c8130c9e680c5068271ec2b67c7d3e4b0950c1 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Thu, 26 Dec 2024 16:01:24 -0700 Subject: [PATCH 25/37] Add changelog entry for #341 --- changelog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/changelog.md b/changelog.md index dea9ace02..fe9ae1d0e 100644 --- a/changelog.md +++ b/changelog.md @@ -3,6 +3,10 @@ - @parsonsmatt - [#414](https://github.com/bitemyapp/esqueleto/pull/414) - Derive `Foldable` and `Traversable` for `Value`. +- @matthewbauer + - [#341](https://github.com/bitemyapp/esqueleto/pull/341/) + - Add functions for `NULLS FIRST` and `NULLS LAST` in the Postgresql + module 3.5.13.2 ======== From bc9c1690198ee8a3e7b17a9f70c155413a100ecb Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Thu, 26 Dec 2024 16:04:05 -0700 Subject: [PATCH 26/37] Add Functor and Bifunctor instance for pairs (#416) * Add Functor and Bifunctor instance for pairs * Add since * changelog entry --- changelog.md | 2 ++ src/Database/Esqueleto/Internal/Internal.hs | 10 +++++++++- 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/changelog.md b/changelog.md index fe9ae1d0e..12f1fb93c 100644 --- a/changelog.md +++ b/changelog.md @@ -3,6 +3,8 @@ - @parsonsmatt - [#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 diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index d919ade85..bda9ff8c6 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} @@ -54,6 +55,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 @@ -1551,9 +1553,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 From 324de6ac36736faffb0d6f8150b94dc4b3537aae Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Thu, 26 Dec 2024 16:05:16 -0700 Subject: [PATCH 27/37] Export SqlSelect from Database.Esqueleto.Experimental (#415) * Export SqlSelect from Database.Esqueleto.Experimental * cabal, changelog --- changelog.md | 2 ++ src/Database/Esqueleto/Experimental.hs | 1 + 2 files changed, 3 insertions(+) diff --git a/changelog.md b/changelog.md index 12f1fb93c..cba9879ad 100644 --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,8 @@ 3.5.14.0 (unreleased) ======== - @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) diff --git a/src/Database/Esqueleto/Experimental.hs b/src/Database/Esqueleto/Experimental.hs index 5caffd403..edffd3f57 100644 --- a/src/Database/Esqueleto/Experimental.hs +++ b/src/Database/Esqueleto/Experimental.hs @@ -61,6 +61,7 @@ module Database.Esqueleto.Experimental , ToAliasReference(..) , ToAliasReferenceT , ToSqlSetOperation(..) + , SqlSelect -- * The Normal Stuff , where_ From e739a91aa69ff2aaf664133ca92ca0324014a7b6 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Thu, 26 Dec 2024 16:24:19 -0700 Subject: [PATCH 28/37] Jnm/add cte materialized to postgres (#417) * Materialized CTEs for Postgres * changelog update * fix tests --------- Co-authored-by: Joel McCracken --- changelog.md | 3 + .../From/CommonTableExpression.hs | 8 +- src/Database/Esqueleto/Internal/Internal.hs | 13 +-- src/Database/Esqueleto/PostgreSQL.hs | 89 ++++++++++++++++++- test/MySQL/Test.hs | 7 +- test/PostgreSQL/Test.hs | 77 +++++++++++++++- test/docker-compose.yml | 28 ++++++ 7 files changed, 212 insertions(+), 13 deletions(-) create mode 100644 test/docker-compose.yml diff --git a/changelog.md b/changelog.md index cba9879ad..795fa5516 100644 --- a/changelog.md +++ b/changelog.md @@ -11,6 +11,9 @@ - [#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 ======== diff --git a/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs b/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs index 2a7898b97..c564432c9 100644 --- a/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs +++ b/src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs @@ -38,7 +38,8 @@ 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 @@ -50,7 +51,7 @@ 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 $ do @@ -107,7 +108,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 bda9ff8c6..969a65e19 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -1998,8 +1998,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 @@ -3212,14 +3214,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 = diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 76d300b28..5bb4bde5c 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -36,6 +36,8 @@ module Database.Esqueleto.PostgreSQL , forKeyShareOf , filterWhere , values + , withMaterialized + , withNotMaterialized , ascNullsFirst , ascNullsLast , descNullsFirst @@ -52,15 +54,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 @@ -490,7 +499,7 @@ forNoKeyUpdateOf lockableEntities onLockedBehavior = 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 -- @@ -499,6 +508,82 @@ 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 + , SqlSelect a r + ) => SqlQuery a -> SqlQuery (Ex.From a) +withMaterialized query = do + (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ query + aliasedValue <- toAlias ret + let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData) + ident <- newIdentFor (DBName "cte") + let clause = CommonTableExpressionClause NormalCommonTableExpression (\_ _ -> "MATERIALIZED ") ident (\info -> toRawSql SELECT info aliasedQuery) + Q $ W.tell mempty{sdCteClause = [clause]} + ref <- toAliasReference ident aliasedValue + pure $ Ex.From $ pure (ref, (\_ info -> (useIdent info ident, mempty))) + +-- | @WITH@ @NOT@ @MATERIALIZED@ clause is used to introduce a +-- [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression) +-- with the NOT MATERIALIZED keywords. These are only supported in PostgreSQL >= +-- version 12. In Esqueleto, CTEs should be used as a subquery memoization +-- tactic. PostgreSQL treats a materialized CTE as an optimization fence. A +-- MATERIALIZED CTE is always fully calculated, and is not "inlined" with other +-- table joins. Sometimes, this is undesirable, so postgres provides the NOT +-- MATERIALIZED modifier to prevent this behavior, thus enabling it to possibly +-- decide to treat the CTE as any other join. +-- +-- Given the above, it is unlikely that this function will be useful, as a +-- normal join should be used instead, but is provided for completeness. +-- +-- @ +-- select $ do +-- cte <- withNotMaterialized subQuery +-- cteResult <- from cte +-- where_ $ cteResult ... +-- pure cteResult +-- @ +-- +-- +-- For more information on materialized CTEs, see the PostgreSQL manual documentation on +-- [Common Table Expression Materialization](https://www.postgresql.org/docs/14/queries-with.html#id-1.5.6.12.7). +-- +-- @since 3.5.14.0 +withNotMaterialized :: ( ToAlias a + , ToAliasReference a + , SqlSelect a r + ) => SqlQuery a -> SqlQuery (Ex.From a) +withNotMaterialized query = do + (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ query + aliasedValue <- toAlias ret + let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData) + ident <- newIdentFor (DBName "cte") + let clause = CommonTableExpressionClause NormalCommonTableExpression (\_ _ -> "NOT MATERIALIZED ") ident (\info -> toRawSql SELECT info aliasedQuery) + Q $ W.tell mempty{sdCteClause = [clause]} + ref <- toAliasReference ident aliasedValue + pure $ Ex.From $ pure (ref, (\_ info -> (useIdent info ident, mempty))) + -- | Ascending order of this field or SqlExpression with nulls coming first. -- -- @since 3.5.14.0 diff --git a/test/MySQL/Test.hs b/test/MySQL/Test.hs index 6941328f9..8f6ecf9a6 100644 --- a/test/MySQL/Test.hs +++ b/test/MySQL/Test.hs @@ -23,14 +23,16 @@ import Database.Persist.MySQL , connectPassword , connectPort , connectUser + , createMySQLPool , defaultConnectInfo , withMySQLConn - , createMySQLPool ) import Test.Hspec import Common.Test +import Data.Maybe (fromMaybe) +import System.Environment (lookupEnv) testMysqlSum :: SpecDb testMysqlSum = do @@ -189,6 +191,7 @@ migrateIt = do mkConnectionPool :: IO ConnectionPool mkConnectionPool = do ci <- isCI + mysqlHost <- (fromMaybe "localhost" <$> lookupEnv "MYSQL_HOST") let connInfo | ci = defaultConnectInfo @@ -200,7 +203,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 c86307181..62c020051 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -40,7 +40,8 @@ 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_, withMaterialized, withNotMaterialized) import qualified Database.Esqueleto.PostgreSQL as EP import Database.Esqueleto.PostgreSQL.JSON hiding ((-.), (?.), (||.)) import qualified Database.Esqueleto.PostgreSQL.JSON as JSON @@ -1232,6 +1233,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 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 From 6ea947ae2b88288c491b1bef3528643283090ed2 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Thu, 26 Dec 2024 16:24:50 -0700 Subject: [PATCH 29/37] v3.5.14.0 --- changelog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changelog.md b/changelog.md index 795fa5516..8af2057e5 100644 --- a/changelog.md +++ b/changelog.md @@ -1,4 +1,4 @@ -3.5.14.0 (unreleased) +3.5.14.0 ======== - @parsonsmatt - [#415](https://github.com/bitemyapp/esqueleto/pull/415) From 135f8281ca72e8907ac90d197d8499dbb5d8b19f Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Thu, 26 Dec 2024 17:32:45 -0700 Subject: [PATCH 30/37] oof --- .github/workflows/haskell.yml | 23 +- changelog.md | 51 ++ esqueleto.cabal | 1 + src/Database/Esqueleto.hs | 1 - src/Database/Esqueleto/Experimental.hs | 2 +- .../From/CommonTableExpression.hs | 15 +- src/Database/Esqueleto/Internal/Internal.hs | 310 +++++---- src/Database/Esqueleto/Legacy.hs | 4 +- src/Database/Esqueleto/PostgreSQL.hs | 136 +++- src/Database/Esqueleto/Record.hs | 620 +++++++++++------- stack-8.10.yaml | 3 + stack-8.2.yaml | 3 + stack-8.4.yaml | 3 + stack-8.6.yaml | 3 + stack-8.8.yaml | 3 + stack-9.0.yaml | 3 + stack-nightly.yaml | 3 + test/Common/Record.hs | 143 +++- test/Common/Test.hs | 57 +- test/Common/Test/CTE.hs | 35 + test/Common/Test/Models.hs | 10 + test/MySQL/Test.hs | 5 +- test/PostgreSQL/Test.hs | 132 +++- test/docker-compose.yml | 28 + 24 files changed, 1202 insertions(+), 392 deletions(-) create mode 100644 test/Common/Test/CTE.hs create mode 100644 test/docker-compose.yml 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 From f54a84b06381795ce23b3ac246d92d1f12b14197 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Thu, 26 Dec 2024 17:33:37 -0700 Subject: [PATCH 31/37] fix the ci --- .github/workflows/haskell.yml | 9 --------- 1 file changed, 9 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index d4ef49c50..7a1d5c20c 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -33,14 +33,6 @@ 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" @@ -57,7 +49,6 @@ jobs: steps: - uses: actions/checkout@v4 - uses: haskell-actions/setup@v2 ->>>>>>> master id: setup-haskell-cabal with: ghc-version: ${{ matrix.ghc }} From c0f4db4ed16fdb6e4faf96777b1930d1bca32b0a Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 27 Dec 2024 10:40:08 -0700 Subject: [PATCH 32/37] All tests are passing now --- .../Esqueleto/Experimental/From/Join.hs | 1 + src/Database/Esqueleto/Record.hs | 191 +++++++++--------- test/Common/LegacyTest.hs | 26 --- test/Common/Test.hs | 60 ++---- test/PostgreSQL/LegacyTest.hs | 1 - test/PostgreSQL/Test.hs | 49 +++-- test/SQLite/LegacyTest.hs | 1 - test/SQLite/Test.hs | 1 - 8 files changed, 133 insertions(+), 197 deletions(-) diff --git a/src/Database/Esqueleto/Experimental/From/Join.hs b/src/Database/Esqueleto/Experimental/From/Join.hs index a4789ed0e..0726d2f00 100644 --- a/src/Database/Esqueleto/Experimental/From/Join.hs +++ b/src/Database/Esqueleto/Experimental/From/Join.hs @@ -66,6 +66,7 @@ instance ValidOnClause (a -> SqlQuery b) instance (SqlSelectCols a, SqlSelectCols b) => SqlSelectCols (a :& b) where sqlSelectCols esc (a :& b) = sqlSelectCols esc (a, b) sqlSelectColCount = sqlSelectColCount . toTupleP + instance (SqlSelect a ra, SqlSelect b rb) => SqlSelect (a :& b) (ra :& rb) where sqlSelectProcessRow p = fmap (uncurry (:&)) . sqlSelectProcessRow (toTupleP p) diff --git a/src/Database/Esqueleto/Record.hs b/src/Database/Esqueleto/Record.hs index 7d9be64fb..6aa055d8d 100644 --- a/src/Database/Esqueleto/Record.hs +++ b/src/Database/Esqueleto/Record.hs @@ -378,27 +378,24 @@ makeSqlRecord RecordInfo {..} = do -- @Sql@-prefixed variant. makeSqlSelectInstance :: RecordInfo -> Q [Dec] makeSqlSelectInstance info@RecordInfo {..} = do - sqlSelectColsDec' <- sqlSelectColsDec info - sqlSelectColCountDec' <- sqlSelectColCountDec info - sqlSelectProcessRowDec' <- sqlSelectProcessRowDec info - let overlap = Nothing - instanceConstraints = [] --- <<<<<<< 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 $ pure $ InstanceD overlap instanceConstraints instanceType (sqlSelectColsDec' ++ sqlSelectColCountDec' ++ [ sqlSelectProcessRowDec']) --- >>>>>>> master + sqlSelectColsDec' <- sqlSelectColsDec info + sqlSelectColCountDec' <- sqlSelectColCountDec info + sqlSelectProcessRowDec' <- sqlSelectProcessRowDec info + let overlap = Nothing + instanceConstraints = [] + sqlSelectColsType = + AppT (ConT ''SqlSelectCols) (ConT sqlName) + sqlSelectType = + (ConT ''SqlSelect) + `AppT` (ConT sqlName) + `AppT` (ConT name) + + pure + [ InstanceD overlap instanceConstraints sqlSelectColsType + (concat [ sqlSelectColsDec', sqlSelectColCountDec']) + , InstanceD overlap instanceConstraints sqlSelectType + [ sqlSelectProcessRowDec'] + ] -- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance. sqlSelectColsDec :: RecordInfo -> Q [Dec] @@ -469,59 +466,62 @@ sqlSelectColCountDec RecordInfo {..} = do -- instance. sqlSelectProcessRowDec :: RecordInfo -> Q Dec sqlSelectProcessRowDec RecordInfo {..} = do - -- Binding statements and field expressions (used in record construction) to - -- fill out the body of the main generated `do` expression. - -- - -- Each statement is like: - -- Value fooName' <- takeColumns @(SqlExpr (Value Text)) - -- A corresponding field expression would be: - -- fooName = fooName' - -- - -- See `sqlSelectProcessRowPat` for the left-hand side of the patterns. - (statements, fieldExps) <- - unzip <$> forM (zip fields sqlFields) (\((fieldName', fieldType), (_, sqlType')) -> do - valueName <- newName (nameBase fieldName') - pattern <- sqlSelectProcessRowPat fieldType valueName - pure - ( BindS - pattern - (AppTypeE (VarE 'takeColumns) sqlType') - , (mkName $ nameBase fieldName', VarE valueName) - )) - - colsName <- newName "columns" - processName <- newName "process" - - -- Roughly: - -- sqlSelectProcessRow $colsName = - -- first ((fromString "Failed to parse $name: ") <>) - -- (evalStateT $processName $colsName) - -- where $processName = do $statements - -- pure $name {$fieldExps} - bodyExp <- [e| - first (fromString ("Failed to parse " ++ $(lift $ nameBase name) ++ ": ") <>) - (evalStateT $(varE processName) $(varE colsName)) - |] - - pure $ - FunD - 'sqlSelectProcessRow - [ Clause - [WildP, VarP colsName] - (NormalB bodyExp) - -- `where` clause - [ ValD - (VarP processName) - ( NormalB $ - DoE + -- Binding statements and field expressions (used in record construction) to + -- fill out the body of the main generated `do` expression. + -- + -- Each statement is like: + -- Value fooName' <- takeColumns @(SqlExpr (Value Text)) + -- A corresponding field expression would be: + -- fooName = fooName' + -- + -- See `sqlSelectProcessRowPat` for the left-hand side of the patterns. + (statements, fieldExps) <- + unzip <$> forM (zip fields sqlFields) (\((fieldName', fieldType), (_, sqlType')) -> do + valueName <- newName (nameBase fieldName') + pattern <- sqlSelectProcessRowPat fieldType valueName + pure + ( BindS + pattern + (AppTypeE (VarE 'takeColumns) sqlType') + , (mkName $ nameBase fieldName', VarE valueName) + )) + + colsName <- newName "columns" + processName <- newName "process" + + -- Roughly: + -- sqlSelectProcessRow $proxy $colsName = + -- first ((fromString "Failed to parse $name: ") <>) + -- (evalStateT $processName $colsName) + -- where $processName = do $statements + -- pure $name {$fieldExps} + bodyExp <- [e| + first (fromString ("Failed to parse " ++ $(lift $ nameBase name) ++ ": ") <>) + (evalStateT $(varE processName) $(varE colsName)) + |] + processType <- + [t| StateT [PersistValue] (Either Text) $(conT name) |] + + pure $ + FunD + 'sqlSelectProcessRow + [ Clause + [WildP, VarP colsName] + (NormalB bodyExp) + -- `where` clause + [ SigD processName processType + , ValD + (VarP processName) + ( NormalB $ + DoE #if MIN_VERSION_template_haskell(2,17,0) - Nothing + Nothing #endif - (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE constructorName fieldExps)]) - ) - [] - ] - ] + (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE constructorName fieldExps)]) + ) + [] + ] + ] -- | Get the left-hand side pattern of a statement in a @do@ block for binding -- to the result of `sqlSelectProcessRow`. @@ -844,35 +844,28 @@ toMaybeDec RecordInfo {..} = do -- @Sql@-prefixed variant. makeSqlMaybeRecordSelectInstance :: RecordInfo -> Q [Dec] makeSqlMaybeRecordSelectInstance info@RecordInfo {..} = do - sqlSelectColsDec' <- sqlMaybeSelectColsDec info - sqlSelectColCountDec' <- sqlMaybeSelectColCountDec info - sqlSelectProcessRowDec' <- sqlMaybeSelectProcessRowDec info - let overlap = Nothing - instanceConstraints = [] --- <<<<<<< 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']) + sqlSelectColsDec' <- sqlMaybeSelectColsDec info + sqlSelectColCountDec' <- sqlMaybeSelectColCountDec info + sqlSelectProcessRowDec' <- sqlMaybeSelectProcessRowDec info + let overlap = Nothing + instanceConstraints = [] + instanceType <- [t| SqlSelect $(conT sqlMaybeName) (Maybe $(conT name)) |] + pure + [ InstanceD overlap instanceConstraints instanceType + [ sqlSelectProcessRowDec' + ] + , InstanceD overlap instanceConstraints + (ConT ''SqlSelectCols `AppT` ConT sqlMaybeName) + (concat + [ sqlSelectColsDec' + , sqlSelectColCountDec' + ] + ) + + ] -- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance. sqlMaybeSelectColsDec :: RecordInfo -> Q [Dec] --- >>>>>>> master sqlMaybeSelectColsDec RecordInfo {..} = do -- Pairs of record field names and local variable names. fieldNames <- forM sqlMaybeFields (\(name', _type) -> do @@ -1042,7 +1035,7 @@ sqlMaybeSelectProcessRowDec RecordInfo {..} = do FunD 'sqlSelectProcessRow [ Clause - [VarP colsName] + [WildP, VarP colsName] (NormalB bodyExp) -- `where` [ ValD diff --git a/test/Common/LegacyTest.hs b/test/Common/LegacyTest.hs index 0b37380bd..7e43094fb 100644 --- a/test/Common/LegacyTest.hs +++ b/test/Common/LegacyTest.hs @@ -32,7 +32,6 @@ module Common.LegacyTest ( tests , testLocking , testAscRandom - , testRandomMath , migrateAll , migrateUnique , cleanDB @@ -1352,31 +1351,6 @@ testInsertsBySelectReturnsCount = do asserting $ ret `shouldBe` [Value (3::Int)] asserting $ cnt `shouldBe` 3 - - - -testRandomMath :: SpecDb -testRandomMath = describe "random_ math" $ - itDb "rand returns result in random order" $ - do - replicateM_ 20 $ do - _ <- insert p1 - _ <- insert p2 - _ <- insert p3 - _ <- insert p4 - _ <- insert $ Person "Jane" Nothing Nothing 0 - _ <- insert $ Person "Mark" Nothing Nothing 0 - _ <- insert $ Person "Sarah" Nothing Nothing 0 - insert $ Person "Paul" Nothing Nothing 0 - ret1 <- fmap (map unValue) $ select $ from $ \p -> do - orderBy [rand] - return (p ^. PersonId) - ret2 <- fmap (map unValue) $ select $ from $ \p -> do - orderBy [rand] - return (p ^. PersonId) - - asserting $ (ret1 == ret2) `shouldBe` False - testMathFunctions :: SpecDb testMathFunctions = do describe "Math-related functions" $ do diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 1d886c9e1..539a951a8 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -32,7 +32,6 @@ module Common.Test ( tests , testLocking , testAscRandom - , testRandomMath , migrateAll , migrateUnique , cleanDB @@ -922,37 +921,37 @@ testSelectWhere = describe "select where_" $ 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 ] 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 + ret <- select $ do + p <- from $ table @Person + where_ (not_ $ p ^. PersonName ==. val "John" ||. p ^. PersonName ==. val "Rachel") + pure p asserting $ ret `shouldBe` [ p3e ] itDb "works with (>.), (<.) and (&&.) [uses just . val]" $ do p1e <- insert' p1 _ <- insert' p2 _ <- insert' p3 - ret <- select $ - from $ \p -> do - where_ (not_ $ (p ^. PersonAge >. just (val 10)) &&. (p ^. PersonAge <. just (val 30))) - return p + ret <- select $ do + p <- from $ table @Person + where_ (not_ $ (p ^. PersonAge >. just (val 10)) &&. (p ^. PersonAge <. just (val 30))) + pure p asserting $ ret `shouldBe` [ p1e ] itDb "works with between [uses just . val]" $ do _ <- insert' p1 _ <- insert' p2 p3e <- insert' p3 - ret <- select $ - from $ \p -> do - where_ (not_ $ (p ^. PersonAge) `between` (just $ val 20, just $ val 40)) - return p + ret <- select $ do + p <- from $ table @Person + where_ (not_ $ (p ^. PersonAge) `between` (just $ val 20, just $ val 40)) + pure p asserting $ ret `shouldBe` [ p3e ] itDb "works with avg_" $ do @@ -1570,33 +1569,6 @@ testInsertsBySelectReturnsCount = do asserting $ ret `shouldBe` [Value (3::Int)] asserting $ cnt `shouldBe` 3 - - - -testRandomMath :: SpecDb -testRandomMath = describe "random_ math" $ - itDb "rand returns result in random order" $ - do - replicateM_ 20 $ do - _ <- insert p1 - _ <- insert p2 - _ <- insert p3 - _ <- insert p4 - _ <- insert $ Person "Jane" Nothing Nothing 0 - _ <- insert $ Person "Mark" Nothing Nothing 0 - _ <- insert $ Person "Sarah" Nothing Nothing 0 - insert $ Person "Paul" Nothing Nothing 0 - ret1 <- fmap (map unValue) $ select $ do - p <- from $ table @Person - orderBy [rand] - return (p ^. PersonId) - ret2 <- fmap (map unValue) $ select $ do - p <- from $ table @Person - orderBy [rand] - return (p ^. PersonId) - - asserting $ (ret1 == ret2) `shouldBe` False - testMathFunctions :: SpecDb testMathFunctions = do describe "Math-related functions" $ do diff --git a/test/PostgreSQL/LegacyTest.hs b/test/PostgreSQL/LegacyTest.hs index e3840a4a4..1e18aa327 100644 --- a/test/PostgreSQL/LegacyTest.hs +++ b/test/PostgreSQL/LegacyTest.hs @@ -1201,7 +1201,6 @@ spec = beforeAll mkConnectionPool $ do describe "PostgreSQL specific tests" $ do testAscRandom random_ - testRandomMath testSelectDistinctOn testPostgresModule testPostgresqlOneAscOneDesc diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 3d26b2807..5bbb8aec5 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -1267,10 +1267,10 @@ testCommonTableExpressions = do void $ select $ do limitedLordsCte <- withNotMaterialized $ do - lords <- Experimental.from $ Experimental.table @Lord + lords <- from $ table @Lord limit 10 pure lords - lords <- Experimental.from limitedLordsCte + lords <- from limitedLordsCte orderBy [asc $ lords ^. LordId] pure lords @@ -1280,10 +1280,10 @@ testCommonTableExpressions = do (sql, _) <- showQuery ES.SELECT $ do limitedLordsCte <- withNotMaterialized $ do - lords <- Experimental.from $ Experimental.table @Lord + lords <- from $ table @Lord limit 10 pure lords - lords <- Experimental.from limitedLordsCte + lords <- from limitedLordsCte orderBy [asc $ lords ^. LordId] pure lords @@ -1304,10 +1304,10 @@ testCommonTableExpressions = do (sql, _) <- showQuery ES.SELECT $ do limitedLordsCte <- withMaterialized $ do - lords <- Experimental.from $ Experimental.table @Lord + lords <- from $ table @Lord limit 10 pure lords - lords <- Experimental.from limitedLordsCte + lords <- from limitedLordsCte orderBy [asc $ lords ^. LordId] pure lords @@ -1326,10 +1326,10 @@ testCommonTableExpressions = do void $ select $ do limitedLordsCte <- withMaterialized $ do - lords <- Experimental.from $ Experimental.table @Lord + lords <- from $ table @Lord limit 10 pure lords - lords <- Experimental.from limitedLordsCte + lords <- from limitedLordsCte orderBy [asc $ lords ^. LordId] pure lords @@ -1882,10 +1882,10 @@ testPostgresqlNullsOrdering = do 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 + ret <- select $ do + p <- from $ table @Person + orderBy [EP.ascNullsFirst (p ^. PersonAge), EP.ascNullsFirst (p ^. PersonFavNum)] + pure p -- nulls come first asserting $ ret `shouldBe` [ p2e, p3e, p4e, p1e ] itDb "ASC NULLS LAST works" $ do @@ -1893,10 +1893,10 @@ testPostgresqlNullsOrdering = do 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 + ret <- select $ do + p <- from $ table @Person + orderBy [EP.ascNullsLast (p ^. PersonAge), EP.ascNullsLast (p ^. PersonFavNum)] + pure p -- nulls come last asserting $ ret `shouldBe` [ p3e, p4e, p1e, p2e ] itDb "DESC NULLS FIRST works" $ do @@ -1904,10 +1904,10 @@ testPostgresqlNullsOrdering = do 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 + ret <- select $ do + p <- from $ table @Person + orderBy [EP.descNullsFirst (p ^. PersonAge), EP.descNullsFirst (p ^. PersonFavNum)] + pure p -- nulls come first asserting $ ret `shouldBe` [ p2e, p1e, p4e, p3e ] itDb "DESC NULLS LAST works" $ do @@ -1915,10 +1915,10 @@ testPostgresqlNullsOrdering = do 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 + ret <- select $ do + p <- from $ table @Person + orderBy [EP.descNullsLast (p ^. PersonAge), EP.descNullsLast (p ^. PersonFavNum)] + pure p -- nulls come last asserting $ ret `shouldBe` [ p1e, p4e, p3e, p2e ] @@ -1995,7 +1995,6 @@ spec = beforeAll mkConnectionPool $ do describe "PostgreSQL specific tests" $ do testAscRandom random_ - testRandomMath testSelectDistinctOn testPostgresModule testPostgresqlOneAscOneDesc diff --git a/test/SQLite/LegacyTest.hs b/test/SQLite/LegacyTest.hs index 185c3f69c..51ebe3b19 100644 --- a/test/SQLite/LegacyTest.hs +++ b/test/SQLite/LegacyTest.hs @@ -134,7 +134,6 @@ spec = beforeAll mkConnectionPool $ do describe "SQLite specific tests" $ do testAscRandom random_ - testRandomMath testSqliteRandom testSqliteSum testSqliteTwoAscFields diff --git a/test/SQLite/Test.hs b/test/SQLite/Test.hs index b432a4a64..e56a54fa3 100644 --- a/test/SQLite/Test.hs +++ b/test/SQLite/Test.hs @@ -135,7 +135,6 @@ spec = beforeAll mkConnectionPool $ do describe "SQLite specific tests" $ do testAscRandom random_ - testRandomMath testSqliteRandom testSqliteSum testSqliteTwoAscFields From a9a3a030ed56852d199b73ec56d17c9e977e2691 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 27 Dec 2024 10:44:06 -0700 Subject: [PATCH 33/37] remove cruft --- src/Database/Esqueleto/Internal/Internal.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 809f0f51a..f692c9973 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -3934,7 +3934,6 @@ 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 @@ -3988,7 +3987,6 @@ 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 @@ -4045,7 +4043,6 @@ 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 @@ -4105,7 +4102,6 @@ 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 @@ -4168,7 +4164,6 @@ 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 From 9298406a7bf7f4a3eb4a072ab2b6bfbc86d0001c Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 27 Dec 2024 10:45:49 -0700 Subject: [PATCH 34/37] remove comments from merge --- src/Database/Esqueleto/Record.hs | 195 ------------------------------- 1 file changed, 195 deletions(-) diff --git a/src/Database/Esqueleto/Record.hs b/src/Database/Esqueleto/Record.hs index 6aa055d8d..8fc597ba6 100644 --- a/src/Database/Esqueleto/Record.hs +++ b/src/Database/Esqueleto/Record.hs @@ -423,31 +423,10 @@ 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" [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] @@ -761,37 +740,12 @@ makeSqlMaybeRecord RecordInfo {..} = do -- | Generates a `ToMaybe` instance for the given record. makeToMaybeInstance :: RecordInfo -> Q [Dec] makeToMaybeInstance info@RecordInfo {..} = do --- <<<<<<< HEAD --- toMaybeTDec' <- toMaybeTDec info --- ======= toMaybeTDec' <- toMaybeTDec sqlName sqlMaybeName --- >>>>>>> master toMaybeDec' <- toMaybeDec info let overlap = Nothing instanceConstraints = [] instanceType = (ConT ''ToMaybe) `AppT` (ConT sqlName) --- <<<<<<< 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. @@ -811,7 +765,6 @@ toMaybeTDec nameLeft nameRight = -- | Generates a `toMaybe value = ...` declaration for the given record. toMaybeDec :: RecordInfo -> Q [Dec] --- >>>>>>> master toMaybeDec RecordInfo {..} = do (fieldPatterns, fieldExps) <- unzip <$> forM (zip sqlFields sqlMaybeFields) (\((fieldName', _), (maybeFieldName', _)) -> do @@ -821,21 +774,6 @@ toMaybeDec RecordInfo {..} = do , (maybeFieldName', VarE 'toMaybe `AppE` VarE fieldPatternName) )) --- <<<<<<< 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) |] @@ -891,118 +829,6 @@ sqlMaybeSelectColsDec RecordInfo {..} = do in foldl' helper (VarE f1) rest identInfo <- newName "identInfo" --- <<<<<<< 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) |] @@ -1072,7 +898,6 @@ sqlMaybeSelectProcessRowDec RecordInfo {..} = do -- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance. sqlMaybeSelectColCountDec :: RecordInfo -> Q [Dec] --- >>>>>>> master sqlMaybeSelectColCountDec RecordInfo {..} = do let joinedTypes = case snd `map` sqlMaybeFields of @@ -1082,27 +907,7 @@ sqlMaybeSelectColCountDec RecordInfo {..} = do InfixT lhs ''(:&) ty in foldl' helper t1 rest --- <<<<<<< 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` From 7821cbed8952aac76f5bbb9a9ab20815c1831baf Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Mon, 13 Jan 2025 15:43:08 -0700 Subject: [PATCH 35/37] Version 3.6.0.0 (#419) * Remove `Coercible` abiilty for `SqlExpr`. (#413) * Remove Coercible * Remove coercible * update docs and changelog * Support upsert with empty updates (#301) * Support upsert with empty updates * stylish, changelog link * clean * remove focus * oh no * update with new api * tests pass * Fix distinctOn (#287) * Fix distinctOn * lol * expose * Deprecation Cycles for 3.6 (#412) * Deprecate ilike outside of Postgres * lol * Deprecation Cycling * wow okay cool * oh woops * Add fixity on question-dot operator (#420) * Add fixity on question-dot operator * changelog link * Deprecate LockingKind constructors (#421) * Deprecate LockingKind constructors * changelog * `HasField` for `SqlExpr (Maybe (Entity a))` joins `Maybe` (#422) * HasField on SqlExpr (Maybe Entity) joins Maybe * hmmm that works kinda nicely * Incorporate changes from the work codebase * add another test case * changelog * wat * wat * wat * 3.6 fixups (#425) * Re-export Nullable from ToMaybe * Fixity on ilike * lolwhoops * changelog link * add toBaseIdMaybe and fromBaseIdMaybe * start sketching out the sqlcoerce class * no sqlcoerce yet * ok for convenience --- .github/workflows/haskell.yml | 1 + Makefile | 1 + changelog.md | 78 ++++ esqueleto.cabal | 5 +- examples/Main.hs | 2 +- src/Database/Esqueleto.hs | 12 +- src/Database/Esqueleto/Experimental.hs | 17 +- src/Database/Esqueleto/Experimental/From.hs | 4 - .../Experimental/From/SqlSetOperation.hs | 25 -- .../Esqueleto/Experimental/ToAlias.hs | 3 - .../Experimental/ToAliasReference.hs | 6 +- .../Esqueleto/Experimental/ToMaybe.hs | 7 +- src/Database/Esqueleto/Internal/Internal.hs | 339 ++++++++++++++---- src/Database/Esqueleto/Legacy.hs | 12 +- src/Database/Esqueleto/MySQL.hs | 15 +- src/Database/Esqueleto/PostgreSQL.hs | 249 +++++++++++-- stack-9.0.yaml | 3 +- test/Common/Test.hs | 114 +++--- test/Common/Test/Models.hs | 1 - test/PostgreSQL/Test.hs | 99 ++--- test/SQLite/Test.hs | 1 - test/Spec.hs | 1 - 22 files changed, 711 insertions(+), 284 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 7a1d5c20c..40b6d9041 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -69,6 +69,7 @@ jobs: # mysql database: 'esqutest' # Optional, default value is "test". The specified database which will be create # mysql user: 'travis' # Required if "mysql root password" is empty, default is empty. The superuser for the specified database. Can use secrets, too # mysql password: 'esqutest' # Required if "mysql user" exists. The password for the "mysql user" + - run: sudo apt-get update && sudo apt-get install -y libpcre3-dev - run: cabal v2-update - run: cabal v2-freeze $CONFIG - uses: actions/cache@v4 diff --git a/Makefile b/Makefile index f0b35becc..7ac864507 100644 --- a/Makefile +++ b/Makefile @@ -58,6 +58,7 @@ clean: $(STACK) clean .PHONY: init-pgsql + init-pgsql: sudo -u postgres -- createuser -s esqutest diff --git a/changelog.md b/changelog.md index 8af2057e5..2049c6c60 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,81 @@ +3.6.0.0 +======= +- @parsonsmatt + - [#422](https://github.com/bitemyapp/esqueleto/pull/422) + - The instance of `HasField` for `SqlExpr (Maybe (Entity a))` joins + `Maybe` values together. This means that if you `leftJoin` a table + with a `Maybe` column, the result will be a `SqlExpr (Value (Maybe + typ))`, instead of `SqlExpr (Value (Maybe (Maybe typ)))`. + - To make this a less breaking change, `joinV` has been given a similar + behavior. If the input type to `joinV` is `Maybe (Maybe typ)`, then + the result becomes `Maybe typ`. If the input type is `Maybe typ`, then + the output is also `Maybe typ`. The `joinV'` function is given as an + alternative with monomorphic behavior. + - The `just` function is also modified to avoid nesting `Maybe`. + Likewise, `just'` is provided to give monomorphic behavior. + - `subSelect`, `max_`, `min_`, and `coalesce` were all + given `Nullable` output types as well. This should help to reduce the + incidence of nested `Maybe`. + - The operator `??.` was introduced which can do nested `Maybe`. You may + want this if you have type inference issues with `?.` combining + `Maybe`. + - [#420](https://github.com/bitemyapp/esqueleto/pull/420) + - Add a fixity declaration to `?.` + - [#412](https://github.com/bitemyapp/esqueleto/pull/412) + - The `random_` and `rand` functions (deprecated in 2.6.0) have been + removed. Please refer to the database specific ones (ie + `Database.Esqueleto.PostgreSQL` etc) + - The `sub_select` function (deprecated in 3.2.0) has been removed. + Please use the safer variants like `subSelect`, `subSelectMaybe`, etc. + - The `ToAliasT` and `ToAliasReferenceT` types has been removed after having been deprecated in 3.4.0.1. + - The `Union` type (deprecated in 3.4) was removed. Please use `union_` + instead. + - The `UnionAll` type (deprecated in 3.4) was removed. Please use + `unionAll_` instead. + - The `Except` type (deprecated in 3.4) was removed. Please use + `except_` instead. + - The `Intersect` type (deprecated in 3.4) was removed. Please use + `intersect_` instead. + - The `SubQuery` type (deprecated in 3.4) was removed. You do not need + to tag subqueries to use them in `from` clauses. + - The `SelectQuery` type (deprecated in 3.4) was removed. You do not + need to tag `SqlQuery` values with `SelectQuery`. + - [#287](https://github.com/bitemyapp/esqueleto/pull/278) + - Deprecate `distinctOn` and `distinctOnOrderBy`. Use the variants + defined in `PostgreSQL` module instead. The signature has changed, but + the refactor is straightforward: + ``` + -- old: + p <- from $ table + distinctOn [don x] $ do + pure p + + -- new: + p <- from $ table + distinctOn [don x] + pure p + ``` + - [#301](https://github.com/bitemyapp/esqueleto/pull/301) + - Postgresql `upsert` and `upsertBy` now require a `NonEmpty` list of + updates. If you want to provide an empty list of updates, you'll need + to use `upsertMaybe` and `upsertMaybeBe` instead. Postgres does not + return rows from the database if no updates are performed. + - [#413](https://github.com/bitemyapp/esqueleto/pull/413) + - The ability to `coerce` `SqlExpr` was removed. Instead, use + `veryUnsafeCoerceSqlExpr`. See the documentation on + `veryUnsafeCoerceSqlExpr` for safe use example. + - `unsafeCeorceSqlExpr` is provided as an option when the underlying + Haskell types are coercible. This is still unsafe, as different + `PersistFieldSql` instances may be at play. + - [#420](https://github.com/bitemyapp/esqueleto/pull/421) + - The `LockingKind` constructors are deprecated, and will be removed + from non-Internal modules in a future release. Smart constructors + replace them, and you may need to import them from a different + database-specific module. + - [#425](https://github.com/bitemyapp/esqueleto/pull/425) + - `fromBaseId` is introduced as the inverse of `toBaseId`. + - `toBaseIdMaybe` and `fromBaseIdMaybe` are introduced. + 3.5.14.0 ======== - @parsonsmatt diff --git a/esqueleto.cabal b/esqueleto.cabal index f5c40ddb8..d412e8512 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -1,8 +1,7 @@ cabal-version: 1.12 name: esqueleto - -version: 3.5.14.0 +version: 3.6.0.0 synopsis: Type-safe EDSL for SQL queries on persistent backends. description: @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends. Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime. . @@ -53,7 +52,7 @@ library hs-source-dirs: src/ build-depends: - base >=4.8 && <5.0 + base >=4.12 && <5.0 , aeson >=1.0 , attoparsec >= 0.13 && < 0.15 , blaze-html diff --git a/examples/Main.hs b/examples/Main.hs index f4cabebb1..78d58791a 100644 --- a/examples/Main.hs +++ b/examples/Main.hs @@ -28,6 +28,7 @@ import Control.Monad.Reader (MonadReader(..), runReaderT) import Control.Monad.Trans.Control (MonadBaseControl) import Database.Esqueleto.Experimental import Database.Persist.Postgresql (ConnectionString, withPostgresqlConn) +import qualified Database.Persist.Sql as Persistent import Database.Persist.TH ( mkMigrate , mkPersist @@ -36,7 +37,6 @@ import Database.Persist.TH , sqlSettings ) - share [ mkPersist sqlSettings , mkMigrate "migrateAll"] [persistLowerCase| Person diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index b4b4c9812..254f0497c 100644 --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -51,14 +51,14 @@ module Database.Esqueleto {-# WARNING "This module will switch over to the Exper -- $gettingstarted -- * @esqueleto@'s Language - where_, on, groupBy, orderBy, rand, asc, desc, limit, offset + where_, on, groupBy, orderBy, asc, desc, limit, offset , distinct, distinctOn, don, distinctOnOrderBy, having, locking - , sub_select, (^.), (?.) - , val, isNothing, just, nothing, joinV, withNonNull + , (^.), (?.) + , val, isNothing, just, just', nothing, joinV, joinV', withNonNull , countRows, count, countDistinct , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , between, (+.), (-.), (/.), (*.) - , random_, round_, ceiling_, floor_ + , round_, ceiling_, floor_ , min_, max_, sum_, avg_, castNum, castNumM , coalesce, coalesceDefault , lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_ @@ -66,7 +66,7 @@ module Database.Esqueleto {-# WARNING "This module will switch over to the Exper , subList_select, valList, justList , in_, notIn, exists, notExists , set, (=.), (+=.), (-=.), (*=.), (/=.) - , case_, toBaseId + , case_, toBaseId, fromBaseId, toBaseIdMaybe, fromBaseIdMaybe , subSelect , subSelectMaybe , subSelectCount @@ -83,6 +83,8 @@ module Database.Esqueleto {-# WARNING "This module will switch over to the Exper , OrderBy , DistinctOn , LockingKind(..) + , forUpdate + , forUpdateSkipLocked , LockableEntity(..) , SqlString -- ** Joins diff --git a/src/Database/Esqueleto/Experimental.hs b/src/Database/Esqueleto/Experimental.hs index edffd3f57..1c0e33648 100644 --- a/src/Database/Esqueleto/Experimental.hs +++ b/src/Database/Esqueleto/Experimental.hs @@ -22,7 +22,6 @@ module Database.Esqueleto.Experimental from , table , Table(..) - , SubQuery(..) , selectQuery -- ** Joins @@ -40,14 +39,9 @@ module Database.Esqueleto.Experimental -- ** Set Operations -- $sql-set-operations , union_ - , Union(..) , unionAll_ - , UnionAll(..) , except_ - , Except(..) , intersect_ - , Intersect(..) - , pattern SelectQuery -- ** Common Table Expressions , with @@ -57,18 +51,16 @@ module Database.Esqueleto.Experimental , From(..) , ToMaybe(..) , ToAlias(..) - , ToAliasT , ToAliasReference(..) - , ToAliasReferenceT , ToSqlSetOperation(..) , SqlSelect + , Nullable -- * The Normal Stuff , where_ , groupBy , groupBy_ , orderBy - , rand , asc , desc , limit @@ -80,8 +72,9 @@ module Database.Esqueleto.Experimental , distinctOnOrderBy , having , locking + , forUpdate + , forUpdateSkipLocked - , sub_select , (^.) , (?.) @@ -113,7 +106,6 @@ module Database.Esqueleto.Experimental , (/.) , (*.) - , random_ , round_ , ceiling_ , floor_ @@ -162,6 +154,9 @@ module Database.Esqueleto.Experimental , case_ , toBaseId + , toBaseIdMaybe + , fromBaseId + , fromBaseIdMaybe , subSelect , subSelectMaybe , subSelectCount diff --git a/src/Database/Esqueleto/Experimental/From.hs b/src/Database/Esqueleto/Experimental/From.hs index e9d391899..1a844f67e 100644 --- a/src/Database/Esqueleto/Experimental/From.hs +++ b/src/Database/Esqueleto/Experimental/From.hs @@ -98,10 +98,6 @@ table = From $ do ) -{-# DEPRECATED SubQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SubQuery@" #-} -newtype SubQuery a = SubQuery a -instance (SqlSelect a r, ToAlias a, ToAliasReference 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 toFrom = selectQuery diff --git a/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs b/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs index c4e9145a2..63abb62e6 100644 --- a/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs +++ b/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs @@ -74,11 +74,6 @@ mkSetOperation operation lhs rhs = SqlSetOperation $ \p -> do (_, rightClause) <- unSqlSetOperation (toSqlSetOperation rhs) p pure (leftValue, \info -> leftClause info <> (operation, mempty) <> rightClause info) -{-# DEPRECATED Union "/Since: 3.4.0.0/ - Use the 'union_' function instead of the 'Union' data constructor" #-} -data Union a b = a `Union` b -instance ToSqlSetOperation a a' => ToSqlSetOperation (Union a a) a' where - toSqlSetOperation (Union a b) = union_ a b - -- | Overloaded @union_@ function to support use in both 'SqlSetOperation' -- and 'withRecursive' -- @@ -102,30 +97,10 @@ instance (ToSqlSetOperation a c, ToSqlSetOperation b c, res ~ SqlSetOperation c) => UnionAll_ (a -> b -> res) where unionAll_ = mkSetOperation " UNION ALL " -{-# DEPRECATED UnionAll "/Since: 3.4.0.0/ - Use the 'unionAll_' function instead of the 'UnionAll' data constructor" #-} -data UnionAll a b = a `UnionAll` b -instance ToSqlSetOperation a a' => ToSqlSetOperation (UnionAll a a) a' where - toSqlSetOperation (UnionAll a b) = unionAll_ a b - -{-# DEPRECATED Except "/Since: 3.4.0.0/ - Use the 'except_' function instead of the 'Except' data constructor" #-} -data Except a b = a `Except` b -instance ToSqlSetOperation a a' => ToSqlSetOperation (Except a a) a' where - toSqlSetOperation (Except a b) = except_ a b - -- | @EXCEPT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. except_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a' except_ = mkSetOperation " EXCEPT " -{-# DEPRECATED Intersect "/Since: 3.4.0.0/ - Use the 'intersect_' function instead of the 'Intersect' data constructor" #-} -data Intersect a b = a `Intersect` b -instance ToSqlSetOperation a a' => ToSqlSetOperation (Intersect a a) a' where - toSqlSetOperation (Intersect a b) = intersect_ a b - -- | @INTERSECT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. intersect_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a' intersect_ = mkSetOperation " INTERSECT " - -{-# DEPRECATED SelectQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SelectQuery@" #-} -pattern SelectQuery :: p -> p -pattern SelectQuery a = a - diff --git a/src/Database/Esqueleto/Experimental/ToAlias.hs b/src/Database/Esqueleto/Experimental/ToAlias.hs index 1756fe6bf..870d1087f 100644 --- a/src/Database/Esqueleto/Experimental/ToAlias.hs +++ b/src/Database/Esqueleto/Experimental/ToAlias.hs @@ -8,9 +8,6 @@ module Database.Esqueleto.Experimental.ToAlias import Database.Esqueleto.Internal.Internal hiding (From, from, on) import Database.Esqueleto.Internal.PersistentImport -{-# DEPRECATED ToAliasT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-} -type ToAliasT a = a - -- Tedious tuple magic class ToAlias a where toAlias :: a -> SqlQuery a diff --git a/src/Database/Esqueleto/Experimental/ToAliasReference.hs b/src/Database/Esqueleto/Experimental/ToAliasReference.hs index 1f4003b8e..5bee884eb 100644 --- a/src/Database/Esqueleto/Experimental/ToAliasReference.hs +++ b/src/Database/Esqueleto/Experimental/ToAliasReference.hs @@ -5,13 +5,9 @@ module Database.Esqueleto.Experimental.ToAliasReference where -import Data.Coerce import Database.Esqueleto.Internal.Internal hiding (From, from, on) import Database.Esqueleto.Internal.PersistentImport -{-# DEPRECATED ToAliasReferenceT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-} -type ToAliasReferenceT a = a - -- more tedious tuple magic class ToAliasReference a where toAliasReference :: Ident -> a -> SqlQuery a @@ -31,7 +27,7 @@ instance ToAliasReference (SqlExpr (Entity a)) where instance ToAliasReference (SqlExpr (Maybe (Entity a))) where toAliasReference aliasSource e = - coerce <$> toAliasReference aliasSource (coerce e :: SqlExpr (Entity a)) + veryUnsafeCoerceSqlExpr <$> toAliasReference aliasSource (veryUnsafeCoerceSqlExpr e :: SqlExpr (Entity a)) instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a, b) where diff --git a/src/Database/Esqueleto/Experimental/ToMaybe.hs b/src/Database/Esqueleto/Experimental/ToMaybe.hs index 0677bfb9c..18210a039 100644 --- a/src/Database/Esqueleto/Experimental/ToMaybe.hs +++ b/src/Database/Esqueleto/Experimental/ToMaybe.hs @@ -2,15 +2,14 @@ {-# LANGUAGE TypeFamilies #-} module Database.Esqueleto.Experimental.ToMaybe + ( module Database.Esqueleto.Experimental.ToMaybe + , Nullable + ) where import Database.Esqueleto.Internal.Internal hiding (From(..), from, on) import Database.Esqueleto.Internal.PersistentImport (Entity(..)) -type family Nullable a where - Nullable (Maybe a) = a - Nullable a = a - class ToMaybe a where type ToMaybeT a toMaybe :: a -> ToMaybeT a diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 969a65e19..8b7e0d298 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# language AllowAmbiguousTypes #-} +{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} @@ -35,6 +37,8 @@ -- tracker so we can safely support it. module Database.Esqueleto.Internal.Internal where +import Data.Typeable (TypeRep, typeRep) +import Data.Coerce (Coercible) import Control.Applicative ((<|>)) import Control.Arrow (first, (***)) import Control.Exception (Exception, throw, throwIO) @@ -126,7 +130,7 @@ fromStartMaybe = maybelize <$> fromStart maybelize :: PreprocessedFrom (SqlExpr (Entity a)) -> PreprocessedFrom (SqlExpr (Maybe (Entity a))) - maybelize (PreprocessedFrom e f') = PreprocessedFrom (coerce e) f' + maybelize (PreprocessedFrom e f') = PreprocessedFrom (veryUnsafeCoerceSqlExpr e) f' -- | (Internal) Do a @JOIN@. fromJoin @@ -362,12 +366,14 @@ distinct act = Q (W.tell mempty { sdDistinctClause = DistinctStandard }) >> act distinctOn :: [SqlExpr DistinctOn] -> SqlQuery a -> SqlQuery a distinctOn exprs act = Q (W.tell mempty { sdDistinctClause = DistinctOn exprs }) >> act +{-# DEPRECATED distinctOn "This function is deprecated, as it is only supported in Postgresql. Please use the variant in `Database.Esqueleto.PostgreSQL` instead." #-} + -- | Erase an SqlExpression's type so that it's suitable to -- be used by 'distinctOn'. -- -- @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, @@ -401,11 +407,7 @@ distinctOnOrderBy exprs act = $ TLB.toLazyText b , vals ) --- | @ORDER BY random()@ clause. --- --- @since 1.3.10 -rand :: SqlExpr OrderBy -rand = ERaw noMeta $ \_ _ -> ("RANDOM()", []) +{-# DEPRECATED distinctOnOrderBy "This function is deprecated, as it is only supported in Postgresql. Please use the function defined in `Database.Esqueleto.PostgreSQL` instead." #-} -- | @HAVING@. -- @@ -430,29 +432,6 @@ locking kind = putLocking $ LegacyLockingClause kind putLocking :: LockingClause -> SqlQuery () putLocking clause = Q $ W.tell mempty { sdLockingClause = clause } -{-# - DEPRECATED - sub_select - "sub_select \n \ -sub_select is an unsafe function to use. If used with a SqlQuery that \n \ -returns 0 results, then it may return NULL despite not mentioning Maybe \n \ -in the return type. If it returns more than 1 result, then it will throw a \n \ -SQL error.\n\n Instead, consider using one of the following alternatives: \n \ -- subSelect: attaches a LIMIT 1 and the Maybe return type, totally safe. \n \ -- subSelectMaybe: Attaches a LIMIT 1, useful for a query that already \n \ - has a Maybe in the return type. \n \ -- subSelectCount: Performs a count of the query - this is always safe. \n \ -- subSelectUnsafe: Performs no checks or guarantees. Safe to use with \n \ - countRows and friends." - #-} --- | Execute a subquery @SELECT@ in an SqlExpression. Returns a --- simple value so should be used only when the @SELECT@ query --- is guaranteed to return just one row. --- --- Deprecated in 3.2.0. -sub_select :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) -sub_select = sub SELECT - -- | Execute a subquery @SELECT@ in a 'SqlExpr'. The query passed to this -- function will only return a single result - it has a @LIMIT 1@ passed in to -- the query to make it safe, and the return type is 'Maybe' to indicate that @@ -470,9 +449,9 @@ sub_select = sub SELECT -- -- @since 3.2.0 subSelect - :: PersistField a + :: (PersistField a, NullableFieldProjection a a') => SqlQuery (SqlExpr (Value a)) - -> SqlExpr (Value (Maybe a)) + -> SqlExpr (Value (Maybe a')) subSelect query = just (subSelectUnsafe (query <* limit 1)) -- | Execute a subquery @SELECT@ in a 'SqlExpr'. This function is a shorthand @@ -623,12 +602,28 @@ withNonNull field f = do where_ $ not_ $ isNothing field f $ veryUnsafeCoerceSqlExprValue field +-- | Project an 'EntityField' of a nullable entity. The result type will be +-- 'Nullable', meaning that nested 'Maybe' won't be produced here. +-- +-- As of v3.6.0.0, this will attempt to combine nested 'Maybe'. If you want to +-- keep nested 'Maybe', then see '??.'. +(?.) :: (PersistEntity val , PersistField typ) + => SqlExpr (Maybe (Entity val)) + -> EntityField val typ + -> SqlExpr (Value (Maybe (Nullable typ))) +ent ?. field = veryUnsafeCoerceSqlExprValue (ent ??. field) + -- | Project a field of an entity that may be null. -(?.) :: ( PersistEntity val , PersistField typ) +-- +-- This variant will produce a nested 'Maybe' if you select a 'Maybe' column. +-- If you want to collapse 'Maybe', see '?.'. +-- +-- @since 3.6.0.0 +(??.) :: ( PersistEntity val , PersistField typ) => SqlExpr (Maybe (Entity val)) -> EntityField val typ -> SqlExpr (Value (Maybe typ)) -ERaw m f ?. field = just (ERaw m f ^. field) +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) @@ -680,18 +675,52 @@ 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)) +-- +-- This function will try not to produce a nested 'Maybe'. This is in accord +-- with how SQL represents @NULL@. That means that @'just' . 'just' = 'just'@. +-- This behavior was changed in v3.6.0.0. If you want to produce nested 'Maybe', +-- see 'just''. +just + :: (NullableFieldProjection typ typ') + => SqlExpr (Value typ) -> SqlExpr (Value (Maybe typ')) just = veryUnsafeCoerceSqlExprValue +-- | Like 'just', but this function does not try to collapse nested 'Maybe'. +-- This may be useful if you have type inference problems with 'just'. +-- +-- @since 3.6.0.0 +just' :: SqlExpr (Value typ) -> SqlExpr (Value (Maybe typ)) +just' = veryUnsafeCoerceSqlExprValue + -- | @NULL@ value. nothing :: SqlExpr (Value (Maybe typ)) nothing = unsafeSqlValue "NULL" -- | Join nested 'Maybe's in a 'Value' into one. This is useful when -- calling aggregate functions on nullable fields. -joinV :: SqlExpr (Value (Maybe (Maybe typ))) -> SqlExpr (Value (Maybe typ)) +-- +-- As of v3.6.0.0, this function will attempt to work on both @'SqlExpr' +-- ('Value' ('Maybe' a))@ as well as @'SqlExpr' ('Value' ('Maybe' ('Maybe' a)))@ +-- inputs to make transitioning to 'NullableFieldProjection' easier. This may +-- make type inference worse in some cases. If you want the monomorphic variant, +-- see 'joinV'' +joinV + :: (NullableFieldProjection typ typ') + => SqlExpr (Value (Maybe typ)) + -> SqlExpr (Value (Maybe typ')) joinV = veryUnsafeCoerceSqlExprValue +-- | Like 'joinV', but monomorphic: the input type only works on @'SqlExpr' +-- ('Value' (Maybe (Maybe a)))@. +-- +-- This function may be useful if you have type inference issues with 'joinV'. +-- +-- @since 3.6.0.0 +joinV' + :: SqlExpr (Value (Maybe (Maybe typ))) + -> SqlExpr (Value (Maybe typ)) +joinV' = veryUnsafeCoerceSqlExprValue + countHelper :: Num a => TLB.Builder -> TLB.Builder -> SqlExpr (Value typ) -> SqlExpr (Value a) countHelper open close v = @@ -886,9 +915,6 @@ not_ v = ERaw noMeta (const $ first ("NOT " <>) . x) between :: PersistField a => SqlExpr (Value a) -> (SqlExpr (Value a), SqlExpr (Value a)) -> SqlExpr (Value Bool) a `between` (b, c) = a >=. b &&. a <=. c -random_ :: (PersistField a, Num a) => SqlExpr (Value a) -random_ = unsafeSqlValue "RANDOM()" - round_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr (Value a) -> SqlExpr (Value b) round_ = unsafeSqlFunction "ROUND" @@ -900,12 +926,21 @@ floor_ = unsafeSqlFunction "FLOOR" sum_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr (Value (Maybe b)) sum_ = unsafeSqlFunction "SUM" -min_ :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe a)) -min_ = unsafeSqlFunction "MIN" -max_ :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe a)) -max_ = unsafeSqlFunction "MAX" -avg_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr (Value (Maybe b)) -avg_ = unsafeSqlFunction "AVG" + +min_ + :: (PersistField a) + => SqlExpr (Value a) + -> SqlExpr (Value (Maybe (Nullable a))) +min_ = unsafeSqlFunction "MIN" + +max_ + :: (PersistField a) + => SqlExpr (Value a) + -> SqlExpr (Value (Maybe (Nullable a))) +max_ = unsafeSqlFunction "MAX" + +avg_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr (Value (Maybe b)) +avg_ = unsafeSqlFunction "AVG" -- | Allow a number of one type to be used as one of another -- type via an implicit cast. An explicit cast is not made, @@ -940,7 +975,10 @@ castNumM = veryUnsafeCoerceSqlExprValue -- documentation. -- -- @since 1.4.3 -coalesce :: PersistField a => [SqlExpr (Value (Maybe a))] -> SqlExpr (Value (Maybe a)) +coalesce + :: (PersistField a, NullableFieldProjection a a') + => [SqlExpr (Value (Maybe a))] + -> SqlExpr (Value (Maybe a')) coalesce = unsafeSqlFunctionParens "COALESCE" -- | Like @coalesce@, but takes a non-nullable SqlExpression @@ -996,12 +1034,15 @@ like = unsafeSqlBinOp " LIKE " -- | @ILIKE@ operator (case-insensitive @LIKE@). -- --- Supported by PostgreSQL only. +-- Supported by PostgreSQL only. Deprecated in version 3.6.0 in favor of the +-- version available from "Database.Esqueleto.PostgreSQL". -- -- @since 2.2.3 ilike :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value Bool) ilike = unsafeSqlBinOp " ILIKE " +{-# DEPRECATED ilike "Since 3.6.0: `ilike` is only supported on Postgres. Please import it from 'Database.Esqueleto.PostgreSQL." #-} + -- | The string @'%'@. May be useful while using 'like' and -- concatenation ('concat_' or '++.', depending on your -- database). Note that you always have to type the parenthesis, @@ -1014,13 +1055,19 @@ ilike = unsafeSqlBinOp " ILIKE " (%) = unsafeSqlValue "'%'" -- | The @CONCAT@ function with a variable number of --- parameters. Supported by MySQL and PostgreSQL. +-- parameters. Supported by MySQL and PostgreSQL. SQLite supports this in +-- versions after 3.44.0, and @persistent-sqlite@ supports this in versions +-- @2.13.3.0@ and after. concat_ :: SqlString s => [SqlExpr (Value s)] -> SqlExpr (Value s) concat_ = unsafeSqlFunction "CONCAT" -- | The @||@ string concatenation operator (named after -- Haskell's '++' in order to avoid naming clash with '||.'). +-- -- Supported by SQLite and PostgreSQL. +-- +-- MySQL support requires setting the SQL mode to @PIPES_AS_CONCAT@ or @ANSI@ +-- - see . (++.) :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value s) (++.) = unsafeSqlBinOp " || " @@ -1167,13 +1214,13 @@ field /=. expr = setAux field (\ent -> ent ^. field /. expr) -- 'from' $ \\p -> do -- 'where_' (p '^.' PersonName '==.' 'val' \"Mike\")) -- 'then_' --- ('sub_select' $ +-- ('subSelect' $ -- 'from' $ \\v -> do -- let sub = -- 'from' $ \\c -> do -- 'where_' (c '^.' PersonName '==.' 'val' \"Mike\") -- return (c '^.' PersonFavNum) --- 'where_' (v '^.' PersonFavNum >. 'sub_select' sub) +-- 'where_' ('just' (v '^.' PersonFavNum) >. 'subSelect' sub) -- return $ 'count' (v '^.' PersonName) +. 'val' (1 :: Int)) ] -- ('else_' $ 'val' (-1)) -- @ @@ -1239,12 +1286,67 @@ case_ = unsafeSqlCase toBaseId :: ToBaseId ent => SqlExpr (Value (Key ent)) -> SqlExpr (Value (Key (BaseEnt ent))) toBaseId = veryUnsafeCoerceSqlExprValue -{-# DEPRECATED random_ "Since 2.6.0: `random_` is not uniform across all databases! Please use a specific one such as 'Database.Esqueleto.PostgreSQL.random_', 'Database.Esqueleto.MySQL.random_', or 'Database.Esqueleto.SQLite.random_'" #-} +-- | Like 'toBaseId', but works on 'Maybe' keys. +-- +-- @since 3.6.0.0 +toBaseIdMaybe + :: (ToBaseId ent) + => SqlExpr (Value (Maybe (Key ent))) + -> SqlExpr (Value (Maybe (Key (BaseEnt ent)))) +toBaseIdMaybe = veryUnsafeCoerceSqlExprValue + +-- | The inverse of 'toBaseId'. Note that this is somewhat less "safe" than +-- 'toBaseId'. Calling 'toBaseId' will usually mean that a foreign key +-- constraint is present that guarantees the presence of the base ID. +-- 'fromBaseId' has no such guarantee. Consider the code example given in +-- 'toBaseId': +-- +-- @ +-- Bar +-- barNum Int +-- Foo +-- bar BarId +-- fooNum Int +-- Primary bar +-- @ +-- +-- @ +-- instance ToBaseId Foo where +-- type BaseEnt Foo = Bar +-- toBaseIdWitness barId = FooKey barId +-- @ +-- +-- The type of 'toBaseId' for @Foo@ would be: +-- +-- @ +-- toBaseId :: SqlExpr (Value FooId) -> SqlExpr (Value BarId) +-- @ +-- +-- The foreign key constraint on @Foo@ means that every @FooId@ points to +-- a @BarId@ in the database. However, 'fromBaseId' will not have this: +-- +-- @ +-- fromBaseId :: SqlExpr (Value BarId) -> SqlExpr (Value FooId) +-- @ +-- +-- @since 3.6.0.0 +fromBaseId + :: (ToBaseId ent) + => SqlExpr (Value (Key (BaseEnt ent))) + -> SqlExpr (Value (Key ent)) +fromBaseId = veryUnsafeCoerceSqlExprValue -{-# DEPRECATED rand "Since 2.6.0: `rand` ordering function is not uniform across all databases! To avoid accidental partiality it will be removed in the next major version." #-} +-- | As 'fromBaseId', but works on 'Maybe' keys. +-- +-- @since 3.6.0.0 +fromBaseIdMaybe + :: (ToBaseId ent) + => SqlExpr (Value (Maybe (Key (BaseEnt ent)))) + -> SqlExpr (Value (Maybe (Key ent))) +fromBaseIdMaybe = veryUnsafeCoerceSqlExprValue -- Fixity declarations -infixl 9 ^. +infixl 9 ^., ?. infixl 7 *., /. infixl 6 +., -. infixr 5 ++. @@ -1591,6 +1693,32 @@ data LockingKind -- -- @since 2.2.7 +{-# DEPRECATED ForUpdate, ForUpdateSkipLocked "The constructors for 'LockingKind' are deprecated in v3.6.0.0. Instead, please refer to the smart constructors 'forUpdate' and 'forUpdateSkipLocked'." #-} +{-# DEPRECATED ForShare "The constructors for 'LockingKind' are deprecated in v3.6.0.0. Instead, please refer to the smart constructor 'forShare' exported from Database.Esqueleto.PostgreSQL." #-} +{-# DEPRECATED LockInShareMode "The constructors for 'LockingKind' are deprecated in v3.6.0.0. Instead, please refer to the smart constructors 'lockInShareMode' exported from Database.Esqueleto.MySQL." #-} + +-- | @FOR UPDATE@ syntax. +-- +-- Usage: +-- +-- @ +-- 'locking' 'forUpdate' +-- @ +-- +-- @since 3.6.0.0 +forUpdate :: LockingKind +forUpdate = ForUpdate + +-- | @FOR UPDATE SKIP LOCKED@ syntax. +-- +-- @ +-- 'locking' 'forUpdateSkipLocked' +-- @ +-- +-- @since 3.6.0.0 +forUpdateSkipLocked :: LockingKind +forUpdateSkipLocked = ForUpdateSkipLocked + -- | Postgres specific locking, used only internally -- -- @since 3.5.9.0 @@ -2340,12 +2468,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. -- @@ -2357,6 +2485,51 @@ entityAsValueMaybe = coerce -- interpolated by the SQL backend. data SqlExpr a = ERaw SqlExprMeta (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])) +type role SqlExpr nominal + +-- | The type @'SqlExpr' a@ represents a SQL expression that evaluates to +-- a value that can be parsed in Haskell to an @a@. There are often many +-- underlying SQL values that can parse exactly. The function +-- 'veryUnsafeCoerceSqlExpr' allows you to change this type. +-- +-- There is no guarantee that the result works! To be safe, you want to provide +-- a local helper function that calls this at a tested type. +-- +-- As an example, you may know that two types share an identical SQL +-- representation, and can be parsed exactly the same way. Perhaps you have +-- a @data SomeEnum@ which you represent as a @TEXT@ in Postgres, and you +-- want to treat it as a @TEXT@. You could define a top-level +-- type-restricted alias to this which allows this to be done safely: +-- +-- @ +-- enumToText :: SqlExpr (Value SomeEnum) -> SqlExpr (Value Text) +-- enumToText = veryUnsafeCoerceSqlExpr +-- @ +-- +-- Note that this is fragile: if you change the encoding of 'SomeEnum' to +-- be anything other than 'Text', then your code will fail at runtime. +-- +-- @since 3.6.0.0 +veryUnsafeCoerceSqlExpr :: SqlExpr a -> SqlExpr b +veryUnsafeCoerceSqlExpr (ERaw m k) = ERaw m k + +-- | While 'veryUnsafeCoerceSqlExpr' allows you to coerce anything at all, this +-- requires that the two types are 'Coercible' in Haskell. This is not truly +-- safe: after all, the point of @newtype@ is to allow you to provide different +-- instances of classes like 'PersistFieldSql' and 'SqlSelect'. Using this may +-- break your code if you change the underlying SQL representation. +-- +-- @since 3.6.0.0 +unsafeCoerceSqlExpr :: (Coercible a b) => SqlExpr a -> SqlExpr b +unsafeCoerceSqlExpr = veryUnsafeCoerceSqlExpr + +-- | Like 'unsafeCoerceSqlExpr' but for the common case where you are +-- coercing a 'Value'. +-- +-- @since 3.6.0.0 +unsafeCoerceSqlExprValue :: (Coercible a b) => SqlExpr (Value a) -> SqlExpr (Value b) +unsafeCoerceSqlExprValue = veryUnsafeCoerceSqlExpr + -- | Folks often want the ability to promote a Haskell function into the -- 'SqlExpr' expression language - and naturally reach for 'fmap'. -- Unfortunately, this is impossible. We cannot send *functions* to the @@ -2472,11 +2645,43 @@ instance -- -- @since 3.5.4.0 instance - (PersistEntity rec, PersistField typ, SymbolToField sym rec typ) + (PersistEntity rec, PersistField typ, PersistField typ', SymbolToField sym rec typ + , NullableFieldProjection typ typ' + , HasField sym (SqlExpr (Maybe (Entity rec))) (SqlExpr (Value (Maybe typ'))) + ) => - HasField sym (SqlExpr (Maybe (Entity rec))) (SqlExpr (Value (Maybe typ))) + HasField sym (SqlExpr (Maybe (Entity rec))) (SqlExpr (Value (Maybe typ'))) where - getField expr = expr ?. symbolToField @sym + getField expr = veryUnsafeCoerceSqlExpr (expr ?. symbolToField @sym) + +-- | The 'NullableFieldProjection' type is used to determine whether +-- a 'Maybe' should be stripped off or not. This is used in the 'HasField' +-- for @'SqlExpr' ('Maybe' ('Entity' a))@ to allow you to only have +-- a single level of 'Maybe'. +-- +-- @ +-- MyTable +-- column Int Maybe +-- someTableId SomeTableId +-- +-- select $ do +-- (_ :& maybeMyTable) <- +-- from $ table @SomeTable +-- `leftJoin` table @MyTable +-- `on` do +-- \(someTable :& maybeMyTable) -> +-- just someTable.id ==. maybeMyTable.someTableId +-- where_ $ maybeMyTable.column ==. just (val 10) +-- pure maybeMyTable +-- @ +-- +-- Without this class, projecting a field with type @'Maybe' typ@ would +-- have resulted in a @'SqlExpr' ('Value' ('Maybe' ('Maybe' typ)))@. +-- +-- @since 3.6.0.0 +class NullableFieldProjection typ typ' +instance {-# incoherent #-} (typ ~ typ') => NullableFieldProjection (Maybe typ) typ' +instance {-# overlappable #-} (typ ~ typ') => NullableFieldProjection typ typ' -- | Data type to support from hack data PreprocessedFrom a = PreprocessedFrom a FromClause @@ -2826,14 +3031,20 @@ instance ( UnsafeSqlFunctionArgument a -- | (Internal) Coerce a value's type from 'SqlExpr (Value a)' to -- 'SqlExpr (Value b)'. You should /not/ use this function -- unless you know what you're doing! +-- +-- This is an alias for 'veryUnsafeCoerceSqlExpr' with the type fixed to +-- 'Value'. veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b) -veryUnsafeCoerceSqlExprValue = coerce +veryUnsafeCoerceSqlExprValue = veryUnsafeCoerceSqlExpr -- | (Internal) Coerce a value's type from 'SqlExpr (ValueList -- a)' to 'SqlExpr (Value a)'. Does not work with empty lists. +-- +-- This is an alias for 'veryUnsafeCoerceSqlExpr', with the type fixed to +-- 'ValueList' and 'Value'. veryUnsafeCoerceSqlExprValueList :: SqlExpr (ValueList a) -> SqlExpr (Value a) -veryUnsafeCoerceSqlExprValueList = coerce +veryUnsafeCoerceSqlExprValueList = veryUnsafeCoerceSqlExpr ---------------------------------------------------------------------- @@ -3257,7 +3468,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 (veryUnsafeCoerceSqlExpr e :: SqlExpr (Value a)) withCols v = v <> sqlSelectCols info ret plain v = (v, []) @@ -3513,7 +3724,7 @@ 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)) + sqlSelectCols info e = sqlSelectCols info (veryUnsafeCoerceSqlExpr e :: SqlExpr (Entity a)) sqlSelectColCount = sqlSelectColCount . fromEMaybe where fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e) @@ -4251,3 +4462,7 @@ associateJoin = foldr f start (\(oneOld, manyOld) (_, manyNew) -> (oneOld, manyNew ++ manyOld )) (entityKey one) (entityVal one, [many]) + +type family Nullable a where + Nullable (Maybe a) = a + Nullable a = a diff --git a/src/Database/Esqueleto/Legacy.hs b/src/Database/Esqueleto/Legacy.hs index debe44ce3..62b801f6d 100644 --- a/src/Database/Esqueleto/Legacy.hs +++ b/src/Database/Esqueleto/Legacy.hs @@ -52,14 +52,14 @@ module Database.Esqueleto.Legacy -- $gettingstarted -- * @esqueleto@'s Language - where_, on, groupBy, orderBy, rand, asc, desc, limit, offset + where_, on, groupBy, orderBy, asc, desc, limit, offset , distinct, distinctOn, don, distinctOnOrderBy, having, locking - , sub_select, (^.), (?.) - , val, isNothing, just, nothing, joinV, withNonNull + , (^.), (?.) + , val, isNothing, just, just', nothing, joinV, joinV', withNonNull , countRows, count, countDistinct , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , between, (+.), (-.), (/.), (*.) - , random_, round_, ceiling_, floor_ + , round_, ceiling_, floor_ , min_, max_, sum_, avg_, castNum, castNumM , coalesce, coalesceDefault , lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_ @@ -67,7 +67,7 @@ module Database.Esqueleto.Legacy , subList_select, valList, justList , in_, notIn, exists, notExists , set, (=.), (+=.), (-=.), (*=.), (/=.) - , case_, toBaseId + , case_, toBaseId, fromBaseId, fromBaseIdMaybe, toBaseIdMaybe , subSelect , subSelectMaybe , subSelectCount @@ -84,6 +84,8 @@ module Database.Esqueleto.Legacy , OrderBy , DistinctOn , LockingKind(..) + , forUpdate + , forUpdateSkipLocked , LockableEntity(..) , SqlString -- ** Joins diff --git a/src/Database/Esqueleto/MySQL.hs b/src/Database/Esqueleto/MySQL.hs index 4182fc67c..44553fec9 100644 --- a/src/Database/Esqueleto/MySQL.hs +++ b/src/Database/Esqueleto/MySQL.hs @@ -5,6 +5,7 @@ -- @since 2.2.8 module Database.Esqueleto.MySQL ( random_ + , lockInShareMode ) where import Database.Esqueleto.Internal.Internal hiding (random_) @@ -13,6 +14,18 @@ import Database.Esqueleto.Internal.PersistentImport -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. -- --- /Since: 2.6.0/ +-- @since 2.6.0 random_ :: (PersistField a, Num a) => SqlExpr (Value a) random_ = unsafeSqlValue "RAND()" + +-- | @LOCK IN SHARE MODE@ syntax. +-- +-- Example: +-- +-- @ +-- 'locking' 'lockInShareMode' +-- @ +-- +-- @since 3.6.0.0 +lockInShareMode :: LockingKind +lockInShareMode = LockInShareMode diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 5bb4bde5c..430b083d6 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -9,7 +9,7 @@ -- | This module contain PostgreSQL-specific functions. -- --- @since: 2.2.8 +-- @since 2.2.8 module Database.Esqueleto.PostgreSQL ( AggMode(..) , arrayAggDistinct @@ -24,7 +24,9 @@ module Database.Esqueleto.PostgreSQL , now_ , random_ , upsert + , upsertMaybe , upsertBy + , upsertMaybeBy , insertSelectWithConflict , insertSelectWithConflictCount , noWait @@ -32,10 +34,14 @@ module Database.Esqueleto.PostgreSQL , skipLocked , forUpdateOf , forNoKeyUpdateOf + , forShare , forShareOf , forKeyShareOf , filterWhere , values + , ilike + , distinctOn + , distinctOnOrderBy , withMaterialized , withNotMaterialized , ascNullsFirst @@ -46,9 +52,6 @@ module Database.Esqueleto.PostgreSQL , unsafeSqlAggregateFunction ) where -#if __GLASGOW_HASKELL__ < 804 -import Data.Semigroup -#endif import Control.Arrow (first) import Control.Exception (throw) import Control.Monad (void) @@ -59,6 +62,7 @@ import Data.Int (Int64) import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Proxy (Proxy(..)) +import qualified Data.Text as Text import qualified Data.Text.Internal.Builder as TLB import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB @@ -69,10 +73,14 @@ 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.Internal hiding + (From(..), ilike, distinctOn, distinctOnOrderBy, from, on, random_) import Database.Esqueleto.Internal.PersistentImport hiding (uniqueFields, upsert, upsertBy) +import Database.Persist (ConstraintNameDB(..), EntityNameDB(..)) +import Database.Persist.Class (OnlyOneUniqueKey) import Database.Persist.SqlBackend +import GHC.Stack -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. @@ -81,6 +89,69 @@ import Database.Persist.SqlBackend random_ :: (PersistField a, Num a) => SqlExpr (Value a) random_ = unsafeSqlValue "RANDOM()" +-- | @DISTINCT ON@. Change the current @SELECT@ into +-- @SELECT DISTINCT ON (SqlExpressions)@. For example: +-- +-- @ +-- select $ do +-- foo <- 'from' $ table \@Foo +-- 'distinctOn' ['don' (foo ^. FooName), 'don' (foo ^. FooState)] +-- pure foo +-- @ +-- +-- You can also chain different calls to 'distinctOn'. The +-- above is equivalent to: +-- +-- @ +-- select $ do +-- foo <- 'from' $ table \@Foo +-- 'distinctOn' ['don' (foo ^. FooName)] +-- 'distinctOn' ['don' (foo ^. FooState)] +-- pure foo +-- @ +-- +-- Each call to 'distinctOn' adds more SqlExpressions. Calls to +-- 'distinctOn' override any calls to 'distinct'. +-- +-- Note that PostgreSQL requires the SqlExpressions on @DISTINCT +-- ON@ to be the first ones to appear on a @ORDER BY@. This is +-- not managed automatically by esqueleto, keeping its spirit +-- of trying to be close to raw SQL. +-- +-- @since 3.6.0 +distinctOn :: [SqlExpr DistinctOn] -> SqlQuery () +distinctOn exprs = Q (W.tell mempty { sdDistinctClause = DistinctOn exprs }) + +-- | A convenience function that calls both 'distinctOn' and +-- 'orderBy'. In other words, +-- +-- @ +-- 'distinctOnOrderBy' [asc foo, desc bar, desc quux] +-- @ +-- +-- is the same as: +-- +-- @ +-- 'distinctOn' [don foo, don bar, don quux] +-- 'orderBy' [asc foo, desc bar, desc quux] +-- ... +-- @ +-- +-- @since 3.6.0.0 +distinctOnOrderBy :: [SqlExpr OrderBy] -> SqlQuery () +distinctOnOrderBy exprs = do + distinctOn (toDistinctOn <$> exprs) + orderBy exprs + where + toDistinctOn :: SqlExpr OrderBy -> SqlExpr DistinctOn + toDistinctOn (ERaw m f) = ERaw m $ \p info -> + let (b, vals) = f p info + in ( TLB.fromLazyText + $ TL.replace " DESC" "" + $ TL.replace " ASC" "" + $ TLB.toLazyText b + , vals ) + -- | Empty array literal. (@val []@) does unfortunately not work emptyArray :: SqlExpr (Value [a]) emptyArray = unsafeSqlValue "'{}'" @@ -198,6 +269,15 @@ chr = unsafeSqlFunction "chr" now_ :: SqlExpr (Value UTCTime) now_ = unsafeSqlFunction "NOW" () +-- | Perform an @upsert@ operation on the given record. +-- +-- If the record exists in the database already, then the updates will be +-- performed on that record. If the record does not exist, then the +-- provided record will be inserted. +-- +-- If you wish to provide an empty list of updates (ie "if the record +-- exists, do nothing"), then you will need to call 'upsertMaybe'. Postgres +-- will not return anything if there are no modifications or inserts made. upsert :: ( MonadIO m @@ -208,17 +288,57 @@ upsert ) => record -- ^ new record to insert - -> [SqlExpr (Entity record) -> SqlExpr Update] + -> NE.NonEmpty (SqlExpr (Entity record) -> SqlExpr Update) -- ^ updates to perform if the record already exists -> R.ReaderT SqlBackend m (Entity record) -- ^ the record in the database after the operation -upsert record updates = do - uniqueKey <- onlyUnique record - upsertBy uniqueKey record updates +upsert record = + upsertBy (onlyUniqueP record) record -upsertBy +-- | Like 'upsert', but permits an empty list of updates to be performed. +-- +-- If no updates are provided and the record already was present in the +-- database, then this will return 'Nothing'. If you want to fetch the +-- record out of the database, you can write: +-- +-- @ +-- mresult <- upsertMaybe record [] +-- case mresult of +-- Nothing -> +-- 'getBy' ('onlyUniqueP' record) +-- Just res -> +-- pure (Just res) +-- @ +-- +-- @since 3.6.0.0 +upsertMaybe + :: + ( MonadIO m + , PersistEntity record + , OnlyOneUniqueKey record + , PersistRecordBackend record SqlBackend + , IsPersistBackend (PersistEntityBackend record) + ) + => record + -- ^ new record to insert + -> [SqlExpr (Entity record) -> SqlExpr Update] + -- ^ updates to perform if the record already exists + -> R.ReaderT SqlBackend m (Maybe (Entity record)) + -- ^ the record in the database after the operation +upsertMaybe rec upds = do + upsertMaybeBy (onlyUniqueP rec) rec upds + +-- | Attempt to insert a @record@ into the database. If the @record@ +-- already exists for the given @'Unique' record@, then a list of updates +-- will be performed. +-- +-- If you provide an empty list of updates, then this function will return +-- 'Nothing' if the record already exists in the database. +-- +-- @since 3.6.0.0 +upsertMaybeBy :: - (MonadIO m + ( MonadIO m , PersistEntity record , IsPersistBackend (PersistEntityBackend record) ) @@ -228,9 +348,9 @@ upsertBy -- ^ new record to insert -> [SqlExpr (Entity record) -> SqlExpr Update] -- ^ updates to perform if the record already exists - -> R.ReaderT SqlBackend m (Entity record) + -> R.ReaderT SqlBackend m (Maybe (Entity record)) -- ^ the record in the database after the operation -upsertBy uniqueKey record updates = do +upsertMaybeBy uniqueKey record updates = do sqlB <- R.ask case getConnUpsertSql sqlB of Nothing -> @@ -240,25 +360,62 @@ upsertBy uniqueKey record updates = do Just upsertSql -> handler sqlB upsertSql where - addVals l = map toPersistValue (toPersistFields record) ++ l ++ persistUniqueToValues uniqueKey - entDef = entityDef (Just record) - updatesText conn = first builderToText $ renderUpdates conn updates -#if MIN_VERSION_persistent(2,11,0) + addVals l = + map toPersistValue (toPersistFields record) ++ l ++ case updates of + [] -> + [] + _ -> + persistUniqueToValues uniqueKey + entDef = + entityDef (Just record) + updatesText conn = + first builderToText $ renderUpdates conn updates uniqueFields = persistUniqueToFieldNames uniqueKey handler sqlB upsertSql = do let (updateText, updateVals) = updatesText sqlB - queryText = + queryTextUnmodified = upsertSql entDef uniqueFields updateText + queryText = + case updates of + [] -> + let + (okay, _bad) = + Text.breakOn "DO UPDATE" queryTextUnmodified + good = + okay <> "DO NOTHING RETURNING ??" + in + good + _ -> + queryTextUnmodified + queryVals = addVals updateVals xs <- rawSql queryText queryVals - pure (head xs) -#else - uDef = toUniqueDef uniqueKey - handler conn f = fmap head $ uncurry rawSql $ - (***) (f entDef (uDef :| [])) addVals $ updatesText conn -#endif + pure (listToMaybe xs) + +upsertBy + :: + ( MonadIO m + , PersistEntity record + , IsPersistBackend (PersistEntityBackend record) + , HasCallStack + ) + => Unique record + -- ^ uniqueness constraint to find by + -> record + -- ^ new record to insert + -> NE.NonEmpty (SqlExpr (Entity record) -> SqlExpr Update) + -- ^ updates to perform if the record already exists + -> R.ReaderT SqlBackend m (Entity record) + -- ^ the record in the database after the operation +upsertBy uniqueKey record updates = do + mrec <- upsertMaybeBy uniqueKey record (NE.toList updates) + case mrec of + Nothing -> + error "non-empty list of updates should have resulted in a row being returned" + Just rec -> + pure rec -- | Inserts into a table the results of a query similar to 'insertSelect' but allows -- to update values that violate a constraint during insertions. @@ -266,10 +423,7 @@ upsertBy uniqueKey record updates = do -- Example of usage: -- -- @ --- share [ mkPersist sqlSettings --- , mkDeleteCascade sqlSettings --- , mkMigrate "migrate" --- ] [persistLowerCase| +-- 'mkPersist' 'sqlSettings' ['persistLowerCase'| -- Bar -- num Int -- deriving Eq Show @@ -279,17 +433,19 @@ upsertBy uniqueKey record updates = do -- deriving Eq Show -- |] -- --- insertSelectWithConflict --- UniqueFoo -- (UniqueFoo undefined) or (UniqueFoo anyNumber) would also work --- (from $ \b -> --- return $ Foo <# (b ^. BarNum) --- ) --- (\current excluded -> --- [FooNum =. (current ^. FooNum) +. (excluded ^. FooNum)] --- ) +-- action = do +-- 'insertSelectWithConflict' +-- UniqueFoo -- (UniqueFoo undefined) or (UniqueFoo anyNumber) would also work +-- (do +-- b <- from $ table \@Bar +-- return $ Foo <# (b ^. BarNum) +-- ) +-- (\\current excluded -> +-- [FooNum =. (current ^. FooNum) +. (excluded ^. FooNum)] +-- ) -- @ -- --- Inserts to table Foo all Bar.num values and in case of conflict SomeFooUnique, +-- Inserts to table @Foo@ all @Bar.num@ values and in case of conflict @SomeFooUnique@, -- the conflicting value is updated to the current plus the excluded. -- -- @since 3.1.3 @@ -500,6 +656,18 @@ forShareOf :: LockableEntity a => a -> OnLockedBehavior -> SqlQuery () forShareOf lockableEntities onLockedBehavior = putLocking $ PostgresLockingClauses [PostgresLockingKind PostgresForShare (Just $ LockingOfClause lockableEntities) onLockedBehavior] +-- | @FOR SHARE@ syntax for Postgres locking. +-- +-- Example use: +-- +-- @ +-- 'locking' 'forShare' +-- @ +-- +-- @since 3.6.0.0 +forShare :: LockingKind +forShare = ForShare + -- | `FOR KEY SHARE OF` syntax for postgres locking -- allows locking of specific tables with a key share lock in a view or join -- @@ -508,6 +676,13 @@ forKeyShareOf :: LockableEntity a => a -> OnLockedBehavior -> SqlQuery () forKeyShareOf lockableEntities onLockedBehavior = putLocking $ PostgresLockingClauses [PostgresLockingKind PostgresForKeyShare (Just $ LockingOfClause lockableEntities) onLockedBehavior] +-- | @ILIKE@ operator (case-insensitive @LIKE@). +-- +-- @since 2.2.3 +ilike :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value Bool) +ilike = unsafeSqlBinOp " ILIKE " +infixr 2 `ilike` + -- | @WITH@ @MATERIALIZED@ clause is used to introduce a -- [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression) -- with the MATERIALIZED keyword. The MATERIALIZED keyword is only supported in PostgreSQL >= version 12. diff --git a/stack-9.0.yaml b/stack-9.0.yaml index 49a504ea7..067a3735e 100644 --- a/stack-9.0.yaml +++ b/stack-9.0.yaml @@ -1,4 +1,4 @@ -resolver: lts-19.13 +resolver: lts-23.1 packages: - '.' @@ -8,7 +8,6 @@ allow-newer: true extra-deps: - lift-type-0.1.0.1 -- persistent-2.14.0.2 nix: packages: [zlib, libmysqlclient, pcre, postgresql] diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 823b4c9a7..6cc42f4d9 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} @@ -32,7 +33,6 @@ module Common.Test ( tests , testLocking , testAscRandom - , testRandomMath , migrateAll , migrateUnique , cleanDB @@ -65,6 +65,7 @@ module Common.Test , DateTruncTest(..) , DateTruncTestId , Key(..) + , assertJust ) where import Common.Test.Import hiding (from, on) @@ -160,19 +161,8 @@ testSubSelect = do pure (n ^. NumbersInt) setup res <- select $ pure $ subSelect query - eres <- try $ do - select $ pure $ sub_select query asserting $ do res `shouldBe` [Value (Just 1)] - case eres of - Left (SomeException _) -> - -- We should receive an exception, but the different database - -- libraries throw different exceptions. Hooray. - pure () - Right v -> - -- This shouldn't happen, but in sqlite land, many things are - -- possible. - v `shouldBe` [Value 1] itDb "is safe for queries that may not return anything" $ do let query = @@ -184,21 +174,8 @@ testSubSelect = do res <- select $ pure $ subSelect query transactionUndo - eres <- try $ do - select $ pure $ sub_select query - asserting $ do res `shouldBe` [Value $ Just 1] - case eres of - Left (_ :: PersistException) -> - -- We expect to receive this exception. However, sqlite evidently has - -- no problems with itDb, so we can't *require* that the exception is - -- thrown. Sigh. - pure () - Right v -> - -- This shouldn't happen, but in sqlite land, many things are - -- possible. - v `shouldBe` [Value 1] describe "subSelectList" $ do itDb "is safe on empty databases as well as good databases" $ do @@ -405,7 +382,7 @@ testSelectFrom = do , (p2e, p2e) ] - itDb "works for a self-join via sub_select" $ do + itDb "works for a self-join via subSelect" $ do p1k <- insert p1 p2k <- insert p2 _f1k <- insert (Follow p1k p2k) @@ -416,7 +393,7 @@ testSelectFrom = do from $ \followB -> do where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed return $ followB ^. FollowFollower - where_ $ followA ^. FollowFollowed ==. sub_select subquery + where_ $ just (followA ^. FollowFollowed) ==. subSelect subquery return followA asserting $ length ret `shouldBe` 2 @@ -744,7 +721,7 @@ testSelectSubQuery = describe "select subquery" $ do _ <- insert' p3 let q = do (name, age) <- - Experimental.from $ SubQuery $ do + Experimental.from $ do p <- Experimental.from $ Table @Person return ( p ^. PersonName, p ^. PersonAge) orderBy [ asc age ] @@ -765,7 +742,7 @@ testSelectSubQuery = describe "select subquery" $ do lord ^. LordId ==. deed ^. DeedOwnerId) return (lord ^. LordId, deed ^. DeedId) q' = do - (lordId, deedId) <- Experimental.from $ SubQuery q + (lordId, deedId) <- Experimental.from q groupBy (lordId) return (lordId, count deedId) (ret :: [(Value (Key Lord), Value Int)]) <- select q' @@ -788,7 +765,7 @@ testSelectSubQuery = describe "select subquery" $ do return (lord ^. LordId, count (deed ^. DeedId)) (ret :: [(Value Int)]) <- select $ do - (lordId, deedCount) <- Experimental.from $ SubQuery q + (lordId, deedCount) <- Experimental.from q where_ $ deedCount >. val (3 :: Int) return (count lordId) @@ -1135,12 +1112,12 @@ testSelectOrderBy = describe "select/orderBy" $ do return p asserting $ ret `shouldBe` [ p1e, p3e, p2e ] - itDb "works with a sub_select" $ do + itDb "works with a subSelect" $ do [p1k, p2k, p3k, p4k] <- mapM insert [p1, p2, p3, p4] [b1k, b2k, b3k, b4k] <- mapM (insert . BlogPost "") [p1k, p2k, p3k, p4k] ret <- select $ from $ \b -> do - orderBy [desc $ sub_select $ + orderBy [desc $ subSelect $ from $ \p -> do where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) return (p ^. PersonName) @@ -1244,8 +1221,8 @@ testCoasleceDefault = describe "coalesce/coalesceDefault" $ do let sub = from $ \p -> do where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) - return $ p ^. PersonAge - return $ coalesceDefault [sub_select sub] (val (42 :: Int)) + pure $ p ^. PersonAge + return $ coalesceDefault [joinV $ subSelect sub] (val (42 :: Int)) asserting $ ret `shouldBe` [ Value (36 :: Int) , Value 42 , Value 17 @@ -1288,7 +1265,7 @@ testUpdate = describe "update" $ do where_ (b ^. BlogPostAuthorId ==. p ^. PersonId) return countRows () <- update $ \p -> do - set p [ PersonAge =. just (sub_select (blogPostsBy p)) ] + set p [ PersonAge =. subSelect (blogPostsBy p) ] ret <- select $ from $ \p -> do orderBy [ asc (p ^. PersonName) ] @@ -1557,31 +1534,6 @@ testInsertsBySelectReturnsCount = do asserting $ ret `shouldBe` [Value (3::Int)] asserting $ cnt `shouldBe` 3 - - - -testRandomMath :: SpecDb -testRandomMath = describe "random_ math" $ - itDb "rand returns result in random order" $ - do - replicateM_ 20 $ do - _ <- insert p1 - _ <- insert p2 - _ <- insert p3 - _ <- insert p4 - _ <- insert $ Person "Jane" Nothing Nothing 0 - _ <- insert $ Person "Mark" Nothing Nothing 0 - _ <- insert $ Person "Sarah" Nothing Nothing 0 - insert $ Person "Paul" Nothing Nothing 0 - ret1 <- fmap (map unValue) $ select $ from $ \p -> do - orderBy [rand] - return (p ^. PersonId) - ret2 <- fmap (map unValue) $ select $ from $ \p -> do - orderBy [rand] - return (p ^. PersonId) - - asserting $ (ret1 == ret2) `shouldBe` False - testMathFunctions :: SpecDb testMathFunctions = do describe "Math-related functions" $ do @@ -1639,16 +1591,16 @@ testCase = do (exists $ from $ \p -> do where_ (p ^. PersonName ==. val "Mike")) then_ - (sub_select $ from $ \v -> do + (subSelect $ from $ \v -> do let sub = from $ \c -> do where_ (c ^. PersonName ==. val "Mike") return (c ^. PersonFavNum) - where_ (v ^. PersonFavNum >. sub_select sub) + where_ (just (v ^. PersonFavNum) >. subSelect sub) return $ count (v ^. PersonName) +. val (1 :: Int)) ] - (else_ $ val (-1)) + (else_ $ just $ val (-1)) - asserting $ ret `shouldBe` [ Value (3) ] + asserting $ ret `shouldBe` [ Value (Just 3) ] testLocking :: SpecDb testLocking = do @@ -2370,7 +2322,7 @@ testExperimentalFrom = do insert_ p3 -- Pretend this isnt all posts upperNames <- select $ do - author <- Experimental.from $ SelectQuery $ Experimental.from $ Table @Person + author <- Experimental.from $ Experimental.from $ Table @Person pure $ upper_ $ author ^. PersonName asserting $ upperNames `shouldMatchList` [ Value "JOHN" @@ -2536,7 +2488,7 @@ testOverloadedRecordDot = describe "OverloadedRecordDot" $ do pure bp.title describe "with SqlExpr (Maybe (Entity rec))" $ do itDb "lets you project from a Maybe record" $ do - select $ do + void $ select $ do p :& mbp <- Experimental.from $ table @Person `leftJoin` table @BlogPost @@ -2545,6 +2497,34 @@ testOverloadedRecordDot = describe "OverloadedRecordDot" $ do just p.id ==. mbp.authorId pure (p.id, mbp.title) + itDb "joins Maybe together" $ do + void $ select $ do + deed :& lord <- + Experimental.from $ + table @Deed + `leftJoin` table @Lord + `Experimental.on` do + \(deed :& lord) -> + lord.id ==. just deed.ownerId + where_ $ lord.dogs >=. just (val 10) + where_ $ joinV lord.dogs >=. just (just (val 10)) + where_ $ lord.dogs >=. just (val (Just 10)) + + itDb "i didn't bork ?." $ do + weights <- select $ do + (pro :& per) <- Experimental.from $ + table @Profile + `leftJoin` table @Person + `Experimental.on` do + \(pro :& per) -> + just (pro ^. #person) ==. per ?. #id + &&. just pro.person ==. per ?. PersonId + pure $ per ?. #weight + asserting $ do + weights `shouldBe` ([] :: [Value (Maybe Int)]) + + + #else it "is only supported in GHC 9.2 or above" $ \_ -> do pending @@ -2573,3 +2553,5 @@ testGetTable = pure (person, blogPost, profile, reply) asserting noExceptions +assertJust :: HasCallStack => Maybe a -> IO a +assertJust = maybe (expectationFailure "Expected Just, got Nothing" >> error "asdf") pure diff --git a/test/Common/Test/Models.hs b/test/Common/Test/Models.hs index 2a1ada117..3041d2252 100644 --- a/test/Common/Test/Models.hs +++ b/test/Common/Test/Models.hs @@ -207,4 +207,3 @@ share [mkPersist sqlSettings, mkMigrate "migrateUnique"] [persistUpperCase| instance ToBaseId ArticleMetadata where type BaseEnt ArticleMetadata = Article toBaseIdWitness articleId = ArticleMetadataKey articleId - diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 62c020051..1818c512a 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -57,6 +57,37 @@ import Common.Test import Common.Test.Import hiding (from, on) import PostgreSQL.MigrateJSON +spec :: Spec +spec = beforeAll mkConnectionPool $ do + tests + + describe "PostgreSQL specific tests" $ do + testAscRandom random_ + testSelectDistinctOn + testPostgresModule + testPostgresqlOneAscOneDesc + testPostgresqlTwoAscFields + testPostgresqlSum + testPostgresqlRandom + testPostgresqlUpdate + testPostgresqlCoalesce + testPostgresqlTextFunctions + testInsertUniqueViolation + testUpsert + testInsertSelectWithConflict + testFilterWhere + testCommonTableExpressions + setDatabaseState insertJsonValues cleanJSON + $ describe "PostgreSQL JSON tests" $ do + testJSONInsertions + testJSONOperators + testLateralQuery + testValuesExpression + testSubselectAliasingBehavior + testPostgresqlLocking + testPostgresqlNullsOrdering + + returningType :: forall a m . m a -> m a returningType a = a @@ -1044,18 +1075,29 @@ testInsertUniqueViolation = sqlErrorHint = ""} testUpsert :: SpecDb -testUpsert = - describe "Upsert test" $ do +testUpsert = describe "Upsert test" $ do itDb "Upsert can insert like normal" $ do - u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"] - liftIO $ entityVal u1e `shouldBe` u1 + u1e <- EP.upsert u1 (pure (OneUniqueName =. val "fifth")) + liftIO $ entityVal u1e `shouldBe` u1 itDb "Upsert performs update on collision" $ do - u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"] - liftIO $ entityVal u1e `shouldBe` u1 - u2e <- EP.upsert u2 [OneUniqueName =. val "fifth"] - liftIO $ entityVal u2e `shouldBe` u2 - u3e <- EP.upsert u3 [OneUniqueName =. val "fifth"] - liftIO $ entityVal u3e `shouldBe` u1{oneUniqueName="fifth"} + u1e <- EP.upsert u1 (pure (OneUniqueName =. val "fifth")) + liftIO $ entityVal u1e `shouldBe` u1 + u2e <- EP.upsert u2 (pure (OneUniqueName =. val "fifth")) + liftIO $ entityVal u2e `shouldBe` u2 + u3e <- EP.upsert u3 (pure (OneUniqueName =. val "fifth")) + liftIO $ entityVal u3e `shouldBe` u1{oneUniqueName="fifth"} + describe "With no updates" $ do + itDb "Works with no updates" $ do + _ <- EP.upsertMaybe u1 [] + pure () + itDb "Works with no updates, twice" $ do + mu1 <- EP.upsertMaybe u1 [] + Entity u1Key u1' <- liftIO $ assertJust mu1 + mu2 <- EP.upsertMaybe u1 { oneUniqueName = "Something Else" } [] + asserting $ do + mu2 `shouldBe` Nothing + -- liftIO $ do + -- u1 `shouldBe` u1' testInsertSelectWithConflict :: SpecDb testInsertSelectWithConflict = @@ -1730,43 +1772,6 @@ 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 - testInsertSelectWithConflict - testFilterWhere - testCommonTableExpressions - setDatabaseState insertJsonValues cleanJSON - $ describe "PostgreSQL JSON tests" $ do - testJSONInsertions - testJSONOperators - testLateralQuery - testValuesExpression - testSubselectAliasingBehavior - testPostgresqlLocking - testPostgresqlNullsOrdering - insertJsonValues :: SqlPersistT IO () insertJsonValues = do insertIt Null diff --git a/test/SQLite/Test.hs b/test/SQLite/Test.hs index 79818ee01..2f1025fe0 100644 --- a/test/SQLite/Test.hs +++ b/test/SQLite/Test.hs @@ -134,7 +134,6 @@ spec = beforeAll mkConnectionPool $ do describe "SQLite specific tests" $ do testAscRandom random_ - testRandomMath testSqliteRandom testSqliteSum testSqliteTwoAscFields diff --git a/test/Spec.hs b/test/Spec.hs index f6201f104..8d0bcd9f7 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -19,4 +19,3 @@ spec = do sequential $ MySQL.spec describe "Postgresql" $ do sequential $ Postgres.spec - From 233e6350aa1de277a1cf53d607a3cdb131f08926 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 15 Apr 2025 16:23:13 -0600 Subject: [PATCH 36/37] Fix export --- src/Database/Esqueleto.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index b530eded8..63d4133fd 100644 --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -63,7 +63,7 @@ module Database.Esqueleto , where_, on, groupBy, orderBy, asc, desc, limit, offset , distinct, distinctOn, don, distinctOnOrderBy, having, locking , (^.), (?.) - , val, isNothing, just, just', nothing, joinV, joinV', withNonNull + , val, isNothing, isNothing_, just, just', nothing, joinV, joinV', withNonNull , countRows, count, countDistinct , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , between, (+.), (-.), (/.), (*.) From 91a7ae41b151f9fa01014956b60aa1555f251742 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 15 Apr 2025 17:42:24 -0600 Subject: [PATCH 37/37] groupBy_ --- src/Database/Esqueleto.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index 63d4133fd..2d3f7f683 100644 --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -129,6 +129,7 @@ module Database.Esqueleto -- * The Normal Stuff , where_ , groupBy + , groupBy_ , orderBy , asc , desc @@ -147,6 +148,7 @@ module Database.Esqueleto , val , isNothing + , isNothing_ , just , nothing , joinV