moved coverage checking options into its own data structure

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

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,43 +984,44 @@ 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
 
         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

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