haskell/esqueleto
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

[Experimental] More powerful queries (#215)

Browse Source 
* Initial attempt at Lateral joins

* Fix lateral queries for Inner and Left joins. Remove for Full and Right as this is apparently illegal(who knew). Add TypeError on Full and Right joins. Update on clause to use a custom constraint instead of relying on ToFrom.

* Fix typo leading to erroneous ToFrom instance

* Implement non-recursive CTE's

* add withRecursive; cleanup whitespace

* Fix multiple recursive CTEs. Apparently the spec just wants RECURSIVE if any of the queries are recursive.

* Add test to verify that a CTE can reference a previously defined CTE

* Update with/Recursive to return an element of a from clause to allow for joins against CTEs

* Modify set operations to use a custom data type + typeclass + typefamily to allow direct use of SqlQuery a in set operation and to allow recursive cte's to unify syntax with SqlSetOperation. Added lowercase names for set operations. If we can migrate off the constructor names we may be able to simplify the implementation.

* Fixed haddock documentation issue from v3.3.4.0 and added documentation
for new features introduced by v3.4.0.0

* fixed comments that were changed while debugging haddock build

* Cleanup formatting in From per PR. Cleanup ValidOnClause, added documentation and reduced the number of instances

* Update src/Database/Esqueleto/Experimental.hs

Co-authored-by: charukiewicz <charukiewicz@protonmail.com>
Co-authored-by: Matt Parsons <parsonsmatt@gmail.com>
This commit is contained in:
Ben Levy 2020-10-28 22:37:17 -05:00 committed by GitHub
parent 8adab239df
commit a319d13bee
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
8 changed files with 953 additions and 234 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
changelog.md
View File

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

8
esqueleto.cabal
View File

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

63
src/Database/Esqueleto.hs
View File

@ -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'@
-- (<https://github.com/prowdsponsor/esqueleto/issues/9>).
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
-- (<https://github.com/prowdsponsor/esqueleto/pull/69>).
--
-- /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])

784
src/Database/Esqueleto/Experimental.hs
View File

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

148
src/Database/Esqueleto/Internal/Internal.hs
View File

@ -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'@
-- (<https://github.com/prowdsponsor/esqueleto/issues/9>).
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
-- (<https://github.com/prowdsponsor/esqueleto/pull/69>).
--
-- /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])

4
src/Database/Esqueleto/Internal/Sql.hs
View File

@ -73,6 +73,10 @@ module Database.Esqueleto.Internal.Sql
, toArgList
, builderToText
, Ident(..)
, valkey
, valJ
, deleteKey
, associateJoin
) where
import Database.Esqueleto.Internal.Internal

23
test/Common/Test.hs
View File

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

144
test/PostgreSQL/Test.hs
View File

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