{-# OPTIONS_GHC -Wno-orphans #-}

module Plutarch.Test.QuickCheck (
  propEval,
  propEvalFail,
  propCompileFail,
  propEvalEqual,
  checkHaskellEquivalent,
  checkHaskellEquivalent2,
) where

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.Tasty (TestName, TestTree)
import Test.Tasty.QuickCheck (
  Arbitrary,
  Negative (Negative),
  NonNegative (NonNegative),
  NonPositive (NonPositive),
  NonZero (NonZero),
  Positive (Positive),
  Property,
  arbitrary,
  counterexample,
  forAllShrinkShow,
  property,
  shrink,
  testProperty,
  (===),
 )

{- | Like `Plutarch.Test.Unit.testEvalFail` but generate terms

@since WIP
-}
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

{- | Like `Plutarch.Test.Unit.testCompileFail` but generate terms

@since WIP
-}
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

{- | Like `Plutarch.Test.Unit.testEvalEqual` but generate terms

@since WIP
-}
propEvalEqual ::
  (Arbitrary a, Show a) =>
  TestName ->
  -- | Actual
  (a -> ClosedTerm b) ->
  -- | Expected
  (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

{- | Like `Plutarch.Test.Unit.testEval` but generate terms

@since WIP
-}
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

-- | @since WIP
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

-- | @since WIP
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

-- * Orphans

-- | @since WIP
deriving newtype instance Pretty a => Pretty (Positive a)

-- | @since WIP
deriving newtype instance Pretty a => Pretty (Negative a)

-- | @since WIP
deriving newtype instance Pretty a => Pretty (NonZero a)

-- | @since WIP
deriving newtype instance Pretty a => Pretty (NonNegative a)

-- | @since WIP
deriving newtype instance Pretty a => Pretty (NonPositive a)