{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Plutus conformance test suite library.
module PlutusConformance.Common where

import Control.Monad.Except (runExcept)
import Data.ByteString qualified as BS
import Data.Maybe (fromJust)
import Data.Proxy (Proxy (Proxy))
import Data.Tagged (Tagged (Tagged))
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Text.IO qualified as T
import PlutusCore.Annotation
import PlutusCore.DeBruijn (fakeNameDeBruijn)
import PlutusCore.Default
  ( DefaultFun
  , DefaultUni
  )
import PlutusCore.Error (ParserErrorBundle)
import PlutusCore.Evaluation.Machine.CostModelInterface
import PlutusCore.Evaluation.Machine.ExBudget
import PlutusCore.Evaluation.Machine.ExBudgetingDefaults
  ( defaultCostModelParamsForTesting
  )
import PlutusCore.Flat
  ( DecodeException
  , flat
  , unflat
  )
import PlutusCore.Name.Unique (Name)
import PlutusCore.Quote (runQuoteT)
import PlutusPrelude
  ( Pretty (pretty)
  , display
  , void
  )
import System.Directory
import System.FilePath
  ( takeBaseName
  , takeFileName
  , (<.>)
  , (</>)
  )
import Test.Tasty
  ( defaultIngredients
  , defaultMainWithIngredients
  , includingOptions
  , testGroup
  )
import Test.Tasty.ExpectedFailure (ignoreTest)
import Test.Tasty.Extras (goldenVsDocM)
import Test.Tasty.Golden (findByExtension)
import Test.Tasty.Golden.Advanced (goldenTest)
import Test.Tasty.Options
  ( IsOption (..)
  , OptionDescription (Option)
  , lookupOption
  )
import Test.Tasty.Providers (TestTree)
import Test.Tasty.Runners (parseOptions)
import UntypedPlutusCore qualified as UPLC
import UntypedPlutusCore.Parser qualified as UPLC
import Witherable (Witherable (wither))

-- Common functions for all tests

{-| The text shown when a file fails to parse or decode.  We don't want to
show the detailed errors so that users of the test suite can produce the
expected output more easily. This is used in .uplc.expected and .budget.expected
files. -}
shownParseError :: T.Text
shownParseError :: Text
shownParseError = Text
"parse/decode error"

{-| The text shown when evaluation fails.  This is used in .uplc.expected and
.budget.expected files. -}
shownEvaluationFailure :: T.Text
shownEvaluationFailure :: Text
shownEvaluationFailure = Text
"evaluation failure"

{-| The default parser to parse UPLC program inputs.
FIXME: unlike the flat decoder, this does not detect free variables: they will
only be detected if/when we deBruijnify the program. -}
parseTxt
  :: T.Text
  -> Either ParserErrorBundle (UPLC.Program Name DefaultUni DefaultFun SrcSpan)
parseTxt :: Text
-> Either
     ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan)
parseTxt Text
resTxt = QuoteT
  (Either ParserErrorBundle)
  (Program Name DefaultUni DefaultFun SrcSpan)
-> Either
     ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan)
forall (m :: * -> *) a. Monad m => QuoteT m a -> m a
runQuoteT (QuoteT
   (Either ParserErrorBundle)
   (Program Name DefaultUni DefaultFun SrcSpan)
 -> Either
      ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan))
-> QuoteT
     (Either ParserErrorBundle)
     (Program Name DefaultUni DefaultFun SrcSpan)
-> Either
     ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan)
forall a b. (a -> b) -> a -> b
$ Text
-> QuoteT
     (Either ParserErrorBundle)
     (Program Name DefaultUni DefaultFun SrcSpan)
forall (m :: * -> *).
(MonadError ParserErrorBundle m, MonadQuote m) =>
Text -> m (Program Name DefaultUni DefaultFun SrcSpan)
UPLC.parseProgram Text
resTxt

-- | The input/output UPLC program type.
type UplcProg = UPLC.Program Name DefaultUni DefaultFun ()

-- Test-case input format

{-| The format of the test-case input files that the tests should be run
against: either the textual `.uplc` representation or the `flat`-encoded
`.flat` representation of the same program.  See `formatExtension`. -}
data Format = Textual | Flat
  deriving stock (Int -> Format -> ShowS
[Format] -> ShowS
Format -> [Char]
(Int -> Format -> ShowS)
-> (Format -> [Char]) -> ([Format] -> ShowS) -> Show Format
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Format -> ShowS
showsPrec :: Int -> Format -> ShowS
$cshow :: Format -> [Char]
show :: Format -> [Char]
$cshowList :: [Format] -> ShowS
showList :: [Format] -> ShowS
Show, Format -> Format -> Bool
(Format -> Format -> Bool)
-> (Format -> Format -> Bool) -> Eq Format
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Format -> Format -> Bool
== :: Format -> Format -> Bool
$c/= :: Format -> Format -> Bool
/= :: Format -> Format -> Bool
Eq)

-- | The filename extension (without the leading dot) used for a given `Format`.
formatExtension :: Format -> String
formatExtension :: Format -> [Char]
formatExtension Format
Textual = [Char]
"uplc"
formatExtension Format
Flat = [Char]
"flat"

{-| This instance allows `Format` to be used as a `tasty` command-line option
(`--format=textual` or `--format=flat`), so that users of the test suites can
choose which input format the tests are run against.  The default is `uplc`. -}
instance IsOption Format where
  defaultValue :: Format
defaultValue = Format
Textual
  parseValue :: [Char] -> Maybe Format
parseValue [Char]
s = case [Char]
s of
    [Char]
"textual" -> Format -> Maybe Format
forall a. a -> Maybe a
Just Format
Textual
    [Char]
"flat" -> Format -> Maybe Format
forall a. a -> Maybe a
Just Format
Flat
    [Char]
_ -> Maybe Format
forall a. Maybe a
Nothing
  optionName :: Tagged Format [Char]
optionName = [Char] -> Tagged Format [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"format"
  optionHelp :: Tagged Format [Char]
optionHelp =
    [Char] -> Tagged Format [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged
      [Char]
"The format of the test-case input files to run the tests against: \
      \'textual' (textual UPLC source) or 'flat' (flat-encoded UPLC). \
      \Default: textual."

-- UPLC evaluation test functions

-- A type to contain a result or one of several kinds of failure
data EvaluationResult res = BadMachineParameters | DecodeError | EvalFailure | EvalSuccess res
  deriving stock ((forall a b. (a -> b) -> EvaluationResult a -> EvaluationResult b)
-> (forall a b. a -> EvaluationResult b -> EvaluationResult a)
-> Functor EvaluationResult
forall a b. a -> EvaluationResult b -> EvaluationResult a
forall a b. (a -> b) -> EvaluationResult a -> EvaluationResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> EvaluationResult a -> EvaluationResult b
fmap :: forall a b. (a -> b) -> EvaluationResult a -> EvaluationResult b
$c<$ :: forall a b. a -> EvaluationResult b -> EvaluationResult a
<$ :: forall a b. a -> EvaluationResult b -> EvaluationResult a
Functor)

-- convenience type synonym
type UplcEvaluatorFun res = UplcProg -> EvaluationResult res

-- TODO: consider splitting up the evaluator with costing into a part that
-- parses the model and a part that consumes it. Currently the tests are fast
-- enough regardless so it doesn't matter.

-- | The evaluator to be tested.
data UplcEvaluator
  = -- | An evaluator that just produces an output program, or fails.
    UplcEvaluatorWithoutCosting (UplcEvaluatorFun UplcProg)
  | {-| An evaluator that produces an output program along with the cost of
    evaluating it, or fails. Note that nothing cares about the cost of failing
    programs, so we don't test for conformance there. -}
    UplcEvaluatorWithCosting
      (CostModelParams -> UplcEvaluatorFun (UplcProg, ExBudget))

{-| Directories under which no `.flat` input files are expected and hence
shouldn't lead to errors.  These test the textual parser's handling of
constants, and there are generally no `flat` equivalents for these tests. This
applies to the directory itself and everything below it. -}
dirsWithNoFlatFiles :: [FilePath]
dirsWithNoFlatFiles :: [[Char]]
dirsWithNoFlatFiles =
  [ [Char]
"test-cases/uplc/evaluation/builtin/parser"
  , [Char]
"test-cases/uplc/evaluation/term/parser"
  ]

{-| Walk a file tree, making test groups for directories with subdirectories,
   and test cases for directories without.  We expect every test directory to
   contain a single input file, in the given `Format`, whose name matches that
   of the directory. For example, if the `Format` is `UPLC` then the directory
   `modInteger-15` should contain `modInteger-15.uplc`, and that file should
   contain a textual UPLC program; if the `Format` is `Flat` then it should
   instead contain `modInteger-15.flat`, a `flat`-encoded UPLC program.  The
   evaluation golden file is named to match: `modInteger-15.uplc.expected`
   for `Textual`, or `modInteger-15.flat.expected` for `Flat`.  The budget
   golden file, however, is always `modInteger-15.budget.expected`
   regardless of format, since there's no per-format budget convention (the
   budget only depends on the AST, not on how it was obtained). These golden
   files will be created by the testing machinery if they aren't already
   present.

   Every test-case directory is expected to have an input file for the requested
   `Format`; a missing input file is treated as an error, except under the
   directories listed in `dirsWithNoFlatFiles`, where (in `Flat` mode only) no
   `.flat` files is expected and the directory is skipped instead (for example
   `.flat` files don't make sense for the tests under
   `test-cases/uplc/evaluation/builtin/parser`, which test the handling of
   constants by the textual parser). -}
discoverTests
  :: Format
  -- ^ The format of the test-case input files to run the tests against (.uplc or .flat).
  -> UplcEvaluator
  -- ^ The evaluator to be tested.
  -> CostModelParams
  -> (FilePath -> Bool)
  {-^ A function that takes a test directory and returns a Bool indicating
  whether the evaluation test for the file in that directory is expected to
  fail. -}
  -> (FilePath -> Bool)
  {-^ A function that takes a test directory and returns a Bool indicating
  whether the budget test for the file in that directory is expected to fail. -}
  -> FilePath
  -- ^ The directory to search for tests.
  -> IO TestTree
discoverTests :: Format
-> UplcEvaluator
-> CostModelParams
-> ([Char] -> Bool)
-> ([Char] -> Bool)
-> [Char]
-> IO TestTree
discoverTests Format
fmt UplcEvaluator
eval CostModelParams
modelParams [Char] -> Bool
evaluationFailureExpected [Char] -> Bool
budgetFailureExpected =
  Bool -> [Char] -> IO TestTree
go Bool
False
  where
    ext :: [Char]
ext = Format -> [Char]
formatExtension Format
fmt
    go :: Bool -> [Char] -> IO TestTree
go Bool
flatNotExpected [Char]
dir = do
      let name :: [Char]
name = ShowS
takeBaseName [Char]
dir
          flatNotExpected' :: Bool
flatNotExpected' = Bool
flatNotExpected Bool -> Bool -> Bool
|| [Char]
dir [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
dirsWithNoFlatFiles
      [[Char]]
children <- [Char] -> IO [[Char]]
listDirectory [Char]
dir
      [[Char]]
subdirs <- (([Char] -> IO (Maybe [Char])) -> [[Char]] -> IO [[Char]])
-> [[Char]] -> ([Char] -> IO (Maybe [Char])) -> IO [[Char]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([Char] -> IO (Maybe [Char])) -> [[Char]] -> IO [[Char]]
forall (t :: * -> *) (f :: * -> *) a b.
(Witherable t, Applicative f) =>
(a -> f (Maybe b)) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f (Maybe b)) -> [a] -> f [b]
wither [[Char]]
children (([Char] -> IO (Maybe [Char])) -> IO [[Char]])
-> ([Char] -> IO (Maybe [Char])) -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ \[Char]
child -> do
        let fullPath :: [Char]
fullPath = [Char]
dir [Char] -> ShowS
</> [Char]
child
        Bool
isDir <- [Char] -> IO Bool
doesDirectoryExist [Char]
fullPath
        Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [Char] -> IO (Maybe [Char]))
-> Maybe [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ if Bool
isDir then [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
fullPath else Maybe [Char]
forall a. Maybe a
Nothing
      if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
subdirs
        -- no children, this is a test case directory
        then do
          -- Check that the directory <dir> contains at most one input file
          -- with the extension for the requested format, and that if it's
          -- present it's called <name>.<ext>, where <name> is the final path
          -- component of <dir>.
          [[Char]]
inputFiles <- [[Char]] -> [Char] -> IO [[Char]]
findByExtension [[Char]
"." [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
ext] [Char]
dir
          let expectedInputFile :: [Char]
expectedInputFile = ShowS
takeFileName [Char]
dir [Char] -> ShowS
<.> [Char]
ext
          case [[Char]]
inputFiles of
            [] ->
              if Format
fmt Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
Flat Bool -> Bool -> Bool
&& Bool
flatNotExpected'
                then -- No `.flat` file for this test case, but that's expected here: skip it.
                  TestTree -> IO TestTree
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestTree -> IO TestTree) -> TestTree -> IO TestTree
forall a b. (a -> b) -> a -> b
$ [Char] -> [TestTree] -> TestTree
testGroup [Char]
name []
                else [Char] -> IO TestTree
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO TestTree) -> [Char] -> IO TestTree
forall a b. (a -> b) -> a -> b
$ [Char]
"Input file " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
expectedInputFile [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" missing in " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
dir
            [Char]
_ : [Char]
_ : [[Char]]
_ -> [Char] -> IO TestTree
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO TestTree) -> [Char] -> IO TestTree
forall a b. (a -> b) -> a -> b
$ [Char]
"More than one ." [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
ext [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" file in " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
dir
            [[Char]
inputFilePath] ->
              if ShowS
takeFileName [Char]
inputFilePath [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
expectedInputFile
                then
                  [Char] -> IO TestTree
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO TestTree) -> [Char] -> IO TestTree
forall a b. (a -> b) -> a -> b
$
                    [Char]
"Found file "
                      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
takeFileName [Char]
inputFilePath
                      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" in directory "
                      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
dir
                      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" (expected "
                      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
expectedInputFile
                      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"
                else TestTree -> IO TestTree
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestTree -> IO TestTree) -> TestTree -> IO TestTree
forall a b. (a -> b) -> a -> b
$ case UplcEvaluator
eval of
                  UplcEvaluatorWithCosting CostModelParams -> UplcEvaluatorFun (UplcProg, ExBudget)
f ->
                    [Char] -> [TestTree] -> TestTree
testGroup
                      [Char]
name
                      [ [Char] -> [Char] -> UplcEvaluatorFun UplcProg -> TestTree
testForEval [Char]
dir [Char]
inputFilePath (((UplcProg, ExBudget) -> UplcProg)
-> EvaluationResult (UplcProg, ExBudget)
-> EvaluationResult UplcProg
forall a b. (a -> b) -> EvaluationResult a -> EvaluationResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UplcProg, ExBudget) -> UplcProg
forall a b. (a, b) -> a
fst (EvaluationResult (UplcProg, ExBudget)
 -> EvaluationResult UplcProg)
-> UplcEvaluatorFun (UplcProg, ExBudget)
-> UplcEvaluatorFun UplcProg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CostModelParams -> UplcEvaluatorFun (UplcProg, ExBudget)
f CostModelParams
modelParams)
                      , [Char] -> [Char] -> UplcEvaluatorFun ExBudget -> TestTree
testForBudget [Char]
dir [Char]
inputFilePath (((UplcProg, ExBudget) -> ExBudget)
-> EvaluationResult (UplcProg, ExBudget)
-> EvaluationResult ExBudget
forall a b. (a -> b) -> EvaluationResult a -> EvaluationResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UplcProg, ExBudget) -> ExBudget
forall a b. (a, b) -> b
snd (EvaluationResult (UplcProg, ExBudget)
 -> EvaluationResult ExBudget)
-> UplcEvaluatorFun (UplcProg, ExBudget)
-> UplcEvaluatorFun ExBudget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CostModelParams -> UplcEvaluatorFun (UplcProg, ExBudget)
f CostModelParams
modelParams)
                      ]
                  UplcEvaluatorWithoutCosting UplcEvaluatorFun UplcProg
f -> [Char] -> [Char] -> UplcEvaluatorFun UplcProg -> TestTree
testForEval [Char]
dir [Char]
inputFilePath UplcEvaluatorFun UplcProg
f
        -- has children, so it's a grouping directory
        else [Char] -> [TestTree] -> TestTree
testGroup [Char]
name ([TestTree] -> TestTree) -> IO [TestTree] -> IO TestTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> IO TestTree) -> [[Char]] -> IO [TestTree]
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 (Bool -> [Char] -> IO TestTree
go Bool
flatNotExpected') [[Char]]
subdirs
    -- The names of all of the golden files begin with the name of the directory.
    goldenBasePath :: ShowS
goldenBasePath [Char]
dir = [Char]
dir [Char] -> ShowS
</> ShowS
takeBaseName [Char]
dir
    testForEval :: FilePath -> FilePath -> UplcEvaluatorFun UplcProg -> TestTree
    testForEval :: [Char] -> [Char] -> UplcEvaluatorFun UplcProg -> TestTree
testForEval [Char]
dir [Char]
inputFilePath UplcEvaluatorFun UplcProg
e =
      let goldenFilePath :: [Char]
goldenFilePath = ShowS
goldenBasePath [Char]
dir [Char] -> ShowS
<.> [Char]
ext [Char] -> ShowS
<.> [Char]
"expected"
          test :: TestTree
test =
            [Char]
-> IO (Either Text UplcProg)
-> IO (Either Text UplcProg)
-> (Either Text UplcProg
    -> Either Text UplcProg -> IO (Maybe [Char]))
-> (Either Text UplcProg -> IO ())
-> TestTree
forall a.
[Char]
-> IO a
-> IO a
-> (a -> a -> IO (Maybe [Char]))
-> (a -> IO ())
-> TestTree
goldenTest
              (ShowS
takeFileName [Char]
inputFilePath [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" (evaluation)")
              -- get the golden test value
              (Format -> [Char] -> IO (Either Text UplcProg)
getExpectedProg Format
fmt [Char]
goldenFilePath)
              -- get the tested value
              (Format
-> UplcEvaluatorFun UplcProg -> [Char] -> IO (Either Text UplcProg)
forall res.
Format -> UplcEvaluatorFun res -> [Char] -> IO (Either Text res)
getTestedValue Format
fmt UplcEvaluatorFun UplcProg
e [Char]
inputFilePath)
              (\Either Text UplcProg
x Either Text UplcProg
y -> Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [Char] -> IO (Maybe [Char]))
-> Maybe [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ Either Text UplcProg -> Either Text UplcProg -> Maybe [Char]
compareAlphaEq Either Text UplcProg
x Either Text UplcProg
y) -- comparison function
              (Format -> [Char] -> Either Text UplcProg -> IO ()
updateGoldenFile Format
fmt [Char]
goldenFilePath) -- update the golden file
       in Bool -> TestTree -> TestTree
possiblyFailingTest ([Char] -> Bool
evaluationFailureExpected [Char]
dir) TestTree
test
    testForBudget :: FilePath -> FilePath -> UplcEvaluatorFun ExBudget -> TestTree
    testForBudget :: [Char] -> [Char] -> UplcEvaluatorFun ExBudget -> TestTree
testForBudget [Char]
dir [Char]
inputFilePath UplcEvaluatorFun ExBudget
e =
      let goldenFilePath :: [Char]
goldenFilePath = ShowS
goldenBasePath [Char]
dir [Char] -> ShowS
<.> [Char]
"budget" [Char] -> ShowS
<.> [Char]
"expected"
          prettyEither :: Either a a -> Doc ann
prettyEither (Left a
l) = a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
l
          prettyEither (Right a
r) = a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
r
          test :: TestTree
test =
            [Char] -> [Char] -> IO (Doc Any) -> TestTree
forall ann. [Char] -> [Char] -> IO (Doc ann) -> TestTree
goldenVsDocM
              (ShowS
takeFileName [Char]
inputFilePath [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" (budget)")
              [Char]
goldenFilePath
              (Either Text ExBudget -> Doc Any
forall {a} {a} {ann}. (Pretty a, Pretty a) => Either a a -> Doc ann
prettyEither (Either Text ExBudget -> Doc Any)
-> IO (Either Text ExBudget) -> IO (Doc Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Format
-> UplcEvaluatorFun ExBudget -> [Char] -> IO (Either Text ExBudget)
forall res.
Format -> UplcEvaluatorFun res -> [Char] -> IO (Either Text res)
getTestedValue Format
fmt UplcEvaluatorFun ExBudget
e [Char]
inputFilePath)
       in Bool -> TestTree -> TestTree
possiblyFailingTest ([Char] -> Bool
budgetFailureExpected [Char]
dir) TestTree
test
    possiblyFailingTest :: Bool -> TestTree -> TestTree
    possiblyFailingTest :: Bool -> TestTree -> TestTree
possiblyFailingTest Bool
failureExpected TestTree
test =
      if Bool
failureExpected
        then TestTree -> TestTree
ignoreTest TestTree
test
        -- TODO: ^ this should really be `expectFail`, but that behaves strangely
        -- with `--accept` (the golden files for the failing tests get updated:
        -- see https://github.com/IntersectMBO/plutus/issues/6714 and
        -- https://github.com/nomeata/tasty-expected-failure/issues/27.
        -- If/when that gets fixed `ignoreTest` should be changed to `expectFail`.
        else TestTree
test

{-| Check whether some text looks like it's meant to be a UPLC program, ie,
whether it begins with `(program` once whitespace and comments (which may
appear before the `(` and/or between the `(` and `program`, as `--` line
comments or `{\- -\}` block comments -- possibly nested, matching the real
lexer's `whitespace` parser in "PlutusCore.Parser.ParserCommon" -- are
ignored). -}
looksLikeUplcProgram :: T.Text -> Bool
looksLikeUplcProgram :: Text -> Bool
looksLikeUplcProgram Text
t =
  case Text -> Maybe (Char, Text)
T.uncons (Text -> Text
dropLeadingCommentsAndSpace Text
t) of
    Just (Char
'(', Text
rest) -> Text
"program" Text -> Text -> Bool
`T.isPrefixOf` Text -> Text
dropLeadingCommentsAndSpace Text
rest
    Maybe (Char, Text)
_ -> Bool
False
  where
    dropLeadingCommentsAndSpace :: T.Text -> T.Text
    dropLeadingCommentsAndSpace :: Text -> Text
dropLeadingCommentsAndSpace Text
s =
      let s' :: Text
s' = Text -> Text
T.stripStart Text
s
       in if Text
"--" Text -> Text -> Bool
`T.isPrefixOf` Text
s'
            then Text -> Text
dropLeadingCommentsAndSpace ((Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') Text
s')
            else case Text -> Text -> Maybe Text
T.stripPrefix Text
"{-" Text
s' of
              Just Text
rest -> Text -> Text
dropLeadingCommentsAndSpace (Int -> Text -> Text
dropBlockComment Int
1 Text
rest)
              Maybe Text
Nothing -> Text
s'
    -- Skip past the remainder of a block comment which is already open to
    -- the given nesting `depth`, ie, past the point where we've just
    -- consumed the opening `{-`. Mirrors `Lex.skipBlockCommentNested "{-"
    -- "-}"`. If the comment is unterminated, we just give up and return the
    -- empty text rather than looping forever.
    dropBlockComment :: Int -> T.Text -> T.Text
    dropBlockComment :: Int -> Text -> Text
dropBlockComment Int
0 Text
s = Text
s
    dropBlockComment Int
depth Text
s
      | Just Text
rest <- Text -> Text -> Maybe Text
T.stripPrefix Text
"{-" Text
s = Int -> Text -> Text
dropBlockComment (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
rest
      | Just Text
rest <- Text -> Text -> Maybe Text
T.stripPrefix Text
"-}" Text
s = Int -> Text -> Text
dropBlockComment (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
rest
      | Just (Char
_, Text
rest) <- Text -> Maybe (Char, Text)
T.uncons Text
s = Int -> Text -> Text
dropBlockComment Int
depth Text
rest
      | Bool
otherwise = Text
s

{-| Turn the expected file content in text to a `UplcProg` unless the expected
result is a parse or evaluation error.  We use the same shape-based check as
`getInputProg` (`looksLikeUplcProgram`) to decide whether the content
represents a program at all, rather than just trying to parse it and seeing
whether that fails: this way, things like the literal `"parse error"` and
`"evaluation failure"` markers are recognised as failures without needing to
attempt (and fail) a real parse. -}
expectedToProg :: T.Text -> Either T.Text UplcProg
expectedToProg :: Text -> Either Text UplcProg
expectedToProg Text
txt
  | Bool -> Bool
not (Text -> Bool
looksLikeUplcProgram Text
txt) = Text -> Either Text UplcProg
forall a b. a -> Either a b
Left Text
txt
  | Bool
otherwise =
      case Text
-> Either
     ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan)
parseTxt Text
txt of
        Left ParserErrorBundle
_ -> Text -> Either Text UplcProg
forall a b. a -> Either a b
Left Text
txt
        Right Program Name DefaultUni DefaultFun SrcSpan
p -> UplcProg -> Either Text UplcProg
forall a b. b -> Either a b
Right (UplcProg -> Either Text UplcProg)
-> UplcProg -> Either Text UplcProg
forall a b. (a -> b) -> a -> b
$ Program Name DefaultUni DefaultFun SrcSpan -> UplcProg
forall (f :: * -> *) a. Functor f => f a -> f ()
void Program Name DefaultUni DefaultFun SrcSpan
p

{-| Decode the content of a `.flat.expected` golden file.  A `.flat.expected`
file records either a successful evaluation result (as `flat`-encoded
bytes) or a failure (as the UTF8-encoded text of `shownParseError` or
`shownEvaluationFailure`) -- exactly mirroring the `.uplc.expected`
convention (see `expectedToProg`), rather than the old convention of an
empty file standing in for "some failure, reason unspecified". We check for
the text markers first (a valid flat encoding could coincidentally also be
valid UTF8, but it will essentially never happen to be the exact text of
one of the two markers).

If the content is neither a recognised failure marker nor a valid flat
encoding (for example because the golden file is empty, using the old
convention, or has been corrupted), we don't fail outright: instead we
return `Left` with the flat decoder's error text as the "expected" reason.
This will essentially never match a real tested value (which is always
either a real program or exactly `shownParseError`/`shownEvaluationFailure`),
so it surfaces as an ordinary golden-mismatch test failure -- visible on a
normal run, and fixable with `--accept` like any other outdated golden file
(which is how the old empty-file goldens get migrated to the new
convention), rather than a special-cased crash. -}
decodeFlatExpected :: BS.ByteString -> Either T.Text UplcProg
decodeFlatExpected :: ByteString -> Either Text UplcProg
decodeFlatExpected ByteString
input =
  case ByteString -> Either UnicodeException Text
TE.decodeUtf8' ByteString
input of
    Right Text
txt
      | Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
shownParseError Bool -> Bool -> Bool
|| Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
shownEvaluationFailure -> Text -> Either Text UplcProg
forall a b. a -> Either a b
Left Text
txt
    Either UnicodeException Text
_ -> case ByteString -> Either [Char] UplcProg
decodeFlatProg ByteString
input of
      Right UplcProg
p -> UplcProg -> Either Text UplcProg
forall a b. b -> Either a b
Right UplcProg
p
      Left [Char]
err -> Text -> Either Text UplcProg
forall a b. a -> Either a b
Left (Text -> Either Text UplcProg) -> Text -> Either Text UplcProg
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
err

{-| Obtain the expected `UplcProg` from a golden `.expected` file in the given
`Format`: parsed as text for `Textual` (via `expectedToProg`), or decoded
via `decodeFlatExpected` for `Flat`. -}
getExpectedProg :: Format -> FilePath -> IO (Either T.Text UplcProg)
getExpectedProg :: Format -> [Char] -> IO (Either Text UplcProg)
getExpectedProg Format
Textual [Char]
file = Text -> Either Text UplcProg
expectedToProg (Text -> Either Text UplcProg)
-> IO Text -> IO (Either Text UplcProg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Text
T.readFile [Char]
file
getExpectedProg Format
Flat [Char]
file = ByteString -> Either Text UplcProg
decodeFlatExpected (ByteString -> Either Text UplcProg)
-> IO ByteString -> IO (Either Text UplcProg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ByteString
BS.readFile [Char]
file

{-| Obtain the input `UplcProg` from a test-case input file in the given
`Format`, either by parsing it (for `textual`) or by `flat`-decoding it (for
`Flat`). Rather than relying on the parser or decoder itself to fail, we check
directly whether the file looks like it's even meant to contain a program: a
`.uplc` file is expected to begin with `(program` (once any leading
whitespace and comments are ignored: see `looksLikeUplcProgram`), and a
`.flat` file is expected to be non-empty. If a file doesn't meet this
expectation, we treat it as `shownParseError` without attempting to
parse or decode it. Otherwise, we go ahead and parse/decode it to get the
actual program (this may still fail, for example if the program contains an
ill-formed constant). -}
getInputProg :: Format -> FilePath -> IO (Either T.Text UplcProg)
getInputProg :: Format -> [Char] -> IO (Either Text UplcProg)
getInputProg Format
Textual [Char]
file = do
  Text
input <- [Char] -> IO Text
T.readFile [Char]
file
  Either Text UplcProg -> IO (Either Text UplcProg)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text UplcProg -> IO (Either Text UplcProg))
-> Either Text UplcProg -> IO (Either Text UplcProg)
forall a b. (a -> b) -> a -> b
$
    if Text -> Bool
looksLikeUplcProgram Text
input
      then case Text
-> Either
     ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan)
parseTxt Text
input of
        Left ParserErrorBundle
_ -> Text -> Either Text UplcProg
forall a b. a -> Either a b
Left Text
shownParseError
        Right Program Name DefaultUni DefaultFun SrcSpan
p -> UplcProg -> Either Text UplcProg
forall a b. b -> Either a b
Right (UplcProg -> Either Text UplcProg)
-> UplcProg -> Either Text UplcProg
forall a b. (a -> b) -> a -> b
$ Program Name DefaultUni DefaultFun SrcSpan -> UplcProg
forall (f :: * -> *) a. Functor f => f a -> f ()
void Program Name DefaultUni DefaultFun SrcSpan
p
      else Text -> Either Text UplcProg
forall a b. a -> Either a b
Left Text
shownParseError
getInputProg Format
Flat [Char]
file = do
  ByteString
input <- [Char] -> IO ByteString
BS.readFile [Char]
file
  Either Text UplcProg -> IO (Either Text UplcProg)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text UplcProg -> IO (Either Text UplcProg))
-> Either Text UplcProg -> IO (Either Text UplcProg)
forall a b. (a -> b) -> a -> b
$
    if ByteString -> Bool
BS.null ByteString
input
      then Text -> Either Text UplcProg
forall a b. a -> Either a b
Left Text
shownParseError
      else case ByteString -> Either [Char] UplcProg
decodeFlatProg ByteString
input of
        -- This is a bit messy in order to deal with an edge case.  If a
        -- .uplc file contains a free variable then parsing will succeed
        -- but evaluation will fail, whereas a free variable in a .flat
        -- file will cause decdoing to fail.  We want to get the same
        -- mesage in both cases because they have to agree with the
        -- expected budget file, which will contatin "evaluation failed".
        -- Perhaps the budget file should just say "error" in that case
        -- without trying to distinguish parse errors and evaluation errors.
        Left [Char]
_ -> Text -> Either Text UplcProg
forall a b. a -> Either a b
Left Text
shownParseError
        Right UplcProg
p -> UplcProg -> Either Text UplcProg
forall a b. b -> Either a b
Right UplcProg
p

{-| Get the tested value from a test-case input file in the given `Format`.
The tested value is either the shown parse error or evaluation error, or a
`res`. -}
getTestedValue
  :: Format
  -> UplcEvaluatorFun res
  -> FilePath
  -> IO (Either T.Text res)
getTestedValue :: forall res.
Format -> UplcEvaluatorFun res -> [Char] -> IO (Either Text res)
getTestedValue Format
fmt UplcEvaluatorFun res
eval [Char]
file = do
  Either Text UplcProg
inputProg <- Format -> [Char] -> IO (Either Text UplcProg)
getInputProg Format
fmt [Char]
file
  Either Text res -> IO (Either Text res)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text res -> IO (Either Text res))
-> Either Text res -> IO (Either Text res)
forall a b. (a -> b) -> a -> b
$ case Either Text UplcProg
inputProg of
    Left Text
err -> Text -> Either Text res
forall a b. a -> Either a b
Left Text
err
    Right UplcProg
p ->
      case UplcEvaluatorFun res
eval UplcProg
p of
        EvaluationResult res
BadMachineParameters -> Text -> Either Text res
forall a b. a -> Either a b
Left Text
shownEvaluationFailure -- questionable, but this should never happen,
        EvaluationResult res
DecodeError -> Text -> Either Text res
forall a b. a -> Either a b
Left Text
shownParseError
        EvaluationResult res
EvalFailure -> Text -> Either Text res
forall a b. a -> Either a b
Left Text
shownEvaluationFailure
        EvalSuccess res
prog -> res -> Either Text res
forall a b. b -> Either a b
Right res
prog

{-| The comparison function used for the golden test.
This function checks alpha-equivalence of programs when the output is a program.
Both `Textual` and `Flat` golden values now record the failure reason precisely
(see `decodeFlatExpected`), so in both cases we require it to match. -}
compareAlphaEq
  :: Either T.Text UplcProg
  -- ^ golden value
  -> Either T.Text UplcProg
  -- ^ tested value
  -> Maybe String
  {-^ If two values are the same, it returns `Nothing`.
   If they are different, it returns an error that will be printed to the user. -}
compareAlphaEq :: Either Text UplcProg -> Either Text UplcProg -> Maybe [Char]
compareAlphaEq (Left Text
expectedTxt) (Left Text
actualTxt) =
  if Text
actualTxt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
expectedTxt
    then Maybe [Char]
forall a. Maybe a
Nothing
    else
      [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$
        [Char]
"Test failed, the output failed to parse or evaluate: \n"
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
actualTxt
compareAlphaEq (Right UplcProg
expected) (Right UplcProg
actual) =
  if UplcProg
actual UplcProg -> UplcProg -> Bool
forall a. Eq a => a -> a -> Bool
== UplcProg
expected
    then Maybe [Char]
forall a. Maybe a
Nothing
    else
      [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$
        [Char]
"Test failed, the output was successfully parsed and evaluated, \
        \but it isn't as expected. "
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"The output program is: \n"
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> UplcProg -> [Char]
forall str a. (Pretty a, Render str) => a -> str
display UplcProg
actual
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n The output program, with the unique names shown is: \n"
          -- using `show` here so that the unique names will show
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> UplcProg -> [Char]
forall a. Show a => a -> [Char]
show UplcProg
actual
          -- the user can look at the .expected file,
          -- but they can't see the unique names
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n But the expected result, with the unique names shown is: \n"
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> UplcProg -> [Char]
forall a. Show a => a -> [Char]
show UplcProg
expected
compareAlphaEq (Right UplcProg
expected) (Left Text
actualTxt) =
  [Char] -> Maybe [Char]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$
    [Char]
"Test failed, the output failed to parse or evaluate: \n"
      [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
actualTxt
      [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n But the expected result, with the unique names shown is: \n"
      [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> UplcProg -> [Char]
forall a. Show a => a -> [Char]
show UplcProg
expected
compareAlphaEq (Left Text
txt) (Right UplcProg
actual) =
  {- this is to catch the case when the expected program failed to parse because
  our parser doesn't support `data` atm. In this case, if the textual program is
  the same as the actual, the test succeeds. -}
  if Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== UplcProg -> Text
forall str a. (Pretty a, Render str) => a -> str
display UplcProg
actual
    then Maybe [Char]
forall a. Maybe a
Nothing
    else
      [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$
        [Char]
"Test failed, the output was successfully parsed and evaluated, \
        \but it isn't as expected. "
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"The output program is: "
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> UplcProg -> [Char]
forall str a. (Pretty a, Render str) => a -> str
display UplcProg
actual
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
". But the expected result is: "
          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
txt

{-| Update the golden file with the tested value, in the given `Format`: as
text for `Textual` (unchanged from before), or, for `Flat`, as `flat`-encoded
bytes on success or the UTF8-encoded failure-reason text on failure (see
`decodeFlatExpected`).
TODO abstract out for other tests. -}
updateGoldenFile
  :: Format
  -> FilePath
  -- ^ the path to write the golden file to
  -> Either T.Text UplcProg
  -> IO ()
updateGoldenFile :: Format -> [Char] -> Either Text UplcProg -> IO ()
updateGoldenFile Format
Textual [Char]
goldenPath (Left Text
txt) = [Char] -> Text -> IO ()
T.writeFile [Char]
goldenPath Text
txt
updateGoldenFile Format
Textual [Char]
goldenPath (Right UplcProg
p) = [Char] -> Text -> IO ()
T.writeFile [Char]
goldenPath (UplcProg -> Text
forall str a. (Pretty a, Render str) => a -> str
display UplcProg
p)
updateGoldenFile Format
Flat [Char]
goldenPath (Left Text
txt) = [Char] -> ByteString -> IO ()
BS.writeFile [Char]
goldenPath (Text -> ByteString
TE.encodeUtf8 Text
txt)
updateGoldenFile Format
Flat [Char]
goldenPath (Right UplcProg
p) = [Char] -> ByteString -> IO ()
BS.writeFile [Char]
goldenPath (UplcProg -> ByteString
encodeFlatProg UplcProg
p)

{-| A golden test that is never actually run: it exists only so that it can be
passed to `parseOptions` to make tasty register the `Golden` test provider's
own options (`--accept`, `--no-create`, `--size-cutoff`, `--delete-output`)
before the real test tree (which needs the parsed `--format` option to be
built in the first place) exists. See the comment in `runUplcEvalTests`. -}
representativeGoldenTest :: TestTree
representativeGoldenTest :: TestTree
representativeGoldenTest =
  [Char]
-> IO ()
-> IO ()
-> (() -> () -> IO (Maybe [Char]))
-> (() -> IO ())
-> TestTree
forall a.
[Char]
-> IO a
-> IO a
-> (a -> a -> IO (Maybe [Char]))
-> (a -> IO ())
-> TestTree
goldenTest
    [Char]
"representative golden test (for option discovery only)"
    (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    (\()
_ ()
_ -> Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing)
    (\()
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

{-| Run the UPLC evaluation tests given an `evaluator` that evaluates UPLC
programs.  By default the tests are run against the textual `.uplc` test-case
files, but passing `--format=flat` on the command line makes them run
against the `flat`-encoded `.flat` files instead (see `Format`). -}
runUplcEvalTests
  :: UplcEvaluator
  -- ^ The action to run the input through for the tests.
  -> (FilePath -> Bool)
  {-^ A function that takes a test name and returns
  whether it should labelled as `ExpectedFailure`. -}
  -> (FilePath -> Bool)
  {-^ A function that takes a test name and returns
  whether it should labelled as `ExpectedBudgetFailure`. -}
  -> IO ()
runUplcEvalTests :: UplcEvaluator -> ([Char] -> Bool) -> ([Char] -> Bool) -> IO ()
runUplcEvalTests UplcEvaluator
eval [Char] -> Bool
expectedFailTests [Char] -> Bool
expectedBudgetFailTests = do
  let params :: CostModelParams
params = Maybe CostModelParams -> CostModelParams
forall a. HasCallStack => Maybe a -> a
fromJust Maybe CostModelParams
defaultCostModelParamsForTesting
      ingredients :: [Ingredient]
ingredients = [OptionDescription] -> Ingredient
includingOptions [Proxy Format -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy Format
forall {k} (t :: k). Proxy t
Proxy :: Proxy Format)] Ingredient -> [Ingredient] -> [Ingredient]
forall a. a -> [a] -> [a]
: [Ingredient]
defaultIngredients
  {- Parse the command-line options (in particular `--format`) up front, since the
  choice of format determines which input files `discoverTests` looks for when
  it builds the test tree. We can't parse against the real test tree (building
  it requires knowing the format first), but we can't parse against an empty
  tree either: tasty only recognises a golden test's own options (`--accept`,
  `--no-create`, etc, contributed by the `Golden` provider's `testOptions`) if a
  test using that provider appears somewhere in the tree being parsed (see
  `treeOptions`). So we parse against a tree containing one representative
  golden test purely so that those options are registered; it's never actually
  run. -}
  OptionSet
opts <- [Ingredient] -> TestTree -> IO OptionSet
parseOptions [Ingredient]
ingredients ([Char] -> [TestTree] -> TestTree
testGroup [Char]
"" [TestTree
representativeGoldenTest])
  let fmt :: Format
fmt = OptionSet -> Format
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts :: Format
  TestTree
tests <-
    Format
-> UplcEvaluator
-> CostModelParams
-> ([Char] -> Bool)
-> ([Char] -> Bool)
-> [Char]
-> IO TestTree
discoverTests
      Format
fmt
      UplcEvaluator
eval
      CostModelParams
params
      [Char] -> Bool
expectedFailTests
      [Char] -> Bool
expectedBudgetFailTests
      [Char]
"test-cases/uplc/evaluation"
  [Ingredient] -> TestTree -> IO ()
defaultMainWithIngredients [Ingredient]
ingredients (TestTree -> IO ()) -> TestTree -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [TestTree] -> TestTree
testGroup [Char]
"UPLC evaluation tests" [TestTree
tests]

-- Flat/UPLC decoding conformance tests

{-| Turn a `Program` using de Bruijn-indexed variables (as decoded from a
`.flat` file) into the `Name`-based representation used elsewhere in this
module, so that it can be compared with a program obtained by parsing a
textual `.uplc` file. -}
unDeBruijnProgram
  :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun ()
  -> Either UPLC.FreeVariableError UplcProg
unDeBruijnProgram :: Program NamedDeBruijn DefaultUni DefaultFun ()
-> Either FreeVariableError UplcProg
unDeBruijnProgram (UPLC.Program ()
ann Version
ver Term NamedDeBruijn DefaultUni DefaultFun ()
t) =
  QuoteT (Either FreeVariableError) UplcProg
-> Either FreeVariableError UplcProg
forall (m :: * -> *) a. Monad m => QuoteT m a -> m a
runQuoteT (() -> Version -> Term Name DefaultUni DefaultFun () -> UplcProg
forall name (uni :: * -> *) fun ann.
ann -> Version -> Term name uni fun ann -> Program name uni fun ann
UPLC.Program ()
ann Version
ver (Term Name DefaultUni DefaultFun () -> UplcProg)
-> QuoteT
     (Either FreeVariableError) (Term Name DefaultUni DefaultFun ())
-> QuoteT (Either FreeVariableError) UplcProg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term NamedDeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (Either FreeVariableError) (Term Name DefaultUni DefaultFun ())
forall (m :: * -> *) (uni :: * -> *) fun ann.
(MonadQuote m, MonadError FreeVariableError m) =>
Term NamedDeBruijn uni fun ann -> m (Term Name uni fun ann)
UPLC.unDeBruijnTerm Term NamedDeBruijn DefaultUni DefaultFun ()
t)

{-| Decode a flat-encoded UPLC program.  We use the `UnrestrictedProgram`
wrapper so that the decoding doesn't reject programs on the grounds of using
builtins or term constructs which are unavailable in the version declared by
the program: we just want to know whether the bytes decode to the same AST as
the textual program that they're supposed to correspond to, not whether
they're a valid on-chain script. -}
decodeFlatProg :: BS.ByteString -> Either String UplcProg
decodeFlatProg :: ByteString -> Either [Char] UplcProg
decodeFlatProg ByteString
bs =
  case Either
  DecodeException
  (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
decoded of
    Left DecodeException
err -> [Char] -> Either [Char] UplcProg
forall a b. a -> Either a b
Left ([Char] -> Either [Char] UplcProg)
-> [Char] -> Either [Char] UplcProg
forall a b. (a -> b) -> a -> b
$ DecodeException -> [Char]
forall a. Show a => a -> [Char]
show DecodeException
err
    Right (UPLC.UnrestrictedProgram Program DeBruijn DefaultUni DefaultFun ()
dbProg) ->
      case Program NamedDeBruijn DefaultUni DefaultFun ()
-> Either FreeVariableError UplcProg
unDeBruijnProgram ((DeBruijn -> NamedDeBruijn)
-> Program DeBruijn DefaultUni DefaultFun ()
-> Program NamedDeBruijn DefaultUni DefaultFun ()
forall name name' (uni :: * -> *) fun ann.
(name -> name')
-> Program name uni fun ann -> Program name' uni fun ann
UPLC.programMapNames DeBruijn -> NamedDeBruijn
fakeNameDeBruijn Program DeBruijn DefaultUni DefaultFun ()
dbProg) of
        Left FreeVariableError
err -> [Char] -> Either [Char] UplcProg
forall a b. a -> Either a b
Left ([Char] -> Either [Char] UplcProg)
-> [Char] -> Either [Char] UplcProg
forall a b. (a -> b) -> a -> b
$ FreeVariableError -> [Char]
forall a. Show a => a -> [Char]
show FreeVariableError
err
        Right UplcProg
prog -> UplcProg -> Either [Char] UplcProg
forall a b. b -> Either a b
Right UplcProg
prog
  where
    decoded
      :: Either
           DecodeException
           (UPLC.UnrestrictedProgram UPLC.DeBruijn DefaultUni DefaultFun ())
    decoded :: Either
  DecodeException
  (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
decoded = ByteString
-> Either
     DecodeException
     (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat ByteString
bs

{-| Encode a `UplcProg` as `flat` bytes: the inverse of `decodeFlatProg`.
Converts the program's names to de Bruijn indices first (that's the
representation `flat` actually encodes), then encodes it via the same
`UnrestrictedProgram` wrapper `decodeFlatProg` uses, for the same reason
(avoiding rejecting programs on the grounds of builtins/term constructs
unavailable in the declared version). Used to write `.flat.expected` golden
files when accepting a `Flat`-format test result. -}
encodeFlatProg :: UplcProg -> BS.ByteString
encodeFlatProg :: UplcProg -> ByteString
encodeFlatProg (UPLC.Program ()
ann Version
ver Term Name DefaultUni DefaultFun ()
t) =
  case Except
  FreeVariableError (Term NamedDeBruijn DefaultUni DefaultFun ())
-> Either
     FreeVariableError (Term NamedDeBruijn DefaultUni DefaultFun ())
forall e a. Except e a -> Either e a
runExcept (Term Name DefaultUni DefaultFun ()
-> Except
     FreeVariableError (Term NamedDeBruijn DefaultUni DefaultFun ())
forall (m :: * -> *) (uni :: * -> *) fun ann.
MonadError FreeVariableError m =>
Term Name uni fun ann -> m (Term NamedDeBruijn uni fun ann)
UPLC.deBruijnTerm Term Name DefaultUni DefaultFun ()
t) of
    -- Programs written to a golden file are always closed (they come from a
    -- successful evaluation), so this should never actually happen.
    Left (FreeVariableError
err :: UPLC.FreeVariableError) -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char]
"encodeFlatProg (deBruijnTerm): " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> FreeVariableError -> [Char]
forall a. Show a => a -> [Char]
show FreeVariableError
err
    Right Term NamedDeBruijn DefaultUni DefaultFun ()
namedDbTerm ->
      UnrestrictedProgram DeBruijn DefaultUni DefaultFun () -> ByteString
forall a. Flat a => a -> ByteString
flat (UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()
 -> ByteString)
-> UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()
-> ByteString
forall a b. (a -> b) -> a -> b
$
        Program DeBruijn DefaultUni DefaultFun ()
-> UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
Program name uni fun ann -> UnrestrictedProgram name uni fun ann
UPLC.UnrestrictedProgram (Program DeBruijn DefaultUni DefaultFun ()
 -> UnrestrictedProgram DeBruijn DefaultUni DefaultFun ())
-> Program DeBruijn DefaultUni DefaultFun ()
-> UnrestrictedProgram DeBruijn DefaultUni DefaultFun ()
forall a b. (a -> b) -> a -> b
$
          (NamedDeBruijn -> DeBruijn)
-> Program NamedDeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
forall name name' (uni :: * -> *) fun ann.
(name -> name')
-> Program name uni fun ann -> Program name' uni fun ann
UPLC.programMapNames NamedDeBruijn -> DeBruijn
UPLC.unNameDeBruijn (()
-> Version
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> Program NamedDeBruijn DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> Version -> Term name uni fun ann -> Program name uni fun ann
UPLC.Program ()
ann Version
ver Term NamedDeBruijn DefaultUni DefaultFun ()
namedDbTerm)