{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
module PlutusConformance.Common where
import PlutusCore.Annotation
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.Name.Unique (Name)
import PlutusCore.Quote (runQuoteT)
import PlutusPrelude (Pretty (pretty), display, void)
import UntypedPlutusCore qualified as UPLC
import UntypedPlutusCore.Parser qualified as UPLC
import Data.Maybe (fromJust)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import System.Directory
import System.FilePath (takeBaseName, (<.>), (</>))
import Test.Tasty (defaultMain, testGroup)
import Test.Tasty.ExpectedFailure (expectFail)
import Test.Tasty.Extras (goldenVsDocM)
import Test.Tasty.Golden (findByExtension)
import Test.Tasty.Golden.Advanced (goldenTest)
import Test.Tasty.Providers (TestTree)
import Witherable (Witherable (wither))
shownParseError :: T.Text
shownParseError :: Text
shownParseError = Text
"parse error"
shownEvaluationFailure :: T.Text
shownEvaluationFailure :: Text
shownEvaluationFailure = Text
"evaluation failure"
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 e (m :: * -> *).
(AsParserErrorBundle e, MonadError e m, MonadQuote m) =>
Text -> m (Program Name DefaultUni DefaultFun SrcSpan)
UPLC.parseProgram Text
resTxt
type UplcProg = UPLC.Program Name DefaultUni DefaultFun ()
type UplcEvaluatorFun res = UplcProg -> Maybe res
data UplcEvaluator =
UplcEvaluatorWithoutCosting (UplcEvaluatorFun UplcProg)
| UplcEvaluatorWithCosting (CostModelParams -> UplcEvaluatorFun (UplcProg, ExBudget))
discoverTests
:: UplcEvaluator
-> CostModelParams
-> (FilePath -> Bool)
-> (FilePath -> Bool)
-> FilePath
-> IO TestTree
discoverTests :: UplcEvaluator
-> CostModelParams
-> (String -> Bool)
-> (String -> Bool)
-> String
-> IO TestTree
discoverTests UplcEvaluator
eval CostModelParams
modelParams String -> Bool
evaluationFailureExpected String -> Bool
budgetFailureExpected = String -> IO TestTree
go
where
go :: String -> IO TestTree
go String
dir = do
let name :: String
name = String -> String
takeBaseName String
dir
[String]
children <- String -> IO [String]
listDirectory String
dir
[String]
subdirs <- ((String -> IO (Maybe String)) -> [String] -> IO [String])
-> [String] -> (String -> IO (Maybe String)) -> IO [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> IO (Maybe String)) -> [String] -> IO [String]
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 [String]
children ((String -> IO (Maybe String)) -> IO [String])
-> (String -> IO (Maybe String)) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \String
child -> do
let fullPath :: String
fullPath = String
dir String -> String -> String
</> String
child
Bool
isDir <- String -> IO Bool
doesDirectoryExist String
fullPath
Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ if Bool
isDir then String -> Maybe String
forall a. a -> Maybe a
Just String
fullPath else Maybe String
forall a. Maybe a
Nothing
if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
subdirs
then
let tests :: TestTree
tests = case UplcEvaluator
eval of
UplcEvaluatorWithCosting CostModelParams -> UplcEvaluatorFun (UplcProg, ExBudget)
f -> String -> [TestTree] -> TestTree
testGroup String
name
[ String -> String -> UplcEvaluatorFun UplcProg -> TestTree
testForEval String
dir String
name (((UplcProg, ExBudget) -> UplcProg)
-> Maybe (UplcProg, ExBudget) -> Maybe UplcProg
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UplcProg, ExBudget) -> UplcProg
forall a b. (a, b) -> a
fst (Maybe (UplcProg, ExBudget) -> Maybe UplcProg)
-> UplcEvaluatorFun (UplcProg, ExBudget)
-> UplcEvaluatorFun UplcProg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CostModelParams -> UplcEvaluatorFun (UplcProg, ExBudget)
f CostModelParams
modelParams)
, String -> String -> UplcEvaluatorFun ExBudget -> TestTree
testForBudget String
dir String
name (((UplcProg, ExBudget) -> ExBudget)
-> Maybe (UplcProg, ExBudget) -> Maybe ExBudget
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UplcProg, ExBudget) -> ExBudget
forall a b. (a, b) -> b
snd (Maybe (UplcProg, ExBudget) -> Maybe 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 -> String -> String -> UplcEvaluatorFun UplcProg -> TestTree
testForEval String
dir String
name UplcEvaluatorFun UplcProg
f
in TestTree -> IO TestTree
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestTree
tests
else String -> [TestTree] -> TestTree
testGroup String
name ([TestTree] -> TestTree) -> IO [TestTree] -> IO TestTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO TestTree) -> [String] -> 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 String -> IO TestTree
go [String]
subdirs
testForEval :: FilePath -> String -> UplcEvaluatorFun UplcProg -> TestTree
testForEval :: String -> String -> UplcEvaluatorFun UplcProg -> TestTree
testForEval String
dir String
name UplcEvaluatorFun UplcProg
e =
let goldenFilePath :: String
goldenFilePath = String
dir String -> String -> String
</> String
name String -> String -> String
<.> String
"uplc.expected"
test :: TestTree
test = String
-> IO (Either Text UplcProg)
-> IO (Either Text UplcProg)
-> (Either Text UplcProg
-> Either Text UplcProg -> IO (Maybe String))
-> (Either Text UplcProg -> IO ())
-> TestTree
forall a.
String
-> IO a
-> IO a
-> (a -> a -> IO (Maybe String))
-> (a -> IO ())
-> TestTree
goldenTest
(String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (evaluation)")
(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
<$> String -> IO Text
T.readFile String
goldenFilePath)
(UplcEvaluatorFun UplcProg -> String -> IO (Either Text UplcProg)
forall res. UplcEvaluatorFun res -> String -> IO (Either Text res)
getTestedValue UplcEvaluatorFun UplcProg
e String
dir)
(\ Either Text UplcProg
x Either Text UplcProg
y -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ Either Text UplcProg -> Either Text UplcProg -> Maybe String
compareAlphaEq Either Text UplcProg
x Either Text UplcProg
y)
(String -> Either Text UplcProg -> IO ()
updateGoldenFile String
goldenFilePath)
in Bool -> TestTree -> TestTree
possiblyFailingTest (String -> Bool
evaluationFailureExpected String
dir) TestTree
test
testForBudget :: FilePath -> String -> UplcEvaluatorFun ExBudget -> TestTree
testForBudget :: String -> String -> UplcEvaluatorFun ExBudget -> TestTree
testForBudget String
dir String
name UplcEvaluatorFun ExBudget
e =
let goldenFilePath :: String
goldenFilePath = String
dir String -> String -> String
</> String
name String -> String -> String
<.> String
"uplc.budget.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 = String -> String -> IO (Doc Any) -> TestTree
forall ann. String -> String -> IO (Doc ann) -> TestTree
goldenVsDocM
(String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (budget)")
String
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
<$> UplcEvaluatorFun ExBudget -> String -> IO (Either Text ExBudget)
forall res. UplcEvaluatorFun res -> String -> IO (Either Text res)
getTestedValue UplcEvaluatorFun ExBudget
e String
dir)
in Bool -> TestTree -> TestTree
possiblyFailingTest (String -> Bool
budgetFailureExpected String
dir) TestTree
test
possiblyFailingTest :: Bool -> TestTree -> TestTree
possiblyFailingTest :: Bool -> TestTree -> TestTree
possiblyFailingTest Bool
failureExpected TestTree
test =
if Bool
failureExpected
then TestTree -> TestTree
expectFail TestTree
test
else TestTree
test
expectedToProg :: T.Text -> Either T.Text UplcProg
expectedToProg :: Text -> Either Text UplcProg
expectedToProg Text
txt
| 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
| Text
txt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
shownParseError =
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
getTestedValue ::
UplcEvaluatorFun res
-> FilePath
-> IO (Either T.Text res)
getTestedValue :: forall res. UplcEvaluatorFun res -> String -> IO (Either Text res)
getTestedValue UplcEvaluatorFun res
eval String
dir = do
[String]
inputFile <- [String] -> String -> IO [String]
findByExtension [String
".uplc"] String
dir
case [String]
inputFile of
[] -> String -> IO (Either Text res)
forall a. HasCallStack => String -> a
error (String -> IO (Either Text res)) -> String -> IO (Either Text res)
forall a b. (a -> b) -> a -> b
$ String
"Input file missing in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dir
String
_:String
_:[String]
_ -> String -> IO (Either Text res)
forall a. HasCallStack => String -> a
error (String -> IO (Either Text res)) -> String -> IO (Either Text res)
forall a b. (a -> b) -> a -> b
$ String
"More than 1 input files in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dir
[String
file] -> do
Text
input <- String -> IO Text
T.readFile String
file
case Text
-> Either
ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan)
parseTxt Text
input of
Left ParserErrorBundle
_ -> 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
$ Text -> Either Text res
forall a b. a -> Either a b
Left Text
shownParseError
Right Program Name DefaultUni DefaultFun SrcSpan
p -> do
case UplcEvaluatorFun res
eval (Program Name DefaultUni DefaultFun SrcSpan -> UplcProg
forall (f :: * -> *) a. Functor f => f a -> f ()
void Program Name DefaultUni DefaultFun SrcSpan
p) of
Maybe res
Nothing -> 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
$ Text -> Either Text res
forall a b. a -> Either a b
Left Text
shownEvaluationFailure
Just res
prog -> 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
$ res -> Either Text res
forall a b. b -> Either a b
Right res
prog
compareAlphaEq ::
Either T.Text UplcProg
-> Either T.Text UplcProg
-> Maybe String
compareAlphaEq :: Either Text UplcProg -> Either Text UplcProg -> Maybe String
compareAlphaEq (Left Text
expectedTxt) (Left Text
actualTxt) =
if Text
actualTxt Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
expectedTxt
then Maybe String
forall a. Maybe a
Nothing
else String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$
String
"Test failed, the output failed to parse or evaluate: \n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
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 String
forall a. Maybe a
Nothing
else String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$
String
"Test failed, the output was successfully parsed and evaluated, but it isn't as expected. "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"The output program is: \n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UplcProg -> String
forall str a. (Pretty a, Render str) => a -> str
display UplcProg
actual
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n The output program, with the unique names shown is: \n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UplcProg -> String
forall a. Show a => a -> String
show UplcProg
actual
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n But the expected result, with the unique names shown is: \n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UplcProg -> String
forall a. Show a => a -> String
show UplcProg
expected
compareAlphaEq (Right UplcProg
expected) (Left Text
actualTxt) =
String -> Maybe String
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Test failed, the output failed to parse or evaluate: \n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
actualTxt
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n But the expected result, with the unique names shown is: \n"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UplcProg -> String
forall a. Show a => a -> String
show UplcProg
expected
compareAlphaEq (Left Text
txt) (Right UplcProg
actual) =
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 String
forall a. Maybe a
Nothing
else String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$
String
"Test failed, the output was successfully parsed and evaluated, but it isn't as expected. "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"The output program is: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UplcProg -> String
forall str a. (Pretty a, Render str) => a -> str
display UplcProg
actual
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
". But the expected result is: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
txt
updateGoldenFile ::
FilePath
-> Either T.Text UplcProg -> IO ()
updateGoldenFile :: String -> Either Text UplcProg -> IO ()
updateGoldenFile String
goldenPath (Left Text
txt) = String -> Text -> IO ()
T.writeFile String
goldenPath Text
txt
updateGoldenFile String
goldenPath (Right UplcProg
p) = String -> Text -> IO ()
T.writeFile String
goldenPath (UplcProg -> Text
forall str a. (Pretty a, Render str) => a -> str
display UplcProg
p)
runUplcEvalTests ::
UplcEvaluator
-> (FilePath -> Bool)
-> (FilePath -> Bool)
-> IO ()
runUplcEvalTests :: UplcEvaluator -> (String -> Bool) -> (String -> Bool) -> IO ()
runUplcEvalTests UplcEvaluator
eval String -> Bool
expectedFailTests String -> Bool
expectedBudgetFailTests = do
let params :: CostModelParams
params = Maybe CostModelParams -> CostModelParams
forall a. HasCallStack => Maybe a -> a
fromJust Maybe CostModelParams
defaultCostModelParamsForTesting
TestTree
tests <-
UplcEvaluator
-> CostModelParams
-> (String -> Bool)
-> (String -> Bool)
-> String
-> IO TestTree
discoverTests
UplcEvaluator
eval
CostModelParams
params
String -> Bool
expectedFailTests
String -> Bool
expectedBudgetFailTests
String
"test-cases/uplc/evaluation"
TestTree -> IO ()
defaultMain (TestTree -> IO ()) -> TestTree -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [TestTree] -> TestTree
testGroup String
"UPLC evaluation tests" [TestTree
tests]