haskell/esqueleto
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lord

Browse Source
This commit is contained in:
parsonsmatt 2019-10-29 14:07:53 -06:00
parent 6a8239ac93
commit 0c9b41a87d
2 changed files with 93 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
src/Database/Esqueleto/Internal/Internal.hs
View File

@ -64,6 +64,7 @@ import qualified Data.Text.Lazy.Builder as TLB
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Text.Blaze.Html (Html) import Text.Blaze.Html (Html)
import qualified Debug.Trace as Debug
import Database.Esqueleto.Internal.ExprParser (TableAccess(..), parseOnExpr) import Database.Esqueleto.Internal.ExprParser (TableAccess(..), parseOnExpr)
-- | (Internal) Start a 'from' query with an entity. 'from' -- | (Internal) Start a 'from' query with an entity. 'from'
@ -1125,7 +1126,7 @@ data JoinKind =
| LeftOuterJoinKind -- ^ @LEFT OUTER JOIN@ | LeftOuterJoinKind -- ^ @LEFT OUTER JOIN@
| RightOuterJoinKind -- ^ @RIGHT OUTER JOIN@ | RightOuterJoinKind -- ^ @RIGHT OUTER JOIN@
| FullOuterJoinKind -- ^ @FULL OUTER JOIN@ | FullOuterJoinKind -- ^ @FULL OUTER JOIN@
deriving Eq deriving (Eq, Show)
-- | (Internal) Functions that operate on types (that should be) -- | (Internal) Functions that operate on types (that should be)
@ -1538,6 +1539,33 @@ data FromClause =
| FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool))) | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool)))
| OnClause (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. -- | A part of a @SET@ clause.
newtype SetClause = SetClause (SqlExpr (Value ())) newtype SetClause = SetClause (SqlExpr (Value ()))
@ -1551,6 +1579,7 @@ collectOnClauses
-> [FromClause] -> [FromClause]
-> Either (SqlExpr (Value Bool)) [FromClause] -> Either (SqlExpr (Value Bool)) [FromClause]
collectOnClauses sqlBackend = go Set.empty [] collectOnClauses sqlBackend = go Set.empty []
-- . (\fcs -> Debug.trace (mappend "FromClauses: " (show fcs)) fcs)
where where
go is [] (f@(FromStart i _) : fs) = go is [] (f@(FromStart i _) : fs) =
fmap (f:) (go (Set.insert i is) [] fs) -- fast path fmap (f:) (go (Set.insert i is) [] fs) -- fast path
@ -1599,39 +1628,53 @@ collectOnClauses sqlBackend = go Set.empty []
tryMatch idents expr fromClause = tryMatch idents expr fromClause =
case fromClause of case fromClause of
FromJoin l k r onClause -> FromJoin l k r onClause ->
matchTable <|> matchR <|> matchC <|> matchL <|> matchPartial -- right to left matchR <|> matchTable <|> matchL <|> matchPartial <|> matchC -- right to left
where where
matchR = fmap (\r' -> FromJoin l k r' onClause) matchR = fmap (\r' -> FromJoin l k r' onClause)
<$> tryMatch idents expr r <$> tryMatch idents expr r
matchL = fmap (\l' -> FromJoin l' k r onClause) matchL = fmap (\l' -> FromJoin l' k r onClause)
<$> tryMatch idents expr l <$> tryMatch idents expr l
matchPartial = do matchPartial = do
i1 <- findLeftmostIdent l -- Debug.traceM $ "matchPartial"
i2 <- findRightmostIdent r -- 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 $ guard $
Set.isSubsetOf Set.isSubsetOf
identsInOnClause identsInOnClause
(Set.fromList [i1, i2]) (Set.fromList [ll, rr])
-- Debug.traceM "matchPartial: passed subset check"
guard $ k /= CrossJoinKind guard $ k /= CrossJoinKind
-- Debug.traceM "matchPartial: passed cross join kind check"
guard $ Maybe.isNothing onClause guard $ Maybe.isNothing onClause
-- Debug.traceM "matchPartial: passed isNothing check!"
pure (Set.fromList [] <> idents, FromJoin l k r (Just expr)) pure (Set.fromList [] <> idents, FromJoin l k r (Just expr))
matchC = matchC =
case onClause of case onClause of
Nothing Nothing
| "?" `T.isInfixOf` renderedExpr -> | "?" `T.isInfixOf` renderedExpr ->
-- Debug.trace ("matchC success" <> show identsInOnClause) $
return (idents, FromJoin l k r (Just expr)) return (idents, FromJoin l k r (Just expr))
| Set.null identsInOnClause -> | Set.null identsInOnClause ->
-- Debug.trace ("matchC success" <> show identsInOnClause) $
return (idents, FromJoin l k r (Just expr)) return (idents, FromJoin l k r (Just expr))
| otherwise -> | otherwise ->
Nothing Nothing
Just _ -> Just _ ->
Nothing Nothing
matchTable = do matchTable = do
-- Debug.traceM $ "matchTable: " <> show identsInOnClause
i1 <- findLeftmostIdent r i1 <- findLeftmostIdent r
i2 <- findRightmostIdent l i2 <- findRightmostIdent l
guard $ Set.fromList [i1, i2] `Set.isSubsetOf` identsInOnClause guard $ Set.fromList [i1, i2] `Set.isSubsetOf` identsInOnClause
guard $ k /= CrossJoinKind guard $ k /= CrossJoinKind
guard $ Maybe.isNothing onClause guard $ Maybe.isNothing onClause
-- Debug.traceM $ "matchTable: succeed " <> show identsInOnClause
pure (Set.fromList [i1, i2] <> idents, FromJoin l k r (Just expr)) pure (Set.fromList [i1, i2] <> idents, FromJoin l k r (Just expr))
_ -> _ ->

63
test/Common/Test.hs
View File

@ -101,6 +101,9 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
Shoop Shoop
baz BazId baz BazId
deriving Show Eq deriving Show Eq
Asdf
shoop ShoopId
deriving Show Eq
Person Person
name String name String
@ -116,6 +119,9 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
body String body String
blog BlogPostId blog BlogPostId
deriving Eq Show deriving Eq Show
CommentReply
body String
comment CommentId
Profile Profile
name String name String
person PersonId person PersonId
@ -2172,7 +2178,7 @@ testOnClauseOrder run = describe "On Clause Ordering" $ do
describe "works with nested joins" $ do describe "works with nested joins" $ do
it "unnested" $ do it "unnested" $ do
run $ void $ run $ void $
select $ selectRethrowingQuery $
from $ \(f `InnerJoin` b `LeftOuterJoin` baz `InnerJoin` shoop) -> do from $ \(f `InnerJoin` b `LeftOuterJoin` baz `InnerJoin` shoop) -> do
on $ f ^. FooId ==. b ^. BarQuux on $ f ^. FooId ==. b ^. BarQuux
on $ f ^. FooId ==. baz ^. BazBlargh on $ f ^. FooId ==. baz ^. BazBlargh
@ -2180,28 +2186,49 @@ testOnClauseOrder run = describe "On Clause Ordering" $ do
pure ( f ^. FooName) pure ( f ^. FooName)
it "leftmost nesting" $ do it "leftmost nesting" $ do
run $ void $ run $ void $
select $ selectRethrowingQuery $
from $ \((f `InnerJoin` b) `LeftOuterJoin` baz `InnerJoin` shoop) -> do from $ \((f `InnerJoin` b) `LeftOuterJoin` baz `InnerJoin` shoop) -> do
on $ f ^. FooId ==. b ^. BarQuux on $ f ^. FooId ==. b ^. BarQuux
on $ f ^. FooId ==. baz ^. BazBlargh on $ f ^. FooId ==. baz ^. BazBlargh
on $ baz ^. BazId ==. shoop ^. ShoopBaz on $ baz ^. BazId ==. shoop ^. ShoopBaz
pure ( f ^. FooName) pure ( f ^. FooName)
it "middle nesting" $ do describe "middle nesting" $ do
run $ void $ it "direct association" $ do
select $ run $ void $
from $ \(f `InnerJoin` (b `LeftOuterJoin` baz) `InnerJoin` shoop) -> do selectRethrowingQuery $
on $ f ^. FooId ==. b ^. BarQuux from $ \(p `InnerJoin` (bp `LeftOuterJoin` c) `LeftOuterJoin` cr) -> do
on $ f ^. FooId ==. baz ^. BazBlargh on $ p ^. PersonId ==. bp ^. BlogPostAuthorId
on $ baz ^. BazId ==. shoop ^. ShoopBaz on $ just (bp ^. BlogPostId) ==. c ?. CommentBlog
pure ( f ^. FooName) on $ c ?. CommentId ==. cr ?. CommentReplyComment
it "rightmost nesting" $ do pure (p,bp,c,cr)
run $ void $ it "indirect association" $ do
select $ run $ void $
from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop)) -> do selectRethrowingQuery $
on $ f ^. FooId ==. b ^. BarQuux from $ \(f `InnerJoin` b `LeftOuterJoin` (baz `InnerJoin` shoop) `InnerJoin` asdf) -> do
on $ f ^. FooId ==. baz ^. BazBlargh on $ f ^. FooId ==. b ^. BarQuux
on $ baz ^. BazId ==. shoop ^. ShoopBaz on $ f ^. FooId ==. baz ^. BazBlargh
pure ( f ^. FooName) 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 listsEqualOn :: (Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) -> Expectation