{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

{-| This module mirrors 'PlutusIR.Transform.EvaluateBuiltins', adapted for UPLC's
untyped 'Term' and 'AppCtx'. See that module for detailed commentary. -}
module UntypedPlutusCore.Transform.EvaluateBuiltins
  ( evaluateBuiltinsPass
  ) where

import PlutusCore.Builtin
import UntypedPlutusCore.Analysis.Builtins
import UntypedPlutusCore.Contexts
import UntypedPlutusCore.Core
import UntypedPlutusCore.Transform.Certify.Trace
import UntypedPlutusCore.Transform.Optimizer

import Control.Lens (transformOf, (^.))
import Data.Functor (void)

evaluateBuiltinsPass
  :: (Monad m, ToBuiltinMeaning uni fun, Typeable name)
  => Bool
  -- ^ Whether to be conservative and try to retain logging behaviour.
  -> BuiltinsInfo uni fun
  -> CostingPart uni fun
  -> Term name uni fun a
  -> OptimizerT name uni fun a m (Term name uni fun a)
evaluateBuiltinsPass :: forall (m :: * -> *) (uni :: * -> *) fun name a.
(Monad m, ToBuiltinMeaning uni fun, Typeable name) =>
Bool
-> BuiltinsInfo uni fun
-> CostingPart uni fun
-> Term name uni fun a
-> OptimizerT name uni fun a m (Term name uni fun a)
evaluateBuiltinsPass Bool
preserveLogging BuiltinsInfo uni fun
binfo CostingPart uni fun
costModel Term name uni fun a
term = do
  Term name uni fun a
result <- Bool
-> BuiltinsInfo uni fun
-> CostingPart uni fun
-> Term name uni fun a
-> OptimizerT name uni fun a m (Term name uni fun a)
forall (m :: * -> *) name (uni :: * -> *) fun a.
(Monad m, ToBuiltinMeaning uni fun, Typeable name) =>
Bool
-> BuiltinsInfo uni fun
-> CostingPart uni fun
-> Term name uni fun a
-> OptimizerT name uni fun a m (Term name uni fun a)
evaluateBuiltins Bool
preserveLogging BuiltinsInfo uni fun
binfo CostingPart uni fun
costModel Term name uni fun a
term
  Term name uni fun a
-> OptStage
-> Term name uni fun a
-> OptimizerT name uni fun a m ()
forall (m :: * -> *) name (uni :: * -> *) fun a.
Monad m =>
Term name uni fun a
-> OptStage
-> Term name uni fun a
-> OptimizerT name uni fun a m ()
recordOptimization Term name uni fun a
term OptStage
ConstantFoldingStage Term name uni fun a
result
  Term name uni fun a
-> OptimizerT name uni fun a m (Term name uni fun a)
forall a. a -> OptimizerT name uni fun a m a
forall (m :: * -> *) a. Monad m => a -> m a
return Term name uni fun a
result

evaluateBuiltins
  :: forall m name uni fun a
   . ( Monad m
     , ToBuiltinMeaning uni fun
     , Typeable name
     )
  => Bool
  -- ^ Whether to be conservative and try to retain logging behaviour.
  -> BuiltinsInfo uni fun
  -> CostingPart uni fun
  -> Term name uni fun a
  -> OptimizerT name uni fun a m (Term name uni fun a)
evaluateBuiltins :: forall (m :: * -> *) name (uni :: * -> *) fun a.
(Monad m, ToBuiltinMeaning uni fun, Typeable name) =>
Bool
-> BuiltinsInfo uni fun
-> CostingPart uni fun
-> Term name uni fun a
-> OptimizerT name uni fun a m (Term name uni fun a)
evaluateBuiltins Bool
preserveLogging BuiltinsInfo uni fun
binfo CostingPart uni fun
costModel =
  Term name uni fun a
-> OptimizerT name uni fun a m (Term name uni fun a)
forall a. a -> OptimizerT name uni fun a m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term name uni fun a
 -> OptimizerT name uni fun a m (Term name uni fun a))
-> (Term name uni fun a -> Term name uni fun a)
-> Term name uni fun a
-> OptimizerT name uni fun a m (Term name uni fun a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter
  (Term name uni fun a)
  (Term name uni fun a)
  (Term name uni fun a)
  (Term name uni fun a)
-> (Term name uni fun a -> Term name uni fun a)
-> Term name uni fun a
-> Term name uni fun a
forall a b. ASetter a b a b -> (b -> b) -> a -> b
transformOf ASetter
  (Term name uni fun a)
  (Term name uni fun a)
  (Term name uni fun a)
  (Term name uni fun a)
forall name (uni :: * -> *) fun ann (f :: * -> *).
Applicative f =>
(Term name uni fun ann -> f (Term name uni fun ann))
-> Term name uni fun ann -> f (Term name uni fun ann)
termSubterms Term name uni fun a -> Term name uni fun a
processTerm
  where
    eval
      :: BuiltinRuntime (Term name uni fun ())
      -> AppCtx name uni fun a
      -> Maybe (Term name uni fun ())
    eval :: BuiltinRuntime (Term name uni fun ())
-> AppCtx name uni fun a -> Maybe (Term name uni fun ())
eval (BuiltinCostedResult ExBudgetStream
_ BuiltinResult (Term name uni fun ())
getFXs) AppCtx name uni fun a
AppCtxEnd =
      case BuiltinResult (Term name uni fun ())
getFXs of
        BuiltinSuccess Term name uni fun ()
y -> Term name uni fun () -> Maybe (Term name uni fun ())
forall a. a -> Maybe a
Just Term name uni fun ()
y
        BuiltinSuccessWithLogs DList Text
_ Term name uni fun ()
y -> if Bool
preserveLogging then Maybe (Term name uni fun ())
forall a. Maybe a
Nothing else Term name uni fun () -> Maybe (Term name uni fun ())
forall a. a -> Maybe a
Just Term name uni fun ()
y
        BuiltinFailure {} -> Maybe (Term name uni fun ())
forall a. Maybe a
Nothing
    eval (BuiltinExpectArgument Term name uni fun () -> BuiltinRuntime (Term name uni fun ())
toRuntime) (AppCtxTerm a
_ Term name uni fun a
arg AppCtx name uni fun a
ctx) =
      BuiltinRuntime (Term name uni fun ())
-> AppCtx name uni fun a -> Maybe (Term name uni fun ())
eval (Term name uni fun () -> BuiltinRuntime (Term name uni fun ())
toRuntime (Term name uni fun () -> BuiltinRuntime (Term name uni fun ()))
-> Term name uni fun () -> BuiltinRuntime (Term name uni fun ())
forall a b. (a -> b) -> a -> b
$ Term name uni fun a -> Term name uni fun ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Term name uni fun a
arg) AppCtx name uni fun a
ctx
    eval (BuiltinExpectForce BuiltinRuntime (Term name uni fun ())
runtime) (AppCtxType a
_ AppCtx name uni fun a
ctx) =
      BuiltinRuntime (Term name uni fun ())
-> AppCtx name uni fun a -> Maybe (Term name uni fun ())
eval BuiltinRuntime (Term name uni fun ())
runtime AppCtx name uni fun a
ctx
    eval BuiltinRuntime (Term name uni fun ())
_ AppCtx name uni fun a
_ = Maybe (Term name uni fun ())
forall a. Maybe a
Nothing

    processTerm :: Term name uni fun a -> Term name uni fun a
    -- See Note [Context splitting in a recursive pass]
    processTerm :: Term name uni fun a -> Term name uni fun a
processTerm t :: Term name uni fun a
t@(Term name uni fun a -> (Term name uni fun a, AppCtx name uni fun a)
forall nam (uni :: * -> *) fun a.
Term nam uni fun a -> (Term nam uni fun a, AppCtx nam uni fun a)
splitAppCtx -> (Builtin a
x fun
bn, AppCtx name uni fun a
argCtx)) =
      let runtime :: BuiltinRuntime (Term name uni fun ())
runtime = CostingPart uni fun
-> BuiltinMeaning (Term name uni fun ()) (CostingPart uni fun)
-> BuiltinRuntime (Term name uni fun ())
forall cost val.
cost -> BuiltinMeaning val cost -> BuiltinRuntime val
toBuiltinRuntime CostingPart uni fun
costModel (BuiltinSemanticsVariant fun
-> fun
-> BuiltinMeaning
     (Term name uni fun ())
     (CostingPart (UniOf (Term name uni fun ())) fun)
forall val.
HasMeaningIn (UniOf (Term name uni fun ())) val =>
BuiltinSemanticsVariant fun
-> fun
-> BuiltinMeaning
     val (CostingPart (UniOf (Term name uni fun ())) fun)
forall (uni :: * -> *) fun val.
(ToBuiltinMeaning uni fun, HasMeaningIn uni val) =>
BuiltinSemanticsVariant fun
-> fun -> BuiltinMeaning val (CostingPart uni fun)
toBuiltinMeaning (BuiltinsInfo uni fun
binfo BuiltinsInfo uni fun
-> Getting
     (BuiltinSemanticsVariant fun)
     (BuiltinsInfo uni fun)
     (BuiltinSemanticsVariant fun)
-> BuiltinSemanticsVariant fun
forall s a. s -> Getting a s a -> a
^. Getting
  (BuiltinSemanticsVariant fun)
  (BuiltinsInfo uni fun)
  (BuiltinSemanticsVariant fun)
forall (uni :: * -> *) fun1 fun2 (f :: * -> *).
Functor f =>
(BuiltinSemanticsVariant fun1 -> f (BuiltinSemanticsVariant fun2))
-> BuiltinsInfo uni fun1 -> f (BuiltinsInfo uni fun2)
biSemanticsVariant) fun
bn)
       in case BuiltinRuntime (Term name uni fun ())
-> AppCtx name uni fun a -> Maybe (Term name uni fun ())
eval BuiltinRuntime (Term name uni fun ())
runtime AppCtx name uni fun a
argCtx of
            -- See Note [Unserializable constants] in PlutusIR.Analysis.Builtins
            Just Term name uni fun ()
t' | BuiltinsInfo uni fun -> Term name uni fun () -> Bool
forall (uni :: * -> *) fun name a.
BuiltinsInfo uni fun -> Term name uni fun a -> Bool
termIsSerializable BuiltinsInfo uni fun
binfo Term name uni fun ()
t' -> a
x a -> Term name uni fun () -> Term name uni fun a
forall a b. a -> Term name uni fun b -> Term name uni fun a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Term name uni fun ()
t'
            Maybe (Term name uni fun ())
_ -> Term name uni fun a
t
    processTerm Term name uni fun a
t = Term name uni fun a
t