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
bitemyapp · Jan 7, 2025 · 1010b1e · 1010b1e
1 parent ef9a4bc
commit 1010b1e
Show file tree

Hide file tree

Showing 7 changed files with 165 additions and 23 deletions.
diff --git 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/changelog.md b/changelog.md
@@ -1,6 +1,24 @@
 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)

diff --git 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/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
@@ -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)
@@ -656,18 +672,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 =
@@ -873,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,
@@ -913,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
@@ -2504,11 +2566,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
@@ -4289,3 +4383,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
@@ -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, (+.), (-.), (/.), (*.)

diff --git a/test/Common/Test.hs b/test/Common/Test.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -2487,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
@@ -2496,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