Merge pull request #161 from bitemyapp/matt/test-on-clause

Fix on clause nesting
2019-10-31 14:38:16 -06:00 · 2019-10-31 14:38:16 -06:00 · 04a73ed92d
commit 04a73ed92d
parent f9f953c89e 1627feafa3
4 changed files with 151 additions and 8 deletions
--- a/changelog.md
+++ b/changelog.md
@ -1,8 +1,15 @@
+3.2.2
+========
+
+- @parsonsmatt
+  - [#161](https://github.com/bitemyapp/esqueleto/pull/161/): Fix an issue where
+    nested joins didn't get the right on clause.
+
 3.2.1
 ========

 - @parsonsmatt
-  = [#159](https://github.com/bitemyapp/esqueleto/pull/159): Add an instance of `UnsafeSqlFunction ()` for 0-argument SQL
+  - [#159](https://github.com/bitemyapp/esqueleto/pull/159): Add an instance of `UnsafeSqlFunction ()` for 0-argument SQL
  functions.

 3.2.0
--- a/esqueleto.cabal
+++ b/esqueleto.cabal
@ -1,7 +1,7 @@
 cabal-version: 1.12

 name:           esqueleto
-version:        3.2.1
+version:        3.2.2
 synopsis:       Type-safe EDSL for SQL queries on persistent backends.
 description:    @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends.  Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime.
                .
--- 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:
@ -1125,7 +1126,7 @@ data JoinKind =
  | LeftOuterJoinKind  -- ^ @LEFT OUTER JOIN@
  | RightOuterJoinKind -- ^ @RIGHT OUTER JOIN@
  | FullOuterJoinKind  -- ^ @FULL OUTER JOIN@
-    deriving Eq
+    deriving (Eq, Show)


 -- | (Internal) Functions that operate on types (that should be)
@ -1538,6 +1539,40 @@ 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 _ ->
+      "(FromStart " <> show i <> ")"
+    FromJoin lhs jk rhs mexpr ->
+      mconcat
+        [ "(FromJoin "
+        , show lhs
+        , " "
+        , show jk
+        , " "
+        , case mexpr of
+            Nothing -> "(no on clause)"
+            Just expr -> "(" <> render' expr <> ")"
+        , " "
+        , show rhs
+        , ")"
+      ]
+    OnClause expr ->
+      "(OnClause " <> render' expr <> ")"
+
+
+    where
+      dummy = SqlBackend
+        { connEscapeName = \(DBName x) -> x
+        }
+      render' = T.unpack . renderExpr dummy
+

 -- | A part of a @SET@ clause.
 newtype SetClause = SetClause (SqlExpr (Value ()))
@ -1551,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
@ -1568,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
@ -1605,16 +1642,24 @@ collectOnClauses sqlBackend = go Set.empty []
                <$> tryMatch idents expr r
              matchL = fmap (\l' -> FromJoin l' k r onClause)
                <$> tryMatch idents expr l
+
              matchPartial = do
+                --Debug.traceM $ "matchPartial"
+                --Debug.traceM $ "matchPartial: identsInOnClause: " <> show identsInOnClause
                i1 <- findLeftmostIdent l
-                i2 <- findRightmostIdent r
+                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 (Set.fromList [] <> idents, FromJoin l k r (Just expr))
+                pure (idents, FromJoin l k r (Just expr))
+
              matchC =
                case onClause of
                  Nothing
--- a/test/Common/Test.hs
+++ b/test/Common/Test.hs
@ -95,6 +95,19 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
  Bar
    quux FooId
    deriving Show Eq Ord
+  Baz
+    blargh FooId
+    deriving Show Eq
+  Shoop
+    baz BazId
+    deriving Show Eq
+  Asdf
+    shoop ShoopId
+    deriving Show Eq
+  Another
+    why BazId
+  YetAnother
+    argh ShoopId

  Person
    name String
@ -110,6 +123,9 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
    body String
    blog BlogPostId
    deriving Eq Show
+  CommentReply
+    body String
+    comment CommentId
  Profile
    name String
    person PersonId
@ -2152,7 +2168,82 @@ testOnClauseOrder run = describe "On Clause Ordering" $ do
        pure (a, b)
      listsEqualOn a (map (\(x, y) -> (y, x)) b) id

+    it "works with joins in subselect" $ do
+      run $ void $
+        select $
+        from $ \(p `InnerJoin` r) -> do
+        on $ p ^. PersonId ==. r ^. ReplyGuy
+        pure . (,) (p ^. PersonName) $
+          subSelect $
+          from $ \(c `InnerJoin` bp) -> do
+          on $ bp ^. BlogPostId ==. c ^. CommentBlog
+          pure (c ^. CommentBody)

+    describe "works with nested joins" $ do
+      it "unnested" $ do
+        run $ void $
+          selectRethrowingQuery $
+          from $ \(f `InnerJoin` b `LeftOuterJoin` baz `InnerJoin` shoop) -> do
+          on $ f ^. FooId ==. b ^. BarQuux
+          on $ f ^. FooId ==. baz ^. BazBlargh
+          on $ baz ^. BazId ==. shoop ^. ShoopBaz
+          pure ( f ^. FooName)
+      it "leftmost nesting" $ do
+        run $ void $
+          selectRethrowingQuery $
+          from $ \((f `InnerJoin` b) `LeftOuterJoin` baz `InnerJoin` shoop) -> do
+          on $ f ^. FooId ==. b ^. BarQuux
+          on $ f ^. FooId ==. baz ^. BazBlargh
+          on $ baz ^. BazId ==. shoop ^. ShoopBaz
+          pure ( f ^. FooName)
+      describe "middle nesting" $ do
+        it "direct association" $ do
+          run $ void $
+            selectRethrowingQuery $
+            from $ \(p `InnerJoin` (bp `LeftOuterJoin` c) `LeftOuterJoin` cr) -> do
+            on $ p ^. PersonId ==. bp ^. BlogPostAuthorId
+            on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog
+            on $ c ?. CommentId ==. cr ?. CommentReplyComment
+            pure (p,bp,c,cr)
+        it "indirect association" $ do
+          run $ void $
+            selectRethrowingQuery $
+            from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf) -> do
+            on $ f ^. FooId ==. b ^. BarQuux
+            on $ f ^. FooId ==. baz ^. BazBlargh
+            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
+          run $ void $
+            selectRethrowingQuery $
+            from $ \(p `InnerJoin` bp `LeftOuterJoin` (c `LeftOuterJoin` cr)) -> do
+            on $ p ^. PersonId ==. bp ^. BlogPostAuthorId
+            on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog
+            on $ c ?. CommentId ==. cr ?. CommentReplyComment
+            pure (p,bp,c,cr)
+
+        it "indirect association" $ do
+          run $ void $
+            selectRethrowingQuery $
+            from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop)) -> do
+            on $ f ^. FooId ==. b ^. BarQuux
+            on $ f ^. FooId ==. baz ^. BazBlargh
+            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