diff --git a/esqueleto.cabal b/esqueleto.cabal index f5c40ddb8..ebcddda7c 100644 --- a/esqueleto.cabal +++ b/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 diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 128e51482..863674524 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/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 diff --git a/stack-9.0.yaml b/stack-9.0.yaml index 49a504ea7..0c147bfe3 100644 --- a/stack-9.0.yaml +++ b/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] diff --git a/test/Common/Test.hs b/test/Common/Test.hs index c39e3a848..2af075f77 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 #-} @@ -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 diff --git a/test/Common/Test/Models.hs b/test/Common/Test/Models.hs index 2a1ada117..692fe1cd4 100644 --- a/test/Common/Test/Models.hs +++ b/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