{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

module Database.Esqueleto.Experimental.From.CommonTableExpression
    where

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.From.SqlSetOperation
import Database.Esqueleto.Experimental.ToAlias
import Database.Esqueleto.Experimental.ToAliasReference
import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)

-- | @WITH@ clause used to introduce a [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression).
-- CTEs are supported in most modern SQL engines and can be useful
-- in performance tuning. In Esqueleto, CTEs should be used as a
-- subquery memoization tactic. When writing plain SQL, CTEs
-- are sometimes used to organize the SQL code, in Esqueleto, this
-- is better achieved through function that return 'SqlQuery' values.
--
-- @
-- select $ do
-- cte <- with subQuery
-- cteResult <- from cte
-- where_ $ cteResult ...
-- pure cteResult
-- @
--
-- __WARNING__: In some SQL engines using a CTE can diminish performance.
-- In these engines the CTE is treated as an optimization fence. You should
-- always verify that using a CTE will in fact improve your performance
-- over a regular subquery.
--
-- Notably, in PostgreSQL prior to version 12, CTEs are always fully
-- calculated, which can potentially significantly pessimize queries. As of
-- PostgreSQL 12, non-recursive and side-effect-free queries may be inlined and
-- optimized accordingly if not declared @MATERIALIZED@ to get the previous
-- behaviour. See [the PostgreSQL CTE documentation](https://www.postgresql.org/docs/current/queries-with.html#id-1.5.6.12.7),
-- section Materialization, for more information. To use a @MATERIALIZED@ query
-- in Esquelto, see functions 'withMaterialized' and 'withRecursiveMaterialized'.
--
-- /Since: 3.4.0.0/
with :: ( ToAlias a
        , ToAliasReference a
        , SqlSelect a r
        ) => SqlQuery a -> SqlQuery (From a)
with :: forall a r.
(ToAlias a, ToAliasReference a, SqlSelect a r) =>
SqlQuery a -> SqlQuery (From a)
with SqlQuery a
query = do
    (ret, 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
query
    aliasedValue <- toAlias ret
    let 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 a. a -> StateT IdentState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
aliasedValue, SideData
sideData)
    ident <- newIdentFor (DBName "cte")
    let clause = CommonTableExpressionKind
-> CommonTableExpressionModifierAfterAs
-> Ident
-> (IdentInfo -> (Builder, [PersistValue]))
-> CommonTableExpressionClause
CommonTableExpressionClause CommonTableExpressionKind
NormalCommonTableExpression (\CommonTableExpressionClause
_ IdentInfo
_ -> Builder
"")  Ident
ident (\IdentInfo
info -> 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)
    Q $ W.tell mempty{sdCteClause = [clause]}
    ref <- toAliasReference ident aliasedValue
    pure $ From $ do
        newIdent <- newIdentFor (DBName "cte")
        localRef <- toAliasReference newIdent ref
        let makeLH IdentInfo
info = IdentInfo -> Ident -> Builder
useIdent IdentInfo
info Ident
ident Builder -> Builder -> Builder
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
newIdent
        pure (localRef, (\NeedParens
_ IdentInfo
info -> (IdentInfo -> Builder
makeLH IdentInfo
info, [PersistValue]
forall a. Monoid a => a
mempty)))

-- | @WITH@ @RECURSIVE@ allows one to make a recursive subquery, which can
-- reference itself. Like @WITH@, this is supported in most modern SQL engines.
-- Useful for hierarchical, self-referential data, like a tree of data.
--
-- @
-- select $ do
-- cte <- withRecursive
--          (do
--              person <- from $ table \@Person
--              where_ $ person ^. PersonId ==. val personId
--              pure person
--          )
--          unionAll_
--          (\\self -> do
--              (p :& f :& p2 :& pSelf) <- from self
--                       \`innerJoin\` $ table \@Follow
--                       \`on\` (\\(p :& f) ->
--                               p ^. PersonId ==. f ^. FollowFollower)
--                       \`innerJoin\` $ table \@Person
--                       \`on\` (\\(p :& f :& p2) ->
--                               f ^. FollowFollowed ==. p2 ^. PersonId)
--                       \`leftJoin\` self
--                       \`on\` (\\(_ :& _ :& p2 :& pSelf) ->
--                               just (p2 ^. PersonId) ==. pSelf ?. PersonId)
--              where_ $ isNothing (pSelf ?. PersonId)
--              groupBy (p2 ^. PersonId)
--              pure p2
--          )
-- from cte
-- @
--
-- /Since: 3.4.0.0/
withRecursive :: ( ToAlias a
                 , ToAliasReference a
                 , SqlSelect a r
                 )
              => SqlQuery a
              -> UnionKind
              -> (From a -> SqlQuery a)
              -> SqlQuery (From a)
withRecursive :: forall a r.
(ToAlias a, ToAliasReference a, SqlSelect a r) =>
SqlQuery a
-> UnionKind -> (From a -> SqlQuery a) -> SqlQuery (From a)
withRecursive SqlQuery a
baseCase UnionKind
unionKind From a -> SqlQuery a
recursiveCase = do
    (ret, 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
baseCase
    aliasedValue <- toAlias ret
    let 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 a. a -> StateT IdentState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
aliasedValue, SideData
sideData)
    ident <- newIdentFor (DBName "cte")
    ref <- toAliasReference ident aliasedValue
    let refFrom = SqlQuery (a, RawFn) -> From a
forall a. SqlQuery (a, RawFn) -> From a
From ((a, RawFn) -> SqlQuery (a, RawFn)
forall a. a -> SqlQuery a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
ref, (\NeedParens
_ IdentInfo
info -> (IdentInfo -> Ident -> Builder
useIdent IdentInfo
info Ident
ident, [PersistValue]
forall a. Monoid a => a
mempty))))
    let recursiveQuery = From a -> SqlQuery a
recursiveCase From a
refFrom
    let noModifier p
_ p
_ = a
""
    let clause = CommonTableExpressionKind
-> CommonTableExpressionModifierAfterAs
-> Ident
-> (IdentInfo -> (Builder, [PersistValue]))
-> CommonTableExpressionClause
CommonTableExpressionClause CommonTableExpressionKind
RecursiveCommonTableExpression CommonTableExpressionModifierAfterAs
forall {a} {p} {p}. IsString a => p -> p -> a
noModifier Ident
ident
                 (\IdentInfo
info -> (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)
                        (Builder, [PersistValue])
-> (Builder, [PersistValue]) -> (Builder, [PersistValue])
forall a. Semigroup a => a -> a -> a
<> (Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (UnionKind -> Builder
unUnionKind UnionKind
unionKind)  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n", [PersistValue]
forall a. Monoid a => a
mempty)
                        (Builder, [PersistValue])
-> (Builder, [PersistValue]) -> (Builder, [PersistValue])
forall a. Semigroup a => a -> a -> a
<> (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
recursiveQuery)
                 )
    Q $ W.tell mempty{sdCteClause = [clause]}
    pure refFrom

newtype UnionKind = UnionKind { UnionKind -> Builder
unUnionKind :: TLB.Builder }
instance Union_ UnionKind where
    union_ :: UnionKind
union_ = Builder -> UnionKind
UnionKind Builder
"UNION"
instance UnionAll_ UnionKind where
    unionAll_ :: UnionKind
unionAll_ = Builder -> UnionKind
UnionKind Builder
"UNION ALL"