Factored out coverage from exec

lib/Echidna/Exec.hs

@@ -1,26 +1,19 @@
 {-# LANGUAGE BangPatterns, DeriveGeneric, FlexibleContexts, KindSignatures, LambdaCase, StrictData #-}
 
 module Echidna.Exec (
-    ContractCov(..)
-  , CoveragePoint(..)
-  , CoverageReport(..)
-  , byHashes
+    VMState
+  , VMAction(..)
   , checkTest
   , checkBoolExpTest
   , checkRevertTest
   , checkTrueOrRevertTest
   , checkFalseOrRevertTest
-  , CoverageInfo
-  , CoverageRef
   , eCommand
-  , eCommandCoverage
+  , eCommandUsing
   , ePropertySeq
-  , ePropertySeqCoverage
+  , ePropertyUsing
   , execCall
-  , execCallCoverage
-  , getCover
-  , ppHashes
-  , printResults
+  , execCallUsing
   , module Echidna.Internal.Runner
   , module Echidna.Internal.JsonRunner
   ) where
@@ -67,48 +60,11 @@ import Echidna.Internal.Runner
 import Echidna.Internal.JsonRunner
 import Echidna.Property (PropertyType(..))
 
---------------------------------------------------------------------
--- COVERAGE HANDLING
-
-data CoveragePoint = C (Int, Int) W256 deriving (Eq, Generic)
-
-instance NFData CoveragePoint
-
-instance Ord CoveragePoint where
-  compare (C (_,i0) w0) (C (_,i1) w1) = case compare w0 w1 of EQ -> compare i0 i1
-                                                              x  -> x
-
-type CoverageInfo = (SolCall, Set CoveragePoint)
-type CoverageRef  = IORef CoverageInfo
-
-byHashes :: (Foldable t, Monoid (t CoveragePoint)) => t CoveragePoint -> Map W256 (Set (Int, Int))
-byHashes = foldr (\(C i w) -> insertWith mappend w $ singleton i) mempty . toList
-
-printResults :: (MonadIO m, MonadReader Config m) => Set CoveragePoint -> m ()
-printResults ci = do liftIO (putStrLn $ "Coverage: " ++ show (size ci) ++ " unique arcs")
-                     view printCoverage >>= \case True  -> liftIO . print . ppHashes $ byHashes ci
-                                                  False -> pure ()
-
-data ContractCov = ContractCov { hash :: String, arcs :: [(Int, Int)] } deriving (Show, Generic)
-newtype CoverageReport = CoverageReport { coverage :: [ContractCov] } deriving (Show, Generic)
-
-instance ToJSON ContractCov
-instance ToJSON CoverageReport
-
-ppHashes :: Map W256 (Set (Int, Int)) -> String
-ppHashes = unpack . encode . toJSON . CoverageReport
-  . map (\(h, is) -> ContractCov (show h) (toList is)) . toAscList
-
-getCover :: (Foldable t, Monoid (t b)) => [(a, t b)] -> [a]
-getCover [] = []
-getCover xs = setCover (fromList xs) mempty totalCoverage []
-  where totalCoverage = length $ foldl' (\acc -> mappend acc . snd) mempty xs
+-------------------------------------------------------------------
+-- Fuzzing and Hedgehog Init
 
-setCover :: (Foldable t, Monoid (t b)) => Vector (a, t b) -> t b -> Int -> [a] -> [a]
-setCover vs cov tot calls = best : calls & if length new == tot then id
-                                                                else setCover vs new tot where
-  (best, new) = mappend cov <$> maximumBy (comparing $ length . mappend cov . snd) vs
-  
+execCall :: MonadState VM m => SolCall -> m VMResult
+execCall = execCallUsing exec
 
 execCallUsing :: MonadState VM m => m VMResult -> SolCall -> m VMResult
 execCallUsing m (t,vs) = do og <- get
@@ -119,26 +75,6 @@ execCallUsing m (t,vs) = do og <- get
   where cd = B . abiCalldata (encodeSig t $ abiValueType <$> vs) $ fromList vs
         cleanUp = sequence_ [result .= Nothing, state . pc .= 0, state . stack .= mempty]
 
-
-execCall :: MonadState VM m => SolCall -> m VMResult
-execCall = execCallUsing exec
-
-
-execCallCoverage :: (MonadState VM m, MonadReader CoverageRef m, MonadIO m) => SolCall -> m VMResult
-execCallCoverage sol = execCallUsing (go mempty) sol where
-  go !c = use result >>= \case
-    Just x -> do ref <- ask
-                 liftIO $ modifyIORef' ref (const (sol, c))
-                 return x
-    _      -> do current <- use $ state . pc
-                 ch      <- view codehash . fromMaybe (error "no current contract??") . currentContract <$> get 
-                 S.state (runState exec1)
-                 new     <- use $ state . pc
-                 go . force $ insert (C (current, new) ch) c
-
--------------------------------------------------------------------
--- Fuzzing and Hedgehog Init
-
 checkTest :: PropertyType -> VM -> Text -> Bool
 checkTest ShouldReturnTrue             = checkBoolExpTest True
 checkTest ShouldReturnFalse            = checkBoolExpTest False
@@ -198,14 +134,6 @@ eCommandUsing gen ex p = Command (\_ -> pure $ Call <$> gen) ex
 eCommand :: (MonadGen n, MonadTest m) => n SolCall -> (VM -> Bool) -> Command n m VMState
 eCommand = flip eCommandUsing (\ _ -> pure ())
 
-
-eCommandCoverage :: (MonadGen n, MonadTest m, MonadState VM m, MonadReader CoverageRef m, MonadIO m)
-                 => [SolCall] -> (VM -> Bool) -> [SolSignature] -> Config -> [Command n m VMState]
-eCommandCoverage cov p ts conf = let useConf = flip runReaderT conf in case cov of
-  [] -> [eCommandUsing (useConf $ genInteractions ts) (\(Call c) -> execCallCoverage c) p]
-  xs -> map (\x -> eCommandUsing (choice $ useConf <$> [mutateCall x, genInteractions ts])
-              (\(Call c) -> execCallCoverage c) p) xs
-
 configProperty :: Config -> PropertyConfig -> PropertyConfig
 configProperty config x = x { propertyTestLimit   = config ^. testLimit
                             , propertyShrinkLimit = config ^. shrinkLimit
@@ -232,21 +160,3 @@ ePropertySeq :: (MonadReader Config m)
              -> VM             -- Initial state
              -> m Property
 ePropertySeq p ts vm = ask >>= \c -> ePropertyUsing [eCommand (runReaderT (genInteractions ts) c) p] id vm
-
-
-ePropertySeqCoverage :: (MonadReader Config m)
-                     => [SolCall]
-                     -> MVar [CoverageInfo]
-                     -> (VM -> Bool)
-                     -> [SolSignature]
-                     -> VM
-                     -> m Property
-ePropertySeqCoverage calls cov p ts v = ask >>= \c -> ePropertyUsing (eCommandCoverage calls p ts c) writeCoverage v 
-  where writeCoverage :: MonadIO m => ReaderT CoverageRef (StateT VM m) a -> m a
-        writeCoverage m = do
-          threadCovRef <- liftIO $ newIORef mempty
-          let s = runReaderT m threadCovRef
-          a         <- evalStateT s v
-          threadCov <- liftIO $ readIORef threadCovRef
-          liftIO $ modifyMVar_ cov (\xs -> pure $ threadCov:xs)
-          return a

package.yaml

@@ -40,6 +40,7 @@ library:
   exposed-modules:
     - Echidna.ABI
     - Echidna.Config
+    - Echidna.Coverage
     - Echidna.Exec
     - Echidna.Solidity
     - Echidna.Property

perprop/Main.hs

@@ -25,6 +25,7 @@ import Hedgehog.Internal.Property (GroupName(..), PropertyName(..))
 
 import Echidna.ABI
 import Echidna.Config
+import Echidna.Coverage
 import Echidna.Exec
 import Echidna.Property
 import Echidna.Solidity

src/Main.hs

@@ -9,11 +9,12 @@ import Control.Monad.Catch     (MonadThrow(..))
 import Control.Monad.IO.Class  (liftIO)
 import Control.Monad.Reader    (runReaderT)
 import Data.List               (foldl')
-import Data.Set                (unions)
+import Data.Set                (unions, size)
 import Data.Text               (pack)
 import Data.Semigroup          ((<>))
 
 import Echidna.Config
+import Echidna.Coverage (ePropertySeqCoverage, getCover, printResults)
 import Echidna.Exec
 import Echidna.Solidity