aha!

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))

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