{-# LANGUAGE RankNTypes #-}

module Plutarch.Extra.DebuggableScript (
  -- * Type
  DebuggableScript,

  -- * Construction
  checkedCompileD,
  mustCompileD,

  -- * Use
  applyScript,
  applyDebuggableScript,
  applyDebuggableArg,
  mustFinalEvalDebuggableScript,
  finalEvalDebuggableScript,
  mustEvalScript,
  mustEvalD,
) where

import Data.Text (Text)
import Data.Text qualified as Text
import Optics.Getter (A_Getter, to, view)
import Optics.Label (LabelOptic (labelOptic))
import Plutarch (
  Config (Config, tracingMode),
  TracingMode (DetTracing, NoTracing),
  compile,
 )
import Plutarch.Evaluate (EvalError, evalScript)
import Plutarch.Extra.Compile (mustCompile, mustCompileTracing)
import Plutarch.Extra.Script (applyArguments)
import Plutarch.Script (
  Script (Script),
 )
import PlutusLedgerApi.V1 (Data, ExBudget)
import UntypedPlutusCore (
  Program (
    Program,
    _progAnn,
    _progTerm,
    _progVer
  ),
 )
import UntypedPlutusCore.Core.Type qualified as UplcType
import UntypedPlutusCore.Evaluation.Machine.Cek (
  CekUserError (CekEvaluationFailure, CekOutOfExError),
  ErrorWithCause (ErrorWithCause),
  EvaluationError (InternalEvaluationError, UserEvaluationError),
 )

{- | A 'Script' with a debug fallback that has tracing turned on.

 @since 3.8.0
-}
data DebuggableScript = DebuggableScript Script Script
  deriving stock
    ( -- | @since 3.0.2
      DebuggableScript -> DebuggableScript -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DebuggableScript -> DebuggableScript -> Bool
$c/= :: DebuggableScript -> DebuggableScript -> Bool
== :: DebuggableScript -> DebuggableScript -> Bool
$c== :: DebuggableScript -> DebuggableScript -> Bool
Eq
    , -- | @since 3.0.2
      Int -> DebuggableScript -> ShowS
[DebuggableScript] -> ShowS
DebuggableScript -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DebuggableScript] -> ShowS
$cshowList :: [DebuggableScript] -> ShowS
show :: DebuggableScript -> String
$cshow :: DebuggableScript -> String
showsPrec :: Int -> DebuggableScript -> ShowS
$cshowsPrec :: Int -> DebuggableScript -> ShowS
Show
    , -- | @since 3.0.2
      forall x. Rep DebuggableScript x -> DebuggableScript
forall x. DebuggableScript -> Rep DebuggableScript x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DebuggableScript x -> DebuggableScript
$cfrom :: forall x. DebuggableScript -> Rep DebuggableScript x
Generic
    )

{- | Retrieves the non-debugging 'Script'. This is read-only, as allowing it to
 change could break invariants.

 @since 3.8.0
-}
instance
  (k ~ A_Getter, a ~ Script, b ~ Script) =>
  LabelOptic "script" k DebuggableScript DebuggableScript a b
  where
  labelOptic :: Optic k NoIx DebuggableScript DebuggableScript a b
labelOptic = forall s a. (s -> a) -> Getter s a
to forall a b. (a -> b) -> a -> b
$ \(DebuggableScript Script
x Script
_) -> Script
x

{- | Retrieves the debugging 'Script'. This is read-only, as allowing it to
 change could break invariants.

 @since 3.8.0
-}
instance
  (k ~ A_Getter, a ~ Script, b ~ Script) =>
  LabelOptic "debugScript" k DebuggableScript DebuggableScript a b
  where
  labelOptic :: Optic k NoIx DebuggableScript DebuggableScript a b
labelOptic = forall s a. (s -> a) -> Getter s a
to forall a b. (a -> b) -> a -> b
$ \(DebuggableScript Script
_ Script
x) -> Script
x

{- | Apply a function to an argument on the compiled 'Script' level.

 @since 3.8.0
-}
applyScript :: Script -> Script -> Script
applyScript :: Script -> Script -> Script
applyScript Script
f Script
a =
  if Version ()
fVer forall a. Eq a => a -> a -> Bool
/= Version ()
aVer
    then forall a. HasCallStack => String -> a
error String
"apply: Plutus Core version mismatch"
    else
      Program DeBruijn DefaultUni DefaultFun () -> Script
Script
        Program
          { _progTerm :: Term DeBruijn DefaultUni DefaultFun ()
_progTerm = forall name (uni :: Type -> Type) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
UplcType.Apply () Term DeBruijn DefaultUni DefaultFun ()
fTerm Term DeBruijn DefaultUni DefaultFun ()
aTerm
          , _progVer :: Version ()
_progVer = Version ()
fVer
          , _progAnn :: ()
_progAnn = ()
          }
  where
    (Script Program {_progTerm :: forall name (uni :: Type -> Type) fun ann.
Program name uni fun ann -> Term name uni fun ann
_progTerm = Term DeBruijn DefaultUni DefaultFun ()
fTerm, _progVer :: forall name (uni :: Type -> Type) fun ann.
Program name uni fun ann -> Version ann
_progVer = Version ()
fVer}) = Script
f
    (Script Program {_progTerm :: forall name (uni :: Type -> Type) fun ann.
Program name uni fun ann -> Term name uni fun ann
_progTerm = Term DeBruijn DefaultUni DefaultFun ()
aTerm, _progVer :: forall name (uni :: Type -> Type) fun ann.
Program name uni fun ann -> Version ann
_progVer = Version ()
aVer}) = Script
a

{- | Apply given arguments to 'DebuggableScript'.

 @since 3.7.1
-}
applyDebuggableScript :: DebuggableScript -> [Data] -> DebuggableScript
applyDebuggableScript :: DebuggableScript -> [Data] -> DebuggableScript
applyDebuggableScript (DebuggableScript Script
script Script
debugScript) [Data]
args =
  Script -> Script -> DebuggableScript
DebuggableScript (Script -> [Data] -> Script
applyArguments Script
script [Data]
args) (Script -> [Data] -> Script
applyArguments Script
debugScript [Data]
args)

{- | Apply a single argument, provided as a 'DebuggableScript'.

 @since 3.8.0
-}
applyDebuggableArg ::
  DebuggableScript ->
  DebuggableScript ->
  DebuggableScript
applyDebuggableArg :: DebuggableScript -> DebuggableScript -> DebuggableScript
applyDebuggableArg DebuggableScript
f DebuggableScript
x =
  Script -> Script -> DebuggableScript
DebuggableScript
    (Script -> Script -> Script
applyScript (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "script" a => a
#script DebuggableScript
f) (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "script" a => a
#script DebuggableScript
x))
    (Script -> Script -> Script
applyScript (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "debugScript" a => a
#debugScript DebuggableScript
f) (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "debugScript" a => a
#debugScript DebuggableScript
x))

{- | For handling compilation errors right away.

 You pay for the compilation of the debug script, even if it's not needed down
 the line. You most likely want 'mustCompileD' instead.

  @since 3.0.2
-}
checkedCompileD ::
  forall (a :: S -> Type).
  (forall (s :: S). Term s a) ->
  Either Text DebuggableScript
checkedCompileD :: forall (a :: S -> Type).
(forall (s :: S). Term s a) -> Either Text DebuggableScript
checkedCompileD forall (s :: S). Term s a
term = do
  Script
script <- forall (a :: S -> Type).
Config -> ClosedTerm a -> Either Text Script
compile Config {$sel:tracingMode:Config :: TracingMode
tracingMode = TracingMode
NoTracing} forall (s :: S). Term s a
term
  Script
debugScript <- forall (a :: S -> Type).
Config -> ClosedTerm a -> Either Text Script
compile Config {$sel:tracingMode:Config :: TracingMode
tracingMode = TracingMode
DetTracing} forall (s :: S). Term s a
term
  forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Script -> Script -> DebuggableScript
DebuggableScript Script
script Script
debugScript

{- | Compilation errors cause exceptions, but deferred by lazyness.

 You don't pay for compilation of the debug script if it's not needed!

 @since 3.0.2
-}
mustCompileD ::
  forall (a :: S -> Type).
  (forall (s :: S). Term s a) ->
  DebuggableScript
mustCompileD :: forall (a :: S -> Type).
(forall (s :: S). Term s a) -> DebuggableScript
mustCompileD forall (s :: S). Term s a
term =
  Script -> Script -> DebuggableScript
DebuggableScript (forall (a :: S -> Type). ClosedTerm a -> Script
mustCompile forall (s :: S). Term s a
term) (forall (a :: S -> Type). ClosedTerm a -> Script
mustCompileTracing forall (s :: S). Term s a
term)

{- | Final evaluation of a 'DebuggableScript' to a 'Script', with errors resulting in
 exceptions.

 @since 3.0.2
-}
mustFinalEvalDebuggableScript :: DebuggableScript -> Script
mustFinalEvalDebuggableScript :: DebuggableScript -> Script
mustFinalEvalDebuggableScript DebuggableScript
s =
  let (Either EvalError Script
res, ExBudget
_, [Text]
traces) = DebuggableScript -> (Either EvalError Script, ExBudget, [Text])
finalEvalDebuggableScript DebuggableScript
s
   in case Either EvalError Script
res of
        Right Script
r -> Script
r
        Left EvalError
err ->
          forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
            [String] -> String
unlines
              [ String
"Error when evaluating Script:"
              , forall a. Show a => a -> String
show EvalError
err
              , String
"Traces:"
              , Text -> String
Text.unpack ([Text] -> Text
Text.unlines [Text]
traces)
              ]

{- | Final evaluation of a 'DebuggableScript', with full 'evalScript' result.

 Falls back to the debug script if a 'UserEvaluationError' occurs. Verifies that
 the debug script results in a 'UserEvaluationError' too, throws an exception
 otherwise.

 @since 3.0.2
-}
finalEvalDebuggableScript ::
  DebuggableScript ->
  (Either EvalError Script, ExBudget, [Text])
finalEvalDebuggableScript :: DebuggableScript -> (Either EvalError Script, ExBudget, [Text])
finalEvalDebuggableScript (DebuggableScript Script
script Script
debugScript) =
  case Either EvalError Script
res of
    Right Script
_ -> (Either EvalError Script, ExBudget, [Text])
r
    Left (ErrorWithCause EvaluationError CekUserError (MachineError DefaultFun)
evalErr Maybe (Term NamedDeBruijn DefaultUni DefaultFun ())
_) ->
      case EvaluationError CekUserError (MachineError DefaultFun)
evalErr of
        UserEvaluationError CekUserError
e ->
          case CekUserError
e of
            CekUserError
CekEvaluationFailure ->
              EvaluationError CekUserError (MachineError DefaultFun)
-> (Either EvalError Script, ExBudget, [Text])
verifyDebuggableScriptOutput EvaluationError CekUserError (MachineError DefaultFun)
evalErr
            CekUserError
_ -> (Either EvalError Script, ExBudget, [Text])
r
        EvaluationError CekUserError (MachineError DefaultFun)
_ -> (Either EvalError Script, ExBudget, [Text])
r
  where
    r :: (Either EvalError Script, ExBudget, [Text])
r@(Either EvalError Script
res, ExBudget
_, [Text]
_) = Script -> (Either EvalError Script, ExBudget, [Text])
evalScript Script
script
    r' :: (Either EvalError Script, ExBudget, [Text])
r'@(Either EvalError Script
res', ExBudget
_, [Text]
traces) = Script -> (Either EvalError Script, ExBudget, [Text])
evalScript Script
debugScript
    verifyDebuggableScriptOutput :: EvaluationError CekUserError (MachineError DefaultFun)
-> (Either EvalError Script, ExBudget, [Text])
verifyDebuggableScriptOutput EvaluationError CekUserError (MachineError DefaultFun)
origEvalErr =
      case Either EvalError Script
res' of
        Right Script
_ ->
          forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
            [String] -> String
unlines
              [ String
"Script failed, but corresponding debug Script "
                  forall a. Semigroup a => a -> a -> a
<> String
"succeeded!"
              , String
"Original error: "
              , forall a. Show a => a -> String
show EvaluationError CekUserError (MachineError DefaultFun)
origEvalErr
              , String
"Debug Script traces:"
              , Text -> String
Text.unpack ([Text] -> Text
Text.unlines [Text]
traces)
              ]
        Left (ErrorWithCause EvaluationError CekUserError (MachineError DefaultFun)
evalErr Maybe (Term NamedDeBruijn DefaultUni DefaultFun ())
_) ->
          case EvaluationError CekUserError (MachineError DefaultFun)
evalErr of
            UserEvaluationError CekUserError
e ->
              case CekUserError
e of
                CekUserError
CekEvaluationFailure ->
                  (Either EvalError Script, ExBudget, [Text])
r'
                CekOutOfExError ExRestrictingBudget
_ ->
                  forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
                    [String] -> String
unlines
                      [ String
"Script failed normally, "
                          forall a. Semigroup a => a -> a -> a
<> String
"but corresponding debug Script"
                          forall a. Semigroup a => a -> a -> a
<> String
"ran out of budget!"
                      , String
"Original error:"
                      , forall a. Show a => a -> String
show EvaluationError CekUserError (MachineError DefaultFun)
origEvalErr
                      , String
"Debug Script traces until crash:"
                      , Text -> String
Text.unpack ([Text] -> Text
Text.unlines [Text]
traces)
                      ]
            InternalEvaluationError MachineError DefaultFun
e ->
              forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
                [String] -> String
unlines
                  [ String
"Script failed with UserEvaluationError, "
                      forall a. Semigroup a => a -> a -> a
<> String
"but corresponding debug Script caused "
                      forall a. Semigroup a => a -> a -> a
<> String
"internal evaluation error!"
                  , String
"an Internal evaluation error:"
                  , forall a. Show a => a -> String
show MachineError DefaultFun
e
                  , String
"Original error:"
                  , forall a. Show a => a -> String
show EvaluationError CekUserError (MachineError DefaultFun)
origEvalErr
                  , String
"Debug Script traces until crash:"
                  , Text -> String
Text.unpack ([Text] -> Text
Text.unlines [Text]
traces)
                  ]

{- | Evaluate a 'Script' to a 'Script', with errors resulting in exceptions.

 This is mostly useful for pre-evaluating arguments to a thing being
 tested/benchmarked.

 @since 3.0.2
-}
mustEvalScript :: Script -> Script
mustEvalScript :: Script -> Script
mustEvalScript Script
s =
  case Either EvalError Script
res of
    Left EvalError
err ->
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
        [String] -> String
unlines
          [ String
"Error when evaluating Script:"
          , forall a. Show a => a -> String
show EvalError
err
          , String
"Traces:"
          , Text -> String
Text.unpack ([Text] -> Text
Text.unlines [Text]
traces)
          ]
    Right Script
sr -> Script
sr
  where
    (Either EvalError Script
res, ExBudget
_, [Text]
traces) = Script -> (Either EvalError Script, ExBudget, [Text])
evalScript Script
s

{- | Evaluate a 'DebuggableScript' to a 'DebuggableScript', with errors
  resulting in exceptions.

 This is mostly useful for pre-evaluating arguments to a thing being
 tested/benchmarked.
 Lazyness defers the evaluation (and exception) until it's needed, so the debug
 script causes no unneccessary work.

 @since 3.0.2
-}
mustEvalD :: DebuggableScript -> DebuggableScript
-- - If something else tries to use 'script' and it fails, we must fall
--   back to 'debugScript', this is just what 'mustEvalDebuggableScript' does.
-- - If something tries to use 'debugScript' directly (because another
--   Script in some expression failed already), there is nothing to fall
--   back to, so we need only 'mustEvalScript'.
mustEvalD :: DebuggableScript -> DebuggableScript
mustEvalD DebuggableScript
ds =
  Script -> Script -> DebuggableScript
DebuggableScript
    (DebuggableScript -> Script
mustFinalEvalDebuggableScript DebuggableScript
ds)
    (Script -> Script
mustEvalScript forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view forall a. IsLabel "debugScript" a => a
#debugScript forall a b. (a -> b) -> a -> b
$ DebuggableScript
ds)