From 55fec71ed4ef786a5b60a7b2f6f4deed956a7a95 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 29 Oct 2019 08:49:49 -0600 Subject: [PATCH 1/8] Add instance of UnsafeSqlFunctionArgument () --- changelog.md | 7 +++++++ esqueleto.cabal | 2 +- src/Database/Esqueleto/Internal/Internal.hs | 17 ++++++++++++----- test/PostgreSQL/Test.hs | 10 +++++++++- 4 files changed, 29 insertions(+), 7 deletions(-) diff --git a/changelog.md b/changelog.md index 5890340..cd04b73 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,10 @@ +3.2.1 +======== + +- @parsonsmatt + = [#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 e71220f..57f6a6e 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.2.0 +version: 3.2.1 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 16bbc6a..ddc6e83 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -1053,12 +1053,12 @@ instance FinalResult (Unique val) where instance (FinalResult b) => FinalResult (a -> b) where finalR f = finalR (f undefined) --- | Convert a constructor for a 'Unique' key on a record to the 'UniqueDef' that defines it. You --- can supply just the constructor itself, or a value of the type - the library is capable of figuring +-- | Convert a constructor for a 'Unique' key on a record to the 'UniqueDef' that defines it. You +-- can supply just the constructor itself, or a value of the type - the library is capable of figuring -- it out from there. -- -- @since 3.1.3 -toUniqueDef :: forall a val. (KnowResult a ~ (Unique val), PersistEntity val,FinalResult a) => +toUniqueDef :: forall a val. (KnowResult a ~ (Unique val), PersistEntity val,FinalResult a) => a -> UniqueDef toUniqueDef uniqueConstructor = uniqueDef where @@ -1071,9 +1071,9 @@ toUniqueDef uniqueConstructor = uniqueDef uniqueDef = head . filter filterF . entityUniques . entityDef $ proxy -- | Render updates to be use in a SET clause for a given sql backend. --- +-- -- @since 3.1.3 -renderUpdates :: (BackendCompatible SqlBackend backend) => +renderUpdates :: (BackendCompatible SqlBackend backend) => backend -> [SqlExpr (Update val)] -> (TLB.Builder, [PersistValue]) @@ -2025,6 +2025,13 @@ unsafeSqlCastAs _ (ECompositeKey _) = throw (CompositeKeyErr SqlCastAsError) class UnsafeSqlFunctionArgument a where toArgList :: a -> [SqlExpr (Value ())] + +-- | Useful for 0-argument functions, like @now@ in Postgresql. +-- +-- @since 3.2.1 +instance UnsafeSqlFunctionArgument () where + toArgList _ = [] + instance (a ~ Value b) => UnsafeSqlFunctionArgument (SqlExpr a) where toArgList = (:[]) . veryUnsafeCoerceSqlExprValue instance UnsafeSqlFunctionArgument a => diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index b008f13..2b7b99e 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -25,7 +25,7 @@ import qualified Data.List as L import Data.Ord (comparing) import qualified Data.Text as T import qualified Data.Text.Encoding as TE -import Data.Time.Clock (getCurrentTime, diffUTCTime) +import Data.Time.Clock (getCurrentTime, diffUTCTime, UTCTime) import Database.Esqueleto hiding (random_) import qualified Database.Esqueleto.Internal.Sql as ES import Database.Esqueleto.PostgreSQL (random_) @@ -493,6 +493,14 @@ testPostgresModule = do [Value (ret :: String)] <- select $ return (EP.chr (val 65)) liftIO $ ret `shouldBe` "A" + it "allows unit for functions" $ do + vals <- run $ do + let + fn :: SqlExpr (Value UTCTime) + fn = ES.unsafeSqlFunction "now" () + select $ pure fn + vals `shouldSatisfy` ((1 ==) . length) + it "works with now" $ run $ do nowDb <- select $ return EP.now_ From 214f1906da935cd11aa8be3d5dffc2ad8b0f2348 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 29 Oct 2019 08:53:13 -0600 Subject: [PATCH 2/8] Use now, clean a warn --- src/Database/Esqueleto/PostgreSQL.hs | 30 ++++++++++++++-------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 8f70fb2..dd1eab5 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -35,7 +35,7 @@ import Data.Time.Clock (UTCTime) import Database.Esqueleto.Internal.Language hiding (random_) import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy) import Database.Esqueleto.Internal.Sql -import Database.Esqueleto.Internal.Internal (EsqueletoError(..), CompositeKeyError(..), +import Database.Esqueleto.Internal.Internal (EsqueletoError(..), CompositeKeyError(..), UnexpectedCaseError(..), SetClause, Ident(..), uncommas, FinalResult(..), toUniqueDef, KnowResult, renderUpdates) @@ -44,7 +44,7 @@ import Data.List.NonEmpty ( NonEmpty( (:|) ) import Data.Int (Int64) import Data.Proxy (Proxy(..)) import Control.Arrow ((***), first) -import Control.Exception (Exception, throw, throwIO) +import Control.Exception (throw) import Control.Monad (void) import Control.Monad.IO.Class (MonadIO (..)) import qualified Control.Monad.Trans.Reader as R @@ -169,7 +169,7 @@ chr :: SqlString s => SqlExpr (Value Int) -> SqlExpr (Value s) chr = unsafeSqlFunction "chr" now_ :: SqlExpr (Value UTCTime) -now_ = unsafeSqlValue "NOW()" +now_ = unsafeSqlFunction "NOW" () upsert :: (MonadIO m, PersistEntity record, @@ -200,7 +200,7 @@ upsertBy :: (MonadIO m, upsertBy uniqueKey record updates = do sqlB <- R.ask maybe - (throw (UnexpectedCaseErr OperationNotSupported)) -- Postgres backend should have connUpsertSql, if this error is thrown, check changes on persistent + (throw (UnexpectedCaseErr OperationNotSupported)) -- Postgres backend should have connUpsertSql, if this error is thrown, check changes on persistent (handler sqlB) (connUpsertSql sqlB) where @@ -230,7 +230,7 @@ upsertBy uniqueKey record updates = do -- deriving Eq Show -- |] -- --- insertSelectWithConflict +-- insertSelectWithConflict -- UniqueFoo -- (UniqueFoo undefined) or (UniqueFoo anyNumber) would also work -- (from $ \b -> -- return $ Foo <# (b ^. BarNum) @@ -240,18 +240,18 @@ upsertBy uniqueKey record updates = do -- ) -- @ -- --- Inserts to table Foo all Bar.num values and in case of conflict SomeFooUnique, +-- Inserts to table Foo all Bar.num values and in case of conflict SomeFooUnique, -- the conflicting value is updated to the current plus the excluded. -- -- @since 3.1.3 insertSelectWithConflict :: forall a m val. ( FinalResult a, - KnowResult a ~ (Unique val), - MonadIO m, - PersistEntity val) => + KnowResult a ~ (Unique val), + MonadIO m, + PersistEntity val) => a -- ^ Unique constructor or a unique, this is used just to get the name of the postgres constraint, the value(s) is(are) never used, so if you have a unique "MyUnique 0", "MyUnique undefined" would work as well. - -> SqlQuery (SqlExpr (Insertion val)) + -> SqlQuery (SqlExpr (Insertion val)) -- ^ Insert query. -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)]) -- ^ A list of updates to be applied in case of the constraint being violated. The expression takes the current and excluded value to produce the updates. @@ -263,11 +263,11 @@ insertSelectWithConflict unique query = void . insertSelectWithConflictCount uni -- @since 3.1.3 insertSelectWithConflictCount :: forall a val m. ( FinalResult a, - KnowResult a ~ (Unique val), - MonadIO m, - PersistEntity val) => + KnowResult a ~ (Unique val), + MonadIO m, + PersistEntity val) => a - -> SqlQuery (SqlExpr (Insertion val)) + -> SqlQuery (SqlExpr (Insertion val)) -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)]) -> SqlWriteT m Int64 insertSelectWithConflictCount unique query conflictQuery = do @@ -292,7 +292,7 @@ insertSelectWithConflictCount unique query conflictQuery = do TLB.fromText "ON CONFLICT ON CONSTRAINT \"", constraint, TLB.fromText "\" DO " - ] ++ if null updates then [TLB.fromText "NOTHING"] else [ + ] ++ if null updates then [TLB.fromText "NOTHING"] else [ TLB.fromText "UPDATE SET ", updatesTLB ]),values) From 6a8239ac934699ba4d482935b9b0e4febf377b1b Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 29 Oct 2019 11:50:10 -0600 Subject: [PATCH 3/8] Add test cases --- test/Common/Test.hs | 50 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 806e0f1..2a6da38 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -95,6 +95,12 @@ 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 Person name String @@ -2152,6 +2158,50 @@ 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 $ + select $ + 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 $ + select $ + 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 "middle nesting" $ do + run $ void $ + select $ + 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 "rightmost nesting" $ do + run $ void $ + select $ + 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 From 0c9b41a87d137becce0091e1d9353bbed0773365 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 29 Oct 2019 14:07:53 -0600 Subject: [PATCH 4/8] lord --- src/Database/Esqueleto/Internal/Internal.hs | 53 +++++++++++++++-- test/Common/Test.hs | 63 +++++++++++++++------ 2 files changed, 93 insertions(+), 23 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index ddc6e83..bd5190c 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 qualified Debug.Trace as Debug import Database.Esqueleto.Internal.ExprParser (TableAccess(..), parseOnExpr) -- | (Internal) Start a 'from' query with an entity. 'from' @@ -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,33 @@ data FromClause = | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool))) | OnClause (SqlExpr (Value Bool)) +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 + , " " + , show rhs + , case mexpr of + Nothing -> "" + Just expr -> "(" <> render' expr <> ")" + , ")" + ] + 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 +1579,7 @@ collectOnClauses -> [FromClause] -> Either (SqlExpr (Value Bool)) [FromClause] collectOnClauses sqlBackend = go Set.empty [] + -- . (\fcs -> Debug.trace (mappend "FromClauses: " (show fcs)) fcs) where go is [] (f@(FromStart i _) : fs) = fmap (f:) (go (Set.insert i is) [] fs) -- fast path @@ -1599,39 +1628,53 @@ collectOnClauses sqlBackend = go Set.empty [] tryMatch idents expr fromClause = case fromClause of FromJoin l k r onClause -> - matchTable <|> matchR <|> matchC <|> matchL <|> matchPartial -- right to left + matchR <|> matchTable <|> matchL <|> matchPartial <|> matchC -- right to left where matchR = fmap (\r' -> FromJoin l k r' onClause) <$> tryMatch idents expr r matchL = fmap (\l' -> FromJoin l' k r onClause) <$> tryMatch idents expr l + matchPartial = do - i1 <- findLeftmostIdent l - i2 <- findRightmostIdent r + -- Debug.traceM $ "matchPartial" + -- Debug.traceM $ "matchPartial: identsInOnClause: " <> show identsInOnClause + -- Debug.traceM $ "matchPartial: seen idents: " <> show idents + ll <- findLeftmostIdent l + -- Debug.traceM $ "matchPartial: ll: " <> show ll + rr <- findLeftmostIdent r + -- Debug.traceM $ "matchPartial: rr: " <> show rr guard $ Set.isSubsetOf identsInOnClause - (Set.fromList [i1, i2]) + (Set.fromList [ll, rr]) + -- Debug.traceM "matchPartial: passed subset check" guard $ k /= CrossJoinKind + -- Debug.traceM "matchPartial: passed cross join kind check" guard $ Maybe.isNothing onClause + -- Debug.traceM "matchPartial: passed isNothing check!" pure (Set.fromList [] <> idents, FromJoin l k r (Just expr)) + matchC = case onClause of Nothing | "?" `T.isInfixOf` renderedExpr -> + -- Debug.trace ("matchC success" <> show identsInOnClause) $ return (idents, FromJoin l k r (Just expr)) | Set.null identsInOnClause -> + -- Debug.trace ("matchC success" <> show identsInOnClause) $ return (idents, FromJoin l k r (Just expr)) | otherwise -> Nothing Just _ -> Nothing matchTable = do + -- Debug.traceM $ "matchTable: " <> show identsInOnClause i1 <- findLeftmostIdent r i2 <- findRightmostIdent l guard $ Set.fromList [i1, i2] `Set.isSubsetOf` identsInOnClause guard $ k /= CrossJoinKind guard $ Maybe.isNothing onClause + -- Debug.traceM $ "matchTable: succeed " <> show identsInOnClause pure (Set.fromList [i1, i2] <> idents, FromJoin l k r (Just expr)) _ -> diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 2a6da38..ceebd5b 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -101,6 +101,9 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| Shoop baz BazId deriving Show Eq + Asdf + shoop ShoopId + deriving Show Eq Person name String @@ -116,6 +119,9 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| body String blog BlogPostId deriving Eq Show + CommentReply + body String + comment CommentId Profile name String person PersonId @@ -2172,7 +2178,7 @@ testOnClauseOrder run = describe "On Clause Ordering" $ do describe "works with nested joins" $ do it "unnested" $ do run $ void $ - select $ + selectRethrowingQuery $ from $ \(f `InnerJoin` b `LeftOuterJoin` baz `InnerJoin` shoop) -> do on $ f ^. FooId ==. b ^. BarQuux on $ f ^. FooId ==. baz ^. BazBlargh @@ -2180,28 +2186,49 @@ testOnClauseOrder run = describe "On Clause Ordering" $ do pure ( f ^. FooName) it "leftmost nesting" $ do run $ void $ - select $ + 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 "middle nesting" $ do - run $ void $ - select $ - 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 "rightmost nesting" $ do - run $ void $ - select $ - 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) + + 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 From edc7db8f3fbe4051ddaea73b550c74e28831ea30 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 29 Oct 2019 14:26:09 -0600 Subject: [PATCH 5/8] remove debug --- changelog.md | 9 ++++++++- src/Database/Esqueleto/Internal/Internal.hs | 14 -------------- 2 files changed, 8 insertions(+), 15 deletions(-) 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/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index bd5190c..376273d 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -64,7 +64,6 @@ import qualified Data.Text.Lazy.Builder as TLB import Data.Typeable (Typeable) import Text.Blaze.Html (Html) -import qualified Debug.Trace as Debug import Database.Esqueleto.Internal.ExprParser (TableAccess(..), parseOnExpr) -- | (Internal) Start a 'from' query with an entity. 'from' @@ -1579,7 +1578,6 @@ collectOnClauses -> [FromClause] -> Either (SqlExpr (Value Bool)) [FromClause] collectOnClauses sqlBackend = go Set.empty [] - -- . (\fcs -> Debug.trace (mappend "FromClauses: " (show fcs)) fcs) where go is [] (f@(FromStart i _) : fs) = fmap (f:) (go (Set.insert i is) [] fs) -- fast path @@ -1636,45 +1634,33 @@ collectOnClauses sqlBackend = go Set.empty [] <$> tryMatch idents expr l matchPartial = do - -- Debug.traceM $ "matchPartial" - -- Debug.traceM $ "matchPartial: identsInOnClause: " <> show identsInOnClause - -- Debug.traceM $ "matchPartial: seen idents: " <> show idents ll <- findLeftmostIdent l - -- Debug.traceM $ "matchPartial: ll: " <> show ll rr <- findLeftmostIdent r - -- Debug.traceM $ "matchPartial: rr: " <> show rr guard $ Set.isSubsetOf identsInOnClause (Set.fromList [ll, rr]) - -- Debug.traceM "matchPartial: passed subset check" guard $ k /= CrossJoinKind - -- Debug.traceM "matchPartial: passed cross join kind check" guard $ Maybe.isNothing onClause - -- Debug.traceM "matchPartial: passed isNothing check!" pure (Set.fromList [] <> idents, FromJoin l k r (Just expr)) matchC = case onClause of Nothing | "?" `T.isInfixOf` renderedExpr -> - -- Debug.trace ("matchC success" <> show identsInOnClause) $ return (idents, FromJoin l k r (Just expr)) | Set.null identsInOnClause -> - -- Debug.trace ("matchC success" <> show identsInOnClause) $ return (idents, FromJoin l k r (Just expr)) | otherwise -> Nothing Just _ -> Nothing matchTable = do - -- Debug.traceM $ "matchTable: " <> show identsInOnClause i1 <- findLeftmostIdent r i2 <- findRightmostIdent l guard $ Set.fromList [i1, i2] `Set.isSubsetOf` identsInOnClause guard $ k /= CrossJoinKind guard $ Maybe.isNothing onClause - -- Debug.traceM $ "matchTable: succeed " <> show identsInOnClause pure (Set.fromList [i1, i2] <> idents, FromJoin l k r (Just expr)) _ -> From f84945fb041bd8684926ae22b72f63ed0e5cb447 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 29 Oct 2019 14:26:48 -0600 Subject: [PATCH 6/8] add cabal --- esqueleto.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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. . From ae3b96e0f67f618d5c62a3c304daccf5b3ae685c Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 29 Oct 2019 14:29:27 -0600 Subject: [PATCH 7/8] cleaner diff --- src/Database/Esqueleto/Internal/Internal.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 376273d..d624e3d 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -1626,7 +1626,7 @@ collectOnClauses sqlBackend = go Set.empty [] tryMatch idents expr fromClause = case fromClause of FromJoin l k r onClause -> - matchR <|> matchTable <|> matchL <|> matchPartial <|> matchC -- right to left + matchTable <|> matchR <|> matchC <|> matchL <|> matchPartial -- right to left where matchR = fmap (\r' -> FromJoin l k r' onClause) <$> tryMatch idents expr r @@ -1634,15 +1634,15 @@ collectOnClauses sqlBackend = go Set.empty [] <$> tryMatch idents expr l matchPartial = do - ll <- findLeftmostIdent l - rr <- findLeftmostIdent r + i1 <- findLeftmostIdent l + i2 <- findLeftmostIdent r guard $ Set.isSubsetOf identsInOnClause - (Set.fromList [ll, rr]) + (Set.fromList [i1, i2]) 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 From 1627feafa309c5f0cb74f75960e71ee5e93e0407 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 29 Oct 2019 16:54:58 -0600 Subject: [PATCH 8/8] aha! --- src/Database/Esqueleto/Internal/Internal.hs | 26 +++++++++++++++++---- test/Common/Test.hs | 16 ++++++++++++- 2 files changed, 36 insertions(+), 6 deletions(-) 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