From 74dcbc8d3091d7e3f12fd54074dbdaf916fce4b1 Mon Sep 17 00:00:00 2001 From: Ziyang Liu Date: Tue, 26 Apr 2022 16:06:08 -0700 Subject: [PATCH 01/10] Test that builtin functions don't throw --- plutus-core/plutus-core.cabal | 1 + .../plutus-core/test/Evaluation/Spec.hs | 244 +++++++++++++++++- 2 files changed, 241 insertions(+), 4 deletions(-) diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 55aa0300c26..76a0cbd6cf7 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -397,6 +397,7 @@ test-suite plutus-core-test base >=4.9 && <5, bytestring -any, containers -any, + extra -any, filepath -any, flat -any, hedgehog -any, diff --git a/plutus-core/plutus-core/test/Evaluation/Spec.hs b/plutus-core/plutus-core/test/Evaluation/Spec.hs index 2a2732365c0..288ac956da9 100644 --- a/plutus-core/plutus-core/test/Evaluation/Spec.hs +++ b/plutus-core/plutus-core/test/Evaluation/Spec.hs @@ -1,11 +1,247 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + module Evaluation.Spec where +import Control.Monad.Except +import Data.ByteString qualified as BS +import Data.Functor ((<&>)) +import Data.Int (Int64) +import Data.List.Extra qualified as List +import Data.Text (Text) +import Data.Type.Equality +import Data.Typeable (splitTyConApp) import Evaluation.Machines (test_machines) - +import Hedgehog hiding (Opaque, Var, eval) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import PlutusCore hiding (Term) +import PlutusCore qualified as PLC +import PlutusCore.Builtin +import PlutusCore.Data (Data (..)) +import PlutusCore.Generators +import Prettyprinter import Test.Tasty +import Test.Tasty.Hedgehog +import Type.Reflection +import Unsafe.Coerce + +type Term = PLC.Term TyName Name DefaultUni DefaultFun () + +test_builtinsDon'tThrow :: TestTree +test_builtinsDon'tThrow = + testGroup + "Builtins don't throw" + . fmap (\fun -> testProperty (show fun) $ prop_builtinsDon'tThrow fun) + $ List.enumerate + -- TODO: remove this + List.\\ [ VerifySignature, + VerifyEcdsaSecp256k1Signature, + VerifySchnorrSecp256k1Signature + ] + +prop_builtinsDon'tThrow :: DefaultFun -> Property +prop_builtinsDon'tThrow bn = property $ do + (args, argStrings) <- unzip <$> forAllNoShow (genArgs bn) + let (res, logs) = runEmitter . runExceptT $ eval args argStrings + case res of + Right _ -> success + Left err -> do + liftIO $ do + putStrLn "Builtin function evaluation failed" + putStrLn $ "Function: " <> show bn + putStrLn $ "Arguments: " <> show argStrings + putStrLn $ + "Error: " + <> ( case err of + KnownTypeEvaluationFailure -> "KnownTypeEvaluationFailure" + KnownTypeUnliftingError e -> + "KnownTypeUnliftingError: " + <> show (pretty e) + ) + putStrLn $ "Execution log: " <> show logs + failure + where + meaning :: BuiltinMeaning Term (CostingPart DefaultUni DefaultFun) + meaning = toBuiltinMeaning bn + + eval :: [Term] -> [String] -> MakeKnownM Term + eval args0 argStrings = case meaning of + BuiltinMeaning _ _ runtime -> go (_broRuntimeScheme runtime) (_broImmediateF runtime) args0 + where + go :: + forall n. + RuntimeScheme n -> + ToRuntimeDenotationType Term n -> + [Term] -> + MakeKnownM Term + go sch f args = case (sch, args) of + (RuntimeSchemeArrow sch', a : as) -> do + res <- liftEither (f a) + go sch' res as + (RuntimeSchemeResult, []) -> f + (RuntimeSchemeAll sch', _) -> go sch' f args + _ -> error $ "Wrong number of args for builtin " <> show bn <> ": " <> show argStrings + +-- | Generate arguments to a builtin function +genArgs :: DefaultFun -> Gen [(Term, String)] +genArgs bn = case bn of + -- These functions are partial, so we manually generate their arguments. + IndexByteString -> do + s <- Gen.utf8 (Range.linear 5 100) Gen.enumBounded + i :: Integer <- fromIntegral <$> Gen.int (Range.linear 0 (BS.length s - 1)) + pure [mkArg s, mkArg i] + HeadList -> pure . pure . mkArg =<< Gen.list (Range.linear 1 100) genInteger + TailList -> genArgs HeadList + UnConstrData -> pure . pure . mkArg =<< genConstr 5 + UnMapData -> pure . pure . mkArg =<< genMap 5 + UnListData -> pure . pure . mkArg =<< genList 5 + UnIData -> pure . pure . mkArg =<< genI + UnBData -> pure . pure . mkArg =<< genB + -- The rest are total functions and we generate the arguments based on their `TypeScheme`s. + _ -> sequenceA $ case meaning of + BuiltinMeaning tySch _ _ -> go tySch + where + go :: forall args res. TypeScheme Term args res -> [Gen (Term, String)] + go = \case + TypeSchemeResult -> [] + TypeSchemeArrow sch -> genArg (typeRep @(Head args)) : go sch + TypeSchemeAll _ sch -> go sch + where + meaning :: BuiltinMeaning Term (CostingPart DefaultUni DefaultFun) + meaning = toBuiltinMeaning bn + +-- | Generate one argument to a builtin function based on its `TypeRep`. +genArg :: forall k (a :: k). TypeRep a -> Gen (Term, String) +genArg tr + | Just HRefl <- eqTypeRep tr (typeRep @()) = pure $ mkArg () + | Just HRefl <- eqTypeRep tr (typeRep @Integer) = pure . mkArg =<< genInteger + | Just HRefl <- eqTypeRep tr (typeRep @Int) = pure . mkArg =<< genInteger + | Just HRefl <- eqTypeRep tr (typeRep @Bool) = pure . mkArg =<< Gen.bool + | Just HRefl <- eqTypeRep tr (typeRep @BS.ByteString) = pure . mkArg =<< genByteString + | Just HRefl <- eqTypeRep tr (typeRep @Text) = pure . mkArg =<< genText + | Just HRefl <- eqTypeRep tr (typeRep @Data) = pure . mkArg =<< genData 5 + | Just [SomeTypeRep tr1, SomeTypeRep tr2] <- matchTyCon @(,) tr = do + (arg1, argStr1) <- genArg tr1 + (arg2, argStr2) <- genArg tr2 + case (arg1, arg2) of + (Constant _ (Some (ValueOf uni1 val1)), Constant _ (Some (ValueOf uni2 val2))) -> + pure + ( Constant + () + ( someValueOf + (DefaultUniApply (DefaultUniApply DefaultUniProtoPair uni1) uni2) + (val1, val2) + ), + show (argStr1, argStr2) + ) + _ -> error "genArg: encountered non-Constant term" + | Just [SomeTypeRep trElem] <- matchTyCon @[] tr = do + (arg, _) <- genArg trElem + case arg of + Constant _ (Some (ValueOf uniElem (_ :: b))) -> do + (args, argStrings) <- unzip <$> (Gen.list (Range.linear 0 10) $ genArg trElem) + let valElems :: [b] + valElems = + args <&> \case + Constant _ (Some (ValueOf _ valElem')) -> unsafeCoerce valElem' + _ -> error "genArg: encountered non-Constant term" + pure + ( Constant () (someValueOf (DefaultUniApply DefaultUniProtoList uniElem) valElems), + show argStrings + ) + _ -> error "genArg: encountered non-Constant term" + -- Descend upon `Opaque` + | Just [_, SomeTypeRep tr'] <- matchTyCon @Opaque tr = genArg tr' + -- Descend upon `SomeConstant` + | Just [_, SomeTypeRep tr'] <- matchTyCon @SomeConstant tr = genArg tr' + -- In the current implementation, all type variables are instantiated + -- to `Integer` (TODO: change this). + | Just _ <- matchTyCon' "PlutusCore.Builtin.Polymorphism" "TyVarRep" tr = + pure . mkArg =<< genInteger + | otherwise = + error $ + "genArg: I don't know how to generate builtin arguments of this type: " <> show tr + +mkArg :: (Contains DefaultUni a, Show a) => a -> (Term, String) +mkArg a = (Constant () (someValue a), show a) + +-- | If the given `TypeRep`'s `TyCon` is @con@, return its type arguments. +matchTyCon :: forall con a. (Typeable con) => TypeRep a -> Maybe [SomeTypeRep] +matchTyCon tr = if con == con' then Just args else Nothing + where + (con, args) = splitTyConApp (SomeTypeRep tr) + con' = typeRepTyCon (typeRep @con) + +-- | If the given `TypeRep`'s `TyCon` matches the given module and name, return its type arguments. +matchTyCon' :: forall a. String -> String -> TypeRep a -> Maybe [SomeTypeRep] +matchTyCon' modu name tr = if modu == modu' && name == name' then Just args else Nothing + where + (con, args) = splitTyConApp (SomeTypeRep tr) + modu' = tyConModule con + name' = tyConName con + +type family Head a where + Head (x ': xs) = x + +---------------------------------------------------------- +-- Generators + +genInteger :: Gen Integer +genInteger = fromIntegral @Int64 <$> Gen.enumBounded + +genByteString :: Gen BS.ByteString +genByteString = Gen.utf8 (Range.linear 0 100) Gen.enumBounded + +genText :: Gen Text +genText = Gen.text (Range.linear 0 100) Gen.enumBounded + +genData :: Int -> Gen Data +genData depth = + Gen.choice $ + [genI, genB] + <> [ genRec | depth > 1, genRec <- + [ genList (depth - 1), + genMap (depth - 1), + genConstr (depth - 1) + ] + ] + +genI :: Gen Data +genI = I <$> genInteger + +genB :: Gen Data +genB = B <$> genByteString + +genList :: Int -> Gen Data +genList depth = List <$> Gen.list (Range.linear 0 5) (genData (depth - 1)) + +genMap :: Int -> Gen Data +genMap depth = + Map + <$> Gen.list + (Range.linear 0 5) + ((,) <$> genData (depth - 1) <*> genData (depth - 1)) + +genConstr :: Int -> Gen Data +genConstr depth = + Constr <$> genInteger + <*> Gen.list + (Range.linear 0 5) + (genData (depth - 1)) test_evaluation :: TestTree test_evaluation = - testGroup "evaluation" - [ test_machines - ] + testGroup + "evaluation" + [ test_machines, + test_builtinsDon'tThrow + ] From e61aafe9252fd83db2bd92c926c9a39ab4ca617d Mon Sep 17 00:00:00 2001 From: Ziyang Liu Date: Wed, 27 Apr 2022 12:44:34 -0700 Subject: [PATCH 02/10] Use four spaces --- .../plutus-core/test/Evaluation/Spec.hs | 262 +++++++++--------- 1 file changed, 131 insertions(+), 131 deletions(-) diff --git a/plutus-core/plutus-core/test/Evaluation/Spec.hs b/plutus-core/plutus-core/test/Evaluation/Spec.hs index 288ac956da9..510103a1d45 100644 --- a/plutus-core/plutus-core/test/Evaluation/Spec.hs +++ b/plutus-core/plutus-core/test/Evaluation/Spec.hs @@ -38,83 +38,83 @@ type Term = PLC.Term TyName Name DefaultUni DefaultFun () test_builtinsDon'tThrow :: TestTree test_builtinsDon'tThrow = - testGroup - "Builtins don't throw" - . fmap (\fun -> testProperty (show fun) $ prop_builtinsDon'tThrow fun) - $ List.enumerate - -- TODO: remove this - List.\\ [ VerifySignature, - VerifyEcdsaSecp256k1Signature, - VerifySchnorrSecp256k1Signature - ] + testGroup + "Builtins don't throw" + . fmap (\fun -> testProperty (show fun) $ prop_builtinsDon'tThrow fun) + $ List.enumerate + -- TODO: remove this + List.\\ [ VerifySignature + , VerifyEcdsaSecp256k1Signature + , VerifySchnorrSecp256k1Signature + ] prop_builtinsDon'tThrow :: DefaultFun -> Property prop_builtinsDon'tThrow bn = property $ do - (args, argStrings) <- unzip <$> forAllNoShow (genArgs bn) - let (res, logs) = runEmitter . runExceptT $ eval args argStrings - case res of - Right _ -> success - Left err -> do - liftIO $ do - putStrLn "Builtin function evaluation failed" - putStrLn $ "Function: " <> show bn - putStrLn $ "Arguments: " <> show argStrings - putStrLn $ - "Error: " - <> ( case err of - KnownTypeEvaluationFailure -> "KnownTypeEvaluationFailure" - KnownTypeUnliftingError e -> - "KnownTypeUnliftingError: " - <> show (pretty e) - ) - putStrLn $ "Execution log: " <> show logs - failure + (args, argStrings) <- unzip <$> forAllNoShow (genArgs bn) + let (res, logs) = runEmitter . runExceptT $ eval args argStrings + case res of + Right _ -> success + Left err -> do + liftIO $ do + putStrLn "Builtin function evaluation failed" + putStrLn $ "Function: " <> show bn + putStrLn $ "Arguments: " <> show argStrings + putStrLn $ + "Error: " + <> ( case err of + KnownTypeEvaluationFailure -> "KnownTypeEvaluationFailure" + KnownTypeUnliftingError e -> + "KnownTypeUnliftingError: " + <> show (pretty e) + ) + putStrLn $ "Execution log: " <> show logs + failure where meaning :: BuiltinMeaning Term (CostingPart DefaultUni DefaultFun) meaning = toBuiltinMeaning bn eval :: [Term] -> [String] -> MakeKnownM Term eval args0 argStrings = case meaning of - BuiltinMeaning _ _ runtime -> go (_broRuntimeScheme runtime) (_broImmediateF runtime) args0 + BuiltinMeaning _ _ runtime -> go (_broRuntimeScheme runtime) (_broImmediateF runtime) args0 where go :: - forall n. - RuntimeScheme n -> - ToRuntimeDenotationType Term n -> - [Term] -> - MakeKnownM Term + forall n. + RuntimeScheme n -> + ToRuntimeDenotationType Term n -> + [Term] -> + MakeKnownM Term go sch f args = case (sch, args) of - (RuntimeSchemeArrow sch', a : as) -> do - res <- liftEither (f a) - go sch' res as - (RuntimeSchemeResult, []) -> f - (RuntimeSchemeAll sch', _) -> go sch' f args - _ -> error $ "Wrong number of args for builtin " <> show bn <> ": " <> show argStrings + (RuntimeSchemeArrow sch', a : as) -> do + res <- liftEither (f a) + go sch' res as + (RuntimeSchemeResult, []) -> f + (RuntimeSchemeAll sch', _) -> go sch' f args + _ -> error $ "Wrong number of args for builtin " <> show bn <> ": " <> show argStrings -- | Generate arguments to a builtin function genArgs :: DefaultFun -> Gen [(Term, String)] genArgs bn = case bn of - -- These functions are partial, so we manually generate their arguments. - IndexByteString -> do - s <- Gen.utf8 (Range.linear 5 100) Gen.enumBounded - i :: Integer <- fromIntegral <$> Gen.int (Range.linear 0 (BS.length s - 1)) - pure [mkArg s, mkArg i] - HeadList -> pure . pure . mkArg =<< Gen.list (Range.linear 1 100) genInteger - TailList -> genArgs HeadList - UnConstrData -> pure . pure . mkArg =<< genConstr 5 - UnMapData -> pure . pure . mkArg =<< genMap 5 - UnListData -> pure . pure . mkArg =<< genList 5 - UnIData -> pure . pure . mkArg =<< genI - UnBData -> pure . pure . mkArg =<< genB - -- The rest are total functions and we generate the arguments based on their `TypeScheme`s. - _ -> sequenceA $ case meaning of - BuiltinMeaning tySch _ _ -> go tySch - where - go :: forall args res. TypeScheme Term args res -> [Gen (Term, String)] - go = \case - TypeSchemeResult -> [] - TypeSchemeArrow sch -> genArg (typeRep @(Head args)) : go sch - TypeSchemeAll _ sch -> go sch + -- These functions are partial, so we manually generate their arguments. + IndexByteString -> do + s <- Gen.utf8 (Range.linear 5 100) Gen.enumBounded + i :: Integer <- fromIntegral <$> Gen.int (Range.linear 0 (BS.length s - 1)) + pure [mkArg s, mkArg i] + HeadList -> pure . pure . mkArg =<< Gen.list (Range.linear 1 100) genInteger + TailList -> genArgs HeadList + UnConstrData -> pure . pure . mkArg =<< genConstr 5 + UnMapData -> pure . pure . mkArg =<< genMap 5 + UnListData -> pure . pure . mkArg =<< genList 5 + UnIData -> pure . pure . mkArg =<< genI + UnBData -> pure . pure . mkArg =<< genB + -- The rest are total functions and we generate the arguments based on their `TypeScheme`s. + _ -> sequenceA $ case meaning of + BuiltinMeaning tySch _ _ -> go tySch + where + go :: forall args res. TypeScheme Term args res -> [Gen (Term, String)] + go = \case + TypeSchemeResult -> [] + TypeSchemeArrow sch -> genArg (typeRep @(Head args)) : go sch + TypeSchemeAll _ sch -> go sch where meaning :: BuiltinMeaning Term (CostingPart DefaultUni DefaultFun) meaning = toBuiltinMeaning bn @@ -122,54 +122,54 @@ genArgs bn = case bn of -- | Generate one argument to a builtin function based on its `TypeRep`. genArg :: forall k (a :: k). TypeRep a -> Gen (Term, String) genArg tr - | Just HRefl <- eqTypeRep tr (typeRep @()) = pure $ mkArg () - | Just HRefl <- eqTypeRep tr (typeRep @Integer) = pure . mkArg =<< genInteger - | Just HRefl <- eqTypeRep tr (typeRep @Int) = pure . mkArg =<< genInteger - | Just HRefl <- eqTypeRep tr (typeRep @Bool) = pure . mkArg =<< Gen.bool - | Just HRefl <- eqTypeRep tr (typeRep @BS.ByteString) = pure . mkArg =<< genByteString - | Just HRefl <- eqTypeRep tr (typeRep @Text) = pure . mkArg =<< genText - | Just HRefl <- eqTypeRep tr (typeRep @Data) = pure . mkArg =<< genData 5 - | Just [SomeTypeRep tr1, SomeTypeRep tr2] <- matchTyCon @(,) tr = do - (arg1, argStr1) <- genArg tr1 - (arg2, argStr2) <- genArg tr2 - case (arg1, arg2) of - (Constant _ (Some (ValueOf uni1 val1)), Constant _ (Some (ValueOf uni2 val2))) -> - pure - ( Constant - () - ( someValueOf - (DefaultUniApply (DefaultUniApply DefaultUniProtoPair uni1) uni2) - (val1, val2) - ), - show (argStr1, argStr2) - ) - _ -> error "genArg: encountered non-Constant term" - | Just [SomeTypeRep trElem] <- matchTyCon @[] tr = do - (arg, _) <- genArg trElem - case arg of - Constant _ (Some (ValueOf uniElem (_ :: b))) -> do - (args, argStrings) <- unzip <$> (Gen.list (Range.linear 0 10) $ genArg trElem) - let valElems :: [b] - valElems = - args <&> \case - Constant _ (Some (ValueOf _ valElem')) -> unsafeCoerce valElem' - _ -> error "genArg: encountered non-Constant term" - pure - ( Constant () (someValueOf (DefaultUniApply DefaultUniProtoList uniElem) valElems), - show argStrings - ) - _ -> error "genArg: encountered non-Constant term" - -- Descend upon `Opaque` - | Just [_, SomeTypeRep tr'] <- matchTyCon @Opaque tr = genArg tr' - -- Descend upon `SomeConstant` - | Just [_, SomeTypeRep tr'] <- matchTyCon @SomeConstant tr = genArg tr' - -- In the current implementation, all type variables are instantiated - -- to `Integer` (TODO: change this). - | Just _ <- matchTyCon' "PlutusCore.Builtin.Polymorphism" "TyVarRep" tr = - pure . mkArg =<< genInteger - | otherwise = - error $ - "genArg: I don't know how to generate builtin arguments of this type: " <> show tr + | Just HRefl <- eqTypeRep tr (typeRep @()) = pure $ mkArg () + | Just HRefl <- eqTypeRep tr (typeRep @Integer) = pure . mkArg =<< genInteger + | Just HRefl <- eqTypeRep tr (typeRep @Int) = pure . mkArg =<< genInteger + | Just HRefl <- eqTypeRep tr (typeRep @Bool) = pure . mkArg =<< Gen.bool + | Just HRefl <- eqTypeRep tr (typeRep @BS.ByteString) = pure . mkArg =<< genByteString + | Just HRefl <- eqTypeRep tr (typeRep @Text) = pure . mkArg =<< genText + | Just HRefl <- eqTypeRep tr (typeRep @Data) = pure . mkArg =<< genData 5 + | Just [SomeTypeRep tr1, SomeTypeRep tr2] <- matchTyCon @(,) tr = do + (arg1, argStr1) <- genArg tr1 + (arg2, argStr2) <- genArg tr2 + case (arg1, arg2) of + (Constant _ (Some (ValueOf uni1 val1)), Constant _ (Some (ValueOf uni2 val2))) -> + pure + ( Constant + () + ( someValueOf + (DefaultUniApply (DefaultUniApply DefaultUniProtoPair uni1) uni2) + (val1, val2) + ) + , show (argStr1, argStr2) + ) + _ -> error "genArg: encountered non-Constant term" + | Just [SomeTypeRep trElem] <- matchTyCon @[] tr = do + (arg, _) <- genArg trElem + case arg of + Constant _ (Some (ValueOf uniElem (_ :: b))) -> do + (args, argStrings) <- unzip <$> (Gen.list (Range.linear 0 10) $ genArg trElem) + let valElems :: [b] + valElems = + args <&> \case + Constant _ (Some (ValueOf _ valElem')) -> unsafeCoerce valElem' + _ -> error "genArg: encountered non-Constant term" + pure + ( Constant () (someValueOf (DefaultUniApply DefaultUniProtoList uniElem) valElems) + , show argStrings + ) + _ -> error "genArg: encountered non-Constant term" + -- Descend upon `Opaque` + | Just [_, SomeTypeRep tr'] <- matchTyCon @Opaque tr = genArg tr' + -- Descend upon `SomeConstant` + | Just [_, SomeTypeRep tr'] <- matchTyCon @SomeConstant tr = genArg tr' + -- In the current implementation, all type variables are instantiated + -- to `Integer` (TODO: change this). + | Just _ <- matchTyCon' "PlutusCore.Builtin.Polymorphism" "TyVarRep" tr = + pure . mkArg =<< genInteger + | otherwise = + error $ + "genArg: I don't know how to generate builtin arguments of this type: " <> show tr mkArg :: (Contains DefaultUni a, Show a) => a -> (Term, String) mkArg a = (Constant () (someValue a), show a) @@ -190,7 +190,7 @@ matchTyCon' modu name tr = if modu == modu' && name == name' then Just args else name' = tyConName con type family Head a where - Head (x ': xs) = x + Head (x ': xs) = x ---------------------------------------------------------- -- Generators @@ -206,14 +206,14 @@ genText = Gen.text (Range.linear 0 100) Gen.enumBounded genData :: Int -> Gen Data genData depth = - Gen.choice $ - [genI, genB] - <> [ genRec | depth > 1, genRec <- - [ genList (depth - 1), - genMap (depth - 1), - genConstr (depth - 1) - ] - ] + Gen.choice $ + [genI, genB] + <> [ genRec | depth > 1, genRec <- + [ genList (depth - 1) + , genMap (depth - 1) + , genConstr (depth - 1) + ] + ] genI :: Gen Data genI = I <$> genInteger @@ -226,22 +226,22 @@ genList depth = List <$> Gen.list (Range.linear 0 5) (genData (depth - 1)) genMap :: Int -> Gen Data genMap depth = - Map - <$> Gen.list - (Range.linear 0 5) - ((,) <$> genData (depth - 1) <*> genData (depth - 1)) + Map + <$> Gen.list + (Range.linear 0 5) + ((,) <$> genData (depth - 1) <*> genData (depth - 1)) genConstr :: Int -> Gen Data genConstr depth = - Constr <$> genInteger - <*> Gen.list - (Range.linear 0 5) - (genData (depth - 1)) + Constr <$> genInteger + <*> Gen.list + (Range.linear 0 5) + (genData (depth - 1)) test_evaluation :: TestTree test_evaluation = - testGroup - "evaluation" - [ test_machines, - test_builtinsDon'tThrow - ] + testGroup + "evaluation" + [ test_machines + , test_builtinsDon'tThrow + ] From 48ee4752f4e67a6524d492f4753d984c3343823c Mon Sep 17 00:00:00 2001 From: Ziyang Liu Date: Wed, 27 Apr 2022 13:08:10 -0700 Subject: [PATCH 03/10] Catch exceptions from evaluation --- .../plutus-core/test/Evaluation/Spec.hs | 79 +++++++------------ 1 file changed, 29 insertions(+), 50 deletions(-) diff --git a/plutus-core/plutus-core/test/Evaluation/Spec.hs b/plutus-core/plutus-core/test/Evaluation/Spec.hs index 510103a1d45..21e184a9669 100644 --- a/plutus-core/plutus-core/test/Evaluation/Spec.hs +++ b/plutus-core/plutus-core/test/Evaluation/Spec.hs @@ -11,9 +11,11 @@ module Evaluation.Spec where +import Control.Exception import Control.Monad.Except +import Control.Monad.Extra import Data.ByteString qualified as BS -import Data.Functor ((<&>)) +import Data.Functor (($>), (<&>)) import Data.Int (Int64) import Data.List.Extra qualified as List import Data.Text (Text) @@ -22,13 +24,13 @@ import Data.Typeable (splitTyConApp) import Evaluation.Machines (test_machines) import Hedgehog hiding (Opaque, Var, eval) import Hedgehog.Gen qualified as Gen +import Hedgehog.Internal.Property (failWith) import Hedgehog.Range qualified as Range import PlutusCore hiding (Term) import PlutusCore qualified as PLC import PlutusCore.Builtin import PlutusCore.Data (Data (..)) import PlutusCore.Generators -import Prettyprinter import Test.Tasty import Test.Tasty.Hedgehog import Type.Reflection @@ -40,35 +42,26 @@ test_builtinsDon'tThrow :: TestTree test_builtinsDon'tThrow = testGroup "Builtins don't throw" - . fmap (\fun -> testProperty (show fun) $ prop_builtinsDon'tThrow fun) - $ List.enumerate - -- TODO: remove this - List.\\ [ VerifySignature - , VerifyEcdsaSecp256k1Signature - , VerifySchnorrSecp256k1Signature - ] + $ fmap (\fun -> testProperty (show fun) $ prop_builtinsDon'tThrow fun) List.enumerate prop_builtinsDon'tThrow :: DefaultFun -> Property prop_builtinsDon'tThrow bn = property $ do (args, argStrings) <- unzip <$> forAllNoShow (genArgs bn) - let (res, logs) = runEmitter . runExceptT $ eval args argStrings - case res of - Right _ -> success - Left err -> do - liftIO $ do - putStrLn "Builtin function evaluation failed" - putStrLn $ "Function: " <> show bn - putStrLn $ "Arguments: " <> show argStrings - putStrLn $ - "Error: " - <> ( case err of - KnownTypeEvaluationFailure -> "KnownTypeEvaluationFailure" - KnownTypeUnliftingError e -> - "KnownTypeUnliftingError: " - <> show (pretty e) - ) - putStrLn $ "Execution log: " <> show logs - failure + mbErr <- + liftIO $ + catch + (($> Nothing) . evaluate . runEmitter . runExceptT $ eval args argStrings) + (pure . pure) + whenJust mbErr $ \(e :: SomeException) -> do + let msg = + "Builtin function evaluation failed" + <> "Function: " + <> show bn + <> "Arguments: " + <> show argStrings + <> "Error: " + <> show e + failWith Nothing msg where meaning :: BuiltinMeaning Term (CostingPart DefaultUni DefaultFun) meaning = toBuiltinMeaning bn @@ -91,30 +84,16 @@ prop_builtinsDon'tThrow bn = property $ do (RuntimeSchemeAll sch', _) -> go sch' f args _ -> error $ "Wrong number of args for builtin " <> show bn <> ": " <> show argStrings --- | Generate arguments to a builtin function +-- | Generate arguments to a builtin function based on its `TypeScheme`. genArgs :: DefaultFun -> Gen [(Term, String)] -genArgs bn = case bn of - -- These functions are partial, so we manually generate their arguments. - IndexByteString -> do - s <- Gen.utf8 (Range.linear 5 100) Gen.enumBounded - i :: Integer <- fromIntegral <$> Gen.int (Range.linear 0 (BS.length s - 1)) - pure [mkArg s, mkArg i] - HeadList -> pure . pure . mkArg =<< Gen.list (Range.linear 1 100) genInteger - TailList -> genArgs HeadList - UnConstrData -> pure . pure . mkArg =<< genConstr 5 - UnMapData -> pure . pure . mkArg =<< genMap 5 - UnListData -> pure . pure . mkArg =<< genList 5 - UnIData -> pure . pure . mkArg =<< genI - UnBData -> pure . pure . mkArg =<< genB - -- The rest are total functions and we generate the arguments based on their `TypeScheme`s. - _ -> sequenceA $ case meaning of - BuiltinMeaning tySch _ _ -> go tySch - where - go :: forall args res. TypeScheme Term args res -> [Gen (Term, String)] - go = \case - TypeSchemeResult -> [] - TypeSchemeArrow sch -> genArg (typeRep @(Head args)) : go sch - TypeSchemeAll _ sch -> go sch +genArgs bn = sequenceA $ case meaning of + BuiltinMeaning tySch _ _ -> go tySch + where + go :: forall args res. TypeScheme Term args res -> [Gen (Term, String)] + go = \case + TypeSchemeResult -> [] + TypeSchemeArrow sch -> genArg (typeRep @(Head args)) : go sch + TypeSchemeAll _ sch -> go sch where meaning :: BuiltinMeaning Term (CostingPart DefaultUni DefaultFun) meaning = toBuiltinMeaning bn From 4f93d04fe2e2eb55b727be7d1ba215273449c2bb Mon Sep 17 00:00:00 2001 From: Ziyang Liu Date: Wed, 27 Apr 2022 15:04:36 -0700 Subject: [PATCH 04/10] Make genArg return Some (ValueOf uni)) --- .../plutus-core/test/Evaluation/Spec.hs | 76 ++++++++----------- 1 file changed, 33 insertions(+), 43 deletions(-) diff --git a/plutus-core/plutus-core/test/Evaluation/Spec.hs b/plutus-core/plutus-core/test/Evaluation/Spec.hs index 21e184a9669..2f4c742d1e2 100644 --- a/plutus-core/plutus-core/test/Evaluation/Spec.hs +++ b/plutus-core/plutus-core/test/Evaluation/Spec.hs @@ -14,9 +14,11 @@ module Evaluation.Spec where import Control.Exception import Control.Monad.Except import Control.Monad.Extra +import Data.Bifunctor import Data.ByteString qualified as BS -import Data.Functor (($>), (<&>)) +import Data.Functor (($>)) import Data.Int (Int64) +import Data.Kind qualified as GHC import Data.List.Extra qualified as List import Data.Text (Text) import Data.Type.Equality @@ -46,7 +48,7 @@ test_builtinsDon'tThrow = prop_builtinsDon'tThrow :: DefaultFun -> Property prop_builtinsDon'tThrow bn = property $ do - (args, argStrings) <- unzip <$> forAllNoShow (genArgs bn) + (args, argStrings) <- first (fmap (Constant ())) . unzip <$> forAllNoShow (genArgs bn) mbErr <- liftIO $ catch @@ -85,11 +87,11 @@ prop_builtinsDon'tThrow bn = property $ do _ -> error $ "Wrong number of args for builtin " <> show bn <> ": " <> show argStrings -- | Generate arguments to a builtin function based on its `TypeScheme`. -genArgs :: DefaultFun -> Gen [(Term, String)] +genArgs :: DefaultFun -> Gen [(Some (ValueOf DefaultUni), String)] genArgs bn = sequenceA $ case meaning of BuiltinMeaning tySch _ _ -> go tySch where - go :: forall args res. TypeScheme Term args res -> [Gen (Term, String)] + go :: forall args res. TypeScheme Term args res -> [Gen (Some (ValueOf DefaultUni), String)] go = \case TypeSchemeResult -> [] TypeSchemeArrow sch -> genArg (typeRep @(Head args)) : go sch @@ -99,59 +101,47 @@ genArgs bn = sequenceA $ case meaning of meaning = toBuiltinMeaning bn -- | Generate one argument to a builtin function based on its `TypeRep`. -genArg :: forall k (a :: k). TypeRep a -> Gen (Term, String) +genArg :: forall k (a :: k). TypeRep a -> Gen (Some (ValueOf DefaultUni), String) genArg tr | Just HRefl <- eqTypeRep tr (typeRep @()) = pure $ mkArg () - | Just HRefl <- eqTypeRep tr (typeRep @Integer) = pure . mkArg =<< genInteger - | Just HRefl <- eqTypeRep tr (typeRep @Int) = pure . mkArg =<< genInteger - | Just HRefl <- eqTypeRep tr (typeRep @Bool) = pure . mkArg =<< Gen.bool - | Just HRefl <- eqTypeRep tr (typeRep @BS.ByteString) = pure . mkArg =<< genByteString - | Just HRefl <- eqTypeRep tr (typeRep @Text) = pure . mkArg =<< genText - | Just HRefl <- eqTypeRep tr (typeRep @Data) = pure . mkArg =<< genData 5 + | Just HRefl <- eqTypeRep tr (typeRep @Integer) = mkArg <$> genInteger + | Just HRefl <- eqTypeRep tr (typeRep @Int) = mkArg <$> genInteger + | Just HRefl <- eqTypeRep tr (typeRep @Bool) = mkArg <$> Gen.bool + | Just HRefl <- eqTypeRep tr (typeRep @BS.ByteString) = mkArg <$> genByteString + | Just HRefl <- eqTypeRep tr (typeRep @Text) = mkArg <$> genText + | Just HRefl <- eqTypeRep tr (typeRep @Data) = mkArg <$> genData 5 | Just [SomeTypeRep tr1, SomeTypeRep tr2] <- matchTyCon @(,) tr = do - (arg1, argStr1) <- genArg tr1 - (arg2, argStr2) <- genArg tr2 - case (arg1, arg2) of - (Constant _ (Some (ValueOf uni1 val1)), Constant _ (Some (ValueOf uni2 val2))) -> - pure - ( Constant - () - ( someValueOf - (DefaultUniApply (DefaultUniApply DefaultUniProtoPair uni1) uni2) - (val1, val2) - ) - , show (argStr1, argStr2) - ) - _ -> error "genArg: encountered non-Constant term" + (Some (ValueOf uni1 val1), argStr1) <- genArg tr1 + (Some (ValueOf uni2 val2), argStr2) <- genArg tr2 + pure + ( someValueOf + (DefaultUniApply (DefaultUniApply DefaultUniProtoPair uni1) uni2) + (val1, val2) + , show (argStr1, argStr2) + ) | Just [SomeTypeRep trElem] <- matchTyCon @[] tr = do - (arg, _) <- genArg trElem - case arg of - Constant _ (Some (ValueOf uniElem (_ :: b))) -> do - (args, argStrings) <- unzip <$> (Gen.list (Range.linear 0 10) $ genArg trElem) - let valElems :: [b] - valElems = - args <&> \case - Constant _ (Some (ValueOf _ valElem')) -> unsafeCoerce valElem' - _ -> error "genArg: encountered non-Constant term" - pure - ( Constant () (someValueOf (DefaultUniApply DefaultUniProtoList uniElem) valElems) - , show argStrings - ) - _ -> error "genArg: encountered non-Constant term" + (Some (ValueOf uniElem (_ :: b)), _) <- genArg trElem + (args, argStrings) <- unzip <$> (Gen.list (Range.linear 0 10) $ genArg trElem) + let valElems :: [b] + valElems = (\(Some (ValueOf _ valElem')) -> unsafeCoerce valElem') <$> args + pure + ( someValueOf (DefaultUniApply DefaultUniProtoList uniElem) valElems + , show argStrings + ) -- Descend upon `Opaque` | Just [_, SomeTypeRep tr'] <- matchTyCon @Opaque tr = genArg tr' -- Descend upon `SomeConstant` | Just [_, SomeTypeRep tr'] <- matchTyCon @SomeConstant tr = genArg tr' -- In the current implementation, all type variables are instantiated -- to `Integer` (TODO: change this). - | Just _ <- matchTyCon' "PlutusCore.Builtin.Polymorphism" "TyVarRep" tr = - pure . mkArg =<< genInteger + | Just _ <- matchTyCon @(TyVarRep @GHC.Type) tr = + mkArg <$> genInteger | otherwise = error $ "genArg: I don't know how to generate builtin arguments of this type: " <> show tr -mkArg :: (Contains DefaultUni a, Show a) => a -> (Term, String) -mkArg a = (Constant () (someValue a), show a) +mkArg :: (Contains DefaultUni a, Show a) => a -> (Some (ValueOf DefaultUni), String) +mkArg a = (someValue a, show a) -- | If the given `TypeRep`'s `TyCon` is @con@, return its type arguments. matchTyCon :: forall con a. (Typeable con) => TypeRep a -> Maybe [SomeTypeRep] From f60a53fc6d7fc7682f1757a0aca056dd760355c7 Mon Sep 17 00:00:00 2001 From: Ziyang Liu Date: Wed, 27 Apr 2022 18:06:43 -0700 Subject: [PATCH 05/10] Add tests using arbitrary (not necessarily well-typed) Terms --- .../plutus-core/test/Evaluation/Spec.hs | 85 ++++++++++--------- 1 file changed, 45 insertions(+), 40 deletions(-) diff --git a/plutus-core/plutus-core/test/Evaluation/Spec.hs b/plutus-core/plutus-core/test/Evaluation/Spec.hs index 2f4c742d1e2..3db2b659829 100644 --- a/plutus-core/plutus-core/test/Evaluation/Spec.hs +++ b/plutus-core/plutus-core/test/Evaluation/Spec.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -14,7 +15,6 @@ module Evaluation.Spec where import Control.Exception import Control.Monad.Except import Control.Monad.Extra -import Data.Bifunctor import Data.ByteString qualified as BS import Data.Functor (($>)) import Data.Int (Int64) @@ -32,7 +32,9 @@ import PlutusCore hiding (Term) import PlutusCore qualified as PLC import PlutusCore.Builtin import PlutusCore.Data (Data (..)) -import PlutusCore.Generators +import PlutusCore.Generators (forAllNoShow) +import PlutusCore.Generators.AST +import PlutusCore.Pretty import Test.Tasty import Test.Tasty.Hedgehog import Type.Reflection @@ -44,23 +46,23 @@ test_builtinsDon'tThrow :: TestTree test_builtinsDon'tThrow = testGroup "Builtins don't throw" - $ fmap (\fun -> testProperty (show fun) $ prop_builtinsDon'tThrow fun) List.enumerate + $ fmap (\fun -> testProperty (display fun) $ prop_builtinsDon'tThrow fun) List.enumerate prop_builtinsDon'tThrow :: DefaultFun -> Property prop_builtinsDon'tThrow bn = property $ do - (args, argStrings) <- first (fmap (Constant ())) . unzip <$> forAllNoShow (genArgs bn) + args <- forAllNoShow . Gen.choice $ [genArgsWellTyped bn, genArgsArbitrary bn] mbErr <- liftIO $ catch - (($> Nothing) . evaluate . runEmitter . runExceptT $ eval args argStrings) + (($> Nothing) . evaluate . runEmitter . runExceptT $ eval args) (pure . pure) whenJust mbErr $ \(e :: SomeException) -> do let msg = "Builtin function evaluation failed" <> "Function: " - <> show bn + <> display bn <> "Arguments: " - <> show argStrings + <> display args <> "Error: " <> show e failWith Nothing msg @@ -68,8 +70,8 @@ prop_builtinsDon'tThrow bn = property $ do meaning :: BuiltinMeaning Term (CostingPart DefaultUni DefaultFun) meaning = toBuiltinMeaning bn - eval :: [Term] -> [String] -> MakeKnownM Term - eval args0 argStrings = case meaning of + eval :: [Term] -> MakeKnownM Term + eval args0 = case meaning of BuiltinMeaning _ _ runtime -> go (_broRuntimeScheme runtime) (_broImmediateF runtime) args0 where go :: @@ -84,14 +86,24 @@ prop_builtinsDon'tThrow bn = property $ do go sch' res as (RuntimeSchemeResult, []) -> f (RuntimeSchemeAll sch', _) -> go sch' f args - _ -> error $ "Wrong number of args for builtin " <> show bn <> ": " <> show argStrings + _ -> error $ "Wrong number of args for builtin " <> display bn <> ": " <> display args0 --- | Generate arguments to a builtin function based on its `TypeScheme`. -genArgs :: DefaultFun -> Gen [(Some (ValueOf DefaultUni), String)] -genArgs bn = sequenceA $ case meaning of +{- | Generate well-typed Term arguments to a builtin function. + TODO: currently it only generates constant terms. +-} +genArgsWellTyped :: DefaultFun -> Gen [Term] +genArgsWellTyped = genArgs (fmap (Constant ()) . genValArg) + +-- | Generate arbitrary (most likely ill-typed) Term arguments to a builtin function. +genArgsArbitrary :: DefaultFun -> Gen [Term] +genArgsArbitrary = genArgs (const (runAstGen genTerm)) + +-- | Generate value arguments to a builtin function based on its `TypeScheme`. +genArgs :: (forall k (a :: k). TypeRep a -> Gen Term) -> DefaultFun -> Gen [Term] +genArgs genArg bn = sequenceA $ case meaning of BuiltinMeaning tySch _ _ -> go tySch where - go :: forall args res. TypeScheme Term args res -> [Gen (Some (ValueOf DefaultUni), String)] + go :: forall args res. TypeScheme Term args res -> [Gen Term] go = \case TypeSchemeResult -> [] TypeSchemeArrow sch -> genArg (typeRep @(Head args)) : go sch @@ -100,48 +112,41 @@ genArgs bn = sequenceA $ case meaning of meaning :: BuiltinMeaning Term (CostingPart DefaultUni DefaultFun) meaning = toBuiltinMeaning bn --- | Generate one argument to a builtin function based on its `TypeRep`. -genArg :: forall k (a :: k). TypeRep a -> Gen (Some (ValueOf DefaultUni), String) -genArg tr - | Just HRefl <- eqTypeRep tr (typeRep @()) = pure $ mkArg () - | Just HRefl <- eqTypeRep tr (typeRep @Integer) = mkArg <$> genInteger - | Just HRefl <- eqTypeRep tr (typeRep @Int) = mkArg <$> genInteger - | Just HRefl <- eqTypeRep tr (typeRep @Bool) = mkArg <$> Gen.bool - | Just HRefl <- eqTypeRep tr (typeRep @BS.ByteString) = mkArg <$> genByteString - | Just HRefl <- eqTypeRep tr (typeRep @Text) = mkArg <$> genText - | Just HRefl <- eqTypeRep tr (typeRep @Data) = mkArg <$> genData 5 +-- | Generate one value argument to a builtin function based on its `TypeRep`. +genValArg :: forall k (a :: k). TypeRep a -> Gen (Some (ValueOf DefaultUni)) +genValArg tr + | Just HRefl <- eqTypeRep tr (typeRep @()) = pure $ someValue () + | Just HRefl <- eqTypeRep tr (typeRep @Integer) = someValue <$> genInteger + | Just HRefl <- eqTypeRep tr (typeRep @Int) = someValue <$> genInteger + | Just HRefl <- eqTypeRep tr (typeRep @Bool) = someValue <$> Gen.bool + | Just HRefl <- eqTypeRep tr (typeRep @BS.ByteString) = someValue <$> genByteString + | Just HRefl <- eqTypeRep tr (typeRep @Text) = someValue <$> genText + | Just HRefl <- eqTypeRep tr (typeRep @Data) = someValue <$> genData 5 | Just [SomeTypeRep tr1, SomeTypeRep tr2] <- matchTyCon @(,) tr = do - (Some (ValueOf uni1 val1), argStr1) <- genArg tr1 - (Some (ValueOf uni2 val2), argStr2) <- genArg tr2 + Some (ValueOf uni1 val1) <- genValArg tr1 + Some (ValueOf uni2 val2) <- genValArg tr2 pure ( someValueOf (DefaultUniApply (DefaultUniApply DefaultUniProtoPair uni1) uni2) (val1, val2) - , show (argStr1, argStr2) ) | Just [SomeTypeRep trElem] <- matchTyCon @[] tr = do - (Some (ValueOf uniElem (_ :: b)), _) <- genArg trElem - (args, argStrings) <- unzip <$> (Gen.list (Range.linear 0 10) $ genArg trElem) + Some (ValueOf uniElem (_ :: b)) <- genValArg trElem + args <- Gen.list (Range.linear 0 10) $ genValArg trElem let valElems :: [b] valElems = (\(Some (ValueOf _ valElem')) -> unsafeCoerce valElem') <$> args - pure - ( someValueOf (DefaultUniApply DefaultUniProtoList uniElem) valElems - , show argStrings - ) + pure (someValueOf (DefaultUniApply DefaultUniProtoList uniElem) valElems) -- Descend upon `Opaque` - | Just [_, SomeTypeRep tr'] <- matchTyCon @Opaque tr = genArg tr' + | Just [_, SomeTypeRep tr'] <- matchTyCon @Opaque tr = genValArg tr' -- Descend upon `SomeConstant` - | Just [_, SomeTypeRep tr'] <- matchTyCon @SomeConstant tr = genArg tr' + | Just [_, SomeTypeRep tr'] <- matchTyCon @SomeConstant tr = genValArg tr' -- In the current implementation, all type variables are instantiated -- to `Integer` (TODO: change this). | Just _ <- matchTyCon @(TyVarRep @GHC.Type) tr = - mkArg <$> genInteger + someValue <$> genInteger | otherwise = error $ - "genArg: I don't know how to generate builtin arguments of this type: " <> show tr - -mkArg :: (Contains DefaultUni a, Show a) => a -> (Some (ValueOf DefaultUni), String) -mkArg a = (someValue a, show a) + "genValArg: I don't know how to generate builtin arguments of this type: " <> show tr -- | If the given `TypeRep`'s `TyCon` is @con@, return its type arguments. matchTyCon :: forall con a. (Typeable con) => TypeRep a -> Maybe [SomeTypeRep] From 2e9ef6b19fcc152589867acf4b3e69c9e6cf37fc Mon Sep 17 00:00:00 2001 From: Ziyang Liu Date: Wed, 27 Apr 2022 18:25:16 -0700 Subject: [PATCH 06/10] Move genValArg to testlib --- plutus-core/plutus-core.cabal | 1 + .../plutus-core/test/Evaluation/Spec.hs | 113 +--------------- plutus-core/testlib/PlutusCore/Generators.hs | 1 + .../PlutusCore/Generators/Internal/Builtin.hs | 122 ++++++++++++++++++ 4 files changed, 128 insertions(+), 109 deletions(-) create mode 100644 plutus-core/testlib/PlutusCore/Generators/Internal/Builtin.hs diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 76a0cbd6cf7..d0b030debf5 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -328,6 +328,7 @@ library plutus-core-testlib Test.Tasty.Extras other-modules: + PlutusCore.Generators.Internal.Builtin PlutusCore.Generators.Internal.Denotation PlutusCore.Generators.Internal.Entity PlutusCore.Generators.Internal.TypeEvalCheck diff --git a/plutus-core/plutus-core/test/Evaluation/Spec.hs b/plutus-core/plutus-core/test/Evaluation/Spec.hs index 3db2b659829..c34e5f4eaa0 100644 --- a/plutus-core/plutus-core/test/Evaluation/Spec.hs +++ b/plutus-core/plutus-core/test/Evaluation/Spec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} @@ -10,35 +9,26 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Evaluation.Spec where +module Evaluation.Spec (test_evaluation) where import Control.Exception import Control.Monad.Except import Control.Monad.Extra -import Data.ByteString qualified as BS import Data.Functor (($>)) -import Data.Int (Int64) -import Data.Kind qualified as GHC import Data.List.Extra qualified as List -import Data.Text (Text) -import Data.Type.Equality -import Data.Typeable (splitTyConApp) import Evaluation.Machines (test_machines) import Hedgehog hiding (Opaque, Var, eval) import Hedgehog.Gen qualified as Gen import Hedgehog.Internal.Property (failWith) -import Hedgehog.Range qualified as Range import PlutusCore hiding (Term) import PlutusCore qualified as PLC import PlutusCore.Builtin -import PlutusCore.Data (Data (..)) -import PlutusCore.Generators (forAllNoShow) +import PlutusCore.Generators (forAllNoShow, genValArg) import PlutusCore.Generators.AST import PlutusCore.Pretty import Test.Tasty import Test.Tasty.Hedgehog import Type.Reflection -import Unsafe.Coerce type Term = PLC.Term TyName Name DefaultUni DefaultFun () @@ -86,6 +76,8 @@ prop_builtinsDon'tThrow bn = property $ do go sch' res as (RuntimeSchemeResult, []) -> f (RuntimeSchemeAll sch', _) -> go sch' f args + -- TODO: can we make this function run in GenT MakeKnownM and generate arguments + -- on the fly to avoid this error case? _ -> error $ "Wrong number of args for builtin " <> display bn <> ": " <> display args0 {- | Generate well-typed Term arguments to a builtin function. @@ -112,106 +104,9 @@ genArgs genArg bn = sequenceA $ case meaning of meaning :: BuiltinMeaning Term (CostingPart DefaultUni DefaultFun) meaning = toBuiltinMeaning bn --- | Generate one value argument to a builtin function based on its `TypeRep`. -genValArg :: forall k (a :: k). TypeRep a -> Gen (Some (ValueOf DefaultUni)) -genValArg tr - | Just HRefl <- eqTypeRep tr (typeRep @()) = pure $ someValue () - | Just HRefl <- eqTypeRep tr (typeRep @Integer) = someValue <$> genInteger - | Just HRefl <- eqTypeRep tr (typeRep @Int) = someValue <$> genInteger - | Just HRefl <- eqTypeRep tr (typeRep @Bool) = someValue <$> Gen.bool - | Just HRefl <- eqTypeRep tr (typeRep @BS.ByteString) = someValue <$> genByteString - | Just HRefl <- eqTypeRep tr (typeRep @Text) = someValue <$> genText - | Just HRefl <- eqTypeRep tr (typeRep @Data) = someValue <$> genData 5 - | Just [SomeTypeRep tr1, SomeTypeRep tr2] <- matchTyCon @(,) tr = do - Some (ValueOf uni1 val1) <- genValArg tr1 - Some (ValueOf uni2 val2) <- genValArg tr2 - pure - ( someValueOf - (DefaultUniApply (DefaultUniApply DefaultUniProtoPair uni1) uni2) - (val1, val2) - ) - | Just [SomeTypeRep trElem] <- matchTyCon @[] tr = do - Some (ValueOf uniElem (_ :: b)) <- genValArg trElem - args <- Gen.list (Range.linear 0 10) $ genValArg trElem - let valElems :: [b] - valElems = (\(Some (ValueOf _ valElem')) -> unsafeCoerce valElem') <$> args - pure (someValueOf (DefaultUniApply DefaultUniProtoList uniElem) valElems) - -- Descend upon `Opaque` - | Just [_, SomeTypeRep tr'] <- matchTyCon @Opaque tr = genValArg tr' - -- Descend upon `SomeConstant` - | Just [_, SomeTypeRep tr'] <- matchTyCon @SomeConstant tr = genValArg tr' - -- In the current implementation, all type variables are instantiated - -- to `Integer` (TODO: change this). - | Just _ <- matchTyCon @(TyVarRep @GHC.Type) tr = - someValue <$> genInteger - | otherwise = - error $ - "genValArg: I don't know how to generate builtin arguments of this type: " <> show tr - --- | If the given `TypeRep`'s `TyCon` is @con@, return its type arguments. -matchTyCon :: forall con a. (Typeable con) => TypeRep a -> Maybe [SomeTypeRep] -matchTyCon tr = if con == con' then Just args else Nothing - where - (con, args) = splitTyConApp (SomeTypeRep tr) - con' = typeRepTyCon (typeRep @con) - --- | If the given `TypeRep`'s `TyCon` matches the given module and name, return its type arguments. -matchTyCon' :: forall a. String -> String -> TypeRep a -> Maybe [SomeTypeRep] -matchTyCon' modu name tr = if modu == modu' && name == name' then Just args else Nothing - where - (con, args) = splitTyConApp (SomeTypeRep tr) - modu' = tyConModule con - name' = tyConName con - type family Head a where Head (x ': xs) = x ----------------------------------------------------------- --- Generators - -genInteger :: Gen Integer -genInteger = fromIntegral @Int64 <$> Gen.enumBounded - -genByteString :: Gen BS.ByteString -genByteString = Gen.utf8 (Range.linear 0 100) Gen.enumBounded - -genText :: Gen Text -genText = Gen.text (Range.linear 0 100) Gen.enumBounded - -genData :: Int -> Gen Data -genData depth = - Gen.choice $ - [genI, genB] - <> [ genRec | depth > 1, genRec <- - [ genList (depth - 1) - , genMap (depth - 1) - , genConstr (depth - 1) - ] - ] - -genI :: Gen Data -genI = I <$> genInteger - -genB :: Gen Data -genB = B <$> genByteString - -genList :: Int -> Gen Data -genList depth = List <$> Gen.list (Range.linear 0 5) (genData (depth - 1)) - -genMap :: Int -> Gen Data -genMap depth = - Map - <$> Gen.list - (Range.linear 0 5) - ((,) <$> genData (depth - 1) <*> genData (depth - 1)) - -genConstr :: Int -> Gen Data -genConstr depth = - Constr <$> genInteger - <*> Gen.list - (Range.linear 0 5) - (genData (depth - 1)) - test_evaluation :: TestTree test_evaluation = testGroup diff --git a/plutus-core/testlib/PlutusCore/Generators.hs b/plutus-core/testlib/PlutusCore/Generators.hs index f80ee4e6c91..db63d95fc92 100644 --- a/plutus-core/testlib/PlutusCore/Generators.hs +++ b/plutus-core/testlib/PlutusCore/Generators.hs @@ -4,6 +4,7 @@ module PlutusCore.Generators ( module Export ) where +import PlutusCore.Generators.Internal.Builtin as Export import PlutusCore.Generators.Internal.Denotation as Export import PlutusCore.Generators.Internal.Entity as Export import PlutusCore.Generators.Internal.TypeEvalCheck as Export diff --git a/plutus-core/testlib/PlutusCore/Generators/Internal/Builtin.hs b/plutus-core/testlib/PlutusCore/Generators/Internal/Builtin.hs new file mode 100644 index 00000000000..7120001e8d1 --- /dev/null +++ b/plutus-core/testlib/PlutusCore/Generators/Internal/Builtin.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} + +module PlutusCore.Generators.Internal.Builtin ( + genValArg, + genInteger, + genByteString, + genText, + genData, + genI, + genB, + genList, + genMap, + genConstr, + matchTyCon, +) where + +import Data.ByteString qualified as BS +import Data.Int (Int64) +import Data.Kind qualified as GHC +import Data.Text (Text) +import Data.Type.Equality +import Data.Typeable (splitTyConApp) +import Hedgehog hiding (Opaque, Var, eval) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import PlutusCore hiding (Term) +import PlutusCore.Builtin +import PlutusCore.Data (Data (..)) +import Type.Reflection +import Unsafe.Coerce + +-- | Generate one value argument to a builtin function based on its `TypeRep`. +genValArg :: forall k (a :: k). TypeRep a -> Gen (Some (ValueOf DefaultUni)) +genValArg tr + | Just HRefl <- eqTypeRep tr (typeRep @()) = pure $ someValue () + | Just HRefl <- eqTypeRep tr (typeRep @Integer) = someValue <$> genInteger + | Just HRefl <- eqTypeRep tr (typeRep @Int) = someValue <$> genInteger + | Just HRefl <- eqTypeRep tr (typeRep @Bool) = someValue <$> Gen.bool + | Just HRefl <- eqTypeRep tr (typeRep @BS.ByteString) = someValue <$> genByteString + | Just HRefl <- eqTypeRep tr (typeRep @Text) = someValue <$> genText + | Just HRefl <- eqTypeRep tr (typeRep @Data) = someValue <$> genData 5 + | Just [SomeTypeRep tr1, SomeTypeRep tr2] <- matchTyCon @(,) tr = do + Some (ValueOf uni1 val1) <- genValArg tr1 + Some (ValueOf uni2 val2) <- genValArg tr2 + pure + ( someValueOf + (DefaultUniApply (DefaultUniApply DefaultUniProtoPair uni1) uni2) + (val1, val2) + ) + | Just [SomeTypeRep trElem] <- matchTyCon @[] tr = do + Some (ValueOf uniElem (_ :: b)) <- genValArg trElem + args <- Gen.list (Range.linear 0 10) $ genValArg trElem + let valElems :: [b] + valElems = (\(Some (ValueOf _ valElem')) -> unsafeCoerce valElem') <$> args + pure (someValueOf (DefaultUniApply DefaultUniProtoList uniElem) valElems) + -- Descend upon `Opaque` + | Just [_, SomeTypeRep tr'] <- matchTyCon @Opaque tr = genValArg tr' + -- Descend upon `SomeConstant` + | Just [_, SomeTypeRep tr'] <- matchTyCon @SomeConstant tr = genValArg tr' + -- In the current implementation, all type variables are instantiated + -- to `Integer` (TODO: change this). + | Just _ <- matchTyCon @(TyVarRep @GHC.Type) tr = + someValue <$> genInteger + | otherwise = + error $ + "genValArg: I don't know how to generate builtin arguments of this type: " <> show tr + +-- | If the given `TypeRep`'s `TyCon` is @con@, return its type arguments. +matchTyCon :: forall con a. (Typeable con) => TypeRep a -> Maybe [SomeTypeRep] +matchTyCon tr = if con == con' then Just args else Nothing + where + (con, args) = splitTyConApp (SomeTypeRep tr) + con' = typeRepTyCon (typeRep @con) + +---------------------------------------------------------- +-- Generators + +genInteger :: Gen Integer +genInteger = fromIntegral @Int64 <$> Gen.enumBounded + +genByteString :: Gen BS.ByteString +genByteString = Gen.utf8 (Range.linear 0 100) Gen.enumBounded + +genText :: Gen Text +genText = Gen.text (Range.linear 0 100) Gen.enumBounded + +genData :: Int -> Gen Data +genData depth = + Gen.choice $ + [genI, genB] + <> [ genRec | depth > 1, genRec <- + [ genList (depth - 1) + , genMap (depth - 1) + , genConstr (depth - 1) + ] + ] + +genI :: Gen Data +genI = I <$> genInteger + +genB :: Gen Data +genB = B <$> genByteString + +genList :: Int -> Gen Data +genList depth = List <$> Gen.list (Range.linear 0 5) (genData (depth - 1)) + +genMap :: Int -> Gen Data +genMap depth = + Map + <$> Gen.list + (Range.linear 0 5) + ((,) <$> genData (depth - 1) <*> genData (depth - 1)) + +genConstr :: Int -> Gen Data +genConstr depth = + Constr <$> genInteger + <*> Gen.list + (Range.linear 0 5) + (genData (depth - 1)) From 602fddedb8fb710103be7bed7eb7d4c9db7360c6 Mon Sep 17 00:00:00 2001 From: Ziyang Liu Date: Wed, 27 Apr 2022 18:31:46 -0700 Subject: [PATCH 07/10] Reorganize imports --- plutus-core/plutus-core/test/Evaluation/Spec.hs | 13 +++++++------ .../PlutusCore/Generators/Internal/Builtin.hs | 7 ++++--- 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/plutus-core/plutus-core/test/Evaluation/Spec.hs b/plutus-core/plutus-core/test/Evaluation/Spec.hs index c34e5f4eaa0..d3fd86e6216 100644 --- a/plutus-core/plutus-core/test/Evaluation/Spec.hs +++ b/plutus-core/plutus-core/test/Evaluation/Spec.hs @@ -11,6 +11,13 @@ module Evaluation.Spec (test_evaluation) where +import PlutusCore hiding (Term) +import PlutusCore qualified as PLC +import PlutusCore.Builtin +import PlutusCore.Generators (forAllNoShow, genValArg) +import PlutusCore.Generators.AST +import PlutusCore.Pretty + import Control.Exception import Control.Monad.Except import Control.Monad.Extra @@ -20,12 +27,6 @@ import Evaluation.Machines (test_machines) import Hedgehog hiding (Opaque, Var, eval) import Hedgehog.Gen qualified as Gen import Hedgehog.Internal.Property (failWith) -import PlutusCore hiding (Term) -import PlutusCore qualified as PLC -import PlutusCore.Builtin -import PlutusCore.Generators (forAllNoShow, genValArg) -import PlutusCore.Generators.AST -import PlutusCore.Pretty import Test.Tasty import Test.Tasty.Hedgehog import Type.Reflection diff --git a/plutus-core/testlib/PlutusCore/Generators/Internal/Builtin.hs b/plutus-core/testlib/PlutusCore/Generators/Internal/Builtin.hs index 7120001e8d1..f35e20e24dc 100644 --- a/plutus-core/testlib/PlutusCore/Generators/Internal/Builtin.hs +++ b/plutus-core/testlib/PlutusCore/Generators/Internal/Builtin.hs @@ -17,6 +17,10 @@ module PlutusCore.Generators.Internal.Builtin ( matchTyCon, ) where +import PlutusCore hiding (Term) +import PlutusCore.Builtin +import PlutusCore.Data (Data (..)) + import Data.ByteString qualified as BS import Data.Int (Int64) import Data.Kind qualified as GHC @@ -26,9 +30,6 @@ import Data.Typeable (splitTyConApp) import Hedgehog hiding (Opaque, Var, eval) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import PlutusCore hiding (Term) -import PlutusCore.Builtin -import PlutusCore.Data (Data (..)) import Type.Reflection import Unsafe.Coerce From 765e6651bf0b48f0cb989efc1589afa73b612c21 Mon Sep 17 00:00:00 2001 From: Ziyang Liu Date: Fri, 29 Apr 2022 10:49:54 -0700 Subject: [PATCH 08/10] Replace genValArg with genConstant The idea is due to @effectfully (be2efd3) --- .../plutus-core/test/Evaluation/Spec.hs | 17 +++-- .../PlutusCore/Generators/Internal/Builtin.hs | 67 +++++++++---------- 2 files changed, 43 insertions(+), 41 deletions(-) diff --git a/plutus-core/plutus-core/test/Evaluation/Spec.hs b/plutus-core/plutus-core/test/Evaluation/Spec.hs index d3fd86e6216..2e2048fd4d1 100644 --- a/plutus-core/plutus-core/test/Evaluation/Spec.hs +++ b/plutus-core/plutus-core/test/Evaluation/Spec.hs @@ -14,14 +14,15 @@ module Evaluation.Spec (test_evaluation) where import PlutusCore hiding (Term) import PlutusCore qualified as PLC import PlutusCore.Builtin -import PlutusCore.Generators (forAllNoShow, genValArg) -import PlutusCore.Generators.AST +import PlutusCore.Generators (forAllNoShow, genConstant) +import PlutusCore.Generators.AST hiding (genConstant) import PlutusCore.Pretty import Control.Exception import Control.Monad.Except import Control.Monad.Extra import Data.Functor (($>)) +import Data.Kind qualified as GHC import Data.List.Extra qualified as List import Evaluation.Machines (test_machines) import Hedgehog hiding (Opaque, Var, eval) @@ -85,14 +86,22 @@ prop_builtinsDon'tThrow bn = property $ do TODO: currently it only generates constant terms. -} genArgsWellTyped :: DefaultFun -> Gen [Term] -genArgsWellTyped = genArgs (fmap (Constant ()) . genValArg) +genArgsWellTyped = genArgs (fmap mkTerm . genConstant) + where + mkTerm :: forall (a :: GHC.Type). MakeKnown Term a => a -> Term + mkTerm a = case runEmitter . runExceptT $ makeKnown a of + (Right term, _) -> term + _ -> error "genArgsWellTyped: got error from makeKnown" -- | Generate arbitrary (most likely ill-typed) Term arguments to a builtin function. genArgsArbitrary :: DefaultFun -> Gen [Term] genArgsArbitrary = genArgs (const (runAstGen genTerm)) -- | Generate value arguments to a builtin function based on its `TypeScheme`. -genArgs :: (forall k (a :: k). TypeRep a -> Gen Term) -> DefaultFun -> Gen [Term] +genArgs :: + (forall (a :: GHC.Type). MakeKnown Term a => TypeRep a -> Gen Term) -> + DefaultFun -> + Gen [Term] genArgs genArg bn = sequenceA $ case meaning of BuiltinMeaning tySch _ _ -> go tySch where diff --git a/plutus-core/testlib/PlutusCore/Generators/Internal/Builtin.hs b/plutus-core/testlib/PlutusCore/Generators/Internal/Builtin.hs index f35e20e24dc..653095bb9c9 100644 --- a/plutus-core/testlib/PlutusCore/Generators/Internal/Builtin.hs +++ b/plutus-core/testlib/PlutusCore/Generators/Internal/Builtin.hs @@ -4,7 +4,7 @@ {-# LANGUAGE TypeApplications #-} module PlutusCore.Generators.Internal.Builtin ( - genValArg, + genConstant, genInteger, genByteString, genText, @@ -17,13 +17,13 @@ module PlutusCore.Generators.Internal.Builtin ( matchTyCon, ) where -import PlutusCore hiding (Term) +import PlutusCore import PlutusCore.Builtin import PlutusCore.Data (Data (..)) +import PlutusCore.Generators.AST (genTerm, runAstGen) import Data.ByteString qualified as BS import Data.Int (Int64) -import Data.Kind qualified as GHC import Data.Text (Text) import Data.Type.Equality import Data.Typeable (splitTyConApp) @@ -31,43 +31,36 @@ import Hedgehog hiding (Opaque, Var, eval) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Type.Reflection -import Unsafe.Coerce --- | Generate one value argument to a builtin function based on its `TypeRep`. -genValArg :: forall k (a :: k). TypeRep a -> Gen (Some (ValueOf DefaultUni)) -genValArg tr - | Just HRefl <- eqTypeRep tr (typeRep @()) = pure $ someValue () - | Just HRefl <- eqTypeRep tr (typeRep @Integer) = someValue <$> genInteger - | Just HRefl <- eqTypeRep tr (typeRep @Int) = someValue <$> genInteger - | Just HRefl <- eqTypeRep tr (typeRep @Bool) = someValue <$> Gen.bool - | Just HRefl <- eqTypeRep tr (typeRep @BS.ByteString) = someValue <$> genByteString - | Just HRefl <- eqTypeRep tr (typeRep @Text) = someValue <$> genText - | Just HRefl <- eqTypeRep tr (typeRep @Data) = someValue <$> genData 5 - | Just [SomeTypeRep tr1, SomeTypeRep tr2] <- matchTyCon @(,) tr = do - Some (ValueOf uni1 val1) <- genValArg tr1 - Some (ValueOf uni2 val2) <- genValArg tr2 - pure - ( someValueOf - (DefaultUniApply (DefaultUniApply DefaultUniProtoPair uni1) uni2) - (val1, val2) - ) - | Just [SomeTypeRep trElem] <- matchTyCon @[] tr = do - Some (ValueOf uniElem (_ :: b)) <- genValArg trElem - args <- Gen.list (Range.linear 0 10) $ genValArg trElem - let valElems :: [b] - valElems = (\(Some (ValueOf _ valElem')) -> unsafeCoerce valElem') <$> args - pure (someValueOf (DefaultUniApply DefaultUniProtoList uniElem) valElems) - -- Descend upon `Opaque` - | Just [_, SomeTypeRep tr'] <- matchTyCon @Opaque tr = genValArg tr' - -- Descend upon `SomeConstant` - | Just [_, SomeTypeRep tr'] <- matchTyCon @SomeConstant tr = genValArg tr' - -- In the current implementation, all type variables are instantiated - -- to `Integer` (TODO: change this). - | Just _ <- matchTyCon @(TyVarRep @GHC.Type) tr = - someValue <$> genInteger +genConstant :: forall a. TypeRep a -> Gen a +genConstant tr + | Just HRefl <- eqTypeRep tr (typeRep @()) = pure () + | Just HRefl <- eqTypeRep tr (typeRep @Integer) = genInteger + | Just HRefl <- eqTypeRep tr (typeRep @Int) = fromIntegral <$> genInteger + | Just HRefl <- eqTypeRep tr (typeRep @Bool) = Gen.bool + | Just HRefl <- eqTypeRep tr (typeRep @BS.ByteString) = genByteString + | Just HRefl <- eqTypeRep tr (typeRep @Text) = genText + | Just HRefl <- eqTypeRep tr (typeRep @Data) = genData 5 + | Just HRefl <- eqTypeRep tr (typeRep @(Term TyName Name DefaultUni DefaultFun ())) = + runAstGen genTerm + | trPair `App` tr1 `App` tr2 <- tr + , Just HRefl <- eqTypeRep trPair (typeRep @(,)) = + (,) <$> genConstant tr1 <*> genConstant tr2 + | trList `App` trElem <- tr + , Just HRefl <- eqTypeRep trList (typeRep @[]) = + Gen.list (Range.linear 0 10) $ genConstant trElem + | trOpaque `App` trVal `App` _ <- tr + , Just HRefl <- eqTypeRep trOpaque (typeRep @Opaque) = + Opaque <$> genConstant trVal + | trSomeConstant `App` trUni `App` _ <- tr + , Just HRefl <- eqTypeRep trUni (typeRep @DefaultUni) + , Just HRefl <- eqTypeRep trSomeConstant (typeRep @SomeConstant) = + -- In the current implementation, all type variables are instantiated + -- to `Integer` (TODO: change this). + SomeConstant . someValue <$> genInteger | otherwise = error $ - "genValArg: I don't know how to generate builtin arguments of this type: " <> show tr + "genConstant: I don't know how to generate constant of this type: " <> show tr -- | If the given `TypeRep`'s `TyCon` is @con@, return its type arguments. matchTyCon :: forall con a. (Typeable con) => TypeRep a -> Maybe [SomeTypeRep] From ebb8fbd50f63a1a9c1b239ba6ea6062972493dd2 Mon Sep 17 00:00:00 2001 From: Ziyang Liu Date: Fri, 29 Apr 2022 10:54:09 -0700 Subject: [PATCH 09/10] Use annotate --- plutus-core/plutus-core/test/Evaluation/Spec.hs | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/plutus-core/plutus-core/test/Evaluation/Spec.hs b/plutus-core/plutus-core/test/Evaluation/Spec.hs index 2e2048fd4d1..e0936be05f9 100644 --- a/plutus-core/plutus-core/test/Evaluation/Spec.hs +++ b/plutus-core/plutus-core/test/Evaluation/Spec.hs @@ -27,7 +27,6 @@ import Data.List.Extra qualified as List import Evaluation.Machines (test_machines) import Hedgehog hiding (Opaque, Var, eval) import Hedgehog.Gen qualified as Gen -import Hedgehog.Internal.Property (failWith) import Test.Tasty import Test.Tasty.Hedgehog import Type.Reflection @@ -49,15 +48,11 @@ prop_builtinsDon'tThrow bn = property $ do (($> Nothing) . evaluate . runEmitter . runExceptT $ eval args) (pure . pure) whenJust mbErr $ \(e :: SomeException) -> do - let msg = - "Builtin function evaluation failed" - <> "Function: " - <> display bn - <> "Arguments: " - <> display args - <> "Error: " - <> show e - failWith Nothing msg + annotate "Builtin function evaluation failed" + annotate $ "Function: " <> display bn + annotate $ "Arguments: " <> display args + annotate $ "Error " <> show e + failure where meaning :: BuiltinMeaning Term (CostingPart DefaultUni DefaultFun) meaning = toBuiltinMeaning bn From 2d2bc10b9519642eaae206ccf4c0584f388f4a61 Mon Sep 17 00:00:00 2001 From: Ziyang Liu Date: Fri, 29 Apr 2022 11:18:09 -0700 Subject: [PATCH 10/10] Add haddock --- plutus-core/plutus-core/test/Evaluation/Spec.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/plutus-core/plutus-core/test/Evaluation/Spec.hs b/plutus-core/plutus-core/test/Evaluation/Spec.hs index e0936be05f9..74ceac2af63 100644 --- a/plutus-core/plutus-core/test/Evaluation/Spec.hs +++ b/plutus-core/plutus-core/test/Evaluation/Spec.hs @@ -39,6 +39,15 @@ test_builtinsDon'tThrow = "Builtins don't throw" $ fmap (\fun -> testProperty (display fun) $ prop_builtinsDon'tThrow fun) List.enumerate +-- | Evaluating a builtin function should never throw any exception (the evaluation is allowed +-- to fail with a `KnownTypeError`, of course). +-- +-- The test covers both succeeding and failing evaluations and verifies that in either case +-- no exception is thrown. The failing cases use arbitrary `Term` arguments (which doesn't +-- guarantee failure, but most likely), and the succeeding cases generate `Term` arguments +-- based on a builtin function's `TypeScheme`. For `Opaque` arguments it generates arbitrary +-- `Term`s (which technically doesn't guarantee evaluation success, although it is the case +-- with all current builtin functions). prop_builtinsDon'tThrow :: DefaultFun -> Property prop_builtinsDon'tThrow bn = property $ do args <- forAllNoShow . Gen.choice $ [genArgsWellTyped bn, genArgsArbitrary bn]