Convert all of experimental to use new From type instead of From type class. Make the data constructors second class, functions should be used. Introduce *Lateral functions, using the same type for lateral and non lateral queries was probably a mistake.
This commit is contained in:
belevy
parent
7a579e921a
commit
dd8814e678
@ -47,7 +47,7 @@ module Database.Esqueleto.Experimental
|
|||||||
, ToAliasT
|
, ToAliasT
|
||||||
, ToAliasReference(..)
|
, ToAliasReference(..)
|
||||||
, ToAliasReferenceT
|
, ToAliasReferenceT
|
||||||
, ToSetOperation(..)
|
, ToSqlSetOperation(..)
|
||||||
, ValidOnClauseValue
|
, ValidOnClauseValue
|
||||||
-- * The Normal Stuff
|
-- * The Normal Stuff
|
||||||
|
|
||||||
|
|||||||
@ -1,28 +1,32 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE FunctionalDependencies #-}
|
{-# LANGUAGE FunctionalDependencies #-}
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE PatternSynonyms #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
module Database.Esqueleto.Experimental.From
|
module Database.Esqueleto.Experimental.From
|
||||||
where
|
where
|
||||||
|
|
||||||
import qualified Control.Monad.Trans.Writer as W
|
import Control.Arrow (first)
|
||||||
import Data.Proxy
|
import Control.Monad (ap)
|
||||||
import qualified Data.Text.Lazy.Builder as TLB
|
import qualified Control.Monad.Trans.Writer as W
|
||||||
import Database.Esqueleto.Experimental.ToAlias
|
import Data.Proxy
|
||||||
import Database.Esqueleto.Experimental.ToAliasReference
|
import qualified Data.Text.Lazy.Builder as TLB
|
||||||
import Database.Esqueleto.Internal.Internal hiding
|
import Database.Esqueleto.Experimental.ToAlias
|
||||||
(From (..),
|
import Database.Esqueleto.Experimental.ToAliasReference
|
||||||
from, on)
|
import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
|
||||||
import Database.Esqueleto.Internal.PersistentImport
|
import Database.Esqueleto.Internal.PersistentImport
|
||||||
|
|
||||||
-- | 'FROM' clause, used to bring entities into scope.
|
-- | 'FROM' clause, used to bring entities into scope.
|
||||||
--
|
--
|
||||||
@ -33,16 +37,20 @@ import Database.Esqueleto.Internal.PersistentImport
|
|||||||
-- instances of `From`. This implementation eliminates certain
|
-- instances of `From`. This implementation eliminates certain
|
||||||
-- types of runtime errors by preventing the construction of
|
-- types of runtime errors by preventing the construction of
|
||||||
-- invalid SQL (e.g. illegal nested-@from@).
|
-- invalid SQL (e.g. illegal nested-@from@).
|
||||||
from :: From a => a -> SqlQuery (FromT a)
|
from :: ToFrom a a' => a -> SqlQuery a'
|
||||||
from parts = do
|
from f = do
|
||||||
(a, clause) <- runFrom parts
|
(a, clause) <- unFrom (toFrom f)
|
||||||
Q $ W.tell mempty{sdFromClause=[FromRaw clause]}
|
Q $ W.tell mempty{sdFromClause=[FromRaw $ clause]}
|
||||||
pure a
|
pure a
|
||||||
|
|
||||||
type RawFn = NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])
|
type RawFn = NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])
|
||||||
class From a where
|
newtype From a = From
|
||||||
type FromT a
|
{ unFrom :: SqlQuery (a, RawFn)}
|
||||||
runFrom :: a -> SqlQuery (FromT 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
|
-- | Data type for bringing a Table into scope in a JOIN tree
|
||||||
--
|
--
|
||||||
@ -50,63 +58,35 @@ class From a where
|
|||||||
-- select $ from $ Table \@People
|
-- select $ from $ Table \@People
|
||||||
-- @
|
-- @
|
||||||
data Table a = Table
|
data Table a = Table
|
||||||
|
instance PersistEntity ent => ToFrom (Table ent) (SqlExpr (Entity ent)) where
|
||||||
|
toFrom _ = table
|
||||||
|
|
||||||
instance PersistEntity a => From (Table a) where
|
table :: forall ent. PersistEntity ent => From (SqlExpr (Entity ent))
|
||||||
type FromT (Table a) = SqlExpr (Entity a)
|
table = From $ do
|
||||||
runFrom e@Table = do
|
let ed = entityDef (Proxy @ent)
|
||||||
let ed = entityDef $ getVal e
|
ident <- newIdentFor (entityDB ed)
|
||||||
ident <- newIdentFor (entityDB ed)
|
let entity = unsafeSqlEntity ident
|
||||||
let entity = unsafeSqlEntity ident
|
pure $ ( entity, const $ base ident ed )
|
||||||
pure $ ( entity, \p -> base p ident ed )
|
where
|
||||||
where
|
base ident@(I identText) def info =
|
||||||
getVal :: Table ent -> Proxy ent
|
let db@(DBName dbText) = entityDB def
|
||||||
getVal = const Proxy
|
in ( fromDBName info db <>
|
||||||
|
if dbText == identText
|
||||||
base _ ident@(I identText) def info =
|
then mempty
|
||||||
let db@(DBName dbText) = entityDB def
|
else " AS " <> useIdent info ident
|
||||||
in ( fromDBName info db <>
|
, mempty
|
||||||
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@" #-}
|
{-# DEPRECATED SubQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SubQuery@" #-}
|
||||||
newtype SubQuery a = SubQuery a
|
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
|
selectQuery :: (SqlSelect a r, ToAlias a, ToAliasReference a) => SqlQuery a -> From a
|
||||||
( ToAlias a
|
selectQuery subquery = From $ do
|
||||||
, 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, RawFn)
|
|
||||||
fromSubQuery subqueryType subquery = do
|
|
||||||
-- We want to update the IdentState without writing the query to side data
|
-- We want to update the IdentState without writing the query to side data
|
||||||
(ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery
|
(ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery
|
||||||
aliasedValue <- toAlias ret
|
aliasedValue <- toAlias ret
|
||||||
@ -121,13 +101,8 @@ fromSubQuery subqueryType subquery = do
|
|||||||
|
|
||||||
pure (ref, \_ info ->
|
pure (ref, \_ info ->
|
||||||
let (queryText,queryVals) = toRawSql SELECT info aliasedQuery
|
let (queryText,queryVals) = toRawSql SELECT info aliasedQuery
|
||||||
lateralKeyword =
|
|
||||||
case subqueryType of
|
|
||||||
NormalSubQuery -> ""
|
|
||||||
LateralSubQuery -> "LATERAL "
|
|
||||||
in
|
in
|
||||||
( lateralKeyword <> (parens queryText) <> " AS " <> useIdent info subqueryAlias
|
( (parens queryText) <> " AS " <> useIdent info subqueryAlias
|
||||||
, queryVals
|
, queryVals
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|||||||
@ -1,26 +1,18 @@
|
|||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
module Database.Esqueleto.Experimental.From.CommonTableExpression
|
module Database.Esqueleto.Experimental.From.CommonTableExpression
|
||||||
where
|
where
|
||||||
|
|
||||||
import qualified Control.Monad.Trans.Writer as W
|
import qualified Control.Monad.Trans.Writer as W
|
||||||
import qualified Data.Text.Lazy.Builder as TLB
|
import qualified Data.Text.Lazy.Builder as TLB
|
||||||
import Database.Esqueleto.Experimental.From
|
import Database.Esqueleto.Experimental.From
|
||||||
import Database.Esqueleto.Experimental.From.SqlSetOperation
|
import Database.Esqueleto.Experimental.From.SqlSetOperation
|
||||||
import Database.Esqueleto.Experimental.ToAlias
|
import Database.Esqueleto.Experimental.ToAlias
|
||||||
import Database.Esqueleto.Experimental.ToAliasReference
|
import Database.Esqueleto.Experimental.ToAliasReference
|
||||||
import Database.Esqueleto.Internal.Internal hiding
|
import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
|
||||||
(From (..),
|
import Database.Esqueleto.Internal.PersistentImport (DBName(..))
|
||||||
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, (\_ info -> (useIdent info ident, mempty)))
|
|
||||||
|
|
||||||
-- | @WITH@ clause used to introduce a [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression).
|
-- | @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
|
-- CTEs are supported in most modern SQL engines and can be useful
|
||||||
@ -46,7 +38,7 @@ instance From (CommonTableExpression ref) where
|
|||||||
with :: ( ToAlias a
|
with :: ( ToAlias a
|
||||||
, ToAliasReference a
|
, ToAliasReference a
|
||||||
, SqlSelect a r
|
, SqlSelect a r
|
||||||
) => SqlQuery a -> SqlQuery (CommonTableExpression a)
|
) => SqlQuery a -> SqlQuery (From a)
|
||||||
with query = do
|
with query = do
|
||||||
(ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ query
|
(ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ query
|
||||||
aliasedValue <- toAlias ret
|
aliasedValue <- toAlias ret
|
||||||
@ -55,7 +47,7 @@ with query = do
|
|||||||
let clause = CommonTableExpressionClause NormalCommonTableExpression ident (\info -> toRawSql SELECT info aliasedQuery)
|
let clause = CommonTableExpressionClause NormalCommonTableExpression ident (\info -> toRawSql SELECT info aliasedQuery)
|
||||||
Q $ W.tell mempty{sdCteClause = [clause]}
|
Q $ W.tell mempty{sdCteClause = [clause]}
|
||||||
ref <- toAliasReference ident aliasedValue
|
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
|
-- | @WITH@ @RECURSIVE@ allows one to make a recursive subquery, which can
|
||||||
-- reference itself. Like @WITH@, this is supported in most modern SQL engines.
|
-- reference itself. Like @WITH@, this is supported in most modern SQL engines.
|
||||||
@ -92,33 +84,29 @@ with query = do
|
|||||||
withRecursive :: ( ToAlias a
|
withRecursive :: ( ToAlias a
|
||||||
, ToAliasReference a
|
, ToAliasReference a
|
||||||
, SqlSelect a r
|
, SqlSelect a r
|
||||||
, RecursiveCteUnion unionKind
|
|
||||||
)
|
)
|
||||||
=> SqlQuery a
|
=> SqlQuery a
|
||||||
-> unionKind
|
-> UnionKind
|
||||||
-> (CommonTableExpression a -> SqlQuery a)
|
-> (From a -> SqlQuery a)
|
||||||
-> SqlQuery (CommonTableExpression a)
|
-> SqlQuery (From a)
|
||||||
withRecursive baseCase unionKind recursiveCase = do
|
withRecursive baseCase unionKind recursiveCase = do
|
||||||
(ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ baseCase
|
(ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ baseCase
|
||||||
aliasedValue <- toAlias ret
|
aliasedValue <- toAlias ret
|
||||||
let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)
|
let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)
|
||||||
ident <- newIdentFor (DBName "cte")
|
ident <- newIdentFor (DBName "cte")
|
||||||
ref <- toAliasReference ident aliasedValue
|
ref <- toAliasReference ident aliasedValue
|
||||||
let refFrom = CommonTableExpression ident ref
|
let refFrom = From (pure (ref, (\_ info -> (useIdent info ident, mempty))))
|
||||||
let recursiveQuery = recursiveCase refFrom
|
let recursiveQuery = recursiveCase refFrom
|
||||||
let clause = CommonTableExpressionClause RecursiveCommonTableExpression ident
|
let clause = CommonTableExpressionClause RecursiveCommonTableExpression ident
|
||||||
(\info -> (toRawSql SELECT info aliasedQuery)
|
(\info -> (toRawSql SELECT info aliasedQuery)
|
||||||
<> (unionKeyword unionKind, mempty)
|
<> ("\n" <> (unUnionKind unionKind) <> "\n", mempty)
|
||||||
<> (toRawSql SELECT info recursiveQuery)
|
<> (toRawSql SELECT info recursiveQuery)
|
||||||
)
|
)
|
||||||
Q $ W.tell mempty{sdCteClause = [clause]}
|
Q $ W.tell mempty{sdCteClause = [clause]}
|
||||||
pure refFrom
|
pure refFrom
|
||||||
|
|
||||||
class RecursiveCteUnion a where
|
newtype UnionKind = UnionKind { unUnionKind :: TLB.Builder }
|
||||||
unionKeyword :: a -> TLB.Builder
|
instance Union_ UnionKind where
|
||||||
|
union_ = UnionKind "UNION"
|
||||||
instance RecursiveCteUnion (a -> b -> Union a b) where
|
instance UnionAll_ UnionKind where
|
||||||
unionKeyword _ = "\nUNION\n"
|
unionAll_ = UnionKind "UNION ALL"
|
||||||
|
|
||||||
instance RecursiveCteUnion (a -> b -> UnionAll a b) where
|
|
||||||
unionKeyword _ = "\nUNION ALL\n"
|
|
||||||
|
|||||||
@ -1,7 +1,11 @@
|
|||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE FunctionalDependencies #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
@ -12,13 +16,16 @@ module Database.Esqueleto.Experimental.From.Join
|
|||||||
import Data.Bifunctor (first)
|
import Data.Bifunctor (first)
|
||||||
import Data.Kind (Constraint)
|
import Data.Kind (Constraint)
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
|
import qualified Data.Text.Lazy.Builder as TLB
|
||||||
import Database.Esqueleto.Experimental.From
|
import Database.Esqueleto.Experimental.From
|
||||||
import Database.Esqueleto.Experimental.From.SqlSetOperation
|
import Database.Esqueleto.Experimental.From.SqlSetOperation
|
||||||
import Database.Esqueleto.Experimental.ToAlias
|
import Database.Esqueleto.Experimental.ToAlias
|
||||||
import Database.Esqueleto.Experimental.ToAliasReference
|
import Database.Esqueleto.Experimental.ToAliasReference
|
||||||
import Database.Esqueleto.Experimental.ToMaybe
|
import Database.Esqueleto.Experimental.ToMaybe
|
||||||
import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
|
import Database.Esqueleto.Internal.Internal hiding
|
||||||
import Database.Esqueleto.Internal.PersistentImport (Entity(..))
|
(From(..), from, fromJoin, on)
|
||||||
|
import Database.Esqueleto.Internal.PersistentImport
|
||||||
|
(Entity(..), EntityField, PersistEntity, PersistField)
|
||||||
import GHC.TypeLits
|
import GHC.TypeLits
|
||||||
|
|
||||||
-- | A left-precedence pair. Pronounced \"and\". Used to represent expressions
|
-- | A left-precedence pair. Pronounced \"and\". Used to represent expressions
|
||||||
@ -35,6 +42,10 @@ import GHC.TypeLits
|
|||||||
data (:&) a b = a :& b
|
data (:&) a b = a :& b
|
||||||
infixl 2 :&
|
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
|
-- | 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
|
-- the left hand side. This was previously reusing the From class which was actually
|
||||||
-- a bit too lenient as it allowed to much.
|
-- a bit too lenient as it allowed to much.
|
||||||
@ -46,6 +57,7 @@ type family ValidOnClauseValue a :: Constraint where
|
|||||||
ValidOnClauseValue (SqlQuery a) = ()
|
ValidOnClauseValue (SqlQuery a) = ()
|
||||||
ValidOnClauseValue (SqlSetOperation a) = ()
|
ValidOnClauseValue (SqlSetOperation a) = ()
|
||||||
ValidOnClauseValue (a -> SqlQuery b) = ()
|
ValidOnClauseValue (a -> SqlQuery b) = ()
|
||||||
|
ValidOnClauseValue (From a) = ()
|
||||||
ValidOnClauseValue _ = TypeError ('Text "Illegal use of ON")
|
ValidOnClauseValue _ = TypeError ('Text "Illegal use of ON")
|
||||||
|
|
||||||
-- | An @ON@ clause that describes how two tables are related. This should be
|
-- | An @ON@ clause that describes how two tables are related. This should be
|
||||||
@ -62,183 +74,233 @@ on :: ValidOnClauseValue a => a -> (b -> SqlExpr (Value Bool)) -> (a, b -> SqlEx
|
|||||||
on = (,)
|
on = (,)
|
||||||
infix 9 `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
|
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 (a -> SqlQuery b) = TypeError ('Text "LATERAL can only be used for INNER, LEFT, and CROSS join kinds.")
|
||||||
ErrorOnLateral _ = ()
|
ErrorOnLateral _ = ()
|
||||||
|
|
||||||
-- Type class magic to allow the use of the `InnerJoin` family of data constructors in from
|
fromJoin :: TLB.Builder -> RawFn -> RawFn -> Maybe (SqlExpr (Value Bool)) -> RawFn
|
||||||
type family FromOnClause a where
|
fromJoin joinKind lhs rhs monClause =
|
||||||
FromOnClause (a, b -> SqlExpr (Value Bool)) = b
|
|
||||||
FromOnClause a = TypeError ('Text "Missing ON clause")
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
class FromInnerJoin lateral lhs rhs res where
|
|
||||||
runFromInnerJoin :: Proxy lateral -> lhs -> rhs -> (res -> SqlExpr (Value Bool)) -> SqlQuery (res, RawFn)
|
|
||||||
|
|
||||||
fromJoin_ :: RawFn -> JoinKind -> RawFn -> Maybe (SqlExpr (Value Bool)) -> RawFn
|
|
||||||
fromJoin_ lhs kind rhs monClause =
|
|
||||||
\paren info ->
|
\paren info ->
|
||||||
first (parensM paren) $
|
first (parensM paren) $
|
||||||
mconcat [ lhs Never info
|
mconcat [ lhs Never info
|
||||||
, (fromKind kind, mempty)
|
, (joinKind, mempty)
|
||||||
, rhs Parens info
|
, rhs Parens info
|
||||||
, maybe mempty (makeOnClause info) monClause
|
, maybe mempty (makeOnClause info) monClause
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
fromKind InnerJoinKind = " INNER JOIN "
|
|
||||||
fromKind CrossJoinKind = " CROSS JOIN "
|
|
||||||
fromKind LeftOuterJoinKind = " LEFT OUTER JOIN "
|
|
||||||
fromKind RightOuterJoinKind = " RIGHT OUTER JOIN "
|
|
||||||
fromKind FullOuterJoinKind = " FULL OUTER JOIN "
|
|
||||||
|
|
||||||
makeOnClause info (ERaw _ f) = first (" ON " <>) (f Never info)
|
makeOnClause info (ERaw _ f) = first (" ON " <>) (f Never info)
|
||||||
|
|
||||||
instance ( SqlSelect b r
|
type family HasOnClause actual expected :: Constraint where
|
||||||
, ToAlias b
|
HasOnClause (a, b -> SqlExpr (Value Bool)) c = () -- Let the compiler handle the type mismatch
|
||||||
, ToAliasReference b
|
HasOnClause a expected =
|
||||||
, From a
|
TypeError ( 'Text "Missing ON clause for join with"
|
||||||
, FromT a ~ a'
|
':$$: 'ShowType a
|
||||||
) => FromInnerJoin Lateral a (a' -> SqlQuery b) (a' :& b) where
|
':$$: 'Text ""
|
||||||
runFromInnerJoin _ leftPart q on' = do
|
':$$: 'Text "Expected: "
|
||||||
(leftVal, leftFrom) <- runFrom leftPart
|
':$$: 'ShowType a
|
||||||
(rightVal, rightFrom) <- fromSubQuery LateralSubQuery (q leftVal)
|
':$$: 'Text "`on` " ':<>: 'ShowType (expected -> SqlExpr (Value Bool))
|
||||||
let ret = leftVal :& rightVal
|
':$$: 'Text ""
|
||||||
pure $ (ret, fromJoin_ leftFrom InnerJoinKind 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
|
innerJoin :: ( ToFrom a a'
|
||||||
type FromT (InnerJoin a (b, b' -> SqlExpr (Value Bool))) = FromOnClause (b, b' -> SqlExpr(Value Bool))
|
, ToFrom b b'
|
||||||
runFrom (InnerJoin lhs (rhs, on')) = runFromInnerJoin (toProxy rhs) lhs rhs on'
|
, HasOnClause rhs (a' :& b')
|
||||||
where
|
, rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool))
|
||||||
toProxy :: b -> Proxy (IsLateral b)
|
) => a -> rhs -> From (a' :& b')
|
||||||
toProxy _ = Proxy
|
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))
|
||||||
|
|
||||||
type family FromCrossJoin a b where
|
|
||||||
FromCrossJoin a (b -> SqlQuery c) = FromT a :& c
|
|
||||||
FromCrossJoin a b = FromT a :& FromT b
|
|
||||||
|
|
||||||
instance ( From a
|
innerJoinLateral :: ( ToFrom a a'
|
||||||
, From b
|
, HasOnClause rhs (a' :& b)
|
||||||
, FromT (CrossJoin a b) ~ (FromT a :& FromT b)
|
, SqlSelect b r
|
||||||
) => From (CrossJoin a b) where
|
, ToAlias b
|
||||||
type FromT (CrossJoin a b) = FromCrossJoin a b
|
, ToAliasReference b
|
||||||
runFrom (CrossJoin leftPart rightPart) = do
|
, rhs ~ (a' -> SqlQuery b, (a' :& b) -> SqlExpr (Value Bool))
|
||||||
(leftVal, leftFrom) <- runFrom leftPart
|
)
|
||||||
(rightVal, rightFrom) <- runFrom rightPart
|
=> a -> rhs -> From (a' :& b)
|
||||||
let ret = leftVal :& rightVal
|
innerJoinLateral lhs (rhsFn, on') = From $ do
|
||||||
pure $ (ret, fromJoin_ leftFrom CrossJoinKind rightFrom Nothing)
|
(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))
|
||||||
|
|
||||||
instance {-# OVERLAPPING #-}
|
crossJoin :: ( ToFrom a a'
|
||||||
( From a
|
, ToFrom b b'
|
||||||
, FromT a ~ a'
|
) => 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)
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
||||||
|
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
|
, SqlSelect b r
|
||||||
, ToAlias b
|
, ToAlias b
|
||||||
, ToAliasReference b
|
, ToAliasReference b
|
||||||
) => From (CrossJoin a (a' -> SqlQuery b)) where
|
, d ~ (a' :& b)
|
||||||
type FromT (CrossJoin a (a' -> SqlQuery b)) = FromCrossJoin a (a' -> SqlQuery b)
|
) => DoInnerJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where
|
||||||
runFrom (CrossJoin leftPart q) = do
|
doInnerJoin _ = innerJoinLateral
|
||||||
(leftVal, leftFrom) <- runFrom leftPart
|
|
||||||
(rightVal, rightFrom) <- fromSubQuery LateralSubQuery (q leftVal)
|
|
||||||
let ret = leftVal :& rightVal
|
|
||||||
pure $ (ret, fromJoin_ leftFrom CrossJoinKind rightFrom Nothing)
|
|
||||||
|
|
||||||
class FromLeftJoin lateral lhs rhs res where
|
instance ( DoInnerJoin lateral lhs rhs r, lateral ~ IsLateral rhs )
|
||||||
runFromLeftJoin :: Proxy lateral -> lhs -> rhs -> (res -> SqlExpr (Value Bool)) -> SqlQuery (res, RawFn)
|
=> ToFrom (InnerJoin lhs rhs) r where
|
||||||
|
toFrom (InnerJoin a b) = doInnerJoin (Proxy @lateral) a b
|
||||||
|
|
||||||
instance ( From a
|
class DoLeftJoin lateral lhs rhs res | lateral rhs lhs -> res where
|
||||||
, FromT a ~ a'
|
doLeftJoin :: Proxy lateral -> lhs -> rhs -> From res
|
||||||
, SqlSelect b r
|
|
||||||
, ToAlias b
|
instance ( ToFrom a a'
|
||||||
, ToAliasReference b
|
, 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
|
, ToMaybe b
|
||||||
, mb ~ ToMaybeT b
|
, d ~ (a' :& ToMaybeT b)
|
||||||
) => FromLeftJoin Lateral a (a' -> SqlQuery b) (a' :& mb) where
|
, SqlSelect b r
|
||||||
runFromLeftJoin _ leftPart q on' = do
|
, ToAlias b
|
||||||
(leftVal, leftFrom) <- runFrom leftPart
|
, ToAliasReference b
|
||||||
(rightVal, rightFrom) <- fromSubQuery LateralSubQuery (q leftVal)
|
) => DoLeftJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where
|
||||||
let ret = leftVal :& (toMaybe rightVal)
|
doLeftJoin _ = leftJoinLateral
|
||||||
pure $ (ret, fromJoin_ leftFrom LeftOuterJoinKind rightFrom (Just (on' ret)))
|
|
||||||
|
|
||||||
instance ( From a
|
instance ( DoLeftJoin lateral lhs rhs r, lateral ~ IsLateral rhs )
|
||||||
, FromT a ~ a'
|
=> ToFrom (LeftOuterJoin lhs rhs) r where
|
||||||
, From b
|
toFrom (LeftOuterJoin a b) = doLeftJoin (Proxy @lateral) a 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 ( FromLeftJoin (IsLateral b) a b b'
|
class DoCrossJoin lateral lhs rhs res | lateral lhs rhs -> res where
|
||||||
) => From (LeftOuterJoin a (b, b' -> SqlExpr (Value Bool))) where
|
doCrossJoin :: Proxy lateral -> lhs -> rhs -> From res
|
||||||
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
|
|
||||||
|
|
||||||
instance ( From a
|
instance (ToFrom a a', ToFrom b b') => DoCrossJoin NotLateral a b (a' :& b') where
|
||||||
, FromT a ~ a'
|
doCrossJoin _ = crossJoin
|
||||||
, From b
|
instance (ToFrom a a', SqlSelect b r, ToAlias b, ToAliasReference b)
|
||||||
, FromT b ~ 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'
|
, ToMaybe a'
|
||||||
, ma ~ ToMaybeT a'
|
, ToMaybeT a' ~ ma
|
||||||
, ToMaybe b'
|
, HasOnClause rhs (ma :& b')
|
||||||
, mb ~ ToMaybeT b'
|
|
||||||
, ErrorOnLateral b
|
, ErrorOnLateral b
|
||||||
) => From (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) where
|
, rhs ~ (b, (ma :& b') -> SqlExpr (Value Bool))
|
||||||
type FromT (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) = FromOnClause (b, (ma :& mb) -> SqlExpr(Value Bool))
|
) => ToFrom (RightOuterJoin a rhs) (ma :& b') where
|
||||||
runFrom (FullOuterJoin leftPart (rightPart, on')) = do
|
toFrom (RightOuterJoin a b) = rightJoin a b
|
||||||
(leftVal, leftFrom) <- runFrom leftPart
|
|
||||||
(rightVal, rightFrom) <- runFrom rightPart
|
|
||||||
let ret = (toMaybe leftVal) :& (toMaybe rightVal)
|
|
||||||
pure $ (ret, fromJoin_ leftFrom FullOuterJoinKind rightFrom (Just (on' ret)))
|
|
||||||
|
|
||||||
instance ( From a
|
instance ( ToFrom a a'
|
||||||
, FromT a ~ a'
|
, ToFrom b b'
|
||||||
, ToMaybe a'
|
, ToMaybe a'
|
||||||
, ma ~ ToMaybeT a'
|
, ToMaybeT a' ~ ma
|
||||||
, From b
|
, ToMaybe b'
|
||||||
, FromT b ~ b'
|
, ToMaybeT b' ~ mb
|
||||||
|
, HasOnClause rhs (ma :& mb)
|
||||||
, ErrorOnLateral b
|
, ErrorOnLateral b
|
||||||
) => From (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) where
|
, rhs ~ (b, (ma :& mb) -> SqlExpr (Value Bool))
|
||||||
type FromT (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) = FromOnClause (b, (ma :& b') -> SqlExpr(Value Bool))
|
) => ToFrom (FullOuterJoin a rhs) (ma :& mb) where
|
||||||
runFrom (RightOuterJoin leftPart (rightPart, on')) = do
|
toFrom (FullOuterJoin a b) = fullOuterJoin a b
|
||||||
(leftVal, leftFrom) <- runFrom leftPart
|
|
||||||
(rightVal, rightFrom) <- runFrom rightPart
|
|
||||||
let ret = (toMaybe leftVal) :& rightVal
|
|
||||||
pure $ (ret, fromJoin_ leftFrom RightOuterJoinKind rightFrom (Just (on' ret)))
|
|
||||||
|
|
||||||
instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where
|
|
||||||
type ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b)
|
|
||||||
toMaybe (a :& b) = (toMaybe a :& toMaybe b)
|
|
||||||
|
|||||||
@ -1,211 +1,112 @@
|
|||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE FunctionalDependencies #-}
|
{-# LANGUAGE FunctionalDependencies #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE PatternSynonyms #-}
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
module Database.Esqueleto.Experimental.From.SqlSetOperation
|
module Database.Esqueleto.Experimental.From.SqlSetOperation
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad.Trans.Class (lift)
|
import Control.Arrow (first)
|
||||||
import qualified Control.Monad.Trans.State as S
|
import Control.Monad.Trans.Class (lift)
|
||||||
import qualified Control.Monad.Trans.Writer as W
|
import qualified Control.Monad.Trans.State as S
|
||||||
import qualified Data.Text.Lazy.Builder as TLB
|
import qualified Control.Monad.Trans.Writer as W
|
||||||
import Database.Esqueleto.Experimental.From
|
import qualified Data.Text.Lazy.Builder as TLB
|
||||||
import Database.Esqueleto.Experimental.ToAlias
|
import Database.Esqueleto.Experimental.From
|
||||||
import Database.Esqueleto.Experimental.ToAliasReference
|
import Database.Esqueleto.Experimental.ToAlias
|
||||||
import Database.Esqueleto.Internal.Internal hiding
|
import Database.Esqueleto.Experimental.ToAliasReference
|
||||||
(From (..),
|
import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
|
||||||
from, on)
|
import Database.Esqueleto.Internal.PersistentImport
|
||||||
import Database.Esqueleto.Internal.PersistentImport (DBName (..),
|
(DBName(..), Entity, PersistEntity, PersistValue)
|
||||||
PersistValue)
|
|
||||||
|
|
||||||
data SqlSetOperation a
|
newtype SqlSetOperation a = SqlSetOperation
|
||||||
= SqlSetUnion (SqlSetOperation a) (SqlSetOperation a)
|
{ unSqlSetOperation :: NeedParens -> SqlQuery (a, IdentInfo -> (TLB.Builder, [PersistValue]))}
|
||||||
| SqlSetUnionAll (SqlSetOperation a) (SqlSetOperation a)
|
|
||||||
| SqlSetExcept (SqlSetOperation a) (SqlSetOperation a)
|
|
||||||
| SqlSetIntersect (SqlSetOperation a) (SqlSetOperation a)
|
|
||||||
| SelectQueryP NeedParens (SqlQuery a)
|
|
||||||
|
|
||||||
runSetOperation :: (SqlSelect a r, ToAlias a, ToAliasReference a)
|
instance ToAliasReference a => ToFrom (SqlSetOperation a) a where
|
||||||
=> SqlSetOperation a -> SqlQuery (a, NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]))
|
toFrom setOperation = From $ do
|
||||||
runSetOperation operation = do
|
ident <- newIdentFor (DBName "u")
|
||||||
(aliasedOperation, ret) <- aliasQueries operation
|
(a, fromClause) <- unSqlSetOperation setOperation Never
|
||||||
ident <- newIdentFor (DBName "u")
|
ref <- toAliasReference ident a
|
||||||
ref <- toAliasReference ident ret
|
pure (ref, \_ info -> (first parens $ fromClause info) <> (" AS " <> useIdent info ident, mempty))
|
||||||
pure ( ref
|
|
||||||
, \_ info ->
|
|
||||||
let (queryText, queryVals) = operationToSql aliasedOperation info
|
|
||||||
in (parens queryText <> " AS " <> useIdent info ident, queryVals)
|
|
||||||
)
|
|
||||||
|
|
||||||
where
|
class ToSqlSetOperation a r | a -> r where
|
||||||
aliasQueries o =
|
toSqlSetOperation :: a -> SqlSetOperation r
|
||||||
case o of
|
instance ToSqlSetOperation (SqlSetOperation a) a where
|
||||||
SelectQueryP p q -> do
|
toSqlSetOperation = id
|
||||||
(ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ q
|
instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToSqlSetOperation (SqlQuery a) a where
|
||||||
prevState <- Q $ lift S.get
|
toSqlSetOperation subquery =
|
||||||
aliasedRet <- toAlias ret
|
SqlSetOperation $ \p -> do
|
||||||
Q $ lift $ S.put prevState
|
(ret, sideData) <- Q $ W.censor (\_ -> mempty) $ W.listen $ unQ subquery
|
||||||
let p' =
|
state <- Q $ lift S.get
|
||||||
case p of
|
aliasedValue <- toAlias ret
|
||||||
Parens -> Parens
|
Q $ lift $ S.put state
|
||||||
Never ->
|
let aliasedQuery = Q $ W.WriterT $ pure (aliasedValue, sideData)
|
||||||
if (sdLimitClause sideData) /= mempty
|
let p' =
|
||||||
|| length (sdOrderByClause sideData) > 0 then
|
case p of
|
||||||
Parens
|
Parens -> Parens
|
||||||
else
|
Never ->
|
||||||
Never
|
if (sdLimitClause sideData) /= mempty
|
||||||
pure (SelectQueryP p' $ Q $ W.WriterT $ pure (aliasedRet, sideData), aliasedRet)
|
|| length (sdOrderByClause sideData) > 0 then
|
||||||
SqlSetUnion o1 o2 -> do
|
Parens
|
||||||
(o1', ret) <- aliasQueries o1
|
else
|
||||||
(o2', _ ) <- aliasQueries o2
|
Never
|
||||||
pure (SqlSetUnion o1' o2', ret)
|
pure (aliasedValue, \info -> first (parensM p') $ toRawSql SELECT info aliasedQuery)
|
||||||
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)
|
|
||||||
|
|
||||||
|
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" #-}
|
{-# DEPRECATED Union "/Since: 3.4.0.0/ - Use the 'union_' function instead of the 'Union' data constructor" #-}
|
||||||
data Union a b = a `Union` b
|
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
|
class Union_ a where
|
||||||
union_ = Union
|
-- | @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" #-}
|
{-# DEPRECATED UnionAll "/Since: 3.4.0.0/ - Use the 'unionAll_' function instead of the 'UnionAll' data constructor" #-}
|
||||||
data UnionAll a b = a `UnionAll` b
|
data UnionAll a b = a `UnionAll` b
|
||||||
|
instance ToSqlSetOperation a a' => ToSqlSetOperation (UnionAll a a) a' where
|
||||||
-- | @UNION@ @ALL@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
|
toSqlSetOperation (UnionAll a b) = unionAll_ a b
|
||||||
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" #-}
|
{-# DEPRECATED Except "/Since: 3.4.0.0/ - Use the 'except_' function instead of the 'Except' data constructor" #-}
|
||||||
data Except a b = a `Except` b
|
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@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
|
||||||
except_ :: a -> b -> Except a b
|
except_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a'
|
||||||
except_ = Except
|
except_ = mkSetOperation " EXCEPT "
|
||||||
|
|
||||||
{-# DEPRECATED Intersect "/Since: 3.4.0.0/ - Use the 'intersect_' function instead of the 'Intersect' data constructor" #-}
|
{-# DEPRECATED Intersect "/Since: 3.4.0.0/ - Use the 'intersect_' function instead of the 'Intersect' data constructor" #-}
|
||||||
data Intersect a b = a `Intersect` b
|
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@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
|
||||||
intersect_ :: a -> b -> Intersect a b
|
intersect_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a'
|
||||||
intersect_ = Intersect
|
intersect_ = mkSetOperation " 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)
|
|
||||||
|
|
||||||
{-# DEPRECATED SelectQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SelectQuery@" #-}
|
{-# 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 a = a
|
||||||
pattern SelectQuery q = SelectQueryP Never q
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user