Static analysis to find unnecessary locations (#416)

cabal.project

@@ -91,7 +91,7 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/plutus
-  tag: 4127e9cd6e889824d724c30eae55033cb50cbf3e
+  tag: 00a6eee2ed318fc2ba46c7672576e692196f2ada
   subdir:
     plutus-core
     plutus-ledger-api

doc/plutus/tutorials/Auction.hs

@@ -359,7 +359,7 @@ check_propAuctionWithCoverage = do
     withMaxSuccess 1000 $
       propRunActionsWithOptions @AuctionModel
         (set minLogLevel Critical options) covopts (const (pure True))
-  writeCoverageReport "Auction" covIdx cr
+  writeCoverageReport "Auction" cr
 
 tests :: TestTree
 tests =

doc/plutus/tutorials/Escrow5.hs

@@ -235,5 +235,5 @@ check_propEscrowWithCoverage = do
     withMaxSuccess 1000 $
       CM.propRunActionsWithOptions @EscrowModel CM.defaultCheckOptionsContractModel covopts
         (const (pure True))
-  writeCoverageReport "Escrow" covIdx cr
+  writeCoverageReport "Escrow" cr
 {- END check_propEscrowWithCoverage -}

doc/plutus/tutorials/Escrow6.hs

@@ -273,6 +273,6 @@ prop_CrashTolerance = CM.propRunActions_
 
 check_propEscrowWithCoverage :: IO ()
 check_propEscrowWithCoverage = do
-  cr <- CM.quickCheckWithCoverage stdArgs (set coverageIndex covIdx defaultCoverageOptions) $ \covopts ->
-    withMaxSuccess 1000 $ CM.propRunActionsWithOptions @EscrowModel CM.defaultCheckOptionsContractModel covopts (const (pure True))
-  writeCoverageReport "Escrow" covIdx cr
+  cr <- quickCheckWithCoverage stdArgs (set coverageIndex covIdx $ defaultCoverageOptions) $ \covopts ->
+    withMaxSuccess 1000 $ propRunActionsWithOptions @EscrowModel defaultCheckOptionsContractModel covopts (const (pure True))
+  writeCoverageReport "Escrow" cr

nix/pkgs/haskell/sha256map.nix

@@ -11,7 +11,7 @@
   "https://github.com/input-output-hk/goblins"."cde90a2b27f79187ca8310b6549331e59595e7ba" = "17c88rbva3iw82yg9srlxjv2ia5wjb9cyqw44hik565f5v9svnyg";
   "https://github.com/input-output-hk/iohk-monitoring-framework"."46f994e216a1f8b36fe4669b47b2a7011b0e153c" = "1il8fx3misp3650ryj368b3x95ksz01zz3x0z9k00807j93d0ka0";
   "https://github.com/input-output-hk/ouroboros-network"."4fac197b6f0d2ff60dc3486c593b68dc00969fbf" = "1b43vbdsr9m3ry1kgag2p2ixpv54gw7a4vvmndxl6knqg8qbsb8b";
-  "https://github.com/input-output-hk/plutus"."4127e9cd6e889824d724c30eae55033cb50cbf3e" = "186w0x7vk8m8npmsfg9pdkxds0rlj6bmhr8nkgn96rkvaz5azjsb";
+  "https://github.com/input-output-hk/plutus"."00a6eee2ed318fc2ba46c7672576e692196f2ada" = "1zfka8bj4zc348pzgriavn0mbz0503x3gb9fv0bfks0d7yx1rvkp";
   "https://github.com/input-output-hk/purescript-bridge"."47a1f11825a0f9445e0f98792f79172efef66c00" = "0da1vn2l6iyfxcjk58qal1l4755v92zi6yppmjmqvxf1gacyf9px";
   "https://github.com/input-output-hk/servant-purescript"."44e7cacf109f84984cd99cd3faf185d161826963" = "10pb0yfp80jhb9ryn65a4rha2lxzsn2vlhcc6xphrrkf4x5lhzqc";
   "https://github.com/input-output-hk/Win32-network"."3825d3abf75f83f406c1f7161883c438dac7277d" = "19wahfv726fa3mqajpqdqhnl9ica3xmf68i254q45iyjcpj1psqx";

plutus-contract-certification/src/Plutus/Contract/Test/Certification/Run.hs

@@ -24,7 +24,6 @@ module Plutus.Contract.Test.Certification.Run
   , certRes_standardCrashToleranceResult
   , certRes_unitTestResults
   , certRes_coverageReport
-  , certRes_coverageIndexReport
   , certRes_whitelistOk
   , certRes_whitelistResult
   , certRes_DLTests
@@ -93,7 +92,6 @@ data CertificationReport m = CertificationReport {
     _certRes_standardCrashToleranceResult :: Maybe QC.Result,
     _certRes_unitTestResults              :: [Tasty.Result],
     _certRes_coverageReport               :: CoverageReport,
-    _certRes_coverageIndexReport          :: CoverageIndex,
     _certRes_whitelistOk                  :: Maybe Bool,
     _certRes_whitelistResult              :: Maybe QC.Result,
     _certRes_DLTests                      :: [(String, QC.Result)]
@@ -120,7 +118,7 @@ liftIORep io = do
 runCertMonad :: CertMonad (CertificationReport m) -> IO (CertificationReport m)
 runCertMonad m = do
   (rep, cov) <- runWriterT m
-  return $ rep { _certRes_coverageReport = cov }
+  return $ rep & certRes_coverageReport %~ (<> cov)
 
 runStandardProperty :: forall m. ContractModel m => CertificationOptions -> CoverageIndex -> CertMonad QC.Result
 runStandardProperty opts covIdx = liftIORep $ quickCheckWithCoverageAndResult
@@ -153,7 +151,7 @@ runUnitTests t = liftIORep $ do
       rs <- atomically $ mapM waitForDone (IntMap.elems status)
       return $ \ _ -> return rs
     cov <- readCoverageRef ref
-    return (cov, res)
+    return (CoverageReport mempty cov, res)
   where
     waitForDone tv = do
       s <- readTVar tv
@@ -221,8 +219,7 @@ certifyWithOptions opts Certification{..} = runCertMonad $ do
                                  _certRes_noLockedFundsResult          = noLock,
                                  _certRes_noLockedFundsLightResult     = noLockLight,
                                  _certRes_unitTestResults              = unitTests,
-                                 _certRes_coverageReport               = mempty,
-                                 _certRes_coverageIndexReport          = certCoverageIndex,
+                                 _certRes_coverageReport               = CoverageReport certCoverageIndex mempty,
                                  _certRes_whitelistOk                  = whitelistOk <$> certWhitelist,
                                  _certRes_whitelistResult              = wlRes,
                                  _certRes_DLTests                      = dlRes }

plutus-contract/plutus-contract.cabal

@@ -37,6 +37,7 @@ flag defer-plugin-errors
 
 library
     import: lang
+    ghc-options: -O2 +RTS -T -N -qn8 -A1G -RTS
     exposed-modules:
         Data.Row.Extras
         Data.Text.Extras
@@ -133,6 +134,7 @@ library
         mmorph -any,
         mtl -any,
         prettyprinter >=1.1.0.1,
+        pretty -any,
         profunctors -any,
         quickcheck-dynamic -any,
         row-types >= 1.0.1.0,
@@ -150,7 +152,8 @@ library
         openapi3 -any,
         cardano-wallet-core -any,
         text-class -any,
-        uniplate -any
+        uniplate -any,
+        stm -any
 
     if !(impl(ghcjs) || os(ghcjs))
         build-depends: plutus-tx-plugin -any
@@ -163,6 +166,12 @@ library
             Plutus.Contract.Test
             Plutus.Contract.Test.Coverage
             Plutus.Contract.Test.Coverage.ReportCoverage
+            Plutus.Contract.Test.Coverage.Analysis
+            Plutus.Contract.Test.Coverage.Analysis.Common
+            Plutus.Contract.Test.Coverage.Analysis.DeBruijn
+            Plutus.Contract.Test.Coverage.Analysis.Interpreter
+            Plutus.Contract.Test.Coverage.Analysis.Pretty
+            Plutus.Contract.Test.Coverage.Analysis.Types
             Plutus.Contract.Test.ContractModel
             Plutus.Contract.Test.ContractModel.Internal
             Plutus.Contract.Test.ContractModel.Symbolics
@@ -225,7 +234,15 @@ test-suite plutus-contract-test
         tasty-hunit -any,
         tasty-quickcheck -any,
         text -any,
-        transformers -any
+        transformers -any,
+        plutus-core -any,
+        pretty -any,
+        prettyprinter -any,
+        utf8-string -any,
+        deepseq -any,
+        stm -any,
+        serialise -any,
+        splitmix -any
 
     if !(impl(ghcjs) || os(ghcjs))
         build-depends: plutus-tx-plugin -any

plutus-contract/src/Plutus/Contract/Test.hs

@@ -143,7 +143,7 @@ import Wallet.Emulator.Folds (EmulatorFoldErr (..), Outcome (..), describeError,
 import Wallet.Emulator.Folds qualified as Folds
 import Wallet.Emulator.Stream (filterLogLevel, foldEmulatorStreamM, initialChainState, initialDist)
 
-type TestEffects = '[Reader InitialDistribution, Error EmulatorFoldErr, Writer (Doc Void), Writer CoverageReport]
+type TestEffects = '[Reader InitialDistribution, Error EmulatorFoldErr, Writer (Doc Void), Writer CoverageData]
 newtype TracePredicateF a = TracePredicate (forall effs. Members TestEffects effs => FoldM (Eff effs) EmulatorEvent a)
   deriving (Functor)
 instance Applicative TracePredicateF where
@@ -231,7 +231,7 @@ checkPredicateInner :: forall m.
     -> EmulatorTrace ()
     -> (String -> m ()) -- ^ Print out debug information in case of test failures
     -> (Bool -> m ()) -- ^ assert
-    -> (CoverageReport -> m ())
+    -> (CoverageData -> m ())
     -> m ()
 checkPredicateInner opts@CheckOptions{_emulatorConfig} predicate action annot assert cover =
     checkPredicateInnerStream opts predicate (S.void $ runEmulatorStream _emulatorConfig action) annot assert cover
@@ -243,17 +243,17 @@ checkPredicateInnerStream :: forall m.
     -> (forall effs. S.Stream (S.Of (LogMessage EmulatorEvent)) (Eff effs) ())
     -> (String -> m ()) -- ^ Print out debug information in case of test failures
     -> (Bool -> m ()) -- ^ assert
-    -> (CoverageReport -> m ())
+    -> (CoverageData -> m ())
     -> m ()
 checkPredicateInnerStream CheckOptions{_minLogLevel, _emulatorConfig} (TracePredicate predicate) theStream annot assert cover = do
     let dist = _emulatorConfig ^. initialChainState . to initialDist
         consumedStream :: Eff (TestEffects :++: '[m]) Bool
         consumedStream = S.fst' <$> foldEmulatorStreamM (liftA2 (&&) predicate generateCoverage) theStream
 
-        generateCoverage = flip postMapM (L.generalize Folds.emulatorLog) $ (True <$) . tell @CoverageReport . getCoverageReport
+        generateCoverage = flip postMapM (L.generalize Folds.emulatorLog) $ (True <$) . tell @CoverageData . getCoverageData
 
     result <- runM
-                $ interpretM @(Writer CoverageReport) @m (\case { Tell r -> cover r })
+                $ interpretM @(Writer CoverageData) @m (\case { Tell r -> cover r })
                 $ interpretM @(Writer (Doc Void)) @m (\case { Tell d -> annot $ Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions d })
                 $ runError
                 $ runReader dist

plutus-contract/src/Plutus/Contract/Test/ContractModel/Internal.hs

@@ -211,7 +211,7 @@ import Plutus.Trace.Emulator as Trace (EmulatorTrace, activateContract, callEndp
 import Plutus.Trace.Emulator.Types (unContractInstanceTag)
 import Plutus.V1.Ledger.Scripts
 import PlutusTx.Builtins qualified as Builtins
-import PlutusTx.Coverage
+import PlutusTx.Coverage hiding (_coverageIndex)
 import PlutusTx.ErrorCodes
 import Streaming qualified as S
 import Test.QuickCheck.DynamicLogic.Monad qualified as DL
@@ -1375,7 +1375,7 @@ instance GetModelState (DL state) where
 data CoverageOptions = CoverageOptions { _checkCoverage       :: Bool
                                        , _endpointCoverageReq :: ContractInstanceTag -> String -> Double
                                        , _coverageIndex       :: CoverageIndex
-                                       , _coverageIORef       :: Maybe (IORef CoverageReport)
+                                       , _coverageIORef       :: Maybe (IORef CoverageData)
                                        }
 
 makeLenses ''CoverageOptions
@@ -1405,8 +1405,9 @@ quickCheckWithCoverageAndResult qcargs copts prop = do
   case copts ^. coverageIORef of
     Nothing -> fail "Unreachable case in quickCheckWithCoverage"
     Just ref -> do
-      report <- readIORef ref
-      when (chatty qcargs) $ putStrLn . show $ pprCoverageReport (copts ^. coverageIndex) report
+      covdata <- readIORef ref
+      let report = CoverageReport (copts ^. coverageIndex) covdata
+      when (chatty qcargs) $ putStrLn . show $ pretty report
       return (report, res)
 
 finalChecks :: ContractModel state
@@ -1472,7 +1473,6 @@ addEndpointCoverage copts keys es pm
                          , e <- eps ]
     endpointCovers `deepseq`
       (QC.monitor . foldr (.) id $ endpointCovers)
-    QC.monitor QC.checkCoverage
     return x
   | otherwise = pm
 
@@ -1531,8 +1531,7 @@ propRunActions = propRunActionsWithOptions defaultCheckOptionsContractModel defa
 -- options :: `Map` `Wallet` `Value` -> `Slot` -> `Control.Monad.Freer.Extras.Log.LogLevel` -> `CheckOptions`
 -- options dist slot logLevel =
 --     `defaultCheckOptions` `&` `emulatorConfig` . `Plutus.Trace.Emulator.initialChainState` `.~` `Left` dist
---                         `&` `maxSlot`                            `.~` slot
---                         `&` `minLogLevel`                        `.~` logLevel
+--                           `&` `minLogLevel`                        `.~` logLevel
 -- @
 --
 propRunActionsWithOptions ::

plutus-contract/src/Plutus/Contract/Test/Coverage.hs

@@ -1,27 +1,23 @@
 {-# LANGUAGE DeriveAnyClass     #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Plutus.Contract.Test.Coverage
   ( getInvokedEndpoints
-  , getCoverageReport
+  , getCoverageData
   , CoverageRef(..)
   , newCoverageRef
   , readCoverageRef
   , writeCoverageReport
   ) where
 
-import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
 import Data.Foldable
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Set (Set)
 import Data.Set qualified as Set
-import GHC.Generics
 
 import Data.Text qualified as Text
 
-import Control.DeepSeq
 import Control.Lens
 
 import Ledger qualified
@@ -48,8 +44,8 @@ getInvokedEndpoints es =
   in epsCovered
 
 -- | Collect every executed coverage annotation in the validators executed in `es`
-getCoverageReport :: [EmulatorEvent] -> CoverageReport
-getCoverageReport es =
+getCoverageData :: [EmulatorEvent] -> CoverageData
+getCoverageData es =
   let extractLog e = case e of
         ChainEvent (TxnValidate _ _ valEvs)             -> logOf . Ledger.sveResult <$> valEvs
         ChainEvent (TxnValidationFail _ _ _ _ valEvs _) -> logOf . Ledger.sveResult <$> valEvs
@@ -64,49 +60,17 @@ getCoverageReport es =
     log <- extractLog $ event ^. eteEvent
     logEvent <- log
     let msg = Text.unpack logEvent
-    return $ coverageReportFromLogMsg msg
+    return $ coverageDataFromLogMsg msg
 
-newtype CoverageRef = CoverageRef (IORef CoverageReport)
+newtype CoverageRef = CoverageRef (IORef CoverageData)
 
 newCoverageRef :: IO CoverageRef
 newCoverageRef = CoverageRef <$> newIORef mempty
 
-readCoverageRef :: CoverageRef -> IO CoverageReport
+readCoverageRef :: CoverageRef -> IO CoverageData
 readCoverageRef (CoverageRef ioref) = readIORef ioref
 
 -- | Write a coverage report to name.html for the given index.
-writeCoverageReport :: String -> CoverageIndex -> CoverageReport -> IO ()
+writeCoverageReport :: String -> CoverageReport -> IO ()
 writeCoverageReport = ReportCoverage.writeCoverageReport
 
--- TODO: Move this to plutus core to avoid orhpan instance
-instance NFData CovLoc where
-  rnf (CovLoc f sl el sc ec) =
-    rnf f  `seq`
-    rnf sl `seq`
-    rnf el `seq`
-    rnf sc `seq`
-    rnf ec
-instance NFData CoverageAnnotation where
-  rnf (CoverLocation loc) = rnf loc
-  rnf (CoverBool loc b)   = rnf b `seq` rnf loc
-deriving anyclass instance NFData CoverageReport
-deriving instance Generic CoverageReport
-deriving anyclass instance ToJSON CoverageReport
-deriving anyclass instance FromJSON CoverageReport
-
-deriving anyclass instance ToJSON CoverageIndex
-deriving anyclass instance FromJSON CoverageIndex
-
-deriving anyclass instance ToJSON CoverageAnnotation
-deriving anyclass instance FromJSON CoverageAnnotation
-deriving anyclass instance ToJSONKey CoverageAnnotation
-deriving anyclass instance FromJSONKey CoverageAnnotation
-
-deriving anyclass instance ToJSON CovLoc
-deriving anyclass instance FromJSON CovLoc
-
-deriving anyclass instance ToJSON CoverageMetadata
-deriving anyclass instance FromJSON CoverageMetadata
-
-deriving anyclass instance ToJSON Metadata
-deriving anyclass instance FromJSON Metadata

plutus-contract/src/Plutus/Contract/Test/Coverage/Analysis.hs

@@ -0,0 +1,24 @@
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+
+module Plutus.Contract.Test.Coverage.Analysis
+  ( computeRefinedCoverageIndex
+  ) where
+
+import Control.Lens
+
+import Data.Map qualified as Map
+import Data.Set qualified as Set
+
+import PlutusCore.Default
+import PlutusTx.Code
+import PlutusTx.Coverage
+
+import Plutus.Contract.Test.Coverage.Analysis.Interpreter
+
+computeRefinedCoverageIndex :: CompiledCodeIn DefaultUni DefaultFun a -> CoverageIndex
+computeRefinedCoverageIndex cc =
+    foldr (flip addCoverageMetadata IgnoredAnnotation) covIdx (Set.toList ignoredLocs)
+  where
+    covIdx        = getCovIdx cc
+    importantLocs = allNonFailLocations cc
+    ignoredLocs   = covIdx ^. coverageMetadata . to Map.keysSet . to (`Set.difference` importantLocs)