{-# OPTIONS_GHC -Wno-orphans #-}
module Plutarch.Test.QuickCheck (
propEval,
propEvalFail,
propCompileFail,
propEvalEqual,
checkHaskellEquivalent,
checkHaskellEquivalent2,
) where
import Data.Kind (Type)
import Data.Text qualified as Text
import Plutarch.Internal.Term (Config (NoTracing))
import Plutarch.Prelude
import Plutarch.Test.Unit (TermResult (Evaluated, FailedToCompile, FailedToEvaluate), evalTermResult)
import Plutarch.Test.Utils (precompileTerm, prettyEquals, prettyShow)
import Prettyprinter (Pretty)
import Test.QuickCheck qualified as QuickCheck
import Test.Tasty (TestName, TestTree)
import Test.Tasty.QuickCheck (
Arbitrary,
Negative (Negative),
NonNegative (NonNegative),
NonPositive (NonPositive),
NonZero (NonZero),
Property,
arbitrary,
counterexample,
forAllShrinkShow,
property,
shrink,
testProperty,
(===),
)
propEvalFail ::
(Arbitrary a, Show a) =>
TestName ->
(a -> ClosedTerm b) ->
TestTree
propEvalFail :: forall a (b :: PType).
(Arbitrary a, Show a) =>
TestName -> (a -> ClosedTerm b) -> TestTree
propEvalFail TestName
name a -> ClosedTerm b
mkTerm =
TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
name (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ Gen a
-> (a -> [a]) -> (a -> TestName) -> (a -> Property) -> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> TestName) -> (a -> prop) -> Property
forAllShrinkShow Gen a
forall a. Arbitrary a => Gen a
arbitrary a -> [a]
forall a. Arbitrary a => a -> [a]
shrink a -> TestName
forall a. Show a => a -> TestName
show ((a -> Property) -> Property) -> (a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(a
input :: a) ->
case Config -> ClosedTerm b -> TermResult
forall (a :: PType). Config -> ClosedTerm a -> TermResult
evalTermResult Config
NoTracing (a -> ClosedTerm b
mkTerm a
input) of
FailedToCompile Text
err -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Failed to compile: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> Text -> TestName
Text.unpack Text
err) Bool
False
FailedToEvaluate EvalError
_ [Text]
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
Evaluated TestName
script [Text]
_ -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Evaluated, but expected failure: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
script) Bool
False
propCompileFail ::
(Arbitrary a, Show a) =>
TestName ->
(a -> ClosedTerm b) ->
TestTree
propCompileFail :: forall a (b :: PType).
(Arbitrary a, Show a) =>
TestName -> (a -> ClosedTerm b) -> TestTree
propCompileFail TestName
name a -> ClosedTerm b
mkTerm =
TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
name (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ Gen a
-> (a -> [a]) -> (a -> TestName) -> (a -> Property) -> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> TestName) -> (a -> prop) -> Property
forAllShrinkShow Gen a
forall a. Arbitrary a => Gen a
arbitrary a -> [a]
forall a. Arbitrary a => a -> [a]
shrink a -> TestName
forall a. Show a => a -> TestName
show ((a -> Property) -> Property) -> (a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(a
input :: a) ->
case Config -> ClosedTerm b -> TermResult
forall (a :: PType). Config -> ClosedTerm a -> TermResult
evalTermResult Config
NoTracing (a -> ClosedTerm b
mkTerm a
input) of
FailedToCompile Text
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
FailedToEvaluate EvalError
err [Text]
_ -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Failed to evaluate: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> EvalError -> TestName
forall a. Show a => a -> TestName
show EvalError
err) Bool
False
Evaluated TestName
script [Text]
_ -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Evaluated, but expected failure: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
script) Bool
False
propEvalEqual ::
(Arbitrary a, Show a) =>
TestName ->
(a -> ClosedTerm b) ->
(a -> ClosedTerm b) ->
TestTree
propEvalEqual :: forall a (b :: PType).
(Arbitrary a, Show a) =>
TestName -> (a -> ClosedTerm b) -> (a -> ClosedTerm b) -> TestTree
propEvalEqual TestName
name a -> ClosedTerm b
mkTerm a -> ClosedTerm b
mkExpected =
TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
name (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ Gen a
-> (a -> [a]) -> (a -> TestName) -> (a -> Property) -> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> TestName) -> (a -> prop) -> Property
forAllShrinkShow Gen a
forall a. Arbitrary a => Gen a
arbitrary a -> [a]
forall a. Arbitrary a => a -> [a]
shrink a -> TestName
forall a. Show a => a -> TestName
show ((a -> Property) -> Property) -> (a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(a
input :: a) ->
case Config -> ClosedTerm b -> TermResult
forall (a :: PType). Config -> ClosedTerm a -> TermResult
evalTermResult Config
NoTracing (a -> ClosedTerm b
mkTerm a
input) of
FailedToCompile Text
err -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Failed to compile: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> Text -> TestName
Text.unpack Text
err) Bool
False
FailedToEvaluate EvalError
err [Text]
_ -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Failed to evaluate: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> EvalError -> TestName
forall a. Show a => a -> TestName
show EvalError
err) Bool
False
Evaluated TestName
actual [Text]
_ -> case Config -> ClosedTerm b -> TermResult
forall (a :: PType). Config -> ClosedTerm a -> TermResult
evalTermResult Config
NoTracing (a -> ClosedTerm b
mkExpected a
input) of
FailedToCompile Text
err -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Failed to compile expected term: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> Text -> TestName
Text.unpack Text
err) Bool
False
FailedToEvaluate EvalError
err [Text]
_ -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Failed to evaluate expected term: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> EvalError -> TestName
forall a. Show a => a -> TestName
show EvalError
err) Bool
False
Evaluated TestName
expected [Text]
_ -> TestName
actual TestName -> TestName -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TestName
expected
propEval :: (Arbitrary a, Show a) => TestName -> (a -> ClosedTerm b) -> TestTree
propEval :: forall a (b :: PType).
(Arbitrary a, Show a) =>
TestName -> (a -> ClosedTerm b) -> TestTree
propEval TestName
name a -> ClosedTerm b
mkTerm =
TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
name (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ Gen a
-> (a -> [a]) -> (a -> TestName) -> (a -> Property) -> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> TestName) -> (a -> prop) -> Property
forAllShrinkShow Gen a
forall a. Arbitrary a => Gen a
arbitrary a -> [a]
forall a. Arbitrary a => a -> [a]
shrink a -> TestName
forall a. Show a => a -> TestName
show ((a -> Property) -> Property) -> (a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(a
input :: a) ->
case Config -> ClosedTerm b -> TermResult
forall (a :: PType). Config -> ClosedTerm a -> TermResult
evalTermResult Config
NoTracing (a -> ClosedTerm b
mkTerm a
input) of
FailedToCompile Text
err -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Failed to compile: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> Text -> TestName
Text.unpack Text
err) Bool
False
FailedToEvaluate EvalError
err [Text]
_ -> TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (TestName
"Failed to evaluate: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> EvalError -> TestName
forall a. Show a => a -> TestName
show EvalError
err) Bool
False
Evaluated TestName
_ [Text]
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
checkHaskellEquivalent ::
forall (plutarchInput :: S -> Type) (plutarchOutput :: S -> Type).
( PLiftable plutarchInput
, PLiftable plutarchOutput
, Pretty (AsHaskell plutarchInput)
, Arbitrary (AsHaskell plutarchInput)
, Pretty (AsHaskell plutarchOutput)
, Eq (AsHaskell plutarchOutput)
) =>
(AsHaskell plutarchInput -> AsHaskell plutarchOutput) ->
ClosedTerm (plutarchInput :--> plutarchOutput) ->
Property
checkHaskellEquivalent :: forall (plutarchInput :: PType) (plutarchOutput :: PType).
(PLiftable plutarchInput, PLiftable plutarchOutput,
Pretty (AsHaskell plutarchInput),
Arbitrary (AsHaskell plutarchInput),
Pretty (AsHaskell plutarchOutput),
Eq (AsHaskell plutarchOutput)) =>
(AsHaskell plutarchInput -> AsHaskell plutarchOutput)
-> ClosedTerm (plutarchInput :--> plutarchOutput) -> Property
checkHaskellEquivalent AsHaskell plutarchInput -> AsHaskell plutarchOutput
goHaskell ClosedTerm (plutarchInput :--> plutarchOutput)
goPlutarch =
Gen (AsHaskell plutarchInput)
-> (AsHaskell plutarchInput -> [AsHaskell plutarchInput])
-> (AsHaskell plutarchInput -> TestName)
-> (AsHaskell plutarchInput -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> TestName) -> (a -> prop) -> Property
forAllShrinkShow Gen (AsHaskell plutarchInput)
forall a. Arbitrary a => Gen a
arbitrary AsHaskell plutarchInput -> [AsHaskell plutarchInput]
forall a. Arbitrary a => a -> [a]
shrink AsHaskell plutarchInput -> TestName
forall a. Pretty a => a -> TestName
prettyShow ((AsHaskell plutarchInput -> Property) -> Property)
-> (AsHaskell plutarchInput -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
\(AsHaskell plutarchInput
input :: haskellInput) -> AsHaskell plutarchInput -> AsHaskell plutarchOutput
goHaskell AsHaskell plutarchInput
input AsHaskell plutarchOutput -> AsHaskell plutarchOutput -> Property
forall a. (Eq a, Pretty a) => a -> a -> Property
`prettyEquals` (forall (s :: S). Term s plutarchOutput)
-> AsHaskell plutarchOutput
forall (a :: PType).
PLiftable a =>
(forall (s :: S). Term s a) -> AsHaskell a
plift (Term s (plutarchInput :--> plutarchOutput)
ClosedTerm (plutarchInput :--> plutarchOutput)
pfun Term s (plutarchInput :--> plutarchOutput)
-> Term s plutarchInput -> Term s plutarchOutput
forall (s :: S) (a :: PType) (b :: PType).
Term s (a :--> b) -> Term s a -> Term s b
# AsHaskell plutarchInput -> Term s plutarchInput
forall (a :: PType) (s :: S).
PLiftable a =>
AsHaskell a -> Term s a
pconstant AsHaskell plutarchInput
input)
where
pfun :: ClosedTerm (plutarchInput :--> plutarchOutput)
pfun :: ClosedTerm (plutarchInput :--> plutarchOutput)
pfun = ClosedTerm (plutarchInput :--> plutarchOutput)
-> ClosedTerm (plutarchInput :--> plutarchOutput)
forall (p :: PType). ClosedTerm p -> ClosedTerm p
precompileTerm Term s (plutarchInput :--> plutarchOutput)
ClosedTerm (plutarchInput :--> plutarchOutput)
goPlutarch
checkHaskellEquivalent2 ::
forall (plutarchInput1 :: S -> Type) (plutarchInput2 :: S -> Type) (plutarchOutput :: S -> Type).
( PLiftable plutarchInput1
, Pretty (AsHaskell plutarchInput1)
, Arbitrary (AsHaskell plutarchInput1)
, PLiftable plutarchInput2
, Pretty (AsHaskell plutarchInput2)
, Arbitrary (AsHaskell plutarchInput2)
, PLiftable plutarchOutput
, Pretty (AsHaskell plutarchOutput)
, Eq (AsHaskell plutarchOutput)
) =>
(AsHaskell plutarchInput1 -> AsHaskell plutarchInput2 -> AsHaskell plutarchOutput) ->
ClosedTerm (plutarchInput1 :--> plutarchInput2 :--> plutarchOutput) ->
Property
checkHaskellEquivalent2 :: forall (plutarchInput1 :: PType) (plutarchInput2 :: PType)
(plutarchOutput :: PType).
(PLiftable plutarchInput1, Pretty (AsHaskell plutarchInput1),
Arbitrary (AsHaskell plutarchInput1), PLiftable plutarchInput2,
Pretty (AsHaskell plutarchInput2),
Arbitrary (AsHaskell plutarchInput2), PLiftable plutarchOutput,
Pretty (AsHaskell plutarchOutput),
Eq (AsHaskell plutarchOutput)) =>
(AsHaskell plutarchInput1
-> AsHaskell plutarchInput2 -> AsHaskell plutarchOutput)
-> ClosedTerm
(plutarchInput1 :--> (plutarchInput2 :--> plutarchOutput))
-> Property
checkHaskellEquivalent2 AsHaskell plutarchInput1
-> AsHaskell plutarchInput2 -> AsHaskell plutarchOutput
goHaskell ClosedTerm
(plutarchInput1 :--> (plutarchInput2 :--> plutarchOutput))
goPlutarch =
Gen (AsHaskell plutarchInput1, AsHaskell plutarchInput2)
-> ((AsHaskell plutarchInput1, AsHaskell plutarchInput2)
-> [(AsHaskell plutarchInput1, AsHaskell plutarchInput2)])
-> ((AsHaskell plutarchInput1, AsHaskell plutarchInput2)
-> TestName)
-> ((AsHaskell plutarchInput1, AsHaskell plutarchInput2)
-> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [a]) -> (a -> TestName) -> (a -> prop) -> Property
forAllShrinkShow Gen (AsHaskell plutarchInput1, AsHaskell plutarchInput2)
forall a. Arbitrary a => Gen a
arbitrary (AsHaskell plutarchInput1, AsHaskell plutarchInput2)
-> [(AsHaskell plutarchInput1, AsHaskell plutarchInput2)]
forall a. Arbitrary a => a -> [a]
shrink (AsHaskell plutarchInput1, AsHaskell plutarchInput2) -> TestName
forall a. Pretty a => a -> TestName
prettyShow (((AsHaskell plutarchInput1, AsHaskell plutarchInput2) -> Property)
-> Property)
-> ((AsHaskell plutarchInput1, AsHaskell plutarchInput2)
-> Property)
-> Property
forall a b. (a -> b) -> a -> b
$
\(AsHaskell plutarchInput1
input1 :: AsHaskell plutarchInput1, AsHaskell plutarchInput2
input2 :: AsHaskell plutarchInput2) ->
AsHaskell plutarchInput1
-> AsHaskell plutarchInput2 -> AsHaskell plutarchOutput
goHaskell AsHaskell plutarchInput1
input1 AsHaskell plutarchInput2
input2 AsHaskell plutarchOutput -> AsHaskell plutarchOutput -> Property
forall a. (Eq a, Pretty a) => a -> a -> Property
`prettyEquals` (forall (s :: S). Term s plutarchOutput)
-> AsHaskell plutarchOutput
forall (a :: PType).
PLiftable a =>
(forall (s :: S). Term s a) -> AsHaskell a
plift (Term s (plutarchInput1 :--> (plutarchInput2 :--> plutarchOutput))
ClosedTerm
(plutarchInput1 :--> (plutarchInput2 :--> plutarchOutput))
pfun Term s (plutarchInput1 :--> (plutarchInput2 :--> plutarchOutput))
-> Term s plutarchInput1
-> Term s (plutarchInput2 :--> plutarchOutput)
forall (s :: S) (a :: PType) (b :: PType).
Term s (a :--> b) -> Term s a -> Term s b
# AsHaskell plutarchInput1 -> Term s plutarchInput1
forall (a :: PType) (s :: S).
PLiftable a =>
AsHaskell a -> Term s a
pconstant AsHaskell plutarchInput1
input1 Term s (plutarchInput2 :--> plutarchOutput)
-> Term s plutarchInput2 -> Term s plutarchOutput
forall (s :: S) (a :: PType) (b :: PType).
Term s (a :--> b) -> Term s a -> Term s b
# AsHaskell plutarchInput2 -> Term s plutarchInput2
forall (a :: PType) (s :: S).
PLiftable a =>
AsHaskell a -> Term s a
pconstant AsHaskell plutarchInput2
input2)
where
pfun :: ClosedTerm (plutarchInput1 :--> plutarchInput2 :--> plutarchOutput)
pfun :: ClosedTerm
(plutarchInput1 :--> (plutarchInput2 :--> plutarchOutput))
pfun = ClosedTerm
(plutarchInput1 :--> (plutarchInput2 :--> plutarchOutput))
-> ClosedTerm
(plutarchInput1 :--> (plutarchInput2 :--> plutarchOutput))
forall (p :: PType). ClosedTerm p -> ClosedTerm p
precompileTerm Term s (plutarchInput1 :--> (plutarchInput2 :--> plutarchOutput))
ClosedTerm
(plutarchInput1 :--> (plutarchInput2 :--> plutarchOutput))
goPlutarch
deriving newtype instance Pretty a => Pretty (QuickCheck.Positive a)
deriving newtype instance Pretty a => Pretty (Negative a)
deriving newtype instance Pretty a => Pretty (NonZero a)
deriving newtype instance Pretty a => Pretty (NonNegative a)
deriving newtype instance Pretty a => Pretty (NonPositive a)