diff --git a/src/Database/Esqueleto/Internal/Language.hs b/src/Database/Esqueleto/Internal/Language.hs index 44bdabd..0c2e5f6 100644 --- a/src/Database/Esqueleto/Internal/Language.hs +++ b/src/Database/Esqueleto/Internal/Language.hs @@ -48,11 +48,10 @@ class (Functor query, Applicative query, Monad query) => => query (expr (PreprocessedFrom (expr (Maybe (Entity a))))) -- | (Internal) Do a @JOIN@. fromJoin - :: ( PersistEntity a - , PersistEntityBackend a ~ backend - , IsJoinKind join ) - => expr (PreprocessedFrom b) - -> query (expr (PreprocessedFrom (join (expr (Entity a)) b))) + :: IsJoinKind join + => expr (PreprocessedFrom a) + -> expr (PreprocessedFrom b) + -> query (expr (PreprocessedFrom (join a b))) -- | (Internal) Finish a @JOIN@. fromFinish :: expr (PreprocessedFrom a) @@ -286,28 +285,28 @@ instance ( Esqueleto query expr backend from_ = fromPreprocess >>= fromFinish instance ( Esqueleto query expr backend - , FromPreprocess query expr backend (InnerJoin (expr (Entity val)) b) - ) => From query expr backend (InnerJoin (expr (Entity val)) b) where + , FromPreprocess query expr backend (InnerJoin a b) + ) => From query expr backend (InnerJoin a b) where from_ = fromPreprocess >>= fromFinish instance ( Esqueleto query expr backend - , FromPreprocess query expr backend (CrossJoin (expr (Entity val)) b) - ) => From query expr backend (CrossJoin (expr (Entity val)) b) where + , FromPreprocess query expr backend (CrossJoin a b) + ) => From query expr backend (CrossJoin a b) where from_ = fromPreprocess >>= fromFinish instance ( Esqueleto query expr backend - , FromPreprocess query expr backend (LeftOuterJoin (expr (Entity val)) b) - ) => From query expr backend (LeftOuterJoin (expr (Entity val)) b) where + , FromPreprocess query expr backend (LeftOuterJoin a b) + ) => From query expr backend (LeftOuterJoin a b) where from_ = fromPreprocess >>= fromFinish instance ( Esqueleto query expr backend - , FromPreprocess query expr backend (RightOuterJoin (expr (Entity val)) b) - ) => From query expr backend (RightOuterJoin (expr (Entity val)) b) where + , FromPreprocess query expr backend (RightOuterJoin a b) + ) => From query expr backend (RightOuterJoin a b) where from_ = fromPreprocess >>= fromFinish instance ( Esqueleto query expr backend - , FromPreprocess query expr backend (FullOuterJoin (expr (Entity val)) b) - ) => From query expr backend (FullOuterJoin (expr (Entity val)) b) where + , FromPreprocess query expr backend (FullOuterJoin a b) + ) => From query expr backend (FullOuterJoin a b) where from_ = fromPreprocess >>= fromFinish instance ( From query expr backend a @@ -386,9 +385,11 @@ instance ( Esqueleto query expr backend fromPreprocess = fromStartMaybe instance ( Esqueleto query expr backend - , PersistEntity val - , PersistEntityBackend val ~ backend - , IsJoinKind join + , FromPreprocess query expr backend a , FromPreprocess query expr backend b - ) => FromPreprocess query expr backend (join (expr (Entity val)) b) where - fromPreprocess = fromPreprocess >>= fromJoin + , IsJoinKind join + ) => FromPreprocess query expr backend (join a b) where + fromPreprocess = do + a <- fromPreprocess + b <- fromPreprocess + fromJoin a b diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index 0230ab5..e082071 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -64,7 +64,7 @@ instance Monoid SideData where -- | A part of a @FROM@ clause. data FromClause = FromStart Ident EntityDef - | FromJoin Ident EntityDef JoinKind FromClause (Maybe (SqlExpr (Single Bool))) + | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Single Bool))) | OnClause (SqlExpr (Single Bool)) @@ -79,8 +79,8 @@ collectOnClauses = go [] go acc (f:fs) = go (f:acc) fs go acc [] = return $ reverse acc - findMatching (FromJoin i e k f Nothing : acc) expr = - return (FromJoin i e k f (Just expr) : acc) + findMatching (FromJoin l k r Nothing : acc) expr = + return (FromJoin l k r (Just expr) : acc) findMatching (f : acc) expr = (f:) <$> findMatching acc expr findMatching [] expr = Left expr @@ -142,16 +142,15 @@ instance Esqueleto SqlQuery SqlExpr SqlPersist where maybelize (EPreprocessedFrom ret from_) = EPreprocessedFrom (EMaybe ret) from_ maybelize _ = error "Esqueleto/Sql/fromStartMaybe: never here (see GHC #6124)" - fromJoin (EPreprocessedFrom rhsRet rhsFrom) = Q $ do - lhsIdent <- S.supply - let lhsRet = EEntity lhsIdent - ret = smartJoin lhsRet rhsRet - from_ = FromJoin lhsIdent (entityDef $ getVal lhsRet) -- LHS - (reifyJoinKind ret) -- JOIN - rhsFrom -- RHS - Nothing -- ON + fromJoin (EPreprocessedFrom lhsRet lhsFrom) + (EPreprocessedFrom rhsRet rhsFrom) = Q $ do + let ret = smartJoin lhsRet rhsRet + from_ = FromJoin lhsFrom -- LHS + (reifyJoinKind ret) -- JOIN + rhsFrom -- RHS + Nothing -- ON return (EPreprocessedFrom ret from_) - fromJoin _ = error "Esqueleto/Sql/fromJoin: never here (see GHC #6124)" + fromJoin _ _ = error "Esqueleto/Sql/fromJoin: never here (see GHC #6124)" fromFinish (EPreprocessedFrom ret from_) = Q $ do W.tell mempty { sdFromClause = [from_] } @@ -299,10 +298,10 @@ makeFrom esc fs = ret Right fs' -> first ("\nFROM " <>) $ uncommas' (map mk fs') mk (FromStart (I i) def) = base i def - mk (FromJoin (I i) def kind rest monClause) = - mconcat [ base i def + mk (FromJoin lhs kind rhs monClause) = + mconcat [ mk lhs , (fromKind kind, mempty) - , mk rest + , mk rhs , maybe mempty makeOnClause monClause ] mk (OnClause _) = error "Esqueleto/Sql/makeFrom: never here (is collectOnClauses working?)" diff --git a/test/Test.hs b/test/Test.hs index fab2227..a5c50f7 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -127,6 +127,22 @@ main = do , (p3e, Just b31e) , (p2e, Nothing) ] + it "typechecks (A LEFT OUTER JOIN (B LEFT OUTER JOIN C))" $ + let _ = run $ + select $ + from $ \(a `LeftOuterJoin` (b `LeftOuterJoin` c)) -> + let _ = [a, b, c] :: [ SqlExpr (Entity Person) ] + in return a + in return () :: IO () + + it "typechecks ((A LEFT OUTER JOIN B) LEFT OUTER JOIN C)" $ + let _ = run $ + select $ + from $ \((a `LeftOuterJoin` b) `LeftOuterJoin` c) -> + let _ = [a, b, c] :: [ SqlExpr (Entity Person) ] + in return a + in return () :: IO () + it "throws an error for using on without joins" $ run (do p1e <- insert' p1