{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# 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 (PersistValue)

-- | Data type used to implement the SqlSetOperation language
-- this type is implemented in the same way as a @From@
--
-- Semantically a @SqlSetOperation@ is always a @From@ but not vice versa
--
-- @since 3.5.0.0
newtype SqlSetOperation a = SqlSetOperation
    { SqlSetOperation a
-> NeedParens
-> SqlQuery (a, IdentInfo -> (Builder, [PersistValue]))
unSqlSetOperation :: NeedParens -> SqlQuery (a, IdentInfo -> (TLB.Builder, [PersistValue]))}

instance ToAliasReference a => ToFrom (SqlSetOperation a) a where
    toFrom :: SqlSetOperation a -> From a
toFrom SqlSetOperation a
setOperation = SqlQuery (a, RawFn) -> From a
forall a. SqlQuery (a, RawFn) -> From a
From (SqlQuery (a, RawFn) -> From a) -> SqlQuery (a, RawFn) -> From a
forall a b. (a -> b) -> a -> b
$ do
        Ident
ident <- DBName -> SqlQuery Ident
newIdentFor (Text -> DBName
DBName Text
"u")
        (a
a, IdentInfo -> (Builder, [PersistValue])
fromClause) <- SqlSetOperation a
-> NeedParens
-> SqlQuery (a, IdentInfo -> (Builder, [PersistValue]))
forall a.
SqlSetOperation a
-> NeedParens
-> SqlQuery (a, IdentInfo -> (Builder, [PersistValue]))
unSqlSetOperation SqlSetOperation a
setOperation NeedParens
Never
        a
ref <- Ident -> a -> SqlQuery a
forall a. ToAliasReference a => Ident -> a -> SqlQuery a
toAliasReference Ident
ident a
a
        (a, RawFn) -> SqlQuery (a, RawFn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
ref, \NeedParens
_ IdentInfo
info -> ((Builder -> Builder)
-> (Builder, [PersistValue]) -> (Builder, [PersistValue])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Builder -> Builder
parens ((Builder, [PersistValue]) -> (Builder, [PersistValue]))
-> (Builder, [PersistValue]) -> (Builder, [PersistValue])
forall a b. (a -> b) -> a -> b
$ IdentInfo -> (Builder, [PersistValue])
fromClause IdentInfo
info) (Builder, [PersistValue])
-> (Builder, [PersistValue]) -> (Builder, [PersistValue])
forall a. Semigroup a => a -> a -> a
<> (Builder
" AS " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> IdentInfo -> Ident -> Builder
useIdent IdentInfo
info Ident
ident, [PersistValue]
forall a. Monoid a => a
mempty))

-- | Type class to support direct use of @SqlQuery@ in a set operation tree
--
-- @since 3.5.0.0
class ToSqlSetOperation a r | a -> r where
    toSqlSetOperation :: a -> SqlSetOperation r
instance ToSqlSetOperation (SqlSetOperation a) a where
    toSqlSetOperation :: SqlSetOperation a -> SqlSetOperation a
toSqlSetOperation = SqlSetOperation a -> SqlSetOperation a
forall a. a -> a
id
instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToSqlSetOperation (SqlQuery a) a where
    toSqlSetOperation :: SqlQuery a -> SqlSetOperation a
toSqlSetOperation SqlQuery a
subquery =
        (NeedParens
 -> SqlQuery (a, IdentInfo -> (Builder, [PersistValue])))
-> SqlSetOperation a
forall a.
(NeedParens
 -> SqlQuery (a, IdentInfo -> (Builder, [PersistValue])))
-> SqlSetOperation a
SqlSetOperation ((NeedParens
  -> SqlQuery (a, IdentInfo -> (Builder, [PersistValue])))
 -> SqlSetOperation a)
-> (NeedParens
    -> SqlQuery (a, IdentInfo -> (Builder, [PersistValue])))
-> SqlSetOperation a
forall a b. (a -> b) -> a -> b
$ \NeedParens
p -> do
            (a
ret, SideData
sideData) <- WriterT SideData (State IdentState) (a, SideData)
-> SqlQuery (a, SideData)
forall a. WriterT SideData (State IdentState) a -> SqlQuery a
Q (WriterT SideData (State IdentState) (a, SideData)
 -> SqlQuery (a, SideData))
-> WriterT SideData (State IdentState) (a, SideData)
-> SqlQuery (a, SideData)
forall a b. (a -> b) -> a -> b
$ (SideData -> SideData)
-> WriterT SideData (State IdentState) (a, SideData)
-> WriterT SideData (State IdentState) (a, SideData)
forall (m :: * -> *) w a.
Monad m =>
(w -> w) -> WriterT w m a -> WriterT w m a
W.censor (\SideData
_ -> SideData
forall a. Monoid a => a
mempty) (WriterT SideData (State IdentState) (a, SideData)
 -> WriterT SideData (State IdentState) (a, SideData))
-> WriterT SideData (State IdentState) (a, SideData)
-> WriterT SideData (State IdentState) (a, SideData)
forall a b. (a -> b) -> a -> b
$ WriterT SideData (State IdentState) a
-> WriterT SideData (State IdentState) (a, SideData)
forall (m :: * -> *) w a.
Monad m =>
WriterT w m a -> WriterT w m (a, w)
W.listen (WriterT SideData (State IdentState) a
 -> WriterT SideData (State IdentState) (a, SideData))
-> WriterT SideData (State IdentState) a
-> WriterT SideData (State IdentState) (a, SideData)
forall a b. (a -> b) -> a -> b
$ SqlQuery a -> WriterT SideData (State IdentState) a
forall a. SqlQuery a -> WriterT SideData (State IdentState) a
unQ SqlQuery a
subquery
            IdentState
state <- WriterT SideData (State IdentState) IdentState
-> SqlQuery IdentState
forall a. WriterT SideData (State IdentState) a -> SqlQuery a
Q (WriterT SideData (State IdentState) IdentState
 -> SqlQuery IdentState)
-> WriterT SideData (State IdentState) IdentState
-> SqlQuery IdentState
forall a b. (a -> b) -> a -> b
$ StateT IdentState Identity IdentState
-> WriterT SideData (State IdentState) IdentState
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT IdentState Identity IdentState
forall (m :: * -> *) s. Monad m => StateT s m s
S.get
            a
aliasedValue <- a -> SqlQuery a
forall a. ToAlias a => a -> SqlQuery a
toAlias a
ret
            WriterT SideData (State IdentState) () -> SqlQuery ()
forall a. WriterT SideData (State IdentState) a -> SqlQuery a
Q (WriterT SideData (State IdentState) () -> SqlQuery ())
-> WriterT SideData (State IdentState) () -> SqlQuery ()
forall a b. (a -> b) -> a -> b
$ StateT IdentState Identity ()
-> WriterT SideData (State IdentState) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT IdentState Identity ()
 -> WriterT SideData (State IdentState) ())
-> StateT IdentState Identity ()
-> WriterT SideData (State IdentState) ()
forall a b. (a -> b) -> a -> b
$ IdentState -> StateT IdentState Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
S.put IdentState
state
            let aliasedQuery :: SqlQuery a
aliasedQuery = WriterT SideData (State IdentState) a -> SqlQuery a
forall a. WriterT SideData (State IdentState) a -> SqlQuery a
Q (WriterT SideData (State IdentState) a -> SqlQuery a)
-> WriterT SideData (State IdentState) a -> SqlQuery a
forall a b. (a -> b) -> a -> b
$ State IdentState (a, SideData)
-> WriterT SideData (State IdentState) a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
W.WriterT (State IdentState (a, SideData)
 -> WriterT SideData (State IdentState) a)
-> State IdentState (a, SideData)
-> WriterT SideData (State IdentState) a
forall a b. (a -> b) -> a -> b
$ (a, SideData) -> State IdentState (a, SideData)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
aliasedValue, SideData
sideData)
            let p' :: NeedParens
p' =
                  case NeedParens
p of
                    NeedParens
Parens -> NeedParens
Parens
                    NeedParens
Never ->
                      if (SideData -> LimitClause
sdLimitClause SideData
sideData) LimitClause -> LimitClause -> Bool
forall a. Eq a => a -> a -> Bool
/= LimitClause
forall a. Monoid a => a
mempty
                          Bool -> Bool -> Bool
|| [OrderByClause] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (SideData -> [OrderByClause]
sdOrderByClause SideData
sideData) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then
                        NeedParens
Parens
                      else
                        NeedParens
Never
            (a, IdentInfo -> (Builder, [PersistValue]))
-> SqlQuery (a, IdentInfo -> (Builder, [PersistValue]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
aliasedValue, \IdentInfo
info -> (Builder -> Builder)
-> (Builder, [PersistValue]) -> (Builder, [PersistValue])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (NeedParens -> Builder -> Builder
parensM NeedParens
p') ((Builder, [PersistValue]) -> (Builder, [PersistValue]))
-> (Builder, [PersistValue]) -> (Builder, [PersistValue])
forall a b. (a -> b) -> a -> b
$ Mode -> IdentInfo -> SqlQuery a -> (Builder, [PersistValue])
forall a r backend.
(SqlSelect a r, BackendCompatible SqlBackend backend) =>
Mode
-> (backend, IdentState) -> SqlQuery a -> (Builder, [PersistValue])
toRawSql Mode
SELECT IdentInfo
info SqlQuery a
aliasedQuery)

-- | Helper function for defining set operations
-- @since 3.5.0.0
mkSetOperation :: (ToSqlSetOperation a a', ToSqlSetOperation b a')
               => TLB.Builder -> a -> b -> SqlSetOperation a'
mkSetOperation :: Builder -> a -> b -> SqlSetOperation a'
mkSetOperation Builder
operation a
lhs b
rhs = (NeedParens
 -> SqlQuery (a', IdentInfo -> (Builder, [PersistValue])))
-> SqlSetOperation a'
forall a.
(NeedParens
 -> SqlQuery (a, IdentInfo -> (Builder, [PersistValue])))
-> SqlSetOperation a
SqlSetOperation ((NeedParens
  -> SqlQuery (a', IdentInfo -> (Builder, [PersistValue])))
 -> SqlSetOperation a')
-> (NeedParens
    -> SqlQuery (a', IdentInfo -> (Builder, [PersistValue])))
-> SqlSetOperation a'
forall a b. (a -> b) -> a -> b
$ \NeedParens
p -> do
    (a'
leftValue, IdentInfo -> (Builder, [PersistValue])
leftClause) <- SqlSetOperation a'
-> NeedParens
-> SqlQuery (a', IdentInfo -> (Builder, [PersistValue]))
forall a.
SqlSetOperation a
-> NeedParens
-> SqlQuery (a, IdentInfo -> (Builder, [PersistValue]))
unSqlSetOperation (a -> SqlSetOperation a'
forall a r. ToSqlSetOperation a r => a -> SqlSetOperation r
toSqlSetOperation a
lhs) NeedParens
p
    (a'
_, IdentInfo -> (Builder, [PersistValue])
rightClause) <- SqlSetOperation a'
-> NeedParens
-> SqlQuery (a', IdentInfo -> (Builder, [PersistValue]))
forall a.
SqlSetOperation a
-> NeedParens
-> SqlQuery (a, IdentInfo -> (Builder, [PersistValue]))
unSqlSetOperation (b -> SqlSetOperation a'
forall a r. ToSqlSetOperation a r => a -> SqlSetOperation r
toSqlSetOperation b
rhs) NeedParens
p
    (a', IdentInfo -> (Builder, [PersistValue]))
-> SqlQuery (a', IdentInfo -> (Builder, [PersistValue]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a'
leftValue, \IdentInfo
info -> IdentInfo -> (Builder, [PersistValue])
leftClause IdentInfo
info (Builder, [PersistValue])
-> (Builder, [PersistValue]) -> (Builder, [PersistValue])
forall a. Semigroup a => a -> a -> a
<> (Builder
operation, [PersistValue]
forall a. Monoid a => a
mempty) (Builder, [PersistValue])
-> (Builder, [PersistValue]) -> (Builder, [PersistValue])
forall a. Semigroup a => a -> a -> a
<> IdentInfo -> (Builder, [PersistValue])
rightClause IdentInfo
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 a -> SqlSetOperation a'
toSqlSetOperation (Union a
a a
b) = a -> a -> SqlSetOperation a'
forall a. Union_ a => a
union_ a
a a
b

-- | Overloaded @union_@ function to support use in both 'SqlSetOperation'
-- and 'withRecursive'
--
-- @since 3.5.0.0
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_ :: a -> b -> res
union_ = Builder -> a -> b -> SqlSetOperation c
forall a a' b.
(ToSqlSetOperation a a', ToSqlSetOperation b a') =>
Builder -> a -> b -> SqlSetOperation a'
mkSetOperation Builder
" UNION "

-- | Overloaded @unionAll_@ function to support use in both 'SqlSetOperation'
-- and 'withRecursive'
--
-- @since 3.5.0.0
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_ :: a -> b -> res
unionAll_ = Builder -> a -> b -> SqlSetOperation c
forall a a' b.
(ToSqlSetOperation a a', ToSqlSetOperation b a') =>
Builder -> a -> b -> SqlSetOperation a'
mkSetOperation Builder
" 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
instance ToSqlSetOperation a a' => ToSqlSetOperation (UnionAll a a) a' where
    toSqlSetOperation :: UnionAll a a -> SqlSetOperation a'
toSqlSetOperation (UnionAll a
a a
b) = a -> a -> SqlSetOperation a'
forall a. UnionAll_ a => a
unionAll_ a
a 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 a -> SqlSetOperation a'
toSqlSetOperation (Except a
a a
b) = a -> a -> SqlSetOperation a'
forall a a' b.
(ToSqlSetOperation a a', ToSqlSetOperation b a') =>
a -> b -> SqlSetOperation a'
except_ a
a a
b

-- | @EXCEPT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
except_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a'
except_ :: a -> b -> SqlSetOperation a'
except_ = Builder -> a -> b -> SqlSetOperation a'
forall a a' b.
(ToSqlSetOperation a a', ToSqlSetOperation b a') =>
Builder -> a -> b -> SqlSetOperation a'
mkSetOperation Builder
" 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 a -> SqlSetOperation a'
toSqlSetOperation (Intersect a
a a
b) = a -> a -> SqlSetOperation a'
forall a a' b.
(ToSqlSetOperation a a', ToSqlSetOperation b a') =>
a -> b -> SqlSetOperation a'
intersect_ a
a a
b

-- | @INTERSECT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values.
intersect_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a'
intersect_ :: a -> b -> SqlSetOperation a'
intersect_ = Builder -> a -> b -> SqlSetOperation a'
forall a a' b.
(ToSqlSetOperation a a', ToSqlSetOperation b a') =>
Builder -> a -> b -> SqlSetOperation a'
mkSetOperation Builder
" INTERSECT "

{-# DEPRECATED SelectQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SelectQuery@" #-}
pattern $bSelectQuery :: p -> p
$mSelectQuery :: forall r p. p -> (p -> r) -> (Void# -> r) -> r
SelectQuery a = a