diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index d624e3d..f360496 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -64,6 +64,7 @@ import qualified Data.Text.Lazy.Builder as TLB import Data.Typeable (Typeable) import Text.Blaze.Html (Html) + import Database.Esqueleto.Internal.ExprParser (TableAccess(..), parseOnExpr) -- | (Internal) Start a 'from' query with an entity. 'from' @@ -470,11 +471,11 @@ subSelectForeign -> (SqlExpr (Entity val1) -> SqlExpr (Value a)) -- ^ A function to extract a value from the foreign reference table. -> SqlExpr (Value a) -subSelectForeign expr foreignKey with = +subSelectForeign expr foreignKey k = subSelectUnsafe $ from $ \table -> do where_ $ expr ^. foreignKey ==. table ^. persistIdField - pure (with table) + pure (k table) -- | Execute a subquery @SELECT@ in a 'SqlExpr'. This function is unsafe, -- because it can throw runtime exceptions in two cases: @@ -1538,6 +1539,12 @@ data FromClause = | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool))) | OnClause (SqlExpr (Value Bool)) +collectIdents :: FromClause -> Set Ident +collectIdents fc = case fc of + FromStart i _ -> Set.singleton i + FromJoin lhs _ rhs _ -> collectIdents lhs <> collectIdents rhs + OnClause _ -> mempty + instance Show FromClause where show fc = case fc of FromStart i _ -> @@ -1549,10 +1556,11 @@ instance Show FromClause where , " " , show jk , " " - , show rhs , case mexpr of - Nothing -> "" + Nothing -> "(no on clause)" Just expr -> "(" <> render' expr <> ")" + , " " + , show rhs , ")" ] OnClause expr -> @@ -1578,6 +1586,7 @@ collectOnClauses -> [FromClause] -> Either (SqlExpr (Value Bool)) [FromClause] collectOnClauses sqlBackend = go Set.empty [] + -- . (\fc -> Debug.trace ("From Clauses: " <> show fc) fc) where go is [] (f@(FromStart i _) : fs) = fmap (f:) (go (Set.insert i is) [] fs) -- fast path @@ -1595,6 +1604,7 @@ collectOnClauses sqlBackend = go Set.empty [] -> SqlExpr (Value Bool) -> Either (SqlExpr (Value Bool)) (Set Ident, [FromClause]) findMatching idents fromClauses expr = + -- Debug.trace ("From Clause: " <> show fromClauses) $ case fromClauses of f : acc -> let @@ -1634,12 +1644,18 @@ collectOnClauses sqlBackend = go Set.empty [] <$> tryMatch idents expr l matchPartial = do + --Debug.traceM $ "matchPartial" + --Debug.traceM $ "matchPartial: identsInOnClause: " <> show identsInOnClause i1 <- findLeftmostIdent l i2 <- findLeftmostIdent r + let leftIdents = collectIdents l + -- Debug.traceM $ "matchPartial: i1: " <> show i1 + -- Debug.traceM $ "matchPartial: i2: " <> show i2 + -- Debug.traceM $ "matchPartial: idents: " <> show idents guard $ Set.isSubsetOf identsInOnClause - (Set.fromList [i1, i2]) + (Set.fromList [i1, i2] <> leftIdents) guard $ k /= CrossJoinKind guard $ Maybe.isNothing onClause pure (idents, FromJoin l k r (Just expr)) diff --git a/test/Common/Test.hs b/test/Common/Test.hs index ceebd5b..b9e71bf 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -104,6 +104,10 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| Asdf shoop ShoopId deriving Show Eq + Another + why BazId + YetAnother + argh ShoopId Person name String @@ -2210,6 +2214,17 @@ testOnClauseOrder run = describe "On Clause Ordering" $ do on $ baz ^. BazId ==. shoop ^. ShoopBaz on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId pure (f ^. FooName) + it "indirect association across" $ do + run $ void $ + selectRethrowingQuery $ + from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf `InnerJoin` another `InnerJoin` yetAnother) -> do + on $ f ^. FooId ==. b ^. BarQuux + on $ f ^. FooId ==. baz ^. BazBlargh + on $ baz ^. BazId ==. shoop ^. ShoopBaz + on $ asdf ^. AsdfShoop ==. shoop ^. ShoopId + on $ another ^. AnotherWhy ==. baz ^. BazId + on $ yetAnother ^. YetAnotherArgh ==. shoop ^. ShoopId + pure (f ^. FooName) describe "rightmost nesting" $ do it "direct associations" $ do @@ -2230,7 +2245,6 @@ testOnClauseOrder run = describe "On Clause Ordering" $ do on $ baz ^. BazId ==. shoop ^. ShoopBaz pure (f ^. FooName) - listsEqualOn :: (Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) -> Expectation listsEqualOn a b f = map f a `shouldBe` map f b