{-# 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 = 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 { 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)
a -> With be db a
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)
With be db a -> (a -> With be db b) -> With be db b
With be db a -> With be db b -> With be db b
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 :: a -> With be db a
$creturn :: forall be (db :: (* -> *) -> *) a. a -> With be db a
>> :: 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
>>= :: 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
$cp1Monad :: forall be (db :: (* -> *) -> *). Applicative (With be db)
Monad, Functor (With be db)
a -> With be db a
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)
With be db a -> With be db b -> With be db b
With be db a -> With be db b -> With be db a
With be db (a -> b) -> With be db a -> With be db b
(a -> b -> c) -> With be db a -> With be db b -> With be db c
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
<* :: 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
*> :: 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 :: (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
<*> :: 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 :: a -> With be db a
$cpure :: forall be (db :: (* -> *) -> *) a. a -> With be db a
$cp1Applicative :: forall be (db :: (* -> *) -> *). Functor (With be db)
Applicative, a -> With be db b -> With be db a
(a -> b) -> With be db a -> With be db b
(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
<$ :: 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 :: (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 :: (a -> With be db a) -> With be db a
mfix a -> With be db a
f = WriterT
  (Recursiveness be, [BeamSql99BackendCTESyntax 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, [BeamSql99BackendCTESyntax be])
-> WriterT
     (Recursiveness be, [BeamSql99BackendCTESyntax be]) (State Int) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Recursiveness be
forall be.
IsSql99RecursiveCommonTableExpressionSelectSyntax
  (BeamSqlBackendSelectSyntax be) =>
Recursiveness be
Recursive, [BeamSql99BackendCTESyntax be]
forall a. Monoid a => a
mempty) WriterT
  (Recursiveness be, [BeamSql99BackendCTESyntax be]) (State Int) ()
-> WriterT
     (Recursiveness be, [BeamSql99BackendCTESyntax be]) (State Int) a
-> WriterT
     (Recursiveness be, [BeamSql99BackendCTESyntax be]) (State Int) a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (a
 -> WriterT
      (Recursiveness be, [BeamSql99BackendCTESyntax be]) (State Int) a)
-> WriterT
     (Recursiveness be, [BeamSql99BackendCTESyntax be]) (State Int) a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (With be db a
-> WriterT
     (Recursiveness be, [BeamSql99BackendCTESyntax 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, [BeamSql99BackendCTESyntax be]) (State Int) a)
-> (a -> With be db a)
-> a
-> WriterT
     (Recursiveness be, [BeamSql99BackendCTESyntax 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 :: 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 (Proxy res
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 -> BeamSqlBackendFromSyntax be)
-> (Text -> res)
-> (res
    -> Maybe (WithExprContext (BeamSqlBackendExpressionSyntax 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 (BeamSqlBackendFromSyntax be)
-> Maybe (Text, Maybe [Text]) -> BeamSqlBackendFromSyntax be
forall from.
IsSql92FromSyntax from =>
Sql92FromTableSourceSyntax from
-> Maybe (Text, Maybe [Text]) -> from
fromTable (Sql92TableSourceTableNameSyntax
  (Sql92FromTableSourceSyntax (BeamSqlBackendFromSyntax be))
-> Sql92FromTableSourceSyntax (BeamSqlBackendFromSyntax be)
forall tblSource.
IsSql92TableSourceSyntax tblSource =>
Sql92TableSourceTableNameSyntax tblSource -> tblSource
tableNamed (Maybe Text
-> Text
-> Sql92TableSourceTableNameSyntax
     (Sql92FromTableSourceSyntax (BeamSqlBackendFromSyntax be))
forall tblName.
IsSql92TableNameSyntax tblName =>
Maybe Text -> Text -> tblName
tableName Maybe Text
forall a. Maybe a
Nothing Text
tblNm)) (Maybe (Text, Maybe [Text]) -> BeamSqlBackendFromSyntax be)
-> (Text -> Maybe (Text, Maybe [Text]))
-> Text
-> BeamSqlBackendFromSyntax 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
$ (Text -> BeamSqlBackendFieldNameSyntax be) -> (res, [Text])
forall be res.
(BeamSqlBackend be, Projectible be res) =>
(Text -> BeamSqlBackendFieldNameSyntax be) -> (res, [Text])
mkFieldNames @be @res (Text
-> Text
-> Sql92ExpressionFieldNameSyntax
     (Sql92InsertValuesExpressionSyntax
        (Sql92InsertValuesSyntax
           (Sql92InsertSyntax (BeamSqlBackendSyntax be))))
forall fn. IsSql92FieldNameSyntax fn => Text -> Text -> fn
qualifiedField Text
tblNm'))
                                 (\res
_ -> Maybe (WithExprContext (BeamSqlBackendExpressionSyntax be))
forall a. Maybe a
Nothing)
                                 (Proxy s -> res -> WithRewrittenThread QAnyScope s res
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 :: Q be db QAnyScope res -> With be db (ReusableQ be db res)
selecting Q be db QAnyScope res
q =
  WriterT
  (Recursiveness be, [BeamSql99BackendCTESyntax 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, [BeamSql99BackendCTESyntax be])
   (State Int)
   (ReusableQ be db res)
 -> With be db (ReusableQ be db res))
-> WriterT
     (Recursiveness be, [BeamSql99BackendCTESyntax be])
     (State Int)
     (ReusableQ be db res)
-> With be db (ReusableQ be db res)
forall a b. (a -> b) -> a -> b
$ do
    Int
cteId <- WriterT
  (Recursiveness be, [BeamSql99BackendCTESyntax be]) (State Int) Int
forall s (m :: * -> *). MonadState s m => m s
get
    Int
-> WriterT
     (Recursiveness be, [BeamSql99BackendCTESyntax be]) (State Int) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
cteId Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

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

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

    ReusableQ be db res
-> WriterT
     (Recursiveness be, [BeamSql99BackendCTESyntax be])
     (State Int)
     (ReusableQ be db res)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ReusableQ be db res
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 :: 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 (Proxy s
forall k (t :: k). Proxy t
Proxy @s)