{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE PolyKinds              #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE UndecidableInstances   #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module PlutusCore.Test (
  mapTestLimit,
  withAtLeastTests,
  mapTestLimitAtLeast,
  checkFails,
  isSerialisable,
  ToTPlc (..),
  ToUPlc (..),
  pureTry,
  catchAll,
  rethrow,
  runTPlc,
  runUPlc,
  runUPlcLogs,
  ppCatch,
  ppCatchReadable,
  goldenTPlc,
  goldenTPlcReadable,
  goldenUPlc,
  goldenUPlcReadable,
  goldenTEval,
  goldenUEval,
  goldenUEvalLogs,
  goldenUEvalProfile,
  goldenUEvalProfile',
  goldenUEvalBudget,
  goldenSize,
  initialSrcSpan,
  topSrcSpan,
  NoMarkRenameT (..),
  noMarkRename,
  NoRenameT (..),
  noRename,
  BrokenRenameT (..),
  runBrokenRenameT,
  brokenRename,
  Prerename (..),
  BindingRemoval (..),
  prop_scopingFor,
  test_scopingGood,
  test_scopingBad,
  test_scopingSpoilRenamer,
  -- * Tasty extras
  module TastyExtras,
) where

import PlutusPrelude

import PlutusCore qualified as TPLC
import PlutusCore.Annotation
import PlutusCore.Check.Scoping
import PlutusCore.Compiler qualified as TPLC
import PlutusCore.DeBruijn
import PlutusCore.Default (noMoreTypeFunctions)
import PlutusCore.Evaluation.Machine.Ck qualified as TPLC
import PlutusCore.Evaluation.Machine.ExBudget qualified as TPLC
import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as TPLC
import PlutusCore.Generators.Hedgehog.AST
import PlutusCore.Generators.Hedgehog.Utils
import PlutusCore.Pretty
import PlutusCore.Pretty qualified as PP
import PlutusCore.Rename.Monad qualified as TPLC
import UntypedPlutusCore qualified as UPLC
import UntypedPlutusCore.Evaluation.Machine.Cek qualified as UPLC

import Control.Exception
import Control.Lens
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Data.Either.Extras
import Data.Hashable
import Data.Kind qualified as GHC
import Data.Text (Text)
import Hedgehog
import Hedgehog.Internal.Config
import Hedgehog.Internal.Property
import Hedgehog.Internal.Region
import Hedgehog.Internal.Report
import Hedgehog.Internal.Runner
import Prettyprinter qualified as PP
import System.IO.Unsafe
import Test.Tasty hiding (after)
import Test.Tasty.Extras as TastyExtras
import Test.Tasty.Hedgehog
import Test.Tasty.HUnit
import Universe

-- | Map the 'TestLimit' of a 'Property' with a given function.
mapTestLimit :: (TestLimit -> TestLimit) -> Property -> Property
mapTestLimit :: (TestLimit -> TestLimit) -> Property -> Property
mapTestLimit TestLimit -> TestLimit
f =
  (PropertyConfig -> PropertyConfig) -> Property -> Property
mapConfig ((PropertyConfig -> PropertyConfig) -> Property -> Property)
-> (PropertyConfig -> PropertyConfig) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ \PropertyConfig
config ->
    PropertyConfig
config
      { propertyTerminationCriteria = case propertyTerminationCriteria config of
          NoEarlyTermination Confidence
c TestLimit
tests    -> Confidence -> TestLimit -> TerminationCriteria
NoEarlyTermination Confidence
c (TestLimit -> TerminationCriteria)
-> TestLimit -> TerminationCriteria
forall a b. (a -> b) -> a -> b
$ TestLimit -> TestLimit
f TestLimit
tests
          NoConfidenceTermination TestLimit
tests -> TestLimit -> TerminationCriteria
NoConfidenceTermination (TestLimit -> TerminationCriteria)
-> TestLimit -> TerminationCriteria
forall a b. (a -> b) -> a -> b
$ TestLimit -> TestLimit
f TestLimit
tests
          EarlyTermination Confidence
c TestLimit
tests      -> Confidence -> TestLimit -> TerminationCriteria
EarlyTermination Confidence
c (TestLimit -> TerminationCriteria)
-> TestLimit -> TerminationCriteria
forall a b. (a -> b) -> a -> b
$ TestLimit -> TestLimit
f TestLimit
tests
      }

{- | Set the number of times a property should be executed before it is considered successful,
unless it's already higher than that.
-}
withAtLeastTests :: TestLimit -> Property -> Property
withAtLeastTests :: TestLimit -> Property -> Property
withAtLeastTests = (TestLimit -> TestLimit) -> Property -> Property
mapTestLimit ((TestLimit -> TestLimit) -> Property -> Property)
-> (TestLimit -> TestLimit -> TestLimit)
-> TestLimit
-> Property
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestLimit -> TestLimit -> TestLimit
forall a. Ord a => a -> a -> a
max

{- | Set the number of times a property should be executed before it is considered successful,
unless the given function scales it higher than that.
-}
mapTestLimitAtLeast :: TestLimit -> (TestLimit -> TestLimit) -> Property -> Property
mapTestLimitAtLeast :: TestLimit -> (TestLimit -> TestLimit) -> Property -> Property
mapTestLimitAtLeast TestLimit
n TestLimit -> TestLimit
f = TestLimit -> Property -> Property
withAtLeastTests TestLimit
n (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestLimit -> TestLimit) -> Property -> Property
mapTestLimit TestLimit -> TestLimit
f

{- | @check@ is supposed to just check if the property fails or not, but for some stupid reason it
also performs shrinking and prints the counterexample and other junk. This function is like
@check@, but doesn't do any of that.
-}
checkQuiet :: (MonadIO m) => Property -> m Bool
checkQuiet :: forall (m :: * -> *). MonadIO m => Property -> m Bool
checkQuiet Property
prop = do
  UseColor
color <- m UseColor
forall (m :: * -> *). MonadIO m => m UseColor
detectColor
  -- This is what causes @hedgehog@ to shut up.
  Region
region <- IO Region -> m Region
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Region
forall (m :: * -> *). LiftRegion m => m Region
newEmptyRegion
  -- For some reason @hedgehog@ thinks it's a good idea to shrink a counterexample in case of
  -- an expected failure, so we suppress that.
  let propNoShrink :: Property
propNoShrink = ShrinkLimit -> Property -> Property
withShrinks ShrinkLimit
0 Property
prop
  IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ (Result -> Result -> Bool
forall a. Eq a => a -> a -> Bool
== Result
OK) (Result -> Bool)
-> (Report Result -> Result) -> Report Result -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Report Result -> Result
forall a. Report a -> a
reportStatus (Report Result -> Bool) -> IO (Report Result) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Region
-> UseColor
-> Maybe PropertyName
-> Maybe Seed
-> Property
-> IO (Report Result)
forall (m :: * -> *).
MonadIO m =>
Region
-> UseColor
-> Maybe PropertyName
-> Maybe Seed
-> Property
-> m (Report Result)
checkNamed Region
region UseColor
color Maybe PropertyName
forall a. Maybe a
Nothing Maybe Seed
forall a. Maybe a
Nothing Property
propNoShrink

-- | Check that the given 'Property' fails.
checkFails :: Property -> IO ()
-- 'withAtLeastTests' gives the property that is supposed to fail some room in order for it to
-- reach a failing test case.
checkFails :: Property -> IO ()
checkFails = Property -> IO Bool
forall (m :: * -> *). MonadIO m => Property -> m Bool
checkQuiet (Property -> IO Bool)
-> (Property -> Property) -> Property -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestLimit -> Property -> Property
withAtLeastTests TestLimit
1000 (Property -> IO Bool) -> (Bool -> IO ()) -> Property -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \Bool
res -> Bool
res Bool -> Bool -> IO ()
forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Bool
False

-- | Check whether the given constant can be serialised. Useful for tests of the
-- parser\/deserializer where we need to filter out unprintable\/unserialisable terms. Technically,
-- G1, G2 elements etc can be printed but not serialised, but here for simplicity we just assume
-- that all unserialisable terms are unprintable too.
isSerialisable :: Some (ValueOf TPLC.DefaultUni) -> Bool
isSerialisable :: Some (ValueOf DefaultUni) -> Bool
isSerialisable (Some (ValueOf DefaultUni (Esc a)
uni0 a
x0)) = DefaultUni (Esc a) -> a -> Bool
forall a. DefaultUni (Esc a) -> a -> Bool
go DefaultUni (Esc a)
uni0 a
x0 where
    go :: TPLC.DefaultUni (TPLC.Esc a) -> a -> Bool
    go :: forall a. DefaultUni (Esc a) -> a -> Bool
go DefaultUni (Esc a)
TPLC.DefaultUniInteger a
_ = Bool
True
    go DefaultUni (Esc a)
TPLC.DefaultUniByteString a
_ = Bool
True
    go DefaultUni (Esc a)
TPLC.DefaultUniString a
_ = Bool
True
    go DefaultUni (Esc a)
TPLC.DefaultUniUnit a
_ = Bool
True
    go DefaultUni (Esc a)
TPLC.DefaultUniBool a
_ = Bool
True
    go (DefaultUni (Esc f)
TPLC.DefaultUniProtoList `TPLC.DefaultUniApply` DefaultUni (Esc a1)
uniA) a
xs =
        (a1 -> Bool) -> [a1] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (DefaultUni (Esc a1) -> a1 -> Bool
forall a. DefaultUni (Esc a) -> a -> Bool
go DefaultUni (Esc a1)
DefaultUni (Esc a1)
uniA) a
[a1]
xs
    go (DefaultUni (Esc f)
TPLC.DefaultUniProtoPair `TPLC.DefaultUniApply` DefaultUni (Esc a1)
uniA `TPLC.DefaultUniApply` DefaultUni (Esc a1)
uniB) (a1
x, a1
y) =
        DefaultUni (Esc a1) -> a1 -> Bool
forall a. DefaultUni (Esc a) -> a -> Bool
go DefaultUni (Esc a1)
DefaultUni (Esc a1)
uniA a1
x Bool -> Bool -> Bool
&& DefaultUni (Esc a1) -> a1 -> Bool
forall a. DefaultUni (Esc a) -> a -> Bool
go DefaultUni (Esc a1)
DefaultUni (Esc a1)
uniB a1
y
    go (DefaultUni (Esc f)
f `TPLC.DefaultUniApply` DefaultUni (Esc a1)
_ `TPLC.DefaultUniApply` DefaultUni (Esc a1)
_ `TPLC.DefaultUniApply` DefaultUni (Esc a1)
_) a
_ =
        DefaultUni (Esc f) -> Bool
forall a b c d (f :: a -> b -> c -> d) any.
DefaultUni (Esc f) -> any
noMoreTypeFunctions DefaultUni (Esc f)
DefaultUni (Esc f)
f
    go DefaultUni (Esc a)
TPLC.DefaultUniData a
_ = Bool
True
    go DefaultUni (Esc a)
TPLC.DefaultUniBLS12_381_G1_Element a
_ = Bool
False
    go DefaultUni (Esc a)
TPLC.DefaultUniBLS12_381_G2_Element a
_ = Bool
False
    go DefaultUni (Esc a)
TPLC.DefaultUniBLS12_381_MlResult a
_ = Bool
False

{- | Class for ad-hoc overloading of things which can be turned into a PLC program. Any errors
from the process should be caught.
-}
class ToTPlc a uni fun | a -> uni fun where
  toTPlc :: a -> ExceptT SomeException IO (TPLC.Program TPLC.TyName TPLC.Name uni fun ())

instance (ToTPlc a uni fun) => ToTPlc (ExceptT SomeException IO a) uni fun where
  toTPlc :: ExceptT SomeException IO a
-> ExceptT SomeException IO (Program TyName Name uni fun ())
toTPlc ExceptT SomeException IO a
a = ExceptT SomeException IO a
a ExceptT SomeException IO a
-> (a -> ExceptT SomeException IO (Program TyName Name uni fun ()))
-> ExceptT SomeException IO (Program TyName Name uni fun ())
forall a b.
ExceptT SomeException IO a
-> (a -> ExceptT SomeException IO b) -> ExceptT SomeException IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> ExceptT SomeException IO (Program TyName Name uni fun ())
forall a (uni :: * -> *) fun.
ToTPlc a uni fun =>
a -> ExceptT SomeException IO (Program TyName Name uni fun ())
toTPlc

instance ToTPlc (TPLC.Program TPLC.TyName TPLC.Name uni fun ()) uni fun where
  toTPlc :: Program TyName Name uni fun ()
-> ExceptT SomeException IO (Program TyName Name uni fun ())
toTPlc = Program TyName Name uni fun ()
-> ExceptT SomeException IO (Program TyName Name uni fun ())
forall a. a -> ExceptT SomeException IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

class ToUPlc a uni fun | a -> uni fun where
  toUPlc :: a -> ExceptT SomeException IO (UPLC.Program TPLC.Name uni fun ())

instance (ToUPlc a uni fun) => ToUPlc (ExceptT SomeException IO a) uni fun where
  toUPlc :: ExceptT SomeException IO a
-> ExceptT SomeException IO (Program Name uni fun ())
toUPlc ExceptT SomeException IO a
a = ExceptT SomeException IO a
a ExceptT SomeException IO a
-> (a -> ExceptT SomeException IO (Program Name uni fun ()))
-> ExceptT SomeException IO (Program Name uni fun ())
forall a b.
ExceptT SomeException IO a
-> (a -> ExceptT SomeException IO b) -> ExceptT SomeException IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> ExceptT SomeException IO (Program Name uni fun ())
forall a (uni :: * -> *) fun.
ToUPlc a uni fun =>
a -> ExceptT SomeException IO (Program Name uni fun ())
toUPlc

instance ToUPlc (UPLC.Program TPLC.Name uni fun ()) uni fun where
  toUPlc :: Program Name uni fun ()
-> ExceptT SomeException IO (Program Name uni fun ())
toUPlc = Program Name uni fun ()
-> ExceptT SomeException IO (Program Name uni fun ())
forall a. a -> ExceptT SomeException IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance
  ( TPLC.Typecheckable uni fun
  , Hashable fun
  )
  => ToUPlc (TPLC.Program TPLC.TyName UPLC.Name uni fun ()) uni fun where
  toUPlc :: Program TyName Name uni fun ()
-> ExceptT SomeException IO (Program Name uni fun ())
toUPlc =
    Program Name uni fun ()
-> ExceptT SomeException IO (Program Name uni fun ())
forall a. a -> ExceptT SomeException IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Program Name uni fun ()
 -> ExceptT SomeException IO (Program Name uni fun ()))
-> (Program TyName Name uni fun () -> Program Name uni fun ())
-> Program TyName Name uni fun ()
-> ExceptT SomeException IO (Program Name uni fun ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Quote (Program Name uni fun ()) -> Program Name uni fun ()
forall a. Quote a -> a
TPLC.runQuote
      (Quote (Program Name uni fun ()) -> Program Name uni fun ())
-> (Program TyName Name uni fun ()
    -> Quote (Program Name uni fun ()))
-> Program TyName Name uni fun ()
-> Program Name uni fun ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT
   (CompilationOpts Name fun ())
   (QuoteT Identity)
   (Program Name uni fun ())
 -> CompilationOpts Name fun () -> Quote (Program Name uni fun ()))
-> CompilationOpts Name fun ()
-> ReaderT
     (CompilationOpts Name fun ())
     (QuoteT Identity)
     (Program Name uni fun ())
-> Quote (Program Name uni fun ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  (CompilationOpts Name fun ())
  (QuoteT Identity)
  (Program Name uni fun ())
-> CompilationOpts Name fun () -> Quote (Program Name uni fun ())
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT CompilationOpts Name fun ()
forall fun name a.
Default (BuiltinSemanticsVariant fun) =>
CompilationOpts name fun a
TPLC.defaultCompilationOpts
      (ReaderT
   (CompilationOpts Name fun ())
   (QuoteT Identity)
   (Program Name uni fun ())
 -> Quote (Program Name uni fun ()))
-> (Program TyName Name uni fun ()
    -> ReaderT
         (CompilationOpts Name fun ())
         (QuoteT Identity)
         (Program Name uni fun ()))
-> Program TyName Name uni fun ()
-> Quote (Program Name uni fun ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program TyName Name uni fun ()
-> ReaderT
     (CompilationOpts Name fun ())
     (QuoteT Identity)
     (Program Name uni fun ())
forall (m :: * -> *) (uni :: * -> *) fun name a tyname.
(Compiling m uni fun name a,
 MonadReader (CompilationOpts name fun a) m) =>
Program tyname name uni fun a -> m (Program name uni fun a)
TPLC.compileProgram

instance ToUPlc (UPLC.Program UPLC.NamedDeBruijn uni fun ()) uni fun where
  toUPlc :: Program NamedDeBruijn uni fun ()
-> ExceptT SomeException IO (Program Name uni fun ())
toUPlc Program NamedDeBruijn uni fun ()
p =
    forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT @_ @FreeVariableError FreeVariableError -> SomeException
forall e. Exception e => e -> SomeException
toException (ExceptT FreeVariableError IO (Program Name uni fun ())
 -> ExceptT SomeException IO (Program Name uni fun ()))
-> ExceptT FreeVariableError IO (Program Name uni fun ())
-> ExceptT SomeException IO (Program Name uni fun ())
forall a b. (a -> b) -> a -> b
$
      QuoteT (ExceptT FreeVariableError IO) (Program Name uni fun ())
-> ExceptT FreeVariableError IO (Program Name uni fun ())
forall (m :: * -> *) a. Monad m => QuoteT m a -> m a
TPLC.runQuoteT (QuoteT (ExceptT FreeVariableError IO) (Program Name uni fun ())
 -> ExceptT FreeVariableError IO (Program Name uni fun ()))
-> QuoteT (ExceptT FreeVariableError IO) (Program Name uni fun ())
-> ExceptT FreeVariableError IO (Program Name uni fun ())
forall a b. (a -> b) -> a -> b
$
        LensLike
  (QuoteT (ExceptT FreeVariableError IO))
  (Program NamedDeBruijn uni fun ())
  (Program Name uni fun ())
  (Term NamedDeBruijn uni fun ())
  (Term Name uni fun ())
-> LensLike
     (QuoteT (ExceptT FreeVariableError IO))
     (Program NamedDeBruijn uni fun ())
     (Program Name uni fun ())
     (Term NamedDeBruijn uni fun ())
     (Term Name uni fun ())
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
traverseOf
          LensLike
  (QuoteT (ExceptT FreeVariableError IO))
  (Program NamedDeBruijn uni fun ())
  (Program Name uni fun ())
  (Term NamedDeBruijn uni fun ())
  (Term Name uni fun ())
forall name1 (uni1 :: * -> *) fun1 ann name2 (uni2 :: * -> *) fun2
       (f :: * -> *).
Functor f =>
(Term name1 uni1 fun1 ann -> f (Term name2 uni2 fun2 ann))
-> Program name1 uni1 fun1 ann -> f (Program name2 uni2 fun2 ann)
UPLC.progTerm
          Term NamedDeBruijn uni fun ()
-> QuoteT (ExceptT FreeVariableError IO) (Term Name uni fun ())
forall (m :: * -> *) e (uni :: * -> *) fun ann.
(MonadQuote m, AsFreeVariableError e, MonadError e m) =>
Term NamedDeBruijn uni fun ann -> m (Term Name uni fun ann)
UPLC.unDeBruijnTerm
          Program NamedDeBruijn uni fun ()
p

pureTry :: (Exception e) => a -> Either e a
pureTry :: forall e a. Exception e => a -> Either e a
pureTry = IO (Either e a) -> Either e a
forall a. IO a -> a
unsafePerformIO (IO (Either e a) -> Either e a)
-> (a -> IO (Either e a)) -> a -> Either e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO (Either e a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO (Either e a)) -> (a -> IO a) -> a -> IO (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO a
forall a. a -> IO a
evaluate

catchAll :: a -> ExceptT SomeException IO a
catchAll :: forall a. a -> ExceptT SomeException IO a
catchAll a
value = IO (Either SomeException a) -> ExceptT SomeException IO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either SomeException a) -> ExceptT SomeException IO a)
-> IO (Either SomeException a) -> ExceptT SomeException IO a
forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (a -> IO a
forall a. a -> IO a
evaluate a
value)

rethrow :: ExceptT SomeException IO a -> IO a
rethrow :: forall a. ExceptT SomeException IO a -> IO a
rethrow = (Either SomeException a -> a)
-> IO (Either SomeException a) -> IO a
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either SomeException a -> a
forall e a. Exception e => Either e a -> a
unsafeFromEither (IO (Either SomeException a) -> IO a)
-> (ExceptT SomeException IO a -> IO (Either SomeException a))
-> ExceptT SomeException IO a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT SomeException IO a -> IO (Either SomeException a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

runTPlc ::
  (ToTPlc a TPLC.DefaultUni TPLC.DefaultFun) =>
  [a] ->
  ExceptT
    SomeException
    IO
    (TPLC.EvaluationResult (TPLC.Term TPLC.TyName TPLC.Name TPLC.DefaultUni TPLC.DefaultFun ()))
runTPlc :: forall a.
ToTPlc a DefaultUni DefaultFun =>
[a]
-> ExceptT
     SomeException
     IO
     (EvaluationResult (Term TyName Name DefaultUni DefaultFun ()))
runTPlc [a]
values = do
  [Program TyName Name DefaultUni DefaultFun ()]
ps <- (a
 -> ExceptT
      SomeException IO (Program TyName Name DefaultUni DefaultFun ()))
-> [a]
-> ExceptT
     SomeException IO [Program TyName Name DefaultUni DefaultFun ()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse a
-> ExceptT
     SomeException IO (Program TyName Name DefaultUni DefaultFun ())
forall a (uni :: * -> *) fun.
ToTPlc a uni fun =>
a -> ExceptT SomeException IO (Program TyName Name uni fun ())
toTPlc [a]
values
  let (TPLC.Program ()
_ Version
_ Term TyName Name DefaultUni DefaultFun ()
t) =
        (Program TyName Name DefaultUni DefaultFun ()
 -> Program TyName Name DefaultUni DefaultFun ()
 -> Program TyName Name DefaultUni DefaultFun ())
-> [Program TyName Name DefaultUni DefaultFun ()]
-> Program TyName Name DefaultUni DefaultFun ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1
          (Either
  ApplyProgramError (Program TyName Name DefaultUni DefaultFun ())
-> Program TyName Name DefaultUni DefaultFun ()
forall e a. Show e => Either e a -> a
unsafeFromRight (Either
   ApplyProgramError (Program TyName Name DefaultUni DefaultFun ())
 -> Program TyName Name DefaultUni DefaultFun ())
-> (Program TyName Name DefaultUni DefaultFun ()
    -> Program TyName Name DefaultUni DefaultFun ()
    -> Either
         ApplyProgramError (Program TyName Name DefaultUni DefaultFun ()))
-> Program TyName Name DefaultUni DefaultFun ()
-> Program TyName Name DefaultUni DefaultFun ()
-> Program TyName Name DefaultUni DefaultFun ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.* Program TyName Name DefaultUni DefaultFun ()
-> Program TyName Name DefaultUni DefaultFun ()
-> Either
     ApplyProgramError (Program TyName Name DefaultUni DefaultFun ())
forall (m :: * -> *) a tyname name (uni :: * -> *) fun.
(MonadError ApplyProgramError m, Semigroup a) =>
Program tyname name uni fun a
-> Program tyname name uni fun a
-> m (Program tyname name uni fun a)
TPLC.applyProgram)
          [Program TyName Name DefaultUni DefaultFun ()]
ps
  Either
  SomeException
  (EvaluationResult (Term TyName Name DefaultUni DefaultFun ()))
-> ExceptT
     SomeException
     IO
     (EvaluationResult (Term TyName Name DefaultUni DefaultFun ()))
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either
   SomeException
   (EvaluationResult (Term TyName Name DefaultUni DefaultFun ()))
 -> ExceptT
      SomeException
      IO
      (EvaluationResult (Term TyName Name DefaultUni DefaultFun ())))
-> (Either
      (EvaluationException
         (MachineError DefaultFun)
         CkUserError
         (Term TyName Name DefaultUni DefaultFun ()))
      (Term TyName Name DefaultUni DefaultFun ())
    -> Either
         SomeException
         (EvaluationResult (Term TyName Name DefaultUni DefaultFun ())))
-> Either
     (EvaluationException
        (MachineError DefaultFun)
        CkUserError
        (Term TyName Name DefaultUni DefaultFun ()))
     (Term TyName Name DefaultUni DefaultFun ())
-> ExceptT
     SomeException
     IO
     (EvaluationResult (Term TyName Name DefaultUni DefaultFun ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ErrorWithCause
   (MachineError DefaultFun)
   (Term TyName Name DefaultUni DefaultFun ())
 -> SomeException)
-> Either
     (ErrorWithCause
        (MachineError DefaultFun)
        (Term TyName Name DefaultUni DefaultFun ()))
     (EvaluationResult (Term TyName Name DefaultUni DefaultFun ()))
-> Either
     SomeException
     (EvaluationResult (Term TyName Name DefaultUni DefaultFun ()))
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ErrorWithCause
  (MachineError DefaultFun)
  (Term TyName Name DefaultUni DefaultFun ())
-> SomeException
forall e. Exception e => e -> SomeException
toException (Either
   (ErrorWithCause
      (MachineError DefaultFun)
      (Term TyName Name DefaultUni DefaultFun ()))
   (EvaluationResult (Term TyName Name DefaultUni DefaultFun ()))
 -> Either
      SomeException
      (EvaluationResult (Term TyName Name DefaultUni DefaultFun ())))
-> (Either
      (EvaluationException
         (MachineError DefaultFun)
         CkUserError
         (Term TyName Name DefaultUni DefaultFun ()))
      (Term TyName Name DefaultUni DefaultFun ())
    -> Either
         (ErrorWithCause
            (MachineError DefaultFun)
            (Term TyName Name DefaultUni DefaultFun ()))
         (EvaluationResult (Term TyName Name DefaultUni DefaultFun ())))
-> Either
     (EvaluationException
        (MachineError DefaultFun)
        CkUserError
        (Term TyName Name DefaultUni DefaultFun ()))
     (Term TyName Name DefaultUni DefaultFun ())
-> Either
     SomeException
     (EvaluationResult (Term TyName Name DefaultUni DefaultFun ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either
  (EvaluationException
     (MachineError DefaultFun)
     CkUserError
     (Term TyName Name DefaultUni DefaultFun ()))
  (Term TyName Name DefaultUni DefaultFun ())
-> Either
     (ErrorWithCause
        (MachineError DefaultFun)
        (Term TyName Name DefaultUni DefaultFun ()))
     (EvaluationResult (Term TyName Name DefaultUni DefaultFun ()))
forall structural operational term a.
Either (EvaluationException structural operational term) a
-> Either (ErrorWithCause structural term) (EvaluationResult a)
TPLC.splitStructuralOperational (Either
   (EvaluationException
      (MachineError DefaultFun)
      CkUserError
      (Term TyName Name DefaultUni DefaultFun ()))
   (Term TyName Name DefaultUni DefaultFun ())
 -> ExceptT
      SomeException
      IO
      (EvaluationResult (Term TyName Name DefaultUni DefaultFun ())))
-> Either
     (EvaluationException
        (MachineError DefaultFun)
        CkUserError
        (Term TyName Name DefaultUni DefaultFun ()))
     (Term TyName Name DefaultUni DefaultFun ())
-> ExceptT
     SomeException
     IO
     (EvaluationResult (Term TyName Name DefaultUni DefaultFun ()))
forall a b. (a -> b) -> a -> b
$
    BuiltinsRuntime DefaultFun (CkValue DefaultUni DefaultFun)
-> Term TyName Name DefaultUni DefaultFun ()
-> Either
     (EvaluationException
        (MachineError DefaultFun)
        CkUserError
        (Term TyName Name DefaultUni DefaultFun ()))
     (Term TyName Name DefaultUni DefaultFun ())
forall fun (uni :: * -> *).
BuiltinsRuntime fun (CkValue uni fun)
-> Term TyName Name uni fun ()
-> Either
     (CkEvaluationException uni fun) (Term TyName Name uni fun ())
TPLC.evaluateCkNoEmit BuiltinsRuntime DefaultFun (CkValue DefaultUni DefaultFun)
forall term.
HasMeaningIn DefaultUni term =>
BuiltinsRuntime DefaultFun term
TPLC.defaultBuiltinsRuntimeForTesting Term TyName Name DefaultUni DefaultFun ()
t

-- | An evaluation failure plus the final budget and logs.
data EvaluationExceptionWithLogsAndBudget err =
  EvaluationExceptionWithLogsAndBudget err TPLC.ExBudget [Text]

instance (PrettyBy config err)
  => PrettyBy config (EvaluationExceptionWithLogsAndBudget err) where
  prettyBy :: forall ann.
config -> EvaluationExceptionWithLogsAndBudget err -> Doc ann
prettyBy config
config (EvaluationExceptionWithLogsAndBudget err
err ExBudget
budget [Text]
logs) =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep
    [ config -> err -> Doc ann
forall ann. config -> err -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy config
config err
err
    , Doc ann
"Final budget:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> ExBudget -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. ExBudget -> Doc ann
PP.pretty ExBudget
budget
    , Doc ann
"Logs:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep ((Text -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty [Text]
logs)
    ]

instance (PrettyPlc err)
  => Show (EvaluationExceptionWithLogsAndBudget err) where
    show :: EvaluationExceptionWithLogsAndBudget err -> String
show = Doc Any -> String
forall ann. Doc ann -> String
forall str ann. Render str => Doc ann -> str
render (Doc Any -> String)
-> (EvaluationExceptionWithLogsAndBudget err -> Doc Any)
-> EvaluationExceptionWithLogsAndBudget err
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvaluationExceptionWithLogsAndBudget err -> Doc Any
forall a ann. PrettyPlc a => a -> Doc ann
prettyPlcReadableSimple

instance (PrettyPlc err, Exception err)
  => Exception (EvaluationExceptionWithLogsAndBudget err)

runUPlcFull ::
  (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) =>
  [a] ->
  ExceptT
    SomeException
    IO
    (UPLC.Term TPLC.Name TPLC.DefaultUni TPLC.DefaultFun (), TPLC.ExBudget, [Text])
runUPlcFull :: forall a.
ToUPlc a DefaultUni DefaultFun =>
[a]
-> ExceptT
     SomeException
     IO
     (Term Name DefaultUni DefaultFun (), ExBudget, [Text])
runUPlcFull [a]
values = do
  [Program Name DefaultUni DefaultFun ()]
ps <- (a
 -> ExceptT
      SomeException IO (Program Name DefaultUni DefaultFun ()))
-> [a]
-> ExceptT SomeException IO [Program Name DefaultUni DefaultFun ()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse a
-> ExceptT SomeException IO (Program Name DefaultUni DefaultFun ())
forall a (uni :: * -> *) fun.
ToUPlc a uni fun =>
a -> ExceptT SomeException IO (Program Name uni fun ())
toUPlc [a]
values
  let (UPLC.Program ()
_ Version
_ Term Name DefaultUni DefaultFun ()
t) = (Program Name DefaultUni DefaultFun ()
 -> Program Name DefaultUni DefaultFun ()
 -> Program Name DefaultUni DefaultFun ())
-> [Program Name DefaultUni DefaultFun ()]
-> Program Name DefaultUni DefaultFun ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (Either ApplyProgramError (Program Name DefaultUni DefaultFun ())
-> Program Name DefaultUni DefaultFun ()
forall e a. Show e => Either e a -> a
unsafeFromRight (Either ApplyProgramError (Program Name DefaultUni DefaultFun ())
 -> Program Name DefaultUni DefaultFun ())
-> (Program Name DefaultUni DefaultFun ()
    -> Program Name DefaultUni DefaultFun ()
    -> Either
         ApplyProgramError (Program Name DefaultUni DefaultFun ()))
-> Program Name DefaultUni DefaultFun ()
-> Program Name DefaultUni DefaultFun ()
-> Program Name DefaultUni DefaultFun ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.* Program Name DefaultUni DefaultFun ()
-> Program Name DefaultUni DefaultFun ()
-> Either ApplyProgramError (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) a name (uni :: * -> *) fun.
(MonadError ApplyProgramError m, Semigroup a) =>
Program name uni fun a
-> Program name uni fun a -> m (Program name uni fun a)
UPLC.applyProgram) [Program Name DefaultUni DefaultFun ()]
ps
      (Either
  (CekEvaluationException Name DefaultUni DefaultFun)
  (Term Name DefaultUni DefaultFun ())
res, UPLC.CountingSt ExBudget
budget, [Text]
logs) =
        MachineParameters
  CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ())
-> ExBudgetMode CountingSt DefaultUni DefaultFun
-> EmitterMode DefaultUni DefaultFun
-> Term Name DefaultUni DefaultFun ()
-> (Either
      (CekEvaluationException Name DefaultUni DefaultFun)
      (Term Name DefaultUni DefaultFun ()),
    CountingSt, [Text])
forall (uni :: * -> *) fun ann cost.
ThrowableBuiltins uni fun =>
MachineParameters CekMachineCosts fun (CekValue uni fun ann)
-> ExBudgetMode cost uni fun
-> EmitterMode uni fun
-> Term Name uni fun ann
-> (Either
      (CekEvaluationException Name uni fun) (Term Name uni fun ()),
    cost, [Text])
UPLC.runCek MachineParameters
  CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ())
forall ann.
Typeable ann =>
MachineParameters
  CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann)
TPLC.defaultCekParametersForTesting ExBudgetMode CountingSt DefaultUni DefaultFun
forall (uni :: * -> *) fun. ExBudgetMode CountingSt uni fun
UPLC.counting EmitterMode DefaultUni DefaultFun
forall (uni :: * -> *) fun. EmitterMode uni fun
UPLC.logEmitter Term Name DefaultUni DefaultFun ()
t
  case Either
  (CekEvaluationException Name DefaultUni DefaultFun)
  (Term Name DefaultUni DefaultFun ())
res of
    Left CekEvaluationException Name DefaultUni DefaultFun
err   -> SomeException
-> ExceptT
     SomeException
     IO
     (Term Name DefaultUni DefaultFun (), ExBudget, [Text])
forall a. SomeException -> ExceptT SomeException IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EvaluationExceptionWithLogsAndBudget
  (CekEvaluationException Name DefaultUni DefaultFun)
-> SomeException
forall e. Exception e => e -> SomeException
SomeException (EvaluationExceptionWithLogsAndBudget
   (CekEvaluationException Name DefaultUni DefaultFun)
 -> SomeException)
-> EvaluationExceptionWithLogsAndBudget
     (CekEvaluationException Name DefaultUni DefaultFun)
-> SomeException
forall a b. (a -> b) -> a -> b
$ CekEvaluationException Name DefaultUni DefaultFun
-> ExBudget
-> [Text]
-> EvaluationExceptionWithLogsAndBudget
     (CekEvaluationException Name DefaultUni DefaultFun)
forall err.
err
-> ExBudget -> [Text] -> EvaluationExceptionWithLogsAndBudget err
EvaluationExceptionWithLogsAndBudget CekEvaluationException Name DefaultUni DefaultFun
err ExBudget
budget [Text]
logs)
    Right Term Name DefaultUni DefaultFun ()
resT -> (Term Name DefaultUni DefaultFun (), ExBudget, [Text])
-> ExceptT
     SomeException
     IO
     (Term Name DefaultUni DefaultFun (), ExBudget, [Text])
forall a. a -> ExceptT SomeException IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term Name DefaultUni DefaultFun ()
resT, ExBudget
budget, [Text]
logs)

runUPlc ::
  (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) =>
  [a] ->
  ExceptT
    SomeException
    IO
    (UPLC.Term TPLC.Name TPLC.DefaultUni TPLC.DefaultFun ())
runUPlc :: forall a.
ToUPlc a DefaultUni DefaultFun =>
[a]
-> ExceptT SomeException IO (Term Name DefaultUni DefaultFun ())
runUPlc [a]
values = do
  (Term Name DefaultUni DefaultFun ()
t, ExBudget
_, [Text]
_) <- [a]
-> ExceptT
     SomeException
     IO
     (Term Name DefaultUni DefaultFun (), ExBudget, [Text])
forall a.
ToUPlc a DefaultUni DefaultFun =>
[a]
-> ExceptT
     SomeException
     IO
     (Term Name DefaultUni DefaultFun (), ExBudget, [Text])
runUPlcFull [a]
values
  Term Name DefaultUni DefaultFun ()
-> ExceptT SomeException IO (Term Name DefaultUni DefaultFun ())
forall a. a -> ExceptT SomeException IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term Name DefaultUni DefaultFun ()
t

runUPlcBudget ::
  (ToUPlc a TPLC.DefaultUni UPLC.DefaultFun) =>
  [a] ->
  ExceptT
    SomeException
    IO
    TPLC.ExBudget
runUPlcBudget :: forall a.
ToUPlc a DefaultUni DefaultFun =>
[a] -> ExceptT SomeException IO ExBudget
runUPlcBudget [a]
values = do
  (Term Name DefaultUni DefaultFun ()
_, ExBudget
budget, [Text]
_) <- [a]
-> ExceptT
     SomeException
     IO
     (Term Name DefaultUni DefaultFun (), ExBudget, [Text])
forall a.
ToUPlc a DefaultUni DefaultFun =>
[a]
-> ExceptT
     SomeException
     IO
     (Term Name DefaultUni DefaultFun (), ExBudget, [Text])
runUPlcFull [a]
values
  ExBudget -> ExceptT SomeException IO ExBudget
forall a. a -> ExceptT SomeException IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExBudget
budget

runUPlcLogs ::
  (ToUPlc a TPLC.DefaultUni UPLC.DefaultFun) =>
  [a] ->
  ExceptT
    SomeException
    IO
    [Text]
runUPlcLogs :: forall a.
ToUPlc a DefaultUni DefaultFun =>
[a] -> ExceptT SomeException IO [Text]
runUPlcLogs [a]
values = do
  (Term Name DefaultUni DefaultFun ()
_, ExBudget
_, [Text]
logs) <- [a]
-> ExceptT
     SomeException
     IO
     (Term Name DefaultUni DefaultFun (), ExBudget, [Text])
forall a.
ToUPlc a DefaultUni DefaultFun =>
[a]
-> ExceptT
     SomeException
     IO
     (Term Name DefaultUni DefaultFun (), ExBudget, [Text])
runUPlcFull [a]
values
  [Text] -> ExceptT SomeException IO [Text]
forall a. a -> ExceptT SomeException IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
logs

runUPlcProfile ::
  (ToUPlc a TPLC.DefaultUni UPLC.DefaultFun) =>
  [a] ->
  ExceptT
    SomeException
    IO
    [Text]
-- Can't use runUplcFull here, as with the others, becasue this one actually needs
-- to set a different logging method
runUPlcProfile :: forall a.
ToUPlc a DefaultUni DefaultFun =>
[a] -> ExceptT SomeException IO [Text]
runUPlcProfile [a]
values = do
  [Program Name DefaultUni DefaultFun ()]
ps <- (a
 -> ExceptT
      SomeException IO (Program Name DefaultUni DefaultFun ()))
-> [a]
-> ExceptT SomeException IO [Program Name DefaultUni DefaultFun ()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse a
-> ExceptT SomeException IO (Program Name DefaultUni DefaultFun ())
forall a (uni :: * -> *) fun.
ToUPlc a uni fun =>
a -> ExceptT SomeException IO (Program Name uni fun ())
toUPlc [a]
values
  let (UPLC.Program ()
_ Version
_ Term Name DefaultUni DefaultFun ()
t) = (Program Name DefaultUni DefaultFun ()
 -> Program Name DefaultUni DefaultFun ()
 -> Program Name DefaultUni DefaultFun ())
-> [Program Name DefaultUni DefaultFun ()]
-> Program Name DefaultUni DefaultFun ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (Either ApplyProgramError (Program Name DefaultUni DefaultFun ())
-> Program Name DefaultUni DefaultFun ()
forall e a. Show e => Either e a -> a
unsafeFromRight (Either ApplyProgramError (Program Name DefaultUni DefaultFun ())
 -> Program Name DefaultUni DefaultFun ())
-> (Program Name DefaultUni DefaultFun ()
    -> Program Name DefaultUni DefaultFun ()
    -> Either
         ApplyProgramError (Program Name DefaultUni DefaultFun ()))
-> Program Name DefaultUni DefaultFun ()
-> Program Name DefaultUni DefaultFun ()
-> Program Name DefaultUni DefaultFun ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.* Program Name DefaultUni DefaultFun ()
-> Program Name DefaultUni DefaultFun ()
-> Either ApplyProgramError (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) a name (uni :: * -> *) fun.
(MonadError ApplyProgramError m, Semigroup a) =>
Program name uni fun a
-> Program name uni fun a -> m (Program name uni fun a)
UPLC.applyProgram) [Program Name DefaultUni DefaultFun ()]
ps
      (Either
  (CekEvaluationException Name DefaultUni DefaultFun)
  (Term Name DefaultUni DefaultFun ())
res, UPLC.CountingSt ExBudget
budget, [Text]
logs) =
        MachineParameters
  CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ())
-> ExBudgetMode CountingSt DefaultUni DefaultFun
-> EmitterMode DefaultUni DefaultFun
-> Term Name DefaultUni DefaultFun ()
-> (Either
      (CekEvaluationException Name DefaultUni DefaultFun)
      (Term Name DefaultUni DefaultFun ()),
    CountingSt, [Text])
forall (uni :: * -> *) fun ann cost.
ThrowableBuiltins uni fun =>
MachineParameters CekMachineCosts fun (CekValue uni fun ann)
-> ExBudgetMode cost uni fun
-> EmitterMode uni fun
-> Term Name uni fun ann
-> (Either
      (CekEvaluationException Name uni fun) (Term Name uni fun ()),
    cost, [Text])
UPLC.runCek MachineParameters
  CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ())
forall ann.
Typeable ann =>
MachineParameters
  CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann)
TPLC.defaultCekParametersForTesting ExBudgetMode CountingSt DefaultUni DefaultFun
forall (uni :: * -> *) fun. ExBudgetMode CountingSt uni fun
UPLC.counting EmitterMode DefaultUni DefaultFun
forall (uni :: * -> *) fun. EmitterMode uni fun
UPLC.logWithTimeEmitter Term Name DefaultUni DefaultFun ()
t
  case Either
  (CekEvaluationException Name DefaultUni DefaultFun)
  (Term Name DefaultUni DefaultFun ())
res of
    Left CekEvaluationException Name DefaultUni DefaultFun
err -> SomeException -> ExceptT SomeException IO [Text]
forall a. SomeException -> ExceptT SomeException IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EvaluationExceptionWithLogsAndBudget
  (CekEvaluationException Name DefaultUni DefaultFun)
-> SomeException
forall e. Exception e => e -> SomeException
SomeException (EvaluationExceptionWithLogsAndBudget
   (CekEvaluationException Name DefaultUni DefaultFun)
 -> SomeException)
-> EvaluationExceptionWithLogsAndBudget
     (CekEvaluationException Name DefaultUni DefaultFun)
-> SomeException
forall a b. (a -> b) -> a -> b
$ CekEvaluationException Name DefaultUni DefaultFun
-> ExBudget
-> [Text]
-> EvaluationExceptionWithLogsAndBudget
     (CekEvaluationException Name DefaultUni DefaultFun)
forall err.
err
-> ExBudget -> [Text] -> EvaluationExceptionWithLogsAndBudget err
EvaluationExceptionWithLogsAndBudget CekEvaluationException Name DefaultUni DefaultFun
err ExBudget
budget [Text]
logs)
    Right Term Name DefaultUni DefaultFun ()
_  -> [Text] -> ExceptT SomeException IO [Text]
forall a. a -> ExceptT SomeException IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
logs

runUPlcProfile' ::
  (ToUPlc a TPLC.DefaultUni UPLC.DefaultFun) =>
  [a] ->
  ExceptT
    SomeException
    IO
    [Text]
-- Can't use runUplcFull here, as with the others, becasue this one actually needs
-- to set a different logging method
runUPlcProfile' :: forall a.
ToUPlc a DefaultUni DefaultFun =>
[a] -> ExceptT SomeException IO [Text]
runUPlcProfile' [a]
values = do
  [Program Name DefaultUni DefaultFun ()]
ps <- (a
 -> ExceptT
      SomeException IO (Program Name DefaultUni DefaultFun ()))
-> [a]
-> ExceptT SomeException IO [Program Name DefaultUni DefaultFun ()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse a
-> ExceptT SomeException IO (Program Name DefaultUni DefaultFun ())
forall a (uni :: * -> *) fun.
ToUPlc a uni fun =>
a -> ExceptT SomeException IO (Program Name uni fun ())
toUPlc [a]
values
  let (UPLC.Program ()
_ Version
_ Term Name DefaultUni DefaultFun ()
t) = (Program Name DefaultUni DefaultFun ()
 -> Program Name DefaultUni DefaultFun ()
 -> Program Name DefaultUni DefaultFun ())
-> [Program Name DefaultUni DefaultFun ()]
-> Program Name DefaultUni DefaultFun ()
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (Either ApplyProgramError (Program Name DefaultUni DefaultFun ())
-> Program Name DefaultUni DefaultFun ()
forall e a. Show e => Either e a -> a
unsafeFromRight (Either ApplyProgramError (Program Name DefaultUni DefaultFun ())
 -> Program Name DefaultUni DefaultFun ())
-> (Program Name DefaultUni DefaultFun ()
    -> Program Name DefaultUni DefaultFun ()
    -> Either
         ApplyProgramError (Program Name DefaultUni DefaultFun ()))
-> Program Name DefaultUni DefaultFun ()
-> Program Name DefaultUni DefaultFun ()
-> Program Name DefaultUni DefaultFun ()
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.* Program Name DefaultUni DefaultFun ()
-> Program Name DefaultUni DefaultFun ()
-> Either ApplyProgramError (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) a name (uni :: * -> *) fun.
(MonadError ApplyProgramError m, Semigroup a) =>
Program name uni fun a
-> Program name uni fun a -> m (Program name uni fun a)
UPLC.applyProgram) [Program Name DefaultUni DefaultFun ()]
ps
      (Either
  (CekEvaluationException Name DefaultUni DefaultFun)
  (Term Name DefaultUni DefaultFun ())
res, UPLC.CountingSt ExBudget
_, [Text]
logs) =
        MachineParameters
  CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ())
-> ExBudgetMode CountingSt DefaultUni DefaultFun
-> EmitterMode DefaultUni DefaultFun
-> Term Name DefaultUni DefaultFun ()
-> (Either
      (CekEvaluationException Name DefaultUni DefaultFun)
      (Term Name DefaultUni DefaultFun ()),
    CountingSt, [Text])
forall (uni :: * -> *) fun ann cost.
ThrowableBuiltins uni fun =>
MachineParameters CekMachineCosts fun (CekValue uni fun ann)
-> ExBudgetMode cost uni fun
-> EmitterMode uni fun
-> Term Name uni fun ann
-> (Either
      (CekEvaluationException Name uni fun) (Term Name uni fun ()),
    cost, [Text])
UPLC.runCek MachineParameters
  CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ())
forall ann.
Typeable ann =>
MachineParameters
  CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann)
TPLC.defaultCekParametersForTesting ExBudgetMode CountingSt DefaultUni DefaultFun
forall (uni :: * -> *) fun. ExBudgetMode CountingSt uni fun
UPLC.counting EmitterMode DefaultUni DefaultFun
forall (uni :: * -> *) fun. EmitterMode uni fun
UPLC.logWithBudgetEmitter Term Name DefaultUni DefaultFun ()
t
  case Either
  (CekEvaluationException Name DefaultUni DefaultFun)
  (Term Name DefaultUni DefaultFun ())
res of
    Left CekEvaluationException Name DefaultUni DefaultFun
err -> SomeException -> ExceptT SomeException IO [Text]
forall a. SomeException -> ExceptT SomeException IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CekEvaluationException Name DefaultUni DefaultFun -> SomeException
forall e. Exception e => e -> SomeException
SomeException CekEvaluationException Name DefaultUni DefaultFun
err)
    Right Term Name DefaultUni DefaultFun ()
_  -> [Text] -> ExceptT SomeException IO [Text]
forall a. a -> ExceptT SomeException IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
logs

ppCatch :: (PrettyPlc a) => ExceptT SomeException IO a -> IO (Doc ann)
ppCatch :: forall a ann.
PrettyPlc a =>
ExceptT SomeException IO a -> IO (Doc ann)
ppCatch ExceptT SomeException IO a
value = (SomeException -> Doc ann)
-> (a -> Doc ann) -> Either SomeException a -> Doc ann
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Doc ann
forall a ann. PrettyClassic a => a -> Doc ann
PP.prettyClassic (String -> Doc ann)
-> (SomeException -> String) -> SomeException -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) a -> Doc ann
forall a ann. PrettyPlc a => a -> Doc ann
prettyPlcReadableSimple (Either SomeException a -> Doc ann)
-> IO (Either SomeException a) -> IO (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT SomeException IO a -> IO (Either SomeException a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT SomeException IO a
value

ppCatch' :: ExceptT SomeException IO (Doc ann) -> IO (Doc ann)
ppCatch' :: forall ann. ExceptT SomeException IO (Doc ann) -> IO (Doc ann)
ppCatch' ExceptT SomeException IO (Doc ann)
value = (SomeException -> Doc ann)
-> (Doc ann -> Doc ann)
-> Either SomeException (Doc ann)
-> Doc ann
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Doc ann
forall a ann. PrettyClassic a => a -> Doc ann
PP.prettyClassic (String -> Doc ann)
-> (SomeException -> String) -> SomeException -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) Doc ann -> Doc ann
forall a. a -> a
id (Either SomeException (Doc ann) -> Doc ann)
-> IO (Either SomeException (Doc ann)) -> IO (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT SomeException IO (Doc ann)
-> IO (Either SomeException (Doc ann))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT SomeException IO (Doc ann)
value

ppCatchReadable
  :: forall a ann
   . PrettyBy (PrettyConfigReadable PrettyConfigName) a
  => ExceptT SomeException IO a -> IO (Doc ann)
ppCatchReadable :: forall a ann.
PrettyBy (PrettyConfigReadable PrettyConfigName) a =>
ExceptT SomeException IO a -> IO (Doc ann)
ppCatchReadable ExceptT SomeException IO a
value =
  let pprint :: forall t. PrettyBy (PrettyConfigReadable PrettyConfigName) t => t -> Doc ann
      pprint :: forall t.
PrettyBy (PrettyConfigReadable PrettyConfigName) t =>
t -> Doc ann
pprint = PrettyConfigReadable PrettyConfigName -> t -> Doc ann
forall ann. PrettyConfigReadable PrettyConfigName -> t -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy (PrettyConfigName
-> ShowKinds -> PrettyConfigReadable PrettyConfigName
forall configName.
configName -> ShowKinds -> PrettyConfigReadable configName
topPrettyConfigReadable PrettyConfigName
prettyConfigNameSimple ShowKinds
forall a. Default a => a
def)
   in (SomeException -> Doc ann)
-> (a -> Doc ann) -> Either SomeException a -> Doc ann
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Doc ann
forall t.
PrettyBy (PrettyConfigReadable PrettyConfigName) t =>
t -> Doc ann
pprint (String -> Doc ann)
-> (SomeException -> String) -> SomeException -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) a -> Doc ann
forall t.
PrettyBy (PrettyConfigReadable PrettyConfigName) t =>
t -> Doc ann
pprint (Either SomeException a -> Doc ann)
-> IO (Either SomeException a) -> IO (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT SomeException IO a -> IO (Either SomeException a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT SomeException IO a
value

goldenTPlcWith ::
  (ToTPlc a TPLC.DefaultUni TPLC.DefaultFun) =>
  ( ExceptT
      SomeException
      IO
      (TPLC.Program TPLC.NamedTyDeBruijn TPLC.NamedDeBruijn TPLC.DefaultUni TPLC.DefaultFun ()) ->
    IO (Doc ann)
  ) ->
  String ->
  a ->
  TestNested
goldenTPlcWith :: forall a ann.
ToTPlc a DefaultUni DefaultFun =>
(ExceptT
   SomeException
   IO
   (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
 -> IO (Doc ann))
-> String -> a -> TestNested
goldenTPlcWith ExceptT
  SomeException
  IO
  (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
-> IO (Doc ann)
pp String
name a
value = String -> String -> IO (Doc ann) -> TestNested
forall ann. String -> String -> IO (Doc ann) -> TestNested
nestedGoldenVsDocM String
name String
".tplc" (IO (Doc ann) -> TestNested) -> IO (Doc ann) -> TestNested
forall a b. (a -> b) -> a -> b
$ ExceptT
  SomeException
  IO
  (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
-> IO (Doc ann)
pp (ExceptT
   SomeException
   IO
   (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
 -> IO (Doc ann))
-> ExceptT
     SomeException
     IO
     (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
-> IO (Doc ann)
forall a b. (a -> b) -> a -> b
$ do
  Program TyName Name DefaultUni DefaultFun ()
p <- a
-> ExceptT
     SomeException IO (Program TyName Name DefaultUni DefaultFun ())
forall a (uni :: * -> *) fun.
ToTPlc a uni fun =>
a -> ExceptT SomeException IO (Program TyName Name uni fun ())
toTPlc a
value
  forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT @_ @FreeVariableError FreeVariableError -> SomeException
forall e. Exception e => e -> SomeException
toException (ExceptT
   FreeVariableError
   IO
   (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
 -> ExceptT
      SomeException
      IO
      (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ()))
-> ExceptT
     FreeVariableError
     IO
     (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
-> ExceptT
     SomeException
     IO
     (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ LensLike
  (ExceptT FreeVariableError IO)
  (Program TyName Name DefaultUni DefaultFun ())
  (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
  (Term TyName Name DefaultUni DefaultFun ())
  (Term NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
-> LensLike
     (ExceptT FreeVariableError IO)
     (Program TyName Name DefaultUni DefaultFun ())
     (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
     (Term TyName Name DefaultUni DefaultFun ())
     (Term NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
traverseOf LensLike
  (ExceptT FreeVariableError IO)
  (Program TyName Name DefaultUni DefaultFun ())
  (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
  (Term TyName Name DefaultUni DefaultFun ())
  (Term NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
forall tyname1 name1 (uni1 :: * -> *) fun1 ann tyname2 name2
       (uni2 :: * -> *) fun2 (f :: * -> *).
Functor f =>
(Term tyname1 name1 uni1 fun1 ann
 -> f (Term tyname2 name2 uni2 fun2 ann))
-> Program tyname1 name1 uni1 fun1 ann
-> f (Program tyname2 name2 uni2 fun2 ann)
TPLC.progTerm Term TyName Name DefaultUni DefaultFun ()
-> ExceptT
     FreeVariableError
     IO
     (Term NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
forall e (m :: * -> *) (uni :: * -> *) fun ann.
(AsFreeVariableError e, MonadError e m) =>
Term TyName Name uni fun ann
-> m (Term NamedTyDeBruijn NamedDeBruijn uni fun ann)
deBruijnTerm Program TyName Name DefaultUni DefaultFun ()
p

goldenTPlc ::
  (ToTPlc a TPLC.DefaultUni TPLC.DefaultFun) =>
  String ->
  a ->
  TestNested
goldenTPlc :: forall a.
ToTPlc a DefaultUni DefaultFun =>
String -> a -> TestNested
goldenTPlc = (ExceptT
   SomeException
   IO
   (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
 -> IO (Doc Any))
-> String -> a -> TestNested
forall a ann.
ToTPlc a DefaultUni DefaultFun =>
(ExceptT
   SomeException
   IO
   (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
 -> IO (Doc ann))
-> String -> a -> TestNested
goldenTPlcWith ExceptT
  SomeException
  IO
  (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
-> IO (Doc Any)
forall a ann.
PrettyPlc a =>
ExceptT SomeException IO a -> IO (Doc ann)
ppCatch

goldenTPlcReadable ::
  (ToTPlc a TPLC.DefaultUni TPLC.DefaultFun) =>
  String ->
  a ->
  TestNested
goldenTPlcReadable :: forall a.
ToTPlc a DefaultUni DefaultFun =>
String -> a -> TestNested
goldenTPlcReadable = (ExceptT
   SomeException
   IO
   (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
 -> IO (Doc Any))
-> String -> a -> TestNested
forall a ann.
ToTPlc a DefaultUni DefaultFun =>
(ExceptT
   SomeException
   IO
   (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
 -> IO (Doc ann))
-> String -> a -> TestNested
goldenTPlcWith ExceptT
  SomeException
  IO
  (Program NamedTyDeBruijn NamedDeBruijn DefaultUni DefaultFun ())
-> IO (Doc Any)
forall a ann.
PrettyBy (PrettyConfigReadable PrettyConfigName) a =>
ExceptT SomeException IO a -> IO (Doc ann)
ppCatchReadable

goldenUPlcWith ::
  (ToUPlc a UPLC.DefaultUni UPLC.DefaultFun) =>
  ( ExceptT
      SomeException
      IO
      (UPLC.Program UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) ->
    IO (Doc ann)
  ) ->
  String ->
  a ->
  TestNested
goldenUPlcWith :: forall a ann.
ToUPlc a DefaultUni DefaultFun =>
(ExceptT
   SomeException IO (Program NamedDeBruijn DefaultUni DefaultFun ())
 -> IO (Doc ann))
-> String -> a -> TestNested
goldenUPlcWith ExceptT
  SomeException IO (Program NamedDeBruijn DefaultUni DefaultFun ())
-> IO (Doc ann)
pp String
name a
value = String -> String -> IO (Doc ann) -> TestNested
forall ann. String -> String -> IO (Doc ann) -> TestNested
nestedGoldenVsDocM String
name String
".uplc" (IO (Doc ann) -> TestNested) -> IO (Doc ann) -> TestNested
forall a b. (a -> b) -> a -> b
$ ExceptT
  SomeException IO (Program NamedDeBruijn DefaultUni DefaultFun ())
-> IO (Doc ann)
pp (ExceptT
   SomeException IO (Program NamedDeBruijn DefaultUni DefaultFun ())
 -> IO (Doc ann))
-> ExceptT
     SomeException IO (Program NamedDeBruijn DefaultUni DefaultFun ())
-> IO (Doc ann)
forall a b. (a -> b) -> a -> b
$ do
  Program Name DefaultUni DefaultFun ()
p <- a
-> ExceptT SomeException IO (Program Name DefaultUni DefaultFun ())
forall a (uni :: * -> *) fun.
ToUPlc a uni fun =>
a -> ExceptT SomeException IO (Program Name uni fun ())
toUPlc a
value
  forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT @_ @FreeVariableError FreeVariableError -> SomeException
forall e. Exception e => e -> SomeException
toException (ExceptT
   FreeVariableError
   IO
   (Program NamedDeBruijn DefaultUni DefaultFun ())
 -> ExceptT
      SomeException IO (Program NamedDeBruijn DefaultUni DefaultFun ()))
-> ExceptT
     FreeVariableError
     IO
     (Program NamedDeBruijn DefaultUni DefaultFun ())
-> ExceptT
     SomeException IO (Program NamedDeBruijn DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ LensLike
  (ExceptT FreeVariableError IO)
  (Program Name DefaultUni DefaultFun ())
  (Program NamedDeBruijn DefaultUni DefaultFun ())
  (Term Name DefaultUni DefaultFun ())
  (Term NamedDeBruijn DefaultUni DefaultFun ())
-> LensLike
     (ExceptT FreeVariableError IO)
     (Program Name DefaultUni DefaultFun ())
     (Program NamedDeBruijn DefaultUni DefaultFun ())
     (Term Name DefaultUni DefaultFun ())
     (Term NamedDeBruijn DefaultUni DefaultFun ())
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
traverseOf LensLike
  (ExceptT FreeVariableError IO)
  (Program Name DefaultUni DefaultFun ())
  (Program NamedDeBruijn DefaultUni DefaultFun ())
  (Term Name DefaultUni DefaultFun ())
  (Term NamedDeBruijn DefaultUni DefaultFun ())
forall name1 (uni1 :: * -> *) fun1 ann name2 (uni2 :: * -> *) fun2
       (f :: * -> *).
Functor f =>
(Term name1 uni1 fun1 ann -> f (Term name2 uni2 fun2 ann))
-> Program name1 uni1 fun1 ann -> f (Program name2 uni2 fun2 ann)
UPLC.progTerm Term Name DefaultUni DefaultFun ()
-> ExceptT
     FreeVariableError IO (Term NamedDeBruijn DefaultUni DefaultFun ())
forall e (m :: * -> *) (uni :: * -> *) fun ann.
(AsFreeVariableError e, MonadError e m) =>
Term Name uni fun ann -> m (Term NamedDeBruijn uni fun ann)
UPLC.deBruijnTerm Program Name DefaultUni DefaultFun ()
p

goldenUPlc ::
  (ToUPlc a UPLC.DefaultUni UPLC.DefaultFun) =>
  String ->
  a ->
  TestNested
goldenUPlc :: forall a.
ToUPlc a DefaultUni DefaultFun =>
String -> a -> TestNested
goldenUPlc = (ExceptT
   SomeException IO (Program NamedDeBruijn DefaultUni DefaultFun ())
 -> IO (Doc Any))
-> String -> a -> TestNested
forall a ann.
ToUPlc a DefaultUni DefaultFun =>
(ExceptT
   SomeException IO (Program NamedDeBruijn DefaultUni DefaultFun ())
 -> IO (Doc ann))
-> String -> a -> TestNested
goldenUPlcWith ExceptT
  SomeException IO (Program NamedDeBruijn DefaultUni DefaultFun ())
-> IO (Doc Any)
forall a ann.
PrettyPlc a =>
ExceptT SomeException IO a -> IO (Doc ann)
ppCatch

goldenUPlcReadable ::
  (ToUPlc a UPLC.DefaultUni UPLC.DefaultFun) =>
  String ->
  a ->
  TestNested
goldenUPlcReadable :: forall a.
ToUPlc a DefaultUni DefaultFun =>
String -> a -> TestNested
goldenUPlcReadable = (ExceptT
   SomeException IO (Program NamedDeBruijn DefaultUni DefaultFun ())
 -> IO (Doc Any))
-> String -> a -> TestNested
forall a ann.
ToUPlc a DefaultUni DefaultFun =>
(ExceptT
   SomeException IO (Program NamedDeBruijn DefaultUni DefaultFun ())
 -> IO (Doc ann))
-> String -> a -> TestNested
goldenUPlcWith ExceptT
  SomeException IO (Program NamedDeBruijn DefaultUni DefaultFun ())
-> IO (Doc Any)
forall a ann.
PrettyBy (PrettyConfigReadable PrettyConfigName) a =>
ExceptT SomeException IO a -> IO (Doc ann)
ppCatchReadable

goldenTEval ::
  (ToTPlc a TPLC.DefaultUni TPLC.DefaultFun) =>
  String ->
  [a] ->
  TestNested
goldenTEval :: forall a.
ToTPlc a DefaultUni DefaultFun =>
String -> [a] -> TestNested
goldenTEval String
name [a]
values =
  String -> String -> IO (Doc Any) -> TestNested
forall ann. String -> String -> IO (Doc ann) -> TestNested
nestedGoldenVsDocM String
name String
".eval" (IO (Doc Any) -> TestNested) -> IO (Doc Any) -> TestNested
forall a b. (a -> b) -> a -> b
$ ExceptT
  SomeException
  IO
  (EvaluationResult (Term TyName Name DefaultUni DefaultFun ()))
-> IO (Doc Any)
forall a ann.
PrettyPlc a =>
ExceptT SomeException IO a -> IO (Doc ann)
ppCatch (ExceptT
   SomeException
   IO
   (EvaluationResult (Term TyName Name DefaultUni DefaultFun ()))
 -> IO (Doc Any))
-> ExceptT
     SomeException
     IO
     (EvaluationResult (Term TyName Name DefaultUni DefaultFun ()))
-> IO (Doc Any)
forall a b. (a -> b) -> a -> b
$ [a]
-> ExceptT
     SomeException
     IO
     (EvaluationResult (Term TyName Name DefaultUni DefaultFun ()))
forall a.
ToTPlc a DefaultUni DefaultFun =>
[a]
-> ExceptT
     SomeException
     IO
     (EvaluationResult (Term TyName Name DefaultUni DefaultFun ()))
runTPlc [a]
values

goldenUEval :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => String -> [a] -> TestNested
goldenUEval :: forall a.
ToUPlc a DefaultUni DefaultFun =>
String -> [a] -> TestNested
goldenUEval String
name [a]
values = String -> String -> IO (Doc Any) -> TestNested
forall ann. String -> String -> IO (Doc ann) -> TestNested
nestedGoldenVsDocM String
name String
".eval" (IO (Doc Any) -> TestNested) -> IO (Doc Any) -> TestNested
forall a b. (a -> b) -> a -> b
$ ExceptT SomeException IO (Term Name DefaultUni DefaultFun ())
-> IO (Doc Any)
forall a ann.
PrettyPlc a =>
ExceptT SomeException IO a -> IO (Doc ann)
ppCatch (ExceptT SomeException IO (Term Name DefaultUni DefaultFun ())
 -> IO (Doc Any))
-> ExceptT SomeException IO (Term Name DefaultUni DefaultFun ())
-> IO (Doc Any)
forall a b. (a -> b) -> a -> b
$ [a]
-> ExceptT SomeException IO (Term Name DefaultUni DefaultFun ())
forall a.
ToUPlc a DefaultUni DefaultFun =>
[a]
-> ExceptT SomeException IO (Term Name DefaultUni DefaultFun ())
runUPlc [a]
values

goldenUEvalLogs :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => String -> [a] -> TestNested
goldenUEvalLogs :: forall a.
ToUPlc a DefaultUni DefaultFun =>
String -> [a] -> TestNested
goldenUEvalLogs String
name [a]
values = String -> String -> IO (Doc Any) -> TestNested
forall ann. String -> String -> IO (Doc ann) -> TestNested
nestedGoldenVsDocM String
name String
".eval" (IO (Doc Any) -> TestNested) -> IO (Doc Any) -> TestNested
forall a b. (a -> b) -> a -> b
$ ExceptT SomeException IO [Text] -> IO (Doc Any)
forall a ann.
PrettyPlc a =>
ExceptT SomeException IO a -> IO (Doc ann)
ppCatch (ExceptT SomeException IO [Text] -> IO (Doc Any))
-> ExceptT SomeException IO [Text] -> IO (Doc Any)
forall a b. (a -> b) -> a -> b
$ [a] -> ExceptT SomeException IO [Text]
forall a.
ToUPlc a DefaultUni DefaultFun =>
[a] -> ExceptT SomeException IO [Text]
runUPlcLogs [a]
values

-- | This is mostly useful for profiling a test that is normally
-- tested with one of the other functions, as it's a drop-in
-- replacement and you can then pass the output into `traceToStacks`.
goldenUEvalProfile :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => String -> [a] -> TestNested
goldenUEvalProfile :: forall a.
ToUPlc a DefaultUni DefaultFun =>
String -> [a] -> TestNested
goldenUEvalProfile String
name [a]
values = String -> String -> IO (Doc Any) -> TestNested
forall ann. String -> String -> IO (Doc ann) -> TestNested
nestedGoldenVsDocM String
name String
".eval" (IO (Doc Any) -> TestNested) -> IO (Doc Any) -> TestNested
forall a b. (a -> b) -> a -> b
$ ExceptT SomeException IO [Text] -> IO (Doc Any)
forall a ann.
PrettyPlc a =>
ExceptT SomeException IO a -> IO (Doc ann)
ppCatch (ExceptT SomeException IO [Text] -> IO (Doc Any))
-> ExceptT SomeException IO [Text] -> IO (Doc Any)
forall a b. (a -> b) -> a -> b
$ [a] -> ExceptT SomeException IO [Text]
forall a.
ToUPlc a DefaultUni DefaultFun =>
[a] -> ExceptT SomeException IO [Text]
runUPlcProfile [a]
values

goldenUEvalBudget :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => String -> [a] -> TestNested
goldenUEvalBudget :: forall a.
ToUPlc a DefaultUni DefaultFun =>
String -> [a] -> TestNested
goldenUEvalBudget String
name [a]
values = String -> String -> IO (Doc Any) -> TestNested
forall ann. String -> String -> IO (Doc ann) -> TestNested
nestedGoldenVsDocM String
name String
".budget" (IO (Doc Any) -> TestNested) -> IO (Doc Any) -> TestNested
forall a b. (a -> b) -> a -> b
$ ExceptT SomeException IO ExBudget -> IO (Doc Any)
forall a ann.
PrettyPlc a =>
ExceptT SomeException IO a -> IO (Doc ann)
ppCatch (ExceptT SomeException IO ExBudget -> IO (Doc Any))
-> ExceptT SomeException IO ExBudget -> IO (Doc Any)
forall a b. (a -> b) -> a -> b
$ [a] -> ExceptT SomeException IO ExBudget
forall a.
ToUPlc a DefaultUni DefaultFun =>
[a] -> ExceptT SomeException IO ExBudget
runUPlcBudget [a]
values

goldenSize :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => String -> a -> TestNested
goldenSize :: forall a.
ToUPlc a DefaultUni DefaultFun =>
String -> a -> TestNested
goldenSize String
name a
value =
  String -> String -> IO (Doc Any) -> TestNested
forall ann. String -> String -> IO (Doc ann) -> TestNested
nestedGoldenVsDocM String
name String
".size" (IO (Doc Any) -> TestNested) -> IO (Doc Any) -> TestNested
forall a b. (a -> b) -> a -> b
$ Doc Any -> IO (Doc Any)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc Any -> IO (Doc Any))
-> (Program Name DefaultUni DefaultFun () -> Doc Any)
-> Program Name DefaultUni DefaultFun ()
-> IO (Doc Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. Size -> Doc ann
pretty (Size -> Doc Any)
-> (Program Name DefaultUni DefaultFun () -> Size)
-> Program Name DefaultUni DefaultFun ()
-> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program Name DefaultUni DefaultFun () -> Size
forall name (uni :: * -> *) fun ann.
Program name uni fun ann -> Size
UPLC.programSize (Program Name DefaultUni DefaultFun () -> IO (Doc Any))
-> IO (Program Name DefaultUni DefaultFun ()) -> IO (Doc Any)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT SomeException IO (Program Name DefaultUni DefaultFun ())
-> IO (Program Name DefaultUni DefaultFun ())
forall a. ExceptT SomeException IO a -> IO a
rethrow (a
-> ExceptT SomeException IO (Program Name DefaultUni DefaultFun ())
forall a (uni :: * -> *) fun.
ToUPlc a uni fun =>
a -> ExceptT SomeException IO (Program Name uni fun ())
toUPlc a
value)

-- | This is mostly useful for profiling a test that is normally
-- tested with one of the other functions, as it's a drop-in
-- replacement and you can then pass the output into `traceToStacks`.
goldenUEvalProfile' :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => String -> [a] -> TestNested
goldenUEvalProfile' :: forall a.
ToUPlc a DefaultUni DefaultFun =>
String -> [a] -> TestNested
goldenUEvalProfile' String
name [a]
values =
  String -> String -> IO (Doc Any) -> TestNested
forall ann. String -> String -> IO (Doc ann) -> TestNested
nestedGoldenVsDocM String
name String
".eval" (IO (Doc Any) -> TestNested) -> IO (Doc Any) -> TestNested
forall a b. (a -> b) -> a -> b
$ ExceptT SomeException IO (Doc Any) -> IO (Doc Any)
forall ann. ExceptT SomeException IO (Doc ann) -> IO (Doc ann)
ppCatch' (ExceptT SomeException IO (Doc Any) -> IO (Doc Any))
-> ExceptT SomeException IO (Doc Any) -> IO (Doc Any)
forall a b. (a -> b) -> a -> b
$
    ([Text] -> Doc Any)
-> ExceptT SomeException IO [Text]
-> ExceptT SomeException IO (Doc Any)
forall a b.
(a -> b)
-> ExceptT SomeException IO a -> ExceptT SomeException IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Text]
ts -> [Doc Any] -> Doc Any
forall ann. [Doc ann] -> Doc ann
PP.vsep ((Text -> Doc Any) -> [Text] -> [Doc Any]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Doc Any
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Text]
ts)) (ExceptT SomeException IO [Text]
 -> ExceptT SomeException IO (Doc Any))
-> ExceptT SomeException IO [Text]
-> ExceptT SomeException IO (Doc Any)
forall a b. (a -> b) -> a -> b
$ [a] -> ExceptT SomeException IO [Text]
forall a.
ToUPlc a DefaultUni DefaultFun =>
[a] -> ExceptT SomeException IO [Text]
runUPlcProfile' [a]
values

-- | A made-up `SrcSpan` for testing.
initialSrcSpan :: FilePath -> SrcSpan
initialSrcSpan :: String -> SrcSpan
initialSrcSpan String
fp = String -> Int -> Int -> Int -> Int -> SrcSpan
SrcSpan String
fp Int
1 Int
1 Int
1 Int
2

topSrcSpan :: SrcSpan
topSrcSpan :: SrcSpan
topSrcSpan = String -> SrcSpan
initialSrcSpan String
"top"

-- Some things require annotations to have these instances.
-- Normally in the compiler we use Provenance, which adds them, but
-- we add slightly sketchy instances for SrcSpan here for convenience
instance Semigroup TPLC.SrcSpan where
    SrcSpan
sp1 <> :: SrcSpan -> SrcSpan -> SrcSpan
<> SrcSpan
_ = SrcSpan
sp1

instance Monoid TPLC.SrcSpan where
    mempty :: SrcSpan
mempty = String -> SrcSpan
initialSrcSpan String
""

-- See Note [Marking].

-- | A version of 'RenameT' that fails to take free variables into account.
newtype NoMarkRenameT ren m a = NoMarkRenameT
  { forall ren (m :: * -> *) a.
NoMarkRenameT ren m a -> RenameT ren m a
unNoMarkRenameT :: TPLC.RenameT ren m a
  }
  deriving newtype
    ( (forall a b.
 (a -> b) -> NoMarkRenameT ren m a -> NoMarkRenameT ren m b)
-> (forall a b.
    a -> NoMarkRenameT ren m b -> NoMarkRenameT ren m a)
-> Functor (NoMarkRenameT ren m)
forall a b. a -> NoMarkRenameT ren m b -> NoMarkRenameT ren m a
forall a b.
(a -> b) -> NoMarkRenameT ren m a -> NoMarkRenameT ren m b
forall ren (m :: * -> *) a b.
Functor m =>
a -> NoMarkRenameT ren m b -> NoMarkRenameT ren m a
forall ren (m :: * -> *) a b.
Functor m =>
(a -> b) -> NoMarkRenameT ren m a -> NoMarkRenameT ren m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall ren (m :: * -> *) a b.
Functor m =>
(a -> b) -> NoMarkRenameT ren m a -> NoMarkRenameT ren m b
fmap :: forall a b.
(a -> b) -> NoMarkRenameT ren m a -> NoMarkRenameT ren m b
$c<$ :: forall ren (m :: * -> *) a b.
Functor m =>
a -> NoMarkRenameT ren m b -> NoMarkRenameT ren m a
<$ :: forall a b. a -> NoMarkRenameT ren m b -> NoMarkRenameT ren m a
Functor
    , Functor (NoMarkRenameT ren m)
Functor (NoMarkRenameT ren m) =>
(forall a. a -> NoMarkRenameT ren m a)
-> (forall a b.
    NoMarkRenameT ren m (a -> b)
    -> NoMarkRenameT ren m a -> NoMarkRenameT ren m b)
-> (forall a b c.
    (a -> b -> c)
    -> NoMarkRenameT ren m a
    -> NoMarkRenameT ren m b
    -> NoMarkRenameT ren m c)
-> (forall a b.
    NoMarkRenameT ren m a
    -> NoMarkRenameT ren m b -> NoMarkRenameT ren m b)
-> (forall a b.
    NoMarkRenameT ren m a
    -> NoMarkRenameT ren m b -> NoMarkRenameT ren m a)
-> Applicative (NoMarkRenameT ren m)
forall a. a -> NoMarkRenameT ren m a
forall a b.
NoMarkRenameT ren m a
-> NoMarkRenameT ren m b -> NoMarkRenameT ren m a
forall a b.
NoMarkRenameT ren m a
-> NoMarkRenameT ren m b -> NoMarkRenameT ren m b
forall a b.
NoMarkRenameT ren m (a -> b)
-> NoMarkRenameT ren m a -> NoMarkRenameT ren m b
forall a b c.
(a -> b -> c)
-> NoMarkRenameT ren m a
-> NoMarkRenameT ren m b
-> NoMarkRenameT ren m c
forall ren (m :: * -> *).
Applicative m =>
Functor (NoMarkRenameT ren m)
forall ren (m :: * -> *) a.
Applicative m =>
a -> NoMarkRenameT ren m a
forall ren (m :: * -> *) a b.
Applicative m =>
NoMarkRenameT ren m a
-> NoMarkRenameT ren m b -> NoMarkRenameT ren m a
forall ren (m :: * -> *) a b.
Applicative m =>
NoMarkRenameT ren m a
-> NoMarkRenameT ren m b -> NoMarkRenameT ren m b
forall ren (m :: * -> *) a b.
Applicative m =>
NoMarkRenameT ren m (a -> b)
-> NoMarkRenameT ren m a -> NoMarkRenameT ren m b
forall ren (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> NoMarkRenameT ren m a
-> NoMarkRenameT ren m b
-> NoMarkRenameT ren m 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 ren (m :: * -> *) a.
Applicative m =>
a -> NoMarkRenameT ren m a
pure :: forall a. a -> NoMarkRenameT ren m a
$c<*> :: forall ren (m :: * -> *) a b.
Applicative m =>
NoMarkRenameT ren m (a -> b)
-> NoMarkRenameT ren m a -> NoMarkRenameT ren m b
<*> :: forall a b.
NoMarkRenameT ren m (a -> b)
-> NoMarkRenameT ren m a -> NoMarkRenameT ren m b
$cliftA2 :: forall ren (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> NoMarkRenameT ren m a
-> NoMarkRenameT ren m b
-> NoMarkRenameT ren m c
liftA2 :: forall a b c.
(a -> b -> c)
-> NoMarkRenameT ren m a
-> NoMarkRenameT ren m b
-> NoMarkRenameT ren m c
$c*> :: forall ren (m :: * -> *) a b.
Applicative m =>
NoMarkRenameT ren m a
-> NoMarkRenameT ren m b -> NoMarkRenameT ren m b
*> :: forall a b.
NoMarkRenameT ren m a
-> NoMarkRenameT ren m b -> NoMarkRenameT ren m b
$c<* :: forall ren (m :: * -> *) a b.
Applicative m =>
NoMarkRenameT ren m a
-> NoMarkRenameT ren m b -> NoMarkRenameT ren m a
<* :: forall a b.
NoMarkRenameT ren m a
-> NoMarkRenameT ren m b -> NoMarkRenameT ren m a
Applicative
    , Applicative (NoMarkRenameT ren m)
Applicative (NoMarkRenameT ren m) =>
(forall a. NoMarkRenameT ren m a)
-> (forall a.
    NoMarkRenameT ren m a
    -> NoMarkRenameT ren m a -> NoMarkRenameT ren m a)
-> (forall a. NoMarkRenameT ren m a -> NoMarkRenameT ren m [a])
-> (forall a. NoMarkRenameT ren m a -> NoMarkRenameT ren m [a])
-> Alternative (NoMarkRenameT ren m)
forall a. NoMarkRenameT ren m a
forall a. NoMarkRenameT ren m a -> NoMarkRenameT ren m [a]
forall a.
NoMarkRenameT ren m a
-> NoMarkRenameT ren m a -> NoMarkRenameT ren m a
forall ren (m :: * -> *).
Alternative m =>
Applicative (NoMarkRenameT ren m)
forall ren (m :: * -> *) a. Alternative m => NoMarkRenameT ren m a
forall ren (m :: * -> *) a.
Alternative m =>
NoMarkRenameT ren m a -> NoMarkRenameT ren m [a]
forall ren (m :: * -> *) a.
Alternative m =>
NoMarkRenameT ren m a
-> NoMarkRenameT ren m a -> NoMarkRenameT ren m a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
$cempty :: forall ren (m :: * -> *) a. Alternative m => NoMarkRenameT ren m a
empty :: forall a. NoMarkRenameT ren m a
$c<|> :: forall ren (m :: * -> *) a.
Alternative m =>
NoMarkRenameT ren m a
-> NoMarkRenameT ren m a -> NoMarkRenameT ren m a
<|> :: forall a.
NoMarkRenameT ren m a
-> NoMarkRenameT ren m a -> NoMarkRenameT ren m a
$csome :: forall ren (m :: * -> *) a.
Alternative m =>
NoMarkRenameT ren m a -> NoMarkRenameT ren m [a]
some :: forall a. NoMarkRenameT ren m a -> NoMarkRenameT ren m [a]
$cmany :: forall ren (m :: * -> *) a.
Alternative m =>
NoMarkRenameT ren m a -> NoMarkRenameT ren m [a]
many :: forall a. NoMarkRenameT ren m a -> NoMarkRenameT ren m [a]
Alternative
    , Applicative (NoMarkRenameT ren m)
Applicative (NoMarkRenameT ren m) =>
(forall a b.
 NoMarkRenameT ren m a
 -> (a -> NoMarkRenameT ren m b) -> NoMarkRenameT ren m b)
-> (forall a b.
    NoMarkRenameT ren m a
    -> NoMarkRenameT ren m b -> NoMarkRenameT ren m b)
-> (forall a. a -> NoMarkRenameT ren m a)
-> Monad (NoMarkRenameT ren m)
forall a. a -> NoMarkRenameT ren m a
forall a b.
NoMarkRenameT ren m a
-> NoMarkRenameT ren m b -> NoMarkRenameT ren m b
forall a b.
NoMarkRenameT ren m a
-> (a -> NoMarkRenameT ren m b) -> NoMarkRenameT ren m b
forall ren (m :: * -> *).
Monad m =>
Applicative (NoMarkRenameT ren m)
forall ren (m :: * -> *) a. Monad m => a -> NoMarkRenameT ren m a
forall ren (m :: * -> *) a b.
Monad m =>
NoMarkRenameT ren m a
-> NoMarkRenameT ren m b -> NoMarkRenameT ren m b
forall ren (m :: * -> *) a b.
Monad m =>
NoMarkRenameT ren m a
-> (a -> NoMarkRenameT ren m b) -> NoMarkRenameT ren m 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 ren (m :: * -> *) a b.
Monad m =>
NoMarkRenameT ren m a
-> (a -> NoMarkRenameT ren m b) -> NoMarkRenameT ren m b
>>= :: forall a b.
NoMarkRenameT ren m a
-> (a -> NoMarkRenameT ren m b) -> NoMarkRenameT ren m b
$c>> :: forall ren (m :: * -> *) a b.
Monad m =>
NoMarkRenameT ren m a
-> NoMarkRenameT ren m b -> NoMarkRenameT ren m b
>> :: forall a b.
NoMarkRenameT ren m a
-> NoMarkRenameT ren m b -> NoMarkRenameT ren m b
$creturn :: forall ren (m :: * -> *) a. Monad m => a -> NoMarkRenameT ren m a
return :: forall a. a -> NoMarkRenameT ren m a
Monad
    , MonadReader ren
    , Monad (NoMarkRenameT ren m)
Monad (NoMarkRenameT ren m) =>
(forall a. Quote a -> NoMarkRenameT ren m a)
-> MonadQuote (NoMarkRenameT ren m)
forall a. Quote a -> NoMarkRenameT ren m a
forall ren (m :: * -> *).
MonadQuote m =>
Monad (NoMarkRenameT ren m)
forall ren (m :: * -> *) a.
MonadQuote m =>
Quote a -> NoMarkRenameT ren m a
forall (m :: * -> *).
Monad m =>
(forall a. Quote a -> m a) -> MonadQuote m
$cliftQuote :: forall ren (m :: * -> *) a.
MonadQuote m =>
Quote a -> NoMarkRenameT ren m a
liftQuote :: forall a. Quote a -> NoMarkRenameT ren m a
TPLC.MonadQuote
    )

noMarkRename ::
  (Monoid ren) =>
  (t -> NoMarkRenameT ren m t) ->
  t ->
  m t
noMarkRename :: forall ren t (m :: * -> *).
Monoid ren =>
(t -> NoMarkRenameT ren m t) -> t -> m t
noMarkRename t -> NoMarkRenameT ren m t
renM = RenameT ren m t -> m t
forall ren (m :: * -> *) a. Monoid ren => RenameT ren m a -> m a
TPLC.runRenameT (RenameT ren m t -> m t) -> (t -> RenameT ren m t) -> t -> m t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoMarkRenameT ren m t -> RenameT ren m t
forall ren (m :: * -> *) a.
NoMarkRenameT ren m a -> RenameT ren m a
unNoMarkRenameT (NoMarkRenameT ren m t -> RenameT ren m t)
-> (t -> NoMarkRenameT ren m t) -> t -> RenameT ren m t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> NoMarkRenameT ren m t
renM

-- | A version of 'RenameT' that does not perform any renaming at all.
newtype NoRenameT (ren :: GHC.Type) m a = NoRenameT
  { forall {k} ren (m :: k -> *) (a :: k). NoRenameT ren m a -> m a
unNoRenameT :: m a
  }
  deriving newtype
    ( (forall a b. (a -> b) -> NoRenameT ren m a -> NoRenameT ren m b)
-> (forall a b. a -> NoRenameT ren m b -> NoRenameT ren m a)
-> Functor (NoRenameT ren m)
forall a b. a -> NoRenameT ren m b -> NoRenameT ren m a
forall a b. (a -> b) -> NoRenameT ren m a -> NoRenameT ren m b
forall ren (m :: * -> *) a b.
Functor m =>
a -> NoRenameT ren m b -> NoRenameT ren m a
forall ren (m :: * -> *) a b.
Functor m =>
(a -> b) -> NoRenameT ren m a -> NoRenameT ren m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall ren (m :: * -> *) a b.
Functor m =>
(a -> b) -> NoRenameT ren m a -> NoRenameT ren m b
fmap :: forall a b. (a -> b) -> NoRenameT ren m a -> NoRenameT ren m b
$c<$ :: forall ren (m :: * -> *) a b.
Functor m =>
a -> NoRenameT ren m b -> NoRenameT ren m a
<$ :: forall a b. a -> NoRenameT ren m b -> NoRenameT ren m a
Functor
    , Functor (NoRenameT ren m)
Functor (NoRenameT ren m) =>
(forall a. a -> NoRenameT ren m a)
-> (forall a b.
    NoRenameT ren m (a -> b) -> NoRenameT ren m a -> NoRenameT ren m b)
-> (forall a b c.
    (a -> b -> c)
    -> NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m c)
-> (forall a b.
    NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m b)
-> (forall a b.
    NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m a)
-> Applicative (NoRenameT ren m)
forall a. a -> NoRenameT ren m a
forall a b.
NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m a
forall a b.
NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m b
forall a b.
NoRenameT ren m (a -> b) -> NoRenameT ren m a -> NoRenameT ren m b
forall a b c.
(a -> b -> c)
-> NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m c
forall ren (m :: * -> *).
Applicative m =>
Functor (NoRenameT ren m)
forall ren (m :: * -> *) a. Applicative m => a -> NoRenameT ren m a
forall ren (m :: * -> *) a b.
Applicative m =>
NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m a
forall ren (m :: * -> *) a b.
Applicative m =>
NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m b
forall ren (m :: * -> *) a b.
Applicative m =>
NoRenameT ren m (a -> b) -> NoRenameT ren m a -> NoRenameT ren m b
forall ren (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m 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 ren (m :: * -> *) a. Applicative m => a -> NoRenameT ren m a
pure :: forall a. a -> NoRenameT ren m a
$c<*> :: forall ren (m :: * -> *) a b.
Applicative m =>
NoRenameT ren m (a -> b) -> NoRenameT ren m a -> NoRenameT ren m b
<*> :: forall a b.
NoRenameT ren m (a -> b) -> NoRenameT ren m a -> NoRenameT ren m b
$cliftA2 :: forall ren (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m c
liftA2 :: forall a b c.
(a -> b -> c)
-> NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m c
$c*> :: forall ren (m :: * -> *) a b.
Applicative m =>
NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m b
*> :: forall a b.
NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m b
$c<* :: forall ren (m :: * -> *) a b.
Applicative m =>
NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m a
<* :: forall a b.
NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m a
Applicative
    , Applicative (NoRenameT ren m)
Applicative (NoRenameT ren m) =>
(forall a. NoRenameT ren m a)
-> (forall a.
    NoRenameT ren m a -> NoRenameT ren m a -> NoRenameT ren m a)
-> (forall a. NoRenameT ren m a -> NoRenameT ren m [a])
-> (forall a. NoRenameT ren m a -> NoRenameT ren m [a])
-> Alternative (NoRenameT ren m)
forall a. NoRenameT ren m a
forall a. NoRenameT ren m a -> NoRenameT ren m [a]
forall a.
NoRenameT ren m a -> NoRenameT ren m a -> NoRenameT ren m a
forall ren (m :: * -> *).
Alternative m =>
Applicative (NoRenameT ren m)
forall ren (m :: * -> *) a. Alternative m => NoRenameT ren m a
forall ren (m :: * -> *) a.
Alternative m =>
NoRenameT ren m a -> NoRenameT ren m [a]
forall ren (m :: * -> *) a.
Alternative m =>
NoRenameT ren m a -> NoRenameT ren m a -> NoRenameT ren m a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
$cempty :: forall ren (m :: * -> *) a. Alternative m => NoRenameT ren m a
empty :: forall a. NoRenameT ren m a
$c<|> :: forall ren (m :: * -> *) a.
Alternative m =>
NoRenameT ren m a -> NoRenameT ren m a -> NoRenameT ren m a
<|> :: forall a.
NoRenameT ren m a -> NoRenameT ren m a -> NoRenameT ren m a
$csome :: forall ren (m :: * -> *) a.
Alternative m =>
NoRenameT ren m a -> NoRenameT ren m [a]
some :: forall a. NoRenameT ren m a -> NoRenameT ren m [a]
$cmany :: forall ren (m :: * -> *) a.
Alternative m =>
NoRenameT ren m a -> NoRenameT ren m [a]
many :: forall a. NoRenameT ren m a -> NoRenameT ren m [a]
Alternative
    , Applicative (NoRenameT ren m)
Applicative (NoRenameT ren m) =>
(forall a b.
 NoRenameT ren m a -> (a -> NoRenameT ren m b) -> NoRenameT ren m b)
-> (forall a b.
    NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m b)
-> (forall a. a -> NoRenameT ren m a)
-> Monad (NoRenameT ren m)
forall a. a -> NoRenameT ren m a
forall a b.
NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m b
forall a b.
NoRenameT ren m a -> (a -> NoRenameT ren m b) -> NoRenameT ren m b
forall ren (m :: * -> *). Monad m => Applicative (NoRenameT ren m)
forall ren (m :: * -> *) a. Monad m => a -> NoRenameT ren m a
forall ren (m :: * -> *) a b.
Monad m =>
NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m b
forall ren (m :: * -> *) a b.
Monad m =>
NoRenameT ren m a -> (a -> NoRenameT ren m b) -> NoRenameT ren m 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 ren (m :: * -> *) a b.
Monad m =>
NoRenameT ren m a -> (a -> NoRenameT ren m b) -> NoRenameT ren m b
>>= :: forall a b.
NoRenameT ren m a -> (a -> NoRenameT ren m b) -> NoRenameT ren m b
$c>> :: forall ren (m :: * -> *) a b.
Monad m =>
NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m b
>> :: forall a b.
NoRenameT ren m a -> NoRenameT ren m b -> NoRenameT ren m b
$creturn :: forall ren (m :: * -> *) a. Monad m => a -> NoRenameT ren m a
return :: forall a. a -> NoRenameT ren m a
Monad
    , Monad (NoRenameT ren m)
Monad (NoRenameT ren m) =>
(forall a. Quote a -> NoRenameT ren m a)
-> MonadQuote (NoRenameT ren m)
forall a. Quote a -> NoRenameT ren m a
forall ren (m :: * -> *). MonadQuote m => Monad (NoRenameT ren m)
forall ren (m :: * -> *) a.
MonadQuote m =>
Quote a -> NoRenameT ren m a
forall (m :: * -> *).
Monad m =>
(forall a. Quote a -> m a) -> MonadQuote m
$cliftQuote :: forall ren (m :: * -> *) a.
MonadQuote m =>
Quote a -> NoRenameT ren m a
liftQuote :: forall a. Quote a -> NoRenameT ren m a
TPLC.MonadQuote
    )

instance (Monad m, Monoid ren) => MonadReader ren (NoRenameT ren m) where
  ask :: NoRenameT ren m ren
ask = ren -> NoRenameT ren m ren
forall a. a -> NoRenameT ren m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ren
forall a. Monoid a => a
mempty
  local :: forall a. (ren -> ren) -> NoRenameT ren m a -> NoRenameT ren m a
local ren -> ren
_ = NoRenameT ren m a -> NoRenameT ren m a
forall a. a -> a
id

noRename ::
  (TPLC.MonadQuote m) =>
  (t -> m ()) ->
  (t -> NoRenameT ren m t) ->
  t ->
  m t
noRename :: forall (m :: * -> *) t ren.
MonadQuote m =>
(t -> m ()) -> (t -> NoRenameT ren m t) -> t -> m t
noRename t -> m ()
mark t -> NoRenameT ren m t
renM = (t -> m ()) -> t -> m t
forall (f :: * -> *) a b. Functor f => (a -> f b) -> a -> f a
through t -> m ()
mark (t -> m t) -> (t -> m t) -> t -> m t
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> NoRenameT ren m t -> m t
forall {k} ren (m :: k -> *) (a :: k). NoRenameT ren m a -> m a
unNoRenameT (NoRenameT ren m t -> m t) -> (t -> NoRenameT ren m t) -> t -> m t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> NoRenameT ren m t
renM

{- | A broken version of 'RenameT' whose 'local' updates the scope globally
(as opposed to locally).
-}
newtype BrokenRenameT ren m a = BrokenRenameT
  { forall ren (m :: * -> *) a. BrokenRenameT ren m a -> StateT ren m a
unBrokenRenameT :: StateT ren m a
  }
  deriving newtype
    ( (forall a b.
 (a -> b) -> BrokenRenameT ren m a -> BrokenRenameT ren m b)
-> (forall a b.
    a -> BrokenRenameT ren m b -> BrokenRenameT ren m a)
-> Functor (BrokenRenameT ren m)
forall a b. a -> BrokenRenameT ren m b -> BrokenRenameT ren m a
forall a b.
(a -> b) -> BrokenRenameT ren m a -> BrokenRenameT ren m b
forall ren (m :: * -> *) a b.
Functor m =>
a -> BrokenRenameT ren m b -> BrokenRenameT ren m a
forall ren (m :: * -> *) a b.
Functor m =>
(a -> b) -> BrokenRenameT ren m a -> BrokenRenameT ren m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall ren (m :: * -> *) a b.
Functor m =>
(a -> b) -> BrokenRenameT ren m a -> BrokenRenameT ren m b
fmap :: forall a b.
(a -> b) -> BrokenRenameT ren m a -> BrokenRenameT ren m b
$c<$ :: forall ren (m :: * -> *) a b.
Functor m =>
a -> BrokenRenameT ren m b -> BrokenRenameT ren m a
<$ :: forall a b. a -> BrokenRenameT ren m b -> BrokenRenameT ren m a
Functor
    , Functor (BrokenRenameT ren m)
Functor (BrokenRenameT ren m) =>
(forall a. a -> BrokenRenameT ren m a)
-> (forall a b.
    BrokenRenameT ren m (a -> b)
    -> BrokenRenameT ren m a -> BrokenRenameT ren m b)
-> (forall a b c.
    (a -> b -> c)
    -> BrokenRenameT ren m a
    -> BrokenRenameT ren m b
    -> BrokenRenameT ren m c)
-> (forall a b.
    BrokenRenameT ren m a
    -> BrokenRenameT ren m b -> BrokenRenameT ren m b)
-> (forall a b.
    BrokenRenameT ren m a
    -> BrokenRenameT ren m b -> BrokenRenameT ren m a)
-> Applicative (BrokenRenameT ren m)
forall a. a -> BrokenRenameT ren m a
forall a b.
BrokenRenameT ren m a
-> BrokenRenameT ren m b -> BrokenRenameT ren m a
forall a b.
BrokenRenameT ren m a
-> BrokenRenameT ren m b -> BrokenRenameT ren m b
forall a b.
BrokenRenameT ren m (a -> b)
-> BrokenRenameT ren m a -> BrokenRenameT ren m b
forall a b c.
(a -> b -> c)
-> BrokenRenameT ren m a
-> BrokenRenameT ren m b
-> BrokenRenameT ren m c
forall ren (m :: * -> *). Monad m => Functor (BrokenRenameT ren m)
forall ren (m :: * -> *) a. Monad m => a -> BrokenRenameT ren m a
forall ren (m :: * -> *) a b.
Monad m =>
BrokenRenameT ren m a
-> BrokenRenameT ren m b -> BrokenRenameT ren m a
forall ren (m :: * -> *) a b.
Monad m =>
BrokenRenameT ren m a
-> BrokenRenameT ren m b -> BrokenRenameT ren m b
forall ren (m :: * -> *) a b.
Monad m =>
BrokenRenameT ren m (a -> b)
-> BrokenRenameT ren m a -> BrokenRenameT ren m b
forall ren (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> BrokenRenameT ren m a
-> BrokenRenameT ren m b
-> BrokenRenameT ren m 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 ren (m :: * -> *) a. Monad m => a -> BrokenRenameT ren m a
pure :: forall a. a -> BrokenRenameT ren m a
$c<*> :: forall ren (m :: * -> *) a b.
Monad m =>
BrokenRenameT ren m (a -> b)
-> BrokenRenameT ren m a -> BrokenRenameT ren m b
<*> :: forall a b.
BrokenRenameT ren m (a -> b)
-> BrokenRenameT ren m a -> BrokenRenameT ren m b
$cliftA2 :: forall ren (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> BrokenRenameT ren m a
-> BrokenRenameT ren m b
-> BrokenRenameT ren m c
liftA2 :: forall a b c.
(a -> b -> c)
-> BrokenRenameT ren m a
-> BrokenRenameT ren m b
-> BrokenRenameT ren m c
$c*> :: forall ren (m :: * -> *) a b.
Monad m =>
BrokenRenameT ren m a
-> BrokenRenameT ren m b -> BrokenRenameT ren m b
*> :: forall a b.
BrokenRenameT ren m a
-> BrokenRenameT ren m b -> BrokenRenameT ren m b
$c<* :: forall ren (m :: * -> *) a b.
Monad m =>
BrokenRenameT ren m a
-> BrokenRenameT ren m b -> BrokenRenameT ren m a
<* :: forall a b.
BrokenRenameT ren m a
-> BrokenRenameT ren m b -> BrokenRenameT ren m a
Applicative
    , Applicative (BrokenRenameT ren m)
Applicative (BrokenRenameT ren m) =>
(forall a. BrokenRenameT ren m a)
-> (forall a.
    BrokenRenameT ren m a
    -> BrokenRenameT ren m a -> BrokenRenameT ren m a)
-> (forall a. BrokenRenameT ren m a -> BrokenRenameT ren m [a])
-> (forall a. BrokenRenameT ren m a -> BrokenRenameT ren m [a])
-> Alternative (BrokenRenameT ren m)
forall a. BrokenRenameT ren m a
forall a. BrokenRenameT ren m a -> BrokenRenameT ren m [a]
forall a.
BrokenRenameT ren m a
-> BrokenRenameT ren m a -> BrokenRenameT ren m a
forall ren (m :: * -> *).
MonadPlus m =>
Applicative (BrokenRenameT ren m)
forall ren (m :: * -> *) a. MonadPlus m => BrokenRenameT ren m a
forall ren (m :: * -> *) a.
MonadPlus m =>
BrokenRenameT ren m a -> BrokenRenameT ren m [a]
forall ren (m :: * -> *) a.
MonadPlus m =>
BrokenRenameT ren m a
-> BrokenRenameT ren m a -> BrokenRenameT ren m a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
$cempty :: forall ren (m :: * -> *) a. MonadPlus m => BrokenRenameT ren m a
empty :: forall a. BrokenRenameT ren m a
$c<|> :: forall ren (m :: * -> *) a.
MonadPlus m =>
BrokenRenameT ren m a
-> BrokenRenameT ren m a -> BrokenRenameT ren m a
<|> :: forall a.
BrokenRenameT ren m a
-> BrokenRenameT ren m a -> BrokenRenameT ren m a
$csome :: forall ren (m :: * -> *) a.
MonadPlus m =>
BrokenRenameT ren m a -> BrokenRenameT ren m [a]
some :: forall a. BrokenRenameT ren m a -> BrokenRenameT ren m [a]
$cmany :: forall ren (m :: * -> *) a.
MonadPlus m =>
BrokenRenameT ren m a -> BrokenRenameT ren m [a]
many :: forall a. BrokenRenameT ren m a -> BrokenRenameT ren m [a]
Alternative
    , Applicative (BrokenRenameT ren m)
Applicative (BrokenRenameT ren m) =>
(forall a b.
 BrokenRenameT ren m a
 -> (a -> BrokenRenameT ren m b) -> BrokenRenameT ren m b)
-> (forall a b.
    BrokenRenameT ren m a
    -> BrokenRenameT ren m b -> BrokenRenameT ren m b)
-> (forall a. a -> BrokenRenameT ren m a)
-> Monad (BrokenRenameT ren m)
forall a. a -> BrokenRenameT ren m a
forall a b.
BrokenRenameT ren m a
-> BrokenRenameT ren m b -> BrokenRenameT ren m b
forall a b.
BrokenRenameT ren m a
-> (a -> BrokenRenameT ren m b) -> BrokenRenameT ren m b
forall ren (m :: * -> *).
Monad m =>
Applicative (BrokenRenameT ren m)
forall ren (m :: * -> *) a. Monad m => a -> BrokenRenameT ren m a
forall ren (m :: * -> *) a b.
Monad m =>
BrokenRenameT ren m a
-> BrokenRenameT ren m b -> BrokenRenameT ren m b
forall ren (m :: * -> *) a b.
Monad m =>
BrokenRenameT ren m a
-> (a -> BrokenRenameT ren m b) -> BrokenRenameT ren m 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 ren (m :: * -> *) a b.
Monad m =>
BrokenRenameT ren m a
-> (a -> BrokenRenameT ren m b) -> BrokenRenameT ren m b
>>= :: forall a b.
BrokenRenameT ren m a
-> (a -> BrokenRenameT ren m b) -> BrokenRenameT ren m b
$c>> :: forall ren (m :: * -> *) a b.
Monad m =>
BrokenRenameT ren m a
-> BrokenRenameT ren m b -> BrokenRenameT ren m b
>> :: forall a b.
BrokenRenameT ren m a
-> BrokenRenameT ren m b -> BrokenRenameT ren m b
$creturn :: forall ren (m :: * -> *) a. Monad m => a -> BrokenRenameT ren m a
return :: forall a. a -> BrokenRenameT ren m a
Monad
    , MonadState ren
    , Monad (BrokenRenameT ren m)
Monad (BrokenRenameT ren m) =>
(forall a. Quote a -> BrokenRenameT ren m a)
-> MonadQuote (BrokenRenameT ren m)
forall a. Quote a -> BrokenRenameT ren m a
forall ren (m :: * -> *).
MonadQuote m =>
Monad (BrokenRenameT ren m)
forall ren (m :: * -> *) a.
MonadQuote m =>
Quote a -> BrokenRenameT ren m a
forall (m :: * -> *).
Monad m =>
(forall a. Quote a -> m a) -> MonadQuote m
$cliftQuote :: forall ren (m :: * -> *) a.
MonadQuote m =>
Quote a -> BrokenRenameT ren m a
liftQuote :: forall a. Quote a -> BrokenRenameT ren m a
TPLC.MonadQuote
    )

instance (Monad m) => MonadReader ren (BrokenRenameT ren m) where
  ask :: BrokenRenameT ren m ren
ask = BrokenRenameT ren m ren
forall s (m :: * -> *). MonadState s m => m s
get
  local :: forall a.
(ren -> ren) -> BrokenRenameT ren m a -> BrokenRenameT ren m a
local ren -> ren
f BrokenRenameT ren m a
a = (ren -> ren) -> BrokenRenameT ren m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ren -> ren
f BrokenRenameT ren m ()
-> BrokenRenameT ren m a -> BrokenRenameT ren m a
forall a b.
BrokenRenameT ren m a
-> BrokenRenameT ren m b -> BrokenRenameT ren m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BrokenRenameT ren m a
a

runBrokenRenameT :: (Monad m, Monoid ren) => BrokenRenameT ren m a -> m a
runBrokenRenameT :: forall (m :: * -> *) ren a.
(Monad m, Monoid ren) =>
BrokenRenameT ren m a -> m a
runBrokenRenameT = (StateT ren m a -> ren -> m a) -> ren -> StateT ren m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT ren m a -> ren -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ren
forall a. Monoid a => a
mempty (StateT ren m a -> m a)
-> (BrokenRenameT ren m a -> StateT ren m a)
-> BrokenRenameT ren m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BrokenRenameT ren m a -> StateT ren m a
forall ren (m :: * -> *) a. BrokenRenameT ren m a -> StateT ren m a
unBrokenRenameT

brokenRename ::
  (TPLC.MonadQuote m, Monoid ren) =>
  (t -> m ()) ->
  (t -> BrokenRenameT ren m t) ->
  t ->
  m t
brokenRename :: forall (m :: * -> *) ren t.
(MonadQuote m, Monoid ren) =>
(t -> m ()) -> (t -> BrokenRenameT ren m t) -> t -> m t
brokenRename t -> m ()
mark t -> BrokenRenameT ren m t
renM = (t -> m ()) -> t -> m t
forall (f :: * -> *) a b. Functor f => (a -> f b) -> a -> f a
through t -> m ()
mark (t -> m t) -> (t -> m t) -> t -> m t
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> BrokenRenameT ren m t -> m t
forall (m :: * -> *) ren a.
(Monad m, Monoid ren) =>
BrokenRenameT ren m a -> m a
runBrokenRenameT (BrokenRenameT ren m t -> m t)
-> (t -> BrokenRenameT ren m t) -> t -> m t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> BrokenRenameT ren m t
renM

{- Note [Scoping tests API]
If you want to test how a certain pass handles scoping you should use either 'test_scopingGood' or
'test_scopingBad' depending on whether the pass is expected to preserve global uniqueness and not
change scoping of its argument. Regarding the last one: substitution, for example, may remove free
variables and scoping tests, being initially developed only to test renamers, will fail upon seeing
that a free variable was removed. So any scoping test failure needs to be carefully scrutinized
before concluding that it reveals a bug.

As it turns out, most AST transformations don't do anything that would cause the scoping tests to
false-positively report a bug:

- a lot of passes simply do not do anything with names apart from maybe moving them around
- those that do change names may produce alpha-equivalent results and this is one thing that the
  scoping machinery is designed to test
- some passes such as inlining may duplicate binders, but that is also fine as long as the
  duplicates are properly renamed, since the scoping machinery doesn't count binders or variable
  usages, it only expects free names to stay free, bound names to change together with their binders
  and global uniqueness to be preserved (see 'ScopeError' for the full list of possible errors)
- some passes such as inlining may remove bindings and there's special support implemented for
  handling this: when invoking either 'test_scopingGood' or 'test_scopingBad' you need to provide a
  'BindingRemoval' argument specifying whether binding removal is expected for the pass. Conversily,
  make it 'BindingRemovalOk' whenever you use 'test_scopingBad' to emphasize that even with binding
  removal allowed tests still fail
- some passes do not perform renaming of the input themselves, in that case you need to provide
  'PrerenameYes' for the 'Prerename' argument that both the test runners expect. It doesn't matter
  whether the pass relies on global uniqueness itself, because the scoping tests rely on it anyway.
  If the pass renames its input, and only in this case, provide 'PrerenameNo' for the 'Prerename'
  argument, this will allow the scoping tests to ensure that the pass does indeed rename its input
- due to a very specific design of the scoping tests some passes don't give false positives, but
  don't get tested properly either. For example dead code elimination is a no-op within the scoping
  tests, because internally all types/terms/programs only contain bindings that get referenced

There's also 'test_scopingSpoilRenamer', this one is used to test that the scoping tests do catch
various kinds of bugs. Don't use it with any passes that aren't renamers.

All in all, in order to use the scoping tests you have to understand how they work, which is an
unfortunate but seemingly inevitable requirement. On the bright side, it's worth the effort, because
the tests do catch bugs occasionally.

Whenever you use 'test_scopingBad' make sure to explain why, so that it's clear whether there's
something wrong with the pass or it's just a limitation of the scoping tests.
-}

-- | Determines whether to perform renaming before running the scoping tests. Needed for passes that
-- don't perform renaming themselves.
data Prerename =
  PrerenameYes |
  PrerenameNo

runPrerename :: TPLC.Rename a => Prerename -> a -> a
runPrerename :: forall a. Rename a => Prerename -> a -> a
runPrerename Prerename
PrerenameYes = Quote a -> a
forall a. Quote a -> a
TPLC.runQuote (Quote a -> a) -> (a -> Quote a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Quote a
forall a (m :: * -> *). (Rename a, MonadQuote m) => a -> m a
forall (m :: * -> *). MonadQuote m => a -> m a
TPLC.rename
runPrerename Prerename
PrerenameNo  = a -> a
forall a. a -> a
id

-- | Test scoping for a renamer.
prop_scopingFor ::
  (PrettyPlc (t NameAnn), TPLC.Rename (t NameAnn), Scoping t) =>
  -- | A generator of types\/terms\/programs.
  AstGen (t ann) ->
  -- | Whether binding removal is expected for the pass.
  BindingRemoval ->
  -- | Whether renaming is required before running the scoping tests. Note that the scoping tests
  -- rely on global uniqueness themselves, hence for any pass that doesn't perform renaming
  -- internally this needs to be 'PrerenameYes'.
  Prerename ->
  -- | The runner of the pass.
  (t NameAnn -> TPLC.Quote (t NameAnn)) ->
  Property
prop_scopingFor :: forall (t :: * -> *) ann.
(PrettyPlc (t NameAnn), Rename (t NameAnn), Scoping t) =>
AstGen (t ann)
-> BindingRemoval
-> Prerename
-> (t NameAnn -> Quote (t NameAnn))
-> Property
prop_scopingFor AstGen (t ann)
gen BindingRemoval
bindRem Prerename
preren t NameAnn -> Quote (t NameAnn)
run = TestLimit -> Property -> Property
withTests TestLimit
200 (Property -> Property)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  t ann
prog <- Gen (t ann) -> PropertyT IO (t ann)
forall (m :: * -> *) a. Monad m => Gen a -> PropertyT m a
forAllNoShow (Gen (t ann) -> PropertyT IO (t ann))
-> Gen (t ann) -> PropertyT IO (t ann)
forall a b. (a -> b) -> a -> b
$ AstGen (t ann) -> Gen (t ann)
forall (m :: * -> *) a. MonadGen m => AstGen a -> m a
runAstGen AstGen (t ann)
gen
  let catchEverything :: a -> Either SomeException a
catchEverything = IO (Either SomeException a) -> Either SomeException a
forall a. IO a -> a
unsafePerformIO (IO (Either SomeException a) -> Either SomeException a)
-> (a -> IO (Either SomeException a))
-> a
-> Either SomeException a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException (IO a -> IO (Either SomeException a))
-> (a -> IO a) -> a -> IO (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO a
forall a. a -> IO a
evaluate
      prep :: t NameAnn -> t NameAnn
prep = Prerename -> t NameAnn -> t NameAnn
forall a. Rename a => Prerename -> a -> a
runPrerename Prerename
preren
  case Either (ScopeCheckError t) ()
-> Either SomeException (Either (ScopeCheckError t) ())
forall {a}. a -> Either SomeException a
catchEverything (Either (ScopeCheckError t) ()
 -> Either SomeException (Either (ScopeCheckError t) ()))
-> Either (ScopeCheckError t) ()
-> Either SomeException (Either (ScopeCheckError t) ())
forall a b. (a -> b) -> a -> b
$ BindingRemoval
-> (t NameAnn -> t NameAnn)
-> (t NameAnn -> t NameAnn)
-> t ann
-> Either (ScopeCheckError t) ()
forall (t :: * -> *) ann.
Scoping t =>
BindingRemoval
-> (t NameAnn -> t NameAnn)
-> (t NameAnn -> t NameAnn)
-> t ann
-> Either (ScopeCheckError t) ()
checkRespectsScoping BindingRemoval
bindRem t NameAnn -> t NameAnn
prep (Quote (t NameAnn) -> t NameAnn
forall a. Quote a -> a
TPLC.runQuote (Quote (t NameAnn) -> t NameAnn)
-> (t NameAnn -> Quote (t NameAnn)) -> t NameAnn -> t NameAnn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t NameAnn -> Quote (t NameAnn)
run) t ann
prog of
    Left SomeException
exc         -> String -> PropertyT IO ()
forall a. String -> PropertyT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> PropertyT IO ()) -> String -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
exc
    Right (Left ScopeCheckError t
err) -> String -> PropertyT IO ()
forall a. String -> PropertyT IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> PropertyT IO ()) -> String -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ ScopeCheckError t -> String
forall a str. (PrettyPlc a, Render str) => a -> str
displayPlc ScopeCheckError t
err
    Right (Right ()) -> PropertyT IO ()
forall (m :: * -> *). MonadTest m => m ()
success

-- | Test that a pass does not break global uniqueness.
test_scopingGood ::
  (PrettyPlc (t NameAnn), TPLC.Rename (t NameAnn), Scoping t) =>
  -- | The name of the pass we're about to test.
  String ->
  -- | A generator of types\/terms\/programs.
  AstGen (t ann) ->
  -- | Whether binding removal is expected for the pass.
  BindingRemoval ->
  -- | Whether renaming is required before running the scoping tests. Note that the scoping tests
  -- rely on global uniqueness themselves, hence for any pass that doesn't perform renaming
  -- internally this needs to be 'PrerenameYes'.
  Prerename ->
  -- | The runner of the pass.
  (t NameAnn -> TPLC.Quote (t NameAnn)) ->
  TestTree
test_scopingGood :: forall (t :: * -> *) ann.
(PrettyPlc (t NameAnn), Rename (t NameAnn), Scoping t) =>
String
-> AstGen (t ann)
-> BindingRemoval
-> Prerename
-> (t NameAnn -> Quote (t NameAnn))
-> TestTree
test_scopingGood String
pass AstGen (t ann)
gen BindingRemoval
bindRem Prerename
preren t NameAnn -> Quote (t NameAnn)
run =
  String -> PropertyName -> Property -> TestTree
testPropertyNamed (String
pass String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not break scoping and global uniqueness") PropertyName
"test_scopingGood" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
    AstGen (t ann)
-> BindingRemoval
-> Prerename
-> (t NameAnn -> Quote (t NameAnn))
-> Property
forall (t :: * -> *) ann.
(PrettyPlc (t NameAnn), Rename (t NameAnn), Scoping t) =>
AstGen (t ann)
-> BindingRemoval
-> Prerename
-> (t NameAnn -> Quote (t NameAnn))
-> Property
prop_scopingFor AstGen (t ann)
gen BindingRemoval
bindRem Prerename
preren t NameAnn -> Quote (t NameAnn)
run

-- | Test that a pass breaks global uniqueness.
test_scopingBad ::
  (PrettyPlc (t NameAnn), TPLC.Rename (t NameAnn), Scoping t) =>
  -- | The name of the pass we're about to test.
  String ->
  -- | A generator of types\/terms\/programs.
  AstGen (t ann) ->
  -- | Whether binding removal is expected for the pass.
  BindingRemoval ->
  -- | Whether renaming is required before running the scoping tests. Note that the scoping tests
  -- rely on global uniqueness themselves, hence for any pass that doesn't perform renaming
  -- internally this needs to be 'PrerenameYes'.
  Prerename ->
  -- | The runner of the pass.
  (t NameAnn -> TPLC.Quote (t NameAnn)) ->
  TestTree
test_scopingBad :: forall (t :: * -> *) ann.
(PrettyPlc (t NameAnn), Rename (t NameAnn), Scoping t) =>
String
-> AstGen (t ann)
-> BindingRemoval
-> Prerename
-> (t NameAnn -> Quote (t NameAnn))
-> TestTree
test_scopingBad String
pass AstGen (t ann)
gen BindingRemoval
bindRem Prerename
preren t NameAnn -> Quote (t NameAnn)
run =
  String -> IO () -> TestTree
testCase (String
pass String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" breaks scoping or global uniqueness") (IO () -> TestTree) -> (Property -> IO ()) -> Property -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Property -> IO ()
checkFails (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
    AstGen (t ann)
-> BindingRemoval
-> Prerename
-> (t NameAnn -> Quote (t NameAnn))
-> Property
forall (t :: * -> *) ann.
(PrettyPlc (t NameAnn), Rename (t NameAnn), Scoping t) =>
AstGen (t ann)
-> BindingRemoval
-> Prerename
-> (t NameAnn -> Quote (t NameAnn))
-> Property
prop_scopingFor AstGen (t ann)
gen BindingRemoval
bindRem Prerename
preren t NameAnn -> Quote (t NameAnn)
run

-- | Test that the scoping machinery fails when the given renamer is spoiled in some way
-- (e.g. marking is removed) to ensure that the machinery does catch bugs.
test_scopingSpoilRenamer ::
  (PrettyPlc (t NameAnn), TPLC.Rename (t NameAnn), Scoping t, Monoid ren) =>
  AstGen (t ann) ->
  (t NameAnn -> TPLC.Quote ()) ->
  (forall m. (TPLC.MonadQuote m, MonadReader ren m) => t NameAnn -> m (t NameAnn)) ->
  TestTree
test_scopingSpoilRenamer :: forall (t :: * -> *) ren ann.
(PrettyPlc (t NameAnn), Rename (t NameAnn), Scoping t,
 Monoid ren) =>
AstGen (t ann)
-> (t NameAnn -> Quote ())
-> (forall (m :: * -> *).
    (MonadQuote m, MonadReader ren m) =>
    t NameAnn -> m (t NameAnn))
-> TestTree
test_scopingSpoilRenamer AstGen (t ann)
gen t NameAnn -> Quote ()
mark forall (m :: * -> *).
(MonadQuote m, MonadReader ren m) =>
t NameAnn -> m (t NameAnn)
renM =
  String -> [TestTree] -> TestTree
testGroup
    String
"bad renaming"
    [ String
-> AstGen (t ann)
-> BindingRemoval
-> Prerename
-> (t NameAnn -> Quote (t NameAnn))
-> TestTree
forall (t :: * -> *) ann.
(PrettyPlc (t NameAnn), Rename (t NameAnn), Scoping t) =>
String
-> AstGen (t ann)
-> BindingRemoval
-> Prerename
-> (t NameAnn -> Quote (t NameAnn))
-> TestTree
test_scopingBad String
"wrong renaming" AstGen (t ann)
gen BindingRemoval
BindingRemovalNotOk Prerename
PrerenameNo ((t NameAnn -> Quote (t NameAnn)) -> TestTree)
-> (t NameAnn -> Quote (t NameAnn)) -> TestTree
forall a b. (a -> b) -> a -> b
$
        (t NameAnn -> Quote ())
-> (t NameAnn -> BrokenRenameT ren (QuoteT Identity) (t NameAnn))
-> t NameAnn
-> Quote (t NameAnn)
forall (m :: * -> *) ren t.
(MonadQuote m, Monoid ren) =>
(t -> m ()) -> (t -> BrokenRenameT ren m t) -> t -> m t
brokenRename t NameAnn -> Quote ()
mark t NameAnn -> BrokenRenameT ren (QuoteT Identity) (t NameAnn)
forall (m :: * -> *).
(MonadQuote m, MonadReader ren m) =>
t NameAnn -> m (t NameAnn)
renM
    , String
-> AstGen (t ann)
-> BindingRemoval
-> Prerename
-> (t NameAnn -> Quote (t NameAnn))
-> TestTree
forall (t :: * -> *) ann.
(PrettyPlc (t NameAnn), Rename (t NameAnn), Scoping t) =>
String
-> AstGen (t ann)
-> BindingRemoval
-> Prerename
-> (t NameAnn -> Quote (t NameAnn))
-> TestTree
test_scopingBad String
"no renaming" AstGen (t ann)
gen BindingRemoval
BindingRemovalNotOk Prerename
PrerenameNo ((t NameAnn -> Quote (t NameAnn)) -> TestTree)
-> (t NameAnn -> Quote (t NameAnn)) -> TestTree
forall a b. (a -> b) -> a -> b
$
        (t NameAnn -> Quote ())
-> (t NameAnn -> NoRenameT ren (QuoteT Identity) (t NameAnn))
-> t NameAnn
-> Quote (t NameAnn)
forall (m :: * -> *) t ren.
MonadQuote m =>
(t -> m ()) -> (t -> NoRenameT ren m t) -> t -> m t
noRename t NameAnn -> Quote ()
mark t NameAnn -> NoRenameT ren (QuoteT Identity) (t NameAnn)
forall (m :: * -> *).
(MonadQuote m, MonadReader ren m) =>
t NameAnn -> m (t NameAnn)
renM
    , String
-> AstGen (t ann)
-> BindingRemoval
-> Prerename
-> (t NameAnn -> Quote (t NameAnn))
-> TestTree
forall (t :: * -> *) ann.
(PrettyPlc (t NameAnn), Rename (t NameAnn), Scoping t) =>
String
-> AstGen (t ann)
-> BindingRemoval
-> Prerename
-> (t NameAnn -> Quote (t NameAnn))
-> TestTree
test_scopingBad String
"renaming with no marking" AstGen (t ann)
gen BindingRemoval
BindingRemovalNotOk Prerename
PrerenameNo ((t NameAnn -> Quote (t NameAnn)) -> TestTree)
-> (t NameAnn -> Quote (t NameAnn)) -> TestTree
forall a b. (a -> b) -> a -> b
$
        (t NameAnn -> NoMarkRenameT ren (QuoteT Identity) (t NameAnn))
-> t NameAnn -> Quote (t NameAnn)
forall ren t (m :: * -> *).
Monoid ren =>
(t -> NoMarkRenameT ren m t) -> t -> m t
noMarkRename t NameAnn -> NoMarkRenameT ren (QuoteT Identity) (t NameAnn)
forall (m :: * -> *).
(MonadQuote m, MonadReader ren m) =>
t NameAnn -> m (t NameAnn)
renM
    ]