HasField on SqlExpr (Maybe Entity) joins Maybe

bitemyapp · Dec 27, 2024 · d22003c · d22003c
1 parent 339f66a
commit d22003c
Show file tree

Hide file tree

Showing 3 changed files with 33 additions and 9 deletions.
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
@@ -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
@@ -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