{-# language DerivingStrategies #-}
{-# language FlexibleContexts #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language NamedFieldPuns #-}
{-# language StandaloneKindSignatures #-}

module Rel8.Query.Evaluate
  ( Evaluate
  , eval
  , evaluate
  )
where

-- base
import Data.Kind ( Type )
import Data.Monoid ( Endo ( Endo ), appEndo )
import Prelude

-- opaleye
import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
import qualified Opaleye.Internal.PackMap as Opaleye
import qualified Opaleye.Internal.PrimQuery as Opaleye
import qualified Opaleye.Internal.QueryArr as Opaleye
import qualified Opaleye.Internal.Tag as Opaleye
import qualified Opaleye.Internal.Unpackspec as Opaleye

-- rel8
import Rel8.Expr ( Expr )
import Rel8.Query ( Query( Query ) )
import Rel8.Table ( Table )
import Rel8.Table.Opaleye ( unpackspec )

-- semigroupoids
import Data.Functor.Apply ( Apply )
import Data.Functor.Bind ( Bind, (>>-) )

-- transformers
import Control.Monad.Trans.State.Strict ( State, get, put, runState )


type Evaluations :: Type
data Evaluations = Evaluations
  { Evaluations -> Tag
tag :: !Opaleye.Tag
  , Evaluations -> Endo (Bindings PrimExpr)
bindings :: !(Endo (Opaleye.Bindings Opaleye.PrimExpr))
  }


-- | Some PostgreSQL functions, such as 'Rel8.nextval', have side effects,
-- breaking the referential transparency we would otherwise enjoy.
--
-- To try to recover our ability to reason about such expressions, 'Evaluate'
-- allows us to control the evaluation order of side-effects by sequencing
-- them monadically.
type Evaluate :: Type -> Type
newtype Evaluate a = Evaluate (State Evaluations a)
  deriving newtype (a -> Evaluate b -> Evaluate a
(a -> b) -> Evaluate a -> Evaluate b
(forall a b. (a -> b) -> Evaluate a -> Evaluate b)
-> (forall a b. a -> Evaluate b -> Evaluate a) -> Functor Evaluate
forall a b. a -> Evaluate b -> Evaluate a
forall a b. (a -> b) -> Evaluate a -> Evaluate b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Evaluate b -> Evaluate a
$c<$ :: forall a b. a -> Evaluate b -> Evaluate a
fmap :: (a -> b) -> Evaluate a -> Evaluate b
$cfmap :: forall a b. (a -> b) -> Evaluate a -> Evaluate b
Functor, Functor Evaluate
Functor Evaluate
-> (forall a b. Evaluate (a -> b) -> Evaluate a -> Evaluate b)
-> (forall a b. Evaluate a -> Evaluate b -> Evaluate b)
-> (forall a b. Evaluate a -> Evaluate b -> Evaluate a)
-> (forall a b c.
    (a -> b -> c) -> Evaluate a -> Evaluate b -> Evaluate c)
-> Apply Evaluate
Evaluate a -> Evaluate b -> Evaluate b
Evaluate a -> Evaluate b -> Evaluate a
Evaluate (a -> b) -> Evaluate a -> Evaluate b
(a -> b -> c) -> Evaluate a -> Evaluate b -> Evaluate c
forall a b. Evaluate a -> Evaluate b -> Evaluate a
forall a b. Evaluate a -> Evaluate b -> Evaluate b
forall a b. Evaluate (a -> b) -> Evaluate a -> Evaluate b
forall a b c.
(a -> b -> c) -> Evaluate a -> Evaluate b -> Evaluate c
forall (f :: * -> *).
Functor f
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> Apply f
liftF2 :: (a -> b -> c) -> Evaluate a -> Evaluate b -> Evaluate c
$cliftF2 :: forall a b c.
(a -> b -> c) -> Evaluate a -> Evaluate b -> Evaluate c
<. :: Evaluate a -> Evaluate b -> Evaluate a
$c<. :: forall a b. Evaluate a -> Evaluate b -> Evaluate a
.> :: Evaluate a -> Evaluate b -> Evaluate b
$c.> :: forall a b. Evaluate a -> Evaluate b -> Evaluate b
<.> :: Evaluate (a -> b) -> Evaluate a -> Evaluate b
$c<.> :: forall a b. Evaluate (a -> b) -> Evaluate a -> Evaluate b
$cp1Apply :: Functor Evaluate
Apply, Functor Evaluate
a -> Evaluate a
Functor Evaluate
-> (forall a. a -> Evaluate a)
-> (forall a b. Evaluate (a -> b) -> Evaluate a -> Evaluate b)
-> (forall a b c.
    (a -> b -> c) -> Evaluate a -> Evaluate b -> Evaluate c)
-> (forall a b. Evaluate a -> Evaluate b -> Evaluate b)
-> (forall a b. Evaluate a -> Evaluate b -> Evaluate a)
-> Applicative Evaluate
Evaluate a -> Evaluate b -> Evaluate b
Evaluate a -> Evaluate b -> Evaluate a
Evaluate (a -> b) -> Evaluate a -> Evaluate b
(a -> b -> c) -> Evaluate a -> Evaluate b -> Evaluate c
forall a. a -> Evaluate a
forall a b. Evaluate a -> Evaluate b -> Evaluate a
forall a b. Evaluate a -> Evaluate b -> Evaluate b
forall a b. Evaluate (a -> b) -> Evaluate a -> Evaluate b
forall a b c.
(a -> b -> c) -> Evaluate a -> Evaluate b -> Evaluate 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
<* :: Evaluate a -> Evaluate b -> Evaluate a
$c<* :: forall a b. Evaluate a -> Evaluate b -> Evaluate a
*> :: Evaluate a -> Evaluate b -> Evaluate b
$c*> :: forall a b. Evaluate a -> Evaluate b -> Evaluate b
liftA2 :: (a -> b -> c) -> Evaluate a -> Evaluate b -> Evaluate c
$cliftA2 :: forall a b c.
(a -> b -> c) -> Evaluate a -> Evaluate b -> Evaluate c
<*> :: Evaluate (a -> b) -> Evaluate a -> Evaluate b
$c<*> :: forall a b. Evaluate (a -> b) -> Evaluate a -> Evaluate b
pure :: a -> Evaluate a
$cpure :: forall a. a -> Evaluate a
$cp1Applicative :: Functor Evaluate
Applicative, Applicative Evaluate
a -> Evaluate a
Applicative Evaluate
-> (forall a b. Evaluate a -> (a -> Evaluate b) -> Evaluate b)
-> (forall a b. Evaluate a -> Evaluate b -> Evaluate b)
-> (forall a. a -> Evaluate a)
-> Monad Evaluate
Evaluate a -> (a -> Evaluate b) -> Evaluate b
Evaluate a -> Evaluate b -> Evaluate b
forall a. a -> Evaluate a
forall a b. Evaluate a -> Evaluate b -> Evaluate b
forall a b. Evaluate a -> (a -> Evaluate b) -> Evaluate 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 -> Evaluate a
$creturn :: forall a. a -> Evaluate a
>> :: Evaluate a -> Evaluate b -> Evaluate b
$c>> :: forall a b. Evaluate a -> Evaluate b -> Evaluate b
>>= :: Evaluate a -> (a -> Evaluate b) -> Evaluate b
$c>>= :: forall a b. Evaluate a -> (a -> Evaluate b) -> Evaluate b
$cp1Monad :: Applicative Evaluate
Monad)


instance Bind Evaluate where
  >>- :: Evaluate a -> (a -> Evaluate b) -> Evaluate b
(>>-) = Evaluate a -> (a -> Evaluate b) -> Evaluate b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=)


-- | 'eval' takes expressions that could potentially have side effects and
-- \"runs\" them in the 'Evaluate' monad. The returned expressions have no
-- side effetcs and can safely be reused.
eval :: Table Expr a => a -> Evaluate a
eval :: a -> Evaluate a
eval a
a = State Evaluations a -> Evaluate a
forall a. State Evaluations a -> Evaluate a
Evaluate (State Evaluations a -> Evaluate a)
-> State Evaluations a -> Evaluate a
forall a b. (a -> b) -> a -> b
$ do
  Evaluations {Tag
tag :: Tag
tag :: Evaluations -> Tag
tag, Endo (Bindings PrimExpr)
bindings :: Endo (Bindings PrimExpr)
bindings :: Evaluations -> Endo (Bindings PrimExpr)
bindings} <- StateT Evaluations Identity Evaluations
forall (m :: * -> *) s. Monad m => StateT s m s
get
  let
    tag' :: Tag
tag' = Tag -> Tag
Opaleye.next Tag
tag
    (a
a', Bindings PrimExpr
bindings') = PM (Bindings PrimExpr) a -> (a, Bindings PrimExpr)
forall a r. PM [a] r -> (r, [a])
Opaleye.run (PM (Bindings PrimExpr) a -> (a, Bindings PrimExpr))
-> PM (Bindings PrimExpr) a -> (a, Bindings PrimExpr)
forall a b. (a -> b) -> a -> b
$
      Unpackspec a a
-> (PrimExpr -> StateT (Bindings PrimExpr, Int) Identity PrimExpr)
-> a
-> PM (Bindings PrimExpr) a
forall (f :: * -> *) columns b.
Applicative f =>
Unpackspec columns b -> (PrimExpr -> f PrimExpr) -> columns -> f b
Opaleye.runUnpackspec Unpackspec a a
forall a. Table Expr a => Unpackspec a a
unpackspec (String
-> Tag
-> PrimExpr
-> StateT (Bindings PrimExpr, Int) Identity PrimExpr
forall primExpr.
String -> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
Opaleye.extractAttr String
"eval" Tag
tag') a
a
  Evaluations -> StateT Evaluations Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Evaluations :: Tag -> Endo (Bindings PrimExpr) -> Evaluations
Evaluations {tag :: Tag
tag = Tag
tag', bindings :: Endo (Bindings PrimExpr)
bindings = Endo (Bindings PrimExpr)
bindings Endo (Bindings PrimExpr)
-> Endo (Bindings PrimExpr) -> Endo (Bindings PrimExpr)
forall a. Semigroup a => a -> a -> a
<> (Bindings PrimExpr -> Bindings PrimExpr)
-> Endo (Bindings PrimExpr)
forall a. (a -> a) -> Endo a
Endo (Bindings PrimExpr
bindings' Bindings PrimExpr -> Bindings PrimExpr -> Bindings PrimExpr
forall a. [a] -> [a] -> [a]
++)}
  a -> State Evaluations a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a'


-- | 'evaluate' runs an 'Evaluate' inside the 'Query' monad.
evaluate :: Evaluate a -> Query a
evaluate :: Evaluate a -> Query a
evaluate (Evaluate State Evaluations a
m) = Select a -> Query a
forall a. Select a -> Query a
Query (Select a -> Query a) -> Select a -> Query a
forall a b. (a -> b) -> a -> b
$ (((), PrimQuery, Tag) -> (a, PrimQuery, Tag)) -> Select a
forall a b.
((a, PrimQuery, Tag) -> (b, PrimQuery, Tag)) -> SelectArr a b
Opaleye.QueryArr ((((), PrimQuery, Tag) -> (a, PrimQuery, Tag)) -> Select a)
-> (((), PrimQuery, Tag) -> (a, PrimQuery, Tag)) -> Select a
forall a b. (a -> b) -> a -> b
$ \(()
_, PrimQuery
query, Tag
tag) ->
  case State Evaluations a -> Evaluations -> (a, Evaluations)
forall s a. State s a -> s -> (a, s)
runState State Evaluations a
m (Tag -> Endo (Bindings PrimExpr) -> Evaluations
Evaluations Tag
tag Endo (Bindings PrimExpr)
forall a. Monoid a => a
mempty) of
    (a
a, Evaluations {tag :: Evaluations -> Tag
tag = Tag
tag', Endo (Bindings PrimExpr)
bindings :: Endo (Bindings PrimExpr)
bindings :: Evaluations -> Endo (Bindings PrimExpr)
bindings}) ->
      (a
a, Bool -> Bindings PrimExpr -> PrimQuery -> PrimQuery
forall a. Bool -> Bindings PrimExpr -> PrimQuery' a -> PrimQuery' a
Opaleye.Rebind Bool
True (Endo (Bindings PrimExpr) -> Bindings PrimExpr -> Bindings PrimExpr
forall a. Endo a -> a -> a
appEndo Endo (Bindings PrimExpr)
bindings Bindings PrimExpr
forall a. Monoid a => a
mempty) PrimQuery
query, Tag
tag')