neat

esqueleto.cabal

@@ -81,6 +81,8 @@ library
         -Wcpp-undef
         -Wcpp-undef
     default-language: Haskell2010
+    default-extensions: 
+        TypeOperators
 
 test-suite specs
     type: exitcode-stdio-1.0

src/Database/Esqueleto/Internal/Internal.hs

@@ -470,9 +470,9 @@ sub_select         = sub SELECT
 --
 -- @since 3.2.0
 subSelect
-  :: PersistField a
+  :: (PersistField a, NullableFieldProjection a a')
   => SqlQuery (SqlExpr (Value a))
-  -> SqlExpr (Value (Maybe a))
+  -> SqlExpr (Value (Maybe a'))
 subSelect query = just (subSelectUnsafe (query <* limit 1))
 
 -- | Execute a subquery @SELECT@ in a 'SqlExpr'. This function is a shorthand
@@ -626,10 +626,10 @@ withNonNull field f = do
 -- | Project a field of an entity that may be null.
 --
 -- This will not produce a nested 'Maybe'.
-(?.) :: (PersistEntity val , PersistField typ, NullableFieldProjection typ typ')
+(?.) :: (PersistEntity val, PersistField typ)
     => SqlExpr (Maybe (Entity val))
     -> EntityField val typ
-    -> SqlExpr (Value (Maybe typ'))
+    -> SqlExpr (Value (Maybe (Nullable typ)))
 ERaw m f ?. field = veryUnsafeCoerceSqlExprValue (ERaw m f ^. field)
 
 -- | Lift a constant value from Haskell-land to the query.
@@ -686,8 +686,9 @@ isNothing_ = isNothing
 -- This function will not produce a nested 'Maybe'. This is in accord with
 -- how SQL represents @NULL@. That means that @'just' . 'just' = 'just'@.
 just
-    :: SqlExpr (Value typ)
-    -> SqlExpr (Value (Maybe typ))
+    :: (NullableFieldProjection typ typ')
+    => SqlExpr (Value typ)
+    -> SqlExpr (Value (Maybe typ'))
 just = veryUnsafeCoerceSqlExprValue
 
 -- | @NULL@ value.
@@ -697,8 +698,9 @@ 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))
+    :: (NullableFieldProjection typ typ')
+    => SqlExpr (Value (Maybe typ))
+    -> SqlExpr (Value (Maybe typ'))
 joinV = veryUnsafeCoerceSqlExprValue
 
 
@@ -2489,7 +2491,7 @@ instance
   =>
     HasField sym (SqlExpr (Maybe (Entity rec))) (SqlExpr (Value (Maybe typ')))
   where
-    getField expr = expr ?. symbolToField @sym
+    getField expr = veryUnsafeCoerceSqlExprValue (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'
@@ -2516,7 +2518,7 @@ instance
 -- 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'
+instance (typ ~ typ') => NullableFieldProjection typ typ'
 
 type family Nullable a where
     Nullable (Maybe a) = a

stack-9.0.yaml

@@ -1,4 +1,4 @@
-resolver: lts-19.13
+resolver: lts-22.04
 
 packages:
   - '.'
@@ -8,7 +8,6 @@ allow-newer: true
 
 extra-deps:
 - lift-type-0.1.0.1
-- persistent-2.14.0.2
 
 nix:
   packages: [zlib, libmysqlclient, pcre, postgresql]

test/Common/Test.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -543,8 +544,8 @@ testSelectJoin = do
         b31e <- insert' $ BlogPost "c" (entityKey p3e)
         ret <- select $
                from $ \(p `LeftOuterJoin` mb) -> do
-               on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)
-               orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ]
+               on (just (p ^. PersonId) ==. mb ?. #authorId)
+               orderBy [ asc (p ^. PersonName), asc (mb ?. #title) ]
                return (p, mb)
         asserting $ ret `shouldBe` [ (p1e, Just b11e)
                                 , (p1e, Just b12e)
@@ -579,6 +580,20 @@ testSelectJoin = do
            return (p, mb)
       asserting $ shouldBeOnClauseWithoutMatchingJoinException eres
 
+    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)])
+
+
     itDb "throws an error for using too many ons" $ do
       eres <- try $ select $
            from $ \(p `FullOuterJoin` mb) -> do
@@ -2527,7 +2542,7 @@ shouldBeOnClauseWithoutMatchingJoinException ea =
             expectationFailure $ "Expected OnClauseWithMatchingJoinException, got: " <> show ea
 
 testOverloadedRecordDot :: SpecDb
-testOverloadedRecordDot = describe "OverloadedRecordDot" $ do
+testOverloadedRecordDot = focus $ describe "OverloadedRecordDot" $ do
 #if __GLASGOW_HASKELL__ >= 902
     describe "with SqlExpr (Entity rec)" $ do
         itDb "lets you project from a record" $ do
@@ -2545,19 +2560,58 @@ 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
+    describe "Type Inference and Maybe" $ do
+        itDb "joins Maybe together" $ do
+            void $ select $ do
+                deed :& lord :& user :& address <-
+                    Experimental.from $
+                        table @Deed
+                        `leftJoin` table @Lord
+                            `Experimental.on` do
+                                \(deed :& lord) ->
+                                    lord.id ==. just deed.ownerId
+                        `leftJoin` table @User
+                            `Experimental.on` do
+                                \(_ :& lord :& user) ->
+                                    lord.county ==. user.name
+                        `leftJoin` table @Address
+                            `Experimental.on` do
+                                \(_ :& user :& address) ->
+                                    user.address ==. address.id
+                where_ $ lord.dogs >=. just (just (val 10))
+                where_ $ joinV lord.dogs >=. just (just (val 10))
+                where_ $ lord.dogs >=. just (val (Just 10))
+                where_ $ lord.dogs >=. just (val 10)
+                -- where_ $ lord.dogs >=. val 10 -- this fails with a type error, as expected
+                pure (lord, user.address, address.address)
+
+        itDb "" $ void $ do
+            select $ do
+                (p :& bp :& c) <- Experimental.from $
+                    table @Person
+                    `leftJoin` table @BlogPost
+                        `Experimental.on` do
+                            \(p :& bp) ->
+                                just p.id ==. bp.authorId
+                                -- this has a bad type error. "can't match
+                                -- `Maybe typ'` with `Key Person`". no good
+                                -- indication that the problem is that
+                                -- `bp.authorId` has type `Maybe _` and
+                                -- that's why.
+                                -- p.id ==. bp.authorId
+                    `leftJoin` table @Comment
                         `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))
-            pure lord
+                            \(_ :& bp :& c) ->
+                                bp.id ==. c.blog
+                                &&. bp ?. #id ==. c ?. #blog
+                where_ $ p.id ==. val undefined
+                where_ $ c.title ==. just (val "hello")
+                where_ $ c.title ==. just (just (val "hello"))
+                where_ $ c ?. #title ==. just (val "hello")
+                -- this gives "no instance IsSTring (Maybe [Char])" which
+                -- is great for type inference
+                -- where_ $ c ?. #title ==. (val "hello")
+                pure (p, bp, c)
 
 #else
     it "is only supported in GHC 9.2 or above" $ \_ -> do
@@ -2583,7 +2637,7 @@ testGetTable =
                         `leftJoin` table @Reply
                             `Experimental.on` do
                                 \((getTable @Person -> p) :& reply) ->
-                                    just (p ^. PersonId) ==. reply ?. ReplyGuy
+                                    just (p ^. PersonId) ==. reply ?. #guy
                 pure (person, blogPost, profile, reply)
             asserting noExceptions
 

test/Common/Test/Models.hs

@@ -61,6 +61,7 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
     deriving Eq Show
   Comment
     body String
+    title String Maybe
     blog BlogPostId
     deriving Eq Show
   CommentReply