From 2ace47efaf8f33d1d07b12387ca212280ed67e2d Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 1 May 2024 17:02:48 -0600 Subject: [PATCH 1/2] Update esqueleto-next --- .github/workflows/haskell.yml | 6 +- README.md | 2 +- changelog.md | 55 +++ esqueleto.cabal | 2 +- src/Database/Esqueleto/Experimental.hs | 10 +- .../Esqueleto/Experimental/From/Join.hs | 2 +- .../Esqueleto/Experimental/ToAlias.hs | 124 +++++ .../Experimental/ToAliasReference.hs | 124 +++++ src/Database/Esqueleto/Internal/Internal.hs | 58 ++- src/Database/Esqueleto/PostgreSQL.hs | 3 +- src/Database/Esqueleto/Record.hs | 447 ++++++++++++++++-- test/Common/LegacyTest.hs | 9 +- test/Common/Record.hs | 116 ++++- test/Common/Test.hs | 8 +- test/PostgreSQL/Test.hs | 9 + 15 files changed, 902 insertions(+), 73 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 642759783..8f4e14e87 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -32,13 +32,13 @@ jobs: --health-retries=3 strategy: matrix: - cabal: ["3.6"] - ghc: ["8.6.5", "8.8.4", "8.10.4", "9.0.2", "9.2.2"] + cabal: ["3.10.2.1"] + ghc: ["8.6.5", "8.8.4", "8.10.4", "9.0.2", "9.2.2", "9.4.5", "9.6.2", "9.8.1"] env: CONFIG: "--enable-tests --enable-benchmarks " steps: - uses: actions/checkout@v2 - - uses: haskell/actions/setup@v1 + - uses: haskell/actions/setup@v2 id: setup-haskell-cabal with: ghc-version: ${{ matrix.ghc }} diff --git a/README.md b/README.md index fc347f18e..3bd07f800 100644 --- a/README.md +++ b/README.md @@ -219,7 +219,7 @@ Advantages: - `ON` clause is attached directly to the relevant join, so you never need to worry about how they're ordered, nor will you ever run into bugs where the `on` clause is on the wrong `JOIN` -- The `ON` clause lambda will all the available tables in it. This forbids +- The `ON` clause lambda will exclusively have all the available tables in it. This forbids runtime errors where an `ON` clause refers to a table that isn't in scope yet. - You can join on a table twice, and the aliases work out fine with the `ON` clause. diff --git a/changelog.md b/changelog.md index 922c6d8e1..5113ea968 100644 --- a/changelog.md +++ b/changelog.md @@ -6,6 +6,61 @@ - Change SqlExpr type to alias for new SqlExpr_ allowing for value "contexts". Currently used by window functions to avoid allowing double windowing. This change lays the groundwork for aggregate values as being contextually different from single values. - Add support for window functions in Postgres module +3.5.11.2 +======== +- @arguri + - [#387](https://github.com/bitemyapp/esqueleto/pull/387) + - Fix build for ghc 9.8.1 / template-haskell 2.18 + +3.5.11.0 +======== +- @9999years, @halogenandtoast + - [#378](https://github.com/bitemyapp/esqueleto/pull/378) + - `ToMaybe` instances are now derived for records so you can now left + join them in queries + +3.5.10.3 +======== +- @ttuegel + - [#377](https://github.com/bitemyapp/esqueleto/pull/377) + - Fix Postgres syntax for `noWait` + +3.5.10.2 +======== +- @parsonsmatt + - [#376](https://github.com/bitemyapp/esqueleto/pull/376) + - When using Postgres 15, `LIMIT`, and the `locking` functions, you + could accidentally construct SQL code like: + + > ... LIMIT 1FOR UPDATE ... + + This parsed on Postgres <15, but the new Postgres parser is more + strict, and fails to parse. This PR introduces newlines between each + query chunk, which fixes the issue. + +3.5.10.1 +======== +- @9999years + - [#369](https://github.com/bitemyapp/esqueleto/pull/369) + - Fix `myAge` type in `deriveEsqueletoRecord` documentation + +3.5.10.0 +======== +- @ivanbakel + - [#328](https://github.com/bitemyapp/esqueleto/pull/328) + - Add `ToAlias` instances for 9- to 16-tuples + - Add `ToAliasReference` instances for 9- to 16-tuples +- @parsonsmatt + - [#365](https://github.com/bitemyapp/esqueleto/pull/365) + - Add `isNothing_` and `groupBy_` to avoid name conflicts with + `Data.List` and `Data.Maybe`. + +3.5.9.1 +======= +- @duplode + - [#363](https://github.com/bitemyapp/esqueleto/pull/363) + - Add missing `just` to left join examples in the Haddocks + 3.5.9.0 ======= - @9999years diff --git a/esqueleto.cabal b/esqueleto.cabal index 2cd9fd929..0822af6be 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -68,7 +68,7 @@ library , resourcet >=1.2 , tagged >=0.2 , template-haskell - , text >=0.11 && <2.1 + , text >=0.11 && <2.2 , time >=1.5.0.1 && <=1.13 , transformers >=0.2 , unliftio diff --git a/src/Database/Esqueleto/Experimental.hs b/src/Database/Esqueleto/Experimental.hs index 339909782..de08c880f 100644 --- a/src/Database/Esqueleto/Experimental.hs +++ b/src/Database/Esqueleto/Experimental.hs @@ -65,6 +65,7 @@ module Database.Esqueleto.Experimental {-# WARNING "This module will be removed -- * The Normal Stuff , where_ , groupBy + , groupBy_ , orderBy , rand , asc @@ -85,6 +86,7 @@ module Database.Esqueleto.Experimental {-# WARNING "This module will be removed , val , isNothing + , isNothing_ , just , nothing , joinV @@ -338,8 +340,8 @@ import Database.Esqueleto.Experimental.ToMaybe -- @ -- select $ -- from $ \\(people \`LeftOuterJoin\` blogPosts) -> do --- on (people ^. PersonId ==. blogPosts ?. BlogPostAuthorId) --- where_ (people ^. PersonAge >. val 18) +-- on (just (people ^. PersonId) ==. blogPosts ?. BlogPostAuthorId) +-- where_ (people ^. PersonAge >. just (val 18)) -- pure (people, blogPosts) -- @ -- @@ -353,8 +355,8 @@ import Database.Esqueleto.Experimental.ToMaybe -- from $ table \@Person -- \`leftJoin\` table \@BlogPost -- \`on\` (\\(people :& blogPosts) -> --- people ^. PersonId ==. blogPosts ?. BlogPostAuthorId) --- where_ (people ^. PersonAge >. val 18) +-- just (people ^. PersonId) ==. blogPosts ?. BlogPostAuthorId) +-- where_ (people ^. PersonAge >. just (val 18)) -- pure (people, blogPosts) -- @ -- diff --git a/src/Database/Esqueleto/Experimental/From/Join.hs b/src/Database/Esqueleto/Experimental/From/Join.hs index 40ae03ee7..a4789ed0e 100644 --- a/src/Database/Esqueleto/Experimental/From/Join.hs +++ b/src/Database/Esqueleto/Experimental/From/Join.hs @@ -232,7 +232,7 @@ crossJoinLateral lhs rhsFn = From $ do -- from $ table \@Person -- \`leftJoin\` table \@BlogPost -- \`on\` (\\(p :& bp) -> --- p ^. PersonId ==. bp ?. BlogPostAuthorId) +-- just (p ^. PersonId) ==. bp ?. BlogPostAuthorId) -- @ -- -- @since 3.5.0.0 diff --git a/src/Database/Esqueleto/Experimental/ToAlias.hs b/src/Database/Esqueleto/Experimental/ToAlias.hs index 34b879268..d1eea9a9e 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 2726edda1..9af0d2b83 100644 --- a/src/Database/Esqueleto/Experimental/ToAliasReference.hs +++ b/src/Database/Esqueleto/Experimental/ToAliasReference.hs @@ -93,3 +93,127 @@ instance ( ToAliasReference a a' , ToAliasReference h h' ) => ToAliasReference (a,b,c,d,e,f,g,h) (a',b',c',d',e',f',g',h') where toAliasReference ident x = to8 <$> (toAliasReference ident $ from8 x) + +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + , ToAliasReference i i' + ) => ToAliasReference (a,b,c,d,e,f,g,h,i) (a',b',c',d',e',f',g',h',i') where + toAliasReference ident x = to9 <$> (toAliasReference ident $ from9 x) + +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + , ToAliasReference i i' + , ToAliasReference j j' + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j) (a',b',c',d',e',f',g',h',i',j') where + toAliasReference ident x = to10 <$> (toAliasReference ident $ from10 x) + +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + , ToAliasReference i i' + , ToAliasReference j j' + , ToAliasReference k k' + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k) (a',b',c',d',e',f',g',h',i',j',k') where + toAliasReference ident x = to11 <$> (toAliasReference ident $ from11 x) + +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + , ToAliasReference i i' + , ToAliasReference j j' + , ToAliasReference k k' + , ToAliasReference l l' + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l) (a',b',c',d',e',f',g',h',i',j',k',l') where + toAliasReference ident x = to12 <$> (toAliasReference ident $ from12 x) + +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + , ToAliasReference i i' + , ToAliasReference j j' + , ToAliasReference k k' + , ToAliasReference l l' + , ToAliasReference m m' + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m) (a',b',c',d',e',f',g',h',i',j',k',l',m') where + toAliasReference ident x = to13 <$> (toAliasReference ident $ from13 x) + +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + , ToAliasReference i i' + , ToAliasReference j j' + , ToAliasReference k k' + , ToAliasReference l l' + , ToAliasReference m m' + , ToAliasReference n n' + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m,n) (a',b',c',d',e',f',g',h',i',j',k',l',m',n') where + toAliasReference ident x = to14 <$> (toAliasReference ident $ from14 x) + +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + , ToAliasReference i i' + , ToAliasReference j j' + , ToAliasReference k k' + , ToAliasReference l l' + , ToAliasReference m m' + , ToAliasReference n n' + , ToAliasReference o o' + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) (a',b',c',d',e',f',g',h',i',j',k',l',m',n',o') where + toAliasReference ident x = to15 <$> (toAliasReference ident $ from15 x) + +instance ( ToAliasReference a a' + , ToAliasReference b b' + , ToAliasReference c c' + , ToAliasReference d d' + , ToAliasReference e e' + , ToAliasReference f f' + , ToAliasReference g g' + , ToAliasReference h h' + , ToAliasReference i i' + , ToAliasReference j j' + , ToAliasReference k k' + , ToAliasReference l l' + , ToAliasReference m m' + , ToAliasReference n n' + , ToAliasReference o o' + , ToAliasReference p p' + ) => ToAliasReference (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) (a',b',c',d',e',f',g',h',i',j',k',l',m',n',o',p') where + toAliasReference ident x = to16 <$> (toAliasReference ident $ from16 x) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index bd8de5a7c..4e18636a1 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 @@ -666,6 +673,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'@. @@ -1572,7 +1586,7 @@ makeLockableEntity info lockableEntity = uncommas' $ Set.toList . Set.fromList $ (\(LockableSqlExpr (ERaw _ f)) -> f Never info) <$> NEL.toList (flattenLockableEntity lockableEntity) instance PersistEntity val => LockableEntity (SqlExpr (Entity val)) where - flattenLockableEntity e = pure $ LockableSqlExpr e + flattenLockableEntity e = pure $ LockableSqlExpr e instance (LockableEntity a, LockableEntity b) => LockableEntity (a :& b) where flattenLockableEntity (a :& b) = flattenLockableEntity a <> flattenLockableEntity b @@ -3036,6 +3050,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 @@ -3051,7 +3074,7 @@ toRawSql mode (conn, firstIdentState) query = -- that no name clashes will occur on subqueries that may -- appear on the expressions below. info = (projectBackend conn, finalIdentState) - in mconcat + in (\(x, t) -> (TLB.fromLazyText $ deleteRepeatedNewlines $ TL.strip $ TLB.toLazyText x, t)) $ mconcat $ intersperse ("\n", []) [ makeCte info cteClause , makeInsertInto info mode ret , makeSelect info mode distinctClause ret @@ -3065,6 +3088,7 @@ toRawSql mode (conn, firstIdentState) query = , makeLocking info lockingClause ] + -- | Renders a 'SqlQuery' into a 'Text' value along with the list of -- 'PersistValue's that would be supplied to the database for @?@ placeholders. -- @@ -3286,11 +3310,11 @@ makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue]) makeOrderBy _ [] = mempty makeOrderBy info is = let (tlb, vals) = makeOrderByNoNewline info is - in ("\n" <> tlb, vals) + in (tlb, vals) makeLimit :: IdentInfo -> LimitClause -> (TLB.Builder, [PersistValue]) makeLimit (conn, _) (Limit ml mo) = - let limitRaw = getConnLimitOffset (v ml, v mo) "\n" conn + let limitRaw = getConnLimitOffset (v ml, v mo) "" conn v :: Maybe Int64 -> Int v = maybe 0 fromIntegral in (TLB.fromText limitRaw, mempty) @@ -3320,7 +3344,7 @@ makeLocking info (PostgresLockingClauses clauses) = makeLockingStrength PostgresForShare = plain "FOR SHARE" makeLockingBehavior :: OnLockedBehavior -> (TLB.Builder, [PersistValue]) - makeLockingBehavior NoWait = plain "NO WAIT" + makeLockingBehavior NoWait = plain "NOWAIT" makeLockingBehavior SkipLocked = plain "SKIP LOCKED" makeLockingBehavior Wait = plain "" @@ -3471,6 +3495,7 @@ instance PersistEntity a => SqlSelect (SqlExpr_ ctx (Maybe (Entity a))) (Maybe ( instance PersistField a => SqlSelectCols (SqlExpr_ ctx (Value a)) where sqlSelectCols = materializeExpr sqlSelectColCount = const 1 + instance PersistField a => SqlSelect (SqlExpr_ ctx (Value a)) (Value a) where sqlSelectProcessRow _ [pv] = Value <$> fromPersistValue pv sqlSelectProcessRow _ pvs = Value <$> fromPersistValue (PersistList pvs) @@ -3832,6 +3857,7 @@ instance ( SqlSelectCols a , sqlSelectCols esc k ] sqlSelectColCount = sqlSelectColCount . from11P + instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc @@ -3849,6 +3875,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) @@ -3881,6 +3910,7 @@ instance ( SqlSelectCols a , sqlSelectCols esc l ] sqlSelectColCount = sqlSelectColCount . from12P + instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc @@ -3899,6 +3929,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) @@ -3933,6 +3966,7 @@ instance ( SqlSelectCols a , sqlSelectCols esc m ] sqlSelectColCount = sqlSelectColCount . from13P + instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc @@ -3955,6 +3989,9 @@ 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 @@ -3988,6 +4025,7 @@ instance ( SqlSelectCols a , sqlSelectCols esc n ] sqlSelectColCount = sqlSelectColCount . from14P + instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc @@ -4008,6 +4046,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) @@ -4046,6 +4087,7 @@ instance ( SqlSelectCols a , sqlSelectCols esc o ] sqlSelectColCount = sqlSelectColCount . from15P + instance ( SqlSelect a ra , SqlSelect b rb , SqlSelect c rc @@ -4067,6 +4109,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) @@ -4129,6 +4174,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) diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index a022b9fb1..6fc9ac558 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -455,7 +455,8 @@ values exprs = Ex.From $ do -> SqlExpr_ ctx (Value a) (%.) = unsafeSqlBinOp " % " --- | `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/src/Database/Esqueleto/Record.hs b/src/Database/Esqueleto/Record.hs index bf0f70d75..62f95e89f 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 AllowAmbiguousTypes #-} @@ -15,6 +17,8 @@ module Database.Esqueleto.Record , DeriveEsqueletoRecordSettings(..) , defaultDeriveEsqueletoRecordSettings + , takeColumns + , takeMaybeColumns ) where import Control.Monad.Trans.State.Strict (StateT(..), evalStateT) @@ -23,6 +27,7 @@ import Database.Esqueleto.Experimental (Entity, PersistValue, SqlExpr, Value(..), (:&)(..)) import Database.Esqueleto.Internal.Internal (SqlSelectCols(..), SqlSelect(..)) import Database.Esqueleto.Experimental.ToAlias (ToAlias(..)) +import Database.Esqueleto.Experimental.ToMaybe (ToMaybe(..)) import Database.Esqueleto.Experimental.ToAliasReference (ToAliasReference(..)) import Language.Haskell.TH import Language.Haskell.TH.Syntax @@ -32,6 +37,7 @@ import Control.Monad (forM) import Data.Foldable (foldl') import GHC.Exts (IsString(fromString)) import Data.Maybe (mapMaybe, fromMaybe, listToMaybe) +import Debug.Trace -- | Takes the name of a Haskell record type and creates a variant of that -- record prefixed with @Sql@ which can be used in esqueleto expressions. This @@ -59,7 +65,7 @@ import Data.Maybe (mapMaybe, fromMaybe, listToMaybe) -- @ -- data SqlMyRecord = -- SqlMyRecord { myName :: 'SqlExpr' ('Value' Text) --- , myAge :: 'SqlExpr' ('Value' Int) +-- , myAge :: 'SqlExpr' ('Value' ('Maybe' Int)) -- , myUser :: 'SqlExpr' ('Entity' User) -- , myAddress :: 'SqlExpr' ('Maybe' ('Entity' Address)) -- } @@ -77,7 +83,7 @@ import Data.Maybe (mapMaybe, fromMaybe, listToMaybe) -- 'sqlSelectColCount' _ = -- 'sqlSelectColCount' -- ('Proxy' \@( ('SqlExpr' ('Value' Text)) --- :& ('SqlExpr' ('Value' Int)) +-- :& ('SqlExpr' ('Value' ('Maybe' Int))) -- :& ('SqlExpr' ('Entity' User)) -- :& ('SqlExpr' ('Maybe' ('Entity' Address))))) -- @@ -87,7 +93,7 @@ import Data.Maybe (mapMaybe, fromMaybe, listToMaybe) -- where -- process = do -- 'Value' myName <- 'takeColumns' \@('SqlExpr' ('Value' Text)) --- 'Value' myAge <- 'takeColumns' \@('SqlExpr' ('Value' Int)) +-- 'Value' myAge <- 'takeColumns' \@('SqlExpr' ('Value' ('Maybe' Int))) -- myUser <- 'takeColumns' \@('SqlExpr' ('Entity' User)) -- myAddress <- 'takeColumns' \@('SqlExpr' ('Maybe' ('Entity' Address))) -- 'pure' MyRecord { myName = myName @@ -132,11 +138,21 @@ data DeriveEsqueletoRecordSettings = DeriveEsqueletoRecordSettings -- name to produce the SQL record's type name and constructor name. -- -- @since 3.5.8.0 + , sqlMaybeNameModifier :: String -> String + -- ^ Function applied to the Haskell record's type name and constructor + -- name to produce the 'ToMaybe' record's type name and constructor name. + -- + -- @since 3.5.11.0 , sqlFieldModifier :: String -> String -- ^ Function applied to the Haskell record's field names to produce the -- SQL record's field names. -- -- @since 3.5.8.0 + , sqlMaybeFieldModifier :: String -> String + -- ^ Function applied to the Haskell record's field names to produce the + -- 'ToMaybe' SQL record's field names. + -- + -- @since 3.5.11.0 } -- | The default codegen settings for 'deriveEsqueletoRecord'. @@ -150,7 +166,9 @@ data DeriveEsqueletoRecordSettings = DeriveEsqueletoRecordSettings defaultDeriveEsqueletoRecordSettings :: DeriveEsqueletoRecordSettings defaultDeriveEsqueletoRecordSettings = DeriveEsqueletoRecordSettings { sqlNameModifier = ("Sql" ++) + , sqlMaybeNameModifier = ("SqlMaybe" ++) , sqlFieldModifier = id + , sqlMaybeFieldModifier = id } -- | Takes the name of a Haskell record type and creates a variant of that @@ -170,13 +188,20 @@ 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 - : toAliasInstanceDec - : toAliasReferenceInstanceDec - : sqlSelectInstanceDec + pure $ concat + [ [recordDec] + , sqlSelectInstanceDec + , pure sqlMaybeRecordDec + , pure toMaybeInstanceDec + , sqlMaybeRecordSelectInstanceDec + , pure toAliasInstanceDec + , pure toAliasReferenceInstanceDec + ] -- | Information about a record we need to generate the declarations. -- We compute this once and then pass it around to save on complexity / @@ -186,11 +211,15 @@ data RecordInfo = RecordInfo name :: Name , -- | The generated SQL record's name. sqlName :: Name + , -- | The generated SQL 'ToMaybe' record's name. + sqlMaybeName :: Name , -- | The original record's constraints. If this isn't empty it'll probably -- cause problems, but it's easy to pass around so might as well. constraints :: Cxt , -- | The original record's type-variable-binders. -#if MIN_VERSION_template_haskell(2,17,0) +#if MIN_VERSION_template_haskell(2,21,0) + typeVarBinders :: [TyVarBndr BndrVis] +#elif MIN_VERSION_template_haskell(2,17,0) typeVarBinders :: [TyVarBndr ()] #else typeVarBinders :: [TyVarBndr] @@ -201,12 +230,17 @@ data RecordInfo = RecordInfo constructorName :: Name , -- | The generated SQL record's constructor name. sqlConstructorName :: Name + , -- | The generated SQL 'ToMaybe' record's constructor name. + sqlMaybeConstructorName :: Name , -- | The original record's field names and types, derived from the -- constructors. fields :: [(Name, Type)] , -- | The generated SQL record's field names and types, computed -- with 'sqlFieldType'. sqlFields :: [(Name, Type)] + , -- | The generated SQL 'ToMaybe' record's field names and types, computed + -- with 'sqlMaybeFieldType'. + sqlMaybeFields :: [(Name, Type)] } -- | Get a `RecordInfo` instance for the given record name. @@ -229,9 +263,12 @@ getRecordInfo settings name = do con -> error $ nonRecordConstructorMessage con fields = getFields constructor sqlName = makeSqlName settings name + sqlMaybeName = makeSqlMaybeName settings name sqlConstructorName = makeSqlName settings constructorName + sqlMaybeConstructorName = makeSqlMaybeName settings constructorName sqlFields <- mapM toSqlField fields + sqlMaybeFields <- mapM toSqlMaybeField fields pure RecordInfo {..} where @@ -244,10 +281,20 @@ getRecordInfo settings name = do sqlTy <- sqlFieldType ty pure (modifier fieldName', sqlTy) + toSqlMaybeField (fieldName', ty) = do + let modifier = mkName . sqlMaybeFieldModifier settings . nameBase + sqlTy <- sqlMaybeFieldType ty + let result = (modifier fieldName', sqlTy) + pure (modifier fieldName', sqlTy) + -- | Create a new name by prefixing @Sql@ to a given name. makeSqlName :: DeriveEsqueletoRecordSettings -> Name -> Name makeSqlName settings name = mkName $ sqlNameModifier settings $ nameBase name +-- | Create a new name by prefixing @SqlMaybe@ to a given name. +makeSqlMaybeName :: DeriveEsqueletoRecordSettings -> Name -> Name +makeSqlMaybeName settings name = mkName $ sqlMaybeNameModifier settings $ nameBase name + -- | Transforms a record field type into a corresponding `SqlExpr` type. -- -- * @'Entity' x@ is transformed into @'SqlExpr' ('Entity' x)@. @@ -276,6 +323,40 @@ sqlFieldType fieldType = do `AppT` ((ConT ''Value) `AppT` fieldType) +-- | Transforms a record field type into a corresponding `SqlExpr` `ToMaybe` type. +-- +-- * @'Entity' x@ is transformed into @'SqlExpr' ('Maybe' ('Entity' x))@. +-- * @'Maybe' ('Entity' x)@ is transformed into @'SqlExpr' ('Maybe' ('Maybe' ('Entity' x)))@. +-- * @x@ is transformed into @'SqlExpr' ('Value' ('Maybe' x))@. +-- * If there exists an instance @'SqlSelect' sql x@, then @x@ is transformed into @sql@. +-- +-- This function should match `sqlSelectProcessRowPat`. +sqlMaybeFieldType :: Type -> Q Type +sqlMaybeFieldType fieldType = do + maybeSqlType <- reifySqlSelectType fieldType + + pure $ maybe convertFieldType convertSqlType maybeSqlType + where + convertSqlType = ((ConT ''ToMaybeT) `AppT`) + convertFieldType = case fieldType of + -- Entity x -> SqlExpr (Entity x) -> SqlExpr (Maybe (Entity x)) + AppT (ConT ((==) ''Entity -> True)) _innerType -> + (ConT ''SqlExpr) `AppT` ((ConT ''Maybe) `AppT` fieldType) + + -- Maybe (Entity x) -> SqlExpr (Maybe (Entity x)) -> SqlExpr (Maybe (Entity x)) + (ConT ((==) ''Maybe -> True)) + `AppT` ((ConT ((==) ''Entity -> True)) + `AppT` _innerType) -> + (ConT ''SqlExpr) `AppT` fieldType + + -- Maybe x -> SqlExpr (Value (Maybe x)) -> SqlExpr (Value (Maybe x)) + inner@((ConT ((==) ''Maybe -> True)) `AppT` _inner) -> (ConT ''SqlExpr) `AppT` ((ConT ''Value) `AppT` inner) + + -- x -> SqlExpr (Value x) -> SqlExpr (Value (Maybe x)) + _ -> (ConT ''SqlExpr) + `AppT` ((ConT ''Value) + `AppT` ((ConT ''Maybe) `AppT` fieldType)) + -- | Generates the declaration for an @Sql@-prefixed record, given the original -- record's information. makeSqlRecord :: RecordInfo -> Q Dec @@ -310,47 +391,47 @@ makeSqlSelectInstance info@RecordInfo {..} = do -- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance. sqlSelectColsDec :: RecordInfo -> Q Dec sqlSelectColsDec RecordInfo {..} = do - -- Pairs of record field names and local variable names. - fieldNames <- forM sqlFields (\(name', _type) -> do - var <- newName $ nameBase name' - pure (name', var)) - - -- Patterns binding record fields to local variables. - let fieldPatterns :: [FieldPat] - fieldPatterns = [(name', VarP var) | (name', var) <- fieldNames] - - -- Local variables for fields joined with `:&` in a single expression. - joinedFields :: Exp - joinedFields = - case snd `map` fieldNames of - [] -> TupE [] - [f1] -> VarE f1 - f1 : rest -> - let helper lhs field = - InfixE - (Just lhs) - (ConE '(:&)) - (Just $ VarE field) - in foldl' helper (VarE f1) rest - - identInfo <- newName "identInfo" - -- Roughly: - -- sqlSelectCols $identInfo SqlFoo{..} = sqlSelectCols $identInfo $joinedFields - pure $ - FunD - 'sqlSelectCols - [ Clause - [ VarP identInfo - , RecP sqlName fieldPatterns - ] - ( NormalB $ - (VarE 'sqlSelectCols) - `AppE` (VarE identInfo) - `AppE` (ParensE joinedFields) - ) - -- `where` clause. - [] - ] + -- Pairs of record field names and local variable names. + fieldNames <- forM sqlFields $ \(name', typ) -> do + var <- newName $ nameBase name' + pure (name', var, typ) + + -- Patterns binding record fields to local variables. + let fieldPatterns :: [FieldPat] + fieldPatterns = [(name', VarP var) | (name', var, _typ) <- fieldNames] + + -- Local variables for fields joined with `:&` in a single expression. + joinedFields :: Exp + joinedFields = + case map (\(_, v, _) -> v) fieldNames of + [] -> TupE [] + [f1] -> VarE f1 + f1 : rest -> + let helper lhs field = + InfixE + (Just lhs) + (ConE '(:&)) + (Just $ VarE field) + in foldl' helper (VarE f1) rest + + identInfo <- newName "identInfo" + -- Roughly: + -- sqlSelectCols $identInfo SqlFoo{..} = sqlSelectCols $identInfo $joinedFields + pure $ + FunD + 'sqlSelectCols + [ Clause + [ VarP identInfo + , RecP sqlName fieldPatterns + ] + ( NormalB $ + (VarE 'sqlSelectCols) + `AppE` (VarE identInfo) + `AppE` (ParensE joinedFields) + ) + -- `where` clause. + [] + ] -- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance. sqlSelectColCountDec :: RecordInfo -> Q Dec @@ -658,3 +739,269 @@ toAliasReferenceDec RecordInfo {..} = do [] ] +-- | Generates the declaration for an @SqlMaybe@-prefixed record, given the original +-- record's information. +makeSqlMaybeRecord :: RecordInfo -> Q Dec +makeSqlMaybeRecord RecordInfo {..} = do + let newConstructor = RecC sqlMaybeConstructorName (makeField `map` sqlMaybeFields) + derivingClauses = [] + pure $ DataD constraints sqlMaybeName typeVarBinders kind [newConstructor] derivingClauses + where + makeField (fieldName', fieldType) = + (fieldName', Bang NoSourceUnpackedness NoSourceStrictness, fieldType) + + +-- | Generates a `ToMaybe` instance for the given record. +makeToMaybeInstance :: RecordInfo -> Q Dec +makeToMaybeInstance info@RecordInfo {..} = do + toMaybeTDec' <- toMaybeTDec info + toMaybeDec' <- toMaybeDec info + let overlap = Nothing + instanceConstraints = [] + instanceType = (ConT ''ToMaybe) `AppT` (ConT sqlName) + + pure $ InstanceD overlap instanceConstraints instanceType [toMaybeTDec', toMaybeDec'] + +-- | Generates a `type ToMaybeT ... = ...` declaration for the given record. +toMaybeTDec :: RecordInfo -> Q Dec +toMaybeTDec RecordInfo {..} = do + pure $ mkTySynInstD ''ToMaybeT (ConT sqlName) (ConT sqlMaybeName) + where + mkTySynInstD className lhsArg rhs = +#if MIN_VERSION_template_haskell(2,15,0) + let binders = Nothing + lhs = ConT className `AppT` lhsArg + in + TySynInstD $ TySynEqn binders lhs rhs +#else + TySynInstD className $ TySynEqn [lhsArg] rhs +#endif + +-- | Generates a `toMaybe value = ...` declaration for the given record. +toMaybeDec :: RecordInfo -> Q Dec +toMaybeDec RecordInfo {..} = do + (fieldPatterns, fieldExps) <- + unzip <$> forM (zip sqlFields sqlMaybeFields) (\((fieldName', _), (maybeFieldName', _)) -> do + fieldPatternName <- newName (nameBase fieldName') + pure + ( (fieldName', VarP fieldPatternName) + , (maybeFieldName', VarE 'toMaybe `AppE` VarE fieldPatternName) + )) + + pure $ + FunD + 'toMaybe + [ Clause + [ RecP sqlName fieldPatterns + ] + (NormalB $ RecConE sqlMaybeName fieldExps) + [] + ] + +-- | Generates an `SqlSelect` and 'SqlSelectCols' instance for the given record and its +-- @Sql@-prefixed variant. +makeSqlMaybeRecordSelectInstance :: RecordInfo -> Q [Dec] +makeSqlMaybeRecordSelectInstance info@RecordInfo {..} = do + sqlSelectColsDec' <- sqlMaybeSelectColsDec info + sqlSelectColCountDec' <- sqlMaybeSelectColCountDec info + sqlSelectProcessRowDec' <- sqlMaybeSelectProcessRowDec info + let overlap = Nothing + instanceConstraints = [] + instanceType = + (ConT ''SqlSelect) + `AppT` (ConT sqlMaybeName) + `AppT` (AppT (ConT ''Maybe) (ConT name)) + + pure + [ InstanceD overlap instanceConstraints instanceType [sqlSelectProcessRowDec'] + , InstanceD overlap instanceConstraints (ConT ''SqlSelectCols `AppT` ConT sqlMaybeName) + [ sqlSelectColsDec' + , sqlSelectColCountDec' + ] + + ] + +-- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance. +sqlMaybeSelectColsDec :: RecordInfo -> Q Dec +sqlMaybeSelectColsDec RecordInfo {..} = do + -- Pairs of record field names and local variable names. + fieldNames <- forM sqlMaybeFields (\(name', _type) -> do + var <- newName $ nameBase name' + pure (name', var)) + + -- Patterns binding record fields to local variables. + let fieldPatterns :: [FieldPat] + fieldPatterns = [(name', VarP var) | (name', var) <- fieldNames] + + -- Local variables for fields joined with `:&` in a single expression. + joinedFields :: Exp + joinedFields = + case snd `map` fieldNames of + [] -> TupE [] + [f1] -> VarE f1 + f1 : rest -> + let helper lhs field = + InfixE + (Just lhs) + (ConE '(:&)) + (Just $ VarE field) + in foldl' helper (VarE f1) rest + + identInfo <- newName "identInfo" + -- Roughly: + -- sqlSelectCols $identInfo SqlFoo{..} = sqlSelectCols $identInfo $joinedFields + pure $ + FunD + 'sqlSelectCols + [ Clause + [ VarP identInfo + , RecP sqlMaybeName fieldPatterns + ] + ( NormalB $ + (VarE 'sqlSelectCols) + `AppE` (VarE identInfo) + `AppE` (ParensE joinedFields) + ) + -- `where` clause. + [] + ] + +-- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect` +-- instance. +sqlMaybeSelectProcessRowDec :: RecordInfo -> Q Dec +sqlMaybeSelectProcessRowDec RecordInfo {..} = do + let sqlOp x t = + case x of + -- AppT (ConT ((==) ''Entity -> True)) _innerType -> id + -- (ConT ((==) ''Maybe -> True)) `AppT` ((ConT ((==) ''Entity -> True)) `AppT` _innerType) -> (AppE (VarE 'pure)) + -- inner@((ConT ((==) ''Maybe -> True)) `AppT` _inner) -> (AppE (VarE 'unValue)) + (AppT (ConT ((==) ''SqlExpr -> True)) (AppT (ConT ((==) ''Value -> True)) inner)) + | AppT (ConT m) _ <- inner -> + case () of + () + | ''Maybe == m -> do + [e| (pure . unValue) $(pure t) |] + | otherwise -> do + pure (AppE (VarE 'unValue) t) + | otherwise -> + pure (AppE (VarE 'unValue) t) + (AppT (ConT ((==) ''SqlExpr -> True)) (AppT (ConT ((==) ''Entity -> True)) _)) -> + pure t + (AppT (ConT ((==) ''SqlExpr -> True)) (AppT (ConT ((==) ''Maybe -> True)) _)) -> do + pure (AppE (VarE 'pure) t) + (ConT _) -> + pure t + _ -> + fail $ show t + + fieldNames <- forM sqlFields $ \(name', typ) -> do + var <- newName $ nameBase name' + newTy <- sqlOp typ (VarE var) + pure (name', var, newTy) + + let joinedFields = + case map (\(_,x,_) -> x) fieldNames of + [] -> TupP [] + [f1] -> VarP f1 + f1 : rest -> + let helper lhs field = + InfixP + lhs + '(:&) + (VarP field) + in foldl' helper (VarP f1) rest + + fieldTypes = map snd sqlMaybeFields + + toMaybeT t = ConT ''ToMaybeT `AppT` t + + tupleType = + case fieldTypes of + [] -> + ConT '() + (x:xs) -> + foldl' (\acc t -> + ConT ''(:&) + `AppT` acc + `AppT` t) x xs + + proxy <- [e| Proxy :: Proxy $(pure tupleType) |] + colsName <- newName "columns" + proxyName <- newName "proxy" + + let +#if MIN_VERSION_template_haskell(2,17,0) + bodyExp = DoE Nothing +#else + bodyExp = DoE +#endif + [ BindS joinedFields (VarE 'sqlSelectProcessRow `AppE` proxy `AppE` VarE colsName) + , NoBindS + $ AppE (VarE 'pure) ( + case fieldNames of + [] -> ConE constructorName + (_,_,e):xs -> foldl' + (\acc (_,_,e2) -> AppE (AppE (VarE '(<*>)) acc) e2) + (AppE (AppE (VarE 'fmap) (ConE constructorName)) e) + xs + ) + ] + + pure $ + FunD + 'sqlSelectProcessRow + [ Clause + [WildP, VarP colsName] + (NormalB bodyExp) + [] + ] + +-- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance. +sqlMaybeSelectColCountDec :: RecordInfo -> Q Dec +sqlMaybeSelectColCountDec RecordInfo {..} = do + let joinedTypes = + case snd `map` sqlMaybeFields of + [] -> TupleT 0 + t1 : rest -> + let helper lhs ty = + InfixT lhs ''(:&) ty + in foldl' helper t1 rest + + -- Roughly: + -- sqlSelectColCount _ = sqlSelectColCount (Proxy @($joinedTypes)) + pure $ + FunD + 'sqlSelectColCount + [ Clause + [WildP] + ( NormalB $ + AppE (VarE 'sqlSelectColCount) $ + ParensE $ + AppTypeE + (ConE 'Proxy) + joinedTypes + ) + -- `where` clause. + [] + ] + +-- | Statefully parse some number of columns from a list of `PersistValue`s, +-- where the number of columns to parse is determined by `sqlSelectColCount` +-- for @a@. +-- +-- This is used to implement `sqlSelectProcessRow` for records created with +-- `deriveEsqueletoRecord`. +takeMaybeColumns :: + forall a b. + (SqlSelect a (ToMaybeT b)) => + StateT [PersistValue] (Either Text) (ToMaybeT b) +takeMaybeColumns = StateT (\pvs -> + let targetColCount = + sqlSelectColCount (Proxy @a) + (target, other) = + splitAt targetColCount pvs + in if length target == targetColCount + then do + value <- sqlSelectProcessRow (Proxy @a) target + Right (value, other) + else Left "Insufficient columns when trying to parse a column") diff --git a/test/Common/LegacyTest.hs b/test/Common/LegacyTest.hs index 601381b3e..ab68cb436 100644 --- a/test/Common/LegacyTest.hs +++ b/test/Common/LegacyTest.hs @@ -80,6 +80,7 @@ import qualified Data.Conduit.List as CL import qualified Data.List as L import qualified Data.Set as S import qualified Data.Text as Text +import qualified Data.Text.Lazy as TL import qualified Data.Text.Internal.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import qualified Database.Esqueleto.Internal.ExprParser as P @@ -1482,9 +1483,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 + asserting $ do + TL.strip with1 `shouldBe` expected + TL.strip with2 `shouldBe` expected + TL.strip with3 `shouldBe` expected itDb "looks sane for ForUpdate" $ sanityCheck ForUpdate "FOR UPDATE" itDb "looks sane for ForUpdateSkipLocked" $ sanityCheck ForUpdateSkipLocked "FOR UPDATE SKIP LOCKED" itDb "looks sane for ForShare" $ sanityCheck ForShare "FOR SHARE" diff --git a/test/Common/Record.hs b/test/Common/Record.hs index a6d5904d2..398b59023 100644 --- a/test/Common/Record.hs +++ b/test/Common/Record.hs @@ -14,12 +14,17 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -ddump-splices #-} + -- Tests for `Database.Esqueleto.Record`. module Common.Record (testDeriveEsqueletoRecord) where import Common.Test.Import hiding (from, on) +import Control.Monad.Trans.State.Strict (StateT(..), evalStateT) +import Data.Bifunctor (first) import Data.List (sortOn) import Database.Esqueleto import Database.Esqueleto.Record @@ -28,6 +33,23 @@ import Database.Esqueleto.Record , deriveEsqueletoRecord , deriveEsqueletoRecordWith ) +import Data.Maybe (catMaybes) +import Data.Proxy (Proxy(..)) +import Database.Esqueleto.Experimental +import Database.Esqueleto.Internal.Internal (SqlSelect(..)) +import Database.Esqueleto.Record ( + DeriveEsqueletoRecordSettings(..), + defaultDeriveEsqueletoRecordSettings, + deriveEsqueletoRecord, + deriveEsqueletoRecordWith, + takeColumns, + takeMaybeColumns, + ) +import GHC.Records + +data MySimpleRecord = MySimpleRecord { mySimpleAge :: Maybe Int } + deriving (Show, Eq) +$(deriveEsqueletoRecord ''MySimpleRecord) data MyRecord = MyRecord @@ -112,6 +134,15 @@ myModifiedRecordQuery = do , myModifiedAddressSql = address } +mySubselectRecordQuery :: SqlQuery (SqlExpr (Maybe (Entity Address))) +mySubselectRecordQuery = do + _ :& record <- from $ + table @User + `leftJoin` + myRecordQuery + `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" record ?. #id) + pure $ getField @"myAddress" record + testDeriveEsqueletoRecord :: SpecDb testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do let setup :: MonadIO m => SqlPersistT m () @@ -208,7 +239,6 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do } -> addr1 == addr2 -- The keys should match. _ -> False) - itDb "can select user-modified records" $ do setup records <- select myModifiedRecordQuery @@ -235,3 +265,87 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do , myModifiedAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"}) } -> addr1 == addr2 -- The keys should match. _ -> False) + + itDb "can left join on records" $ do + setup + records <- select $ do + from + ( table @User + `leftJoin` myRecordQuery `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" record ?. #id) + ) + let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case (_ :& Just (MyRecord {myName = "Rebecca", myAddress = Nothing})) -> True + _ -> False) + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case ( _ :& Just ( MyRecord { myName = "Some Guy" + , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) + } + )) -> True + _ -> True) + + itDb "can can handle joins on records with Nothing" $ do + setup + records <- select $ do + from + ( table @User + `leftJoin` myRecordQuery `on` (do \(user :& record) -> user ^. #address ==. getField @"myAddress" record ?. #id) + ) + let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case (_ :& Nothing) -> True + _ -> False) + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case ( _ :& Just ( MyRecord { myName = "Some Guy" + , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) + } + )) -> True + _ -> True) + + itDb "can left join on nested records" $ do + setup + records <- select $ do + from + ( table @User + `leftJoin` myNestedRecordQuery + `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" (getField @"myRecord" record) ?. #id) + ) + let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case (_ :& Just (MyNestedRecord {myRecord = MyRecord {myName = "Rebecca", myAddress = Nothing}})) -> True + _ -> False) + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case ( _ :& Just ( MyNestedRecord { myRecord = MyRecord { myName = "Some Guy" + , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) + } + })) -> True + _ -> True) + + itDb "can handle multiple left joins on the same record" $ do + setup + records <- select $ do + from + ( table @User + `leftJoin` myNestedRecordQuery + `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" (getField @"myRecord" record) ?. #id) + `leftJoin` myNestedRecordQuery + `on` (do \(user :& record1 :& record2) -> getField @"myUser" (getField @"myRecord" record1) ?. #id !=. getField @"myUser" (getField @"myRecord" record2) ?. #id) + ) + let sortedRecords = sortOn (\(Entity _ user :& _ :& _) -> getField @"userName" user) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case ( _ :& _ :& Just ( MyNestedRecord { myRecord = MyRecord { myName = "Some Guy" + , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) + } + })) -> True + _ -> True) + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case (_ :& _ :& Just (MyNestedRecord {myRecord = MyRecord {myName = "Rebecca", myAddress = Nothing}})) -> True + _ -> False) diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 8d4e6e212..7c6ffc8f5 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -1667,9 +1667,11 @@ testLocking = do [complex, with1, with2, with3] <- return $ map (toText conn) [complexQuery, queryWithClause1, queryWithClause2, queryWithClause3] - let expected = complex <> "\n" <> syntax - asserting $ - (with1, with2, with3) `shouldBe` (expected, expected, expected) + let expected = complex <> syntax <> "\n" + asserting $ do + with1 `shouldBe` expected + with2 `shouldBe` expected + with3 `shouldBe` expected itDb "looks sane for ForUpdate" $ sanityCheck ForUpdate "FOR UPDATE" itDb "looks sane for ForUpdateSkipLocked" $ sanityCheck ForUpdateSkipLocked "FOR UPDATE SKIP LOCKED" itDb "looks sane for ForShare" $ sanityCheck ForShare "FOR SHARE" diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 7bd122473..5e3d18a73 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -1443,6 +1443,15 @@ testPostgresqlLocking = do asserting sideThreadAsserts asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3 + describe "noWait" $ do + itDb "doesn't crash" $ do + select $ do + t <- from $ table @Person + EP.forUpdateOf t EP.noWait + pure t + + asserting noExceptions + -- Since lateral queries arent supported in Sqlite or older versions of mysql -- the test is in the Postgres module testLateralQuery :: SpecDb From 77259d046c0d95dc312b08794bd5f6799fbae053 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Wed, 1 May 2024 17:11:40 -0600 Subject: [PATCH 2/2] spacing --- test/Common/LegacyTest.hs | 388 +++++++++++++++++++------------------- 1 file changed, 195 insertions(+), 193 deletions(-) diff --git a/test/Common/LegacyTest.hs b/test/Common/LegacyTest.hs index ab68cb436..0b37380bd 100644 --- a/test/Common/LegacyTest.hs +++ b/test/Common/LegacyTest.hs @@ -1447,205 +1447,207 @@ testCase = do testLocking :: SpecDb testLocking = do - let toText conn q = - let (tlb, _) = EI.toRawSql EI.SELECT (conn, EI.initialIdentState) q - in TLB.toLazyText tlb - complexQuery = - from $ \(p1' `InnerJoin` p2') -> do - on (p1' ^. PersonName ==. p2' ^. PersonName) - where_ (p1' ^. PersonFavNum >. val 2) - orderBy [desc (p2' ^. PersonAge)] - limit 3 - offset 9 - groupBy (p1' ^. PersonId) - having (countRows <. val (0 :: Int)) - return (p1', p2') - describe "locking" $ do - -- The locking clause is the last one, so try to use many - -- others to test if it's at the right position. We don't - -- care about the text of the rest, nor with the RDBMS' - -- reaction to the clause. - let sanityCheck kind syntax = do - let queryWithClause1 = do - r <- complexQuery - locking kind - return r - queryWithClause2 = do - locking ForUpdate - r <- complexQuery - locking ForShare - locking kind - return r - queryWithClause3 = do - locking kind - complexQuery - conn <- ask - [complex, with1, with2, with3] <- - return $ - map (toText conn) [complexQuery, queryWithClause1, queryWithClause2, queryWithClause3] - let expected = complex <> syntax - asserting $ do - TL.strip with1 `shouldBe` expected - TL.strip with2 `shouldBe` expected - TL.strip with3 `shouldBe` expected - itDb "looks sane for ForUpdate" $ sanityCheck ForUpdate "FOR UPDATE" - itDb "looks sane for ForUpdateSkipLocked" $ sanityCheck ForUpdateSkipLocked "FOR UPDATE SKIP LOCKED" - itDb "looks sane for ForShare" $ sanityCheck ForShare "FOR SHARE" - itDb "looks sane for LockInShareMode" $ sanityCheck LockInShareMode "LOCK IN SHARE MODE" + let toText conn q = + let (tlb, _) = EI.toRawSql EI.SELECT (conn, EI.initialIdentState) q + in TLB.toLazyText tlb + complexQuery = + from $ \(p1' `InnerJoin` p2') -> do + on (p1' ^. PersonName ==. p2' ^. PersonName) + where_ (p1' ^. PersonFavNum >. val 2) + orderBy [desc (p2' ^. PersonAge)] + limit 3 + offset 9 + groupBy (p1' ^. PersonId) + having (countRows <. val (0 :: Int)) + return (p1', p2') + describe "locking" $ do + -- The locking clause is the last one, so try to use many + -- others to test if it's at the right position. We don't + -- care about the text of the rest, nor with the RDBMS' + -- reaction to the clause. + let sanityCheck kind syntax = do + let queryWithClause1 = do + r <- complexQuery + locking kind + return r + queryWithClause2 = do + locking ForUpdate + r <- complexQuery + locking ForShare + locking kind + return r + queryWithClause3 = do + locking kind + complexQuery + conn <- ask + [complex, with1, with2, with3] <- + return $ + map (toText conn) [complexQuery, queryWithClause1, queryWithClause2, queryWithClause3] + let expected = complex <> syntax + asserting $ do + TL.strip with1 `shouldBe` expected + TL.strip with2 `shouldBe` expected + TL.strip with3 `shouldBe` expected + itDb "looks sane for ForUpdate" $ sanityCheck ForUpdate "FOR UPDATE" + itDb "looks sane for ForUpdateSkipLocked" $ sanityCheck ForUpdateSkipLocked "FOR UPDATE SKIP LOCKED" + itDb "looks sane for ForShare" $ sanityCheck ForShare "FOR SHARE" + itDb "looks sane for LockInShareMode" $ sanityCheck LockInShareMode "LOCK IN SHARE MODE" testCountingRows :: SpecDb testCountingRows = do - describe "counting rows" $ do - forM_ [ ("count (test A)", count . (^. PersonAge), 4) - , ("count (test B)", count . (^. PersonWeight), 5) - , ("countRows", const countRows, 5) - , ("countDistinct", countDistinct . (^. PersonAge), 2) ] $ - \(title, countKind, expected) -> - itDb (title ++ " works as expected") $ - do - mapM_ insert - [ Person "" (Just 1) (Just 1) 1 - , Person "" (Just 2) (Just 1) 1 - , Person "" (Just 2) (Just 1) 1 - , Person "" (Just 2) (Just 2) 1 - , Person "" Nothing (Just 3) 1] - [Value n] <- select $ from $ return . countKind - asserting $ (n :: Int) `shouldBe` expected + describe "counting rows" $ do + let cases = + [ ("count (test A)", count . (^. PersonAge), 4) + , ("count (test B)", count . (^. PersonWeight), 5) + , ("countRows", const countRows, 5) + , ("countDistinct", countDistinct . (^. PersonAge), 2) + ] + forM_ cases $ \(title, countKind, expected) -> do + itDb (title ++ " works as expected") $ do + insertMany_ + [ Person "" (Just 1) (Just 1) 1 + , Person "" (Just 2) (Just 1) 1 + , Person "" (Just 2) (Just 1) 1 + , Person "" (Just 2) (Just 2) 1 + , Person "" Nothing (Just 3) 1 + ] + [Value n] <- select $ from $ return . countKind + asserting $ (n :: Int) `shouldBe` expected testRenderSql :: SpecDb testRenderSql = do - describe "testRenderSql" $ do - itDb "works" $ do - (queryText, queryVals) <- renderQuerySelect $ - from $ \p -> do - where_ $ p ^. PersonName ==. val "Johhny Depp" - pure (p ^. PersonName, p ^. PersonAge) - -- the different backends use different quote marks, so I filter them out - -- here instead of making a duplicate test - asserting $ do - Text.filter (\c -> c `notElem` ['`', '"']) queryText - `shouldBe` - Text.unlines - [ "SELECT Person.name, Person.age" - , "FROM Person" - , "WHERE Person.name = ?" - ] - queryVals - `shouldBe` - [toPersistValue ("Johhny Depp" :: TL.Text)] - - describe "renderExpr" $ do - itDb "renders a value" $ do - (c, expr) <- do - conn <- ask - let Right c = P.mkEscapeChar conn - let user = EI.unsafeSqlEntity (EI.I "user") - blogPost = EI.unsafeSqlEntity (EI.I "blog_post") - pure $ (,) c $ EI.renderExpr conn $ - user ^. PersonId ==. blogPost ^. BlogPostAuthorId - asserting $ do - expr - `shouldBe` - Text.intercalate (Text.singleton c) ["", "user", ".", "id", ""] - <> - " = " - <> - Text.intercalate (Text.singleton c) ["", "blog_post", ".", "authorId", ""] - - itDb "renders ? for a val" $ do - expr <- ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1)) - asserting $ expr `shouldBe` "? = ?" - - beforeWith (\_ -> pure ()) $ describe "ExprParser" $ do - let parse parser = AP.parseOnly (parser '#') - describe "parseEscapedChars" $ do - let subject = parse P.parseEscapedChars - it "parses words" $ do - subject "hello world" - `shouldBe` - Right "hello world" - it "only returns a single escape-char if present" $ do - subject "i_am##identifier##" - `shouldBe` - Right "i_am#identifier#" - describe "parseEscapedIdentifier" $ do - let subject = parse P.parseEscapedIdentifier - it "parses the quotes out" $ do - subject "#it's a me, mario#" - `shouldBe` - Right "it's a me, mario" - it "requires a beginning and end quote" $ do - subject "#alas, i have no end" - `shouldSatisfy` - isLeft - describe "parseTableAccess" $ do - let subject = parse P.parseTableAccess - it "parses a table access" $ do - subject "#foo#.#bar#" - `shouldBe` - Right P.TableAccess - { P.tableAccessTable = "foo" - , P.tableAccessColumn = "bar" - } - describe "onExpr" $ do - let subject = parse P.onExpr - it "works" $ do - subject "#foo#.#bar# = #bar#.#baz#" - `shouldBe` do - Right $ S.fromList - [ P.TableAccess - { P.tableAccessTable = "foo" - , P.tableAccessColumn = "bar" - } - , P.TableAccess - { P.tableAccessTable = "bar" - , P.tableAccessColumn = "baz" - } - ] - it "also works with other nonsense" $ do - subject "#foo#.#bar# = 3" - `shouldBe` do - Right $ S.fromList - [ P.TableAccess - { P.tableAccessTable = "foo" - , P.tableAccessColumn = "bar" - } - ] - it "handles a conjunction" $ do - subject "#foo#.#bar# = #bar#.#baz# AND #bar#.#baz# > 10" - `shouldBe` do - Right $ S.fromList - [ P.TableAccess - { P.tableAccessTable = "foo" - , P.tableAccessColumn = "bar" - } - , P.TableAccess - { P.tableAccessTable = "bar" - , P.tableAccessColumn = "baz" - } - ] - it "handles ? okay" $ do - subject "#foo#.#bar# = ?" - `shouldBe` do - Right $ S.fromList - [ P.TableAccess - { P.tableAccessTable = "foo" - , P.tableAccessColumn = "bar" - } - ] - it "handles degenerate cases" $ do - subject "false" `shouldBe` pure mempty - subject "true" `shouldBe` pure mempty - subject "1 = 1" `shouldBe` pure mempty - it "works even if an identifier isn't first" $ do - subject "true and #foo#.#bar# = 2" - `shouldBe` do - Right $ S.fromList - [ P.TableAccess - { P.tableAccessTable = "foo" - , P.tableAccessColumn = "bar" - } - ] + describe "testRenderSql" $ do + itDb "works" $ do + (queryText, queryVals) <- renderQuerySelect $ + from $ \p -> do + where_ $ p ^. PersonName ==. val "Johhny Depp" + pure (p ^. PersonName, p ^. PersonAge) + -- the different backends use different quote marks, so I filter them out + -- here instead of making a duplicate test + asserting $ do + Text.filter (\c -> c `notElem` ['`', '"']) queryText + `shouldBe` + Text.unlines + [ "SELECT Person.name, Person.age" + , "FROM Person" + , "WHERE Person.name = ?" + ] + queryVals + `shouldBe` + [toPersistValue ("Johhny Depp" :: TL.Text)] + + describe "renderExpr" $ do + itDb "renders a value" $ do + (c, expr) <- do + conn <- ask + let Right c = P.mkEscapeChar conn + let user = EI.unsafeSqlEntity (EI.I "user") + blogPost = EI.unsafeSqlEntity (EI.I "blog_post") + pure $ (,) c $ EI.renderExpr conn $ + user ^. PersonId ==. blogPost ^. BlogPostAuthorId + asserting $ do + expr + `shouldBe` + Text.intercalate (Text.singleton c) ["", "user", ".", "id", ""] + <> + " = " + <> + Text.intercalate (Text.singleton c) ["", "blog_post", ".", "authorId", ""] + + itDb "renders ? for a val" $ do + expr <- ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1)) + asserting $ expr `shouldBe` "? = ?" + + beforeWith (\_ -> pure ()) $ describe "ExprParser" $ do + let parse parser = AP.parseOnly (parser '#') + describe "parseEscapedChars" $ do + let subject = parse P.parseEscapedChars + it "parses words" $ do + subject "hello world" + `shouldBe` + Right "hello world" + it "only returns a single escape-char if present" $ do + subject "i_am##identifier##" + `shouldBe` + Right "i_am#identifier#" + describe "parseEscapedIdentifier" $ do + let subject = parse P.parseEscapedIdentifier + it "parses the quotes out" $ do + subject "#it's a me, mario#" + `shouldBe` + Right "it's a me, mario" + it "requires a beginning and end quote" $ do + subject "#alas, i have no end" + `shouldSatisfy` + isLeft + describe "parseTableAccess" $ do + let subject = parse P.parseTableAccess + it "parses a table access" $ do + subject "#foo#.#bar#" + `shouldBe` + Right P.TableAccess + { P.tableAccessTable = "foo" + , P.tableAccessColumn = "bar" + } + describe "onExpr" $ do + let subject = parse P.onExpr + it "works" $ do + subject "#foo#.#bar# = #bar#.#baz#" + `shouldBe` do + Right $ S.fromList + [ P.TableAccess + { P.tableAccessTable = "foo" + , P.tableAccessColumn = "bar" + } + , P.TableAccess + { P.tableAccessTable = "bar" + , P.tableAccessColumn = "baz" + } + ] + it "also works with other nonsense" $ do + subject "#foo#.#bar# = 3" + `shouldBe` do + Right $ S.fromList + [ P.TableAccess + { P.tableAccessTable = "foo" + , P.tableAccessColumn = "bar" + } + ] + it "handles a conjunction" $ do + subject "#foo#.#bar# = #bar#.#baz# AND #bar#.#baz# > 10" + `shouldBe` do + Right $ S.fromList + [ P.TableAccess + { P.tableAccessTable = "foo" + , P.tableAccessColumn = "bar" + } + , P.TableAccess + { P.tableAccessTable = "bar" + , P.tableAccessColumn = "baz" + } + ] + it "handles ? okay" $ do + subject "#foo#.#bar# = ?" + `shouldBe` do + Right $ S.fromList + [ P.TableAccess + { P.tableAccessTable = "foo" + , P.tableAccessColumn = "bar" + } + ] + it "handles degenerate cases" $ do + subject "false" `shouldBe` pure mempty + subject "true" `shouldBe` pure mempty + subject "1 = 1" `shouldBe` pure mempty + it "works even if an identifier isn't first" $ do + subject "true and #foo#.#bar# = 2" + `shouldBe` do + Right $ S.fromList + [ P.TableAccess + { P.tableAccessTable = "foo" + , P.tableAccessColumn = "bar" + } + ] testOnClauseOrder :: SpecDb testOnClauseOrder = describe "On Clause Ordering" $ do