{-# OPTIONS_GHC -Wall #-}

module FFI.SimplifierTrace
  ( TraceElem
  , Trace
  , mkFfiSimplifierTrace
  ) where

import FFI.Untyped qualified as FFI

import PlutusPrelude

import UntypedPlutusCore qualified as UPLC
import UntypedPlutusCore.Transform.Certify.Hints qualified as Certify
import UntypedPlutusCore.Transform.Simplifier

type TraceElem a = (SimplifierStage, (Certify.Hints, (a, a)))
type Trace a = [TraceElem a]

mkFfiSimplifierTrace
  :: SimplifierTrace UPLC.Name UPLC.DefaultUni UPLC.DefaultFun a
  -> Trace FFI.UTerm
mkFfiSimplifierTrace :: forall a.
SimplifierTrace Name DefaultUni DefaultFun a -> Trace UTerm
mkFfiSimplifierTrace (SimplifierTrace [Simplification Name DefaultUni DefaultFun a]
simplTrace) = Trace UTerm -> Trace UTerm
forall a. [a] -> [a]
reverse (Trace UTerm -> Trace UTerm) -> Trace UTerm -> Trace UTerm
forall a b. (a -> b) -> a -> b
$ Simplification Name DefaultUni DefaultFun a
-> (SimplifierStage, (Hints, (UTerm, UTerm)))
forall {a}.
Simplification Name DefaultUni DefaultFun a
-> (SimplifierStage, (Hints, (UTerm, UTerm)))
toFfiAst (Simplification Name DefaultUni DefaultFun a
 -> (SimplifierStage, (Hints, (UTerm, UTerm))))
-> [Simplification Name DefaultUni DefaultFun a] -> Trace UTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Simplification Name DefaultUni DefaultFun a]
simplTrace
  where
    toFfiAst :: Simplification Name DefaultUni DefaultFun a
-> (SimplifierStage, (Hints, (UTerm, UTerm)))
toFfiAst (Simplification Term Name DefaultUni DefaultFun a
before SimplifierStage
stage Hints
hints Term Name DefaultUni DefaultFun a
after) =
      case (Term Name DefaultUni DefaultFun a
-> Either
     FreeVariableError (Term NamedDeBruijn DefaultUni DefaultFun a)
forall (m :: * -> *) (uni :: * -> *) fun ann.
MonadError FreeVariableError m =>
Term Name uni fun ann -> m (Term NamedDeBruijn uni fun ann)
UPLC.deBruijnTerm Term Name DefaultUni DefaultFun a
before, Term Name DefaultUni DefaultFun a
-> Either
     FreeVariableError (Term NamedDeBruijn DefaultUni DefaultFun a)
forall (m :: * -> *) (uni :: * -> *) fun ann.
MonadError FreeVariableError m =>
Term Name uni fun ann -> m (Term NamedDeBruijn uni fun ann)
UPLC.deBruijnTerm Term Name DefaultUni DefaultFun a
after) of
        (Right Term NamedDeBruijn DefaultUni DefaultFun a
before', Right Term NamedDeBruijn DefaultUni DefaultFun a
after') ->
          (SimplifierStage
stage, (Hints
hints, (Term NamedDeBruijn DefaultUni DefaultFun () -> UTerm
forall a. Term NamedDeBruijn DefaultUni DefaultFun a -> UTerm
FFI.conv (Term NamedDeBruijn DefaultUni DefaultFun a
-> Term NamedDeBruijn DefaultUni DefaultFun ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Term NamedDeBruijn DefaultUni DefaultFun a
before'), Term NamedDeBruijn DefaultUni DefaultFun () -> UTerm
forall a. Term NamedDeBruijn DefaultUni DefaultFun a -> UTerm
FFI.conv (Term NamedDeBruijn DefaultUni DefaultFun a
-> Term NamedDeBruijn DefaultUni DefaultFun ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Term NamedDeBruijn DefaultUni DefaultFun a
after'))))
        (Left (FreeVariableError
err :: UPLC.FreeVariableError), Either
  FreeVariableError (Term NamedDeBruijn DefaultUni DefaultFun a)
_) -> [Char] -> (SimplifierStage, (Hints, (UTerm, UTerm)))
forall a. HasCallStack => [Char] -> a
error ([Char] -> (SimplifierStage, (Hints, (UTerm, UTerm))))
-> [Char] -> (SimplifierStage, (Hints, (UTerm, UTerm)))
forall a b. (a -> b) -> a -> b
$ FreeVariableError -> [Char]
forall a. Show a => a -> [Char]
show FreeVariableError
err
        (Either
  FreeVariableError (Term NamedDeBruijn DefaultUni DefaultFun a)
_, Left (FreeVariableError
err :: UPLC.FreeVariableError)) -> [Char] -> (SimplifierStage, (Hints, (UTerm, UTerm)))
forall a. HasCallStack => [Char] -> a
error ([Char] -> (SimplifierStage, (Hints, (UTerm, UTerm))))
-> [Char] -> (SimplifierStage, (Hints, (UTerm, UTerm)))
forall a b. (a -> b) -> a -> b
$ FreeVariableError -> [Char]
forall a. Show a => a -> [Char]
show FreeVariableError
err