Convert all of experimental to use new From type instead of From type class. Make the data constructors second class, functions should be used. Introduce *Lateral functions, using the same type for lateral and non lateral queries was probably a mistake.

src/Database/Esqueleto/Experimental.hs

@@ -47,7 +47,7 @@ module Database.Esqueleto.Experimental
     , ToAliasT
     , ToAliasReference(..)
     , ToAliasReferenceT
-    , ToSetOperation(..)
+    , ToSqlSetOperation(..)
     , ValidOnClauseValue
     -- * The Normal Stuff
 

src/Database/Esqueleto/Experimental/From.hs

@@ -1,12 +1,16 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -14,14 +18,14 @@
 module Database.Esqueleto.Experimental.From
     where
 
+import Control.Arrow (first)
+import Control.Monad (ap)
 import qualified Control.Monad.Trans.Writer as W
 import Data.Proxy
 import qualified Data.Text.Lazy.Builder as TLB
 import Database.Esqueleto.Experimental.ToAlias
 import Database.Esqueleto.Experimental.ToAliasReference
-import           Database.Esqueleto.Internal.Internal             hiding
+import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
-                                                                  (From (..),
-                                                                   from, on)
 import Database.Esqueleto.Internal.PersistentImport
 
 -- | 'FROM' clause, used to bring entities into scope.
@@ -33,16 +37,20 @@ import           Database.Esqueleto.Internal.PersistentImport
 -- instances of `From`. This implementation eliminates certain
 -- types of runtime errors by preventing the construction of
 -- invalid SQL (e.g. illegal nested-@from@).
-from :: From a  => a -> SqlQuery (FromT a)
+from :: ToFrom a a' => a -> SqlQuery a'
-from parts = do
+from f = do
-    (a, clause) <- runFrom parts
+    (a, clause) <- unFrom (toFrom f)
-    Q $ W.tell mempty{sdFromClause=[FromRaw clause]}
+    Q $ W.tell mempty{sdFromClause=[FromRaw $ clause]}
     pure a
 
 type RawFn = NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])
-class From a where
+newtype From a = From
-    type FromT a
+    { unFrom :: SqlQuery (a, RawFn)}
-    runFrom :: a -> SqlQuery (FromT a, RawFn)
+
+class ToFrom a r | a -> r where
+    toFrom :: a -> From r
+instance ToFrom (From a) a where
+    toFrom = id
 
 -- | Data type for bringing a Table into scope in a JOIN tree
 --
@@ -50,19 +58,17 @@ class From a where
 -- select $ from $ Table \@People
 -- @
 data Table a = Table
+instance PersistEntity ent => ToFrom (Table ent) (SqlExpr (Entity ent)) where
+    toFrom _ = table
 
-instance PersistEntity a => From (Table a) where
+table :: forall ent. PersistEntity ent => From (SqlExpr (Entity ent))
-    type FromT (Table a) = SqlExpr (Entity a)
+table = From $ do
-    runFrom e@Table = do
+    let ed = entityDef (Proxy @ent)
-        let ed = entityDef $ getVal e
     ident <- newIdentFor (entityDB ed)
     let entity = unsafeSqlEntity ident
-        pure $ ( entity, \p -> base p ident ed )
+    pure $ ( entity, const $ base ident ed )
       where
-            getVal ::  Table ent -> Proxy ent
+        base ident@(I identText) def info =
-            getVal = const Proxy
-
-            base _ ident@(I identText) def info =
             let db@(DBName dbText) = entityDB def
             in ( fromDBName info db <>
                      if dbText == identText
@@ -74,39 +80,13 @@ instance PersistEntity a => From (Table a) where
 
 {-# DEPRECATED SubQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SubQuery@" #-}
 newtype SubQuery a = SubQuery a
+instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SubQuery (SqlQuery a)) a where
+    toFrom (SubQuery q) = selectQuery q
+instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SqlQuery a) a where
+    toFrom = selectQuery
 
-instance
+selectQuery :: (SqlSelect a r, ToAlias a, ToAliasReference a) => SqlQuery a -> From a
-    ( ToAlias a
+selectQuery subquery = From $ do
-    , ToAliasReference a
-    , SqlSelect a r
-    )
-  =>
-    From (SqlQuery a)
-  where
-    type FromT (SqlQuery a) = a
-    runFrom subquery =
-        fromSubQuery NormalSubQuery subquery
-
-instance
-    ( ToAlias a
-    , ToAliasReference a
-    , SqlSelect a r
-    )
-  =>
-    From (SubQuery (SqlQuery a))
-  where
-    type FromT (SubQuery (SqlQuery a)) = a
-    runFrom (SubQuery subquery) =
-        fromSubQuery NormalSubQuery subquery
-
-fromSubQuery
-    ::
-    ( SqlSelect a r
-    , ToAlias a
-    , ToAliasReference a
-    )
-    => SubQueryType -> SqlQuery a -> SqlQuery (a, RawFn)
-fromSubQuery subqueryType subquery = do
     -- We want to update the IdentState without writing the query to side data
     (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery
     aliasedValue <- toAlias ret
@@ -121,13 +101,8 @@ fromSubQuery subqueryType subquery = do
 
     pure (ref, \_ info ->
             let (queryText,queryVals) = toRawSql SELECT info aliasedQuery
-                lateralKeyword =
-                    case subqueryType of
-                      NormalSubQuery  -> ""
-                      LateralSubQuery -> "LATERAL "
             in
-            ( lateralKeyword <> (parens queryText) <> " AS " <> useIdent info subqueryAlias
+            ( (parens queryText) <> " AS " <> useIdent info subqueryAlias
             , queryVals
             )
          )
-

src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs

@@ -11,17 +11,9 @@ import           Database.Esqueleto.Experimental.From
 import Database.Esqueleto.Experimental.From.SqlSetOperation
 import Database.Esqueleto.Experimental.ToAlias
 import Database.Esqueleto.Experimental.ToAliasReference
-import           Database.Esqueleto.Internal.Internal                 hiding
+import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
-                                                                      (From (..),
-                                                                       from, on)
 import Database.Esqueleto.Internal.PersistentImport (DBName(..))
 
-data CommonTableExpression ref = CommonTableExpression Ident ref
-instance From (CommonTableExpression ref) where
-    type FromT (CommonTableExpression ref) = ref
-    runFrom (CommonTableExpression ident ref) =
-        pure (ref, (\_ info -> (useIdent info ident, mempty)))
-
 -- | @WITH@ clause used to introduce a [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression).
 -- CTEs are supported in most modern SQL engines and can be useful
 -- in performance tuning. In Esqueleto, CTEs should be used as a
@@ -46,7 +38,7 @@ instance From (CommonTableExpression ref) where
 with :: ( ToAlias a
         , ToAliasReference a
         , SqlSelect a r
-        ) => SqlQuery a -> SqlQuery (CommonTableExpression a)
+        ) => SqlQuery a -> SqlQuery (From a)
 with query = do
     (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ query
     aliasedValue <- toAlias ret
@@ -55,7 +47,7 @@ with query = do
     let clause = CommonTableExpressionClause NormalCommonTableExpression ident (\info -> toRawSql SELECT info aliasedQuery)
     Q $ W.tell mempty{sdCteClause = [clause]}
     ref <- toAliasReference ident aliasedValue
-    pure $ CommonTableExpression ident ref
+    pure $ From $ pure (ref, (\_ info -> (useIdent info ident, mempty)))
 
 -- | @WITH@ @RECURSIVE@ allows one to make a recursive subquery, which can
 -- reference itself. Like @WITH@, this is supported in most modern SQL engines.
@@ -92,33 +84,29 @@ with query = do
 withRecursive :: ( ToAlias a
                  , ToAliasReference a
                  , SqlSelect a r
-                 , RecursiveCteUnion unionKind
                  )
               => SqlQuery a
-              -> unionKind
+              -> UnionKind
-              -> (CommonTableExpression a -> SqlQuery a)
+              -> (From a -> SqlQuery a)
-              -> SqlQuery (CommonTableExpression a)
+              -> SqlQuery (From a)
 withRecursive baseCase unionKind recursiveCase = do
     (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ baseCase
     aliasedValue <- toAlias ret
     let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)
     ident <- newIdentFor (DBName "cte")
     ref <- toAliasReference ident aliasedValue
-    let refFrom = CommonTableExpression ident ref
+    let refFrom = From (pure (ref, (\_ info -> (useIdent info ident, mempty))))
     let recursiveQuery = recursiveCase refFrom
     let clause = CommonTableExpressionClause RecursiveCommonTableExpression ident
                  (\info -> (toRawSql SELECT info aliasedQuery)
-                        <> (unionKeyword unionKind, mempty)
+                        <> ("\n" <> (unUnionKind unionKind)  <> "\n", mempty)
                         <> (toRawSql SELECT info recursiveQuery)
                  )
     Q $ W.tell mempty{sdCteClause = [clause]}
     pure refFrom
 
-class RecursiveCteUnion a where
+newtype UnionKind = UnionKind { unUnionKind :: TLB.Builder }
-    unionKeyword :: a -> TLB.Builder
+instance Union_ UnionKind where
-
+    union_ = UnionKind "UNION"
-instance RecursiveCteUnion (a -> b -> Union a b) where
+instance UnionAll_ UnionKind where
-    unionKeyword _ = "\nUNION\n"
+    unionAll_ = UnionKind "UNION ALL"
-
-instance RecursiveCteUnion (a -> b -> UnionAll a b) where
-    unionKeyword _ = "\nUNION ALL\n"

src/Database/Esqueleto/Experimental/From/Join.hs

@@ -1,7 +1,11 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -12,13 +16,16 @@ module Database.Esqueleto.Experimental.From.Join
 import Data.Bifunctor (first)
 import Data.Kind (Constraint)
 import Data.Proxy
+import qualified Data.Text.Lazy.Builder as TLB
 import Database.Esqueleto.Experimental.From
 import Database.Esqueleto.Experimental.From.SqlSetOperation
 import Database.Esqueleto.Experimental.ToAlias
 import Database.Esqueleto.Experimental.ToAliasReference
 import Database.Esqueleto.Experimental.ToMaybe
-import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
+import Database.Esqueleto.Internal.Internal hiding
-import Database.Esqueleto.Internal.PersistentImport (Entity(..))
+       (From(..), from, fromJoin, on)
+import Database.Esqueleto.Internal.PersistentImport
+       (Entity(..), EntityField, PersistEntity, PersistField)
 import GHC.TypeLits
 
 -- | A left-precedence pair. Pronounced \"and\". Used to represent expressions
@@ -35,6 +42,10 @@ import GHC.TypeLits
 data (:&) a b = a :& b
 infixl 2 :&
 
+instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where
+    type ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b)
+    toMaybe (a :& b) = (toMaybe a :& toMaybe b)
+
 -- | Constraint for `on`. Ensures that only types that require an `on` can be used on
 -- the left hand side. This was previously reusing the From class which was actually
 -- a bit too lenient as it allowed to much.
@@ -46,6 +57,7 @@ type family ValidOnClauseValue a :: Constraint where
   ValidOnClauseValue (SqlQuery a) = ()
   ValidOnClauseValue (SqlSetOperation a) = ()
   ValidOnClauseValue (a -> SqlQuery b) = ()
+  ValidOnClauseValue (From a) = ()
   ValidOnClauseValue _ = TypeError ('Text "Illegal use of ON")
 
 -- | An @ON@ clause that describes how two tables are related. This should be
@@ -62,183 +74,233 @@ on :: ValidOnClauseValue a => a -> (b -> SqlExpr (Value Bool)) -> (a, b -> SqlEx
 on = (,)
 infix 9 `on`
 
-data Lateral
-data NotLateral
-
-type family IsLateral a where
-    IsLateral (a -> SqlQuery b) = Lateral
-    IsLateral a = NotLateral
-
 type family ErrorOnLateral a :: Constraint where
   ErrorOnLateral (a -> SqlQuery b) = TypeError ('Text "LATERAL can only be used for INNER, LEFT, and CROSS join kinds.")
   ErrorOnLateral _ = ()
 
--- Type class magic to allow the use of the `InnerJoin` family of data constructors in from
+fromJoin :: TLB.Builder -> RawFn -> RawFn -> Maybe (SqlExpr (Value Bool)) -> RawFn
-type family FromOnClause a where
+fromJoin joinKind lhs rhs monClause =
-    FromOnClause (a, b -> SqlExpr (Value Bool)) = b
-    FromOnClause a = TypeError ('Text "Missing ON clause")
-
-instance {-# OVERLAPPABLE #-} From (InnerJoin a b) where
-    type FromT (InnerJoin a b) = FromOnClause b
-    runFrom = undefined
-instance {-# OVERLAPPABLE #-} From (LeftOuterJoin a b) where
-    type FromT (LeftOuterJoin a b) = FromOnClause b
-    runFrom = undefined
-instance {-# OVERLAPPABLE #-} From (RightOuterJoin a b) where
-    type FromT (RightOuterJoin a b) = FromOnClause b
-    runFrom = undefined
-instance {-# OVERLAPPABLE #-} From (FullOuterJoin a b) where
-    type FromT (FullOuterJoin a b) = FromOnClause b
-    runFrom = undefined
-
-class FromInnerJoin lateral lhs rhs res where
-    runFromInnerJoin :: Proxy lateral -> lhs -> rhs -> (res -> SqlExpr (Value Bool)) -> SqlQuery (res, RawFn)
-
-fromJoin_ :: RawFn -> JoinKind -> RawFn -> Maybe (SqlExpr (Value Bool)) -> RawFn
-fromJoin_ lhs kind rhs monClause =
     \paren info ->
         first (parensM paren) $
         mconcat [ lhs Never info
-                , (fromKind kind, mempty)
+                , (joinKind, mempty)
                 , rhs Parens info
                 , maybe mempty (makeOnClause info) monClause
                 ]
     where
-        fromKind InnerJoinKind      = " INNER JOIN "
-        fromKind CrossJoinKind      = " CROSS JOIN "
-        fromKind LeftOuterJoinKind  = " LEFT OUTER JOIN "
-        fromKind RightOuterJoinKind = " RIGHT OUTER JOIN "
-        fromKind FullOuterJoinKind  = " FULL OUTER JOIN "
-
         makeOnClause info (ERaw _ f)        = first (" ON " <>) (f Never info)
 
-instance ( SqlSelect b r
+type family HasOnClause actual expected :: Constraint where
-         , ToAlias b
+    HasOnClause (a, b -> SqlExpr (Value Bool)) c = () -- Let the compiler handle the type mismatch
-         , ToAliasReference b
+    HasOnClause a expected =
-         , From a
+        TypeError ( 'Text "Missing ON clause for join with"
-         , FromT a ~ a'
+                    ':$$: 'ShowType a
-         ) => FromInnerJoin Lateral a (a' -> SqlQuery b) (a' :& b) where
+                    ':$$: 'Text ""
-             runFromInnerJoin _ leftPart q on' = do
+                    ':$$: 'Text "Expected: "
-                 (leftVal, leftFrom) <- runFrom leftPart
+                    ':$$: 'ShowType a
-                 (rightVal, rightFrom) <- fromSubQuery LateralSubQuery (q leftVal)
+                    ':$$: 'Text "`on` " ':<>: 'ShowType (expected -> SqlExpr (Value Bool))
+                    ':$$: 'Text ""
+                  )
+
+
+innerJoin :: ( ToFrom a a'
+             , ToFrom b b'
+             , HasOnClause rhs (a' :& b')
+             , rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool))
+             ) => a -> rhs -> From (a' :& b')
+innerJoin lhs (rhs, on') = From $ do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (toFrom rhs)
      let ret = leftVal :& rightVal
-                 pure $ (ret, fromJoin_ leftFrom InnerJoinKind rightFrom (Just (on' ret)))
+     pure $ (ret, fromJoin " INNER JOIN " leftFrom rightFrom (Just $ on' ret))
 
-instance (From a, FromT a ~ a', From b, FromT b ~ b')
-  => FromInnerJoin NotLateral a b (a' :& b') where
-      runFromInnerJoin _ leftPart rightPart on' = do
-          (leftVal, leftFrom) <- runFrom leftPart
-          (rightVal, rightFrom) <- runFrom rightPart
-          let ret = leftVal :& rightVal
-          pure $ (ret, fromJoin_ leftFrom InnerJoinKind rightFrom (Just (on' ret)))
 
-instance (FromInnerJoin (IsLateral b) a b b') => From (InnerJoin a (b, b' -> SqlExpr (Value Bool))) where
+innerJoinLateral :: ( ToFrom a a'
-    type FromT (InnerJoin a (b, b' -> SqlExpr (Value Bool))) = FromOnClause (b, b' -> SqlExpr(Value Bool))
+                    , HasOnClause rhs (a' :& b)
-    runFrom (InnerJoin lhs (rhs, on')) = runFromInnerJoin (toProxy rhs) lhs rhs on'
-        where
-            toProxy :: b -> Proxy (IsLateral b)
-            toProxy _ = Proxy
-
-type family FromCrossJoin a b where
-    FromCrossJoin a (b -> SqlQuery c) = FromT a :& c
-    FromCrossJoin a b = FromT a :& FromT b
-
-instance ( From a
-         , From b
-         , FromT (CrossJoin a b) ~ (FromT a :& FromT b)
-         ) => From (CrossJoin a b) where
-    type FromT (CrossJoin a b) = FromCrossJoin a b
-    runFrom (CrossJoin leftPart rightPart) = do
-        (leftVal, leftFrom) <- runFrom leftPart
-        (rightVal, rightFrom) <- runFrom rightPart
-        let ret = leftVal :& rightVal
-        pure $ (ret, fromJoin_ leftFrom CrossJoinKind rightFrom Nothing)
-
-instance {-# OVERLAPPING #-}
-         ( From a
-         , FromT a ~ a'
                     , SqlSelect b r
                     , ToAlias b
                     , ToAliasReference b
-         ) => From (CrossJoin a (a' -> SqlQuery b)) where
+                    , rhs ~ (a' -> SqlQuery b, (a' :& b) -> SqlExpr (Value Bool))
-    type FromT (CrossJoin a (a' -> SqlQuery b)) = FromCrossJoin a (a' -> SqlQuery b)
+                    )
-    runFrom (CrossJoin leftPart q) = do
+                 => a -> rhs -> From (a' :& b)
-        (leftVal, leftFrom) <- runFrom leftPart
+innerJoinLateral lhs (rhsFn, on') = From $ do
-        (rightVal, rightFrom) <- fromSubQuery LateralSubQuery (q leftVal)
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal))
      let ret = leftVal :& rightVal
-        pure $ (ret, fromJoin_ leftFrom CrossJoinKind rightFrom Nothing)
+     pure $ (ret, fromJoin " INNER JOIN LATERAL " leftFrom rightFrom (Just $ on' ret))
 
-class FromLeftJoin lateral lhs rhs res where
+crossJoin :: ( ToFrom a a'
-    runFromLeftJoin :: Proxy lateral -> lhs -> rhs -> (res -> SqlExpr (Value Bool)) -> SqlQuery (res, RawFn)
+             , ToFrom b b'
+             ) => a -> b -> From (a' :& b')
+crossJoin lhs rhs = From $ do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (toFrom rhs)
+     let ret = leftVal :& rightVal
+     pure $ (ret, fromJoin " CROSS JOIN " leftFrom rightFrom Nothing)
 
-instance ( From a
+crossJoinLateral :: ( ToFrom a a'
-         , FromT a ~ a'
                     , SqlSelect b r
                     , ToAlias b
                     , ToAliasReference b
+                    )
+                 => a -> (a' -> SqlQuery b) -> From (a' :& b)
+crossJoinLateral lhs rhsFn = From $ do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal))
+     let ret = leftVal :& rightVal
+     pure $ (ret, fromJoin " CROSS JOIN LATERAL " leftFrom rightFrom Nothing)
+
+leftJoin :: ( ToFrom a a'
+            , ToFrom b b'
+            , ToMaybe b'
+            , HasOnClause rhs (a' :& ToMaybeT b')
+            , rhs ~ (b, (a' :& ToMaybeT b') -> SqlExpr (Value Bool))
+            ) => a -> rhs -> From (a' :& ToMaybeT b')
+leftJoin lhs (rhs, on') = From $ do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (toFrom rhs)
+     let ret = leftVal :& toMaybe rightVal
+     pure $ (ret, fromJoin " LEFT OUTER JOIN " leftFrom rightFrom (Just $ on' ret))
+
+leftJoinLateral :: ( ToFrom a a'
+                   , SqlSelect b r
+                   , HasOnClause rhs (a' :& ToMaybeT b)
+                   , ToAlias b
+                   , ToAliasReference b
                    , ToMaybe b
-         , mb ~ ToMaybeT b
+                   , rhs ~ (a' -> SqlQuery b, (a' :& ToMaybeT b) -> SqlExpr (Value Bool))
-         ) => FromLeftJoin Lateral a (a' -> SqlQuery b) (a' :& mb) where
+                   )
-            runFromLeftJoin _ leftPart q on' = do
+                 => a -> rhs -> From (a' :& ToMaybeT b)
-                (leftVal, leftFrom) <- runFrom leftPart
+leftJoinLateral lhs (rhsFn, on') = From $ do
-                (rightVal, rightFrom) <- fromSubQuery LateralSubQuery (q leftVal)
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
-                let ret = leftVal :& (toMaybe rightVal)
+     (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal))
-                pure $ (ret, fromJoin_ leftFrom LeftOuterJoinKind rightFrom (Just (on' ret)))
+     let ret = leftVal :& toMaybe rightVal
+     pure $ (ret, fromJoin " LEFT OUTER JOIN LATERAL " leftFrom rightFrom (Just $ on' ret))
 
-instance ( From a
+rightJoin :: ( ToFrom a a'
-         , FromT a ~ a'
+             , ToFrom b b'
-         , From b
-         , FromT b ~ b'
-         , ToMaybe b'
-         , mb ~ ToMaybeT b'
-         ) => FromLeftJoin NotLateral a b (a' :& mb) where
-            runFromLeftJoin _ leftPart rightPart on' = do
-                (leftVal, leftFrom) <- runFrom leftPart
-                (rightVal, rightFrom) <- runFrom rightPart
-                let ret = leftVal :& (toMaybe rightVal)
-                pure $ (ret, fromJoin_ leftFrom LeftOuterJoinKind rightFrom (Just (on' ret)))
-
-instance ( FromLeftJoin (IsLateral b) a b b'
-         ) => From (LeftOuterJoin a (b, b' -> SqlExpr (Value Bool))) where
-            type FromT (LeftOuterJoin a (b, b' -> SqlExpr (Value Bool))) = FromOnClause (b, b' -> SqlExpr(Value Bool))
-            runFrom (LeftOuterJoin lhs (rhs, on')) =
-                runFromLeftJoin (toProxy rhs) lhs rhs on'
-              where
-                toProxy :: b -> Proxy (IsLateral b)
-                toProxy _ = Proxy
-
-instance ( From a
-         , FromT a ~ a'
-         , From b
-         , FromT b ~ b'
              , ToMaybe a'
-         , ma ~ ToMaybeT a'
+             , HasOnClause rhs (ToMaybeT a' :& b')
-         , ToMaybe b'
+             , rhs ~ (b, (ToMaybeT a' :& b') -> SqlExpr (Value Bool))
-         , mb ~ ToMaybeT b'
+             ) => a -> rhs -> From (ToMaybeT a' :& b')
-         , ErrorOnLateral b
+rightJoin lhs (rhs, on') = From $ do
-         ) => From (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) where
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
-            type FromT (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) = FromOnClause (b, (ma :& mb) -> SqlExpr(Value Bool))
+     (rightVal, rightFrom) <- unFrom (toFrom rhs)
-            runFrom (FullOuterJoin leftPart (rightPart, on')) = do
+     let ret = toMaybe leftVal :& rightVal
-                (leftVal, leftFrom) <- runFrom leftPart
+     pure $ (ret, fromJoin " RIGHT OUTER JOIN " leftFrom rightFrom (Just $ on' ret))
-                (rightVal, rightFrom) <- runFrom rightPart
-                let ret = (toMaybe leftVal) :& (toMaybe rightVal)
-                pure $ (ret, fromJoin_ leftFrom FullOuterJoinKind rightFrom (Just (on' ret)))
 
-instance ( From a
+fullOuterJoin :: ( ToFrom a a'
-         , FromT a ~ a'
+                 , ToFrom b b'
                  , ToMaybe a'
-         , ma ~ ToMaybeT a'
+                 , ToMaybe b'
-         , From b
+                 , HasOnClause rhs (ToMaybeT a' :& ToMaybeT b')
-         , FromT b ~ b'
+                 , rhs ~ (b, (ToMaybeT a' :& ToMaybeT b') -> SqlExpr (Value Bool))
-         , ErrorOnLateral b
+                 ) => a -> rhs -> From (ToMaybeT a' :& ToMaybeT b')
-         ) => From (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) where
+fullOuterJoin lhs (rhs, on') = From $ do
-            type FromT (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) = FromOnClause (b, (ma :& b') -> SqlExpr(Value Bool))
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
-            runFrom (RightOuterJoin leftPart (rightPart, on')) = do
+     (rightVal, rightFrom) <- unFrom (toFrom rhs)
-                (leftVal, leftFrom) <- runFrom leftPart
+     let ret = toMaybe leftVal :& toMaybe rightVal
-                (rightVal, rightFrom) <- runFrom rightPart
+     pure $ (ret, fromJoin " FULL OUTER JOIN " leftFrom rightFrom (Just $ on' ret))
-                let ret = (toMaybe leftVal) :& rightVal
+
-                pure $ (ret, fromJoin_ leftFrom RightOuterJoinKind rightFrom (Just (on' ret)))
+infixl 2 `innerJoin`,
+         `innerJoinLateral`,
+         `leftJoin`,
+         `leftJoinLateral`,
+         `crossJoin`,
+         `crossJoinLateral`,
+         `rightJoin`,
+         `fullOuterJoin`
+
+
+------ Compatibility for old syntax
+
+data Lateral
+data NotLateral
+
+type family IsLateral a where
+    IsLateral (a -> SqlQuery b, c) = Lateral
+    IsLateral (a -> SqlQuery b) = Lateral
+    IsLateral a = NotLateral
+
+class DoInnerJoin lateral lhs rhs res | lateral rhs lhs -> res where
+    doInnerJoin :: Proxy lateral -> lhs -> rhs -> From res
+
+instance ( ToFrom a a'
+         , ToFrom b b'
+         , HasOnClause rhs (a' :& b')
+         , rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool))
+         ) => DoInnerJoin NotLateral a rhs (a' :& b') where
+    doInnerJoin _ = innerJoin
+
+instance ( ToFrom a a'
+         , SqlSelect b r
+         , ToAlias b
+         , ToAliasReference b
+         , d ~ (a' :& b)
+         ) => DoInnerJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where
+    doInnerJoin _ = innerJoinLateral
+
+instance ( DoInnerJoin lateral lhs rhs r, lateral ~ IsLateral rhs )
+           => ToFrom (InnerJoin lhs rhs) r where
+     toFrom (InnerJoin a b) = doInnerJoin (Proxy @lateral) a b
+
+class DoLeftJoin lateral lhs rhs res | lateral rhs lhs -> res where
+    doLeftJoin :: Proxy lateral -> lhs -> rhs -> From res
+
+instance ( ToFrom a a'
+         , ToFrom b b'
+         , ToMaybe b'
+         , ToMaybeT b' ~ mb
+         , HasOnClause rhs (a' :& mb)
+         , rhs ~ (b, (a' :& mb) -> SqlExpr (Value Bool))
+         ) => DoLeftJoin NotLateral a rhs (a' :& mb) where
+    doLeftJoin _ = leftJoin
+
+instance ( ToFrom a a'
+         , ToMaybe b
+         , d ~ (a' :& ToMaybeT b)
+         , SqlSelect b r
+         , ToAlias b
+         , ToAliasReference b
+         ) => DoLeftJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where
+    doLeftJoin _ = leftJoinLateral
+
+instance ( DoLeftJoin lateral lhs rhs r, lateral ~ IsLateral rhs )
+           => ToFrom (LeftOuterJoin lhs rhs) r where
+     toFrom (LeftOuterJoin a b) = doLeftJoin (Proxy @lateral) a b
+
+class DoCrossJoin lateral lhs rhs res | lateral lhs rhs -> res where
+    doCrossJoin :: Proxy lateral -> lhs -> rhs -> From res
+
+instance (ToFrom a a', ToFrom b b') => DoCrossJoin NotLateral a b (a' :& b') where
+    doCrossJoin _ = crossJoin
+instance (ToFrom a a', SqlSelect b r, ToAlias b, ToAliasReference b)
+  => DoCrossJoin Lateral a (a' -> SqlQuery b) (a' :& b) where
+    doCrossJoin _ = crossJoinLateral
+
+instance (DoCrossJoin lateral lhs rhs r, IsLateral rhs ~ lateral)
+  => ToFrom (CrossJoin lhs rhs) r where
+    toFrom (CrossJoin a b) = doCrossJoin (Proxy @lateral) a b
+
+instance ( ToFrom a a'
+         , ToFrom b b'
+         , ToMaybe a'
+         , ToMaybeT a' ~ ma
+         , HasOnClause rhs (ma :& b')
+         , ErrorOnLateral b
+         , rhs ~ (b, (ma :& b') -> SqlExpr (Value Bool))
+         ) => ToFrom (RightOuterJoin a rhs) (ma :& b') where
+    toFrom (RightOuterJoin a b) = rightJoin a b
+
+instance ( ToFrom a a'
+         , ToFrom b b'
+         , ToMaybe a'
+         , ToMaybeT a' ~ ma
+         , ToMaybe b'
+         , ToMaybeT b' ~ mb
+         , HasOnClause rhs (ma :& mb)
+         , ErrorOnLateral b
+         , rhs ~ (b, (ma :& mb) -> SqlExpr (Value Bool))
+         ) => ToFrom (FullOuterJoin a rhs) (ma :& mb) where
+    toFrom (FullOuterJoin a b) = fullOuterJoin a b
 
-instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where
-    type ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b)
-    toMaybe (a :& b) = (toMaybe a :& toMaybe b)

src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs

@@ -4,12 +4,15 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Database.Esqueleto.Experimental.From.SqlSetOperation
         where
 
+import Control.Arrow (first)
 import Control.Monad.Trans.Class (lift)
 import qualified Control.Monad.Trans.State as S
 import qualified Control.Monad.Trans.Writer as W
@@ -17,39 +20,32 @@ import qualified Data.Text.Lazy.Builder                           as TLB
 import Database.Esqueleto.Experimental.From
 import Database.Esqueleto.Experimental.ToAlias
 import Database.Esqueleto.Experimental.ToAliasReference
-import           Database.Esqueleto.Internal.Internal             hiding
+import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
-                                                                  (From (..),
+import Database.Esqueleto.Internal.PersistentImport
-                                                                   from, on)
+       (DBName(..), Entity, PersistEntity, PersistValue)
-import           Database.Esqueleto.Internal.PersistentImport     (DBName (..),
-                                                                   PersistValue)
 
-data SqlSetOperation a
+newtype SqlSetOperation a = SqlSetOperation
-    = SqlSetUnion (SqlSetOperation a) (SqlSetOperation a)
+    { unSqlSetOperation :: NeedParens -> SqlQuery (a, IdentInfo -> (TLB.Builder, [PersistValue]))}
-    | SqlSetUnionAll (SqlSetOperation a) (SqlSetOperation a)
-    | SqlSetExcept (SqlSetOperation a) (SqlSetOperation a)
-    | SqlSetIntersect (SqlSetOperation a) (SqlSetOperation a)
-    | SelectQueryP NeedParens (SqlQuery a)
 
-runSetOperation :: (SqlSelect a r, ToAlias a, ToAliasReference a)
+instance ToAliasReference a => ToFrom (SqlSetOperation a) a where
-                => SqlSetOperation a -> SqlQuery (a, NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]))
+    toFrom setOperation = From $ do
-runSetOperation operation = do
-    (aliasedOperation, ret) <- aliasQueries operation
         ident <- newIdentFor (DBName "u")
-    ref <- toAliasReference ident ret
+        (a, fromClause) <- unSqlSetOperation setOperation Never
-    pure ( ref
+        ref <- toAliasReference ident a
-         , \_ info ->
+        pure (ref, \_ info -> (first parens $ fromClause info) <> (" AS " <> useIdent info ident, mempty))
-            let (queryText, queryVals) = operationToSql aliasedOperation info
-            in (parens queryText <> " AS " <> useIdent info ident, queryVals)
-         )
 
-  where
+class ToSqlSetOperation a r | a -> r where
-    aliasQueries o =
+    toSqlSetOperation :: a -> SqlSetOperation r
-        case o of
+instance ToSqlSetOperation (SqlSetOperation a) a where
-            SelectQueryP p q -> do
+    toSqlSetOperation = id
-                (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ q
+instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToSqlSetOperation (SqlQuery a) a where
-                prevState <- Q $ lift S.get
+    toSqlSetOperation subquery =
-                aliasedRet <- toAlias ret
+        SqlSetOperation $ \p -> do
-                Q $ lift $ S.put prevState
+            (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery
+            state <- Q $ lift S.get
+            aliasedValue <- toAlias ret
+            Q $ lift $ S.put state
+            let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)
             let p' =
                   case p of
                     Parens -> Parens
@@ -59,153 +55,58 @@ runSetOperation operation = do
                         Parens
                       else
                         Never
-                pure (SelectQueryP p' $ Q $ W.WriterT $ pure (aliasedRet, sideData), aliasedRet)
+            pure (aliasedValue, \info -> first (parensM p') $ toRawSql SELECT info aliasedQuery)
-            SqlSetUnion     o1 o2 -> do
-                (o1', ret) <- aliasQueries o1
-                (o2', _  ) <- aliasQueries o2
-                pure (SqlSetUnion o1' o2', ret)
-            SqlSetUnionAll  o1 o2 -> do
-                (o1', ret) <- aliasQueries o1
-                (o2', _  ) <- aliasQueries o2
-                pure (SqlSetUnionAll o1' o2', ret)
-            SqlSetExcept    o1 o2 -> do
-                (o1', ret) <- aliasQueries o1
-                (o2', _  ) <- aliasQueries o2
-                pure (SqlSetExcept o1' o2', ret)
-            SqlSetIntersect o1 o2 -> do
-                (o1', ret) <- aliasQueries o1
-                (o2', _  ) <- aliasQueries o2
-                pure (SqlSetIntersect o1' o2', ret)
-
-    operationToSql o info =
-        case o of
-            SelectQueryP p q  ->
-                let (builder, values) = toRawSql SELECT info q
-                in (parensM p builder, values)
-            SqlSetUnion     o1 o2 -> doSetOperation "UNION"     info o1 o2
-            SqlSetUnionAll  o1 o2 -> doSetOperation "UNION ALL" info o1 o2
-            SqlSetExcept    o1 o2 -> doSetOperation "EXCEPT"    info o1 o2
-            SqlSetIntersect o1 o2 -> doSetOperation "INTERSECT" info o1 o2
-
-    doSetOperation operationText info o1 o2 =
-        let (q1, v1) = operationToSql o1 info
-            (q2, v2) = operationToSql o2 info
-        in (q1 <> " " <> operationText <> " " <> q2, v1 <> v2)
 
+mkSetOperation :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => TLB.Builder -> a -> b -> SqlSetOperation a'
+mkSetOperation operation lhs rhs = SqlSetOperation $ \p -> do
+    (leftValue, leftClause) <- unSqlSetOperation (toSqlSetOperation lhs) p
+    (_, rightClause) <- unSqlSetOperation (toSqlSetOperation rhs) p
+    pure (leftValue, \info -> leftClause info <> (operation, mempty) <> rightClause info)
 
 {-# DEPRECATED Union "/Since: 3.4.0.0/ - Use the 'union_' function instead of the 'Union' data constructor" #-}
 data Union a b = a `Union` b
+instance ToSqlSetOperation a a' => ToSqlSetOperation (Union a a) a' where
+    toSqlSetOperation (Union a b) = union_ a b
 
+
+class Union_ a where
     -- | @UNION@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
-union_ :: a -> b -> Union a b
+    union_ :: a
-union_ = Union
+
+instance (ToSqlSetOperation a c, ToSqlSetOperation b c, res ~ SqlSetOperation c)
+  => Union_ (a -> b -> res) where
+    union_ = mkSetOperation " UNION "
+
+class UnionAll_ a where
+    -- | @UNION@ @ALL@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
+    unionAll_ :: a
+instance (ToSqlSetOperation a c, ToSqlSetOperation b c, res ~ SqlSetOperation c)
+  => UnionAll_ (a -> b -> res) where
+    unionAll_ = mkSetOperation " UNION ALL "
 
 {-# DEPRECATED UnionAll "/Since: 3.4.0.0/ - Use the 'unionAll_' function instead of the 'UnionAll' data constructor" #-}
 data UnionAll a b = a `UnionAll` b
-
+instance ToSqlSetOperation a a' => ToSqlSetOperation (UnionAll a a) a' where
--- | @UNION@ @ALL@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
+    toSqlSetOperation (UnionAll a b) = unionAll_ a b
-unionAll_ :: a -> b -> UnionAll a b
-unionAll_ = UnionAll
 
 {-# DEPRECATED Except "/Since: 3.4.0.0/ - Use the 'except_' function instead of the 'Except' data constructor" #-}
 data Except a b = a `Except` b
+instance ToSqlSetOperation a a' => ToSqlSetOperation (Except a a) a' where
+    toSqlSetOperation (Except a b) = except_ a b
 
 -- | @EXCEPT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
-except_ :: a -> b -> Except a b
+except_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a'
-except_ = Except
+except_ = mkSetOperation " EXCEPT "
 
 {-# DEPRECATED Intersect "/Since: 3.4.0.0/ - Use the 'intersect_' function instead of the 'Intersect' data constructor" #-}
 data Intersect a b = a `Intersect` b
+instance ToSqlSetOperation a a' => ToSqlSetOperation (Intersect a a) a' where
+    toSqlSetOperation (Intersect a b) = intersect_ a b
 
 -- | @INTERSECT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
-intersect_ :: a -> b -> Intersect a b
+intersect_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a'
-intersect_ = Intersect
+intersect_ = mkSetOperation " INTERSECT "
-
-class SetOperationT a ~ b => ToSetOperation a b | a -> b where
-    type SetOperationT a
-    toSetOperation :: a -> SqlSetOperation b
-instance ToSetOperation (SqlSetOperation a) a where
-    type SetOperationT (SqlSetOperation a) = a
-    toSetOperation = id
-instance ToSetOperation (SqlQuery a) a where
-    type SetOperationT (SqlQuery a) = a
-    toSetOperation = SelectQueryP Never
-instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Union a b) c where
-    type SetOperationT (Union a b) = SetOperationT a
-    toSetOperation (Union a b) = SqlSetUnion (toSetOperation a) (toSetOperation b)
-instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (UnionAll a b) c where
-    type SetOperationT (UnionAll a b) = SetOperationT a
-    toSetOperation (UnionAll a b) = SqlSetUnionAll (toSetOperation a) (toSetOperation b)
-instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Except a b) c where
-    type SetOperationT (Except a b) = SetOperationT a
-    toSetOperation (Except a b) = SqlSetExcept (toSetOperation a) (toSetOperation b)
-instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Intersect a b) c where
-    type SetOperationT (Intersect a b) = SetOperationT a
-    toSetOperation (Intersect a b) = SqlSetIntersect (toSetOperation a) (toSetOperation b)
 
 {-# DEPRECATED SelectQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SelectQuery@" #-}
-pattern SelectQuery :: SqlQuery a -> SqlSetOperation a
+pattern SelectQuery a = a
-pattern SelectQuery q = SelectQueryP Never q
 
-instance
-    ( SqlSelect c r
-    , ToAlias c
-    , ToAliasReference c
-    , ToSetOperation a c
-    , ToSetOperation b c
-    , c ~ SetOperationT a
-    )
-  =>
-    From (Union a b)
-  where
-    type FromT (Union a b) = SetOperationT a
-    runFrom u = runSetOperation $ toSetOperation u
-
-instance
-    ( SqlSelect c r
-    , ToAlias c
-    , ToAliasReference c
-    , ToSetOperation a c
-    , ToSetOperation b c
-    , c ~ SetOperationT a
-    )
-  =>
-    From (UnionAll a b)
-  where
-    type FromT (UnionAll a b) = SetOperationT a
-    runFrom u = runSetOperation $ toSetOperation u
-
-instance
-    ( SqlSelect c r
-    , ToAlias c
-    , ToAliasReference c
-    , ToSetOperation a c
-    , ToSetOperation b c
-    , c ~ SetOperationT a
-    )
-  =>
-    From (Intersect a b)
-  where
-    type FromT (Intersect a b) = SetOperationT a
-    runFrom u = runSetOperation $ toSetOperation u
-
-instance
-    ( SqlSelect c r
-    , ToAlias c
-    , ToAliasReference c
-    , ToSetOperation a c
-    , ToSetOperation b c
-    , c ~ SetOperationT a
-    )
-  =>
-    From (Except a b)
-  where
-    type FromT (Except a b) = SetOperationT a
-    runFrom u = runSetOperation $ toSetOperation u
-
-instance (SqlSelect a r, ToAlias a, ToAliasReference a) => From (SqlSetOperation a) where
-    type FromT (SqlSetOperation a) = a
-    -- If someone uses just a plain SelectQuery it should behave like a normal subquery
-    runFrom (SelectQueryP _ subquery) = fromSubQuery NormalSubQuery subquery
-    -- Otherwise use the SqlSetOperation
-    runFrom u                         = runSetOperation $ toSetOperation u