Merge pull request #10 from foxhound-systems/from-raw

From raw

src/Database/Esqueleto.hs

@@ -1,4 +1,7 @@
-{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
 -- | The @esqueleto@ EDSL (embedded domain specific language).
 -- This module replaces @Database.Persist@, so instead of
 -- importing that module you should just import this one:
@@ -125,8 +128,8 @@ import Control.Monad.Trans.Reader (ReaderT)
 import Data.Int (Int64)
 import qualified Data.Map.Strict as Map
 import Database.Esqueleto.Internal.Language
-import Database.Esqueleto.Internal.Sql
 import Database.Esqueleto.Internal.PersistentImport
+import Database.Esqueleto.Internal.Sql
 import qualified Database.Persist
 
 

src/Database/Esqueleto/Experimental.hs

@@ -19,8 +19,10 @@ module Database.Esqueleto.Experimental
       -- * Documentation
 
       Table(..)
+    , table
     , from
     , SubQuery(..)
+    , selectQuery
     , (:&)(..)
     , on
 
@@ -40,6 +42,15 @@ module Database.Esqueleto.Experimental
     , with
     , withRecursive
 
+    , innerJoin
+    , innerJoinLateral
+    , leftJoin
+    , leftJoinLateral
+    , rightJoin
+    , fullOuterJoin
+    , crossJoin
+    , crossJoinLateral
+
       -- * Internals
     , From(..)
     , ToMaybe(..)
@@ -47,7 +58,7 @@ module Database.Esqueleto.Experimental
     , ToAliasT
     , ToAliasReference(..)
     , ToAliasReferenceT
-    , ToSetOperation(..)
+    , ToSqlSetOperation(..)
     , ValidOnClauseValue
     -- * The Normal Stuff
 
@@ -216,6 +227,7 @@ import Database.Esqueleto.Experimental.From.SqlSetOperation
 import Database.Esqueleto.Experimental.ToAlias
 import Database.Esqueleto.Experimental.ToAliasReference
 import Database.Esqueleto.Experimental.ToMaybe
+
 -- $setup
 --
 -- If you're already using "Database.Esqueleto", then you can get

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,8 +18,11 @@
 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 (From(..), from, on)
@@ -30,15 +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=[clause]}
+    Q $ W.tell mempty{sdFromClause=[FromRaw $ clause]}
     pure a
 
-class From a where
+type RawFn = NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])
-    type FromT a
+newtype From a = From
-    runFrom :: a -> SqlQuery (FromT a, FromClause)
+    { unFrom :: SqlQuery (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
 --
@@ -46,54 +58,35 @@ 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)
-        ident <- newIdentFor (entityDB ed)
+    let entity = unsafeSqlEntity ident
-        let entity = unsafeSqlEntity ident
+    pure $ ( entity, const $ base ident ed )
-        pure $ (entity, FromStart ident ed)
+      where
-          where
+        base ident@(I identText) def info =
-            getVal ::  Table ent -> Proxy ent
+            let db@(DBName dbText) = entityDB def
-            getVal = const Proxy
+            in ( fromDBName info db <>
+                     if dbText == identText
+                     then mempty
+                     else " AS " <> useIdent info ident
+               , mempty
+               )
 
 
 {-# 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, FromClause)
-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
@@ -105,4 +98,11 @@ fromSubQuery subqueryType subquery = do
     -- create aliased references from the outer query results (e.g value from subquery will be `subquery`.`value`),
     -- this is probably overkill as the aliases should already be unique but seems to be good practice.
     ref <- toAliasReference subqueryAlias aliasedValue
-    pure (ref , FromQuery subqueryAlias (\info -> toRawSql SELECT info aliasedQuery) subqueryType)
+
+    pure (ref, \_ info ->
+            let (queryText,queryVals) = toRawSql SELECT info aliasedQuery
+            in
+            ( (parens queryText) <> " AS " <> useIdent info subqueryAlias
+            , queryVals
+            )
+         )

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

@@ -14,12 +14,6 @@ import Database.Esqueleto.Experimental.ToAliasReference
 import Database.Esqueleto.Internal.Internal hiding (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, FromIdent ident)
-
 -- | @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
@@ -44,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
@@ -53,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.
@@ -90,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,6 +1,11 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -8,15 +13,19 @@
 module Database.Esqueleto.Experimental.From.Join
     where
 
+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
@@ -33,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.
@@ -44,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
@@ -60,165 +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
+    \paren info ->
-    FromOnClause a = TypeError ('Text "Missing ON clause")
+        first (parensM paren) $
+        mconcat [ lhs Never info
+                , (joinKind, mempty)
+                , rhs Parens info
+                , maybe mempty (makeOnClause info) monClause
+                ]
+    where
+        makeOnClause info (ERaw _ f)        = first (" ON " <>) (f Never info)
 
-instance {-# OVERLAPPABLE #-} From (InnerJoin a b) where
+type family HasOnClause actual expected :: Constraint where
-    type FromT (InnerJoin a b) = FromOnClause b
+    HasOnClause (a, b -> SqlExpr (Value Bool)) c = () -- Let the compiler handle the type mismatch
-    runFrom = undefined
+    HasOnClause a expected =
-instance {-# OVERLAPPABLE #-} From (LeftOuterJoin a b) where
+        TypeError ( 'Text "Missing ON clause for join with"
-    type FromT (LeftOuterJoin a b) = FromOnClause b
+                    ':$$: 'ShowType a
-    runFrom = undefined
+                    ':$$: 'Text ""
-instance {-# OVERLAPPABLE #-} From (RightOuterJoin a b) where
+                    ':$$: 'Text "Expected: "
-    type FromT (RightOuterJoin a b) = FromOnClause b
+                    ':$$: 'ShowType a
-    runFrom = undefined
+                    ':$$: 'Text "`on` " ':<>: 'ShowType (expected -> SqlExpr (Value Bool))
-instance {-# OVERLAPPABLE #-} From (FullOuterJoin a b) where
+                    ':$$: 'Text ""
-    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, FromClause)
 
-instance ( SqlSelect b r
+innerJoin :: ( ToFrom a a'
-         , ToAlias b
+             , ToFrom b b'
-         , ToAliasReference b
+             , HasOnClause rhs (a' :& b')
-         , From a
+             , rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool))
-         , FromT a ~ a'
+             ) => a -> rhs -> From (a' :& b')
-         ) => FromInnerJoin Lateral a (a' -> SqlQuery b) (a' :& b) where
+innerJoin lhs (rhs, on') = From $ do
-             runFromInnerJoin _ leftPart q on' = do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
-                 (leftVal, leftFrom) <- runFrom leftPart
+     (rightVal, rightFrom) <- unFrom (toFrom rhs)
-                 (rightVal, rightFrom) <- fromSubQuery LateralSubQuery (q leftVal)
+     let ret = leftVal :& rightVal
-                 let ret = leftVal :& rightVal
+     pure $ (ret, fromJoin " INNER JOIN " leftFrom rightFrom (Just $ on' ret))
-                 pure $ (ret, FromJoin leftFrom InnerJoinKind 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'
+                    , SqlSelect b r
-        where
+                    , ToAlias b
-            toProxy :: b -> Proxy (IsLateral b)
+                    , ToAliasReference b
-            toProxy _ = Proxy
+                    , rhs ~ (a' -> SqlQuery b, (a' :& b) -> SqlExpr (Value Bool))
+                    )
+                 => a -> rhs -> From (a' :& b)
+innerJoinLateral lhs (rhsFn, on') = From $ do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal))
+     let ret = leftVal :& rightVal
+     pure $ (ret, fromJoin " INNER JOIN LATERAL " leftFrom rightFrom (Just $ on' ret))
 
-type family FromCrossJoin a b where
+crossJoin :: ( ToFrom a a'
-    FromCrossJoin a (b -> SqlQuery c) = FromT a :& c
+             , ToFrom b b'
-    FromCrossJoin a b = FromT a :& FromT 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'
-         , From b
+                    , SqlSelect b r
-         , FromT (CrossJoin a b) ~ (FromT a :& FromT b)
+                    , ToAlias b
-         ) => From (CrossJoin a b) where
+                    , ToAliasReference b
-    type FromT (CrossJoin a b) = FromCrossJoin a b
+                    )
-    runFrom (CrossJoin leftPart rightPart) = do
+                 => a -> (a' -> SqlQuery b) -> From (a' :& b)
-        (leftVal, leftFrom) <- runFrom leftPart
+crossJoinLateral lhs rhsFn = From $ do
-        (rightVal, rightFrom) <- runFrom rightPart
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
-        let ret = leftVal :& rightVal
+     (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal))
-        pure $ (ret, FromJoin leftFrom CrossJoinKind rightFrom Nothing)
+     let ret = leftVal :& rightVal
+     pure $ (ret, fromJoin " CROSS JOIN LATERAL " leftFrom rightFrom Nothing)
 
-instance {-# OVERLAPPING #-}
+leftJoin :: ( ToFrom a a'
-         ( From a
+            , ToFrom b b'
-         , FromT a ~ a'
+            , 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
+                   , rhs ~ (a' -> SqlQuery b, (a' :& ToMaybeT b) -> SqlExpr (Value Bool))
+                   )
+                 => a -> rhs -> From (a' :& ToMaybeT b)
+leftJoinLateral lhs (rhsFn, on') = From $ do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal))
+     let ret = leftVal :& toMaybe rightVal
+     pure $ (ret, fromJoin " LEFT OUTER JOIN LATERAL " leftFrom rightFrom (Just $ on' ret))
+
+rightJoin :: ( ToFrom a a'
+             , ToFrom b b'
+             , ToMaybe a'
+             , HasOnClause rhs (ToMaybeT a' :& b')
+             , rhs ~ (b, (ToMaybeT a' :& b') -> SqlExpr (Value Bool))
+             ) => a -> rhs -> From (ToMaybeT a' :& b')
+rightJoin lhs (rhs, on') = From $ do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (toFrom rhs)
+     let ret = toMaybe leftVal :& rightVal
+     pure $ (ret, fromJoin " RIGHT OUTER JOIN " leftFrom rightFrom (Just $ on' ret))
+
+fullOuterJoin :: ( ToFrom a a'
+                 , ToFrom b b'
+                 , ToMaybe a'
+                 , ToMaybe b'
+                 , HasOnClause rhs (ToMaybeT a' :& ToMaybeT b')
+                 , rhs ~ (b, (ToMaybeT a' :& ToMaybeT b') -> SqlExpr (Value Bool))
+                 ) => a -> rhs -> From (ToMaybeT a' :& ToMaybeT b')
+fullOuterJoin lhs (rhs, on') = From $ do
+     (leftVal, leftFrom) <- unFrom (toFrom lhs)
+     (rightVal, rightFrom) <- unFrom (toFrom rhs)
+     let ret = toMaybe leftVal :& toMaybe rightVal
+     pure $ (ret, fromJoin " FULL OUTER JOIN " leftFrom 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
-         ) => From (CrossJoin a (a' -> SqlQuery b)) where
+         , d ~ (a' :& b)
-    type FromT (CrossJoin a (a' -> SqlQuery b)) = FromCrossJoin a (a' -> SqlQuery b)
+         ) => DoInnerJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where
-    runFrom (CrossJoin leftPart q) = do
+    doInnerJoin _ = innerJoinLateral
-        (leftVal, leftFrom) <- runFrom leftPart
-        (rightVal, rightFrom) <- fromSubQuery LateralSubQuery (q leftVal)
-        let ret = leftVal :& rightVal
-        pure $ (ret, FromJoin leftFrom CrossJoinKind rightFrom Nothing)
 
-class FromLeftJoin lateral lhs rhs res where
+instance ( DoInnerJoin lateral lhs rhs r, lateral ~ IsLateral rhs )
-    runFromLeftJoin :: Proxy lateral -> lhs -> rhs -> (res -> SqlExpr (Value Bool)) -> SqlQuery (res, FromClause)
+           => ToFrom (InnerJoin lhs rhs) r where
+     toFrom (InnerJoin a b) = doInnerJoin (Proxy @lateral) a b
 
-instance ( From a
+class DoLeftJoin lateral lhs rhs res | lateral rhs lhs -> res where
-         , FromT a ~ a'
+    doLeftJoin :: Proxy lateral -> lhs -> rhs -> From res
-         , SqlSelect b r
+
-         , ToAlias b
+instance ( ToFrom a a'
-         , ToAliasReference b
+         , 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
-         , mb ~ ToMaybeT b
+         , d ~ (a' :& ToMaybeT b)
-         ) => FromLeftJoin Lateral a (a' -> SqlQuery b) (a' :& mb) where
+         , SqlSelect b r
-            runFromLeftJoin _ leftPart q on' = do
+         , ToAlias b
-                (leftVal, leftFrom) <- runFrom leftPart
+         , ToAliasReference b
-                (rightVal, rightFrom) <- fromSubQuery LateralSubQuery (q leftVal)
+         ) => DoLeftJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where
-                let ret = leftVal :& (toMaybe rightVal)
+    doLeftJoin _ = leftJoinLateral
-                pure $ (ret, FromJoin leftFrom LeftOuterJoinKind rightFrom (Just (on' ret)))
 
-instance ( From a
+instance ( DoLeftJoin lateral lhs rhs r, lateral ~ IsLateral rhs )
-         , FromT a ~ a'
+           => ToFrom (LeftOuterJoin lhs rhs) r where
-         , From b
+     toFrom (LeftOuterJoin a b) = doLeftJoin (Proxy @lateral) a 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'
+class DoCrossJoin lateral lhs rhs res | lateral lhs rhs -> res where
-         ) => From (LeftOuterJoin a (b, b' -> SqlExpr (Value Bool))) where
+    doCrossJoin :: Proxy lateral -> lhs -> rhs -> From res
-            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
+instance (ToFrom a a', ToFrom b b') => DoCrossJoin NotLateral a b (a' :& b') where
-         , FromT a ~ a'
+    doCrossJoin _ = crossJoin
-         , From b
+instance (ToFrom a a', SqlSelect b r, ToAlias b, ToAliasReference b)
-         , FromT b ~ 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'
-         , ma ~ ToMaybeT a'
+         , ToMaybeT a' ~ ma
-         , ToMaybe b'
+         , HasOnClause rhs (ma :& b')
-         , mb ~ ToMaybeT b'
          , ErrorOnLateral b
-         ) => From (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) where
+         , rhs ~ (b, (ma :& b') -> SqlExpr (Value Bool))
-            type FromT (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) = FromOnClause (b, (ma :& mb) -> SqlExpr(Value Bool))
+         ) => ToFrom (RightOuterJoin a rhs) (ma :& b') where
-            runFrom (FullOuterJoin leftPart (rightPart, on')) = do
+    toFrom (RightOuterJoin a b) = rightJoin a b
-                (leftVal, leftFrom) <- runFrom leftPart
-                (rightVal, rightFrom) <- runFrom rightPart
-                let ret = (toMaybe leftVal) :& (toMaybe rightVal)
-                pure $ (ret, FromJoin leftFrom FullOuterJoinKind rightFrom (Just (on' ret)))
 
-instance ( From a
+instance ( ToFrom a a'
-         , FromT a ~ a'
+         , ToFrom b b'
          , ToMaybe a'
-         , ma ~ ToMaybeT a'
+         , ToMaybeT a' ~ ma
-         , From b
+         , ToMaybe b'
-         , FromT b ~ b'
+         , ToMaybeT b' ~ mb
+         , HasOnClause rhs (ma :& mb)
          , ErrorOnLateral b
-         ) => From (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) where
+         , rhs ~ (b, (ma :& mb) -> SqlExpr (Value Bool))
-            type FromT (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) = FromOnClause (b, (ma :& b') -> SqlExpr(Value Bool))
+         ) => ToFrom (FullOuterJoin a rhs) (ma :& mb) where
-            runFrom (RightOuterJoin leftPart (rightPart, on')) = do
+    toFrom (FullOuterJoin a b) = fullOuterJoin a b
-                (leftVal, leftFrom) <- runFrom leftPart
-                (rightVal, rightFrom) <- runFrom rightPart
-                let ret = (toMaybe leftVal) :& rightVal
-                pure $ (ret, FromJoin leftFrom RightOuterJoinKind rightFrom (Just (on' ret)))
 
-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,200 +4,109 @@
 {-# 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
+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 (From(..), from, on)
-import Database.Esqueleto.Internal.PersistentImport (DBName(..))
+import Database.Esqueleto.Internal.PersistentImport
+       (DBName(..), Entity, PersistEntity, 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, FromClause)
+    toFrom setOperation = From $ do
-runSetOperation operation = do
+        ident <- newIdentFor (DBName "u")
-    (aliasedOperation, ret) <- aliasQueries operation
+        (a, fromClause) <- unSqlSetOperation setOperation Never
-    ident <- newIdentFor (DBName "u")
+        ref <- toAliasReference ident a
-    ref <- toAliasReference ident ret
+        pure (ref, \_ info -> (first parens $ fromClause info) <> (" AS " <> useIdent info ident, mempty))
-    pure (ref, FromQuery ident (operationToSql aliasedOperation) NormalSubQuery)
 
-  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
-                let p' =
+            state <- Q $ lift S.get
-                      case p of
+            aliasedValue <- toAlias ret
-                        Parens -> Parens
+            Q $ lift $ S.put state
-                        Never ->
+            let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)
-                          if (sdLimitClause sideData) /= mempty
+            let p' =
-                              || length (sdOrderByClause sideData) > 0 then
+                  case p of
-                            Parens
+                    Parens -> Parens
-                          else
+                    Never ->
-                            Never
+                      if (sdLimitClause sideData) /= mempty
-                pure (SelectQueryP p' $ Q $ W.WriterT $ pure (aliasedRet, sideData), aliasedRet)
+                          || length (sdOrderByClause sideData) > 0 then
-            SqlSetUnion     o1 o2 -> do
+                        Parens
-                (o1', ret) <- aliasQueries o1
+                      else
-                (o2', _  ) <- aliasQueries o2
+                        Never
-                pure (SqlSetUnion o1' o2', ret)
+            pure (aliasedValue, \info -> first (parensM p') $ toRawSql SELECT info aliasedQuery)
-            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
 
--- | @UNION@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
+
-union_ :: a -> b -> Union a b
+class Union_ a where
-union_ = Union
+    -- | @UNION@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
+    union_ :: a
+
+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

src/Database/Esqueleto/Internal/Internal.hs

@@ -24,7 +24,7 @@
 module Database.Esqueleto.Internal.Internal where
 
 import Control.Applicative ((<|>))
-import Data.Coerce (coerce)
+import Data.Coerce (Coercible, coerce)
 import Control.Arrow (first, (***))
 import Control.Exception (Exception, throw, throwIO)
 import Control.Monad (MonadPlus(..), guard, void)
@@ -533,8 +533,7 @@ subSelectUnsafe :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Va
 subSelectUnsafe = sub SELECT
 
 -- | Project a field of an entity.
-(^.)
+(^.) :: forall typ val . (PersistEntity val, PersistField typ)
-    :: forall typ val. (PersistEntity val, PersistField typ)
     => SqlExpr (Entity val)
     -> EntityField val typ
     -> SqlExpr (Value typ)
@@ -585,8 +584,7 @@ withNonNull field f = do
     f $ veryUnsafeCoerceSqlExprValue field
 
 -- | Project a field of an entity that may be null.
-(?.)
+(?.) :: ( PersistEntity val , PersistField typ)
-    :: (PersistEntity val, PersistField typ)
     => SqlExpr (Maybe (Entity val))
     -> EntityField val typ
     -> SqlExpr (Value (Maybe typ))
@@ -1738,8 +1736,7 @@ data FromClause
     = FromStart Ident EntityDef
     | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool)))
     | OnClause (SqlExpr (Value Bool))
-    | FromQuery Ident (IdentInfo -> (TLB.Builder, [PersistValue])) SubQueryType
+    | FromRaw (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]))
-    | FromIdent Ident
 
 data CommonTableExpressionKind
     = RecursiveCommonTableExpression
@@ -1759,8 +1756,7 @@ collectIdents fc = case fc of
     FromStart i _ -> Set.singleton i
     FromJoin lhs _ rhs _ -> collectIdents lhs <> collectIdents rhs
     OnClause _ -> mempty
-    FromQuery _ _ _ -> mempty
+    FromRaw _ -> mempty
-    FromIdent _ -> mempty
 
 instance Show FromClause where
     show fc = case fc of
@@ -1782,10 +1778,8 @@ instance Show FromClause where
             ]
         OnClause expr ->
             "(OnClause " <> render' expr <> ")"
-        FromQuery ident _ subQueryType ->
+        FromRaw _ ->
-            "(FromQuery " <> show ident <> " " <> show subQueryType <> ")"
+            "(FromRaw _)"
-        FromIdent ident ->
-            "(FromIdent " <> show ident <> ")"
 
       where
         dummy = SqlBackend
@@ -1839,14 +1833,12 @@ collectOnClauses sqlBackend = go Set.empty []
     findRightmostIdent (FromStart i _) = Just i
     findRightmostIdent (FromJoin _ _ r _) = findRightmostIdent r
     findRightmostIdent (OnClause {}) = Nothing
-    findRightmostIdent (FromQuery _ _ _) = Nothing
+    findRightmostIdent (FromRaw _) = Nothing
-    findRightmostIdent (FromIdent _) = Nothing
 
     findLeftmostIdent (FromStart i _) = Just i
     findLeftmostIdent (FromJoin l _ _ _) = findLeftmostIdent l
     findLeftmostIdent (OnClause {}) = Nothing
-    findLeftmostIdent (FromQuery _ _ _) = Nothing
+    findLeftmostIdent (FromRaw _) = Nothing
-    findLeftmostIdent (FromIdent _) = Nothing
 
     tryMatch
         :: Set Ident
@@ -2819,18 +2811,7 @@ makeFrom info mode fs = ret
                 , maybe mempty makeOnClause monClause
                 ]
     mk _ (OnClause _) = throw (UnexpectedCaseErr MakeFromError)
-    mk _ (FromQuery ident f subqueryType) =
+    mk paren (FromRaw f) = f paren info
-        let (queryText, queryVals) = f info
-            lateralKeyword =
-              case subqueryType of
-                NormalSubQuery -> ""
-                LateralSubQuery -> "LATERAL "
-        in
-            ( lateralKeyword <> (parens queryText) <> " AS " <> useIdent info ident
-            , queryVals
-            )
-    mk _ (FromIdent ident) =
-        (useIdent info ident, mempty)
 
     base ident@(I identText) def =
         let db@(DBName dbText) = entityDB def
@@ -2914,13 +2895,6 @@ makeLocking = flip (,) [] . maybe mempty toTLB . Monoid.getLast
 parens :: TLB.Builder -> TLB.Builder
 parens b = "(" <> (b <> ")")
 
-aliasedValueIdentToRawSql :: Ident -> IdentInfo -> (TLB.Builder, [PersistValue])
-aliasedValueIdentToRawSql i info = (useIdent info i, mempty)
-
-valueReferenceToRawSql ::  Ident -> (IdentInfo -> Ident) -> IdentInfo -> (TLB.Builder, [PersistValue])
-valueReferenceToRawSql sourceIdent columnIdentF info =
-    (useIdent info sourceIdent <> "." <> useIdent info (columnIdentF info), mempty)
-
 aliasedEntityColumnIdent :: Ident -> FieldDef -> Ident
 aliasedEntityColumnIdent (I baseIdent) field =
     I (baseIdent <> "_" <> (unDBName $ fieldDB field))

test/MySQL/Test.hs

@@ -1,27 +1,28 @@
-{-# LANGUAGE ScopedTypeVariables
+{-# LANGUAGE FlexibleContexts #-}
-           , FlexibleContexts
+{-# LANGUAGE RankNTypes #-}
-           , RankNTypes
+{-# LANGUAGE ScopedTypeVariables #-}
-           , TypeFamilies
+{-# LANGUAGE TypeApplications #-}
-           , TypeApplications
+{-# LANGUAGE TypeFamilies #-}
-#-}
 
 module Main (main) where
 
 import Control.Monad (void)
 import Control.Monad.IO.Class (MonadIO(liftIO))
-import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT)
+import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)
 import Control.Monad.Trans.Reader (ReaderT)
-import Database.Persist.MySQL ( withMySQLConn
+import qualified Control.Monad.Trans.Resource as R
-                              , connectHost
-                              , connectDatabase
-                              , connectUser
-                              , connectPassword
-                              , connectPort
-                              , defaultConnectInfo)
 import Database.Esqueleto
 import Database.Esqueleto.Experimental hiding (from, on)
 import qualified Database.Esqueleto.Experimental as Experimental
-import qualified Control.Monad.Trans.Resource as R
+import Database.Persist.MySQL
+       ( connectDatabase
+       , connectHost
+       , connectPassword
+       , connectPort
+       , connectUser
+       , defaultConnectInfo
+       , withMySQLConn
+       )
 import Test.Hspec
 
 import Common.Test
@@ -187,7 +188,7 @@ testMysqlUnionWithLimits = do
               pure $ foo ^. FooName
 
 
-        ret <- select $ Experimental.from $ SelectQuery q1 `Union` SelectQuery q2
+        ret <- select $ Experimental.from $ q1 `union_` q2
         liftIO $ ret `shouldMatchList` [Value 1, Value 2, Value 4, Value 5]