diff --git a/changelog.md b/changelog.md index 6d7e415..635115b 100644 --- a/changelog.md +++ b/changelog.md @@ -1,9 +1,20 @@ -3.3.4.1 +3.4.0.0 +======= +- @belevy, @charukiewicz + - [#215](https://github.com/bitemyapp/esqueleto/pull/215) + - Added support for common table expressions (`with`, `withRecursive`) + - Added support for lateral JOINs with updated example (Example #6) + - Deprecated `SelectQuery`, removing the neccessity to tag `SqlQuery` values + - Deprecated use of data constructors for SQL set operations (replaced with functions) + - Refactored module structure to fix haddock build (fixes build from `3.3.4.0`) +3.3.4.1 +======= - @maxgabriel - [#214](https://github.com/bitemyapp/esqueleto/pull/214) - Add suggested hlint rules for proper `isNothing` usage + 3.3.4.0 ======= - @parsonsmatt diff --git a/esqueleto.cabal b/esqueleto.cabal index 4ebfa8e..4d52edb 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.3.4.1 +version: 3.4.0.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. . @@ -96,7 +96,7 @@ test-suite mysql , resourcet >=1.2 , tagged >=0.2 , text >=0.11 && <1.3 - , time + , time , transformers >=0.2 , unliftio , unordered-containers >=0.2 @@ -133,7 +133,7 @@ test-suite postgresql , resourcet >=1.2 , tagged >=0.2 , text >=0.11 && <1.3 - , time + , time , transformers >=0.2 , unliftio , unordered-containers >=0.2 @@ -167,7 +167,7 @@ test-suite sqlite , resourcet >=1.2 , tagged >=0.2 , text >=0.11 && <1.3 - , time + , time , transformers >=0.2 , unliftio , unordered-containers >=0.2 diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index eda4272..cd92302 100644 --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -410,66 +410,3 @@ import qualified Database.Persist -- -- In order to use these functions, you need to explicitly import -- their corresponding modules, they're not re-exported here. - - ----------------------------------------------------------------------- - - --- | @valkey i = 'val' . 'toSqlKey'@ --- (). -valkey :: (ToBackendKey SqlBackend entity, PersistField (Key entity)) => - Int64 -> SqlExpr (Value (Key entity)) -valkey = val . toSqlKey - - --- | @valJ@ is like @val@ but for something that is already a @Value@. The use --- case it was written for was, given a @Value@ lift the @Key@ for that @Value@ --- into the query expression in a type safe way. However, the implementation is --- more generic than that so we call it @valJ@. --- --- Its important to note that the input entity and the output entity are --- constrained to be the same by the type signature on the function --- (). --- --- /Since: 1.4.2/ -valJ :: (PersistField (Key entity)) => - Value (Key entity) -> SqlExpr (Value (Key entity)) -valJ = val . unValue - - ----------------------------------------------------------------------- - - --- | Synonym for 'Database.Persist.Store.delete' that does not --- clash with @esqueleto@'s 'delete'. -deleteKey :: ( PersistStore backend - , BaseBackend backend ~ PersistEntityBackend val - , MonadIO m - , PersistEntity val ) - => Key val -> ReaderT backend m () -deleteKey = Database.Persist.delete - --- | Avoid N+1 queries and join entities into a map structure --- @ --- getFoosAndNestedBarsFromParent :: ParentId -> (Map (Key Foo) (Foo, [Maybe (Entity Bar)])) --- getFoosAndNestedBarsFromParent parentId = 'fmap' associateJoin $ 'select' $ --- 'from' $ \\(foo `'LeftOuterJoin`` bar) -> do --- 'on' (bar '?.' BarFooId '==.' foo '^.' FooId) --- 'where_' (foo '^.' FooParentId '==.' 'val' parentId) --- 'pure' (foo, bar) --- @ --- --- @since 3.1.2 -associateJoin - :: forall e1 e0 - . Ord (Key e0) - => [(Entity e0, e1)] - -> Map.Map (Key e0) (e0, [e1]) -associateJoin = foldr f start - where - start = Map.empty - f (one, many) = - Map.insertWith - (\(oneOld, manyOld) (_, manyNew) -> (oneOld, manyNew ++ manyOld )) - (entityKey one) - (entityVal one, [many]) diff --git a/src/Database/Esqueleto/Experimental.hs b/src/Database/Esqueleto/Experimental.hs index b7fe293..f7b8fb9 100644 --- a/src/Database/Esqueleto/Experimental.hs +++ b/src/Database/Esqueleto/Experimental.hs @@ -30,12 +30,27 @@ module Database.Esqueleto.Experimental -- * Documentation - SqlSetOperation(Union, UnionAll, Except, Intersect) - , pattern SelectQuery - , From(..) + From(..) , on , from , (:&)(..) + + -- ** Set Operations + -- $sql-set-operations + , union_ + , Union(..) + , unionAll_ + , UnionAll(..) + , except_ + , Except(..) + , intersect_ + , Intersect(..) + , pattern SelectQuery + + -- ** Common Table Expressions + , with + , withRecursive + -- * Internals , ToFrom(..) , ToFromT @@ -46,11 +61,82 @@ module Database.Esqueleto.Experimental , ToAliasReference(..) , ToAliasReferenceT -- * The Normal Stuff - , module Database.Esqueleto - ) + , where_, groupBy, orderBy, rand, asc, desc, limit, offset + , distinct, distinctOn, don, distinctOnOrderBy, having, locking + , sub_select, (^.), (?.) + , val, isNothing, just, nothing, joinV, withNonNull + , countRows, count, countDistinct + , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) + , between, (+.), (-.), (/.), (*.) + , random_, round_, ceiling_, floor_ + , min_, max_, sum_, avg_, castNum, castNumM + , coalesce, coalesceDefault + , lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_ + , like, ilike, (%), concat_, (++.), castString + , subList_select, valList, justList + , in_, notIn, exists, notExists + , set, (=.), (+=.), (-=.), (*=.), (/=.) + , case_, toBaseId + , subSelect + , subSelectMaybe + , subSelectCount + , subSelectForeign + , subSelectList + , subSelectUnsafe + , ToBaseId(..) + , when_ + , then_ + , else_ + , Value(..) + , ValueList(..) + , OrderBy + , DistinctOn + , LockingKind(..) + , SqlString + -- ** Joins + , InnerJoin(..) + , CrossJoin(..) + , LeftOuterJoin(..) + , RightOuterJoin(..) + , FullOuterJoin(..) + , JoinKind(..) + , OnClauseWithoutMatchingJoinException(..) + -- * SQL backend + , SqlQuery + , SqlExpr + , SqlEntity + , select + , selectSource + , delete + , deleteCount + , update + , updateCount + , insertSelect + , insertSelectCount + , (<#) + , (<&>) + -- ** Rendering Queries + , renderQueryToText + , renderQuerySelect + , renderQueryUpdate + , renderQueryDelete + , renderQueryInsertInto + -- * Internal.Language + -- * RDBMS-specific modules + -- $rdbmsSpecificModules + + -- * Helpers + , valkey + , valJ + , associateJoin + + -- * Re-exports + -- $reexports + , deleteKey + , module Database.Esqueleto.Internal.PersistentImport + ) where -import Database.Esqueleto hiding (from, on, From(..)) import qualified Control.Monad.Trans.Writer as W import qualified Control.Monad.Trans.State as S import Control.Monad.Trans.Class (lift) @@ -58,32 +144,12 @@ import Control.Monad.Trans.Class (lift) import Data.Semigroup #endif import Data.Proxy (Proxy(..)) +import qualified Data.Text.Lazy.Builder as TLB import Database.Esqueleto.Internal.PersistentImport -import Database.Esqueleto.Internal.Internal - ( SqlExpr(..) - , InnerJoin(..) - , CrossJoin(..) - , LeftOuterJoin(..) - , RightOuterJoin(..) - , FullOuterJoin(..) - , FromClause(..) - , SqlQuery(..) - , SideData(..) - , Value(..) - , JoinKind(..) - , newIdentFor - , SqlSelect(..) - , Mode(..) - , toRawSql - , Ident(..) - , to3, to4, to5, to6, to7, to8 - , from3, from4, from5, from6, from7, from8 - , veryUnsafeCoerceSqlExprValue - , parensM - , NeedParens(..) - ) +import Database.Esqueleto.Internal.Internal hiding (from, on, From) import GHC.TypeLits + -- $setup -- -- If you're already using "Database.Esqueleto", then you can get @@ -95,9 +161,11 @@ import GHC.TypeLits -- -- ... -- --- import Database.Esqueleto hiding (on, from) -- import Database.Esqueleto.Experimental -- @ +-- +-- Note: Prior to @esqueleto-3.3.4.0@, the @Database.Esqueleto.Experimental@ +-- module did not reexport @Data.Esqueleto@. ---------------------------------------------------------------------- @@ -272,7 +340,7 @@ import GHC.TypeLits -- @ -- select $ do -- peopleWithPosts <- --- from $ SelectQuery $ do +-- from $ do -- (people :& blogPosts) <- -- from $ Table \@Person -- \`InnerJoin\` Table \@BlogPost @@ -303,7 +371,7 @@ import GHC.TypeLits -- @ -- select $ do -- (authors, blogPosts) <- from $ --- (SelectQuery $ do +-- (do -- (author :& blogPost) <- -- from $ Table \@Person -- \`InnerJoin\` Table \@BlogPost @@ -312,8 +380,8 @@ import GHC.TypeLits -- where_ (author ^. PersonId ==. val currentPersonId) -- pure (author, blogPost) -- ) --- \`Union\` --- (SelectQuery $ do +-- \`union_\` +-- (do -- (follow :& blogPost :& author) <- -- from $ Table \@Follow -- \`InnerJoin\` Table \@BlogPost @@ -329,6 +397,56 @@ import GHC.TypeLits -- limit 25 -- pure (authors, blogPosts) -- @ +-- +-- === Example 6: LATERAL JOIN +-- +-- As of version @3.4.0.0@, lateral subquery joins are supported. +-- +-- +-- @ +-- select $ do +-- (salesPerson :& maxSaleAmount :& maxSaleCustomerName) <- +-- from $ Table \@SalesPerson +-- \`CrossJoin\` (\\salesPerson -> do +-- sales <- from $ Table \@Sale +-- where_ $ sales ^. SaleSalesPersonId ==. salesPerson ^. SalesPersonId +-- pure $ max_ (sales ^. SaleAmount) +-- ) +-- \`CrossJoin\` (\\(salesPerson :& maxSaleAmount) -> do +-- sales <- from $ Table \@Sale +-- where_ $ sales ^. SaleSalesPersonId ==. salesPerson ^. SalesPersonId +-- &&. sales ^. SaleAmount ==. maxSaleAmount +-- pure $ sales ^. SaleCustomerName) +-- ) +-- pure (salesPerson ^. SalesPersonName, maxSaleAmount, maxSaleCustomerName) +-- @ +-- +-- This is the equivalent to the following SQL (example taken from the +-- [MySQL Lateral Derived Table](https://dev.mysql.com/doc/refman/8.0/en/lateral-derived-tables.html) +-- documentation): +-- +-- @ +-- SELECT +-- salesperson.name, +-- max_sale.amount, +-- max_sale_customer.customer_name +-- FROM +-- salesperson, +-- -- calculate maximum size, cache it in transient derived table max_sale +-- LATERAL +-- (SELECT MAX(amount) AS amount +-- FROM all_sales +-- WHERE all_sales.salesperson_id = salesperson.id) +-- AS max_sale, +-- LATERAL +-- (SELECT customer_name +-- FROM all_sales +-- WHERE all_sales.salesperson_id = salesperson.id +-- AND all_sales.amount = +-- -- the cached maximum size +-- max_sale.amount) +-- AS max_sale_customer; +-- @ -- | A left-precedence pair. Pronounced \"and\". Used to represent expressions -- that have been joined together. @@ -344,59 +462,110 @@ import GHC.TypeLits data (:&) a b = a :& b infixl 2 :& --- | Data type that represents SQL set operations. This includes --- 'UNION', 'UNION' 'ALL', 'EXCEPT', and 'INTERSECT'. This data --- type is defined as a binary tree, with @SelectQuery@ on the leaves. +data SqlSetOperation a = + SqlSetUnion (SqlSetOperation a) (SqlSetOperation a) + | SqlSetUnionAll (SqlSetOperation a) (SqlSetOperation a) + | SqlSetExcept (SqlSetOperation a) (SqlSetOperation a) + | SqlSetIntersect (SqlSetOperation a) (SqlSetOperation a) + | SelectQueryP NeedParens (SqlQuery a) + + +-- $sql-set-operations -- --- Each constructor corresponding to the aforementioned set operations --- can be used as an infix function in a @from@ to help with readability +-- Data type that represents SQL set operations. This includes +-- 'UNION', 'UNION' 'ALL', 'EXCEPT', and 'INTERSECT'. These types form +-- a binary tree, with @SqlQuery@ values on the leaves. +-- +-- Each function corresponding to the aforementioned set operations +-- can be used as an infix in a @from@ to help with readability -- and lead to code that closely resembles the underlying SQL. For example, -- -- @ -- select $ from $ --- (SelectQuery ...) --- \`Union\` --- (SelectQuery ...) +-- (do +-- a <- from Table @A +-- pure $ a ^. ASomeCol +-- ) +-- \`union_\` +-- (do +-- b <- from Table @B +-- pure $ b ^. BSomeCol +-- ) -- @ -- -- is translated into -- -- @ -- SELECT * FROM ( --- (SELECT * FROM ...) +-- (SELECT a.some_col FROM a) -- UNION --- (SELECT * FROM ...) +-- (SELECT b.some_col FROM b) -- ) -- @ -- --- @SelectQuery@ can be used without any of the set operations to construct --- a subquery. This can be used in 'JOIN' trees. For example, --- --- @ --- select $ from $ --- Table \@SomeTable --- \`InnerJoin\` (SelectQuery ...) --- \`on\` ... --- @ --- --- is translated into --- --- @ --- SELECT * --- FROM SomeTable --- INNER JOIN (SELECT * FROM ...) --- ON ... --- @ -data SqlSetOperation a = - Union (SqlSetOperation a) (SqlSetOperation a) - | UnionAll (SqlSetOperation a) (SqlSetOperation a) - | Except (SqlSetOperation a) (SqlSetOperation a) - | Intersect (SqlSetOperation a) (SqlSetOperation a) - | SelectQueryP NeedParens (SqlQuery a) +{-# DEPRECATED Union "/Since: 3.4.0.0/ - \ + Use the 'union_' function instead of the 'Union' data constructor" #-} +data Union a b = a `Union` b + +-- | @UNION@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. +union_ :: a -> b -> Union a b +union_ = Union + +{-# DEPRECATED UnionAll "/Since: 3.4.0.0/ - \ + Use the 'unionAll_' function instead of the 'UnionAll' data constructor" #-} +data UnionAll a b = a `UnionAll` b + +-- | @UNION@ @ALL@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. +unionAll_ :: a -> b -> UnionAll a b +unionAll_ = UnionAll + +{-# DEPRECATED Except "/Since: 3.4.0.0/ - \ + Use the 'except_' function instead of the 'Except' data constructor" #-} +data Except a b = a `Except` b + +-- | @EXCEPT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. +except_ :: a -> b -> Except a b +except_ = Except + +{-# DEPRECATED Intersect "/Since: 3.4.0.0/ - \ + Use the 'intersect_' function instead of the 'Intersect' data constructor" #-} +data Intersect a b = a `Intersect` b + +-- | @INTERSECT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. +intersect_ :: a -> b -> Intersect a b +intersect_ = Intersect + +class SetOperationT a ~ b => ToSetOperation a b | a -> b where + toSetOperation :: a -> SqlSetOperation b + +instance ToSetOperation (SqlSetOperation a) a where + toSetOperation = id +instance ToSetOperation (SqlQuery a) a where + toSetOperation = SelectQueryP Never +instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Union a b) c where + toSetOperation (Union a b) = SqlSetUnion (toSetOperation a) (toSetOperation b) +instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (UnionAll a b) c where + toSetOperation (UnionAll a b) = SqlSetUnionAll (toSetOperation a) (toSetOperation b) +instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Except a b) c where + toSetOperation (Except a b) = SqlSetExcept (toSetOperation a) (toSetOperation b) +instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Intersect a b) c where + toSetOperation (Intersect a b) = SqlSetIntersect (toSetOperation a) (toSetOperation b) + +type family SetOperationT a where + SetOperationT (Union a b) = SetOperationT a + SetOperationT (UnionAll a b) = SetOperationT a + SetOperationT (Except a b) = SetOperationT a + SetOperationT (Intersect a b) = SetOperationT a + SetOperationT (SqlQuery a) = a + SetOperationT (SqlSetOperation a) = a + +{-# DEPRECATED SelectQuery "/Since: 3.4.0.0/ - \ + It is no longer necessary to tag 'SqlQuery' values with @SelectQuery@" #-} pattern SelectQuery :: SqlQuery a -> SqlSetOperation a pattern SelectQuery q = SelectQueryP Never q + -- | Data type that represents the syntax of a 'JOIN' tree. In practice, -- only the @Table@ constructor is used directly when writing queries. For example, -- @@ -404,31 +573,101 @@ pattern SelectQuery q = SelectQueryP Never q -- select $ from $ Table \@People -- @ data From a where - Table :: PersistEntity ent => From (SqlExpr (Entity ent)) - SubQuery :: (SqlSelect a' r, SqlSelect a'' r', ToAlias a, a' ~ ToAliasT a, ToAliasReference a', ToAliasReferenceT a' ~ a'') - => SqlQuery a - -> From a'' - SqlSetOperation :: (SqlSelect a' r, ToAlias a, a' ~ ToAliasT a, ToAliasReference a', ToAliasReferenceT a' ~ a'') - => SqlSetOperation a - -> From a'' - InnerJoinFrom :: From a - -> (From b, (a :& b) -> SqlExpr (Value Bool)) - -> From (a :& b) - CrossJoinFrom :: From a - -> From b - -> From (a :& b) - LeftJoinFrom :: ToMaybe b - => From a - -> (From b, (a :& ToMaybeT b) -> SqlExpr (Value Bool)) - -> From (a :& ToMaybeT b) - RightJoinFrom :: ToMaybe a - => From a - -> (From b, (ToMaybeT a :& b) -> SqlExpr (Value Bool)) - -> From (ToMaybeT a :& b) - FullJoinFrom :: (ToMaybe a, ToMaybe b ) - => From a - -> (From b, (ToMaybeT a :& ToMaybeT b) -> SqlExpr (Value Bool)) - -> From (ToMaybeT a :& ToMaybeT b) + Table + :: PersistEntity ent + => From (SqlExpr (Entity ent)) + SubQuery + :: ( SqlSelect a' r + , SqlSelect a'' r' + , ToAlias a + , a' ~ ToAliasT a + , ToAliasReference a' + , ToAliasReferenceT a' ~ a'' + ) + => SqlQuery a + -> From a'' + FromCte + :: Ident + -> a + -> From a + SqlSetOperation + :: ( SqlSelect a' r + , ToAlias a + , a' ~ ToAliasT a + , ToAliasReference a' + , ToAliasReferenceT a' ~ a'' + ) + => SqlSetOperation a + -> From a'' + InnerJoinFrom + :: From a + -> (From b, (a :& b) -> SqlExpr (Value Bool)) + -> From (a :& b) + InnerJoinFromLateral + :: ( SqlSelect b' r + , SqlSelect b'' r' + , ToAlias b + , b' ~ ToAliasT b + , ToAliasReference b' + , ToAliasReferenceT b' ~ b'' + ) + => From a + -> ((a -> SqlQuery b), (a :& b'') -> SqlExpr (Value Bool)) + -> From (a :& b'') + CrossJoinFrom + :: From a + -> From b + -> From (a :& b) + CrossJoinFromLateral + :: ( SqlSelect b' r + , SqlSelect b'' r' + , ToAlias b + , b' ~ ToAliasT b + , ToAliasReference b' + , ToAliasReferenceT b' ~ b'' + ) + => From a + -> (a -> SqlQuery b) + -> From (a :& b'') + LeftJoinFrom + :: ToMaybe b + => From a + -> (From b, (a :& ToMaybeT b) -> SqlExpr (Value Bool)) + -> From (a :& ToMaybeT b) + LeftJoinFromLateral + :: ( SqlSelect b' r + , SqlSelect b'' r' + , ToAlias b + , b' ~ ToAliasT b + , ToAliasReference b' + , ToAliasReferenceT b' ~ b'' + , ToMaybe b'' + ) + => From a + -> ((a -> SqlQuery b), (a :& ToMaybeT b'') -> SqlExpr (Value Bool)) + -> From (a :& ToMaybeT b'') + RightJoinFrom + :: ToMaybe a + => From a + -> (From b, (ToMaybeT a :& b) -> SqlExpr (Value Bool)) + -> From (ToMaybeT a :& b) + FullJoinFrom + :: (ToMaybe a, ToMaybe b ) + => From a + -> (From b, (ToMaybeT a :& ToMaybeT b) -> SqlExpr (Value Bool)) + -> From (ToMaybeT a :& ToMaybeT b) + +-- | Constraint for `on`. Ensures that only types that require an `on` can be used on +-- the left hand side. This was previously reusing the ToFrom class which was actually +-- a bit too lenient as it allowed to much. Expanding this class should not be needed. +-- +-- @since 3.4.0.0 +class ValidOnClauseValue a where +instance ValidOnClauseValue (From a) where +instance ValidOnClauseValue (SqlQuery a) where +instance ValidOnClauseValue (SqlSetOperation a) where +instance ValidOnClauseValue (a -> SqlQuery b) where +instance {-# OVERLAPPABLE #-} (TypeError ('Text "Illegal use of ON")) => ValidOnClauseValue a where -- | An @ON@ clause that describes how two tables are related. This should be -- used as an infix operator after a 'JOIN'. For example, @@ -440,8 +679,7 @@ data From a where -- \`on\` (\\(p :& bP) -> -- p ^. PersonId ==. bP ^. BlogPostAuthorId) -- @ --- -on :: ToFrom a => a -> (b -> SqlExpr (Value Bool)) -> (a, b -> SqlExpr (Value Bool)) +on :: ValidOnClauseValue a => a -> (b -> SqlExpr (Value Bool)) -> (a, b -> SqlExpr (Value Bool)) on = (,) infix 9 `on` @@ -449,17 +687,34 @@ type JoinErrorMsg jk = 'Text "Missing on statement for " ':<>: 'Text jk type family ToFromT a where ToFromT (From a) = a + ToFromT (SqlQuery a) = ToAliasReferenceT (ToAliasT a) + ToFromT (Union a b) = ToAliasReferenceT (ToAliasT (SetOperationT a)) + ToFromT (UnionAll a b) = ToAliasReferenceT (ToAliasT (SetOperationT a)) + ToFromT (Except a b) = ToAliasReferenceT (ToAliasT (SetOperationT a)) + ToFromT (Intersect a b) = ToAliasReferenceT (ToAliasT (SetOperationT a)) ToFromT (SqlSetOperation a) = ToAliasReferenceT (ToAliasT a) - ToFromT (LeftOuterJoin a (b, c -> SqlExpr (Value Bool))) = c - ToFromT (FullOuterJoin a (b, c -> SqlExpr (Value Bool))) = c - ToFromT (RightOuterJoin a (b, c -> SqlExpr (Value Bool))) = c ToFromT (InnerJoin a (b, c -> SqlExpr (Value Bool))) = c - ToFromT (CrossJoin a b) = (ToFromT a :& ToFromT b) + ToFromT (LeftOuterJoin a (b, c -> SqlExpr (Value Bool))) = c + ToFromT (RightOuterJoin a (b, c -> SqlExpr (Value Bool))) = c + ToFromT (FullOuterJoin a (b, c -> SqlExpr (Value Bool))) = c + ToFromT (CrossJoin a (c -> SqlQuery b)) = ToFromT a :& ToAliasReferenceT (ToAliasT b) + ToFromT (CrossJoin a b) = ToFromT a :& ToFromT b ToFromT (InnerJoin a b) = TypeError (JoinErrorMsg "InnerJoin") ToFromT (LeftOuterJoin a b) = TypeError (JoinErrorMsg "LeftOuterJoin") ToFromT (RightOuterJoin a b) = TypeError (JoinErrorMsg "RightOuterJoin") ToFromT (FullOuterJoin a b) = TypeError (JoinErrorMsg "FullOuterJoin") +data Lateral +data NotLateral + +type family IsLateral a where + IsLateral (a -> SqlQuery b) = Lateral + IsLateral a = NotLateral + +class ErrorOnLateral a where +instance (TypeError ('Text "LATERAL can only be used for INNER, LEFT, and CROSS join kinds.")) => ErrorOnLateral (a -> SqlQuery b) where +instance {-# OVERLAPPABLE #-} ErrorOnLateral a where + {-- Type class magic to allow the use of the `InnerJoin` family of data constructors in from --} class ToFrom a where toFrom :: a -> From (ToFromT a) @@ -476,29 +731,146 @@ instance {-# OVERLAPPABLE #-} ToFrom (RightOuterJoin a b) where instance {-# OVERLAPPABLE #-} ToFrom (FullOuterJoin a b) where toFrom = undefined +instance ( ToAlias a + , a' ~ ToAliasT a + , ToAliasReference a' + , a'' ~ ToAliasReferenceT a' + , SqlSelect a' r' + , SqlSelect a'' r' + ) => ToFrom (SqlQuery a) where + toFrom = SubQuery + +instance ( SqlSelect c' r + , SqlSelect c'' r' + , ToAlias c + , c' ~ ToAliasT c + , ToAliasReference c' + , ToAliasReferenceT c' ~ c'' + , ToSetOperation a c + , ToSetOperation b c + , c ~ SetOperationT a + ) => ToFrom (Union a b) where + toFrom u = SqlSetOperation $ toSetOperation u + +instance ( SqlSelect c' r + , SqlSelect c'' r' + , ToAlias c + , c' ~ ToAliasT c + , ToAliasReference c' + , ToAliasReferenceT c' ~ c'' + , ToSetOperation a c + , ToSetOperation b c + , c ~ SetOperationT a + ) => ToFrom (UnionAll a b) where + toFrom u = SqlSetOperation $ toSetOperation u + instance (SqlSelect a' r,SqlSelect a'' r', ToAlias a, a' ~ ToAliasT a, ToAliasReference a', ToAliasReferenceT a' ~ a'') => ToFrom (SqlSetOperation a) where -- If someone uses just a plain SelectQuery it should behave like a normal subquery toFrom (SelectQueryP _ q) = SubQuery q -- Otherwise use the SqlSetOperation toFrom q = SqlSetOperation q -instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b', ToMaybe b', mb ~ ToMaybeT b') - => ToFrom (LeftOuterJoin a (b, (a' :& mb) -> SqlExpr (Value Bool))) where - toFrom (LeftOuterJoin lhs (rhs, on')) = LeftJoinFrom (toFrom lhs) (toFrom rhs, on') +class ToInnerJoin lateral lhs rhs res where + toInnerJoin :: Proxy lateral -> lhs -> rhs -> (res -> SqlExpr (Value Bool)) -> From res -instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b', ToMaybe a', ma ~ ToMaybeT a', ToMaybe b', mb ~ ToMaybeT b') - => ToFrom (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) where +instance ( SqlSelect bAlias r + , SqlSelect bAliasRef r' + , ToAlias b + , bAlias ~ ToAliasT b + , ToAliasReference bAlias + , bAliasRef ~ ToAliasReferenceT bAlias + , ToFrom a + , ToFromT a ~ a' + ) => ToInnerJoin Lateral a (a' -> SqlQuery b) (a' :& bAliasRef) where + toInnerJoin _ lhs q on' = InnerJoinFromLateral (toFrom lhs) (q, on') + +instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b') + => ToInnerJoin NotLateral a b (a' :& b') where + toInnerJoin _ lhs rhs on' = InnerJoinFrom (toFrom lhs) (toFrom rhs, on') + +instance ( ToFrom a + , ToFromT a ~ a' + , ToInnerJoin (IsLateral b) a b b' + ) => ToFrom (InnerJoin a (b, b' -> SqlExpr (Value Bool))) where + toFrom (InnerJoin lhs (rhs, on')) = + let + toProxy :: b -> Proxy (IsLateral b) + toProxy _ = Proxy + in toInnerJoin (toProxy rhs) lhs rhs on' + +instance ( ToFrom a + , ToFrom b + , ToFromT (CrossJoin a b) ~ (ToFromT a :& ToFromT b) + ) => ToFrom (CrossJoin a b) where + toFrom (CrossJoin lhs rhs) = CrossJoinFrom (toFrom lhs) (toFrom rhs) + +instance {-# OVERLAPPING #-} + ( ToFrom a + , ToFromT a ~ a' + , SqlSelect bAlias r + , SqlSelect bAliasRef r' + , ToAlias b + , bAlias ~ ToAliasT b + , ToAliasReference bAlias + , bAliasRef ~ ToAliasReferenceT bAlias + ) + => ToFrom (CrossJoin a (a' -> SqlQuery b)) where + toFrom (CrossJoin lhs q) = CrossJoinFromLateral (toFrom lhs) q + +class ToLeftJoin lateral lhs rhs res where + toLeftJoin :: Proxy lateral -> lhs -> rhs -> (res -> SqlExpr (Value Bool)) -> From res + +instance ( ToFrom a + , ToFromT a ~ a' + , SqlSelect bAlias r + , SqlSelect bAliasRef r' + , ToAlias b + , bAlias ~ ToAliasT b + , ToAliasReference bAlias + , bAliasRef ~ ToAliasReferenceT bAlias + , ToMaybe bAliasRef + , mb ~ ToMaybeT bAliasRef + ) => ToLeftJoin Lateral a (a' -> SqlQuery b) (a' :& mb) where + toLeftJoin _ lhs q on' = LeftJoinFromLateral (toFrom lhs) (q, on') + +instance ( ToFrom a + , ToFromT a ~ a' + , ToFrom b + , ToFromT b ~ b' + , ToMaybe b' + , mb ~ ToMaybeT b' + ) => ToLeftJoin NotLateral a b (a' :& mb) where + toLeftJoin _ lhs rhs on' = LeftJoinFrom (toFrom lhs) (toFrom rhs, on') + +instance ( ToLeftJoin (IsLateral b) a b b' + ) => ToFrom (LeftOuterJoin a (b, b' -> SqlExpr (Value Bool))) where + toFrom (LeftOuterJoin lhs (rhs, on')) = + let + toProxy :: b -> Proxy (IsLateral b) + toProxy _ = Proxy + in toLeftJoin (toProxy rhs) lhs rhs on' + +instance ( ToFrom a + , ToFromT a ~ a' + , ToFrom b + , ToFromT b ~ b' + , ToMaybe a' + , ma ~ ToMaybeT a' + , ToMaybe b' + , mb ~ ToMaybeT b' + , ErrorOnLateral b + ) => ToFrom (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) where toFrom (FullOuterJoin lhs (rhs, on')) = FullJoinFrom (toFrom lhs) (toFrom rhs, on') -instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b', ToMaybe a', ma ~ ToMaybeT a') - => ToFrom (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) where - toFrom (RightOuterJoin lhs (rhs, on')) = RightJoinFrom (toFrom lhs) (toFrom rhs, on') - -instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b') => ToFrom (InnerJoin a (b, (a' :& b') -> SqlExpr (Value Bool))) where - toFrom (InnerJoin lhs (rhs, on')) = InnerJoinFrom (toFrom lhs) (toFrom rhs, on') - -instance (ToFrom a, ToFrom b) => ToFrom (CrossJoin a b) where - toFrom (CrossJoin lhs rhs) = CrossJoinFrom (toFrom lhs) (toFrom rhs) +instance ( ToFrom a + , ToFromT a ~ a' + , ToMaybe a' + , ma ~ ToMaybeT a' + , ToFrom b + , ToFromT b ~ b' + , ErrorOnLateral b + ) => ToFrom (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) where + toFrom (RightOuterJoin lhs (rhs, on')) = RightJoinFrom (toFrom lhs) (toFrom rhs, on') type family Nullable a where Nullable (Maybe a) = a @@ -610,25 +982,17 @@ from parts = do where getVal :: PersistEntity ent => From (SqlExpr (Entity ent)) -> Proxy ent getVal = const Proxy - runFrom (SubQuery subquery) = do - -- We want to update the IdentState without writing the query to side data - (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery - aliasedValue <- toAlias ret - -- Make a fake query with the aliased results, this allows us to ensure that the query is only run once - let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData) - -- Add the FromQuery that renders the subquery to our side data - subqueryAlias <- newIdentFor (DBName "q") - -- Pass the aliased results of the subquery to the outer query - -- create aliased references from the outer query results (e.g value from subquery will be `subquery`.`value`), - -- this is probably overkill as the aliases should already be unique but seems to be good practice. - ref <- toAliasReference subqueryAlias aliasedValue - pure (ref , FromQuery subqueryAlias (\info -> toRawSql SELECT info aliasedQuery)) + runFrom (SubQuery subquery) = + fromSubQuery NormalSubQuery subquery + + runFrom (FromCte ident ref) = + pure (ref, FromIdent ident) runFrom (SqlSetOperation operation) = do (aliasedOperation, ret) <- aliasQueries operation ident <- newIdentFor (DBName "u") ref <- toAliasReference ident ret - pure (ref, FromQuery ident $ operationToSql aliasedOperation) + pure (ref, FromQuery ident (operationToSql aliasedOperation) NormalSubQuery) where aliasQueries o = @@ -648,32 +1012,32 @@ from parts = do else Never pure (SelectQueryP p' $ Q $ W.WriterT $ pure (aliasedRet, sideData), aliasedRet) - Union o1 o2 -> do + SqlSetUnion o1 o2 -> do (o1', ret) <- aliasQueries o1 (o2', _ ) <- aliasQueries o2 - pure (Union o1' o2', ret) - UnionAll o1 o2 -> do + pure (SqlSetUnion o1' o2', ret) + SqlSetUnionAll o1 o2 -> do (o1', ret) <- aliasQueries o1 (o2', _ ) <- aliasQueries o2 - pure (UnionAll o1' o2', ret) - Except o1 o2 -> do + pure (SqlSetUnionAll o1' o2', ret) + SqlSetExcept o1 o2 -> do (o1', ret) <- aliasQueries o1 (o2', _ ) <- aliasQueries o2 - pure (Except o1' o2', ret) - Intersect o1 o2 -> do + pure (SqlSetExcept o1' o2', ret) + SqlSetIntersect o1 o2 -> do (o1', ret) <- aliasQueries o1 (o2', _ ) <- aliasQueries o2 - pure (Intersect o1' o2', ret) + pure (SqlSetIntersect o1' o2', ret) operationToSql o info = case o of SelectQueryP p q -> let (builder, values) = toRawSql SELECT info q in (parensM p builder, values) - Union o1 o2 -> doSetOperation "UNION" info o1 o2 - UnionAll o1 o2 -> doSetOperation "UNION ALL" info o1 o2 - Except o1 o2 -> doSetOperation "EXCEPT" info o1 o2 - Intersect o1 o2 -> doSetOperation "INTERSECT" info o1 o2 + SqlSetUnion o1 o2 -> doSetOperation "UNION" info o1 o2 + SqlSetUnionAll o1 o2 -> doSetOperation "UNION ALL" info o1 o2 + SqlSetExcept o1 o2 -> doSetOperation "EXCEPT" info o1 o2 + SqlSetIntersect o1 o2 -> doSetOperation "INTERSECT" info o1 o2 doSetOperation operationText info o1 o2 = let @@ -687,16 +1051,31 @@ from parts = do (rightVal, rightFrom) <- runFrom rightPart let ret = leftVal :& rightVal pure $ (ret, FromJoin leftFrom InnerJoinKind rightFrom (Just (on' ret))) + runFrom (InnerJoinFromLateral leftPart (q, on')) = do + (leftVal, leftFrom) <- runFrom leftPart + (rightVal, rightFrom) <- fromSubQuery LateralSubQuery (q leftVal) + let ret = leftVal :& rightVal + pure $ (ret, FromJoin leftFrom InnerJoinKind rightFrom (Just (on' ret))) runFrom (CrossJoinFrom leftPart rightPart) = do (leftVal, leftFrom) <- runFrom leftPart (rightVal, rightFrom) <- runFrom rightPart let ret = leftVal :& rightVal pure $ (ret, FromJoin leftFrom CrossJoinKind rightFrom Nothing) + runFrom (CrossJoinFromLateral leftPart q) = do + (leftVal, leftFrom) <- runFrom leftPart + (rightVal, rightFrom) <- fromSubQuery LateralSubQuery (q leftVal) + let ret = leftVal :& rightVal + pure $ (ret, FromJoin leftFrom CrossJoinKind rightFrom Nothing) runFrom (LeftJoinFrom leftPart (rightPart, on')) = do (leftVal, leftFrom) <- runFrom leftPart (rightVal, rightFrom) <- runFrom rightPart let ret = leftVal :& (toMaybe rightVal) pure $ (ret, FromJoin leftFrom LeftOuterJoinKind rightFrom (Just (on' ret))) + runFrom (LeftJoinFromLateral leftPart (q, on')) = do + (leftVal, leftFrom) <- runFrom leftPart + (rightVal, rightFrom) <- fromSubQuery LateralSubQuery (q leftVal) + let ret = leftVal :& (toMaybe rightVal) + pure $ (ret, FromJoin leftFrom LeftOuterJoinKind rightFrom (Just (on' ret))) runFrom (RightJoinFrom leftPart (rightPart, on')) = do (leftVal, leftFrom) <- runFrom leftPart (rightVal, rightFrom) <- runFrom rightPart @@ -708,6 +1087,124 @@ from parts = do let ret = (toMaybe leftVal) :& (toMaybe rightVal) pure $ (ret, FromJoin leftFrom FullOuterJoinKind rightFrom (Just (on' ret))) +fromSubQuery :: ( SqlSelect a' r + , SqlSelect a'' r' + , ToAlias a + , a' ~ ToAliasT a + , ToAliasReference a' + , ToAliasReferenceT a' ~ a'' + ) + => SubQueryType -> SqlQuery a -> SqlQuery (ToAliasReferenceT (ToAliasT a), FromClause) +fromSubQuery subqueryType subquery = do + -- We want to update the IdentState without writing the query to side data + (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery + aliasedValue <- toAlias ret + -- Make a fake query with the aliased results, this allows us to ensure that the query is only run once + let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData) + -- Add the FromQuery that renders the subquery to our side data + subqueryAlias <- newIdentFor (DBName "q") + -- Pass the aliased results of the subquery to the outer query + -- create aliased references from the outer query results (e.g value from subquery will be `subquery`.`value`), + -- this is probably overkill as the aliases should already be unique but seems to be good practice. + ref <- toAliasReference subqueryAlias aliasedValue + pure (ref , FromQuery subqueryAlias (\info -> toRawSql SELECT info aliasedQuery) subqueryType) + + + +-- | @WITH@ clause used to introduce a [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression). +-- CTEs are supported in most modern SQL engines and can be useful +-- in performance tuning. In Esqueleto, CTEs should be used as a +-- subquery memoization tactic. While when writing plain SQL, CTEs +-- are sometimes used to organize the SQL code, in Esqueleto, this +-- is better achieved through function that return 'SqlQuery' values. +-- +-- @ +-- select $ do +-- cte <- with subQuery +-- cteResult <- from cte +-- where_ $ cteResult ... +-- pure cteResult +-- @ +-- +-- __WARNING__: In some SQL engines using a CTE can diminish performance. +-- In these engines the CTE is treated as an optimization fence. You should +-- always verify that using a CTE will in fact improve your performance +-- over a regular subquery. +-- +-- /Since: 3.4.0.0/ +with :: ( ToAlias a + , ToAliasReference (ToAliasT a) + , SqlSelect (ToAliasT a) r + ) => SqlQuery a -> SqlQuery (From (ToAliasReferenceT (ToAliasT a))) +with query = do + (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ query + aliasedValue <- toAlias ret + let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData) + ident <- newIdentFor (DBName "cte") + let clause = CommonTableExpressionClause NormalCommonTableExpression ident (\info -> toRawSql SELECT info aliasedQuery) + Q $ W.tell mempty{sdCteClause = [clause]} + ref <- toAliasReference ident aliasedValue + pure $ FromCte ident ref + +-- | @WITH@ @RECURSIVE@ allows one to make a recursive subquery, which can +-- reference itself. Like @WITH@, this is supported in most modern SQL engines. +-- Useful for hierarchical, self-referential data, like a tree of data. +-- +-- @ +-- select $ do +-- cte <- withRecursive +-- (do $ +-- person <- from $ Table \@Person +-- where_ $ person ^. PersonId ==. val personId +-- pure person +-- ) +-- unionAll_ +-- (\\self -> do $ +-- (p :& f :& p2 :& pSelf) <- from self +-- \`InnerJoin\` $ Table \@Follow +-- \`on\` (\\(p :& f) -> +-- p ^. PersonId ==. f ^. FollowFollower) +-- \`InnerJoin\` $ Table \@Person +-- \`on\` (\\(p :& f :& p2) -> +-- f ^. FollowFollowed ==. p2 ^. PersonId) +-- \`LeftOuterJoin\` self +-- \`on\` (\\(_ :& _ :& p2 :& pSelf) -> +-- just (p2 ^. PersonId) ==. pSelf ?. PersonId) +-- where_ $ isNothing (pSelf ?. PersonId) +-- groupBy (p2 ^. PersonId) +-- pure p2 +-- ) +-- from cte +-- @ +-- +-- /Since: 3.4.0.0/ +withRecursive :: ( ToAlias a + , ToAliasReference (ToAliasT a) + , SqlSelect a r + , SqlSelect (ToAliasT a) r + , ref ~ ToAliasReferenceT (ToAliasT a) + , RecursiveCteUnion unionKind + ) + => SqlQuery a + -> unionKind + -> (From ref -> SqlQuery a) + -> SqlQuery (From ref) +withRecursive baseCase unionKind recursiveCase = do + (ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ baseCase + aliasedValue <- toAlias ret + let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData) + ident <- newIdentFor (DBName "cte") + ref <- toAliasReference ident aliasedValue + let refFrom = FromCte ident ref + let recursiveQuery = recursiveCase refFrom + let clause = CommonTableExpressionClause RecursiveCommonTableExpression ident + (\info -> (toRawSql SELECT info aliasedQuery) + <> (unionKeyword unionKind, mempty) + <> (toRawSql SELECT info recursiveQuery) + ) + Q $ W.tell mempty{sdCteClause = [clause]} + pure refFrom + type family ToAliasT a where ToAliasT (SqlExpr (Value a)) = SqlExpr (Value a) ToAliasT (SqlExpr (Entity a)) = SqlExpr (Entity a) @@ -877,3 +1374,12 @@ instance ( ToAliasReference a , ToAliasReference h ) => ToAliasReference (a,b,c,d,e,f,g,h) where toAliasReference ident x = to8 <$> (toAliasReference ident $ from8 x) + + +class RecursiveCteUnion a where + unionKeyword :: a -> TLB.Builder + +instance RecursiveCteUnion (a -> b -> Union a b) where + unionKeyword _ = "\nUNION\n" +instance RecursiveCteUnion (a -> b -> UnionAll a b) where + unionKeyword _ = "\nUNION ALL\n" diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 592b46a..e3e4e8f 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -47,6 +47,7 @@ import Data.Semigroup import qualified Data.Monoid as Monoid import Data.Proxy (Proxy(..)) import Database.Esqueleto.Internal.PersistentImport +import qualified Database.Persist import Database.Persist.Sql.Util (entityColumnNames, entityColumnCount, parseEntityValues, isIdField, hasCompositeKey) import qualified Data.Set as Set import Data.Set (Set) @@ -57,6 +58,7 @@ import qualified Data.ByteString as B import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import qualified Data.HashSet as HS +import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB @@ -137,7 +139,6 @@ where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr } -- and tuple-joins do not need an 'on' clause, but 'InnerJoin' and the various -- outer joins do. -- --- Note that this function will be replaced by the one in -- "Database.Esqueleto.Experimental" in version 4.0.0.0 of the library. The -- @Experimental@ module has a dramatically improved means for introducing -- tables and entities that provides more power and less potential for runtime @@ -1680,14 +1681,15 @@ data SideData = SideData { sdDistinctClause :: !DistinctClause , sdOrderByClause :: ![OrderByClause] , sdLimitClause :: !LimitClause , sdLockingClause :: !LockingClause + , sdCteClause :: ![CommonTableExpressionClause] } instance Semigroup SideData where - SideData d f s w g h o l k <> SideData d' f' s' w' g' h' o' l' k' = - SideData (d <> d') (f <> f') (s <> s') (w <> w') (g <> g') (h <> h') (o <> o') (l <> l') (k <> k') + SideData d f s w g h o l k c <> SideData d' f' s' w' g' h' o' l' k' c' = + SideData (d <> d') (f <> f') (s <> s') (w <> w') (g <> g') (h <> h') (o <> o') (l <> l') (k <> k') (c <> c') instance Monoid SideData where - mempty = SideData mempty mempty mempty mempty mempty mempty mempty mempty mempty + mempty = SideData mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty mappend = (<>) -- | The @DISTINCT@ "clause". @@ -1711,14 +1713,29 @@ data FromClause = FromStart Ident EntityDef | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool))) | OnClause (SqlExpr (Value Bool)) - | FromQuery Ident (IdentInfo -> (TLB.Builder, [PersistValue])) + | FromQuery Ident (IdentInfo -> (TLB.Builder, [PersistValue])) SubQueryType + | FromIdent Ident + +data CommonTableExpressionKind + = RecursiveCommonTableExpression + | NormalCommonTableExpression + deriving Eq + +data CommonTableExpressionClause = + CommonTableExpressionClause CommonTableExpressionKind Ident (IdentInfo -> (TLB.Builder, [PersistValue])) + +data SubQueryType + = NormalSubQuery + | LateralSubQuery + deriving Show collectIdents :: FromClause -> Set Ident collectIdents fc = case fc of FromStart i _ -> Set.singleton i FromJoin lhs _ rhs _ -> collectIdents lhs <> collectIdents rhs OnClause _ -> mempty - FromQuery _ _ -> mempty + FromQuery _ _ _ -> mempty + FromIdent _ -> mempty instance Show FromClause where show fc = case fc of @@ -1740,9 +1757,10 @@ instance Show FromClause where ] OnClause expr -> "(OnClause " <> render' expr <> ")" - FromQuery ident _-> - "(FromQuery " <> show ident <> ")" - + FromQuery ident _ subQueryType -> + "(FromQuery " <> show ident <> " " <> show subQueryType <> ")" + FromIdent ident -> + "(FromIdent " <> show ident <> ")" where dummy = SqlBackend @@ -1800,12 +1818,14 @@ collectOnClauses sqlBackend = go Set.empty [] findRightmostIdent (FromStart i _) = Just i findRightmostIdent (FromJoin _ _ r _) = findRightmostIdent r findRightmostIdent (OnClause {}) = Nothing - findRightmostIdent (FromQuery _ _) = Nothing + findRightmostIdent (FromQuery _ _ _) = Nothing + findRightmostIdent (FromIdent _) = Nothing findLeftmostIdent (FromStart i _) = Just i findLeftmostIdent (FromJoin l _ _ _) = findLeftmostIdent l findLeftmostIdent (OnClause {}) = Nothing - findLeftmostIdent (FromQuery _ _) = Nothing + findLeftmostIdent (FromQuery _ _ _) = Nothing + findLeftmostIdent (FromIdent _) = Nothing tryMatch :: Set Ident @@ -2632,14 +2652,16 @@ toRawSql mode (conn, firstIdentState) query = havingClause orderByClauses limitClause - lockingClause = sd + lockingClause + cteClause = sd -- Pass the finalIdentState (containing all identifiers -- that were used) to the subsequent calls. This ensures -- that no name clashes will occur on subqueries that may -- appear on the expressions below. info = (projectBackend conn, finalIdentState) in mconcat - [ makeInsertInto info mode ret + [ makeCte info cteClause + , makeInsertInto info mode ret , makeSelect info mode distinctClause ret , makeFrom info mode fromClauses , makeSet info setClauses @@ -2733,6 +2755,33 @@ intersperseB a = mconcat . intersperse a . filter (/= mempty) uncommas' :: Monoid a => [(TLB.Builder, a)] -> (TLB.Builder, a) uncommas' = (uncommas *** mconcat) . unzip +makeCte :: IdentInfo -> [CommonTableExpressionClause] -> (TLB.Builder, [PersistValue]) +makeCte info cteClauses = + let + withCteText + | hasRecursive = "WITH RECURSIVE " + | otherwise = "WITH " + + where + hasRecursive = + any (== RecursiveCommonTableExpression) $ + fmap (\(CommonTableExpressionClause cteKind _ _) -> cteKind) cteClauses + + cteClauseToText (CommonTableExpressionClause _ cteIdent cteFn) = + first (\tlb -> + useIdent info cteIdent <> " AS " <> parens tlb + ) $ cteFn info + + cteBody = + mconcat $ + intersperse (",\n", mempty) $ + fmap cteClauseToText cteClauses + in + if length cteClauses == 0 then + mempty + else + first (\tlb -> withCteText <> tlb <> "\n") cteBody + makeInsertInto :: SqlSelect a r => IdentInfo -> Mode -> a -> (TLB.Builder, [PersistValue]) makeInsertInto info INSERT_INTO ret = sqlInsertInto info ret @@ -2783,9 +2832,15 @@ makeFrom info mode fs = ret , maybe mempty makeOnClause monClause ] mk _ (OnClause _) = throw (UnexpectedCaseErr MakeFromError) - mk _ (FromQuery ident f) = + mk _ (FromQuery ident f subqueryType) = let (queryText, queryVals) = f info - in ((parens queryText) <> " AS " <> useIdent info ident, queryVals) + lateralKeyword = + case subqueryType of + NormalSubQuery -> "" + LateralSubQuery -> "LATERAL " + in (lateralKeyword <> (parens queryText) <> " AS " <> useIdent info ident, queryVals) + mk _ (FromIdent ident) = + (useIdent info ident, mempty) base ident@(I identText) def = let db@(DBName dbText) = entityDB def @@ -3608,3 +3663,66 @@ data RenderExprException = RenderExprUnexpectedECompositeKey T.Text -- -- @since 3.2.0 instance Exception RenderExprException + + +---------------------------------------------------------------------- + + +-- | @valkey i = 'val' . 'toSqlKey'@ +-- (). +valkey :: (ToBackendKey SqlBackend entity, PersistField (Key entity)) => + Int64 -> SqlExpr (Value (Key entity)) +valkey = val . toSqlKey + + +-- | @valJ@ is like @val@ but for something that is already a @Value@. The use +-- case it was written for was, given a @Value@ lift the @Key@ for that @Value@ +-- into the query expression in a type safe way. However, the implementation is +-- more generic than that so we call it @valJ@. +-- +-- Its important to note that the input entity and the output entity are +-- constrained to be the same by the type signature on the function +-- (). +-- +-- /Since: 1.4.2/ +valJ :: (PersistField (Key entity)) => + Value (Key entity) -> SqlExpr (Value (Key entity)) +valJ = val . unValue + + +---------------------------------------------------------------------- + + +-- | Synonym for 'Database.Persist.Store.delete' that does not +-- clash with @esqueleto@'s 'delete'. +deleteKey :: ( PersistStore backend + , BaseBackend backend ~ PersistEntityBackend val + , MonadIO m + , PersistEntity val ) + => Key val -> R.ReaderT backend m () +deleteKey = Database.Persist.delete + +-- | Avoid N+1 queries and join entities into a map structure +-- @ +-- getFoosAndNestedBarsFromParent :: ParentId -> (Map (Key Foo) (Foo, [Maybe (Entity Bar)])) +-- getFoosAndNestedBarsFromParent parentId = 'fmap' associateJoin $ 'select' $ +-- 'from' $ \\(foo `'LeftOuterJoin`` bar) -> do +-- 'on' (bar '?.' BarFooId '==.' foo '^.' FooId) +-- 'where_' (foo '^.' FooParentId '==.' 'val' parentId) +-- 'pure' (foo, bar) +-- @ +-- +-- @since 3.1.2 +associateJoin + :: forall e1 e0 + . Ord (Key e0) + => [(Entity e0, e1)] + -> Map.Map (Key e0) (e0, [e1]) +associateJoin = foldr f start + where + start = Map.empty + f (one, many) = + Map.insertWith + (\(oneOld, manyOld) (_, manyNew) -> (oneOld, manyNew ++ manyOld )) + (entityKey one) + (entityVal one, [many]) diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index f1610c4..fce1c5a 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -73,6 +73,10 @@ module Database.Esqueleto.Internal.Sql , toArgList , builderToText , Ident(..) + , valkey + , valJ + , deleteKey + , associateJoin ) where import Database.Esqueleto.Internal.Internal diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 6d282af..c43f11f 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -891,7 +891,7 @@ testSelectSubQuery run = do let q = do p <- Experimental.from $ Table @Person return ( p ^. PersonName, p ^. PersonAge) - ret <- select $ Experimental.from $ SelectQuery q + ret <- select $ Experimental.from q liftIO $ ret `shouldBe` [ (Value $ personName p1, Value $ personAge p1) ] it "supports sub-selecting Maybe entities" $ do @@ -901,7 +901,7 @@ testSelectSubQuery run = do l1Deeds <- mapM (\k -> insert' $ Deed k (entityKey l1e)) (map show [1..3 :: Int]) let l1WithDeeds = do d <- l1Deeds pure (l1e, Just d) - ret <- select $ Experimental.from $ SelectQuery $ do + ret <- select $ Experimental.from $ do (lords :& deeds) <- Experimental.from $ Table @Lord `LeftOuterJoin` Table @Deed @@ -976,7 +976,7 @@ testSelectSubQuery run = do mapM_ (\k -> insert $ Deed k l3k) (map show [4..10 :: Int]) let q = do (lord :& deed) <- Experimental.from $ Table @Lord - `InnerJoin` (SelectQuery $ Experimental.from $ Table @Deed) + `InnerJoin` (Experimental.from $ Table @Deed) `Experimental.on` (\(lord :& deed) -> lord ^. LordId ==. deed ^. DeedOwnerId) groupBy (lord ^. LordId) @@ -991,10 +991,9 @@ testSelectSubQuery run = do l3k <- insert l3 let q = do (lord :& (_, dogCounts)) <- Experimental.from $ Table @Lord - `LeftOuterJoin` (SelectQuery $ do - lord <- Experimental.from $ Table @Lord - pure (lord ^. LordId, lord ^. LordDogs) - ) + `LeftOuterJoin` do + lord <- Experimental.from $ Table @Lord + pure (lord ^. LordId, lord ^. LordDogs) `Experimental.on` (\(lord :& (lordId, _)) -> just (lord ^. LordId) ==. lordId) groupBy (lord ^. LordId, dogCounts) @@ -1007,17 +1006,17 @@ testSelectSubQuery run = do _ <- insert p1 _ <- insert p2 let q = Experimental.from $ - (SelectQuery $ do + (do p <- Experimental.from $ Table @Person where_ $ not_ $ isNothing $ p ^. PersonAge return (p ^. PersonName)) - `Union` - (SelectQuery $ do + `union_` + (do p <- Experimental.from $ Table @Person where_ $ isNothing $ p ^. PersonAge return (p ^. PersonName)) - `Union` - (SelectQuery $ do + `union_` + (do p <- Experimental.from $ Table @Person where_ $ isNothing $ p ^. PersonAge return (p ^. PersonName)) diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index bb0053f..ff155d0 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -33,6 +33,8 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Time.Clock (getCurrentTime, diffUTCTime, UTCTime) import Database.Esqueleto hiding (random_) +import Database.Esqueleto.Experimental hiding (random_, from, on) +import qualified Database.Esqueleto.Experimental as Experimental import qualified Database.Esqueleto.Internal.Sql as ES import Database.Esqueleto.PostgreSQL (random_) import qualified Database.Esqueleto.PostgreSQL as EP @@ -1151,6 +1153,146 @@ testFilterWhere = ] :: [(Maybe Int, Maybe Rational, Maybe Rational)] ) +testCommonTableExpressions :: Spec +testCommonTableExpressions = do + describe "You can run them" $ do + it "will run" $ do + run $ do + + void $ select $ do + limitedLordsCte <- + Experimental.with $ do + lords <- Experimental.from $ Experimental.Table @Lord + limit 10 + pure lords + lords <- Experimental.from limitedLordsCte + orderBy [asc $ lords ^. LordId] + pure lords + + True `shouldBe` True + + it "can do multiple recursive queries" $ do + vals <- run $ do + let oneToTen = Experimental.withRecursive + (pure $ val (1 :: Int)) + Experimental.unionAll_ + (\self -> do + v <- Experimental.from self + where_ $ v <. val 10 + pure $ v +. val 1 + ) + + select $ do + cte <- oneToTen + cte2 <- oneToTen + res1 <- Experimental.from cte + res2 <- Experimental.from cte2 + pure (res1, res2) + vals `shouldBe` (((,) <$> fmap Value [1..10] <*> fmap Value [1..10])) + + it "passing previous query works" $ + let + oneToTen = + Experimental.withRecursive + (pure $ val (1 :: Int)) + Experimental.unionAll_ + (\self -> do + v <- Experimental.from self + where_ $ v <. val 10 + pure $ v +. val 1 + ) + + oneMore q = + Experimental.with $ do + v <- Experimental.from q + pure $ v +. val 1 + in do + vals <- run $ do + + select $ do + cte <- oneToTen + cte2 <- oneMore cte + res <- Experimental.from cte2 + pure res + vals `shouldBe` fmap Value [2..11] + +-- Since lateral queries arent supported in Sqlite or older versions of mysql +-- the test is in the Postgres module +testLateralQuery :: Spec +testLateralQuery = do + describe "Lateral queries" $ do + it "supports CROSS JOIN LATERAL" $ do + _ <- run $ do + select $ do + l :& c <- + Experimental.from $ Table @Lord + `CrossJoin` \lord -> do + deed <- Experimental.from $ Table @Deed + where_ $ lord ^. LordId ==. deed ^. DeedOwnerId + pure $ countRows @Int + pure (l, c) + True `shouldBe` True + + it "supports INNER JOIN LATERAL" $ do + run $ do + let subquery lord = do + deed <- Experimental.from $ Table @Deed + where_ $ lord ^. LordId ==. deed ^. DeedOwnerId + pure $ countRows @Int + res <- select $ do + l :& c <- Experimental.from $ Table @Lord + `InnerJoin` subquery + `Experimental.on` (const $ val True) + pure (l, c) + + let _ = res :: [(Entity Lord, Value Int)] + pure () + True `shouldBe` True + + it "supports LEFT JOIN LATERAL" $ do + run $ do + res <- select $ do + l :& c <- Experimental.from $ Table @Lord + `LeftOuterJoin` (\lord -> do + deed <- Experimental.from $ Table @Deed + where_ $ lord ^. LordId ==. deed ^. DeedOwnerId + pure $ countRows @Int) + `Experimental.on` (const $ val True) + pure (l, c) + + let _ = res :: [(Entity Lord, Value (Maybe Int))] + pure () + True `shouldBe` True + + {-- + it "compile error on RIGHT JOIN LATERAL" $ do + run $ do + res <- select $ do + l :& c <- Experimental.from $ Table @Lord + `RightOuterJoin` (\lord -> do + deed <- Experimental.from $ Table @Deed + where_ $ lord ?. LordId ==. just (deed ^. DeedOwnerId) + pure $ countRows @Int) + `Experimental.on` (const $ val True) + pure (l, c) + + let _ = res :: [(Maybe (Entity Lord), Value Int)] + pure () + it "compile error on FULL OUTER JOIN LATERAL" $ do + run $ do + res <- select $ do + l :& c <- Experimental.from $ Table @Lord + `FullOuterJoin` (\lord -> do + deed <- Experimental.from $ Table @Deed + where_ $ lord ?. LordId ==. just (deed ^. DeedOwnerId) + pure $ countRows @Int) + `Experimental.on` (const $ val True) + pure (l, c) + + let _ = res :: [(Maybe (Entity Lord), Value (Maybe Int))] + pure () + --} + type JSONValue = Maybe (JSONB A.Value) createSaneSQL :: (PersistField a) => SqlExpr (Value a) -> T.Text -> [PersistValue] -> IO () @@ -1226,6 +1368,7 @@ main = do testUpsert testInsertSelectWithConflict testFilterWhere + testCommonTableExpressions describe "PostgreSQL JSON tests" $ do -- NOTE: We only clean the table once, so we -- can use its contents across all JSON tests @@ -1234,6 +1377,7 @@ main = do cleanJSON testJSONInsertions testJSONOperators + testLateralQuery run, runSilent, runVerbose :: Run