{-# 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
    { forall a.
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 = forall a. SqlQuery (a, RawFn) -> From a
From 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) <- forall a.
SqlSetOperation a
-> NeedParens
-> SqlQuery (a, IdentInfo -> (Builder, [PersistValue]))
unSqlSetOperation SqlSetOperation a
setOperation NeedParens
Never
        a
ref <- forall a. ToAliasReference a => Ident -> a -> SqlQuery a
toAliasReference Ident
ident a
a
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
ref, \NeedParens
_ IdentInfo
info -> (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Builder -> Builder
parens forall a b. (a -> b) -> a -> b
$ IdentInfo -> (Builder, [PersistValue])
fromClause IdentInfo
info) forall a. Semigroup a => a -> a -> a
<> (Builder
" AS " forall a. Semigroup a => a -> a -> a
<> IdentInfo -> Ident -> Builder
useIdent IdentInfo
info Ident
ident, 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 = 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 =
        forall a.
(NeedParens
 -> SqlQuery (a, IdentInfo -> (Builder, [PersistValue])))
-> SqlSetOperation a
SqlSetOperation forall a b. (a -> b) -> a -> b
$ \NeedParens
p -> do
            (a
ret, SideData
sideData) <- forall a. WriterT SideData (State IdentState) a -> SqlQuery a
Q forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) w a.
Monad m =>
(w -> w) -> WriterT w m a -> WriterT w m a
W.censor (\SideData
_ -> forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) w a.
Monad m =>
WriterT w m a -> WriterT w m (a, w)
W.listen forall a b. (a -> b) -> a -> b
$ forall a. SqlQuery a -> WriterT SideData (State IdentState) a
unQ SqlQuery a
subquery
            a
aliasedValue <- forall a. ToAlias a => a -> SqlQuery a
toAlias a
ret
            let aliasedQuery :: SqlQuery a
aliasedQuery = forall a. WriterT SideData (State IdentState) a -> SqlQuery a
Q forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
W.WriterT forall a b. (a -> b) -> a -> b
$ 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) forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty
                          Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Int
length (SideData -> [OrderByClause]
sdOrderByClause SideData
sideData) forall a. Ord a => a -> a -> Bool
> Int
0 then
                        NeedParens
Parens
                      else
                        NeedParens
Never
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
aliasedValue, \IdentInfo
info -> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (NeedParens -> Builder -> Builder
parensM NeedParens
p') forall a b. (a -> b) -> a -> b
$ 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 :: forall a a' b.
(ToSqlSetOperation a a', ToSqlSetOperation b a') =>
Builder -> a -> b -> SqlSetOperation a'
mkSetOperation Builder
operation a
lhs b
rhs = forall a.
(NeedParens
 -> SqlQuery (a, IdentInfo -> (Builder, [PersistValue])))
-> SqlSetOperation a
SqlSetOperation forall a b. (a -> b) -> a -> b
$ \NeedParens
p -> do
    IdentState
state <- forall a. WriterT SideData (State IdentState) a -> SqlQuery a
Q forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *) s. Monad m => StateT s m s
S.get
    (a'
leftValue, IdentInfo -> (Builder, [PersistValue])
leftClause) <- forall a.
SqlSetOperation a
-> NeedParens
-> SqlQuery (a, IdentInfo -> (Builder, [PersistValue]))
unSqlSetOperation (forall a r. ToSqlSetOperation a r => a -> SqlSetOperation r
toSqlSetOperation a
lhs) NeedParens
p
    forall a. WriterT SideData (State IdentState) a -> SqlQuery a
Q forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => s -> StateT s m ()
S.put IdentState
state
    (a'
_, IdentInfo -> (Builder, [PersistValue])
rightClause) <- forall a.
SqlSetOperation a
-> NeedParens
-> SqlQuery (a, IdentInfo -> (Builder, [PersistValue]))
unSqlSetOperation (forall a r. ToSqlSetOperation a r => a -> SqlSetOperation r
toSqlSetOperation b
rhs) NeedParens
p
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (a'
leftValue, \IdentInfo
info -> IdentInfo -> (Builder, [PersistValue])
leftClause IdentInfo
info forall a. Semigroup a => a -> a -> a
<> (Builder
operation, forall a. Monoid a => a
mempty) 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) = 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_ = 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_ = 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) = 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) = 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_ :: forall a a' b.
(ToSqlSetOperation a a', ToSqlSetOperation b a') =>
a -> b -> SqlSetOperation a'
except_ = 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) = 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_ :: forall a a' b.
(ToSqlSetOperation a a', ToSqlSetOperation b a') =>
a -> b -> SqlSetOperation a'
intersect_ = 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 SelectQuery :: p -> p
pattern $bSelectQuery :: forall a. a -> a
$mSelectQuery :: forall {r} {p}. p -> (p -> r) -> ((# #) -> r) -> r
SelectQuery a = a