From d22003cd9e593d8ef0bdc4502f78abf72e7eff4d Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 27 Dec 2024 14:15:29 -0700 Subject: [PATCH 1/8] HasField on SqlExpr (Maybe Entity) joins Maybe --- .../Esqueleto/Experimental/ToMaybe.hs | 4 ---- src/Database/Esqueleto/Internal/Internal.hs | 22 +++++++++++++++---- test/Common/Test.hs | 16 +++++++++++++- 3 files changed, 33 insertions(+), 9 deletions(-) diff --git a/src/Database/Esqueleto/Experimental/ToMaybe.hs b/src/Database/Esqueleto/Experimental/ToMaybe.hs index 0677bfb9c..44471285c 100644 --- a/src/Database/Esqueleto/Experimental/ToMaybe.hs +++ b/src/Database/Esqueleto/Experimental/ToMaybe.hs @@ -7,10 +7,6 @@ module Database.Esqueleto.Experimental.ToMaybe 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 709e934d0..47a7d5670 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -665,7 +665,10 @@ nothing = unsafeSqlValue "NULL" -- | Join nested 'Maybe's in a 'Value' into one. This is useful when -- calling aggregate functions on nullable fields. -joinV :: SqlExpr (Value (Maybe (Maybe typ))) -> SqlExpr (Value (Maybe typ)) +joinV + :: (NullableFieldProjection typ typ') + => SqlExpr (Value (Maybe typ)) + -> SqlExpr (Value (Maybe typ')) joinV = veryUnsafeCoerceSqlExprValue @@ -2478,11 +2481,18 @@ 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) + +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 @@ -4263,3 +4273,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/test/Common/Test.hs b/test/Common/Test.hs index 37df01fca..75b3031bc 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -2487,7 +2487,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 @@ -2496,6 +2496,20 @@ 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_ $ joinV lord.dogs >=. just (val 10) + pure lord + + + #else it "is only supported in GHC 9.2 or above" $ \_ -> do pending From cfa86bb9b785cfa3a2edf9ee798d40a310117128 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 27 Dec 2024 14:30:08 -0700 Subject: [PATCH 2/8] hmmm that works kinda nicely --- changelog.md | 10 +++++++ src/Database/Esqueleto/Internal/Internal.hs | 30 ++++++++++++++++++++- test/Common/Test.hs | 4 ++- 3 files changed, 42 insertions(+), 2 deletions(-) diff --git a/changelog.md b/changelog.md index 689518330..84896ceef 100644 --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,16 @@ 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 `just` function is also modified to avoid nesting `Maybe`. - [#420](https://github.com/bitemyapp/esqueleto/pull/420) - Add a fixity declaration to `?.` - [#412](https://github.com/bitemyapp/esqueleto/pull/412) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 47a7d5670..a3b8c238c 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -656,7 +656,12 @@ 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 not produce a nested 'Maybe'. This is in accord with +-- how SQL represents @NULL@. That means that @'just' . 'just' = 'just'@. +just + :: (NullableFieldProjection typ typ') + => SqlExpr (Value typ) -> SqlExpr (Value (Maybe typ')) just = veryUnsafeCoerceSqlExprValue -- | @NULL@ value. @@ -2490,6 +2495,29 @@ instance where 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)))@. class NullableFieldProjection typ typ' instance {-# incoherent #-} (typ ~ typ') => NullableFieldProjection (Maybe typ) typ' instance {-# overlappable #-} (typ ~ typ') => NullableFieldProjection typ typ' diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 75b3031bc..f3ec3cb0a 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -2505,7 +2505,9 @@ testOverloadedRecordDot = describe "OverloadedRecordDot" $ do `Experimental.on` do \(deed :& lord) -> lord.id ==. just deed.ownerId - where_ $ joinV lord.dogs >=. just (val 10) + where_ $ lord.dogs >=. just (val 10) + where_ $ joinV lord.dogs >=. just (just (val 10)) + where_ $ lord.dogs >=. just (val (Just 10)) pure lord From 43edb0608fa253c0edfece31670a6b30dadbbd23 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 6 Jan 2025 16:41:39 -0700 Subject: [PATCH 3/8] Incorporate changes from the work codebase --- src/Database/Esqueleto.hs | 2 +- src/Database/Esqueleto/Internal/Internal.hs | 82 +++++++++++++++++---- src/Database/Esqueleto/Legacy.hs | 2 +- 3 files changed, 71 insertions(+), 15 deletions(-) diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index 1eac085e2..c4298b966 100644 --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -54,7 +54,7 @@ module Database.Esqueleto {-# WARNING "This module will switch over to the Exper where_, on, groupBy, orderBy, asc, desc, limit, offset , distinct, distinctOn, don, distinctOnOrderBy, having, locking , (^.), (?.) - , val, isNothing, just, nothing, joinV, withNonNull + , val, isNothing, just, just', nothing, joinV, joinV', withNonNull , countRows, count, countDistinct , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , between, (+.), (-.), (/.), (*.) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index a3b8c238c..966c20f18 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -446,9 +446,9 @@ putLocking clause = Q $ W.tell mempty { sdLockingClause = clause } -- -- @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 @@ -599,12 +599,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) @@ -657,25 +673,51 @@ isNothing_ = isNothing -- one of type @Maybe typ@. It should hold that @'val' . Just -- === just . 'val'@. -- --- This function will not produce a nested 'Maybe'. This is in accord with --- how SQL represents @NULL@. That means that @'just' . 'just' = 'just'@. +-- 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. +-- +-- 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 = @@ -881,12 +923,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, @@ -921,7 +972,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 @@ -2518,6 +2572,8 @@ instance -- -- 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' diff --git a/src/Database/Esqueleto/Legacy.hs b/src/Database/Esqueleto/Legacy.hs index dec4695f0..d768036bd 100644 --- a/src/Database/Esqueleto/Legacy.hs +++ b/src/Database/Esqueleto/Legacy.hs @@ -55,7 +55,7 @@ module Database.Esqueleto.Legacy where_, on, groupBy, orderBy, asc, desc, limit, offset , distinct, distinctOn, don, distinctOnOrderBy, having, locking , (^.), (?.) - , val, isNothing, just, nothing, joinV, withNonNull + , val, isNothing, just, just', nothing, joinV, joinV', withNonNull , countRows, count, countDistinct , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , between, (+.), (-.), (/.), (*.) From 269945e9d2c58d9e4a8b4e87d83d3d6a53fca2cb Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 6 Jan 2025 16:43:19 -0700 Subject: [PATCH 4/8] add another test case --- test/Common/Test.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/test/Common/Test.hs b/test/Common/Test.hs index f3ec3cb0a..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 #-} @@ -2508,7 +2509,19 @@ testOverloadedRecordDot = describe "OverloadedRecordDot" $ do where_ $ lord.dogs >=. just (val 10) where_ $ joinV lord.dogs >=. just (just (val 10)) where_ $ lord.dogs >=. just (val (Just 10)) - pure lord + + 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)]) From 697ce26f3df27f2c7dff70ea3a7b39f9c814d0ef Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 6 Jan 2025 16:54:37 -0700 Subject: [PATCH 5/8] changelog --- changelog.md | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/changelog.md b/changelog.md index 84896ceef..c5463f28f 100644 --- a/changelog.md +++ b/changelog.md @@ -9,8 +9,16 @@ - 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 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) From a25658a1a1ec9aa01a29ef7b0f59346f50bf246d Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 7 Jan 2025 09:43:09 -0700 Subject: [PATCH 6/8] wat --- .github/workflows/haskell.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 7a1d5c20c..10fef1d7c 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: apt-get update && apt-get install -y pcre - run: cabal v2-update - run: cabal v2-freeze $CONFIG - uses: actions/cache@v4 From 93deb3b5dec459520eecd371616791f7357f15ae Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 7 Jan 2025 09:48:56 -0700 Subject: [PATCH 7/8] wat --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 10fef1d7c..f4ebe9310 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -69,7 +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: apt-get update && apt-get install -y pcre + - run: sudo apt-get update && sudo apt-get install -y pcre - run: cabal v2-update - run: cabal v2-freeze $CONFIG - uses: actions/cache@v4 From 3bf806142d3a1629703dfb5348be54a37efab7c1 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 7 Jan 2025 09:49:30 -0700 Subject: [PATCH 8/8] wat --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index f4ebe9310..40b6d9041 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -69,7 +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 pcre + - 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