esqueleto 3.1.3 → 3.2.0

raw patch · 9 files changed

+1167/−105 lines, 9 filesdep +attoparsecdep +mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec, mtl

API changes (from Hackage documentation)

Files

• changelog.md +13/−1
• esqueleto.cabal +11/−2
• src/Database/Esqueleto.hs +7/−6
• src/Database/Esqueleto/Internal/ExprParser.hs +82/−0
• src/Database/Esqueleto/Internal/Internal.hs +333/−78
• src/Database/Esqueleto/Internal/Language.hs +6/−0
• src/Database/Esqueleto/Internal/Sql.hs +2/−0
• test/Common/Test.hs +709/−14
• test/PostgreSQL/Test.hs +4/−4

@@ -1,3 +1,15 @@+3.2.0+========++- @parsonsmatt+  - [#153](https://github.com/bitemyapp/esqueleto/pull/153): Deprecate+    `sub_select` and introduce `subSelect`, `subSelectMaybe`, and+    `subSelectUnsafe`.+- @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 +23,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.

@@ -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 @@       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 @@   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 @@   ghc-options: -Wall   build-depends:       base >=4.8 && <5.0+    , attoparsec     , blaze-html     , bytestring     , conduit >=1.3@@ -83,6 +87,7 @@     , exceptions     , hspec     , monad-logger+    , mtl     , mysql     , mysql-simple     , persistent >=2.8.0 && <2.11@@ -110,6 +115,7 @@   build-depends:       base >=4.8 && <5.0     , aeson+    , attoparsec     , blaze-html     , bytestring     , conduit >=1.3@@ -118,6 +124,7 @@     , exceptions     , hspec     , monad-logger+    , mtl     , persistent >=2.10.0 && <2.11     , persistent-postgresql >= 2.10.0 && <2.11     , persistent-template@@ -144,6 +151,7 @@   ghc-options: -Wall   build-depends:       base >=4.8 && <5.0+    , attoparsec     , blaze-html     , bytestring     , conduit >=1.3@@ -152,6 +160,7 @@     , exceptions     , hspec     , monad-logger+    , mtl     , persistent >=2.8.0 && <2.11     , persistent-sqlite     , persistent-template

@@ -53,6 +53,12 @@              , in_, notIn, exists, notExists              , set, (=.), (+=.), (-=.), (*=.), (/=.)              , case_, toBaseId+  , subSelect+  , subSelectMaybe+  , subSelectCount+  , subSelectForeign+  , subSelectList+  , subSelectUnsafe   , ToBaseId(..)   , when_   , then_@@ -327,15 +333,10 @@ -- @ -- '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:

@@ -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)

@@ -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 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 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 @@       let ed = entityDef (getVal x)       ident <- newIdentFor (entityDB ed)       let ret   = EEntity ident-          from_ = FromStart ident ed-      return (EPreprocessedFrom ret from_)+          f' = FromStart ident ed+      return (EPreprocessedFrom ret f')     getVal :: SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))) -> Proxy a     getVal = const Proxy @@ -94,7 +103,7 @@   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 (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-  W.tell mempty { sdFromClause = [from_] }+fromFinish (EPreprocessedFrom ret f') = Q $ do+  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@--- clause will be applied to the /last/ @JOIN@ that does not--- have an @ON@ clause yet.  If there are no @JOIN@s without--- @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.+-- | An @ON@ clause, useful to describe how two tables are related. Cross joins+-- and tuple-joins do not need an 'on' clause, but 'InnerJoin' and the various+-- outer joins do. ----- 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--- you're allowed to call 'on' only once (as in SQL).  If you--- have many joins, then the 'on's are applied on the /reverse/--- order that the @JOIN@s appear.  For example:+-- We need to specify the clause for joining the two columns together. If we had+-- this: -- -- @--- 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.--- For example, consider @query1@ and @query2@ below:+-- Old versions of esqueleto required that you provide the 'on' clauses in+-- 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 =---       'from' $ \\(foo `'InnerJoin`` bar) -> do---         'on' (foo '^.' FooId '==.' bar '^.' BarFooId)---     query2 =---       'from' $ \\(mbaz `'LeftOuterJoin`` quux) -> do---         return (mbaz '?.' BazName, quux)---     test1 =      (,) \<$\> query1 \<*\> query2---     test2 = flip (,) \<$\> query2 \<*\> query1+-- 'select' $+-- 'from' $ \\(foo `'InnerJoin`` bar `'InnerJoin`` baz) -> do+--   'on' (foo '^.' FooId '==.' bar '^.' BarFooId)+--   'on' (baz '^.' BazId '==.' bar '^.' BarBazId)+--   ... -- @------ 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] } @@ -339,12 +352,149 @@ locking :: LockingKind -> SqlQuery () locking kind = Q $ W.tell mempty { sdLockingClause = Monoid.Last (Just kind) } +{-#+  DEPRECATED+    sub_select+    "sub_select \n \+sub_select is an unsafe function to use. If used with a SqlQuery that \n \+returns 0 results, then it may return NULL despite not mentioning Maybe \n \+in the return type. If it returns more than 1 result, then it will throw a \n \+SQL error.\n\n Instead, consider using one of the following alternatives: \n \+- subSelect: attaches a LIMIT 1 and the Maybe return type, totally safe.  \n \+- subSelectMaybe: Attaches a LIMIT 1, useful for a query that already \n \+  has a Maybe in the return type. \n \+- subSelectCount: Performs a count of the query - this is always safe. \n \+- subSelectUnsafe: Performs no checks or guarantees. Safe to use with \n \+  countRows and friends."+  #-} -- | Execute a subquery @SELECT@ in an SqlExpression.  Returns a -- simple value so should be used only when the @SELECT@ query -- is guaranteed to return just one row.+--+-- Deprecated in 3.2.0. sub_select :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) sub_select         = sub SELECT +-- | Execute a subquery @SELECT@ in a 'SqlExpr'. The query passed to this+-- function will only return a single result - it has a @LIMIT 1@ passed in to+-- the query to make it safe, and the return type is 'Maybe' to indicate that+-- the subquery might result in 0 rows.+--+-- If you find yourself writing @'joinV' . 'subSelect'@, then consider using+-- 'subSelectMaybe'.+--+-- If you're performing a 'countRows', then you can use 'subSelectCount' which+-- is safe.+--+-- If you know that the subquery will always return exactly one row (eg+-- a foreign key constraint guarantees that you'll get exactly one row), then+-- consider 'subSelectUnsafe', along with a comment explaining why it is safe.+--+-- @since 3.2.0+subSelect+  :: PersistField a+  => SqlQuery (SqlExpr (Value a))+  -> SqlExpr (Value (Maybe a))+subSelect query = just (subSelectUnsafe (query <* limit 1))++-- | Execute a subquery @SELECT@ in a 'SqlExpr'. This function is a shorthand+-- for the common @'joinV' . 'subSelect'@ idiom, where you are calling+-- 'subSelect' on an expression that would be 'Maybe' already.+--+-- As an example, you would use this function when calling 'sum_' or 'max_',+-- which have 'Maybe' in the result type (for a 0 row query).+--+-- @since 3.2.0+subSelectMaybe+  :: PersistField a+  => SqlQuery (SqlExpr (Value (Maybe a)))+  -> SqlExpr (Value (Maybe a))+subSelectMaybe = joinV . subSelect++-- | Performs a @COUNT@ of the given query in a @subSelect@ manner. This is+-- always guaranteed to return a result value, and is completely safe.+--+-- @since 3.2.0+subSelectCount+  :: (Num a, PersistField a)+  => SqlQuery ignored+  -> SqlExpr (Value a)+subSelectCount query = do+  subSelectUnsafe $ do+    _ <- query+    pure countRows++-- | Execute a subquery @SELECT@ in a 'SqlExpr' that returns a list. This is an+-- alias for 'subList_select' and is provided for symmetry with the other safe+-- subselect functions.+--+-- @since 3.2.0+subSelectList+  :: PersistField a+  => SqlQuery (SqlExpr (Value a))+  -> SqlExpr (ValueList a)+subSelectList = subList_select++-- | Performs a sub-select using the given foreign key on the entity. This is+-- useful to extract values that are known to be present by the database schema.+--+-- As an example, consider the following persistent definition:+--+-- @+-- User+--   profile ProfileId+--+-- Profile+--   name    Text+-- @+--+-- The following query will return the name of the user.+--+-- @+-- getUserWithName =+--     'select' $+--     'from' $ \user ->+--     'pure' (user, 'subSelectForeign' user UserProfile (^. ProfileName)+-- @+--+-- @since 3.2.0+subSelectForeign+  ::+  ( BackendCompatible SqlBackend (PersistEntityBackend val1)+  , PersistEntity val1, PersistEntity val2, PersistField a+  )+  => SqlExpr (Entity val2)+  -- ^ An expression representing the table you have access to now.+  -> EntityField val2 (Key val1)+  -- ^ The foreign key field on the table.+  -> (SqlExpr (Entity val1) -> SqlExpr (Value a))+  -- ^ A function to extract a value from the foreign reference table.+  -> SqlExpr (Value a)+subSelectForeign expr foreignKey with =+  subSelectUnsafe $+  from $ \table -> do+  where_ $ expr ^. foreignKey ==. table ^. persistIdField+  pure (with table)++-- | Execute a subquery @SELECT@ in a 'SqlExpr'. This function is unsafe,+-- because it can throw runtime exceptions in two cases:+--+-- 1. If the query passed has 0 result rows, then it will return a @NULL@ value.+--    The @persistent@ parsing operations will fail on an unexpected @NULL@.+-- 2. If the query passed returns more than one row, then the SQL engine will+--    fail with an error like "More than one row returned by a subquery used as+--    an expression".+--+-- This function is safe if you guarantee that exactly one row will be returned,+-- or if the result already has a 'Maybe' type for some reason.+--+-- For variants with the safety encoded already, see 'subSelect' and+-- 'subSelectMaybe'. For the most common safe use of this, see 'subSelectCount'.+--+-- @since 3.2.0+subSelectUnsafe :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)+subSelectUnsafe = sub SELECT+ -- | Project a field of an entity. (^.)   :: forall typ val. (PersistEntity val, PersistField typ)@@ -1396,33 +1546,109 @@ -- | 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 = go []+collectOnClauses+  :: SqlBackend+  -> [FromClause]+  -> Either (SqlExpr (Value Bool)) [FromClause]+collectOnClauses sqlBackend = go Set.empty []   where-    go []  (f@(FromStart _ _):fs) = fmap (f:) (go [] fs) -- fast path-    go acc (OnClause expr    :fs) = findMatching acc expr >>= flip go fs-    go acc (f:fs)                 = go (f:acc) fs-    go acc []                     = return $ reverse acc+    go is []  (f@(FromStart i _) : fs) =+      fmap (f:) (go (Set.insert i is) [] fs) -- fast path+    go idents acc (OnClause expr : fs) = do+      (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 =-      case tryMatch expr f of-        Just f' -> return (f' : acc)-        Nothing -> (f:) <$> findMatching acc expr-    findMatching [] expr = Left expr+    findMatching+      :: Set Ident+      -> [FromClause]+      -> SqlExpr (Value Bool)+      -> 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) =-      matchR `mplus` matchC `mplus` matchL -- right to left-        where-          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+    findRightmostIdent (FromStart i _) = Just i+    findRightmostIdent (FromJoin _ _ r _) = findRightmostIdent r+    findRightmostIdent (OnClause {}) = Nothing +    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))                  | NoWhere@@ -1476,6 +1702,7 @@  -- | 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 +1716,18 @@ -- | 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-      s <- S.get-      let go (t:ts) | t `HS.member` inUse s = go ts-                    | otherwise             = use t-          go [] = throw (UnexpectedCaseErr NewIdentForError)-      go (possibilities orig)--    possibilities t = t : map addNum [2..]-      where-        addNum :: Int -> T.Text-        addNum = T.append t . T.pack . show--    use t = do-      S.modify (\s -> s { inUse = HS.insert t (inUse s) })-      return (I t)-+    findFree msuffix = do+      let+        withSuffix =+          maybe id (\suffix -> (<> T.pack (show suffix))) msuffix original+      isInUse <- S.gets (HS.member withSuffix . inUse)+      if isInUse+        then findFree (succ <$> (msuffix <|> Just (1 :: Int)))+        else do+          S.modify (\s -> s { inUse = HS.insert withSuffix (inUse s) })+          pure (I withSuffix)  -- | Information needed to escape and use identifiers. type IdentInfo = (SqlBackend, IdentState)@@ -1914,7 +2135,7 @@ --  @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 +2430,15 @@     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 +3157,33 @@ 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

@@ -56,6 +56,12 @@              , in_, notIn, exists, notExists              , set, (=.), (+=.), (-=.), (*=.), (/=.)              , case_, toBaseId, (<#), (<&>)+  , subSelect+  , subSelectMaybe+  , subSelectCount+  , subSelectList+  , subSelectForeign+  , subSelectUnsafe   ) where  import Database.Esqueleto.Internal.PersistentImport

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

@@ -1,7 +1,9 @@-{-# OPTIONS_GHC -fno-warn-unused-binds  #-}-{-# OPTIONS_GHC -fno-warn-deprecations  #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# LANGUAGE ConstraintKinds            , CPP+           , TypeApplications+           , PartialTypeSignatures            , UndecidableInstances            , EmptyDataDecls            , FlexibleContexts@@ -55,7 +57,9 @@     , 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 +73,8 @@ 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 +84,17 @@ 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 +106,18 @@     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 +177,36 @@   Numbers     int    Int     double Double+    deriving Eq Show++  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@@ -242,7 +289,180 @@         ret <- select $ return nothing         liftIO $ ret `shouldBe` [ Value (Nothing :: Maybe Int) ] +testSubSelect :: Run -> Spec+testSubSelect run = do+  let+    setup :: MonadIO m => SqlPersistT m ()+    setup = do+      _ <- insert $ Numbers 1 2+      _ <- insert $ Numbers 2 4+      _ <- insert $ Numbers 3 5+      _ <- insert $ Numbers 6 7+      pure ()+  describe "subSelect" $ do+    it "is safe for queries that may return multiple results" $ do+      let+        query =+          from $ \n -> do+          orderBy [asc (n ^. NumbersInt)]+          pure (n ^. NumbersInt)+      res <- run $ do+        setup+        select $ pure $ subSelect query+      res `shouldBe` [Value (Just 1)] +      eres <- try $ run $ do+        setup+        select $ pure $ sub_select query+      case eres of+        Left (SomeException _) ->+          -- We should receive an exception, but the different database+          -- libraries throw different exceptions. Hooray.+          pure ()+        Right v ->+          -- This shouldn't happen, but in sqlite land, many things are+          -- possible.+          v `shouldBe` [Value 1]++    it "is safe for queries that may not return anything" $ do+      let+        query =+          from $ \n -> do+          orderBy [asc (n ^. NumbersInt)]+          limit 1+          pure (n ^. NumbersInt)+      res <- run $ select $ pure $ subSelect query+      res `shouldBe` [Value Nothing]++      eres <- try $ run $ do+        setup+        select $ pure $ sub_select query++      case eres of+        Left (_ :: PersistException) ->+          -- We expect to receive this exception. However, sqlite evidently has+          -- no problems with it, so we can't *require* that the exception is+          -- thrown. Sigh.+          pure ()+        Right v ->+          -- This shouldn't happen, but in sqlite land, many things are+          -- possible.+          v `shouldBe` [Value 1]++  describe "subSelectList" $ do+    it "is safe on empty databases as well as good databases" $ do+      let+        query =+          from $ \n -> do+          where_ $ n ^. NumbersInt `in_` do+            subSelectList $+              from $ \n' -> do+              where_ $ n' ^. NumbersInt >=. val 3+              pure (n' ^. NumbersInt)+          pure n++      empty <- run $ do+        select query++      full <- run $ do+        setup+        select query++      empty `shouldBe` []+      full `shouldSatisfy` (not . null)++  describe "subSelectMaybe" $ do+    it "is equivalent to joinV . subSelect" $ do+      let+        query+          :: ( SqlQuery (SqlExpr (Value (Maybe Int)))+            -> SqlExpr (Value (Maybe Int))+            )+          -> SqlQuery (SqlExpr (Value (Maybe Int)))+        query selector =+          from $ \n -> do+          pure $+            selector $+            from $ \n' -> do+            where_ $ n' ^. NumbersDouble >=. n ^. NumbersDouble+            pure (max_ (n' ^. NumbersInt))++      a <- run $ do+        setup+        select (query subSelectMaybe)+      b <- run $ do+        setup+        select (query (joinV . subSelect))+      a `shouldBe` b++  describe "subSelectCount" $ do+    it "is a safe way to do a countRows" $ do+      xs0 <- run $ do+        setup+        select $+          from $ \n -> do+          pure $ (,) n $+            subSelectCount @Int $+            from $ \n' -> do+            where_ $ n' ^. NumbersInt >=. n ^. NumbersInt++      xs1 <- run $ do+        setup+        select $+          from $ \n -> do+          pure $ (,) n $+            subSelectUnsafe $+            from $ \n' -> do+            where_ $ n' ^. NumbersInt >=. n ^. NumbersInt+            pure (countRows :: SqlExpr (Value Int))++      let getter (Entity _ a, b) = (a, b)+      map getter xs0 `shouldBe` map getter xs1++  describe "subSelectUnsafe" $ do+    it "throws exceptions on multiple results" $ do+      eres <- try $ run $ do+        setup+        bad <- select $+          from $ \n -> do+          pure $ (,) (n ^. NumbersInt) $+            subSelectUnsafe $+            from $ \n' -> do+            pure (just (n' ^. NumbersDouble))+        good <- select $+          from $ \n -> do+          pure $ (,) (n ^. NumbersInt) $+            subSelect $+            from $ \n' -> do+            pure (n' ^. NumbersDouble)+        pure (bad, good)+      case eres of+        Left (SomeException _) ->+          -- Must use SomeException because the database libraries throw their+          -- own errors.+          pure ()+        Right (bad, good) -> do+          -- SQLite just takes the first element of the sub-select. lol.+          --+          bad `shouldBe` good++    it "throws exceptions on null results" $ do+      eres <- try $ run $ do+        setup+        select $+          from $ \n -> do+          pure $ (,) (n ^. NumbersInt) $+            subSelectUnsafe $+            from $ \n' -> do+            where_ $ val False+            pure (n' ^. NumbersDouble)+      case eres of+        Left (_ :: PersistException) ->+          pure ()+        Right xs ->+          xs `shouldBe` []++ testSelectSource :: Run -> Spec testSelectSource run = do   describe "selectSource" $ do@@ -317,6 +537,7 @@                                                     , (p2e, p1e)                                                     , (p2e, p2e) ] +     it "works for a self-join via sub_select" $       run $ do         p1k <- insert p1@@ -447,7 +668,7 @@  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 +825,9 @@               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 +1047,17 @@                                 , (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 +1691,7 @@           liftIO $ (n :: Int) `shouldBe` expected  testRenderSql :: Run -> Spec-testRenderSql run =+testRenderSql run = do   describe "testRenderSql" $ do     it "works" $ do       (queryText, queryVals) <- run $ renderQuerySelect $@@ -1481,12 +1711,457 @@         `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   describe "Tests that are common to all backends" $ do     testSelect run+    testSubSelect run     testSelectSource run     testSelectFrom run     testSelectJoin run@@ -1503,6 +2178,7 @@     testCase run     testCountingRows run     testRenderSql run+    testOnClauseOrder run   insert' :: ( Functor m@@ -1535,12 +2211,15 @@   :: (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 Follow))     -> return ()-  delete $ from $ \(_ :: SqlExpr (Entity Person))     -> return ()+  delete $ from $ \(_ :: SqlExpr (Entity Reply)) -> return ()+  delete $ from $ \(_ :: SqlExpr (Entity Comment)) -> 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,6 +2236,12 @@   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@@ -1564,3 +2249,13 @@   => SqlPersistT (R.ResourceT m) ()) cleanUniques =   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

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