{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}

module Database.Beam.Query.CTE where

import Database.Beam.Backend.SQL
import Database.Beam.Query.Internal
import Database.Beam.Query.Types

import Control.Monad.Free.Church
import Control.Monad.Writer hiding ((<>))
import Control.Monad.State.Strict

import Data.Kind (Type)
import Data.Proxy (Proxy(Proxy))
import Data.String
import Data.Text (Text)

data Recursiveness be where
    Nonrecursive :: Recursiveness be
    Recursive    :: IsSql99RecursiveCommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be)
                 => Recursiveness be

instance Monoid (Recursiveness be) where
    mempty :: Recursiveness be
mempty = forall be. Recursiveness be
Nonrecursive
    mappend :: Recursiveness be -> Recursiveness be -> Recursiveness be
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup (Recursiveness be) where
    Recursiveness be
Recursive <> :: Recursiveness be -> Recursiveness be -> Recursiveness be
<> Recursiveness be
_ = forall be.
IsSql99RecursiveCommonTableExpressionSelectSyntax
  (BeamSqlBackendSelectSyntax be) =>
Recursiveness be
Recursive
    Recursiveness be
_ <> Recursiveness be
Recursive = forall be.
IsSql99RecursiveCommonTableExpressionSelectSyntax
  (BeamSqlBackendSelectSyntax be) =>
Recursiveness be
Recursive
    Recursiveness be
_ <> Recursiveness be
_ = forall be. Recursiveness be
Nonrecursive

-- | Monad in which @SELECT@ statements can be made (via 'selecting')
-- and bound to result names for re-use later. This has the advantage
-- of only computing each result once. In SQL, this is translated to a
-- common table expression.
--
-- Once introduced, results can be re-used in future queries with 'reuse'.
--
-- 'With' is also a member of 'MonadFix' for backends that support
-- recursive CTEs. In this case, you can use @mdo@ or @rec@ notation
-- (with @RecursiveDo@ enabled) to bind result values (again, using
-- 'reuse') even /before/ they're introduced.
--
-- See further documentation <https://haskell-beam.github.io/beam/user-guide/queries/common-table-expressions/ here>.
newtype With be (db :: (Type -> Type) -> Type) a
    = With { forall be (db :: (* -> *) -> *) a.
With be db a
-> WriterT
     (Recursiveness be, [BeamSql99BackendCTESyntax be]) (State Int) a
runWith :: WriterT (Recursiveness be, [ BeamSql99BackendCTESyntax be ])
                                (State Int) a }
    deriving (forall a. a -> With be db a
forall a b. With be db a -> With be db b -> With be db b
forall a b. With be db a -> (a -> With be db b) -> With be db b
forall {be} {db :: (* -> *) -> *}. Applicative (With be db)
forall be (db :: (* -> *) -> *) a. a -> With be db a
forall be (db :: (* -> *) -> *) a b.
With be db a -> With be db b -> With be db b
forall be (db :: (* -> *) -> *) a b.
With be db a -> (a -> With be db b) -> With be db b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> With be db a
$creturn :: forall be (db :: (* -> *) -> *) a. a -> With be db a
>> :: forall a b. With be db a -> With be db b -> With be db b
$c>> :: forall be (db :: (* -> *) -> *) a b.
With be db a -> With be db b -> With be db b
>>= :: forall a b. With be db a -> (a -> With be db b) -> With be db b
$c>>= :: forall be (db :: (* -> *) -> *) a b.
With be db a -> (a -> With be db b) -> With be db b
Monad, forall a. a -> With be db a
forall a b. With be db a -> With be db b -> With be db a
forall a b. With be db a -> With be db b -> With be db b
forall a b. With be db (a -> b) -> With be db a -> With be db b
forall a b c.
(a -> b -> c) -> With be db a -> With be db b -> With be db c
forall {be} {db :: (* -> *) -> *}. Functor (With be db)
forall be (db :: (* -> *) -> *) a. a -> With be db a
forall be (db :: (* -> *) -> *) a b.
With be db a -> With be db b -> With be db a
forall be (db :: (* -> *) -> *) a b.
With be db a -> With be db b -> With be db b
forall be (db :: (* -> *) -> *) a b.
With be db (a -> b) -> With be db a -> With be db b
forall be (db :: (* -> *) -> *) a b c.
(a -> b -> c) -> With be db a -> With be db b -> With be db c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. With be db a -> With be db b -> With be db a
$c<* :: forall be (db :: (* -> *) -> *) a b.
With be db a -> With be db b -> With be db a
*> :: forall a b. With be db a -> With be db b -> With be db b
$c*> :: forall be (db :: (* -> *) -> *) a b.
With be db a -> With be db b -> With be db b
liftA2 :: forall a b c.
(a -> b -> c) -> With be db a -> With be db b -> With be db c
$cliftA2 :: forall be (db :: (* -> *) -> *) a b c.
(a -> b -> c) -> With be db a -> With be db b -> With be db c
<*> :: forall a b. With be db (a -> b) -> With be db a -> With be db b
$c<*> :: forall be (db :: (* -> *) -> *) a b.
With be db (a -> b) -> With be db a -> With be db b
pure :: forall a. a -> With be db a
$cpure :: forall be (db :: (* -> *) -> *) a. a -> With be db a
Applicative, forall a b. a -> With be db b -> With be db a
forall a b. (a -> b) -> With be db a -> With be db b
forall be (db :: (* -> *) -> *) a b.
a -> With be db b -> With be db a
forall be (db :: (* -> *) -> *) a b.
(a -> b) -> With be db a -> With be db b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> With be db b -> With be db a
$c<$ :: forall be (db :: (* -> *) -> *) a b.
a -> With be db b -> With be db a
fmap :: forall a b. (a -> b) -> With be db a -> With be db b
$cfmap :: forall be (db :: (* -> *) -> *) a b.
(a -> b) -> With be db a -> With be db b
Functor)

instance IsSql99RecursiveCommonTableExpressionSelectSyntax (BeamSqlBackendSelectSyntax be)
    => MonadFix (With be db) where
    mfix :: forall a. (a -> With be db a) -> With be db a
mfix a -> With be db a
f = forall be (db :: (* -> *) -> *) a.
WriterT
  (Recursiveness be, [BeamSql99BackendCTESyntax be]) (State Int) a
-> With be db a
With (forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (forall be.
IsSql99RecursiveCommonTableExpressionSelectSyntax
  (BeamSqlBackendSelectSyntax be) =>
Recursiveness be
Recursive, forall a. Monoid a => a
mempty) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall be (db :: (* -> *) -> *) a.
With be db a
-> WriterT
     (Recursiveness be, [BeamSql99BackendCTESyntax be]) (State Int) a
runWith forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> With be db a
f))

data QAnyScope

-- | Query results that have been introduced into a common table
-- expression via 'selecting' that can be used in future queries with
-- 'reuse'.
data ReusableQ be db res where
    ReusableQ :: Proxy res -> (forall s. Proxy s -> Q be db s (WithRewrittenThread QAnyScope s res)) -> ReusableQ be db res

reusableForCTE :: forall be res db
                . ( ThreadRewritable QAnyScope res
                  , Projectible be res
                  , BeamSqlBackend be )
               => Text -> ReusableQ be db res
reusableForCTE :: forall be res (db :: (* -> *) -> *).
(ThreadRewritable QAnyScope res, Projectible be res,
 BeamSqlBackend be) =>
Text -> ReusableQ be db res
reusableForCTE Text
tblNm =
    forall res be (db :: (* -> *) -> *).
Proxy res
-> (forall s.
    Proxy s -> Q be db s (WithRewrittenThread QAnyScope s res))
-> ReusableQ be db res
ReusableQ (forall {k} (t :: k). Proxy t
Proxy @res)
              (\Proxy s
proxyS ->
                 forall be (db :: (* -> *) -> *) s a. QM be db s a -> Q be db s a
Q forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (forall be r next (db :: (* -> *) -> *) s.
Projectible be r =>
(Text -> Text -> BeamSqlBackendFromSyntax be)
-> (Text -> r)
-> (r
    -> Maybe (WithExprContext (BeamSqlBackendExpressionSyntax be)))
-> ((Text, r) -> next)
-> QF be db s next
QAll (\Text
_ -> forall from.
IsSql92FromSyntax from =>
Sql92FromTableSourceSyntax from
-> Maybe (Text, Maybe [Text]) -> from
fromTable (forall tblSource.
IsSql92TableSourceSyntax tblSource =>
Sql92TableSourceTableNameSyntax tblSource -> tblSource
tableNamed (forall tblName.
IsSql92TableNameSyntax tblName =>
Maybe Text -> Text -> tblName
tableName forall a. Maybe a
Nothing Text
tblNm)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, forall a. Maybe a
Nothing))
                                 (\Text
tblNm' -> forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall be res.
(BeamSqlBackend be, Projectible be res) =>
(Text -> BeamSqlBackendFieldNameSyntax be) -> (res, [Text])
mkFieldNames @be @res (forall fn. IsSql92FieldNameSyntax fn => Text -> Text -> fn
qualifiedField Text
tblNm'))
                                 (\res
_ -> forall a. Maybe a
Nothing)
                                 (forall s a s'.
ThreadRewritable s a =>
Proxy s' -> a -> WithRewrittenThread s s' a
rewriteThread @QAnyScope @res Proxy s
proxyS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)))

-- | Introduce the result of a query as a result in a common table
-- expression. The returned value can be used in future queries by
-- applying 'reuse'.
selecting :: forall res be db
           . ( BeamSql99CommonTableExpressionBackend be, HasQBuilder be
             , Projectible be res
             , ThreadRewritable QAnyScope res )
          => Q be db QAnyScope res -> With be db (ReusableQ be db res)
selecting :: forall res be (db :: (* -> *) -> *).
(BeamSql99CommonTableExpressionBackend be, HasQBuilder be,
 Projectible be res, ThreadRewritable QAnyScope res) =>
Q be db QAnyScope res -> With be db (ReusableQ be db res)
selecting Q be db QAnyScope res
q =
  forall be (db :: (* -> *) -> *) a.
WriterT
  (Recursiveness be, [BeamSql99BackendCTESyntax be]) (State Int) a
-> With be db a
With forall a b. (a -> b) -> a -> b
$ do
    Int
cteId <- forall s (m :: * -> *). MonadState s m => m s
get
    forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
cteId forall a. Num a => a -> a -> a
+ Int
1)

    let tblNm :: Text
tblNm = forall a. IsString a => [Char] -> a
fromString ([Char]
"cte" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
cteId)

        (res
_ :: res, [Text]
fieldNames) = forall be res.
(BeamSqlBackend be, Projectible be res) =>
(Text -> BeamSqlBackendFieldNameSyntax be) -> (res, [Text])
mkFieldNames @be (forall fn. IsSql92FieldNameSyntax fn => Text -> Text -> fn
qualifiedField Text
tblNm)
    forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (forall be. Recursiveness be
Nonrecursive, [ forall syntax.
IsSql99CommonTableExpressionSyntax syntax =>
Text -> [Text] -> Sql99CTESelectSyntax syntax -> syntax
cteSubquerySyntax Text
tblNm [Text]
fieldNames (forall be a (db :: (* -> *) -> *) s.
(HasQBuilder be, Projectible be a) =>
Text -> Q be db s a -> BeamSqlBackendSelectSyntax be
buildSqlQuery (Text
tblNm forall a. Semigroup a => a -> a -> a
<> Text
"_") Q be db QAnyScope res
q) ])

    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall be res (db :: (* -> *) -> *).
(ThreadRewritable QAnyScope res, Projectible be res,
 BeamSqlBackend be) =>
Text -> ReusableQ be db res
reusableForCTE Text
tblNm)

-- | Introduces the result of a previous 'selecting' (a CTE) into a new query
reuse :: forall s be db res
       . ReusableQ be db res -> Q be db s (WithRewrittenThread QAnyScope s res)
reuse :: forall s be (db :: (* -> *) -> *) res.
ReusableQ be db res
-> Q be db s (WithRewrittenThread QAnyScope s res)
reuse (ReusableQ Proxy res
_ forall s.
Proxy s -> Q be db s (WithRewrittenThread QAnyScope s res)
q) = forall s.
Proxy s -> Q be db s (WithRewrittenThread QAnyScope s res)
q (forall {k} (t :: k). Proxy t
Proxy @s)