Skip to content
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
The table of contents is too big for display.
Diff view
Diff view
  •  
  •  
  •  
The diff you're trying to view is too large. We only load the first 3000 changed files.
157 changes: 117 additions & 40 deletions plutus-conformance/README.md

Large diffs are not rendered by default.

55 changes: 10 additions & 45 deletions plutus-conformance/agda/Spec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -16,7 +16,8 @@ import MAlonzo.Code.Evaluator.Term
)

import PlutusConformance.Common
( UplcEvaluator (..)
( EvaluationResult (..)
, UplcEvaluator (..)
, runUplcEvalTests
)
import PlutusCore (Error (..))
Expand Down Expand Up @@ -104,25 +105,24 @@ agdaEvalUplcProg WithCosting =
tmUDB = deBruijnTerm tmU
in
case runQuote $ runExceptT $ withExceptT FreeVariableErrorE tmUDB of
-- if there's an exception, evaluation failed, should return `Nothing`.
Left _ -> Nothing
Left _ -> DecodeError
-- evaluate the untyped term with the CEK evaluator
Right tmUDBSuccess ->
case runUCountingAgda (toRawCostModel modelParams) tmUDBSuccess of
Left _ -> Nothing
Left _ -> EvalFailure
Right (tmEvaluated, (cpuCost, memCost)) ->
-- turn it back into a named term
case runQuote $
runExceptT $
withExceptT FreeVariableErrorE $
unDeBruijnTerm tmEvaluated of
Left _ -> Nothing
Left _ -> DecodeError
Right namedTerm ->
let cost =
ExBudget
(ExCPU (fromInteger cpuCost))
(ExMemory (fromInteger memCost))
in Just (UPLC.Program () version namedTerm, cost)
in EvalSuccess (UPLC.Program () version namedTerm, cost)
agdaEvalUplcProg WithoutCosting =
UplcEvaluatorWithoutCosting $ \(UPLC.Program () version tmU) ->
let tmUDB
Expand All @@ -132,17 +132,17 @@ agdaEvalUplcProg WithoutCosting =
(UPLC.Term NamedDeBruijn DefaultUni DefaultFun ())
tmUDB = deBruijnTerm tmU
in case runQuote $ runExceptT $ withExceptT FreeVariableErrorE tmUDB of
Left _ -> Nothing
Left _ -> DecodeError
Right tmUDBSuccess ->
case runUAgda tmUDBSuccess of
Left _ -> Nothing
Left _ -> EvalFailure
Right tmEvaluated ->
case runQuote $
runExceptT $
withExceptT FreeVariableErrorE $
unDeBruijnTerm tmEvaluated of
Left _ -> Nothing
Right namedTerm -> Just $ UPLC.Program () version namedTerm
Left _ -> EvalFailure -- Shouldn't happen unless there's something wrong with the Agda code.

Copy link
Copy Markdown
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

DecodeError?

Right namedTerm -> EvalSuccess $ UPLC.Program () version namedTerm

{-| A list of evaluation tests which are currently expected to fail. Once a fix
for a test is pushed, the test will succeed and should be removed from the
Expand Down Expand Up @@ -180,41 +180,6 @@ failingEvaluationTests =
, "test-cases/uplc/evaluation/term/constant-case/unit/unit-01"
, "test-cases/uplc/evaluation/term/constant-case/unit/unit-02"
, "test-cases/uplc/evaluation/term/constant-case/unit/unit-03"
, -- valueData and unValueData builtins
"test-cases/uplc/evaluation/builtin/semantics/valueData/empty"
, "test-cases/uplc/evaluation/builtin/semantics/valueData/single-entry"
, "test-cases/uplc/evaluation/builtin/semantics/valueData/multi-token"
, "test-cases/uplc/evaluation/builtin/semantics/valueData/multi-currency"
, "test-cases/uplc/evaluation/builtin/semantics/valueData/negative-quantity"
, "test-cases/uplc/evaluation/builtin/semantics/valueData/roundtrip-from-value"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/empty"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/single-entry"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/multi-token"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/multi-currency"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/negative-quantity"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/max-key-len"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/roundtrip-from-data"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-duplicate-tokens"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-duplicate-currencies"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-duplicate-currencies-cancel"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-duplicate-currencies-merge"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-zero-quantity"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-zero-sum"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-empty-tokens"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-unordered-currencies"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-unordered-tokens"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/non-map-integer"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/non-map-constr"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/non-map-list"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/non-map-bytes"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/currency-key-too-long"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/token-key-too-long"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/quantity-overflow"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/quantity-underflow"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/non-bytestring-currency"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/non-bytestring-token"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/non-integer-quantity"
, "test-cases/uplc/evaluation/builtin/semantics/unValueData/non-map-tokens"
]

{-| A list of budget tests which are currently expected to fail. Once a fix for
Expand Down
167 changes: 167 additions & 0 deletions plutus-conformance/consistency/Spec.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,167 @@
{-| Tests checking that `.flat` files decode to the same AST as the
corresponding textual `.uplc` files and that every `.uplc` file has a
corresponding `.flat` file, and vice-versa. This will make sure that
we remember to add both formats when we add a new test. -}
module Main (main) where

import Data.ByteString qualified as BS
import Data.Text.IO qualified as T
import PlutusConformance.Common
import PlutusPrelude (display)
import System.Directory
import System.FilePath
( dropExtension
, takeBaseName
, (<.>)
, (</>)
)
import Test.Tasty (defaultMain, testGroup)
import Test.Tasty.Golden (findByExtension)
import Test.Tasty.HUnit (Assertion, assertFailure, testCase)
import Test.Tasty.Providers (TestTree)
import Witherable (Witherable (wither))

{-| A list of directories which should be skipped because for one reason or another
we don't have flat files or don't currently expect the test to pass. -}
skippedConsistencyTests :: [FilePath]
skippedConsistencyTests =
[ -- The tests in `constant` are supposed to test that the textual parser
-- parses constants correctly. This doesn't really make sense for `flat`
-- files, so we skip them.
"test-cases/uplc/evaluation/builtin/parser"
, "test-cases/uplc/evaluation/term/parser"
, -- We skip this test for the time being. It involves a program with a free
-- variable, and this will not be detected by the parser but will be detected
-- by the flat decoder. It's OK in the main conformance tests because free
-- variables are detected by deBruijnTerm, which we call before executing the
-- textual test cases.
"test-cases/uplc/evaluation/term/var"
]

{-| Check that a `.flat` (or `.flat.expected`) file decodes to the same AST as
the textual UPLC program in the corresponding `.uplc` (or `.uplc.expected`)
file. A `.uplc.expected` file may instead contain one of the special
"failure" markers (see `expectedToProg`); in that case, and only in that case,
we expect the `.flat.expected` file to fail to decode as well (for example
because it's empty). -}
assertFlatMatchesUplc
:: FilePath
-- ^ path to the `.uplc`/`.uplc.expected` file
-> FilePath
-- ^ path to the corresponding `.flat`/`.flat.expected` file
-> Assertion
assertFlatMatchesUplc uplcFile flatFile = do
uplcResult <- expectedToProg <$> T.readFile uplcFile
flatResult <- decodeFlatProg <$> BS.readFile flatFile
case (uplcResult, flatResult) of
(Left _, Left _) -> pure () -- both fail to represent a program: fine
(Right uplcProg, Right flatProg)
| uplcProg == flatProg -> pure ()
| otherwise ->
assertFailure $
"AST mismatch between "
<> flatFile
<> " and "
<> uplcFile
<> ".\nDecoded from "
<> flatFile
<> ":\n"
<> display flatProg
<> "\nParsed from "
<> uplcFile
<> ":\n"
<> display uplcProg
(Left _, Right flatProg) ->
assertFailure $
uplcFile
<> " does not represent a program, but "
<> flatFile
<> " decoded successfully to:\n"
<> display flatProg
(Right uplcProg, Left err) ->
assertFailure $
flatFile
<> " failed to decode ("
<> err
<> "), but "
<> uplcFile
<> " represents the program:\n"
<> display uplcProg

{-| Walk a file tree (expected to be `test-cases/uplc/evaluation`). Any
directory (leaf or non-leaf) listed in `skippedDirs` is skipped entirely,
along with everything below it. For every other test-case directory, this
requires that a `.uplc` file and a `.flat` file exist together or not at
all: if one is present without the other, that's reported as a failing test
(the idea being that this should remind us to add a `.flat` file whenever we
add a new `.uplc` file, and vice versa). If both are present, we check that
the `.flat` file decodes to the same AST as the `.uplc` file, and likewise
for the `.flat.expected`/`.uplc.expected` pair. -}
discoverTestcases
:: [FilePath]
{-^ Paths, relative to the root of plutus-conformance, of directories to
skip entirely (along with any subdirectories), eg
"test-cases/uplc/evaluation/builtin/semantics/addInteger/addInteger-01" or
"test-cases/uplc/evaluation/builtin/constant". -}
-> FilePath
-- ^ The directory to search for tests.
-> IO TestTree
discoverTestcases skippedDirs = go
where
go dir
| dir `elem` skippedDirs = pure $ testGroup (takeBaseName dir) []
| otherwise = do
let name = takeBaseName dir
children <- listDirectory dir
subdirs <- flip wither children $ \child -> do
let fullPath = dir </> child
isDir <- doesDirectoryExist fullPath
pure $ if isDir then Just fullPath else Nothing
if null subdirs
then testGroup name <$> leafTests dir
else testGroup name <$> traverse go subdirs
leafTests dir = do
uplcFiles <- findByExtension [".uplc"] dir
flatFiles <- findByExtension [".flat"] dir
uplcFile <- case uplcFiles of
[] -> pure Nothing
[f] -> pure (Just f)
_ -> error $ "More than one .uplc file in " <> dir
flatFile <- case flatFiles of
[] -> pure Nothing
[f] -> pure (Just f)
_ -> error $ "More than one .flat file in " <> dir
pure $ case (uplcFile, flatFile) of
(Nothing, Nothing) -> [] -- not a uplc/flat test-case directory
(Just u, Just f) ->
[ testCase "flat matches uplc" $ assertFlatMatchesUplc u f
, testCase "flat.expected matches uplc.expected" $
assertFlatMatchesUplc (u <.> "expected") (f <.> "expected")
]
(Just u, Nothing) ->
[ testCase "flat file exists" . assertFailure $
"Missing "
<> dropExtension u <.> "flat"
<> ": every .uplc file must have a corresponding .flat file"
]
(Nothing, Just f) ->
[ testCase "uplc file exists" . assertFailure $
"Missing "
<> dropExtension f <.> "uplc"
<> ": every .flat file must have a corresponding .uplc file"
]

{-| Run the tests that check that every `.uplc` file (outside `skippedDirs`)
has a corresponding `.flat` file (and vice versa), and that `.flat` files
decode to the same AST as their corresponding `.uplc` files. -}
runConsistencyTests
:: [FilePath]
{-^ Paths, relative to the root of plutus-conformance, of test-case
directories to skip entirely. -}
-> IO ()
runConsistencyTests skippedDirs = do
tests <- discoverTestcases skippedDirs "test-cases"
defaultMain $ testGroup "Flat/UPLC decoding tests" [tests]

main :: IO ()
main = runConsistencyTests skippedConsistencyTests
26 changes: 15 additions & 11 deletions plutus-conformance/haskell-steppable/Spec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -30,17 +30,21 @@ failingBudgetTests = []
evalSteppableUplcProg :: UplcEvaluator
evalSteppableUplcProg = UplcEvaluatorWithCosting $
\modelParams (UPLC.Program a v t) -> do
params <- case mkMachineVariantParametersFor [def] modelParams of
Left _ -> Nothing
Right machParamsList -> UPLC.MachineParameters def <$> lookup def machParamsList
-- runCek-like functions (e.g. evaluateCekNoEmit) are partial on term's with
-- free variables, that is why we manually check first for any free vars
case UPLC.deBruijnTerm t of
Left (_ :: UPLC.FreeVariableError) -> Nothing
Right _ -> Just ()
case SCek.runCekNoEmit params counting t of
(Left _, _) -> Nothing
(Right t', CountingSt cost) -> Just (UPLC.Program a v t', cost)
case mkMachineVariantParametersFor [def] modelParams of
Left _ -> BadMachineParameters
Right machParamsList ->
case lookup def machParamsList of
Nothing -> BadMachineParameters
Just p ->
let params = UPLC.MachineParameters def p
in -- runCek-like functions (e.g. evaluateCekNoEmit) are partial on term's with
-- free variables, that is why we manually check first for any free vars
case UPLC.deBruijnTerm t of
Left (_ :: UPLC.FreeVariableError) -> DecodeError -- For consistency with the flat decoder.
Right _ ->
case SCek.runCekNoEmit params counting t of
(Left _, _) -> EvalFailure
(Right prog, CountingSt cost) -> EvalSuccess (UPLC.Program a v prog, cost)

main :: IO ()
main =
Expand Down
39 changes: 25 additions & 14 deletions plutus-conformance/haskell/Spec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,28 +3,39 @@
-- | Conformance tests for the Haskell implementation.
module Main (main) where

import PlutusConformance.Common (UplcEvaluator (..), runUplcEvalTests)
import PlutusConformance.Common
( EvaluationResult (..)
, UplcEvaluator (..)
, runUplcEvalTests
)
import PlutusCore.Evaluation.Machine.MachineParameters qualified as UPLC
import PlutusCore.Evaluation.Machine.MachineParameters.Default
import PlutusPrelude (def)
import UntypedPlutusCore qualified as UPLC
import UntypedPlutusCore.Evaluation.Machine.Cek (CountingSt (..), counting, runCekNoEmit)
import UntypedPlutusCore.Evaluation.Machine.Cek
( CountingSt (..)
, counting
, runCekNoEmit
)

-- | Our `evaluator` for the Haskell UPLC tests is the CEK machine.
evalUplcProg :: UplcEvaluator
evalUplcProg = UplcEvaluatorWithCosting $ \modelParams (UPLC.Program a v t) ->
do
params <- case mkMachineVariantParametersFor [def] modelParams of
Left _ -> Nothing
Right machParamsList -> UPLC.MachineParameters def <$> lookup def machParamsList
-- runCek-like functions (e.g. evaluateCekNoEmit) are partial on term's with
-- free variables, that is why we manually check first for any free vars
case UPLC.deBruijnTerm t of
Left (_ :: UPLC.FreeVariableError) -> Nothing
Right _ -> Just ()
case runCekNoEmit params counting t of
(Left _, _) -> Nothing
(Right prog, CountingSt cost) -> Just (UPLC.Program a v prog, cost)
case mkMachineVariantParametersFor [def] modelParams of
Left _ -> BadMachineParameters
Right machParamsList ->
case lookup def machParamsList of
Nothing -> BadMachineParameters
Just p ->
let params = UPLC.MachineParameters def p
in -- runCek-like functions (e.g. evaluateCekNoEmit) are partial on term's with
-- free variables, that is why we manually check first for any free vars
case UPLC.deBruijnTerm t of
Left (_ :: UPLC.FreeVariableError) -> DecodeError -- For consistency with the flat decoder.
Right _ ->
case runCekNoEmit params counting t of
(Left _, _) -> EvalFailure
(Right prog, CountingSt cost) -> EvalSuccess (UPLC.Program a v prog, cost)

{-| A list of evaluation tests which are currently expected to fail. Once a fix
for a test is pushed, the test will succeed and should be removed from the
Expand Down
24 changes: 24 additions & 0 deletions plutus-conformance/plutus-conformance.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -54,10 +54,14 @@ library
exposed-modules: PlutusConformance.Common
build-depends:
, base
, bytestring
, directory
, filepath
, mtl
, plutus-core ^>=1.66
, plutus-core:flat
, plutus-core:plutus-core-testlib
, tagged
, tasty
, tasty-expected-failure
, tasty-golden
Expand Down Expand Up @@ -108,3 +112,23 @@ test-suite agda-conformance
, plutus-core ^>=1.66
, plutus-metatheory ^>=1.66
, transformers

test-suite conformance-consistency
import: lang, os-support
type: exitcode-stdio-1.0
main-is: Spec.hs
ghc-options: -threaded -rtsopts -with-rtsopts=-N
hs-source-dirs: consistency test-cases
other-modules:
build-depends:
, base >=4.9 && <5
, bytestring
, directory
, filepath
, plutus-conformance
, plutus-core ^>=1.66
, tasty
, tasty-golden
, tasty-hunit
, text
, witherable
Loading
Loading