diff --git a/plutus-contract/src/Plutus/Contract/Test.hs b/plutus-contract/src/Plutus/Contract/Test.hs index 46d6487b013..0a6a99d6997 100644 --- a/plutus-contract/src/Plutus/Contract/Test.hs +++ b/plutus-contract/src/Plutus/Contract/Test.hs @@ -9,6 +9,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} @@ -57,12 +58,11 @@ module Plutus.Contract.Test( , checkPredicateGen , checkPredicateGenOptions , checkPredicateInner + , checkPredicateInnerStream , CheckOptions , defaultCheckOptions , minLogLevel , emulatorConfig - , checkCoverage - , endpointCoverageReq -- * Etc , goldenPir ) where @@ -157,8 +157,6 @@ defaultCheckOptions = CheckOptions { _minLogLevel = Info , _emulatorConfig = def - , _checkCoverage = False - , _endpointCoverageReq = \ _ _ -> 20 } type TestEffects = '[Reader InitialDistribution, Error EmulatorFoldErr, Writer (Doc Void)] @@ -190,19 +188,28 @@ checkPredicateInner :: forall m. -> (String -> m ()) -- ^ Print out debug information in case of test failures -> (Bool -> m ()) -- ^ assert -> m () -checkPredicateInner CheckOptions{_minLogLevel, _emulatorConfig} predicate action annot assert = do +checkPredicateInner opts@CheckOptions{_emulatorConfig} predicate action annot assert = + checkPredicateInnerStream opts predicate (S.void $ runEmulatorStream _emulatorConfig action) annot assert + +checkPredicateInnerStream :: forall m. + Monad m + => CheckOptions + -> TracePredicate + -> (forall effs. S.Stream (S.Of (LogMessage EmulatorEvent)) (Eff effs) ()) + -> (String -> m ()) -- ^ Print out debug information in case of test failures + -> (Bool -> m ()) -- ^ assert + -> m () +checkPredicateInnerStream CheckOptions{_minLogLevel, _emulatorConfig} predicate theStream annot assert = do let dist = _emulatorConfig ^. initialChainState . to initialDist - theStream :: forall effs. S.Stream (S.Of (LogMessage EmulatorEvent)) (Eff effs) () - theStream = S.void $ runEmulatorStream _emulatorConfig action - consumeStream :: forall a. S.Stream (S.Of (LogMessage EmulatorEvent)) (Eff TestEffects) a -> Eff TestEffects (S.Of Bool a) - consumeStream = foldEmulatorStreamM @TestEffects predicate + consumedStream :: Eff TestEffects Bool + consumedStream = S.fst' <$> foldEmulatorStreamM @TestEffects predicate theStream result <- runM $ reinterpret @(Writer (Doc Void)) @m (\case { Tell d -> sendM $ annot $ Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions d }) $ runError $ runReader dist - $ consumeStream theStream + $ consumedStream - unless (fmap S.fst' result == Right True) $ do + unless (result == Right True) $ do annot "Test failed." annot "Emulator log:" S.mapM_ annot diff --git a/plutus-contract/src/Plutus/Contract/Test/ContractModel.hs b/plutus-contract/src/Plutus/Contract/Test/ContractModel.hs index d9eab5fe342..06d87c23c4b 100644 --- a/plutus-contract/src/Plutus/Contract/Test/ContractModel.hs +++ b/plutus-contract/src/Plutus/Contract/Test/ContractModel.hs @@ -25,7 +25,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -Wno-redundant-constraints -fno-warn-name-shadowing #-} module Plutus.Contract.Test.ContractModel ( -- * Contract models @@ -94,6 +94,11 @@ module Plutus.Contract.Test.ContractModel , SchemaConstraints , ContractInstanceSpec(..) , HandleFun + -- ** Coverage cheking options + , CoverageOptions + , endpointCoverageReq + , checkCoverage + , allCoverAnns -- ** Emulator properties , propRunActions_ , propRunActions @@ -117,6 +122,8 @@ module Plutus.Contract.Test.ContractModel import Control.Lens import Control.Monad.Cont +import Control.Monad.Freer (Eff, run) +import Control.Monad.Freer.Extras.Log (LogMessage, logMessageContent) import Control.Monad.State (MonadState, State) import qualified Control.Monad.State as State import qualified Data.Aeson as JSON @@ -140,12 +147,13 @@ import Plutus.Contract.Test hiding (not) import Plutus.Trace.Effects.EmulatorControl (discardWallets) import Plutus.Trace.Emulator as Trace (ContractHandle (..), ContractInstanceTag, EmulatorTrace, activateContract, - freezeContractInstance, runEmulatorTrace, + freezeContractInstance, runEmulatorStream, walletInstanceTag) import Plutus.Trace.Emulator.Types (ContractInstanceMsg (ReceiveEndpointCall), cilMessage, cilTag, unContractInstanceTag) import PlutusTx.Coverage import PlutusTx.Monoid (inv) +import qualified Streaming as S import qualified Test.QuickCheck.DynamicLogic.Monad as DL import Test.QuickCheck.DynamicLogic.Quantify (Quantifiable (..), Quantification, arbitraryQ, chooseQ, elementsQ, exactlyQ, frequencyQ, mapQ, oneofQ, whereQ) @@ -162,7 +170,8 @@ import qualified Test.QuickCheck.Monadic as QC import Text.Read import Wallet.Emulator.Chain (ChainEvent (..)) -import Wallet.Emulator.MultiAgent (EmulatorEvent' (..), EmulatorTimeEvent (..), eteEvent) +import Wallet.Emulator.MultiAgent (EmulatorEvent, EmulatorEvent' (..), EmulatorTimeEvent (..), + eteEvent) -- | Key-value map where keys and values have three indices that can vary between different elements -- of the map. Used to store `ContractHandle`s, which are indexed over observable state, schema, @@ -975,12 +984,26 @@ data CoverageOptions = CoverageOptions { _checkCoverage :: Bool makeLenses ''CoverageOptions -finalChecks :: CheckOptions -> TracePredicate -> PropertyM (ContractMonad state) a -> PropertyM (ContractMonad state) a -finalChecks opts predicate prop = do +defaultCoverageOptions :: CoverageOptions +defaultCoverageOptions = CoverageOptions { _checkCoverage = False + , _endpointCoverageReq = \ _ _ -> 20 + , _allCoverAnns = Set.empty } + +finalChecks :: CheckOptions + -> CoverageOptions + -> [ContractInstanceSpec state] + -> TracePredicate + -> PropertyM (ContractMonad state) a + -> PropertyM (ContractMonad state) a +finalChecks opts copts handleSpecs predicate prop = do x <- prop tr <- QC.run State.get - x <$ checkPredicateInner opts predicate (void $ runEmulatorAction tr IMNil) - debugOutput assertResult + let action = void $ runEmulatorAction tr IMNil + stream :: forall effs. S.Stream (S.Of (LogMessage EmulatorEvent)) (Eff effs) () + stream = void $ runEmulatorStream (opts ^. emulatorConfig) action + events = S.streamFold (const []) run (\ (msg S.:> es) -> (msg ^. logMessageContent) : es) stream + addEndpointCoverage copts handleSpecs events $ + x <$ checkPredicateInnerStream opts predicate stream debugOutput assertResult where debugOutput :: Monad m => String -> PropertyM m () debugOutput = QC.monitor . whenFail . putStrLn @@ -988,30 +1011,17 @@ finalChecks opts predicate prop = do assertResult :: Monad m => Bool -> PropertyM m () assertResult = QC.assert -contractInstanceEndpoints :: ContractInstanceSpec state -> [String] -contractInstanceEndpoints (ContractInstanceSpec _ _ (_ :: Contract w schema err ())) = labels' @(Input schema) - -contractInstanceSpecTag :: ContractInstanceSpec state -> ContractInstanceTag -contractInstanceSpecTag (ContractInstanceSpec _ w _) = walletInstanceTag w - -- | Check endpoint coverage -addEndpointCoverage :: ContractModel state - => CheckOptions - -> CoverageOptions +addEndpointCoverage :: CoverageOptions -> [ContractInstanceSpec state] + -> [EmulatorEvent] + -> PropertyM (ContractMonad state) a -> PropertyM (ContractMonad state) a - -> PropertyM (ContractMonad state) () -addEndpointCoverage opts copts specs pm +addEndpointCoverage copts specs es pm | copts ^. checkCoverage = do - _ <- pm + x <- pm -- What endpoints should be called let epsToCover = [(contractInstanceSpecTag s, contractInstanceEndpoints s) | s <- specs] - -- Get the emulator trace - tr <- (void . flip runEmulatorAction IMNil) <$> QC.run State.get - -- Using the emulator trace we obtain the result of the - -- computation - let (es, _, _) = runEmulatorTrace (opts ^. emulatorConfig) tr - -- Check what endpoints have been called cs = [ (view cilTag c, view cilMessage c) | EmulatorTimeEvent _ (InstanceEvent c) <- es ] t2ep = [ (t, ep) | (t, ReceiveEndpointCall (EndpointDescription ep) _) <- cs ] epsCovered = fmap nub $ foldr (\(t, ep) -> Map.update (Just . (ep:)) t) (const [] <$> Map.fromList epsToCover) t2ep @@ -1035,12 +1045,19 @@ addEndpointCoverage opts copts specs pm prAnn (CoverageAnnLocation file l1 l2 c1 c2) = concat [file, ":", show l1, ",", show c1, "-", show l2, ",", show c2] QC.monitor . foldr (.) id $ -- Fix this super ugly "pretty printing" hack - concat [ [ QC.cover (view endpointCoverageReq opts t e) (e `elem` fold (Map.lookup t epsCovered)) $ (take 15 . drop 22 $ Text.unpack (unContractInstanceTag t)) ++ " - " ++ e + concat [ [ QC.cover (view endpointCoverageReq copts t e) (e `elem` fold (Map.lookup t epsCovered)) $ (take 15 . drop 22 $ Text.unpack (unContractInstanceTag t)) ++ " - " ++ e | e <- eps ] | (t, eps) <- epsToCover ] ++ - [ QC.cover 0.01 (Set.member ann coverageAnnotations) (prAnn ann) | ann <- Set.toList allCoverAnns ] + [ QC.cover 0.01 (Set.member ann coverageAnnotations) (prAnn ann) | ann <- Set.toList $ copts ^. allCoverAnns ] + return x -- QC.monitor QC.checkCoverage - | otherwise = void pm + | otherwise = pm + +contractInstanceEndpoints :: ContractInstanceSpec state -> [String] +contractInstanceEndpoints (ContractInstanceSpec _ _ (_ :: Contract w schema err ())) = labels' @(Input schema) + +contractInstanceSpecTag :: ContractInstanceSpec state -> ContractInstanceTag +contractInstanceSpecTag (ContractInstanceSpec _ w _) = walletInstanceTag w activateWallets :: forall state. ContractModel state => [ContractInstanceSpec state] -> EmulatorTrace (Handles state) activateWallets [] = return IMNil @@ -1075,7 +1092,7 @@ propRunActions :: -> (ModelState state -> TracePredicate) -- ^ Predicate to check at the end -> Actions state -- ^ The actions to run -> Property -propRunActions = propRunActionsWithOptions defaultCheckOptions Set.empty +propRunActions = propRunActionsWithOptions defaultCheckOptions defaultCoverageOptions -- | Run a `Actions` in the emulator and check that the model and the emulator agree on the final -- wallet balance changes, that no off-chain contract instance crashed, and that the given @@ -1109,24 +1126,24 @@ propRunActions = propRunActionsWithOptions defaultCheckOptions Set.empty propRunActionsWithOptions :: ContractModel state => CheckOptions -- ^ Emulator options - -> Set CoverageAnn -- ^ Coverage annotations we expect to cover + -> CoverageOptions -- ^ Coverage options -> [ContractInstanceSpec state] -- ^ Required wallet contract instances -> (ModelState state -> TracePredicate) -- ^ Predicate to check at the end -> Actions state -- ^ The actions to run -> Property -propRunActionsWithOptions opts coverAnns handleSpecs predicate actions' = - propRunActionsWithOptions' opts coverAnns handleSpecs predicate (toStateModelActions actions') +propRunActionsWithOptions opts copts handleSpecs predicate actions' = + propRunActionsWithOptions' opts copts handleSpecs predicate (toStateModelActions actions') propRunActionsWithOptions' :: ContractModel state => CheckOptions -- ^ Emulator options - -> Set CoverageAnn -- ^ Coverage annotations we expect to cover + -> CoverageOptions -- ^ Coverage options -> [ContractInstanceSpec state] -- ^ Required wallet contract instances -> (ModelState state -> TracePredicate) -- ^ Predicate to check at the end -> StateModel.Actions (ModelState state) -- ^ The actions to run -> Property -propRunActionsWithOptions' opts coverAnns handleSpecs predicate actions = - monadic (flip State.evalState mempty) $ addEndpointCoverage opts coverAnns handleSpecs $ finalChecks opts finalPredicate $ do +propRunActionsWithOptions' opts copts handleSpecs predicate actions = + monadic (flip State.evalState mempty) $ finalChecks opts copts handleSpecs finalPredicate $ do QC.run $ setHandles $ activateWallets handleSpecs void $ runActionsInState StateModel.initialState actions where @@ -1191,7 +1208,7 @@ checkNoLockedFundsProof options spec NoLockedFundsProof{nlfpMainStrategy = mai as'' = toStateModelActions as' in foldl (QC..&&.) (counterexample "Main strategy" $ prop as'') [ walletProp as w bal | (w, bal) <- Map.toList (s ^. balanceChanges) ] where - prop = propRunActionsWithOptions' options Set.empty spec (\ _ -> pure True) + prop = propRunActionsWithOptions' options defaultCoverageOptions spec (\ _ -> pure True) mainProp as = do mapM_ action as diff --git a/plutus-use-cases/test/Spec/GameStateMachine.hs b/plutus-use-cases/test/Spec/GameStateMachine.hs index 5aa6cbb88b5..6ee06068b77 100644 --- a/plutus-use-cases/test/Spec/GameStateMachine.hs +++ b/plutus-use-cases/test/Spec/GameStateMachine.hs @@ -155,7 +155,10 @@ prop_Game :: Actions GameModel -> Property prop_Game script = propRunActions_ handleSpec script prop_Game_coverage :: Actions GameModel -> Property -prop_Game_coverage = propRunActionsWithOptions (set checkCoverage True defaultCheckOptions) scriptLocations handleSpec (const (pure True)) +prop_Game_coverage = propRunActionsWithOptions defaultCheckOptions + (set allCoverAnns scriptLocations $ set checkCoverage True $ defaultCoverageOptions) + handleSpec + (const (pure True)) theScript :: Script theScript = unValidatorScript . Scripts.validatorScript $ typedValidator