Ben Levy
GitHub
commit
ae9ef126d9
@ -1,4 +1,7 @@
|
||||
{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, RankNTypes #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
-- | The @esqueleto@ EDSL (embedded domain specific language).
|
||||
-- This module replaces @Database.Persist@, so instead of
|
||||
-- importing that module you should just import this one:
|
||||
@ -125,8 +128,8 @@ import Control.Monad.Trans.Reader (ReaderT)
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Database.Esqueleto.Internal.Language
|
||||
import Database.Esqueleto.Internal.Sql
|
||||
import Database.Esqueleto.Internal.PersistentImport
|
||||
import Database.Esqueleto.Internal.Sql
|
||||
import qualified Database.Persist
|
||||
|
||||
|
||||
|
||||
@ -19,8 +19,10 @@ module Database.Esqueleto.Experimental
|
||||
-- * Documentation
|
||||
|
||||
Table(..)
|
||||
, table
|
||||
, from
|
||||
, SubQuery(..)
|
||||
, selectQuery
|
||||
, (:&)(..)
|
||||
, on
|
||||
|
||||
@ -40,6 +42,15 @@ module Database.Esqueleto.Experimental
|
||||
, with
|
||||
, withRecursive
|
||||
|
||||
, innerJoin
|
||||
, innerJoinLateral
|
||||
, leftJoin
|
||||
, leftJoinLateral
|
||||
, rightJoin
|
||||
, fullOuterJoin
|
||||
, crossJoin
|
||||
, crossJoinLateral
|
||||
|
||||
-- * Internals
|
||||
, From(..)
|
||||
, ToMaybe(..)
|
||||
@ -47,7 +58,7 @@ module Database.Esqueleto.Experimental
|
||||
, ToAliasT
|
||||
, ToAliasReference(..)
|
||||
, ToAliasReferenceT
|
||||
, ToSetOperation(..)
|
||||
, ToSqlSetOperation(..)
|
||||
, ValidOnClauseValue
|
||||
-- * The Normal Stuff
|
||||
|
||||
@ -216,6 +227,7 @@ import Database.Esqueleto.Experimental.From.SqlSetOperation
|
||||
import Database.Esqueleto.Experimental.ToAlias
|
||||
import Database.Esqueleto.Experimental.ToAliasReference
|
||||
import Database.Esqueleto.Experimental.ToMaybe
|
||||
|
||||
-- $setup
|
||||
--
|
||||
-- If you're already using "Database.Esqueleto", then you can get
|
||||
|
||||
@ -1,12 +1,16 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
@ -14,8 +18,11 @@
|
||||
module Database.Esqueleto.Experimental.From
|
||||
where
|
||||
|
||||
import Control.Arrow (first)
|
||||
import Control.Monad (ap)
|
||||
import qualified Control.Monad.Trans.Writer as W
|
||||
import Data.Proxy
|
||||
import qualified Data.Text.Lazy.Builder as TLB
|
||||
import Database.Esqueleto.Experimental.ToAlias
|
||||
import Database.Esqueleto.Experimental.ToAliasReference
|
||||
import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
|
||||
@ -30,15 +37,20 @@ import Database.Esqueleto.Internal.PersistentImport
|
||||
-- instances of `From`. This implementation eliminates certain
|
||||
-- types of runtime errors by preventing the construction of
|
||||
-- invalid SQL (e.g. illegal nested-@from@).
|
||||
from :: From a => a -> SqlQuery (FromT a)
|
||||
from parts = do
|
||||
(a, clause) <- runFrom parts
|
||||
Q $ W.tell mempty{sdFromClause=[clause]}
|
||||
from :: ToFrom a a' => a -> SqlQuery a'
|
||||
from f = do
|
||||
(a, clause) <- unFrom (toFrom f)
|
||||
Q $ W.tell mempty{sdFromClause=[FromRaw $ clause]}
|
||||
pure a
|
||||
|
||||
class From a where
|
||||
type FromT a
|
||||
runFrom :: a -> SqlQuery (FromT a, FromClause)
|
||||
type RawFn = NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])
|
||||
newtype From a = From
|
||||
{ unFrom :: SqlQuery (a, RawFn)}
|
||||
|
||||
class ToFrom a r | a -> r where
|
||||
toFrom :: a -> From r
|
||||
instance ToFrom (From a) a where
|
||||
toFrom = id
|
||||
|
||||
-- | Data type for bringing a Table into scope in a JOIN tree
|
||||
--
|
||||
@ -46,54 +58,35 @@ class From a where
|
||||
-- select $ from $ Table \@People
|
||||
-- @
|
||||
data Table a = Table
|
||||
instance PersistEntity ent => ToFrom (Table ent) (SqlExpr (Entity ent)) where
|
||||
toFrom _ = table
|
||||
|
||||
instance PersistEntity a => From (Table a) where
|
||||
type FromT (Table a) = SqlExpr (Entity a)
|
||||
runFrom e@Table = do
|
||||
let ed = entityDef $ getVal e
|
||||
ident <- newIdentFor (entityDB ed)
|
||||
let entity = unsafeSqlEntity ident
|
||||
pure $ (entity, FromStart ident ed)
|
||||
where
|
||||
getVal :: Table ent -> Proxy ent
|
||||
getVal = const Proxy
|
||||
table :: forall ent. PersistEntity ent => From (SqlExpr (Entity ent))
|
||||
table = From $ do
|
||||
let ed = entityDef (Proxy @ent)
|
||||
ident <- newIdentFor (entityDB ed)
|
||||
let entity = unsafeSqlEntity ident
|
||||
pure $ ( entity, const $ base ident ed )
|
||||
where
|
||||
base ident@(I identText) def info =
|
||||
let db@(DBName dbText) = entityDB def
|
||||
in ( fromDBName info db <>
|
||||
if dbText == identText
|
||||
then mempty
|
||||
else " AS " <> useIdent info ident
|
||||
, mempty
|
||||
)
|
||||
|
||||
|
||||
{-# DEPRECATED SubQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SubQuery@" #-}
|
||||
newtype SubQuery a = SubQuery a
|
||||
instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SubQuery (SqlQuery a)) a where
|
||||
toFrom (SubQuery q) = selectQuery q
|
||||
instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SqlQuery a) a where
|
||||
toFrom = selectQuery
|
||||
|
||||
instance
|
||||
( ToAlias a
|
||||
, ToAliasReference a
|
||||
, SqlSelect a r
|
||||
)
|
||||
=>
|
||||
From (SqlQuery a)
|
||||
where
|
||||
type FromT (SqlQuery a) = a
|
||||
runFrom subquery =
|
||||
fromSubQuery NormalSubQuery subquery
|
||||
|
||||
instance
|
||||
( ToAlias a
|
||||
, ToAliasReference a
|
||||
, SqlSelect a r
|
||||
)
|
||||
=>
|
||||
From (SubQuery (SqlQuery a))
|
||||
where
|
||||
type FromT (SubQuery (SqlQuery a)) = a
|
||||
runFrom (SubQuery subquery) =
|
||||
fromSubQuery NormalSubQuery subquery
|
||||
|
||||
fromSubQuery
|
||||
::
|
||||
( SqlSelect a r
|
||||
, ToAlias a
|
||||
, ToAliasReference a
|
||||
)
|
||||
=> SubQueryType -> SqlQuery a -> SqlQuery (a, FromClause)
|
||||
fromSubQuery subqueryType subquery = do
|
||||
selectQuery :: (SqlSelect a r, ToAlias a, ToAliasReference a) => SqlQuery a -> From a
|
||||
selectQuery subquery = From $ do
|
||||
-- We want to update the IdentState without writing the query to side data
|
||||
(ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery
|
||||
aliasedValue <- toAlias ret
|
||||
@ -105,4 +98,11 @@ fromSubQuery subqueryType subquery = do
|
||||
-- create aliased references from the outer query results (e.g value from subquery will be `subquery`.`value`),
|
||||
-- this is probably overkill as the aliases should already be unique but seems to be good practice.
|
||||
ref <- toAliasReference subqueryAlias aliasedValue
|
||||
pure (ref , FromQuery subqueryAlias (\info -> toRawSql SELECT info aliasedQuery) subqueryType)
|
||||
|
||||
pure (ref, \_ info ->
|
||||
let (queryText,queryVals) = toRawSql SELECT info aliasedQuery
|
||||
in
|
||||
( (parens queryText) <> " AS " <> useIdent info subqueryAlias
|
||||
, queryVals
|
||||
)
|
||||
)
|
||||
|
||||
@ -14,12 +14,6 @@ import Database.Esqueleto.Experimental.ToAliasReference
|
||||
import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
|
||||
import Database.Esqueleto.Internal.PersistentImport (DBName(..))
|
||||
|
||||
data CommonTableExpression ref = CommonTableExpression Ident ref
|
||||
instance From (CommonTableExpression ref) where
|
||||
type FromT (CommonTableExpression ref) = ref
|
||||
runFrom (CommonTableExpression ident ref) =
|
||||
pure (ref, FromIdent ident)
|
||||
|
||||
-- | @WITH@ clause used to introduce a [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression).
|
||||
-- CTEs are supported in most modern SQL engines and can be useful
|
||||
-- in performance tuning. In Esqueleto, CTEs should be used as a
|
||||
@ -44,7 +38,7 @@ instance From (CommonTableExpression ref) where
|
||||
with :: ( ToAlias a
|
||||
, ToAliasReference a
|
||||
, SqlSelect a r
|
||||
) => SqlQuery a -> SqlQuery (CommonTableExpression a)
|
||||
) => SqlQuery a -> SqlQuery (From a)
|
||||
with query = do
|
||||
(ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ query
|
||||
aliasedValue <- toAlias ret
|
||||
@ -53,7 +47,7 @@ with query = do
|
||||
let clause = CommonTableExpressionClause NormalCommonTableExpression ident (\info -> toRawSql SELECT info aliasedQuery)
|
||||
Q $ W.tell mempty{sdCteClause = [clause]}
|
||||
ref <- toAliasReference ident aliasedValue
|
||||
pure $ CommonTableExpression ident ref
|
||||
pure $ From $ pure (ref, (\_ info -> (useIdent info ident, mempty)))
|
||||
|
||||
-- | @WITH@ @RECURSIVE@ allows one to make a recursive subquery, which can
|
||||
-- reference itself. Like @WITH@, this is supported in most modern SQL engines.
|
||||
@ -90,33 +84,29 @@ with query = do
|
||||
withRecursive :: ( ToAlias a
|
||||
, ToAliasReference a
|
||||
, SqlSelect a r
|
||||
, RecursiveCteUnion unionKind
|
||||
)
|
||||
=> SqlQuery a
|
||||
-> unionKind
|
||||
-> (CommonTableExpression a -> SqlQuery a)
|
||||
-> SqlQuery (CommonTableExpression a)
|
||||
-> UnionKind
|
||||
-> (From a -> SqlQuery a)
|
||||
-> SqlQuery (From a)
|
||||
withRecursive baseCase unionKind recursiveCase = do
|
||||
(ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ baseCase
|
||||
aliasedValue <- toAlias ret
|
||||
let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)
|
||||
ident <- newIdentFor (DBName "cte")
|
||||
ref <- toAliasReference ident aliasedValue
|
||||
let refFrom = CommonTableExpression ident ref
|
||||
let refFrom = From (pure (ref, (\_ info -> (useIdent info ident, mempty))))
|
||||
let recursiveQuery = recursiveCase refFrom
|
||||
let clause = CommonTableExpressionClause RecursiveCommonTableExpression ident
|
||||
(\info -> (toRawSql SELECT info aliasedQuery)
|
||||
<> (unionKeyword unionKind, mempty)
|
||||
<> ("\n" <> (unUnionKind unionKind) <> "\n", mempty)
|
||||
<> (toRawSql SELECT info recursiveQuery)
|
||||
)
|
||||
Q $ W.tell mempty{sdCteClause = [clause]}
|
||||
pure refFrom
|
||||
|
||||
class RecursiveCteUnion a where
|
||||
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"
|
||||
newtype UnionKind = UnionKind { unUnionKind :: TLB.Builder }
|
||||
instance Union_ UnionKind where
|
||||
union_ = UnionKind "UNION"
|
||||
instance UnionAll_ UnionKind where
|
||||
unionAll_ = UnionKind "UNION ALL"
|
||||
|
||||
@ -1,6 +1,11 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
@ -8,15 +13,19 @@
|
||||
module Database.Esqueleto.Experimental.From.Join
|
||||
where
|
||||
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Kind (Constraint)
|
||||
import Data.Proxy
|
||||
import qualified Data.Text.Lazy.Builder as TLB
|
||||
import Database.Esqueleto.Experimental.From
|
||||
import Database.Esqueleto.Experimental.From.SqlSetOperation
|
||||
import Database.Esqueleto.Experimental.ToAlias
|
||||
import Database.Esqueleto.Experimental.ToAliasReference
|
||||
import Database.Esqueleto.Experimental.ToMaybe
|
||||
import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
|
||||
import Database.Esqueleto.Internal.PersistentImport (Entity(..))
|
||||
import Database.Esqueleto.Internal.Internal hiding
|
||||
(From(..), from, fromJoin, on)
|
||||
import Database.Esqueleto.Internal.PersistentImport
|
||||
(Entity(..), EntityField, PersistEntity, PersistField)
|
||||
import GHC.TypeLits
|
||||
|
||||
-- | A left-precedence pair. Pronounced \"and\". Used to represent expressions
|
||||
@ -33,6 +42,10 @@ import GHC.TypeLits
|
||||
data (:&) a b = a :& b
|
||||
infixl 2 :&
|
||||
|
||||
instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where
|
||||
type ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b)
|
||||
toMaybe (a :& b) = (toMaybe a :& toMaybe b)
|
||||
|
||||
-- | Constraint for `on`. Ensures that only types that require an `on` can be used on
|
||||
-- the left hand side. This was previously reusing the From class which was actually
|
||||
-- a bit too lenient as it allowed to much.
|
||||
@ -44,6 +57,7 @@ type family ValidOnClauseValue a :: Constraint where
|
||||
ValidOnClauseValue (SqlQuery a) = ()
|
||||
ValidOnClauseValue (SqlSetOperation a) = ()
|
||||
ValidOnClauseValue (a -> SqlQuery b) = ()
|
||||
ValidOnClauseValue (From a) = ()
|
||||
ValidOnClauseValue _ = TypeError ('Text "Illegal use of ON")
|
||||
|
||||
-- | An @ON@ clause that describes how two tables are related. This should be
|
||||
@ -60,165 +74,233 @@ on :: ValidOnClauseValue a => a -> (b -> SqlExpr (Value Bool)) -> (a, b -> SqlEx
|
||||
on = (,)
|
||||
infix 9 `on`
|
||||
|
||||
data Lateral
|
||||
data NotLateral
|
||||
|
||||
type family IsLateral a where
|
||||
IsLateral (a -> SqlQuery b) = Lateral
|
||||
IsLateral a = NotLateral
|
||||
|
||||
type family ErrorOnLateral a :: Constraint where
|
||||
ErrorOnLateral (a -> SqlQuery b) = TypeError ('Text "LATERAL can only be used for INNER, LEFT, and CROSS join kinds.")
|
||||
ErrorOnLateral _ = ()
|
||||
|
||||
-- Type class magic to allow the use of the `InnerJoin` family of data constructors in from
|
||||
type family FromOnClause a where
|
||||
FromOnClause (a, b -> SqlExpr (Value Bool)) = b
|
||||
FromOnClause a = TypeError ('Text "Missing ON clause")
|
||||
fromJoin :: TLB.Builder -> RawFn -> RawFn -> Maybe (SqlExpr (Value Bool)) -> RawFn
|
||||
fromJoin joinKind lhs rhs monClause =
|
||||
\paren info ->
|
||||
first (parensM paren) $
|
||||
mconcat [ lhs Never info
|
||||
, (joinKind, mempty)
|
||||
, rhs Parens info
|
||||
, maybe mempty (makeOnClause info) monClause
|
||||
]
|
||||
where
|
||||
makeOnClause info (ERaw _ f) = first (" ON " <>) (f Never info)
|
||||
|
||||
instance {-# OVERLAPPABLE #-} From (InnerJoin a b) where
|
||||
type FromT (InnerJoin a b) = FromOnClause b
|
||||
runFrom = undefined
|
||||
instance {-# OVERLAPPABLE #-} From (LeftOuterJoin a b) where
|
||||
type FromT (LeftOuterJoin a b) = FromOnClause b
|
||||
runFrom = undefined
|
||||
instance {-# OVERLAPPABLE #-} From (RightOuterJoin a b) where
|
||||
type FromT (RightOuterJoin a b) = FromOnClause b
|
||||
runFrom = undefined
|
||||
instance {-# OVERLAPPABLE #-} From (FullOuterJoin a b) where
|
||||
type FromT (FullOuterJoin a b) = FromOnClause b
|
||||
runFrom = undefined
|
||||
type family HasOnClause actual expected :: Constraint where
|
||||
HasOnClause (a, b -> SqlExpr (Value Bool)) c = () -- Let the compiler handle the type mismatch
|
||||
HasOnClause a expected =
|
||||
TypeError ( 'Text "Missing ON clause for join with"
|
||||
':$$: 'ShowType a
|
||||
':$$: 'Text ""
|
||||
':$$: 'Text "Expected: "
|
||||
':$$: 'ShowType a
|
||||
':$$: 'Text "`on` " ':<>: 'ShowType (expected -> SqlExpr (Value Bool))
|
||||
':$$: 'Text ""
|
||||
)
|
||||
|
||||
class FromInnerJoin lateral lhs rhs res where
|
||||
runFromInnerJoin :: Proxy lateral -> lhs -> rhs -> (res -> SqlExpr (Value Bool)) -> SqlQuery (res, FromClause)
|
||||
|
||||
instance ( SqlSelect b r
|
||||
, ToAlias b
|
||||
, ToAliasReference b
|
||||
, From a
|
||||
, FromT a ~ a'
|
||||
) => FromInnerJoin Lateral a (a' -> SqlQuery b) (a' :& b) where
|
||||
runFromInnerJoin _ 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)))
|
||||
innerJoin :: ( ToFrom a a'
|
||||
, ToFrom b b'
|
||||
, HasOnClause rhs (a' :& b')
|
||||
, rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool))
|
||||
) => a -> rhs -> From (a' :& b')
|
||||
innerJoin lhs (rhs, on') = From $ do
|
||||
(leftVal, leftFrom) <- unFrom (toFrom lhs)
|
||||
(rightVal, rightFrom) <- unFrom (toFrom rhs)
|
||||
let ret = leftVal :& rightVal
|
||||
pure $ (ret, fromJoin " INNER JOIN " leftFrom rightFrom (Just $ on' ret))
|
||||
|
||||
instance (From a, FromT a ~ a', From b, FromT b ~ b')
|
||||
=> FromInnerJoin NotLateral a b (a' :& b') where
|
||||
runFromInnerJoin _ leftPart rightPart on' = do
|
||||
(leftVal, leftFrom) <- runFrom leftPart
|
||||
(rightVal, rightFrom) <- runFrom rightPart
|
||||
let ret = leftVal :& rightVal
|
||||
pure $ (ret, FromJoin leftFrom InnerJoinKind rightFrom (Just (on' ret)))
|
||||
|
||||
instance (FromInnerJoin (IsLateral b) a b b') => From (InnerJoin a (b, b' -> SqlExpr (Value Bool))) where
|
||||
type FromT (InnerJoin a (b, b' -> SqlExpr (Value Bool))) = FromOnClause (b, b' -> SqlExpr(Value Bool))
|
||||
runFrom (InnerJoin lhs (rhs, on')) = runFromInnerJoin (toProxy rhs) lhs rhs on'
|
||||
where
|
||||
toProxy :: b -> Proxy (IsLateral b)
|
||||
toProxy _ = Proxy
|
||||
innerJoinLateral :: ( ToFrom a a'
|
||||
, HasOnClause rhs (a' :& b)
|
||||
, SqlSelect b r
|
||||
, ToAlias b
|
||||
, ToAliasReference b
|
||||
, rhs ~ (a' -> SqlQuery b, (a' :& b) -> SqlExpr (Value Bool))
|
||||
)
|
||||
=> a -> rhs -> From (a' :& b)
|
||||
innerJoinLateral lhs (rhsFn, on') = From $ do
|
||||
(leftVal, leftFrom) <- unFrom (toFrom lhs)
|
||||
(rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal))
|
||||
let ret = leftVal :& rightVal
|
||||
pure $ (ret, fromJoin " INNER JOIN LATERAL " leftFrom rightFrom (Just $ on' ret))
|
||||
|
||||
type family FromCrossJoin a b where
|
||||
FromCrossJoin a (b -> SqlQuery c) = FromT a :& c
|
||||
FromCrossJoin a b = FromT a :& FromT b
|
||||
crossJoin :: ( ToFrom a a'
|
||||
, ToFrom b b'
|
||||
) => a -> b -> From (a' :& b')
|
||||
crossJoin lhs rhs = From $ do
|
||||
(leftVal, leftFrom) <- unFrom (toFrom lhs)
|
||||
(rightVal, rightFrom) <- unFrom (toFrom rhs)
|
||||
let ret = leftVal :& rightVal
|
||||
pure $ (ret, fromJoin " CROSS JOIN " leftFrom rightFrom Nothing)
|
||||
|
||||
instance ( From a
|
||||
, From b
|
||||
, FromT (CrossJoin a b) ~ (FromT a :& FromT b)
|
||||
) => From (CrossJoin a b) where
|
||||
type FromT (CrossJoin a b) = FromCrossJoin a b
|
||||
runFrom (CrossJoin leftPart rightPart) = do
|
||||
(leftVal, leftFrom) <- runFrom leftPart
|
||||
(rightVal, rightFrom) <- runFrom rightPart
|
||||
let ret = leftVal :& rightVal
|
||||
pure $ (ret, FromJoin leftFrom CrossJoinKind rightFrom Nothing)
|
||||
crossJoinLateral :: ( ToFrom a a'
|
||||
, SqlSelect b r
|
||||
, ToAlias b
|
||||
, ToAliasReference b
|
||||
)
|
||||
=> a -> (a' -> SqlQuery b) -> From (a' :& b)
|
||||
crossJoinLateral lhs rhsFn = From $ do
|
||||
(leftVal, leftFrom) <- unFrom (toFrom lhs)
|
||||
(rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal))
|
||||
let ret = leftVal :& rightVal
|
||||
pure $ (ret, fromJoin " CROSS JOIN LATERAL " leftFrom rightFrom Nothing)
|
||||
|
||||
instance {-# OVERLAPPING #-}
|
||||
( From a
|
||||
, FromT a ~ a'
|
||||
leftJoin :: ( ToFrom a a'
|
||||
, ToFrom b b'
|
||||
, ToMaybe b'
|
||||
, HasOnClause rhs (a' :& ToMaybeT b')
|
||||
, rhs ~ (b, (a' :& ToMaybeT b') -> SqlExpr (Value Bool))
|
||||
) => a -> rhs -> From (a' :& ToMaybeT b')
|
||||
leftJoin lhs (rhs, on') = From $ do
|
||||
(leftVal, leftFrom) <- unFrom (toFrom lhs)
|
||||
(rightVal, rightFrom) <- unFrom (toFrom rhs)
|
||||
let ret = leftVal :& toMaybe rightVal
|
||||
pure $ (ret, fromJoin " LEFT OUTER JOIN " leftFrom rightFrom (Just $ on' ret))
|
||||
|
||||
leftJoinLateral :: ( ToFrom a a'
|
||||
, SqlSelect b r
|
||||
, HasOnClause rhs (a' :& ToMaybeT b)
|
||||
, ToAlias b
|
||||
, ToAliasReference b
|
||||
, ToMaybe b
|
||||
, rhs ~ (a' -> SqlQuery b, (a' :& ToMaybeT b) -> SqlExpr (Value Bool))
|
||||
)
|
||||
=> a -> rhs -> From (a' :& ToMaybeT b)
|
||||
leftJoinLateral lhs (rhsFn, on') = From $ do
|
||||
(leftVal, leftFrom) <- unFrom (toFrom lhs)
|
||||
(rightVal, rightFrom) <- unFrom (selectQuery (rhsFn leftVal))
|
||||
let ret = leftVal :& toMaybe rightVal
|
||||
pure $ (ret, fromJoin " LEFT OUTER JOIN LATERAL " leftFrom rightFrom (Just $ on' ret))
|
||||
|
||||
rightJoin :: ( ToFrom a a'
|
||||
, ToFrom b b'
|
||||
, ToMaybe a'
|
||||
, HasOnClause rhs (ToMaybeT a' :& b')
|
||||
, rhs ~ (b, (ToMaybeT a' :& b') -> SqlExpr (Value Bool))
|
||||
) => a -> rhs -> From (ToMaybeT a' :& b')
|
||||
rightJoin lhs (rhs, on') = From $ do
|
||||
(leftVal, leftFrom) <- unFrom (toFrom lhs)
|
||||
(rightVal, rightFrom) <- unFrom (toFrom rhs)
|
||||
let ret = toMaybe leftVal :& rightVal
|
||||
pure $ (ret, fromJoin " RIGHT OUTER JOIN " leftFrom rightFrom (Just $ on' ret))
|
||||
|
||||
fullOuterJoin :: ( ToFrom a a'
|
||||
, ToFrom b b'
|
||||
, ToMaybe a'
|
||||
, ToMaybe b'
|
||||
, HasOnClause rhs (ToMaybeT a' :& ToMaybeT b')
|
||||
, rhs ~ (b, (ToMaybeT a' :& ToMaybeT b') -> SqlExpr (Value Bool))
|
||||
) => a -> rhs -> From (ToMaybeT a' :& ToMaybeT b')
|
||||
fullOuterJoin lhs (rhs, on') = From $ do
|
||||
(leftVal, leftFrom) <- unFrom (toFrom lhs)
|
||||
(rightVal, rightFrom) <- unFrom (toFrom rhs)
|
||||
let ret = toMaybe leftVal :& toMaybe rightVal
|
||||
pure $ (ret, fromJoin " FULL OUTER JOIN " leftFrom rightFrom (Just $ on' ret))
|
||||
|
||||
infixl 2 `innerJoin`,
|
||||
`innerJoinLateral`,
|
||||
`leftJoin`,
|
||||
`leftJoinLateral`,
|
||||
`crossJoin`,
|
||||
`crossJoinLateral`,
|
||||
`rightJoin`,
|
||||
`fullOuterJoin`
|
||||
|
||||
|
||||
------ Compatibility for old syntax
|
||||
|
||||
data Lateral
|
||||
data NotLateral
|
||||
|
||||
type family IsLateral a where
|
||||
IsLateral (a -> SqlQuery b, c) = Lateral
|
||||
IsLateral (a -> SqlQuery b) = Lateral
|
||||
IsLateral a = NotLateral
|
||||
|
||||
class DoInnerJoin lateral lhs rhs res | lateral rhs lhs -> res where
|
||||
doInnerJoin :: Proxy lateral -> lhs -> rhs -> From res
|
||||
|
||||
instance ( ToFrom a a'
|
||||
, ToFrom b b'
|
||||
, HasOnClause rhs (a' :& b')
|
||||
, rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool))
|
||||
) => DoInnerJoin NotLateral a rhs (a' :& b') where
|
||||
doInnerJoin _ = innerJoin
|
||||
|
||||
instance ( ToFrom a a'
|
||||
, SqlSelect b r
|
||||
, ToAlias b
|
||||
, ToAliasReference b
|
||||
) => From (CrossJoin a (a' -> SqlQuery b)) where
|
||||
type FromT (CrossJoin a (a' -> SqlQuery b)) = FromCrossJoin a (a' -> SqlQuery b)
|
||||
runFrom (CrossJoin leftPart q) = do
|
||||
(leftVal, leftFrom) <- runFrom leftPart
|
||||
(rightVal, rightFrom) <- fromSubQuery LateralSubQuery (q leftVal)
|
||||
let ret = leftVal :& rightVal
|
||||
pure $ (ret, FromJoin leftFrom CrossJoinKind rightFrom Nothing)
|
||||
, d ~ (a' :& b)
|
||||
) => DoInnerJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where
|
||||
doInnerJoin _ = innerJoinLateral
|
||||
|
||||
class FromLeftJoin lateral lhs rhs res where
|
||||
runFromLeftJoin :: Proxy lateral -> lhs -> rhs -> (res -> SqlExpr (Value Bool)) -> SqlQuery (res, FromClause)
|
||||
instance ( DoInnerJoin lateral lhs rhs r, lateral ~ IsLateral rhs )
|
||||
=> ToFrom (InnerJoin lhs rhs) r where
|
||||
toFrom (InnerJoin a b) = doInnerJoin (Proxy @lateral) a b
|
||||
|
||||
instance ( From a
|
||||
, FromT a ~ a'
|
||||
, SqlSelect b r
|
||||
, ToAlias b
|
||||
, ToAliasReference b
|
||||
class DoLeftJoin lateral lhs rhs res | lateral rhs lhs -> res where
|
||||
doLeftJoin :: Proxy lateral -> lhs -> rhs -> From res
|
||||
|
||||
instance ( ToFrom a a'
|
||||
, ToFrom b b'
|
||||
, ToMaybe b'
|
||||
, ToMaybeT b' ~ mb
|
||||
, HasOnClause rhs (a' :& mb)
|
||||
, rhs ~ (b, (a' :& mb) -> SqlExpr (Value Bool))
|
||||
) => DoLeftJoin NotLateral a rhs (a' :& mb) where
|
||||
doLeftJoin _ = leftJoin
|
||||
|
||||
instance ( ToFrom a a'
|
||||
, ToMaybe b
|
||||
, mb ~ ToMaybeT b
|
||||
) => FromLeftJoin Lateral a (a' -> SqlQuery b) (a' :& mb) where
|
||||
runFromLeftJoin _ 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)))
|
||||
, d ~ (a' :& ToMaybeT b)
|
||||
, SqlSelect b r
|
||||
, ToAlias b
|
||||
, ToAliasReference b
|
||||
) => DoLeftJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where
|
||||
doLeftJoin _ = leftJoinLateral
|
||||
|
||||
instance ( From a
|
||||
, FromT a ~ a'
|
||||
, From b
|
||||
, FromT b ~ b'
|
||||
, ToMaybe b'
|
||||
, mb ~ ToMaybeT b'
|
||||
) => FromLeftJoin NotLateral a b (a' :& mb) where
|
||||
runFromLeftJoin _ leftPart rightPart on' = do
|
||||
(leftVal, leftFrom) <- runFrom leftPart
|
||||
(rightVal, rightFrom) <- runFrom rightPart
|
||||
let ret = leftVal :& (toMaybe rightVal)
|
||||
pure $ (ret, FromJoin leftFrom LeftOuterJoinKind rightFrom (Just (on' ret)))
|
||||
instance ( DoLeftJoin lateral lhs rhs r, lateral ~ IsLateral rhs )
|
||||
=> ToFrom (LeftOuterJoin lhs rhs) r where
|
||||
toFrom (LeftOuterJoin a b) = doLeftJoin (Proxy @lateral) a b
|
||||
|
||||
instance ( FromLeftJoin (IsLateral b) a b b'
|
||||
) => From (LeftOuterJoin a (b, b' -> SqlExpr (Value Bool))) where
|
||||
type FromT (LeftOuterJoin a (b, b' -> SqlExpr (Value Bool))) = FromOnClause (b, b' -> SqlExpr(Value Bool))
|
||||
runFrom (LeftOuterJoin lhs (rhs, on')) =
|
||||
runFromLeftJoin (toProxy rhs) lhs rhs on'
|
||||
where
|
||||
toProxy :: b -> Proxy (IsLateral b)
|
||||
toProxy _ = Proxy
|
||||
class DoCrossJoin lateral lhs rhs res | lateral lhs rhs -> res where
|
||||
doCrossJoin :: Proxy lateral -> lhs -> rhs -> From res
|
||||
|
||||
instance ( From a
|
||||
, FromT a ~ a'
|
||||
, From b
|
||||
, FromT b ~ b'
|
||||
instance (ToFrom a a', ToFrom b b') => DoCrossJoin NotLateral a b (a' :& b') where
|
||||
doCrossJoin _ = crossJoin
|
||||
instance (ToFrom a a', SqlSelect b r, ToAlias b, ToAliasReference b)
|
||||
=> DoCrossJoin Lateral a (a' -> SqlQuery b) (a' :& b) where
|
||||
doCrossJoin _ = crossJoinLateral
|
||||
|
||||
instance (DoCrossJoin lateral lhs rhs r, IsLateral rhs ~ lateral)
|
||||
=> ToFrom (CrossJoin lhs rhs) r where
|
||||
toFrom (CrossJoin a b) = doCrossJoin (Proxy @lateral) a b
|
||||
|
||||
instance ( ToFrom a a'
|
||||
, ToFrom b b'
|
||||
, ToMaybe a'
|
||||
, ma ~ ToMaybeT a'
|
||||
, ToMaybe b'
|
||||
, mb ~ ToMaybeT b'
|
||||
, ToMaybeT a' ~ ma
|
||||
, HasOnClause rhs (ma :& b')
|
||||
, ErrorOnLateral b
|
||||
) => From (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) where
|
||||
type FromT (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) = FromOnClause (b, (ma :& mb) -> SqlExpr(Value Bool))
|
||||
runFrom (FullOuterJoin leftPart (rightPart, on')) = do
|
||||
(leftVal, leftFrom) <- runFrom leftPart
|
||||
(rightVal, rightFrom) <- runFrom rightPart
|
||||
let ret = (toMaybe leftVal) :& (toMaybe rightVal)
|
||||
pure $ (ret, FromJoin leftFrom FullOuterJoinKind rightFrom (Just (on' ret)))
|
||||
, rhs ~ (b, (ma :& b') -> SqlExpr (Value Bool))
|
||||
) => ToFrom (RightOuterJoin a rhs) (ma :& b') where
|
||||
toFrom (RightOuterJoin a b) = rightJoin a b
|
||||
|
||||
instance ( From a
|
||||
, FromT a ~ a'
|
||||
instance ( ToFrom a a'
|
||||
, ToFrom b b'
|
||||
, ToMaybe a'
|
||||
, ma ~ ToMaybeT a'
|
||||
, From b
|
||||
, FromT b ~ b'
|
||||
, ToMaybeT a' ~ ma
|
||||
, ToMaybe b'
|
||||
, ToMaybeT b' ~ mb
|
||||
, HasOnClause rhs (ma :& mb)
|
||||
, ErrorOnLateral b
|
||||
) => From (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) where
|
||||
type FromT (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) = FromOnClause (b, (ma :& b') -> SqlExpr(Value Bool))
|
||||
runFrom (RightOuterJoin leftPart (rightPart, on')) = do
|
||||
(leftVal, leftFrom) <- runFrom leftPart
|
||||
(rightVal, rightFrom) <- runFrom rightPart
|
||||
let ret = (toMaybe leftVal) :& rightVal
|
||||
pure $ (ret, FromJoin leftFrom RightOuterJoinKind rightFrom (Just (on' ret)))
|
||||
, rhs ~ (b, (ma :& mb) -> SqlExpr (Value Bool))
|
||||
) => ToFrom (FullOuterJoin a rhs) (ma :& mb) where
|
||||
toFrom (FullOuterJoin a b) = fullOuterJoin a b
|
||||
|
||||
instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where
|
||||
type ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b)
|
||||
toMaybe (a :& b) = (toMaybe a :& toMaybe b)
|
||||
|
||||
@ -4,200 +4,109 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Database.Esqueleto.Experimental.From.SqlSetOperation
|
||||
where
|
||||
|
||||
import Control.Arrow (first)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import qualified Control.Monad.Trans.State as S
|
||||
import qualified Control.Monad.Trans.Writer as W
|
||||
import qualified Data.Text.Lazy.Builder as TLB
|
||||
import Database.Esqueleto.Experimental.From
|
||||
import Database.Esqueleto.Experimental.ToAlias
|
||||
import Database.Esqueleto.Experimental.ToAliasReference
|
||||
import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
|
||||
import Database.Esqueleto.Internal.PersistentImport (DBName(..))
|
||||
import Database.Esqueleto.Internal.PersistentImport
|
||||
(DBName(..), Entity, PersistEntity, PersistValue)
|
||||
|
||||
data SqlSetOperation a
|
||||
= SqlSetUnion (SqlSetOperation a) (SqlSetOperation a)
|
||||
| SqlSetUnionAll (SqlSetOperation a) (SqlSetOperation a)
|
||||
| SqlSetExcept (SqlSetOperation a) (SqlSetOperation a)
|
||||
| SqlSetIntersect (SqlSetOperation a) (SqlSetOperation a)
|
||||
| SelectQueryP NeedParens (SqlQuery a)
|
||||
newtype SqlSetOperation a = SqlSetOperation
|
||||
{ unSqlSetOperation :: NeedParens -> SqlQuery (a, IdentInfo -> (TLB.Builder, [PersistValue]))}
|
||||
|
||||
runSetOperation :: (SqlSelect a r, ToAlias a, ToAliasReference a)
|
||||
=> SqlSetOperation a -> SqlQuery (a, FromClause)
|
||||
runSetOperation operation = do
|
||||
(aliasedOperation, ret) <- aliasQueries operation
|
||||
ident <- newIdentFor (DBName "u")
|
||||
ref <- toAliasReference ident ret
|
||||
pure (ref, FromQuery ident (operationToSql aliasedOperation) NormalSubQuery)
|
||||
instance ToAliasReference a => ToFrom (SqlSetOperation a) a where
|
||||
toFrom setOperation = From $ do
|
||||
ident <- newIdentFor (DBName "u")
|
||||
(a, fromClause) <- unSqlSetOperation setOperation Never
|
||||
ref <- toAliasReference ident a
|
||||
pure (ref, \_ info -> (first parens $ fromClause info) <> (" AS " <> useIdent info ident, mempty))
|
||||
|
||||
where
|
||||
aliasQueries o =
|
||||
case o of
|
||||
SelectQueryP p q -> do
|
||||
(ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ q
|
||||
prevState <- Q $ lift S.get
|
||||
aliasedRet <- toAlias ret
|
||||
Q $ lift $ S.put prevState
|
||||
let p' =
|
||||
case p of
|
||||
Parens -> Parens
|
||||
Never ->
|
||||
if (sdLimitClause sideData) /= mempty
|
||||
|| length (sdOrderByClause sideData) > 0 then
|
||||
Parens
|
||||
else
|
||||
Never
|
||||
pure (SelectQueryP p' $ Q $ W.WriterT $ pure (aliasedRet, sideData), aliasedRet)
|
||||
SqlSetUnion o1 o2 -> do
|
||||
(o1', ret) <- aliasQueries o1
|
||||
(o2', _ ) <- aliasQueries o2
|
||||
pure (SqlSetUnion o1' o2', ret)
|
||||
SqlSetUnionAll o1 o2 -> do
|
||||
(o1', ret) <- aliasQueries o1
|
||||
(o2', _ ) <- aliasQueries o2
|
||||
pure (SqlSetUnionAll o1' o2', ret)
|
||||
SqlSetExcept o1 o2 -> do
|
||||
(o1', ret) <- aliasQueries o1
|
||||
(o2', _ ) <- aliasQueries o2
|
||||
pure (SqlSetExcept o1' o2', ret)
|
||||
SqlSetIntersect o1 o2 -> do
|
||||
(o1', ret) <- aliasQueries o1
|
||||
(o2', _ ) <- aliasQueries o2
|
||||
pure (SqlSetIntersect o1' o2', ret)
|
||||
|
||||
operationToSql o info =
|
||||
case o of
|
||||
SelectQueryP p q ->
|
||||
let (builder, values) = toRawSql SELECT info q
|
||||
in (parensM p builder, values)
|
||||
SqlSetUnion o1 o2 -> doSetOperation "UNION" info o1 o2
|
||||
SqlSetUnionAll o1 o2 -> doSetOperation "UNION ALL" info o1 o2
|
||||
SqlSetExcept o1 o2 -> doSetOperation "EXCEPT" info o1 o2
|
||||
SqlSetIntersect o1 o2 -> doSetOperation "INTERSECT" info o1 o2
|
||||
|
||||
doSetOperation operationText info o1 o2 =
|
||||
let (q1, v1) = operationToSql o1 info
|
||||
(q2, v2) = operationToSql o2 info
|
||||
in (q1 <> " " <> operationText <> " " <> q2, v1 <> v2)
|
||||
class ToSqlSetOperation a r | a -> r where
|
||||
toSqlSetOperation :: a -> SqlSetOperation r
|
||||
instance ToSqlSetOperation (SqlSetOperation a) a where
|
||||
toSqlSetOperation = id
|
||||
instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToSqlSetOperation (SqlQuery a) a where
|
||||
toSqlSetOperation subquery =
|
||||
SqlSetOperation $ \p -> do
|
||||
(ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery
|
||||
state <- Q $ lift S.get
|
||||
aliasedValue <- toAlias ret
|
||||
Q $ lift $ S.put state
|
||||
let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)
|
||||
let p' =
|
||||
case p of
|
||||
Parens -> Parens
|
||||
Never ->
|
||||
if (sdLimitClause sideData) /= mempty
|
||||
|| length (sdOrderByClause sideData) > 0 then
|
||||
Parens
|
||||
else
|
||||
Never
|
||||
pure (aliasedValue, \info -> first (parensM p') $ toRawSql SELECT info aliasedQuery)
|
||||
|
||||
mkSetOperation :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => TLB.Builder -> a -> b -> SqlSetOperation a'
|
||||
mkSetOperation operation lhs rhs = SqlSetOperation $ \p -> do
|
||||
(leftValue, leftClause) <- unSqlSetOperation (toSqlSetOperation lhs) p
|
||||
(_, rightClause) <- unSqlSetOperation (toSqlSetOperation rhs) p
|
||||
pure (leftValue, \info -> leftClause info <> (operation, mempty) <> rightClause info)
|
||||
|
||||
{-# DEPRECATED Union "/Since: 3.4.0.0/ - Use the 'union_' function instead of the 'Union' data constructor" #-}
|
||||
data Union a b = a `Union` b
|
||||
instance ToSqlSetOperation a a' => ToSqlSetOperation (Union a a) a' where
|
||||
toSqlSetOperation (Union a b) = union_ a b
|
||||
|
||||
-- | @UNION@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
|
||||
union_ :: a -> b -> Union a b
|
||||
union_ = Union
|
||||
|
||||
class Union_ a where
|
||||
-- | @UNION@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
|
||||
union_ :: a
|
||||
|
||||
instance (ToSqlSetOperation a c, ToSqlSetOperation b c, res ~ SqlSetOperation c)
|
||||
=> Union_ (a -> b -> res) where
|
||||
union_ = mkSetOperation " UNION "
|
||||
|
||||
class UnionAll_ a where
|
||||
-- | @UNION@ @ALL@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
|
||||
unionAll_ :: a
|
||||
instance (ToSqlSetOperation a c, ToSqlSetOperation b c, res ~ SqlSetOperation c)
|
||||
=> UnionAll_ (a -> b -> res) where
|
||||
unionAll_ = mkSetOperation " UNION ALL "
|
||||
|
||||
{-# DEPRECATED UnionAll "/Since: 3.4.0.0/ - Use the 'unionAll_' function instead of the 'UnionAll' data constructor" #-}
|
||||
data UnionAll a b = a `UnionAll` b
|
||||
|
||||
-- | @UNION@ @ALL@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
|
||||
unionAll_ :: a -> b -> UnionAll a b
|
||||
unionAll_ = UnionAll
|
||||
instance ToSqlSetOperation a a' => ToSqlSetOperation (UnionAll a a) a' where
|
||||
toSqlSetOperation (UnionAll a b) = unionAll_ a b
|
||||
|
||||
{-# DEPRECATED Except "/Since: 3.4.0.0/ - Use the 'except_' function instead of the 'Except' data constructor" #-}
|
||||
data Except a b = a `Except` b
|
||||
instance ToSqlSetOperation a a' => ToSqlSetOperation (Except a a) a' where
|
||||
toSqlSetOperation (Except a b) = except_ a b
|
||||
|
||||
-- | @EXCEPT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
|
||||
except_ :: a -> b -> Except a b
|
||||
except_ = Except
|
||||
except_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a'
|
||||
except_ = mkSetOperation " EXCEPT "
|
||||
|
||||
{-# DEPRECATED Intersect "/Since: 3.4.0.0/ - Use the 'intersect_' function instead of the 'Intersect' data constructor" #-}
|
||||
data Intersect a b = a `Intersect` b
|
||||
instance ToSqlSetOperation a a' => ToSqlSetOperation (Intersect a a) a' where
|
||||
toSqlSetOperation (Intersect a b) = intersect_ a b
|
||||
|
||||
-- | @INTERSECT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
|
||||
intersect_ :: a -> b -> Intersect a b
|
||||
intersect_ = Intersect
|
||||
|
||||
class SetOperationT a ~ b => ToSetOperation a b | a -> b where
|
||||
type SetOperationT a
|
||||
toSetOperation :: a -> SqlSetOperation b
|
||||
instance ToSetOperation (SqlSetOperation a) a where
|
||||
type SetOperationT (SqlSetOperation a) = a
|
||||
toSetOperation = id
|
||||
instance ToSetOperation (SqlQuery a) a where
|
||||
type SetOperationT (SqlQuery a) = a
|
||||
toSetOperation = SelectQueryP Never
|
||||
instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Union a b) c where
|
||||
type SetOperationT (Union a b) = SetOperationT a
|
||||
toSetOperation (Union a b) = SqlSetUnion (toSetOperation a) (toSetOperation b)
|
||||
instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (UnionAll a b) c where
|
||||
type SetOperationT (UnionAll a b) = SetOperationT a
|
||||
toSetOperation (UnionAll a b) = SqlSetUnionAll (toSetOperation a) (toSetOperation b)
|
||||
instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Except a b) c where
|
||||
type SetOperationT (Except a b) = SetOperationT a
|
||||
toSetOperation (Except a b) = SqlSetExcept (toSetOperation a) (toSetOperation b)
|
||||
instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Intersect a b) c where
|
||||
type SetOperationT (Intersect a b) = SetOperationT a
|
||||
toSetOperation (Intersect a b) = SqlSetIntersect (toSetOperation a) (toSetOperation b)
|
||||
intersect_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a'
|
||||
intersect_ = mkSetOperation " INTERSECT "
|
||||
|
||||
{-# 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
|
||||
pattern SelectQuery a = a
|
||||
|
||||
instance
|
||||
( SqlSelect c r
|
||||
, ToAlias c
|
||||
, ToAliasReference c
|
||||
, ToSetOperation a c
|
||||
, ToSetOperation b c
|
||||
, c ~ SetOperationT a
|
||||
)
|
||||
=>
|
||||
From (Union a b)
|
||||
where
|
||||
type FromT (Union a b) = SetOperationT a
|
||||
runFrom u = runSetOperation $ toSetOperation u
|
||||
|
||||
instance
|
||||
( SqlSelect c r
|
||||
, ToAlias c
|
||||
, ToAliasReference c
|
||||
, ToSetOperation a c
|
||||
, ToSetOperation b c
|
||||
, c ~ SetOperationT a
|
||||
)
|
||||
=>
|
||||
From (UnionAll a b)
|
||||
where
|
||||
type FromT (UnionAll a b) = SetOperationT a
|
||||
runFrom u = runSetOperation $ toSetOperation u
|
||||
|
||||
instance
|
||||
( SqlSelect c r
|
||||
, ToAlias c
|
||||
, ToAliasReference c
|
||||
, ToSetOperation a c
|
||||
, ToSetOperation b c
|
||||
, c ~ SetOperationT a
|
||||
)
|
||||
=>
|
||||
From (Intersect a b)
|
||||
where
|
||||
type FromT (Intersect a b) = SetOperationT a
|
||||
runFrom u = runSetOperation $ toSetOperation u
|
||||
|
||||
instance
|
||||
( SqlSelect c r
|
||||
, ToAlias c
|
||||
, ToAliasReference c
|
||||
, ToSetOperation a c
|
||||
, ToSetOperation b c
|
||||
, c ~ SetOperationT a
|
||||
)
|
||||
=>
|
||||
From (Except a b)
|
||||
where
|
||||
type FromT (Except a b) = SetOperationT a
|
||||
runFrom u = runSetOperation $ toSetOperation u
|
||||
|
||||
instance (SqlSelect a r, ToAlias a, ToAliasReference a) => From (SqlSetOperation a) where
|
||||
type FromT (SqlSetOperation a) = a
|
||||
-- If someone uses just a plain SelectQuery it should behave like a normal subquery
|
||||
runFrom (SelectQueryP _ subquery) = fromSubQuery NormalSubQuery subquery
|
||||
-- Otherwise use the SqlSetOperation
|
||||
runFrom u = runSetOperation $ toSetOperation u
|
||||
|
||||
@ -24,7 +24,7 @@
|
||||
module Database.Esqueleto.Internal.Internal where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.Coerce (coerce)
|
||||
import Data.Coerce (Coercible, coerce)
|
||||
import Control.Arrow (first, (***))
|
||||
import Control.Exception (Exception, throw, throwIO)
|
||||
import Control.Monad (MonadPlus(..), guard, void)
|
||||
@ -533,8 +533,7 @@ subSelectUnsafe :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Va
|
||||
subSelectUnsafe = sub SELECT
|
||||
|
||||
-- | Project a field of an entity.
|
||||
(^.)
|
||||
:: forall typ val. (PersistEntity val, PersistField typ)
|
||||
(^.) :: forall typ val . (PersistEntity val, PersistField typ)
|
||||
=> SqlExpr (Entity val)
|
||||
-> EntityField val typ
|
||||
-> SqlExpr (Value typ)
|
||||
@ -585,8 +584,7 @@ withNonNull field f = do
|
||||
f $ veryUnsafeCoerceSqlExprValue field
|
||||
|
||||
-- | Project a field of an entity that may be null.
|
||||
(?.)
|
||||
:: (PersistEntity val, PersistField typ)
|
||||
(?.) :: ( PersistEntity val , PersistField typ)
|
||||
=> SqlExpr (Maybe (Entity val))
|
||||
-> EntityField val typ
|
||||
-> SqlExpr (Value (Maybe typ))
|
||||
@ -1738,8 +1736,7 @@ data FromClause
|
||||
= FromStart Ident EntityDef
|
||||
| FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Value Bool)))
|
||||
| OnClause (SqlExpr (Value Bool))
|
||||
| FromQuery Ident (IdentInfo -> (TLB.Builder, [PersistValue])) SubQueryType
|
||||
| FromIdent Ident
|
||||
| FromRaw (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]))
|
||||
|
||||
data CommonTableExpressionKind
|
||||
= RecursiveCommonTableExpression
|
||||
@ -1759,8 +1756,7 @@ collectIdents fc = case fc of
|
||||
FromStart i _ -> Set.singleton i
|
||||
FromJoin lhs _ rhs _ -> collectIdents lhs <> collectIdents rhs
|
||||
OnClause _ -> mempty
|
||||
FromQuery _ _ _ -> mempty
|
||||
FromIdent _ -> mempty
|
||||
FromRaw _ -> mempty
|
||||
|
||||
instance Show FromClause where
|
||||
show fc = case fc of
|
||||
@ -1782,10 +1778,8 @@ instance Show FromClause where
|
||||
]
|
||||
OnClause expr ->
|
||||
"(OnClause " <> render' expr <> ")"
|
||||
FromQuery ident _ subQueryType ->
|
||||
"(FromQuery " <> show ident <> " " <> show subQueryType <> ")"
|
||||
FromIdent ident ->
|
||||
"(FromIdent " <> show ident <> ")"
|
||||
FromRaw _ ->
|
||||
"(FromRaw _)"
|
||||
|
||||
where
|
||||
dummy = SqlBackend
|
||||
@ -1839,14 +1833,12 @@ collectOnClauses sqlBackend = go Set.empty []
|
||||
findRightmostIdent (FromStart i _) = Just i
|
||||
findRightmostIdent (FromJoin _ _ r _) = findRightmostIdent r
|
||||
findRightmostIdent (OnClause {}) = Nothing
|
||||
findRightmostIdent (FromQuery _ _ _) = Nothing
|
||||
findRightmostIdent (FromIdent _) = Nothing
|
||||
findRightmostIdent (FromRaw _) = Nothing
|
||||
|
||||
findLeftmostIdent (FromStart i _) = Just i
|
||||
findLeftmostIdent (FromJoin l _ _ _) = findLeftmostIdent l
|
||||
findLeftmostIdent (OnClause {}) = Nothing
|
||||
findLeftmostIdent (FromQuery _ _ _) = Nothing
|
||||
findLeftmostIdent (FromIdent _) = Nothing
|
||||
findLeftmostIdent (FromRaw _) = Nothing
|
||||
|
||||
tryMatch
|
||||
:: Set Ident
|
||||
@ -2819,18 +2811,7 @@ makeFrom info mode fs = ret
|
||||
, maybe mempty makeOnClause monClause
|
||||
]
|
||||
mk _ (OnClause _) = throw (UnexpectedCaseErr MakeFromError)
|
||||
mk _ (FromQuery ident f subqueryType) =
|
||||
let (queryText, queryVals) = f info
|
||||
lateralKeyword =
|
||||
case subqueryType of
|
||||
NormalSubQuery -> ""
|
||||
LateralSubQuery -> "LATERAL "
|
||||
in
|
||||
( lateralKeyword <> (parens queryText) <> " AS " <> useIdent info ident
|
||||
, queryVals
|
||||
)
|
||||
mk _ (FromIdent ident) =
|
||||
(useIdent info ident, mempty)
|
||||
mk paren (FromRaw f) = f paren info
|
||||
|
||||
base ident@(I identText) def =
|
||||
let db@(DBName dbText) = entityDB def
|
||||
@ -2914,13 +2895,6 @@ makeLocking = flip (,) [] . maybe mempty toTLB . Monoid.getLast
|
||||
parens :: TLB.Builder -> TLB.Builder
|
||||
parens b = "(" <> (b <> ")")
|
||||
|
||||
aliasedValueIdentToRawSql :: Ident -> IdentInfo -> (TLB.Builder, [PersistValue])
|
||||
aliasedValueIdentToRawSql i info = (useIdent info i, mempty)
|
||||
|
||||
valueReferenceToRawSql :: Ident -> (IdentInfo -> Ident) -> IdentInfo -> (TLB.Builder, [PersistValue])
|
||||
valueReferenceToRawSql sourceIdent columnIdentF info =
|
||||
(useIdent info sourceIdent <> "." <> useIdent info (columnIdentF info), mempty)
|
||||
|
||||
aliasedEntityColumnIdent :: Ident -> FieldDef -> Ident
|
||||
aliasedEntityColumnIdent (I baseIdent) field =
|
||||
I (baseIdent <> "_" <> (unDBName $ fieldDB field))
|
||||
|
||||
@ -1,27 +1,28 @@
|
||||
{-# LANGUAGE ScopedTypeVariables
|
||||
, FlexibleContexts
|
||||
, RankNTypes
|
||||
, TypeFamilies
|
||||
, TypeApplications
|
||||
#-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.IO.Class (MonadIO(liftIO))
|
||||
import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT)
|
||||
import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)
|
||||
import Control.Monad.Trans.Reader (ReaderT)
|
||||
import Database.Persist.MySQL ( withMySQLConn
|
||||
, connectHost
|
||||
, connectDatabase
|
||||
, connectUser
|
||||
, connectPassword
|
||||
, connectPort
|
||||
, defaultConnectInfo)
|
||||
import qualified Control.Monad.Trans.Resource as R
|
||||
import Database.Esqueleto
|
||||
import Database.Esqueleto.Experimental hiding (from, on)
|
||||
import qualified Database.Esqueleto.Experimental as Experimental
|
||||
import qualified Control.Monad.Trans.Resource as R
|
||||
import Database.Persist.MySQL
|
||||
( connectDatabase
|
||||
, connectHost
|
||||
, connectPassword
|
||||
, connectPort
|
||||
, connectUser
|
||||
, defaultConnectInfo
|
||||
, withMySQLConn
|
||||
)
|
||||
import Test.Hspec
|
||||
|
||||
import Common.Test
|
||||
@ -187,7 +188,7 @@ testMysqlUnionWithLimits = do
|
||||
pure $ foo ^. FooName
|
||||
|
||||
|
||||
ret <- select $ Experimental.from $ SelectQuery q1 `Union` SelectQuery q2
|
||||
ret <- select $ Experimental.from $ q1 `union_` q2
|
||||
liftIO $ ret `shouldMatchList` [Value 1, Value 2, Value 4, Value 5]
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user