{-# 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.Fix
import Control.Monad.Free.Church
import Control.Monad.Writer (WriterT, tell)
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 = Recursiveness be
forall be. Recursiveness be
Nonrecursive
    mappend :: Recursiveness be -> Recursiveness be -> Recursiveness be
mappend = Recursiveness be -> Recursiveness be -> Recursiveness be
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup (Recursiveness be) where
    Recursiveness be
Recursive <> :: Recursiveness be -> Recursiveness be -> Recursiveness be
<> Recursiveness be
_ = Recursiveness be
forall be.
IsSql99RecursiveCommonTableExpressionSelectSyntax
  (BeamSqlBackendSelectSyntax be) =>
Recursiveness be
Recursive
    Recursiveness be
_ <> Recursiveness be
Recursive = Recursiveness be
forall be.
IsSql99RecursiveCommonTableExpressionSelectSyntax
  (BeamSqlBackendSelectSyntax be) =>
Recursiveness be
Recursive
    Recursiveness be
_ <> 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 (Applicative (With be db)
Applicative (With be db) =>
(forall a b. With be db a -> (a -> With be db b) -> With be db b)
-> (forall a b. With be db a -> With be db b -> With be db b)
-> (forall a. a -> With be db a)
-> Monad (With be db)
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
$c>>= :: forall be (db :: (* -> *) -> *) a b.
With be db a -> (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 -> With be db b -> With be db b
>> :: forall a b. With be db a -> With be db b -> With be db b
$creturn :: forall be (db :: (* -> *) -> *) a. a -> With be db a
return :: forall a. a -> With be db a
Monad, Functor (With be db)
Functor (With be db) =>
(forall a. a -> With be db a)
-> (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 a b. With be db a -> With be db b -> With be db b)
-> (forall a b. With be db a -> With be db b -> With be db a)
-> Applicative (With be db)
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
$cpure :: forall be (db :: (* -> *) -> *) a. a -> With be db a
pure :: forall a. a -> With be db a
$c<*> :: forall be (db :: (* -> *) -> *) a b.
With be db (a -> b) -> With be db a -> With be db b
<*> :: forall a b. With be db (a -> b) -> With be db a -> With be db b
$cliftA2 :: forall be (db :: (* -> *) -> *) a b c.
(a -> b -> c) -> With be db a -> With be db b -> With be db c
liftA2 :: forall a b c.
(a -> b -> c) -> With be db a -> With be db b -> With be db c
$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 -> 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 a
<* :: forall a b. With be db a -> With be db b -> With be db a
Applicative, (forall a b. (a -> b) -> With be db a -> With be db b)
-> (forall a b. a -> With be db b -> With be db a)
-> Functor (With be db)
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
$cfmap :: forall be (db :: (* -> *) -> *) a b.
(a -> b) -> With be db a -> With be db b
fmap :: forall a b. (a -> b) -> With be db a -> With be db b
$c<$ :: forall be (db :: (* -> *) -> *) a b.
a -> With be db b -> With be db a
<$ :: forall a b. a -> With be db b -> With be db a
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 = WriterT
  (Recursiveness be,
   [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)])
  (State Int)
  a
-> With be db a
forall be (db :: (* -> *) -> *) a.
WriterT
  (Recursiveness be, [BeamSql99BackendCTESyntax be]) (State Int) a
-> With be db a
With ((Recursiveness be,
 [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)])
-> WriterT
     (Recursiveness be,
      [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)])
     (State Int)
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Recursiveness be
forall be.
IsSql99RecursiveCommonTableExpressionSelectSyntax
  (BeamSqlBackendSelectSyntax be) =>
Recursiveness be
Recursive, [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)]
forall a. Monoid a => a
mempty) WriterT
  (Recursiveness be,
   [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)])
  (State Int)
  ()
-> WriterT
     (Recursiveness be,
      [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)])
     (State Int)
     a
-> WriterT
     (Recursiveness be,
      [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)])
     (State Int)
     a
forall a b.
WriterT
  (Recursiveness be,
   [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)])
  (State Int)
  a
-> WriterT
     (Recursiveness be,
      [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)])
     (State Int)
     b
-> WriterT
     (Recursiveness be,
      [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)])
     (State Int)
     b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (a
 -> WriterT
      (Recursiveness be,
       [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)])
      (State Int)
      a)
-> WriterT
     (Recursiveness be,
      [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)])
     (State Int)
     a
forall a.
(a
 -> WriterT
      (Recursiveness be,
       [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)])
      (State Int)
      a)
-> WriterT
     (Recursiveness be,
      [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)])
     (State Int)
     a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (With be db a
-> WriterT
     (Recursiveness be,
      [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)])
     (State Int)
     a
forall be (db :: (* -> *) -> *) a.
With be db a
-> WriterT
     (Recursiveness be, [BeamSql99BackendCTESyntax be]) (State Int) a
runWith (With be db a
 -> WriterT
      (Recursiveness be,
       [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)])
      (State Int)
      a)
-> (a -> With be db a)
-> a
-> WriterT
     (Recursiveness be,
      [Sql99SelectCTESyntax (BeamSqlBackendSelectSyntax be)])
     (State Int)
     a
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 =
    Proxy res
-> (forall s.
    Proxy s -> Q be db s (WithRewrittenThread QAnyScope s res))
-> ReusableQ be db res
forall res be (db :: (* -> *) -> *).
Proxy res
-> (forall s.
    Proxy s -> Q be db s (WithRewrittenThread QAnyScope s res))
-> ReusableQ be db res
ReusableQ (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @res)
              (\Proxy s
proxyS ->
                 QM be db s (WithRewrittenThread QAnyScope s res)
-> Q be db s (WithRewrittenThread QAnyScope s res)
forall be (db :: (* -> *) -> *) s a. QM be db s a -> Q be db s a
Q (QM be db s (WithRewrittenThread QAnyScope s res)
 -> Q be db s (WithRewrittenThread QAnyScope s res))
-> QM be db s (WithRewrittenThread QAnyScope s res)
-> Q be db s (WithRewrittenThread QAnyScope s res)
forall a b. (a -> b) -> a -> b
$ QF be db s (WithRewrittenThread QAnyScope s res)
-> QM be db s (WithRewrittenThread QAnyScope s res)
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF ((Text
 -> Text
 -> Sql92SelectTableFromSyntax
      (Sql92SelectSelectTableSyntax
         (Sql92SelectSyntax (BeamSqlBackendSyntax be))))
-> (Text -> res)
-> (res
    -> Maybe
         (WithExprContext
            (Sql92SelectTableExpressionSyntax
               (Sql92SelectSelectTableSyntax
                  (Sql92SelectSyntax (BeamSqlBackendSyntax be))))))
-> ((Text, res) -> WithRewrittenThread QAnyScope s res)
-> QF be db s (WithRewrittenThread QAnyScope s res)
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
_ -> Sql92FromTableSourceSyntax
  (Sql92SelectTableFromSyntax
     (Sql92SelectSelectTableSyntax
        (Sql92SelectSyntax (BeamSqlBackendSyntax be))))
-> Maybe (Text, Maybe [Text])
-> Sql92SelectTableFromSyntax
     (Sql92SelectSelectTableSyntax
        (Sql92SelectSyntax (BeamSqlBackendSyntax be)))
forall from.
IsSql92FromSyntax from =>
Sql92FromTableSourceSyntax from
-> Maybe (Text, Maybe [Text]) -> from
fromTable (Sql92TableSourceTableNameSyntax
  (Sql92FromTableSourceSyntax
     (Sql92SelectTableFromSyntax
        (Sql92SelectSelectTableSyntax
           (Sql92SelectSyntax (BeamSqlBackendSyntax be)))))
-> Sql92FromTableSourceSyntax
     (Sql92SelectTableFromSyntax
        (Sql92SelectSelectTableSyntax
           (Sql92SelectSyntax (BeamSqlBackendSyntax be))))
forall tblSource.
IsSql92TableSourceSyntax tblSource =>
Sql92TableSourceTableNameSyntax tblSource -> tblSource
tableNamed (Maybe Text
-> Text
-> Sql92TableSourceTableNameSyntax
     (Sql92FromTableSourceSyntax
        (Sql92SelectTableFromSyntax
           (Sql92SelectSelectTableSyntax
              (Sql92SelectSyntax (BeamSqlBackendSyntax be)))))
forall tblName.
IsSql92TableNameSyntax tblName =>
Maybe Text -> Text -> tblName
tableName Maybe Text
forall a. Maybe a
Nothing Text
tblNm)) (Maybe (Text, Maybe [Text])
 -> Sql92SelectTableFromSyntax
      (Sql92SelectSelectTableSyntax
         (Sql92SelectSyntax (BeamSqlBackendSyntax be))))
-> (Text -> Maybe (Text, Maybe [Text]))
-> Text
-> Sql92SelectTableFromSyntax
     (Sql92SelectSelectTableSyntax
        (Sql92SelectSyntax (BeamSqlBackendSyntax be)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Maybe [Text]) -> Maybe (Text, Maybe [Text])
forall a. a -> Maybe a
Just ((Text, Maybe [Text]) -> Maybe (Text, Maybe [Text]))
-> (Text -> (Text, Maybe [Text]))
-> Text
-> Maybe (Text, Maybe [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, Maybe [Text]
forall a. Maybe a
Nothing))
                                 (\Text
tblNm' -> (res, [Text]) -> res
forall a b. (a, b) -> a
fst ((res, [Text]) -> res) -> (res, [Text]) -> res
forall a b. (a -> b) -> a -> b
$ forall be res.
(BeamSqlBackend be, Projectible be res) =>
(Text -> BeamSqlBackendFieldNameSyntax be) -> (res, [Text])
mkFieldNames @be @res (Text
-> Text
-> Sql92UpdateFieldNameSyntax
     (Sql92UpdateSyntax (BeamSqlBackendSyntax be))
forall fn. IsSql92FieldNameSyntax fn => Text -> Text -> fn
qualifiedField Text
tblNm'))
                                 (\res
_ -> Maybe
  (WithExprContext
     (Sql92SelectTableExpressionSyntax
        (Sql92SelectSelectTableSyntax
           (Sql92SelectSyntax (BeamSqlBackendSyntax be)))))
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 (res -> WithRewrittenThread QAnyScope s res)
-> ((Text, res) -> res)
-> (Text, res)
-> WithRewrittenThread QAnyScope s res
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, res) -> res
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 =
  WriterT
  (Recursiveness be,
   [Sql99SelectCTESyntax
      (Sql92SelectSyntax (BeamSqlBackendSyntax be))])
  (State Int)
  (ReusableQ be db res)
-> With be db (ReusableQ be db res)
forall be (db :: (* -> *) -> *) a.
WriterT
  (Recursiveness be, [BeamSql99BackendCTESyntax be]) (State Int) a
-> With be db a
With (WriterT
   (Recursiveness be,
    [Sql99SelectCTESyntax
       (Sql92SelectSyntax (BeamSqlBackendSyntax be))])
   (State Int)
   (ReusableQ be db res)
 -> With be db (ReusableQ be db res))
-> WriterT
     (Recursiveness be,
      [Sql99SelectCTESyntax
         (Sql92SelectSyntax (BeamSqlBackendSyntax be))])
     (State Int)
     (ReusableQ be db res)
-> With be db (ReusableQ be db res)
forall a b. (a -> b) -> a -> b
$ do
    cteId <- WriterT
  (Recursiveness be,
   [Sql99SelectCTESyntax
      (Sql92SelectSyntax (BeamSqlBackendSyntax be))])
  (State Int)
  Int
forall s (m :: * -> *). MonadState s m => m s
get
    put (cteId + 1)

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

        (_ :: res, fieldNames) = mkFieldNames @be (qualifiedField tblNm)
    tell (Nonrecursive, [ cteSubquerySyntax tblNm fieldNames (buildSqlQuery (tblNm <> "_") q) ])

    pure (reusableForCTE 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) = Proxy s -> Q be db s (WithRewrittenThread QAnyScope s res)
forall s.
Proxy s -> Q be db s (WithRewrittenThread QAnyScope s res)
q (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @s)