Fix the On Clause Ordering issue (#156)

* Add failing test

* Refactor newIdentFor to not have an error case

* annotation for warning

* refactoring

* Expression parser

* holy shit it works

* Add a shitload of tests

* cross join

* Find a failing case

* Account for that one case

* works

* Composability test

* okay now it tests something

* Documentation updates

* Add since, changelog

* fix

changelog.md

@@ -1,3 +1,11 @@
+3.2.0 (unreleased)
+=======
+
+- @parsonsmatt
+  - [#156](https://github.com/bitemyapp/esqueleto/pull/156): Remove the
+    restriction that `on` clauses must appear in reverse order to the joining
+    tables.
+
 3.1.3
 ========
 
@@ -11,7 +19,7 @@
   - [#149](https://github.com/bitemyapp/esqueleto/pull/157): Added `associateJoin` query helpers.
 
 3.1.1
-========
+=======
 
 - @JoseD92
   - [#149](https://github.com/bitemyapp/esqueleto/pull/149): Added `upsert` support.

esqueleto.cabal

@@ -1,7 +1,7 @@
 cabal-version: 1.12
 
 name:           esqueleto
-version:        3.1.3
+version:        3.2.0
 synopsis:       Type-safe EDSL for SQL queries on persistent backends.
 description:    @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends.  Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime.
                 .
@@ -31,12 +31,13 @@ library
       Database.Esqueleto
       Database.Esqueleto.Internal.Language
       Database.Esqueleto.Internal.Sql
+      Database.Esqueleto.Internal.Internal
+      Database.Esqueleto.Internal.ExprParser
       Database.Esqueleto.MySQL
       Database.Esqueleto.PostgreSQL
       Database.Esqueleto.PostgreSQL.JSON
       Database.Esqueleto.SQLite
   other-modules:
-      Database.Esqueleto.Internal.Internal
       Database.Esqueleto.Internal.PersistentImport
       Database.Esqueleto.PostgreSQL.JSON.Instances
       Paths_esqueleto
@@ -45,10 +46,12 @@ library
   build-depends:
       base >=4.8 && <5.0
     , aeson >=1.0
+    , attoparsec >= 0.13 && < 0.14
     , blaze-html
     , bytestring
     , containers
     , conduit >=1.3
+    , containers
     , monad-logger
     , persistent >=2.10.0 && <2.11
     , resourcet >=1.2
@@ -75,6 +78,7 @@ test-suite mysql
   ghc-options: -Wall
   build-depends:
       base >=4.8 && <5.0
+    , attoparsec
     , blaze-html
     , bytestring
     , conduit >=1.3
@@ -83,6 +87,7 @@ test-suite mysql
     , exceptions
     , hspec
     , monad-logger
+    , mtl
     , mysql
     , mysql-simple
     , persistent >=2.8.0 && <2.11
@@ -110,6 +115,7 @@ test-suite postgresql
   build-depends:
       base >=4.8 && <5.0
     , aeson
+    , attoparsec
     , blaze-html
     , bytestring
     , conduit >=1.3
@@ -118,6 +124,7 @@ test-suite postgresql
     , exceptions
     , hspec
     , monad-logger
+    , mtl
     , persistent >=2.10.0 && <2.11
     , persistent-postgresql >= 2.10.0 && <2.11
     , persistent-template
@@ -144,6 +151,7 @@ test-suite sqlite
   ghc-options: -Wall
   build-depends:
       base >=4.8 && <5.0
+    , attoparsec
     , blaze-html
     , bytestring
     , conduit >=1.3
@@ -152,6 +160,7 @@ test-suite sqlite
     , exceptions
     , hspec
     , monad-logger
+    , mtl
     , persistent >=2.8.0 && <2.11
     , persistent-sqlite
     , persistent-template

src/Database/Esqueleto.hs

@@ -327,16 +327,11 @@ import qualified Database.Persist
 -- @
 -- 'select' $
 -- 'from' $ \\(p1 `'InnerJoin`` f `'InnerJoin`` p2) -> do
--- 'on' (p2 '^.' PersonId '==.' f '^.' FollowFollowed)
 -- 'on' (p1 '^.' PersonId '==.' f '^.' FollowFollower)
+-- 'on' (p2 '^.' PersonId '==.' f '^.' FollowFollowed)
 -- return (p1, f, p2)
 -- @
 --
--- /Note carefully that the order of the ON clauses is/
--- /reversed!/ You're required to write your 'on's in reverse
--- order because that helps composability (see the documentation
--- of 'on' for more details).
---
 -- We also currently support @UPDATE@ and @DELETE@ statements.
 -- For example:
 --

src/Database/Esqueleto/Internal/ExprParser.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+-- | This is an internal module. This module may have breaking changes without
+-- a corresponding major version bump. If you use this module, please open an
+-- issue with your use-case so we can safely support it.
+module Database.Esqueleto.Internal.ExprParser where
+
+import           Prelude              hiding (takeWhile)
+
+import           Control.Applicative  ((<|>))
+import           Control.Monad        (void)
+import           Data.Attoparsec.Text
+import           Data.Set             (Set)
+import qualified Data.Set             as Set
+import           Data.Text            (Text)
+import qualified Data.Text            as Text
+import           Database.Persist.Sql
+
+-- | A type representing the access of a table value. In Esqueleto, we get
+-- a guarantee that the access will look something like:
+--
+-- @
+-- escape-char [character] escape-char . escape-char [character] escape-char
+--             ^^^^^^^^^^^                           ^^^^^^^^^^^
+--             table name                            column name
+-- @
+data TableAccess = TableAccess
+  { tableAccessTable  :: Text
+  , tableAccessColumn :: Text
+  }
+  deriving (Eq, Ord, Show)
+
+-- | Parse a @SqlExpr (Value Bool)@'s textual representation into a list of
+-- 'TableAccess'
+parseOnExpr :: SqlBackend -> Text -> Either String (Set TableAccess)
+parseOnExpr sqlBackend text = do
+  c <- mkEscapeChar sqlBackend
+  parseOnly (onExpr c) text
+
+-- | This function uses the 'connEscapeName' function in the 'SqlBackend' with an
+-- empty identifier to pull out an escape character. This implementation works
+-- with postgresql, mysql, and sqlite backends.
+mkEscapeChar :: SqlBackend -> Either String Char
+mkEscapeChar sqlBackend =
+  case Text.uncons (connEscapeName sqlBackend (DBName "")) of
+    Nothing ->
+      Left "Failed to get an escape character from the SQL backend."
+    Just (c, _) ->
+      Right c
+
+type ExprParser a = Char -> Parser a
+
+onExpr :: ExprParser (Set TableAccess)
+onExpr e = Set.fromList <$> many' tableAccesses
+  where
+   tableAccesses = do
+     skipToEscape e <?> "Skipping to an escape char"
+     parseTableAccess e <?> "Parsing a table access"
+
+skipToEscape :: ExprParser ()
+skipToEscape escapeChar = void (takeWhile (/= escapeChar))
+
+parseEscapedIdentifier :: ExprParser [Char]
+parseEscapedIdentifier escapeChar = do
+  char escapeChar
+  str <- parseEscapedChars escapeChar
+  char escapeChar
+  pure str
+
+parseTableAccess :: ExprParser TableAccess
+parseTableAccess ec = do
+  tableAccessTable <- Text.pack <$> parseEscapedIdentifier ec
+  _ <- char '.'
+  tableAccessColumn <- Text.pack <$> parseEscapedIdentifier ec
+  pure TableAccess {..}
+
+parseEscapedChars :: ExprParser [Char]
+parseEscapedChars escapeChar = go
+  where
+    twoEscapes = char escapeChar *> char escapeChar
+    go = many' (notChar escapeChar <|> twoEscapes)

src/Database/Esqueleto/Internal/Internal.hs

@@ -25,11 +25,16 @@
 -- | This is an internal module, anything exported by this module
 -- may change without a major version bump.  Please use only
 -- "Database.Esqueleto" if possible.
+--
+-- If you use this module, please report what your use case is on the issue
+-- tracker so we can safely support it.
 module Database.Esqueleto.Internal.Internal where
 
+import Control.Applicative ((<|>))
 import Control.Arrow ((***), first)
 import Control.Exception (Exception, throw, throwIO)
-import Control.Monad (ap, MonadPlus(..), void)
+import qualified Data.Maybe as Maybe
+import Control.Monad (guard, ap, MonadPlus(..), void)
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Resource (MonadResource, release)
@@ -43,6 +48,8 @@ import qualified Data.Monoid as Monoid
 import Data.Proxy (Proxy(..))
 import Database.Esqueleto.Internal.PersistentImport
 import Database.Persist.Sql.Util (entityColumnNames, entityColumnCount, parseEntityValues, isIdField, hasCompositeKey)
+import qualified Data.Set as Set
+import Data.Set (Set)
 import qualified Control.Monad.Trans.Reader as R
 import qualified Control.Monad.Trans.State as S
 import qualified Control.Monad.Trans.Writer as W
@@ -57,6 +64,8 @@ import qualified Data.Text.Lazy.Builder as TLB
 import Data.Typeable (Typeable)
 import Text.Blaze.Html (Html)
 
+import Database.Esqueleto.Internal.ExprParser (TableAccess(..), parseOnExpr)
+
 -- | (Internal) Start a 'from' query with an entity. 'from'
 -- does two kinds of magic using 'fromStart', 'fromJoin' and
 -- 'fromFinish':
@@ -80,8 +89,8 @@ fromStart = x
       let ed = entityDef (getVal x)
       ident <- newIdentFor (entityDB ed)
       let ret   = EEntity ident
-          from_ = FromStart ident ed
+          f' = FromStart ident ed
-      return (EPreprocessedFrom ret from_)
+      return (EPreprocessedFrom ret f')
     getVal :: SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))) -> Proxy a
     getVal = const Proxy
 
@@ -94,7 +103,7 @@ fromStartMaybe = maybelize <$> fromStart
   where
     maybelize :: SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))
               -> SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a))))
-    maybelize (EPreprocessedFrom ret from_) = EPreprocessedFrom (EMaybe ret) from_
+    maybelize (EPreprocessedFrom ret f') = EPreprocessedFrom (EMaybe ret) f'
 
 -- | (Internal) Do a @JOIN@.
 fromJoin
@@ -105,71 +114,75 @@ fromJoin
 fromJoin (EPreprocessedFrom lhsRet lhsFrom)
          (EPreprocessedFrom rhsRet rhsFrom) = Q $ do
   let ret   = smartJoin lhsRet rhsRet
-      from_ = FromJoin lhsFrom             -- LHS
+      from' = FromJoin lhsFrom             -- LHS
                        (reifyJoinKind ret) -- JOIN
                        rhsFrom             -- RHS
                        Nothing             -- ON
-  return (EPreprocessedFrom ret from_)
+  return (EPreprocessedFrom ret from')
 
 -- | (Internal) Finish a @JOIN@.
 fromFinish
   :: SqlExpr (PreprocessedFrom a)
   -> SqlQuery a
-fromFinish (EPreprocessedFrom ret from_) = Q $ do
+fromFinish (EPreprocessedFrom ret f') = Q $ do
-  W.tell mempty { sdFromClause = [from_] }
+  W.tell mempty { sdFromClause = [f'] }
   return ret
 
 -- | @WHERE@ clause: restrict the query's result.
 where_ :: SqlExpr (Value Bool) -> SqlQuery ()
 where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr }
 
--- | @ON@ clause: restrict the a @JOIN@'s result.  The @ON@
+-- | An @ON@ clause, useful to describe how two tables are related. Cross joins
--- clause will be applied to the /last/ @JOIN@ that does not
+-- and tuple-joins do not need an 'on' clause, but 'InnerJoin' and the various
--- have an @ON@ clause yet.  If there are no @JOIN@s without
+-- outer joins do.
--- @ON@ clauses (either because you didn't do any @JOIN@, or
--- because all @JOIN@s already have their own @ON@ clauses), a
--- runtime exception 'OnClauseWithoutMatchingJoinException' is
--- thrown.  @ON@ clauses are optional when doing @JOIN@s.
 --
--- On the simple case of doing just one @JOIN@, for example
+-- If you don't include an 'on' clause (or include too many!) then a runtime
+-- exception will be thrown.
+--
+-- As an example, consider this simple join:
 --
 -- @
--- select $
+-- 'select' $
 -- 'from' $ \\(foo `'InnerJoin`` bar) -> do
 --   'on' (foo '^.' FooId '==.' bar '^.' BarFooId)
 --   ...
 -- @
 --
--- there's no ambiguity and the rules above just mean that
+-- We need to specify the clause for joining the two columns together. If we had
--- you're allowed to call 'on' only once (as in SQL).  If you
+-- this:
--- have many joins, then the 'on's are applied on the /reverse/
--- order that the @JOIN@s appear.  For example:
 --
 -- @
--- select $
+-- 'select' $
+-- 'from' $ \\(foo `'CrossJoin`` bar) -> do
+--   ...
+-- @
+--
+-- Then we can safely omit the 'on' clause, because the cross join will make
+-- pairs of all records possible.
+--
+-- You can do multiple 'on' clauses in a query. This query joins three tables,
+-- and has two 'on' clauses:
+--
+-- @
+-- 'select' $
 -- 'from' $ \\(foo `'InnerJoin`` bar `'InnerJoin`` baz) -> do
 --   'on' (baz '^.' BazId '==.' bar '^.' BarBazId)
 --   'on' (foo '^.' FooId '==.' bar '^.' BarFooId)
 --   ...
 -- @
 --
--- The order is /reversed/ in order to improve composability.
+-- Old versions of esqueleto required that you provide the 'on' clauses in
--- For example, consider @query1@ and @query2@ below:
+-- reverse order. This restriction has been lifted - you can now provide 'on'
+-- clauses in any order, and the SQL should work itself out. The above query is
+-- now totally equivalent to this:
 --
 -- @
--- let query1 =
+-- 'select' $
---       'from' $ \\(foo `'InnerJoin`` bar) -> do
+-- 'from' $ \\(foo `'InnerJoin`` bar `'InnerJoin`` baz) -> do
---         'on' (foo '^.' FooId '==.' bar '^.' BarFooId)
+--   'on' (foo '^.' FooId '==.' bar '^.' BarFooId)
---     query2 =
+--   'on' (baz '^.' BazId '==.' bar '^.' BarBazId)
---       'from' $ \\(mbaz `'LeftOuterJoin`` quux) -> do
+--   ...
---         return (mbaz '?.' BazName, quux)
---     test1 =      (,) \<$\> query1 \<*\> query2
---     test2 = flip (,) \<$\> query2 \<*\> query1
 -- @
---
--- If the order was /not/ reversed, then @test2@ would be
--- broken: @query1@'s 'on' would refer to @query2@'s
--- 'LeftOuterJoin'.
 on :: SqlExpr (Value Bool) -> SqlQuery ()
 on expr = Q $ W.tell mempty { sdFromClause = [OnClause expr] }
 
@@ -1396,32 +1409,108 @@ newtype SetClause = SetClause (SqlExpr (Value ()))
 -- | Collect 'OnClause's on 'FromJoin's.  Returns the first
 -- unmatched 'OnClause's data on error.  Returns a list without
 -- 'OnClauses' on success.
-collectOnClauses :: [FromClause] -> Either (SqlExpr (Value Bool)) [FromClause]
+collectOnClauses
-collectOnClauses = go []
+  :: SqlBackend
+  -> [FromClause]
+  -> Either (SqlExpr (Value Bool)) [FromClause]
+collectOnClauses sqlBackend = go Set.empty []
   where
-    go []  (f@(FromStart _ _):fs) = fmap (f:) (go [] fs) -- fast path
+    go is []  (f@(FromStart i _) : fs) =
-    go acc (OnClause expr    :fs) = findMatching acc expr >>= flip go fs
+      fmap (f:) (go (Set.insert i is) [] fs) -- fast path
-    go acc (f:fs)                 = go (f:acc) fs
+    go idents acc (OnClause expr : fs) = do
-    go acc []                     = return $ reverse acc
+      (idents', a) <- findMatching idents acc expr
+      go idents' a fs
+    go idents acc (f:fs) =
+      go idents (f:acc) fs
+    go _ acc [] =
+      return $ reverse acc
 
-    findMatching (f : acc) expr =
+    findMatching
-      case tryMatch expr f of
+      :: Set Ident
-        Just f' -> return (f' : acc)
+      -> [FromClause]
-        Nothing -> (f:) <$> findMatching acc expr
+      -> SqlExpr (Value Bool)
-    findMatching [] expr = Left expr
+      -> Either (SqlExpr (Value Bool)) (Set Ident, [FromClause])
+    findMatching idents fromClauses expr =
+      case fromClauses of
+        f : acc ->
+          let
+            idents' =
+              idents
+              <> Set.fromList (Maybe.catMaybes [findLeftmostIdent f, findRightmostIdent f])
+          in
+            case tryMatch idents' expr f of
+              Just (idents'', f') ->
+                return (idents'', f' : acc)
+              Nothing ->
+                fmap (f:) <$> findMatching idents' acc expr
+        [] ->
+          Left expr
 
-    tryMatch expr (FromJoin l k r onClause) =
+    findRightmostIdent (FromStart i _) = Just i
-      matchR `mplus` matchC `mplus` matchL -- right to left
+    findRightmostIdent (FromJoin _ _ r _) = findRightmostIdent r
-        where
+    findRightmostIdent (OnClause {}) = Nothing
-          matchR = (\r' -> FromJoin l k r' onClause) <$> tryMatch expr r
-          matchL = (\l' -> FromJoin l' k r onClause) <$> tryMatch expr l
-          matchC = case onClause of
-                     Nothing | k /= CrossJoinKind
-                               -> return (FromJoin l k r (Just expr))
-                             | otherwise -> mzero
-                     Just _  -> mzero
-    tryMatch _ _ = mzero
 
+    findLeftmostIdent (FromStart i _) = Just i
+    findLeftmostIdent (FromJoin l _ _ _) = findLeftmostIdent l
+    findLeftmostIdent (OnClause {}) = Nothing
+
+    tryMatch
+      :: Set Ident
+      -> SqlExpr (Value Bool)
+      -> FromClause
+      -> Maybe (Set Ident, FromClause)
+    tryMatch idents expr fromClause =
+      case fromClause of
+        FromJoin l k r onClause ->
+          matchTable <|> matchR <|> matchC <|> matchL <|> matchPartial -- right to left
+            where
+              matchR = fmap (\r' -> FromJoin l k r' onClause)
+                <$> tryMatch idents expr r
+              matchL = fmap (\l' -> FromJoin l' k r onClause)
+                <$> tryMatch idents expr l
+              matchPartial = do
+                i1 <- findLeftmostIdent l
+                i2 <- findRightmostIdent r
+                guard $
+                  Set.isSubsetOf
+                    identsInOnClause
+                    (Set.fromList [i1, i2])
+                guard $ k /= CrossJoinKind
+                guard $ Maybe.isNothing onClause
+                pure (Set.fromList [] <> idents, FromJoin l k r (Just expr))
+              matchC =
+                case onClause of
+                  Nothing
+                    | "?" `T.isInfixOf` renderedExpr ->
+                        return (idents, FromJoin l k r (Just expr))
+                    | Set.null identsInOnClause ->
+                        return (idents, FromJoin l k r (Just expr))
+                    | otherwise ->
+                        Nothing
+                  Just _ ->
+                    Nothing
+              matchTable = do
+                i1 <- findLeftmostIdent r
+                i2 <- findRightmostIdent l
+                guard $ Set.fromList [i1, i2] `Set.isSubsetOf` identsInOnClause
+                guard $ k /= CrossJoinKind
+                guard $ Maybe.isNothing onClause
+                pure (Set.fromList [i1, i2] <> idents, FromJoin l k r (Just expr))
+
+        _ ->
+          Nothing
+      where
+        identsInOnClause =
+          onExprToTableIdentifiers
+
+        renderedExpr =
+          renderExpr sqlBackend expr
+
+        onExprToTableIdentifiers =
+          Set.map (I . tableAccessTable)
+          . either error id
+          . parseOnExpr sqlBackend
+          $ renderedExpr
 
 -- | A complete @WHERE@ clause.
 data WhereClause = Where (SqlExpr (Value Bool))
@@ -1476,6 +1565,7 @@ type LockingClause = Monoid.Last LockingKind
 
 -- | Identifier used for table names.
 newtype Ident = I T.Text
+  deriving (Eq, Ord, Show)
 
 
 -- | List of identifiers already in use and supply of temporary
@@ -1489,24 +1579,18 @@ initialIdentState = IdentState mempty
 -- | Create a fresh 'Ident'.  If possible, use the given
 -- 'DBName'.
 newIdentFor :: DBName -> SqlQuery Ident
-newIdentFor = Q . lift . try . unDBName
+newIdentFor (DBName original) = Q $ lift $ findFree Nothing
   where
-    try orig = do
+    findFree msuffix = do
-      s <- S.get
+      let
-      let go (t:ts) | t `HS.member` inUse s = go ts
+        withSuffix =
-                    | otherwise             = use t
+          maybe id (\suffix -> (<> T.pack (show suffix))) msuffix original
-          go [] = throw (UnexpectedCaseErr NewIdentForError)
+      isInUse <- S.gets (HS.member withSuffix . inUse)
-      go (possibilities orig)
+      if isInUse
-
+        then findFree (succ <$> (msuffix <|> Just (1 :: Int)))
-    possibilities t = t : map addNum [2..]
+        else do
-      where
+          S.modify (\s -> s { inUse = HS.insert withSuffix (inUse s) })
-        addNum :: Int -> T.Text
+          pure (I withSuffix)
-        addNum = T.append t . T.pack . show
-
-    use t = do
-      S.modify (\s -> s { inUse = HS.insert t (inUse s) })
-      return (I t)
-
 
 -- | Information needed to escape and use identifiers.
 type IdentInfo = (SqlBackend, IdentState)
@@ -1914,7 +1998,7 @@ selectSource query = do
 --  @Value t@.  You may use @Value@ to return projections of an
 --  @Entity@ (see @('^.')@ and @('?.')@) or to return any other
 --  value calculated on the query (e.g., 'countRows' or
---  'sub_select').
+--  'subSelect').
 --
 -- The @SqlSelect a r@ class has functional dependencies that
 -- allow type information to flow both from @a@ to @r@ and
@@ -2209,11 +2293,15 @@ makeSelect info mode_ distinctClause ret = process mode_
     plain    v = (v, [])
 
 
-makeFrom :: IdentInfo -> Mode -> [FromClause] -> (TLB.Builder, [PersistValue])
+makeFrom
+  :: IdentInfo
+  -> Mode
+  -> [FromClause]
+  -> (TLB.Builder, [PersistValue])
 makeFrom _    _    [] = mempty
 makeFrom info mode fs = ret
   where
-    ret = case collectOnClauses fs of
+    ret = case collectOnClauses (fst info) fs of
             Left expr -> throw $ mkExc expr
             Right fs' -> keyword $ uncommas' (map (mk Never) fs')
     keyword = case mode of
@@ -2932,3 +3020,33 @@ insertSelect = void . insertSelectCount
 insertSelectCount :: (MonadIO m, PersistEntity a) =>
   SqlQuery (SqlExpr (Insertion a)) -> SqlWriteT m Int64
 insertSelectCount = rawEsqueleto INSERT_INTO . fmap EInsertFinal
+
+-- | Renders an expression into 'Text'. Only useful for creating a textual
+-- representation of the clauses passed to an "On" clause.
+--
+-- @since 3.2.0
+renderExpr :: SqlBackend -> SqlExpr (Value Bool) -> T.Text
+renderExpr sqlBackend e =
+  case e of
+    ERaw _ mkBuilderValues -> do
+      let (builder, _) = mkBuilderValues (sqlBackend, initialIdentState)
+       in (builderToText builder)
+    ECompositeKey mkInfo ->
+      throw
+        . RenderExprUnexpectedECompositeKey
+        . builderToText
+        . mconcat
+        . mkInfo
+        $ (sqlBackend, initialIdentState)
+
+-- | An exception thrown by 'RenderExpr' - it's not designed to handle composite
+-- keys, and will blow up if you give it one.
+--
+-- @since 3.2.0
+data RenderExprException = RenderExprUnexpectedECompositeKey T.Text
+  deriving Show
+
+-- |
+--
+-- @since 3.2.0
+instance Exception RenderExprException

src/Database/Esqueleto/Internal/Sql.hs

@@ -55,6 +55,7 @@ module Database.Esqueleto.Internal.Sql
   , Mode(..)
   , NeedParens(..)
   , IdentState
+  , renderExpr
   , initialIdentState
   , IdentInfo
   , SqlSelect(..)
@@ -71,6 +72,7 @@ module Database.Esqueleto.Internal.Sql
   , parens
   , toArgList
   , builderToText
+  , Ident(..)
   ) where
 
 import Database.Esqueleto.Internal.Internal

test/Common/Test.hs

@@ -2,6 +2,7 @@
 {-# OPTIONS_GHC -fno-warn-deprecations  #-}
 {-# LANGUAGE ConstraintKinds
            , CPP
+           , PartialTypeSignatures
            , UndecidableInstances
            , EmptyDataDecls
            , FlexibleContexts
@@ -55,7 +56,9 @@ module Common.Test
     , Unique(..)
     ) where
 
+import Data.Either
 import Control.Monad (forM_, replicateM, replicateM_, void)
+import Control.Monad.Reader (ask)
 import Control.Monad.Catch (MonadCatch)
 #if __GLASGOW_HASKELL__ >= 806
 import Control.Monad.Fail (MonadFail)
@@ -69,8 +72,8 @@ import Database.Esqueleto
 import Database.Persist.TH
 import Test.Hspec
 import UnliftIO
+import qualified Data.Attoparsec.Text as AP
 
-import Database.Persist (PersistValue(..))
 import Data.Conduit (ConduitT, (.|), runConduit)
 import qualified Data.Conduit.List as CL
 import qualified Data.List as L
@@ -80,16 +83,17 @@ import qualified Data.Text.Lazy.Builder as TLB
 import qualified Data.Text.Internal.Lazy as TL
 import qualified Database.Esqueleto.Internal.Sql as EI
 import qualified UnliftIO.Resource as R
-
+import qualified Database.Esqueleto.Internal.ExprParser as P
-
 
 -- Test schema
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
   Foo
     name Int
     Primary name
+    deriving Show Eq Ord
   Bar
     quux FooId
+    deriving Show Eq Ord
 
   Person
     name String
@@ -101,6 +105,18 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
     title String
     authorId PersonId
     deriving Eq Show
+  Comment
+    body String
+    blog BlogPostId
+    deriving Eq Show
+  Profile
+    name String
+    person PersonId
+    deriving Eq Show
+  Reply
+    guy PersonId
+    body String
+    deriving Eq Show
 
   Lord
     county String maxlen=100
@@ -160,6 +176,35 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
   Numbers
     int    Int
     double Double
+
+  JoinOne
+    name    String
+    deriving Eq Show
+
+  JoinTwo
+    joinOne JoinOneId
+    name    String
+    deriving Eq Show
+
+  JoinThree
+    joinTwo JoinTwoId
+    name    String
+    deriving Eq Show
+
+  JoinFour
+    name    String
+    joinThree JoinThreeId
+    deriving Eq Show
+
+  JoinOther
+    name    String
+    deriving Eq Show
+
+  JoinMany
+    name      String
+    joinOther JoinOtherId
+    joinOne   JoinOneId
+    deriving Eq Show
 |]
 
 -- Unique Test schema
@@ -317,6 +362,7 @@ testSelectFrom run = do
                                                     , (p2e, p1e)
                                                     , (p2e, p2e) ]
 
+
     it "works for a self-join via sub_select" $
       run $ do
         p1k <- insert p1
@@ -447,7 +493,7 @@ testSelectFrom run = do
 
 testSelectJoin :: Run -> Spec
 testSelectJoin run = do
-  describe "select/JOIN" $ do
+  describe "select:JOIN" $ do
     it "works with a LEFT OUTER JOIN" $
       run $ do
         p1e <- insert' p1
@@ -604,11 +650,9 @@ testSelectJoin run = do
               return p
           liftIO $ (entityVal <$> ps) `shouldBe` [p1]
 
-
-
 testSelectWhere :: Run -> Spec
 testSelectWhere run = do
-  describe "select/where_" $ do
+  describe "select where_" $ do
     it "works for a simple example with (==.)" $
       run $ do
         p1e <- insert' p1
@@ -828,6 +872,17 @@ testSelectWhere run = do
                                 , (p4e, f42, p2e)
                                 , (p2e, f21, p1e) ]
 
+    it "works for a many-to-many explicit join and on order doesn't matter" $ do
+      run $ void $
+        selectRethrowingQuery $
+        from $ \(person `InnerJoin` blog `InnerJoin` comment) -> do
+        on $ person ^. PersonId ==. blog ^. BlogPostAuthorId
+        on $ blog ^. BlogPostId ==. comment ^. CommentBlog
+        pure (person, comment)
+
+      -- we only care that we don't have a SQL error
+      True `shouldBe` True
+
     it "works for a many-to-many explicit join with LEFT OUTER JOINs" $
       run $ do
         p1e@(Entity p1k _) <- insert' p1
@@ -1461,7 +1516,7 @@ testCountingRows run = do
           liftIO $ (n :: Int) `shouldBe` expected
 
 testRenderSql :: Run -> Spec
-testRenderSql run =
+testRenderSql run = do
   describe "testRenderSql" $ do
     it "works" $ do
       (queryText, queryVals) <- run $ renderQuerySelect $
@@ -1481,7 +1536,451 @@ testRenderSql run =
         `shouldBe`
           [toPersistValue ("Johhny Depp" :: TL.Text)]
 
+  describe "renderExpr" $ do
+    it "renders a value" $ do
+      (c, expr) <- run $ do
+        conn <- ask
+        let Right c = P.mkEscapeChar conn
+        pure $ (,) c $ EI.renderExpr conn $
+          EI.EEntity (EI.I "user") ^. PersonId
+          ==. EI.EEntity (EI.I "blog_post") ^. BlogPostAuthorId
+      expr
+        `shouldBe`
+          Text.intercalate (Text.singleton c) ["", "user", ".", "id", ""]
+          <>
+          " = "
+          <>
+          Text.intercalate (Text.singleton c) ["", "blog_post", ".", "authorId", ""]
+    it "renders ? for a val" $ do
+      expr <- run $ ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1))
+      expr `shouldBe` "? = ?"
 
+  describe "EEntity Ident behavior" $ do
+    let
+      render :: SqlExpr (Entity val) -> Text.Text
+      render (EI.EEntity (EI.I ident)) = ident
+    it "renders sensibly" $ do
+      results <- run $ do
+        _ <- insert $ Foo 2
+        _ <- insert $ Foo 3
+        _ <- insert $ Person "hello" Nothing Nothing 3
+        select $
+          from $ \(a `LeftOuterJoin` b) -> do
+          on $ a ^. FooName ==. b ^. PersonFavNum
+          pure (val (render a), val (render b))
+      head results
+        `shouldBe`
+          (Value "Foo", Value "Person")
+
+  describe "ExprParser" $ do
+    let parse parser = AP.parseOnly (parser '#')
+    describe "parseEscapedChars" $ do
+      let subject = parse P.parseEscapedChars
+      it "parses words" $ do
+        subject "hello world"
+          `shouldBe`
+            Right "hello world"
+      it "only returns a single escape-char if present" $ do
+        subject "i_am##identifier##"
+          `shouldBe`
+            Right "i_am#identifier#"
+    describe "parseEscapedIdentifier" $ do
+      let subject = parse P.parseEscapedIdentifier
+      it "parses the quotes out" $ do
+        subject "#it's a me, mario#"
+          `shouldBe`
+            Right "it's a me, mario"
+      it "requires a beginning and end quote" $ do
+        subject "#alas, i have no end"
+          `shouldSatisfy`
+            isLeft
+    describe "parseTableAccess" $ do
+      let subject = parse P.parseTableAccess
+      it "parses a table access" $ do
+        subject "#foo#.#bar#"
+          `shouldBe`
+            Right P.TableAccess
+              { P.tableAccessTable = "foo"
+              , P.tableAccessColumn = "bar"
+              }
+    describe "onExpr" $ do
+      let subject = parse P.onExpr
+      it "works" $ do
+        subject "#foo#.#bar# = #bar#.#baz#"
+          `shouldBe` do
+            Right $ S.fromList
+              [ P.TableAccess
+                { P.tableAccessTable = "foo"
+                , P.tableAccessColumn = "bar"
+                }
+              , P.TableAccess
+                { P.tableAccessTable = "bar"
+                , P.tableAccessColumn = "baz"
+                }
+              ]
+      it "also works with other nonsense" $ do
+        subject "#foo#.#bar# = 3"
+          `shouldBe` do
+            Right $ S.fromList
+              [ P.TableAccess
+                { P.tableAccessTable = "foo"
+                , P.tableAccessColumn = "bar"
+                }
+              ]
+      it "handles a conjunction" $ do
+        subject "#foo#.#bar# = #bar#.#baz# AND #bar#.#baz# > 10"
+          `shouldBe` do
+            Right $ S.fromList
+              [ P.TableAccess
+                { P.tableAccessTable = "foo"
+                , P.tableAccessColumn = "bar"
+                }
+              , P.TableAccess
+                { P.tableAccessTable = "bar"
+                , P.tableAccessColumn = "baz"
+                }
+              ]
+      it "handles ? okay" $ do
+        subject "#foo#.#bar# = ?"
+          `shouldBe` do
+            Right $ S.fromList
+              [ P.TableAccess
+                { P.tableAccessTable = "foo"
+                , P.tableAccessColumn = "bar"
+                }
+              ]
+      it "handles degenerate cases" $ do
+        subject "false" `shouldBe` pure mempty
+        subject "true" `shouldBe` pure mempty
+        subject "1 = 1" `shouldBe` pure mempty
+      it "works even if an identifier isn't first" $ do
+        subject "true and #foo#.#bar# = 2"
+          `shouldBe` do
+            Right $ S.fromList
+              [ P.TableAccess
+                { P.tableAccessTable = "foo"
+                , P.tableAccessColumn = "bar"
+                }
+              ]
+
+testOnClauseOrder :: Run -> Spec
+testOnClauseOrder run = describe "On Clause Ordering" $ do
+  let
+    setup :: MonadIO m => SqlPersistT m ()
+    setup = do
+      ja1 <- insert (JoinOne "j1 hello")
+      ja2 <- insert (JoinOne "j1 world")
+      jb1 <- insert (JoinTwo ja1 "j2 hello")
+      jb2 <- insert (JoinTwo ja1 "j2 world")
+      jb3 <- insert (JoinTwo ja2 "j2 foo")
+      _ <- insert (JoinTwo ja2 "j2 bar")
+      jc1 <- insert (JoinThree jb1 "j3 hello")
+      jc2 <- insert (JoinThree jb1 "j3 world")
+      _ <- insert (JoinThree jb2 "j3 foo")
+      _ <- insert (JoinThree jb3 "j3 bar")
+      _ <- insert (JoinThree jb3 "j3 baz")
+      _ <- insert (JoinFour "j4 foo" jc1)
+      _ <- insert (JoinFour "j4 bar" jc2)
+      jd1 <- insert (JoinOther "foo")
+      jd2 <- insert (JoinOther "bar")
+      _ <- insert (JoinMany "jm foo hello" jd1 ja1)
+      _ <- insert (JoinMany "jm foo world" jd1 ja2)
+      _ <- insert (JoinMany "jm bar hello" jd2 ja1)
+      _ <- insert (JoinMany "jm bar world" jd2 ja2)
+      pure ()
+  describe "identical results for" $ do
+    it "three tables" $ do
+      abcs <- run $ do
+        setup
+        select $
+          from $ \(a `InnerJoin` b `InnerJoin` c) -> do
+          on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
+          on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
+          pure (a, b, c)
+      acbs <- run $ do
+        setup
+        select $
+          from $ \(a `InnerJoin` b `InnerJoin` c) -> do
+          on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
+          on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
+          pure (a, b, c)
+
+      listsEqualOn abcs acbs $ \(Entity _ j1, Entity _ j2, Entity _ j3) ->
+        (joinOneName j1, joinTwoName j2, joinThreeName j3)
+
+    it "four tables" $ do
+      xs0 <- run $ do
+        setup
+        select $
+          from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do
+          on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
+          on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
+          on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
+          pure (a, b, c, d)
+      xs1 <- run $ do
+        setup
+        select $
+          from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do
+          on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
+          on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
+          on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
+          pure (a, b, c, d)
+      xs2 <- run $ do
+        setup
+        select $
+          from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do
+          on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
+          on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
+          on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
+          pure (a, b, c, d)
+      xs3 <- run $ do
+        setup
+        select $
+          from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do
+          on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
+          on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
+          on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
+          pure (a, b, c, d)
+      xs4 <- run $ do
+        setup
+        select $
+          from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do
+          on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
+          on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
+          on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
+          pure (a, b, c, d)
+
+      let getNames (j1, j2, j3, j4) =
+            ( joinOneName (entityVal j1)
+            , joinTwoName (entityVal j2)
+            , joinThreeName (entityVal j3)
+            , joinFourName (entityVal j4)
+            )
+      listsEqualOn xs0 xs1 getNames
+      listsEqualOn xs0 xs2 getNames
+      listsEqualOn xs0 xs3 getNames
+      listsEqualOn xs0 xs4 getNames
+
+    it "associativity of innerjoin" $ do
+      xs0 <- run $ do
+        setup
+        select $
+          from $ \(a `InnerJoin` b `InnerJoin` c `InnerJoin` d) -> do
+          on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
+          on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
+          on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
+          pure (a, b, c, d)
+
+      xs1 <- run $ do
+        setup
+        select $
+          from $ \(a `InnerJoin` b `InnerJoin` (c `InnerJoin` d)) -> do
+          on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
+          on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
+          on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
+          pure (a, b, c, d)
+
+      xs2 <- run $ do
+        setup
+        select $
+          from $ \(a `InnerJoin` (b `InnerJoin` c) `InnerJoin` d) -> do
+          on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
+          on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
+          on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
+          pure (a, b, c, d)
+
+      xs3 <- run $ do
+        setup
+        select $
+          from $ \(a `InnerJoin` (b `InnerJoin` c `InnerJoin` d)) -> do
+          on (a ^. JoinOneId ==. b ^. JoinTwoJoinOne)
+          on (b ^. JoinTwoId ==. c ^. JoinThreeJoinTwo)
+          on (c ^. JoinThreeId ==. d ^. JoinFourJoinThree)
+          pure (a, b, c, d)
+
+      let getNames (j1, j2, j3, j4) =
+            ( joinOneName (entityVal j1)
+            , joinTwoName (entityVal j2)
+            , joinThreeName (entityVal j3)
+            , joinFourName (entityVal j4)
+            )
+      listsEqualOn xs0 xs1 getNames
+      listsEqualOn xs0 xs2 getNames
+      listsEqualOn xs0 xs3 getNames
+
+    it "inner join on two entities" $ do
+      (xs0, xs1) <- run $ do
+        pid <- insert $ Person "hello" Nothing Nothing 3
+        _ <- insert $ BlogPost "good poast" pid
+        _ <- insert $ Profile "cool" pid
+        xs0 <- selectRethrowingQuery $
+          from $ \(p `InnerJoin` b `InnerJoin` pr) -> do
+          on $ p ^. PersonId ==. b ^. BlogPostAuthorId
+          on $ p ^. PersonId ==. pr ^. ProfilePerson
+          pure (p, b, pr)
+        xs1 <- selectRethrowingQuery $
+          from $ \(p `InnerJoin` b `InnerJoin` pr) -> do
+          on $ p ^. PersonId ==. pr ^. ProfilePerson
+          on $ p ^. PersonId ==. b ^. BlogPostAuthorId
+          pure (p, b, pr)
+        pure (xs0, xs1)
+      listsEqualOn xs0 xs1 $ \(Entity _ p, Entity _ b, Entity _ pr) ->
+        (personName p, blogPostTitle b, profileName pr)
+    it "inner join on three entities" $ do
+      res <- run $ do
+        pid <- insert $ Person "hello" Nothing Nothing 3
+        _ <- insert $ BlogPost "good poast" pid
+        _ <- insert $ BlogPost "good poast #2" pid
+        _ <- insert $ Profile "cool" pid
+        _ <- insert $ Reply pid "u wot m8"
+        _ <- insert $ Reply pid "how dare you"
+
+        bprr <- selectRethrowingQuery $
+          from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do
+          on $ p ^. PersonId ==. b ^. BlogPostAuthorId
+          on $ p ^. PersonId ==. pr ^. ProfilePerson
+          on $ p ^. PersonId ==. r ^. ReplyGuy
+          pure (p, b, pr, r)
+
+        brpr <- selectRethrowingQuery $
+          from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do
+          on $ p ^. PersonId ==. b ^. BlogPostAuthorId
+          on $ p ^. PersonId ==. r ^. ReplyGuy
+          on $ p ^. PersonId ==. pr ^. ProfilePerson
+          pure (p, b, pr, r)
+
+        prbr <- selectRethrowingQuery $
+          from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do
+          on $ p ^. PersonId ==. pr ^. ProfilePerson
+          on $ p ^. PersonId ==. b ^. BlogPostAuthorId
+          on $ p ^. PersonId ==. r ^. ReplyGuy
+          pure (p, b, pr, r)
+
+        prrb <- selectRethrowingQuery $
+          from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do
+          on $ p ^. PersonId ==. pr ^. ProfilePerson
+          on $ p ^. PersonId ==. r ^. ReplyGuy
+          on $ p ^. PersonId ==. b ^. BlogPostAuthorId
+          pure (p, b, pr, r)
+
+        rprb <- selectRethrowingQuery $
+          from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do
+          on $ p ^. PersonId ==. r ^. ReplyGuy
+          on $ p ^. PersonId ==. pr ^. ProfilePerson
+          on $ p ^. PersonId ==. b ^. BlogPostAuthorId
+          pure (p, b, pr, r)
+
+        rbpr <- selectRethrowingQuery $
+          from $ \(p `InnerJoin` b `InnerJoin` pr `InnerJoin` r) -> do
+          on $ p ^. PersonId ==. r ^. ReplyGuy
+          on $ p ^. PersonId ==. b ^. BlogPostAuthorId
+          on $ p ^. PersonId ==. pr ^. ProfilePerson
+          pure (p, b, pr, r)
+
+        pure [bprr, brpr, prbr, prrb, rprb, rbpr]
+      forM_ (zip res (drop 1 (cycle res))) $ \(a, b) -> a `shouldBe` b
+
+    it "many-to-many" $ do
+      ac <- run $ do
+        setup
+        select $
+          from $ \(a `InnerJoin` b `InnerJoin` c) -> do
+          on (a ^. JoinOneId ==. b ^. JoinManyJoinOne)
+          on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther)
+          pure (a, c)
+
+      ca <- run $ do
+        setup
+        select $
+          from $ \(a `InnerJoin` b `InnerJoin` c) -> do
+          on (c ^. JoinOtherId ==. b ^. JoinManyJoinOther)
+          on (a ^. JoinOneId ==. b ^. JoinManyJoinOne)
+          pure (a, c)
+
+      listsEqualOn ac ca $ \(Entity _ a, Entity _ b) ->
+        (joinOneName a, joinOtherName b)
+
+    it "left joins on order" $ do
+      ca <- run $ do
+        setup
+        select $
+          from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do
+          on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther)
+          on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne)
+          orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId]
+          pure (a, c)
+      ac <- run $ do
+        setup
+        select $
+          from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do
+          on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne)
+          on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther)
+          orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId]
+          pure (a, c)
+
+      listsEqualOn ac ca $ \(Entity _ a, b) ->
+        (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b)
+
+    it "doesn't require an on for a crossjoin" $ do
+      void $ run $
+        select $
+        from $ \(a `CrossJoin` b) -> do
+        pure (a :: SqlExpr (Entity JoinOne), b :: SqlExpr (Entity JoinTwo))
+
+    it "errors with an on for a crossjoin" $ do
+      (void $ run $
+        select $
+        from $ \(a `CrossJoin` b) -> do
+        on $ a ^. JoinOneId ==. b ^. JoinTwoJoinOne
+        pure (a, b))
+          `shouldThrow` \(OnClauseWithoutMatchingJoinException _) ->
+            True
+
+    it "left joins associativity" $ do
+      ca <- run $ do
+        setup
+        select $
+          from $ \(a `LeftOuterJoin` (b `InnerJoin` c)) -> do
+          on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther)
+          on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne)
+          orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId]
+          pure (a, c)
+      ca' <- run $ do
+        setup
+        select $
+          from $ \(a `LeftOuterJoin` b `InnerJoin` c) -> do
+          on (c ?. JoinOtherId ==. b ?. JoinManyJoinOther)
+          on (just (a ^. JoinOneId) ==. b ?. JoinManyJoinOne)
+          orderBy [asc $ a ^. JoinOneId, asc $ c ?. JoinOtherId]
+          pure (a, c)
+
+      listsEqualOn ca ca' $ \(Entity _ a, b) ->
+        (joinOneName a, maybe "NULL" (joinOtherName . entityVal) b)
+
+    it "composes queries still" $ do
+      let
+        query1 =
+          from $ \(foo `InnerJoin` bar) -> do
+          on (foo ^. FooId ==. bar ^. BarQuux)
+          pure (foo, bar)
+        query2 =
+          from $ \(p `LeftOuterJoin` bp) -> do
+          on (p ^. PersonId ==. bp ^. BlogPostAuthorId)
+          pure (p, bp)
+      (a, b) <- run $ do
+        fid <- insert $ Foo 5
+        _ <- insert $ Bar fid
+        pid <- insert $ Person "hey" Nothing Nothing 30
+        _ <- insert $ BlogPost "WHY" pid
+        a <- select ((,) <$> query1 <*> query2)
+        b <- select (flip (,) <$> query1 <*> query2)
+        pure (a, b)
+      listsEqualOn a (map (\(x, y) -> (y, x)) b) id
+
+
+
+listsEqualOn :: (Show a1, Eq a1) => [a2] -> [a2] -> (a2 -> a1) -> Expectation
+listsEqualOn a b f = map f a `shouldBe` map f b
 
 tests :: Run -> Spec
 tests run = do
@@ -1503,6 +2002,7 @@ tests run = do
     testCase run
     testCountingRows run
     testRenderSql run
+    testOnClauseOrder run
 
 
 insert' :: ( Functor m
@@ -1535,12 +2035,15 @@ cleanDB
   :: (forall m. RunDbMonad m
   => SqlPersistT (R.ResourceT m) ())
 cleanDB = do
-  delete $ from $ \(_ :: SqlExpr (Entity Foo))  -> return ()
   delete $ from $ \(_ :: SqlExpr (Entity Bar))  -> return ()
+  delete $ from $ \(_ :: SqlExpr (Entity Foo))  -> return ()
 
-  delete $ from $ \(_ :: SqlExpr (Entity BlogPost))   -> return ()
+  delete $ from $ \(_ :: SqlExpr (Entity Reply)) -> return ()
-  delete $ from $ \(_ :: SqlExpr (Entity Follow))     -> return ()
+  delete $ from $ \(_ :: SqlExpr (Entity Comment)) -> return ()
-  delete $ from $ \(_ :: SqlExpr (Entity Person))     -> return ()
+  delete $ from $ \(_ :: SqlExpr (Entity Profile)) -> return ()
+  delete $ from $ \(_ :: SqlExpr (Entity BlogPost)) -> return ()
+  delete $ from $ \(_ :: SqlExpr (Entity Follow)) -> return ()
+  delete $ from $ \(_ :: SqlExpr (Entity Person)) -> return ()
 
   delete $ from $ \(_ :: SqlExpr (Entity Deed)) -> return ()
   delete $ from $ \(_ :: SqlExpr (Entity Lord)) -> return ()
@@ -1557,10 +2060,26 @@ cleanDB = do
   delete $ from $ \(_ :: SqlExpr (Entity Point))      -> return ()
 
   delete $ from $ \(_ :: SqlExpr (Entity Numbers))    -> return ()
+  delete $ from $ \(_ :: SqlExpr (Entity JoinMany))    -> return ()
+  delete $ from $ \(_ :: SqlExpr (Entity JoinFour))    -> return ()
+  delete $ from $ \(_ :: SqlExpr (Entity JoinThree))    -> return ()
+  delete $ from $ \(_ :: SqlExpr (Entity JoinTwo))    -> return ()
+  delete $ from $ \(_ :: SqlExpr (Entity JoinOne))    -> return ()
+  delete $ from $ \(_ :: SqlExpr (Entity JoinOther))    -> return ()
 
 
 cleanUniques
   :: (forall m. RunDbMonad m
   => SqlPersistT (R.ResourceT m) ())
 cleanUniques =
-  delete $ from $ \(_ :: SqlExpr (Entity OneUnique))    -> return ()
+  delete $ from $ \(_ :: SqlExpr (Entity OneUnique))    -> return ()
+
+selectRethrowingQuery
+  :: (MonadIO m, EI.SqlSelect a r, MonadUnliftIO m)
+  => SqlQuery a
+  -> SqlPersistT m [r]
+selectRethrowingQuery query =
+  select query
+    `catch` \(SomeException e) -> do
+      (text, _) <- renderQuerySelect query
+      liftIO . throwIO . userError $ Text.unpack text <> "\n\n" <> show e

test/PostgreSQL/Test.hs

@@ -958,10 +958,10 @@ testInsertUniqueViolation =
       insert u3) `shouldThrow` (==) exception
   where
     exception = SqlError {
-      sqlState = "23505", 
+      sqlState = "23505",
-      sqlExecStatus = FatalError, 
+      sqlExecStatus = FatalError,
-      sqlErrorMsg = "duplicate key value violates unique constraint \"UniqueValue\"", 
+      sqlErrorMsg = "duplicate key value violates unique constraint \"UniqueValue\"",
-      sqlErrorDetail = "Key (value)=(0) already exists.", 
+      sqlErrorDetail = "Key (value)=(0) already exists.",
       sqlErrorHint = ""}
 
 testUpsert :: Spec