diff --git a/changelog.md b/changelog.md index cd04b73..4f8b32a 100644 --- 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 diff --git a/esqueleto.cabal b/esqueleto.cabal index 57f6a6e..a6cdf85 100644 --- 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. . diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index ddc6e83..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: @@ -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 diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 806e0f1..b9e71bf 100644 --- 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