Allow any parenthesization of JOINs.

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
+    :: IsJoinKind join
-       , PersistEntityBackend a ~ backend
+    => expr (PreprocessedFrom a)
-       , IsJoinKind join )
+    -> expr (PreprocessedFrom b)
-    => expr (PreprocessedFrom b)
+    -> query (expr (PreprocessedFrom (join a b)))
-    -> query (expr (PreprocessedFrom (join (expr (Entity 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)
+         , FromPreprocess query expr backend (InnerJoin a b)
-         ) => From query expr backend (InnerJoin (expr (Entity val)) b) where
+         ) => 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)
+         , FromPreprocess query expr backend (CrossJoin a b)
-         ) => From query expr backend (CrossJoin (expr (Entity val)) b) where
+         ) => 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)
+         , FromPreprocess query expr backend (LeftOuterJoin a b)
-         ) => From query expr backend (LeftOuterJoin (expr (Entity val)) b) where
+         ) => 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)
+         , FromPreprocess query expr backend (RightOuterJoin a b)
-         ) => From query expr backend (RightOuterJoin (expr (Entity val)) b) where
+         ) => 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)
+         , FromPreprocess query expr backend (FullOuterJoin a b)
-         ) => From query expr backend (FullOuterJoin (expr (Entity val)) b) where
+         ) => 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
+         , FromPreprocess query expr backend a
-         , PersistEntityBackend val ~ backend
-         , IsJoinKind join
          , FromPreprocess query expr backend b
-         ) => FromPreprocess query expr backend (join (expr (Entity val)) b) where
+         , IsJoinKind join
-  fromPreprocess = fromPreprocess >>= fromJoin
+         ) => FromPreprocess query expr backend (join a b) where
+  fromPreprocess = do
+    a <- fromPreprocess
+    b <- fromPreprocess
+    fromJoin a 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 =
+    findMatching (FromJoin l k r Nothing : acc) expr =
-      return (FromJoin i e k f (Just expr) : acc)
+      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
+  fromJoin (EPreprocessedFrom lhsRet lhsFrom)
-    lhsIdent <- S.supply
+           (EPreprocessedFrom rhsRet rhsFrom) = Q $ do
-    let lhsRet = EEntity lhsIdent
+    let ret   = smartJoin lhsRet rhsRet
-        ret    = smartJoin lhsRet rhsRet
+        from_ = FromJoin lhsFrom             -- LHS
-        from_  = FromJoin lhsIdent (entityDef $ getVal lhsRet) -- LHS
+                         (reifyJoinKind ret) -- JOIN
-                          (reifyJoinKind ret)                  -- JOIN
+                         rhsFrom             -- RHS
-                          rhsFrom                              -- RHS
+                         Nothing             -- ON
-                          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) =
+    mk (FromJoin lhs kind rhs monClause) =
-      mconcat [ base i def
+      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?)"
 

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