{-# 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 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 { 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
-> Sql92ExpressionFieldNameSyntax
     (Sql92UpdateExpressionSyntax
        (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
    Int
cteId <- WriterT
  (Recursiveness be,
   [Sql99SelectCTESyntax
      (Sql92SelectSyntax (BeamSqlBackendSyntax be))])
  (State Int)
  Int
forall s (m :: * -> *). MonadState s m => m s
get
    Int
-> WriterT
     (Recursiveness be,
      [Sql99SelectCTESyntax
         (Sql92SelectSyntax (BeamSqlBackendSyntax 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 = [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
_ :: res, [Text]
fieldNames) = forall be res.
(BeamSqlBackend be, Projectible be res) =>
(Text -> BeamSqlBackendFieldNameSyntax be) -> (res, [Text])
mkFieldNames @be (Text
-> Text
-> Sql92ExpressionFieldNameSyntax
     (Sql92UpdateExpressionSyntax
        (Sql92UpdateSyntax (BeamSqlBackendSyntax be)))
forall fn. IsSql92FieldNameSyntax fn => Text -> Text -> fn
qualifiedField Text
tblNm)
    (Recursiveness be,
 [Sql99SelectCTESyntax
    (Sql92SelectSyntax (BeamSqlBackendSyntax be))])
-> WriterT
     (Recursiveness be,
      [Sql99SelectCTESyntax
         (Sql92SelectSyntax (BeamSqlBackendSyntax be))])
     (State Int)
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Recursiveness be
forall be. Recursiveness be
Nonrecursive, [ Text
-> [Text]
-> Sql99CTESelectSyntax
     (Sql99SelectCTESyntax
        (Sql92SelectSyntax (BeamSqlBackendSyntax be)))
-> Sql99SelectCTESyntax
     (Sql92SelectSyntax (BeamSqlBackendSyntax be))
forall syntax.
IsSql99CommonTableExpressionSyntax syntax =>
Text -> [Text] -> Sql99CTESelectSyntax syntax -> syntax
cteSubquerySyntax Text
tblNm [Text]
fieldNames (Text
-> Q be db QAnyScope res
-> Sql92SelectSyntax (BeamSqlBackendSyntax be)
forall be a (db :: (* -> *) -> *) s.
(HasQBuilder be, Projectible be a) =>
Text -> Q be db s a -> BeamSqlBackendSelectSyntax be
forall a (db :: (* -> *) -> *) s.
Projectible be a =>
Text -> Q be db s a -> Sql92SelectSyntax (BeamSqlBackendSyntax 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,
      [Sql99SelectCTESyntax
         (Sql92SelectSyntax (BeamSqlBackendSyntax be))])
     (State Int)
     (ReusableQ be db res)
forall a.
a
-> WriterT
     (Recursiveness be,
      [Sql99SelectCTESyntax
         (Sql92SelectSyntax (BeamSqlBackendSyntax be))])
     (State Int)
     a
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 :: 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)