{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ImplicitParams #-}

module EVM.UnitTest where

import Prelude hiding (Word)

import EVM
import EVM.ABI
import EVM.Concrete
import EVM.SMT
import EVM.Solvers
import EVM.Dapp
import EVM.Debug (srcMapCodePos)
import EVM.Exec
import EVM.Expr (litAddr, readStorage', simplify)
import EVM.Expr qualified as Expr
import EVM.Facts qualified as Facts
import EVM.Facts.Git qualified as Git
import EVM.FeeSchedule qualified as FeeSchedule
import EVM.Fetch qualified as Fetch
import EVM.Format
import EVM.Solidity
import EVM.SymExec (defaultVeriOpts, symCalldata, verify, isQed, extractCex, runExpr, subModel, VeriOpts(..))
import EVM.Types
import EVM.Transaction (initTx)
import EVM.RLP
import EVM.Stepper (Stepper, interpret)
import EVM.Stepper qualified as Stepper

import Control.Monad.Operational qualified as Operational
import Optics.Core hiding (elements)
import Optics.State
import Optics.State.Operators
import Optics.Zoom
import Control.Monad.Par.Class (spawn_)
import Control.Monad.Par.Class qualified as Par
import Control.Monad.Par.IO (runParIO)
import Control.Monad.State.Strict hiding (state)
import Control.Monad.State.Strict qualified as State
import Data.ByteString.Lazy qualified as BSLazy
import Data.Binary.Get (runGet)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.Decimal (DecimalRaw(..))
import Data.Either (isRight)
import Data.Foldable (toList)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe, catMaybes, fromJust, isJust, fromMaybe, mapMaybe, isNothing)
import Data.MultiSet (MultiSet)
import Data.MultiSet qualified as MultiSet
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (isPrefixOf, stripSuffix, intercalate, Text, pack, unpack)
import Data.Text qualified as Text
import Data.Text.Encoding (encodeUtf8)
import Data.Text.IO qualified as Text
import Data.Vector (Vector)
import Data.Vector qualified as Vector
import Data.Word (Word32, Word64)
import GHC.Natural
import System.Environment (lookupEnv)
import System.IO (hFlush, stdout)
import Test.QuickCheck hiding (verbose, Success, Failure)
import qualified Test.QuickCheck as QC
import Witch (unsafeInto, into)

data UnitTestOptions = UnitTestOptions
  { UnitTestOptions -> RpcInfo
rpcInfo     :: Fetch.RpcInfo
  , UnitTestOptions -> SolverGroup
solvers     :: SolverGroup
  , UnitTestOptions -> Maybe Int
verbose     :: Maybe Int
  , UnitTestOptions -> Maybe Integer
maxIter     :: Maybe Integer
  , UnitTestOptions -> Integer
askSmtIters :: Integer
  , UnitTestOptions -> Bool
smtDebug    :: Bool
  , UnitTestOptions -> Maybe Int
maxDepth    :: Maybe Int
  , UnitTestOptions -> Maybe Natural
smtTimeout  :: Maybe Natural
  , UnitTestOptions -> Maybe Text
solver      :: Maybe Text
  , UnitTestOptions -> Maybe Text
covMatch    :: Maybe Text
  , UnitTestOptions -> Text
match       :: Text
  , UnitTestOptions -> Int
fuzzRuns    :: Int
  , UnitTestOptions -> Maybe (Text, ByteString)
replay      :: Maybe (Text, BSLazy.ByteString)
  , UnitTestOptions -> VM -> VM
vmModifier  :: VM -> VM
  , UnitTestOptions -> DappInfo
dapp        :: DappInfo
  , UnitTestOptions -> TestVMParams
testParams  :: TestVMParams
  , UnitTestOptions -> Bool
ffiAllowed  :: Bool
  }

data TestVMParams = TestVMParams
  { TestVMParams -> Addr
address       :: Addr
  , TestVMParams -> Addr
caller        :: Addr
  , TestVMParams -> Addr
origin        :: Addr
  , TestVMParams -> Word64
gasCreate     :: Word64
  , TestVMParams -> Word64
gasCall       :: Word64
  , TestVMParams -> W256
baseFee       :: W256
  , TestVMParams -> W256
priorityFee   :: W256
  , TestVMParams -> W256
balanceCreate :: W256
  , TestVMParams -> Addr
coinbase      :: Addr
  , TestVMParams -> W256
number        :: W256
  , TestVMParams -> W256
timestamp     :: W256
  , TestVMParams -> Word64
gaslimit      :: Word64
  , TestVMParams -> W256
gasprice      :: W256
  , TestVMParams -> W256
maxCodeSize   :: W256
  , TestVMParams -> W256
prevrandao    :: W256
  , TestVMParams -> W256
chainId       :: W256
  }

defaultGasForCreating :: Word64
defaultGasForCreating :: Word64
defaultGasForCreating = Word64
0xffffffffffff

defaultGasForInvoking :: Word64
defaultGasForInvoking :: Word64
defaultGasForInvoking = Word64
0xffffffffffff

defaultBalanceForTestContract :: W256
defaultBalanceForTestContract :: W256
defaultBalanceForTestContract = W256
0xffffffffffffffffffffffff

defaultMaxCodeSize :: W256
defaultMaxCodeSize :: W256
defaultMaxCodeSize = W256
0xffffffff

type ABIMethod = Text


-- | Generate VeriOpts from UnitTestOptions
makeVeriOpts :: UnitTestOptions -> VeriOpts
makeVeriOpts :: UnitTestOptions -> VeriOpts
makeVeriOpts UnitTestOptions
opts =
   VeriOpts
defaultVeriOpts { $sel:debug:VeriOpts :: Bool
debug = UnitTestOptions
opts.smtDebug
                   , $sel:maxIter:VeriOpts :: Maybe Integer
maxIter = UnitTestOptions
opts.maxIter
                   , $sel:askSmtIters:VeriOpts :: Integer
askSmtIters = UnitTestOptions
opts.askSmtIters
                   , $sel:rpcInfo:VeriOpts :: RpcInfo
rpcInfo = UnitTestOptions
opts.rpcInfo
                   }

-- | Top level CLI endpoint for hevm test
unitTest :: UnitTestOptions -> Contracts -> Maybe String -> IO Bool
unitTest :: UnitTestOptions -> Contracts -> Maybe FilePath -> IO Bool
unitTest UnitTestOptions
opts (Contracts Map Text SolcContract
cs) Maybe FilePath
cache' = do
  let unitTests :: [(Text, [(Test, [AbiType])])]
unitTests = Text -> [SolcContract] -> [(Text, [(Test, [AbiType])])]
findUnitTests UnitTestOptions
opts.match ([SolcContract] -> [(Text, [(Test, [AbiType])])])
-> [SolcContract] -> [(Text, [(Test, [AbiType])])]
forall a b. (a -> b) -> a -> b
$ Map Text SolcContract -> [SolcContract]
forall k a. Map k a -> [a]
Map.elems Map Text SolcContract
cs
  [(Bool, VM)]
results <- ((Text, [(Test, [AbiType])]) -> IO [(Bool, VM)])
-> [(Text, [(Test, [AbiType])])] -> IO [(Bool, VM)]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (UnitTestOptions
-> Map Text SolcContract
-> (Text, [(Test, [AbiType])])
-> IO [(Bool, VM)]
runUnitTestContract UnitTestOptions
opts Map Text SolcContract
cs) [(Text, [(Test, [AbiType])])]
unitTests
  let ([Bool]
passing, [VM]
vms) = [(Bool, VM)] -> ([Bool], [VM])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Bool, VM)]
results
  case Maybe FilePath
cache' of
    Maybe FilePath
Nothing ->
      () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just FilePath
path ->
      -- merge all of the post-vm caches and save into the state
      let
        evmcache :: Cache
evmcache = [Cache] -> Cache
forall a. Monoid a => [a] -> a
mconcat [VM
vm.cache | VM
vm <- [VM]
vms]
      in
        IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RepoAt -> Set Fact -> IO ()
Git.saveFacts (FilePath -> RepoAt
Git.RepoAt FilePath
path) (Cache -> Set Fact
Facts.cacheFacts Cache
evmcache)

  Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
passing


-- | Assuming a constructor is loaded, this stepper will run the constructor
-- to create the test contract, give it an initial balance, and run `setUp()'.
initializeUnitTest :: UnitTestOptions -> SolcContract -> Stepper ()
initializeUnitTest :: UnitTestOptions -> SolcContract -> Stepper ()
initializeUnitTest UnitTestOptions
opts SolcContract
theContract = do

  let addr :: Index (Map Addr Contract)
addr = UnitTestOptions
opts.testParams.address

  EVM () -> Stepper ()
forall a. EVM a -> Stepper a
Stepper.evm (EVM () -> Stepper ()) -> EVM () -> Stepper ()
forall a b. (a -> b) -> a -> b
$ do
    -- Maybe modify the initial VM, e.g. to load library code
    (VM -> VM) -> EVM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify UnitTestOptions
opts.vmModifier
    -- Make a trace entry for running the constructor
    TraceData -> EVM ()
pushTrace (Text -> TraceData
EntryTrace Text
"constructor")

  -- Constructor is loaded; run until it returns code
  ProgramT Action Identity (Either EvmError (Expr 'Buf))
-> Stepper ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ProgramT Action Identity (Either EvmError (Expr 'Buf))
Stepper.execFully

  EVM () -> Stepper ()
forall a. EVM a -> Stepper a
Stepper.evm (EVM () -> Stepper ()) -> EVM () -> Stepper ()
forall a b. (a -> b) -> a -> b
$ do
    -- Give a balance to the test target
    #env % #contracts % ix addr % #balance %= (+ opts.testParams.balanceCreate)

    -- call setUp(), if it exists, to initialize the test contract
    let theAbi = theContract.abiMap
        setUp  = abiKeccak (encodeUtf8 "setUp()")

    when (isJust (Map.lookup setUp theAbi)) $ do
      abiCall opts.testParams (Left ("setUp()", emptyAbi))
      popTrace
      pushTrace (EntryTrace "setUp()")

  -- Let `setUp()' run to completion
  Either EvmError (Expr 'Buf)
res <- ProgramT Action Identity (Either EvmError (Expr 'Buf))
Stepper.execFully
  EVM () -> Stepper ()
forall a. EVM a -> Stepper a
Stepper.evm (EVM () -> Stepper ()) -> EVM () -> Stepper ()
forall a b. (a -> b) -> a -> b
$ case Either EvmError (Expr 'Buf)
res of
    Left EvmError
e -> TraceData -> EVM ()
pushTrace (EvmError -> TraceData
ErrorTrace EvmError
e)
    Either EvmError (Expr 'Buf)
_ -> EVM ()
popTrace

-- | Assuming a test contract is loaded and initialized, this stepper
-- will run the specified test method and return whether it succeeded.
runUnitTest :: UnitTestOptions -> ABIMethod -> AbiValue -> Stepper Bool
runUnitTest :: UnitTestOptions -> Text -> AbiValue -> Stepper Bool
runUnitTest UnitTestOptions
a Text
method AbiValue
args = do
  Bool
x <- UnitTestOptions -> Text -> AbiValue -> Stepper Bool
execTestStepper UnitTestOptions
a Text
method AbiValue
args
  UnitTestOptions -> Text -> Bool -> Stepper Bool
checkFailures UnitTestOptions
a Text
method Bool
x

execTestStepper :: UnitTestOptions -> ABIMethod -> AbiValue -> Stepper Bool
execTestStepper :: UnitTestOptions -> Text -> AbiValue -> Stepper Bool
execTestStepper UnitTestOptions { Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
.. } Text
methodName' AbiValue
method = do
  -- Set up the call to the test method
  EVM () -> Stepper ()
forall a. EVM a -> Stepper a
Stepper.evm (EVM () -> Stepper ()) -> EVM () -> Stepper ()
forall a b. (a -> b) -> a -> b
$ do
    TestVMParams -> Either (Text, AbiValue) ByteString -> EVM ()
abiCall TestVMParams
testParams ((Text, AbiValue) -> Either (Text, AbiValue) ByteString
forall a b. a -> Either a b
Left (Text
methodName', AbiValue
method))
    TraceData -> EVM ()
pushTrace (Text -> TraceData
EntryTrace Text
methodName')
  -- Try running the test method
  ProgramT Action Identity (Either EvmError (Expr 'Buf))
Stepper.execFully ProgramT Action Identity (Either EvmError (Expr 'Buf))
-> (Either EvmError (Expr 'Buf) -> Stepper Bool) -> Stepper Bool
forall a b.
ProgramT Action Identity a
-> (a -> ProgramT Action Identity b) -> ProgramT Action Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
     -- If we failed, put the error in the trace.
    Left EvmError
e -> EVM () -> Stepper ()
forall a. EVM a -> Stepper a
Stepper.evm (TraceData -> EVM ()
pushTrace (EvmError -> TraceData
ErrorTrace EvmError
e) EVM () -> EVM () -> EVM ()
forall a b.
StateT VM Identity a
-> StateT VM Identity b -> StateT VM Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EVM ()
popTrace) Stepper () -> Stepper Bool -> Stepper Bool
forall a b.
ProgramT Action Identity a
-> ProgramT Action Identity b -> ProgramT Action Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Stepper Bool
forall a. a -> ProgramT Action Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Either EvmError (Expr 'Buf)
_ -> Bool -> Stepper Bool
forall a. a -> ProgramT Action Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

exploreStep :: UnitTestOptions -> ByteString -> Stepper Bool
exploreStep :: UnitTestOptions -> ByteString -> Stepper Bool
exploreStep UnitTestOptions{Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
..} ByteString
bs = do
  EVM () -> Stepper ()
forall a. EVM a -> Stepper a
Stepper.evm (EVM () -> Stepper ()) -> EVM () -> Stepper ()
forall a b. (a -> b) -> a -> b
$ do
    Map Addr Contract
cs <- Optic A_Lens NoIx VM VM (Map Addr Contract) (Map Addr Contract)
-> StateT VM Identity (Map Addr Contract)
forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use (Optic A_Lens NoIx VM VM Env Env
#env Optic A_Lens NoIx VM VM Env Env
-> Optic
     A_Lens NoIx Env Env (Map Addr Contract) (Map Addr Contract)
-> Optic A_Lens NoIx VM VM (Map Addr Contract) (Map Addr Contract)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx Env Env (Map Addr Contract) (Map Addr Contract)
#contracts)
    TestVMParams -> Either (Text, AbiValue) ByteString -> EVM ()
abiCall TestVMParams
testParams (ByteString -> Either (Text, AbiValue) ByteString
forall a b. b -> Either a b
Right ByteString
bs)
    let Method [(Text, AbiType)]
_ [(Text, AbiType)]
inputs Text
sig Text
_ Mutability
_ = Method -> Maybe Method -> Method
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Method
forall a. HasCallStack => FilePath -> a
internalError FilePath
"unknown abi call") (Maybe Method -> Method) -> Maybe Method -> Method
forall a b. (a -> b) -> a -> b
$ FunctionSelector -> Map FunctionSelector Method -> Maybe Method
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (W256 -> FunctionSelector
forall target source.
(HasCallStack, TryFrom source target, Show source, Typeable source,
 Typeable target) =>
source -> target
unsafeInto (W256 -> FunctionSelector) -> W256 -> FunctionSelector
forall a b. (a -> b) -> a -> b
$ ByteString -> W256
word (ByteString -> W256) -> ByteString -> W256
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
4 ByteString
bs) DappInfo
dapp.abiMap
        types :: [AbiType]
types = (Text, AbiType) -> AbiType
forall a b. (a, b) -> b
snd ((Text, AbiType) -> AbiType) -> [(Text, AbiType)] -> [AbiType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, AbiType)]
inputs
    let ?context = DappInfo -> Map Addr Contract -> DappContext
DappContext DappInfo
dapp Map Addr Contract
cs
    IxValue (Map Addr Contract)
this <- IxValue (Map Addr Contract)
-> Maybe (IxValue (Map Addr Contract))
-> IxValue (Map Addr Contract)
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> IxValue (Map Addr Contract)
forall a. HasCallStack => FilePath -> a
internalError FilePath
"unknown target") (Maybe (IxValue (Map Addr Contract))
 -> IxValue (Map Addr Contract))
-> StateT VM Identity (Maybe (IxValue (Map Addr Contract)))
-> StateT VM Identity (IxValue (Map Addr Contract))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Optic' A_Lens NoIx VM (Maybe (IxValue (Map Addr Contract)))
-> StateT VM Identity (Maybe (IxValue (Map Addr Contract)))
forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use (Optic A_Lens NoIx VM VM Env Env
#env Optic A_Lens NoIx VM VM Env Env
-> Optic
     A_Lens NoIx Env Env (Map Addr Contract) (Map Addr Contract)
-> Optic A_Lens NoIx VM VM (Map Addr Contract) (Map Addr Contract)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx Env Env (Map Addr Contract) (Map Addr Contract)
#contracts Optic A_Lens NoIx VM VM (Map Addr Contract) (Map Addr Contract)
-> Optic
     A_Lens
     NoIx
     (Map Addr Contract)
     (Map Addr Contract)
     (Maybe (IxValue (Map Addr Contract)))
     (Maybe (IxValue (Map Addr Contract)))
-> Optic' A_Lens NoIx VM (Maybe (IxValue (Map Addr Contract)))
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Index (Map Addr Contract)
-> Optic
     A_Lens
     NoIx
     (Map Addr Contract)
     (Map Addr Contract)
     (Maybe (IxValue (Map Addr Contract)))
     (Maybe (IxValue (Map Addr Contract)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at TestVMParams
testParams.address))
    let name :: Text
name = Text -> (SolcContract -> Text) -> Maybe SolcContract -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text -> Text
contractNamePart (Text -> Text) -> (SolcContract -> Text) -> SolcContract -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.contractName)) (Maybe SolcContract -> Text) -> Maybe SolcContract -> Text
forall a b. (a -> b) -> a -> b
$ ContractCode -> DappInfo -> Maybe SolcContract
lookupCode IxValue (Map Addr Contract)
this.contractcode DappInfo
dapp
    TraceData -> EVM ()
pushTrace (Text -> TraceData
EntryTrace (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sig Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
"," ((FilePath -> Text
pack (FilePath -> Text) -> (AbiType -> FilePath) -> AbiType -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbiType -> FilePath
forall a. Show a => a -> FilePath
show) (AbiType -> Text) -> [AbiType] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AbiType]
types) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (?context::DappContext) => [AbiType] -> Expr 'Buf -> Text
[AbiType] -> Expr 'Buf -> Text
showCall [AbiType]
types (ByteString -> Expr 'Buf
ConcreteBuf ByteString
bs)))
  -- Try running the test method
  ProgramT Action Identity (Either EvmError (Expr 'Buf))
Stepper.execFully ProgramT Action Identity (Either EvmError (Expr 'Buf))
-> (Either EvmError (Expr 'Buf) -> Stepper Bool) -> Stepper Bool
forall a b.
ProgramT Action Identity a
-> (a -> ProgramT Action Identity b) -> ProgramT Action Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
     -- If we failed, put the error in the trace.
    Left EvmError
e -> EVM () -> Stepper ()
forall a. EVM a -> Stepper a
Stepper.evm (TraceData -> EVM ()
pushTrace (EvmError -> TraceData
ErrorTrace EvmError
e) EVM () -> EVM () -> EVM ()
forall a b.
StateT VM Identity a
-> StateT VM Identity b -> StateT VM Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EVM ()
popTrace) Stepper () -> Stepper Bool -> Stepper Bool
forall a b.
ProgramT Action Identity a
-> ProgramT Action Identity b -> ProgramT Action Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Stepper Bool
forall a. a -> ProgramT Action Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Either EvmError (Expr 'Buf)
_ -> Bool -> Stepper Bool
forall a. a -> ProgramT Action Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

checkFailures :: UnitTestOptions -> ABIMethod -> Bool -> Stepper Bool
checkFailures :: UnitTestOptions -> Text -> Bool -> Stepper Bool
checkFailures UnitTestOptions { Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
.. } Text
method Bool
bailed = do
   -- Decide whether the test is supposed to fail or succeed
  let shouldFail :: Bool
shouldFail = Text
"testFail" Text -> Text -> Bool
`isPrefixOf` Text
method
  if Bool
bailed then
    Bool -> Stepper Bool
forall a. a -> ProgramT Action Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
shouldFail
  else do
    -- Ask whether any assertions failed
    EVM () -> Stepper ()
forall a. EVM a -> Stepper a
Stepper.evm (EVM () -> Stepper ()) -> EVM () -> Stepper ()
forall a b. (a -> b) -> a -> b
$ do
      EVM ()
popTrace
      TestVMParams -> Either (Text, AbiValue) ByteString -> EVM ()
abiCall TestVMParams
testParams (Either (Text, AbiValue) ByteString -> EVM ())
-> Either (Text, AbiValue) ByteString -> EVM ()
forall a b. (a -> b) -> a -> b
$ (Text, AbiValue) -> Either (Text, AbiValue) ByteString
forall a b. a -> Either a b
Left (Text
"failed()", AbiValue
emptyAbi)
    Either EvmError (Expr 'Buf)
res <- ProgramT Action Identity (Either EvmError (Expr 'Buf))
Stepper.execFully
    case Either EvmError (Expr 'Buf)
res of
      Right (ConcreteBuf ByteString
r) ->
        let failed :: Bool
failed = case AbiType -> ByteString -> AbiValue
decodeAbiValue AbiType
AbiBoolType (ByteString -> ByteString
BSLazy.fromStrict ByteString
r) of
              AbiBool Bool
f -> Bool
f
              AbiValue
_ -> FilePath -> Bool
forall a. HasCallStack => FilePath -> a
internalError FilePath
"fix me with better types"
        in Bool -> Stepper Bool
forall a. a -> ProgramT Action Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
shouldFail Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
failed)
      Either EvmError (Expr 'Buf)
c -> FilePath -> Stepper Bool
forall a. HasCallStack => FilePath -> a
internalError (FilePath -> Stepper Bool) -> FilePath -> Stepper Bool
forall a b. (a -> b) -> a -> b
$ FilePath
"unexpected failure code: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Either EvmError (Expr 'Buf) -> FilePath
forall a. Show a => a -> FilePath
show Either EvmError (Expr 'Buf)
c

-- | Randomly generates the calldata arguments and runs the test
fuzzTest :: UnitTestOptions -> Text -> [AbiType] -> VM -> Property
fuzzTest :: UnitTestOptions -> Text -> [AbiType] -> VM -> Property
fuzzTest opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
..} Text
sig [AbiType]
types VM
vm = Gen AbiValue
-> (AbiValue -> FilePath) -> (AbiValue -> Property) -> Property
forall prop a.
Testable prop =>
Gen a -> (a -> FilePath) -> (a -> prop) -> Property
forAllShow (AbiType -> Gen AbiValue
genAbiValue (Vector AbiType -> AbiType
AbiTupleType (Vector AbiType -> AbiType) -> Vector AbiType -> AbiType
forall a b. (a -> b) -> a -> b
$ [AbiType] -> Vector AbiType
forall a. [a] -> Vector a
Vector.fromList [AbiType]
types)) (ByteStringS -> FilePath
forall a. Show a => a -> FilePath
show (ByteStringS -> FilePath)
-> (AbiValue -> ByteStringS) -> AbiValue -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteStringS
ByteStringS (ByteString -> ByteStringS)
-> (AbiValue -> ByteString) -> AbiValue -> ByteStringS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbiValue -> ByteString
encodeAbiValue)
  ((AbiValue -> Property) -> Property)
-> (AbiValue -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \AbiValue
args -> IO Bool -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Bool -> Property) -> IO Bool -> Property
forall a b. (a -> b) -> a -> b
$
    Fetcher -> VM -> Stepper Bool -> IO Bool
forall a. Fetcher -> VM -> Stepper a -> IO a
EVM.Stepper.interpret (SolverGroup -> RpcInfo -> Fetcher
Fetch.oracle SolverGroup
solvers RpcInfo
rpcInfo) VM
vm (UnitTestOptions -> Text -> AbiValue -> Stepper Bool
runUnitTest UnitTestOptions
opts Text
sig AbiValue
args)

tick :: Text -> IO ()
tick :: Text -> IO ()
tick Text
x = Text -> IO ()
Text.putStr Text
x IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout

-- | This is like an unresolved source mapping.
data OpLocation = OpLocation
  { OpLocation -> Contract
srcContract :: Contract
  , OpLocation -> Int
srcOpIx :: Int
  } deriving (Int -> OpLocation -> FilePath -> FilePath
[OpLocation] -> FilePath -> FilePath
OpLocation -> FilePath
(Int -> OpLocation -> FilePath -> FilePath)
-> (OpLocation -> FilePath)
-> ([OpLocation] -> FilePath -> FilePath)
-> Show OpLocation
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> OpLocation -> FilePath -> FilePath
showsPrec :: Int -> OpLocation -> FilePath -> FilePath
$cshow :: OpLocation -> FilePath
show :: OpLocation -> FilePath
$cshowList :: [OpLocation] -> FilePath -> FilePath
showList :: [OpLocation] -> FilePath -> FilePath
Show)

instance Eq OpLocation where
  == :: OpLocation -> OpLocation -> Bool
(==) (OpLocation Contract
a Int
b) (OpLocation Contract
a' Int
b') = Int
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
b' Bool -> Bool -> Bool
&& Contract
a.contractcode ContractCode -> ContractCode -> Bool
forall a. Eq a => a -> a -> Bool
== Contract
a'.contractcode

instance Ord OpLocation where
  compare :: OpLocation -> OpLocation -> Ordering
compare (OpLocation Contract
a Int
b) (OpLocation Contract
a' Int
b') = (ContractCode, Int) -> (ContractCode, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Contract
a.contractcode, Int
b) (Contract
a'.contractcode, Int
b')

srcMapForOpLocation :: DappInfo -> OpLocation -> Maybe SrcMap
srcMapForOpLocation :: DappInfo -> OpLocation -> Maybe SrcMap
srcMapForOpLocation DappInfo
dapp (OpLocation Contract
contr Int
opIx) = DappInfo -> Contract -> Int -> Maybe SrcMap
srcMap DappInfo
dapp Contract
contr Int
opIx

type CoverageState = (VM, MultiSet OpLocation)

currentOpLocation :: VM -> OpLocation
currentOpLocation :: VM -> OpLocation
currentOpLocation VM
vm =
  case VM -> Maybe Contract
currentContract VM
vm of
    Maybe Contract
Nothing ->
      FilePath -> OpLocation
forall a. HasCallStack => FilePath -> a
internalError FilePath
"why no contract?"
    Just Contract
c ->
      Contract -> Int -> OpLocation
OpLocation
        Contract
c
        (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Int
forall a. HasCallStack => FilePath -> a
internalError FilePath
"op ix") (VM -> Maybe Int
vmOpIx VM
vm))

execWithCoverage :: StateT CoverageState IO VMResult
execWithCoverage :: StateT CoverageState IO VMResult
execWithCoverage = do VM
_ <- StateT CoverageState IO VM
runWithCoverage
                      Maybe VMResult -> VMResult
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe VMResult -> VMResult)
-> StateT CoverageState IO (Maybe VMResult)
-> StateT CoverageState IO VMResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Optic' A_Lens NoIx CoverageState (Maybe VMResult)
-> StateT CoverageState IO (Maybe VMResult)
forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use (Lens CoverageState CoverageState VM VM
forall s t a b. Field1 s t a b => Lens s t a b
_1 Lens CoverageState CoverageState VM VM
-> Optic A_Lens NoIx VM VM (Maybe VMResult) (Maybe VMResult)
-> Optic' A_Lens NoIx CoverageState (Maybe VMResult)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx VM VM (Maybe VMResult) (Maybe VMResult)
#result)

runWithCoverage :: StateT CoverageState IO VM
runWithCoverage :: StateT CoverageState IO VM
runWithCoverage = do
  -- This is just like `exec` except for every instruction evaluated,
  -- we also increment a counter indexed by the current code location.
  VM
vm0 <- Lens CoverageState CoverageState VM VM
-> StateT CoverageState IO VM
forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use Lens CoverageState CoverageState VM VM
forall s t a b. Field1 s t a b => Lens s t a b
_1
  case VM
vm0.result of
    Maybe VMResult
Nothing -> do
      VM
vm1 <- Lens CoverageState CoverageState VM VM
-> StateT VM IO VM -> StateT CoverageState IO VM
forall k (is :: IxList) c.
Is k A_Lens =>
Optic' k is CoverageState VM
-> StateT VM IO c -> StateT CoverageState IO c
forall (m :: * -> *) (n :: * -> *) s t k (is :: IxList) c.
(Zoom m n s t, Is k A_Lens) =>
Optic' k is t s -> m c -> n c
zoom Lens CoverageState CoverageState VM VM
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((VM -> ((), VM)) -> StateT VM IO ()
forall a. (VM -> (a, VM)) -> StateT VM IO a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
State.state (EVM () -> VM -> ((), VM)
forall s a. State s a -> s -> (a, s)
runState EVM ()
exec1) StateT VM IO () -> StateT VM IO VM -> StateT VM IO VM
forall a b. StateT VM IO a -> StateT VM IO b -> StateT VM IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT VM IO VM
forall s (m :: * -> *). MonadState s m => m s
get)
      Optic' A_Lens NoIx CoverageState (MultiSet OpLocation)
-> StateT (MultiSet OpLocation) IO () -> StateT CoverageState IO ()
forall k (is :: IxList) c.
Is k A_Lens =>
Optic' k is CoverageState (MultiSet OpLocation)
-> StateT (MultiSet OpLocation) IO c -> StateT CoverageState IO c
forall (m :: * -> *) (n :: * -> *) s t k (is :: IxList) c.
(Zoom m n s t, Is k A_Lens) =>
Optic' k is t s -> m c -> n c
zoom Optic' A_Lens NoIx CoverageState (MultiSet OpLocation)
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((MultiSet OpLocation -> MultiSet OpLocation)
-> StateT (MultiSet OpLocation) IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (OpLocation -> MultiSet OpLocation -> MultiSet OpLocation
forall a. Ord a => a -> MultiSet a -> MultiSet a
MultiSet.insert (VM -> OpLocation
currentOpLocation VM
vm1)))
      StateT CoverageState IO VM
runWithCoverage
    Just VMResult
_ -> VM -> StateT CoverageState IO VM
forall a. a -> StateT CoverageState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VM
vm0


interpretWithCoverage
  :: UnitTestOptions
  -> Stepper a
  -> StateT CoverageState IO a
interpretWithCoverage :: forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
..} =
  ProgramView Action a -> StateT CoverageState IO a
forall a. ProgramView Action a -> StateT CoverageState IO a
eval (ProgramView Action a -> StateT CoverageState IO a)
-> (Stepper a -> ProgramView Action a)
-> Stepper a
-> StateT CoverageState IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stepper a -> ProgramView Action a
forall (instr :: * -> *) a. Program instr a -> ProgramView instr a
Operational.view

  where
    eval
      :: Operational.ProgramView Stepper.Action a
      -> StateT CoverageState IO a

    eval :: forall a. ProgramView Action a -> StateT CoverageState IO a
eval (Operational.Return a
x) =
      a -> StateT CoverageState IO a
forall a. a -> StateT CoverageState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

    eval (Action b
action Operational.:>>= b -> ProgramT Action Identity a
k) =
      case Action b
action of
        Action b
Stepper.Exec ->
          StateT CoverageState IO VMResult
execWithCoverage StateT CoverageState IO VMResult
-> (VMResult -> StateT CoverageState IO a)
-> StateT CoverageState IO a
forall a b.
StateT CoverageState IO a
-> (a -> StateT CoverageState IO b) -> StateT CoverageState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnitTestOptions
-> ProgramT Action Identity a -> StateT CoverageState IO a
forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage UnitTestOptions
opts (ProgramT Action Identity a -> StateT CoverageState IO a)
-> (VMResult -> ProgramT Action Identity a)
-> VMResult
-> StateT CoverageState IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> ProgramT Action Identity a
VMResult -> ProgramT Action Identity a
k
        Action b
Stepper.Run ->
          StateT CoverageState IO VM
runWithCoverage StateT CoverageState IO VM
-> (VM -> StateT CoverageState IO a) -> StateT CoverageState IO a
forall a b.
StateT CoverageState IO a
-> (a -> StateT CoverageState IO b) -> StateT CoverageState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnitTestOptions
-> ProgramT Action Identity a -> StateT CoverageState IO a
forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage UnitTestOptions
opts (ProgramT Action Identity a -> StateT CoverageState IO a)
-> (VM -> ProgramT Action Identity a)
-> VM
-> StateT CoverageState IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> ProgramT Action Identity a
VM -> ProgramT Action Identity a
k
        Stepper.Wait (PleaseAskSMT (Lit W256
c) [Prop]
_ BranchCondition -> EVM ()
continue) ->
          UnitTestOptions
-> ProgramT Action Identity a -> StateT CoverageState IO a
forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage UnitTestOptions
opts (EVM () -> Stepper ()
forall a. EVM a -> Stepper a
Stepper.evm (BranchCondition -> EVM ()
continue (Bool -> BranchCondition
Case (W256
c W256 -> W256 -> Bool
forall a. Ord a => a -> a -> Bool
> W256
0))) Stepper ()
-> (() -> ProgramT Action Identity a) -> ProgramT Action Identity a
forall a b.
ProgramT Action Identity a
-> (a -> ProgramT Action Identity b) -> ProgramT Action Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> ProgramT Action Identity a
() -> ProgramT Action Identity a
k)
        Stepper.Wait Query
q ->
          do EVM ()
m <- IO (EVM ()) -> StateT CoverageState IO (EVM ())
forall a. IO a -> StateT CoverageState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((SolverGroup -> RpcInfo -> Fetcher
Fetch.oracle SolverGroup
solvers RpcInfo
rpcInfo) Query
q)
             Lens CoverageState CoverageState VM VM
-> StateT VM IO () -> StateT CoverageState IO ()
forall k (is :: IxList) c.
Is k A_Lens =>
Optic' k is CoverageState VM
-> StateT VM IO c -> StateT CoverageState IO c
forall (m :: * -> *) (n :: * -> *) s t k (is :: IxList) c.
(Zoom m n s t, Is k A_Lens) =>
Optic' k is t s -> m c -> n c
zoom Lens CoverageState CoverageState VM VM
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((VM -> ((), VM)) -> StateT VM IO ()
forall a. (VM -> (a, VM)) -> StateT VM IO a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
State.state (EVM () -> VM -> ((), VM)
forall s a. State s a -> s -> (a, s)
runState EVM ()
m)) StateT CoverageState IO ()
-> StateT CoverageState IO a -> StateT CoverageState IO a
forall a b.
StateT CoverageState IO a
-> StateT CoverageState IO b -> StateT CoverageState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UnitTestOptions
-> ProgramT Action Identity a -> StateT CoverageState IO a
forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage UnitTestOptions
opts (b -> ProgramT Action Identity a
k ())
        Stepper.Ask Choose
_ ->
          FilePath -> StateT CoverageState IO a
forall a. HasCallStack => FilePath -> a
internalError FilePath
"cannot make choice in this interpreter"
        Stepper.IOAct StateT VM IO b
q ->
          Lens CoverageState CoverageState VM VM
-> StateT VM IO b -> StateT CoverageState IO b
forall k (is :: IxList) c.
Is k A_Lens =>
Optic' k is CoverageState VM
-> StateT VM IO c -> StateT CoverageState IO c
forall (m :: * -> *) (n :: * -> *) s t k (is :: IxList) c.
(Zoom m n s t, Is k A_Lens) =>
Optic' k is t s -> m c -> n c
zoom Lens CoverageState CoverageState VM VM
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((VM -> IO (b, VM)) -> StateT VM IO b
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT (StateT VM IO b -> VM -> IO (b, VM)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT VM IO b
q)) StateT CoverageState IO b
-> (b -> StateT CoverageState IO a) -> StateT CoverageState IO a
forall a b.
StateT CoverageState IO a
-> (a -> StateT CoverageState IO b) -> StateT CoverageState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnitTestOptions
-> ProgramT Action Identity a -> StateT CoverageState IO a
forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage UnitTestOptions
opts (ProgramT Action Identity a -> StateT CoverageState IO a)
-> (b -> ProgramT Action Identity a)
-> b
-> StateT CoverageState IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> ProgramT Action Identity a
k
        Stepper.EVM EVM b
m ->
          Lens CoverageState CoverageState VM VM
-> StateT VM IO b -> StateT CoverageState IO b
forall k (is :: IxList) c.
Is k A_Lens =>
Optic' k is CoverageState VM
-> StateT VM IO c -> StateT CoverageState IO c
forall (m :: * -> *) (n :: * -> *) s t k (is :: IxList) c.
(Zoom m n s t, Is k A_Lens) =>
Optic' k is t s -> m c -> n c
zoom Lens CoverageState CoverageState VM VM
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((VM -> (b, VM)) -> StateT VM IO b
forall a. (VM -> (a, VM)) -> StateT VM IO a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
State.state (EVM b -> VM -> (b, VM)
forall s a. State s a -> s -> (a, s)
runState EVM b
m)) StateT CoverageState IO b
-> (b -> StateT CoverageState IO a) -> StateT CoverageState IO a
forall a b.
StateT CoverageState IO a
-> (a -> StateT CoverageState IO b) -> StateT CoverageState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnitTestOptions
-> ProgramT Action Identity a -> StateT CoverageState IO a
forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage UnitTestOptions
opts (ProgramT Action Identity a -> StateT CoverageState IO a)
-> (b -> ProgramT Action Identity a)
-> b
-> StateT CoverageState IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> ProgramT Action Identity a
k

coverageReport
  :: DappInfo
  -> MultiSet SrcMap
  -> Map FilePath (Vector (Int, ByteString))
coverageReport :: DappInfo
-> MultiSet SrcMap -> Map FilePath (Vector (Int, ByteString))
coverageReport DappInfo
dapp MultiSet SrcMap
cov =
  let
    sources :: SourceCache
    sources :: SourceCache
sources = DappInfo
dapp.sources

    allPositions :: Set (FilePath, Int)
    allPositions :: Set (FilePath, Int)
allPositions =
      ( [(FilePath, Int)] -> Set (FilePath, Int)
forall a. Ord a => [a] -> Set a
Set.fromList
      ([(FilePath, Int)] -> Set (FilePath, Int))
-> (Seq SrcMap -> [(FilePath, Int)])
-> Seq SrcMap
-> Set (FilePath, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SrcMap -> Maybe (FilePath, Int)) -> [SrcMap] -> [(FilePath, Int)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SourceCache -> SrcMap -> Maybe (FilePath, Int)
srcMapCodePos SourceCache
sources)
      ([SrcMap] -> [(FilePath, Int)])
-> (Seq SrcMap -> [SrcMap]) -> Seq SrcMap -> [(FilePath, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq SrcMap -> [SrcMap]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
      (Seq SrcMap -> Set (FilePath, Int))
-> Seq SrcMap -> Set (FilePath, Int)
forall a b. (a -> b) -> a -> b
$ [Seq SrcMap] -> Seq SrcMap
forall a. Monoid a => [a] -> a
mconcat
        ( DappInfo
dapp.solcByName
        Map Text SolcContract
-> (Map Text SolcContract -> [SolcContract]) -> [SolcContract]
forall a b. a -> (a -> b) -> b
& Map Text SolcContract -> [SolcContract]
forall k a. Map k a -> [a]
Map.elems
        [SolcContract] -> ([SolcContract] -> [Seq SrcMap]) -> [Seq SrcMap]
forall a b. a -> (a -> b) -> b
& (SolcContract -> Seq SrcMap) -> [SolcContract] -> [Seq SrcMap]
forall a b. (a -> b) -> [a] -> [b]
map (\SolcContract
x -> SolcContract
x.runtimeSrcmap Seq SrcMap -> Seq SrcMap -> Seq SrcMap
forall a. Semigroup a => a -> a -> a
<> SolcContract
x.creationSrcmap)
        )
      )

    srcMapCov :: MultiSet (FilePath, Int)
    srcMapCov :: MultiSet (FilePath, Int)
srcMapCov = (SrcMap -> Maybe (FilePath, Int))
-> MultiSet SrcMap -> MultiSet (FilePath, Int)
forall b a. Ord b => (a -> Maybe b) -> MultiSet a -> MultiSet b
MultiSet.mapMaybe (SourceCache -> SrcMap -> Maybe (FilePath, Int)
srcMapCodePos SourceCache
sources) MultiSet SrcMap
cov

    linesByName :: Map FilePath (Vector ByteString)
    linesByName :: Map FilePath (Vector ByteString)
linesByName =
      [(FilePath, Vector ByteString)] -> Map FilePath (Vector ByteString)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(FilePath, Vector ByteString)]
 -> Map FilePath (Vector ByteString))
-> [(FilePath, Vector ByteString)]
-> Map FilePath (Vector ByteString)
forall a b. (a -> b) -> a -> b
$ ((FilePath, ByteString)
 -> Vector ByteString -> (FilePath, Vector ByteString))
-> [(FilePath, ByteString)]
-> [Vector ByteString]
-> [(FilePath, Vector ByteString)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
          (\(FilePath
name, ByteString
_) Vector ByteString
lines' -> (FilePath
name, Vector ByteString
lines'))
          (Map Int (FilePath, ByteString) -> [(FilePath, ByteString)]
forall k a. Map k a -> [a]
Map.elems SourceCache
sources.files)
          (Map Int (Vector ByteString) -> [Vector ByteString]
forall k a. Map k a -> [a]
Map.elems SourceCache
sources.lines)

    f :: FilePath -> Vector ByteString -> Vector (Int, ByteString)
    f :: FilePath -> Vector ByteString -> Vector (Int, ByteString)
f FilePath
name =
      (Int -> ByteString -> (Int, ByteString))
-> Vector ByteString -> Vector (Int, ByteString)
forall a b. (Int -> a -> b) -> Vector a -> Vector b
Vector.imap
        (\Int
i ByteString
bs ->
           let
             n :: Int
n =
               if (FilePath, Int) -> Set (FilePath, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (FilePath
name, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Set (FilePath, Int)
allPositions
               then (FilePath, Int) -> MultiSet (FilePath, Int) -> Int
forall a. Ord a => a -> MultiSet a -> Int
MultiSet.occur (FilePath
name, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) MultiSet (FilePath, Int)
srcMapCov
               else -Int
1
           in (Int
n, ByteString
bs))
  in
    (FilePath -> Vector ByteString -> Vector (Int, ByteString))
-> Map FilePath (Vector ByteString)
-> Map FilePath (Vector (Int, ByteString))
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey FilePath -> Vector ByteString -> Vector (Int, ByteString)
f Map FilePath (Vector ByteString)
linesByName

coverageForUnitTestContract
  :: UnitTestOptions
  -> Map Text SolcContract
  -> SourceCache
  -> (Text, [(Test, [AbiType])])
  -> IO (MultiSet SrcMap)
coverageForUnitTestContract :: UnitTestOptions
-> Map Text SolcContract
-> SourceCache
-> (Text, [(Test, [AbiType])])
-> IO (MultiSet SrcMap)
coverageForUnitTestContract
  opts :: UnitTestOptions
opts@(UnitTestOptions {Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
..}) Map Text SolcContract
contractMap SourceCache
_ (Text
name, [(Test, [AbiType])]
testNames) = do

  -- Look for the wanted contract by name from the Solidity info
  case Text -> Map Text SolcContract -> Maybe SolcContract
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text SolcContract
contractMap of
    Maybe SolcContract
Nothing ->
      -- Fail if there's no such contract
      FilePath -> IO (MultiSet SrcMap)
forall a. HasCallStack => FilePath -> a
internalError (FilePath -> IO (MultiSet SrcMap))
-> FilePath -> IO (MultiSet SrcMap)
forall a b. (a -> b) -> a -> b
$ FilePath
"Contract " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
unpack Text
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" not found"

    Just SolcContract
theContract -> do
      -- Construct the initial VM and begin the contract's constructor
      let vm0 :: VM
vm0 = UnitTestOptions -> SolcContract -> VM
initialUnitTestVm UnitTestOptions
opts SolcContract
theContract
      (VM
vm1, MultiSet OpLocation
cov1) <-
        StateT CoverageState IO () -> CoverageState -> IO CoverageState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT
          (UnitTestOptions -> Stepper () -> StateT CoverageState IO ()
forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage UnitTestOptions
opts
            (Text -> Stepper ()
Stepper.enter Text
name Stepper () -> Stepper () -> Stepper ()
forall a b.
ProgramT Action Identity a
-> ProgramT Action Identity b -> ProgramT Action Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UnitTestOptions -> SolcContract -> Stepper ()
initializeUnitTest UnitTestOptions
opts SolcContract
theContract))
          (VM
vm0, MultiSet OpLocation
forall a. Monoid a => a
mempty)

      -- Define the thread spawner for test cases
      let
        runOne' :: (Test, [AbiType]) -> ParIO (IVar (MultiSet OpLocation))
runOne' (Test
test, [AbiType]
_) = ParIO (MultiSet OpLocation) -> ParIO (IVar (MultiSet OpLocation))
forall a. ParIO a -> ParIO (IVar a)
forall (future :: * -> *) (m :: * -> *) a.
ParFuture future m =>
m a -> m (future a)
spawn_ (ParIO (MultiSet OpLocation) -> ParIO (IVar (MultiSet OpLocation)))
-> (IO (MultiSet OpLocation) -> ParIO (MultiSet OpLocation))
-> IO (MultiSet OpLocation)
-> ParIO (IVar (MultiSet OpLocation))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (MultiSet OpLocation) -> ParIO (MultiSet OpLocation)
forall a. IO a -> ParIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MultiSet OpLocation) -> ParIO (IVar (MultiSet OpLocation)))
-> IO (MultiSet OpLocation) -> ParIO (IVar (MultiSet OpLocation))
forall a b. (a -> b) -> a -> b
$ do
          (Bool
_, (VM
_, MultiSet OpLocation
cov)) <-
            StateT CoverageState IO Bool
-> CoverageState -> IO (Bool, CoverageState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
              (UnitTestOptions -> Stepper Bool -> StateT CoverageState IO Bool
forall a. UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage UnitTestOptions
opts (UnitTestOptions -> Text -> AbiValue -> Stepper Bool
runUnitTest UnitTestOptions
opts (Test -> Text
extractSig Test
test) AbiValue
emptyAbi))
              (VM
vm1, MultiSet OpLocation
forall a. Monoid a => a
mempty)
          MultiSet OpLocation -> IO (MultiSet OpLocation)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MultiSet OpLocation
cov
      -- Run all the test cases in parallel and gather their coverages
      [MultiSet OpLocation]
covs <-
        ParIO [MultiSet OpLocation] -> IO [MultiSet OpLocation]
forall a. ParIO a -> IO a
runParIO (((Test, [AbiType]) -> ParIO (IVar (MultiSet OpLocation)))
-> [(Test, [AbiType])] -> ParIO [IVar (MultiSet OpLocation)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Test, [AbiType]) -> ParIO (IVar (MultiSet OpLocation))
runOne' [(Test, [AbiType])]
testNames ParIO [IVar (MultiSet OpLocation)]
-> ([IVar (MultiSet OpLocation)] -> ParIO [MultiSet OpLocation])
-> ParIO [MultiSet OpLocation]
forall a b. ParIO a -> (a -> ParIO b) -> ParIO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IVar (MultiSet OpLocation) -> ParIO (MultiSet OpLocation))
-> [IVar (MultiSet OpLocation)] -> ParIO [MultiSet OpLocation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM IVar (MultiSet OpLocation) -> ParIO (MultiSet OpLocation)
forall a. IVar a -> ParIO a
forall (future :: * -> *) (m :: * -> *) a.
ParFuture future m =>
future a -> m a
Par.get)

      -- Sum up all the coverage counts
      let cov2 :: MultiSet OpLocation
cov2 = [MultiSet OpLocation] -> MultiSet OpLocation
forall a. Ord a => [MultiSet a] -> MultiSet a
MultiSet.unions (MultiSet OpLocation
cov1 MultiSet OpLocation
-> [MultiSet OpLocation] -> [MultiSet OpLocation]
forall a. a -> [a] -> [a]
: [MultiSet OpLocation]
covs)

      MultiSet SrcMap -> IO (MultiSet SrcMap)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((OpLocation -> Maybe SrcMap)
-> MultiSet OpLocation -> MultiSet SrcMap
forall b a. Ord b => (a -> Maybe b) -> MultiSet a -> MultiSet b
MultiSet.mapMaybe (DappInfo -> OpLocation -> Maybe SrcMap
srcMapForOpLocation DappInfo
dapp) MultiSet OpLocation
cov2)

runUnitTestContract
  :: UnitTestOptions
  -> Map Text SolcContract
  -> (Text, [(Test, [AbiType])])
  -> IO [(Bool, VM)]
runUnitTestContract :: UnitTestOptions
-> Map Text SolcContract
-> (Text, [(Test, [AbiType])])
-> IO [(Bool, VM)]
runUnitTestContract
  opts :: UnitTestOptions
opts@(UnitTestOptions {Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
..}) Map Text SolcContract
contractMap (Text
name, [(Test, [AbiType])]
testSigs) = do

  -- Print a header
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Running " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show ([(Test, [AbiType])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Test, [AbiType])]
testSigs) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" tests for "
    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
unpack Text
name

  -- Look for the wanted contract by name from the Solidity info
  case Text -> Map Text SolcContract -> Maybe SolcContract
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text SolcContract
contractMap of
    Maybe SolcContract
Nothing ->
      -- Fail if there's no such contract
      FilePath -> IO [(Bool, VM)]
forall a. HasCallStack => FilePath -> a
internalError (FilePath -> IO [(Bool, VM)]) -> FilePath -> IO [(Bool, VM)]
forall a b. (a -> b) -> a -> b
$ FilePath
"Contract " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
unpack Text
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" not found"

    Just SolcContract
theContract -> do
      -- Construct the initial VM and begin the contract's constructor
      let vm0 :: VM
vm0 = UnitTestOptions -> SolcContract -> VM
initialUnitTestVm UnitTestOptions
opts SolcContract
theContract
      VM
vm1 <- IO VM -> IO VM
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO VM -> IO VM) -> IO VM -> IO VM
forall a b. (a -> b) -> a -> b
$ Fetcher -> VM -> Stepper VM -> IO VM
forall a. Fetcher -> VM -> Stepper a -> IO a
EVM.Stepper.interpret (SolverGroup -> RpcInfo -> Fetcher
Fetch.oracle SolverGroup
solvers RpcInfo
rpcInfo) VM
vm0 (Stepper VM -> IO VM) -> Stepper VM -> IO VM
forall a b. (a -> b) -> a -> b
$ do
        Text -> Stepper ()
Stepper.enter Text
name
        UnitTestOptions -> SolcContract -> Stepper ()
initializeUnitTest UnitTestOptions
opts SolcContract
theContract
        EVM VM -> Stepper VM
forall a. EVM a -> Stepper a
Stepper.evm EVM VM
forall s (m :: * -> *). MonadState s m => m s
get

      case VM
vm1.result of
        Just (VMFailure EvmError
_) -> IO [(Bool, VM)] -> IO [(Bool, VM)]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Bool, VM)] -> IO [(Bool, VM)])
-> IO [(Bool, VM)] -> IO [(Bool, VM)]
forall a b. (a -> b) -> a -> b
$ do
          Text -> IO ()
Text.putStrLn Text
"\x1b[31m[BAIL]\x1b[0m setUp() "
          Text -> IO ()
tick Text
"\n"
          Text -> IO ()
tick (FilePath -> Text
Data.Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
forall a. Show a => a -> FilePath
show (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ VM -> UnitTestOptions -> Text -> Text
failOutput VM
vm1 UnitTestOptions
opts Text
"setUp()")
          [(Bool, VM)] -> IO [(Bool, VM)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Bool
False, VM
vm1)]
        Just (VMSuccess Expr 'Buf
_) -> do
          let

            runCache :: ([(Either Text Text, VM)], VM) -> (Test, [AbiType])
                        -> IO ([(Either Text Text, VM)], VM)
            runCache :: ([(Either Text Text, VM)], VM)
-> (Test, [AbiType]) -> IO ([(Either Text Text, VM)], VM)
runCache ([(Either Text Text, VM)]
results, VM
vm) (Test
test, [AbiType]
types) = do
              (Text
t, Either Text Text
r, VM
vm') <- UnitTestOptions
-> VM -> (Test, [AbiType]) -> IO (Text, Either Text Text, VM)
runTest UnitTestOptions
opts VM
vm (Test
test, [AbiType]
types)
              IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn Text
t
              let vmCached :: VM
vmCached = VM
vm { $sel:cache:VM :: Cache
cache = VM
vm'.cache }
              ([(Either Text Text, VM)], VM) -> IO ([(Either Text Text, VM)], VM)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Either Text Text
r, VM
vm')(Either Text Text, VM)
-> [(Either Text Text, VM)] -> [(Either Text Text, VM)]
forall a. a -> [a] -> [a]
: [(Either Text Text, VM)]
results), VM
vmCached)

          -- Run all the test cases and print their status updates,
          -- accumulating the vm cache throughout
          ([(Either Text Text, VM)]
details, VM
_) <- (([(Either Text Text, VM)], VM)
 -> (Test, [AbiType]) -> IO ([(Either Text Text, VM)], VM))
-> ([(Either Text Text, VM)], VM)
-> [(Test, [AbiType])]
-> IO ([(Either Text Text, VM)], VM)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([(Either Text Text, VM)], VM)
-> (Test, [AbiType]) -> IO ([(Either Text Text, VM)], VM)
runCache ([], VM
vm1) [(Test, [AbiType])]
testSigs

          let running :: [Text]
running = [Text
x | (Right Text
x, VM
_) <- [(Either Text Text, VM)]
details]
          let bailing :: [Text]
bailing = [Text
x | (Left  Text
x, VM
_) <- [(Either Text Text, VM)]
details]

          IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Text -> IO ()
tick Text
"\n"
            Text -> IO ()
tick ([Text] -> Text
Text.unlines ((Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) [Text]
running))
            Text -> IO ()
tick ([Text] -> Text
Text.unlines [Text]
bailing)

          [(Bool, VM)] -> IO [(Bool, VM)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Either Text Text -> Bool
forall a b. Either a b -> Bool
isRight Either Text Text
r, VM
vm) | (Either Text Text
r, VM
vm) <- [(Either Text Text, VM)]
details]
        Maybe VMResult
_ -> FilePath -> IO [(Bool, VM)]
forall a. HasCallStack => FilePath -> a
internalError FilePath
"setUp() did not end with a result"


runTest :: UnitTestOptions -> VM -> (Test, [AbiType]) -> IO (Text, Either Text Text, VM)
runTest :: UnitTestOptions
-> VM -> (Test, [AbiType]) -> IO (Text, Either Text Text, VM)
runTest opts :: UnitTestOptions
opts@UnitTestOptions{} VM
vm (ConcreteTest Text
testName, []) = IO (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Text, Either Text Text, VM)
 -> IO (Text, Either Text Text, VM))
-> IO (Text, Either Text Text, VM)
-> IO (Text, Either Text Text, VM)
forall a b. (a -> b) -> a -> b
$ UnitTestOptions
-> VM -> Text -> AbiValue -> IO (Text, Either Text Text, VM)
runOne UnitTestOptions
opts VM
vm Text
testName AbiValue
emptyAbi
runTest opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
..} VM
vm (ConcreteTest Text
testName, [AbiType]
types) = IO (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Text, Either Text Text, VM)
 -> IO (Text, Either Text Text, VM))
-> IO (Text, Either Text Text, VM)
-> IO (Text, Either Text Text, VM)
forall a b. (a -> b) -> a -> b
$ case Maybe (Text, ByteString)
replay of
  Maybe (Text, ByteString)
Nothing ->
    UnitTestOptions
-> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM)
fuzzRun UnitTestOptions
opts VM
vm Text
testName [AbiType]
types
  Just (Text
sig, ByteString
callData) ->
    if Text
sig Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
testName
    then UnitTestOptions
-> VM -> Text -> AbiValue -> IO (Text, Either Text Text, VM)
runOne UnitTestOptions
opts VM
vm Text
testName (AbiValue -> IO (Text, Either Text Text, VM))
-> AbiValue -> IO (Text, Either Text Text, VM)
forall a b. (a -> b) -> a -> b
$
      AbiType -> ByteString -> AbiValue
decodeAbiValue (Vector AbiType -> AbiType
AbiTupleType ([AbiType] -> Vector AbiType
forall a. [a] -> Vector a
Vector.fromList [AbiType]
types)) ByteString
callData
    else UnitTestOptions
-> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM)
fuzzRun UnitTestOptions
opts VM
vm Text
testName [AbiType]
types
runTest opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
..} VM
vm (InvariantTest Text
testName, []) = IO (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Text, Either Text Text, VM)
 -> IO (Text, Either Text Text, VM))
-> IO (Text, Either Text Text, VM)
-> IO (Text, Either Text Text, VM)
forall a b. (a -> b) -> a -> b
$ case Maybe (Text, ByteString)
replay of
  Maybe (Text, ByteString)
Nothing -> UnitTestOptions
-> VM -> Text -> [ExploreTx] -> IO (Text, Either Text Text, VM)
exploreRun UnitTestOptions
opts VM
vm Text
testName []
  Just (Text
sig, ByteString
cds) ->
    if Text
sig Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
testName
    then UnitTestOptions
-> VM -> Text -> [ExploreTx] -> IO (Text, Either Text Text, VM)
exploreRun UnitTestOptions
opts VM
vm Text
testName (ByteString -> [ExploreTx]
decodeCalls ByteString
cds)
    else UnitTestOptions
-> VM -> Text -> [ExploreTx] -> IO (Text, Either Text Text, VM)
exploreRun UnitTestOptions
opts VM
vm Text
testName []
runTest UnitTestOptions
_ VM
_ (InvariantTest Text
_, [AbiType]
types) = FilePath -> IO (Text, Either Text Text, VM)
forall a. HasCallStack => FilePath -> a
internalError (FilePath -> IO (Text, Either Text Text, VM))
-> FilePath -> IO (Text, Either Text Text, VM)
forall a b. (a -> b) -> a -> b
$ FilePath
"invariant testing with arguments: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [AbiType] -> FilePath
forall a. Show a => a -> FilePath
show [AbiType]
types FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" is not implemented (yet!)"
runTest UnitTestOptions
opts VM
vm (SymbolicTest Text
testName, [AbiType]
types) = UnitTestOptions
-> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM)
symRun UnitTestOptions
opts VM
vm Text
testName [AbiType]
types

type ExploreTx = (Addr, Addr, ByteString, W256)

decodeCalls :: BSLazy.ByteString -> [ExploreTx]
decodeCalls :: ByteString -> [ExploreTx]
decodeCalls ByteString
b = [ExploreTx] -> Maybe [ExploreTx] -> [ExploreTx]
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> [ExploreTx]
forall a. HasCallStack => FilePath -> a
internalError FilePath
"could not decode replay data") (Maybe [ExploreTx] -> [ExploreTx])
-> Maybe [ExploreTx] -> [ExploreTx]
forall a b. (a -> b) -> a -> b
$ do
  List [RLP]
v <- ByteString -> Maybe RLP
rlpdecode (ByteString -> Maybe RLP) -> ByteString -> Maybe RLP
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSLazy.toStrict ByteString
b
  [ExploreTx] -> Maybe [ExploreTx]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ExploreTx] -> Maybe [ExploreTx])
-> [ExploreTx] -> Maybe [ExploreTx]
forall a b. (a -> b) -> a -> b
$ RLP -> ExploreTx
forall {a} {b}.
(TryFrom W256 a, TryFrom W256 b, Typeable a, Typeable b) =>
RLP -> (a, b, ByteString, W256)
unList (RLP -> ExploreTx) -> [RLP] -> [ExploreTx]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RLP]
v
  where
    unList :: RLP -> (a, b, ByteString, W256)
unList (List [BS ByteString
caller', BS ByteString
target, BS ByteString
cd, BS ByteString
ts]) =
      (W256 -> a
forall target source.
(HasCallStack, TryFrom source target, Show source, Typeable source,
 Typeable target) =>
source -> target
unsafeInto (ByteString -> W256
word ByteString
caller'), W256 -> b
forall target source.
(HasCallStack, TryFrom source target, Show source, Typeable source,
 Typeable target) =>
source -> target
unsafeInto (ByteString -> W256
word ByteString
target), ByteString
cd, ByteString -> W256
word ByteString
ts)
    unList RLP
_ = FilePath -> (a, b, ByteString, W256)
forall a. HasCallStack => FilePath -> a
internalError FilePath
"fix me with better types"

-- | Runs an invariant test, calls the invariant before execution begins
initialExplorationStepper :: UnitTestOptions -> ABIMethod -> [ExploreTx] -> [Addr] -> Int -> Stepper (Bool, RLP)
initialExplorationStepper :: UnitTestOptions
-> Text -> [ExploreTx] -> [Addr] -> Int -> Stepper (Bool, RLP)
initialExplorationStepper UnitTestOptions
opts'' Text
testName [ExploreTx]
replayData [Addr]
targets Int
i = do
  let history :: RLP
history = [RLP] -> RLP
List []
  Bool
x <- UnitTestOptions -> Text -> AbiValue -> Stepper Bool
runUnitTest UnitTestOptions
opts'' Text
testName AbiValue
emptyAbi
  if Bool
x
  then UnitTestOptions
-> Text
-> [ExploreTx]
-> [Addr]
-> RLP
-> Int
-> Stepper (Bool, RLP)
explorationStepper UnitTestOptions
opts'' Text
testName [ExploreTx]
replayData [Addr]
targets RLP
history Int
i
  else (Bool, RLP) -> Stepper (Bool, RLP)
forall a. a -> ProgramT Action Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, RLP
history)

explorationStepper :: UnitTestOptions -> ABIMethod -> [ExploreTx] -> [Addr] -> RLP -> Int -> Stepper (Bool, RLP)
explorationStepper :: UnitTestOptions
-> Text
-> [ExploreTx]
-> [Addr]
-> RLP
-> Int
-> Stepper (Bool, RLP)
explorationStepper UnitTestOptions
_ Text
_ [ExploreTx]
_ [Addr]
_ RLP
history Int
0  = (Bool, RLP) -> Stepper (Bool, RLP)
forall a. a -> ProgramT Action Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, RLP
history)
explorationStepper opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
..} Text
testName [ExploreTx]
replayData [Addr]
targets (List [RLP]
history) Int
i = do
 (Addr
caller', Addr
target, ByteString
cd, W256
timestamp') <-
   case Optic' An_AffineTraversal NoIx [ExploreTx] ExploreTx
-> [ExploreTx] -> Maybe ExploreTx
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Index [ExploreTx]
-> Optic'
     (IxKind [ExploreTx]) NoIx [ExploreTx] (IxValue [ExploreTx])
forall m. Ixed m => Index m -> Optic' (IxKind m) NoIx m (IxValue m)
ix (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) [ExploreTx]
replayData of
     Just ExploreTx
v -> ExploreTx -> ProgramT Action Identity ExploreTx
forall a. a -> ProgramT Action Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExploreTx
v
     Maybe ExploreTx
Nothing ->
      StateT VM IO ExploreTx -> ProgramT Action Identity ExploreTx
forall a. StateT VM IO a -> Stepper a
Stepper.evmIO (StateT VM IO ExploreTx -> ProgramT Action Identity ExploreTx)
-> StateT VM IO ExploreTx -> ProgramT Action Identity ExploreTx
forall a b. (a -> b) -> a -> b
$ do
       VM
vm <- StateT VM IO VM
forall s (m :: * -> *). MonadState s m => m s
get
       let cs :: Map Addr Contract
cs = VM
vm.env.contracts
           noCode :: r -> Bool
noCode r
c = case r
c.contractcode of
             RuntimeCode (ConcreteRuntimeCode ByteString
"") -> Bool
True
             RuntimeCode (SymbolicRuntimeCode Vector (Expr 'Byte)
c') -> Vector (Expr 'Byte) -> Bool
forall a. Vector a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Vector (Expr 'Byte)
c'
             ContractCode
_ -> Bool
False
           mutable :: r -> Bool
mutable r
m = r
m.mutability Mutability -> [Mutability] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Mutability
NonPayable, Mutability
Payable]
           knownAbis :: Map Addr SolcContract
           knownAbis :: Map Addr SolcContract
knownAbis =
             -- exclude contracts without code
             (SolcContract -> Bool)
-> Map Addr SolcContract -> Map Addr SolcContract
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool) -> (SolcContract -> Bool) -> SolcContract -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
BS.null (ByteString -> Bool)
-> (SolcContract -> ByteString) -> SolcContract -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.runtimeCode)) (Map Addr SolcContract -> Map Addr SolcContract)
-> Map Addr SolcContract -> Map Addr SolcContract
forall a b. (a -> b) -> a -> b
$
             -- exclude contracts without state changing functions
             (SolcContract -> Bool)
-> Map Addr SolcContract -> Map Addr SolcContract
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool) -> (SolcContract -> Bool) -> SolcContract -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map FunctionSelector Method -> Bool
forall a. Map FunctionSelector a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Map FunctionSelector Method -> Bool)
-> (SolcContract -> Map FunctionSelector Method)
-> SolcContract
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Method -> Bool)
-> Map FunctionSelector Method -> Map FunctionSelector Method
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Method -> Bool
forall {r}. HasField "mutability" r Mutability => r -> Bool
mutable (Map FunctionSelector Method -> Map FunctionSelector Method)
-> (SolcContract -> Map FunctionSelector Method)
-> SolcContract
-> Map FunctionSelector Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.abiMap)) (Map Addr SolcContract -> Map Addr SolcContract)
-> Map Addr SolcContract -> Map Addr SolcContract
forall a b. (a -> b) -> a -> b
$
             -- exclude testing abis
             (SolcContract -> Bool)
-> Map Addr SolcContract -> Map Addr SolcContract
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Maybe (IxValue (Map FunctionSelector Method)) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (IxValue (Map FunctionSelector Method)) -> Bool)
-> (SolcContract -> Maybe (IxValue (Map FunctionSelector Method)))
-> SolcContract
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic'
  (IxKind (Map FunctionSelector Method))
  NoIx
  (Map FunctionSelector Method)
  (IxValue (Map FunctionSelector Method))
-> Map FunctionSelector Method
-> Maybe (IxValue (Map FunctionSelector Method))
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview (Index (Map FunctionSelector Method)
-> Optic'
     (IxKind (Map FunctionSelector Method))
     NoIx
     (Map FunctionSelector Method)
     (IxValue (Map FunctionSelector Method))
forall m. Ixed m => Index m -> Optic' (IxKind m) NoIx m (IxValue m)
ix Index (Map FunctionSelector Method)
FunctionSelector
unitTestMarkerAbi) (Map FunctionSelector Method
 -> Maybe (IxValue (Map FunctionSelector Method)))
-> (SolcContract -> Map FunctionSelector Method)
-> SolcContract
-> Maybe (IxValue (Map FunctionSelector Method))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.abiMap)) (Map Addr SolcContract -> Map Addr SolcContract)
-> Map Addr SolcContract -> Map Addr SolcContract
forall a b. (a -> b) -> a -> b
$
             -- pick all contracts with known compiler artifacts
             (Maybe SolcContract -> SolcContract)
-> Map Addr (Maybe SolcContract) -> Map Addr SolcContract
forall a b. (a -> b) -> Map Addr a -> Map Addr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe SolcContract -> SolcContract
forall a. HasCallStack => Maybe a -> a
fromJust ((Maybe SolcContract -> Bool)
-> Map Addr (Maybe SolcContract) -> Map Addr (Maybe SolcContract)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Maybe SolcContract -> Bool
forall a. Maybe a -> Bool
isJust (Map Addr (Maybe SolcContract) -> Map Addr (Maybe SolcContract))
-> Map Addr (Maybe SolcContract) -> Map Addr (Maybe SolcContract)
forall a b. (a -> b) -> a -> b
$ [(Addr, Maybe SolcContract)] -> Map Addr (Maybe SolcContract)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Addr
addr, ContractCode -> DappInfo -> Maybe SolcContract
lookupCode Contract
c.contractcode DappInfo
dapp) | (Addr
addr, Contract
c)  <- Map Addr Contract -> [(Addr, Contract)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Addr Contract
cs])
           selected :: [(Addr, SolcContract)]
selected = [(Addr
addr,
                        SolcContract -> Maybe SolcContract -> SolcContract
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> SolcContract
forall a. HasCallStack => FilePath -> a
internalError (FilePath -> SolcContract) -> FilePath -> SolcContract
forall a b. (a -> b) -> a -> b
$ FilePath
"no src found for: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Addr -> FilePath
forall a. Show a => a -> FilePath
show Addr
addr) (Maybe SolcContract -> SolcContract)
-> Maybe SolcContract -> SolcContract
forall a b. (a -> b) -> a -> b
$
                          ContractCode -> DappInfo -> Maybe SolcContract
lookupCode (Contract -> Maybe Contract -> Contract
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Contract
forall a. HasCallStack => FilePath -> a
internalError (FilePath -> Contract) -> FilePath -> Contract
forall a b. (a -> b) -> a -> b
$ FilePath
"contract not found: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Addr -> FilePath
forall a. Show a => a -> FilePath
show Addr
addr) (Maybe Contract -> Contract) -> Maybe Contract -> Contract
forall a b. (a -> b) -> a -> b
$
                            Addr -> Map Addr Contract -> Maybe Contract
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Addr
addr Map Addr Contract
cs).contractcode DappInfo
dapp)
                       | Addr
addr  <- [Addr]
targets]
       -- go to IO and generate a random valid call to any known contract
       IO ExploreTx -> StateT VM IO ExploreTx
forall a. IO a -> StateT VM IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExploreTx -> StateT VM IO ExploreTx)
-> IO ExploreTx -> StateT VM IO ExploreTx
forall a b. (a -> b) -> a -> b
$ do
         -- select random contract
         (Addr
target, SolcContract
solcInfo) <- Gen (Addr, SolcContract) -> IO (Addr, SolcContract)
forall a. Gen a -> IO a
generate (Gen (Addr, SolcContract) -> IO (Addr, SolcContract))
-> Gen (Addr, SolcContract) -> IO (Addr, SolcContract)
forall a b. (a -> b) -> a -> b
$ [(Addr, SolcContract)] -> Gen (Addr, SolcContract)
forall a. [a] -> Gen a
elements (if [Addr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Addr]
targets then Map Addr SolcContract -> [(Addr, SolcContract)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Addr SolcContract
knownAbis else [(Addr, SolcContract)]
selected)
         -- choose a random mutable method
         (FunctionSelector
_, (Method [(Text, AbiType)]
_ [(Text, AbiType)]
inputs Text
sig Text
_ Mutability
_)) <- Gen (FunctionSelector, Method) -> IO (FunctionSelector, Method)
forall a. Gen a -> IO a
generate ([(FunctionSelector, Method)] -> Gen (FunctionSelector, Method)
forall a. [a] -> Gen a
elements ([(FunctionSelector, Method)] -> Gen (FunctionSelector, Method))
-> [(FunctionSelector, Method)] -> Gen (FunctionSelector, Method)
forall a b. (a -> b) -> a -> b
$ Map FunctionSelector Method -> [(FunctionSelector, Method)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map FunctionSelector Method -> [(FunctionSelector, Method)])
-> Map FunctionSelector Method -> [(FunctionSelector, Method)]
forall a b. (a -> b) -> a -> b
$ (Method -> Bool)
-> Map FunctionSelector Method -> Map FunctionSelector Method
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Method -> Bool
forall {r}. HasField "mutability" r Mutability => r -> Bool
mutable SolcContract
solcInfo.abiMap)
         let types :: [AbiType]
types = (Text, AbiType) -> AbiType
forall a b. (a, b) -> b
snd ((Text, AbiType) -> AbiType) -> [(Text, AbiType)] -> [AbiType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, AbiType)]
inputs
         -- set the caller to a random address with 90% probability, 10% known EOA address
         let knownEOAs :: [Addr]
knownEOAs = Map Addr Contract -> [Addr]
forall k a. Map k a -> [k]
Map.keys (Map Addr Contract -> [Addr]) -> Map Addr Contract -> [Addr]
forall a b. (a -> b) -> a -> b
$ (Contract -> Bool) -> Map Addr Contract -> Map Addr Contract
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Contract -> Bool
forall {r}. HasField "contractcode" r ContractCode => r -> Bool
noCode Map Addr Contract
cs
         AbiAddress Addr
caller' <-
           if [Addr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Addr]
knownEOAs
           then Gen AbiValue -> IO AbiValue
forall a. Gen a -> IO a
generate (Gen AbiValue -> IO AbiValue) -> Gen AbiValue -> IO AbiValue
forall a b. (a -> b) -> a -> b
$ AbiType -> Gen AbiValue
genAbiValue AbiType
AbiAddressType
           else Gen AbiValue -> IO AbiValue
forall a. Gen a -> IO a
generate (Gen AbiValue -> IO AbiValue) -> Gen AbiValue -> IO AbiValue
forall a b. (a -> b) -> a -> b
$ [(Int, Gen AbiValue)] -> Gen AbiValue
forall a. [(Int, Gen a)] -> Gen a
frequency
             [ (Int
90, AbiType -> Gen AbiValue
genAbiValue AbiType
AbiAddressType)
             , (Int
10, Addr -> AbiValue
AbiAddress (Addr -> AbiValue) -> Gen Addr -> Gen AbiValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Addr] -> Gen Addr
forall a. [a] -> Gen a
elements [Addr]
knownEOAs)
             ]
         -- make a call with random valid data to the function
         AbiValue
args <- Gen AbiValue -> IO AbiValue
forall a. Gen a -> IO a
generate (Gen AbiValue -> IO AbiValue) -> Gen AbiValue -> IO AbiValue
forall a b. (a -> b) -> a -> b
$ AbiType -> Gen AbiValue
genAbiValue (Vector AbiType -> AbiType
AbiTupleType (Vector AbiType -> AbiType) -> Vector AbiType -> AbiType
forall a b. (a -> b) -> a -> b
$ [AbiType] -> Vector AbiType
forall a. [a] -> Vector a
Vector.fromList [AbiType]
types)
         let cd :: ByteString
cd = Text -> AbiValue -> ByteString
abiMethod (Text
sig Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
"," ((FilePath -> Text
pack (FilePath -> Text) -> (AbiType -> FilePath) -> AbiType -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbiType -> FilePath
forall a. Show a => a -> FilePath
show) (AbiType -> Text) -> [AbiType] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AbiType]
types) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")") AbiValue
args
         -- increment timestamp with random amount
         W256
timepassed <- Word32 -> W256
forall target source. From source target => source -> target
into (Word32 -> W256) -> IO Word32 -> IO W256
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word32 -> IO Word32
forall a. Gen a -> IO a
generate (Gen Word32
forall a. Integral a => Gen a
arbitrarySizedNatural :: Gen Word32)
         let ts :: W256
ts = W256 -> Maybe W256 -> W256
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> W256
forall a. HasCallStack => FilePath -> a
internalError FilePath
"symbolic timestamp not supported here") (Maybe W256 -> W256) -> Maybe W256 -> W256
forall a b. (a -> b) -> a -> b
$ Expr 'EWord -> Maybe W256
maybeLitWord VM
vm.block.timestamp
         ExploreTx -> IO ExploreTx
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Addr
caller', Addr
target, ByteString
cd, W256 -> W256
forall target source. From source target => source -> target
into W256
ts W256 -> W256 -> W256
forall a. Num a => a -> a -> a
+ W256
timepassed)
 let opts' :: UnitTestOptions
opts' = UnitTestOptions
opts { $sel:testParams:UnitTestOptions :: TestVMParams
testParams = TestVMParams
testParams {$sel:address:TestVMParams :: Addr
address = Addr
target, $sel:caller:TestVMParams :: Addr
caller = Addr
caller', $sel:timestamp:TestVMParams :: W256
timestamp = W256
timestamp'}}
     thisCallRLP :: RLP
thisCallRLP = [RLP] -> RLP
List [ByteString -> RLP
BS (ByteString -> RLP) -> ByteString -> RLP
forall a b. (a -> b) -> a -> b
$ Addr -> ByteString
word160Bytes Addr
caller', ByteString -> RLP
BS (ByteString -> RLP) -> ByteString -> RLP
forall a b. (a -> b) -> a -> b
$ Addr -> ByteString
word160Bytes Addr
target, ByteString -> RLP
BS ByteString
cd, ByteString -> RLP
BS (ByteString -> RLP) -> ByteString -> RLP
forall a b. (a -> b) -> a -> b
$ W256 -> ByteString
word256Bytes W256
timestamp']
 -- set the timestamp
 EVM () -> Stepper ()
forall a. EVM a -> Stepper a
Stepper.evm (EVM () -> Stepper ()) -> EVM () -> Stepper ()
forall a b. (a -> b) -> a -> b
$ Optic A_Lens NoIx VM VM (Expr 'EWord) (Expr 'EWord)
-> Expr 'EWord -> EVM ()
forall k s (m :: * -> *) (is :: IxList) a b.
(Is k A_Setter, MonadState s m) =>
Optic k is s s a b -> b -> m ()
assign (Optic A_Lens NoIx VM VM Block Block
#block Optic A_Lens NoIx VM VM Block Block
-> Optic A_Lens NoIx Block Block (Expr 'EWord) (Expr 'EWord)
-> Optic A_Lens NoIx VM VM (Expr 'EWord) (Expr 'EWord)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx Block Block (Expr 'EWord) (Expr 'EWord)
#timestamp) (W256 -> Expr 'EWord
Lit W256
timestamp')
 -- perform the call
 Bool
bailed <- UnitTestOptions -> ByteString -> Stepper Bool
exploreStep UnitTestOptions
opts' ByteString
cd
 EVM () -> Stepper ()
forall a. EVM a -> Stepper a
Stepper.evm EVM ()
popTrace
 let newHistory :: RLP
newHistory = if Bool
bailed then [RLP] -> RLP
List [RLP]
history else [RLP] -> RLP
List (RLP
thisCallRLPRLP -> [RLP] -> [RLP]
forall a. a -> [a] -> [a]
:[RLP]
history)
     opts'' :: UnitTestOptions
opts'' = UnitTestOptions
opts {$sel:testParams:UnitTestOptions :: TestVMParams
testParams = TestVMParams
testParams {$sel:timestamp:TestVMParams :: W256
timestamp = W256
timestamp'}}
     carryOn :: Stepper (Bool, RLP)
carryOn = UnitTestOptions
-> Text
-> [ExploreTx]
-> [Addr]
-> RLP
-> Int
-> Stepper (Bool, RLP)
explorationStepper UnitTestOptions
opts'' Text
testName [ExploreTx]
replayData [Addr]
targets RLP
newHistory (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
 -- if we didn't revert, run the test function
 if Bool
bailed
 then Stepper (Bool, RLP)
carryOn
 else
   do Bool
x <- UnitTestOptions -> Text -> AbiValue -> Stepper Bool
runUnitTest UnitTestOptions
opts'' Text
testName AbiValue
emptyAbi
      if Bool
x
      then Stepper (Bool, RLP)
carryOn
      else (Bool, RLP) -> Stepper (Bool, RLP)
forall a. a -> ProgramT Action Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, [RLP] -> RLP
List (RLP
thisCallRLPRLP -> [RLP] -> [RLP]
forall a. a -> [a] -> [a]
:[RLP]
history))
explorationStepper UnitTestOptions
_ Text
_ [ExploreTx]
_ [Addr]
_ RLP
_ Int
_  = FilePath -> Stepper (Bool, RLP)
forall a. HasCallStack => FilePath -> a
internalError FilePath
"malformed rlp"

getTargetContracts :: UnitTestOptions -> Stepper [Addr]
getTargetContracts :: UnitTestOptions -> Stepper [Addr]
getTargetContracts UnitTestOptions{Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
..} = do
  VM
vm <- EVM VM -> Stepper VM
forall a. EVM a -> Stepper a
Stepper.evm EVM VM
forall s (m :: * -> *). MonadState s m => m s
get
  let contract' :: Contract
contract' = Maybe Contract -> Contract
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Contract -> Contract) -> Maybe Contract -> Contract
forall a b. (a -> b) -> a -> b
$ VM -> Maybe Contract
currentContract VM
vm
      theAbi :: Map FunctionSelector Method
theAbi = (Maybe SolcContract -> SolcContract
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe SolcContract -> SolcContract)
-> Maybe SolcContract -> SolcContract
forall a b. (a -> b) -> a -> b
$ ContractCode -> DappInfo -> Maybe SolcContract
lookupCode Contract
contract'.contractcode DappInfo
dapp).abiMap
      setUp :: FunctionSelector
setUp  = ByteString -> FunctionSelector
abiKeccak (Text -> ByteString
encodeUtf8 Text
"targetContracts()")
  case FunctionSelector -> Map FunctionSelector Method -> Maybe Method
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FunctionSelector
setUp Map FunctionSelector Method
theAbi of
    Maybe Method
Nothing -> [Addr] -> Stepper [Addr]
forall a. a -> ProgramT Action Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just Method
_ -> do
      EVM () -> Stepper ()
forall a. EVM a -> Stepper a
Stepper.evm (EVM () -> Stepper ()) -> EVM () -> Stepper ()
forall a b. (a -> b) -> a -> b
$ TestVMParams -> Either (Text, AbiValue) ByteString -> EVM ()
abiCall TestVMParams
testParams ((Text, AbiValue) -> Either (Text, AbiValue) ByteString
forall a b. a -> Either a b
Left (Text
"targetContracts()", AbiValue
emptyAbi))
      Either EvmError (Expr 'Buf)
res <- ProgramT Action Identity (Either EvmError (Expr 'Buf))
Stepper.execFully
      case Either EvmError (Expr 'Buf)
res of
        Right (ConcreteBuf ByteString
r) ->
          let vs :: Vector AbiValue
vs = case AbiType -> ByteString -> AbiValue
decodeAbiValue (Vector AbiType -> AbiType
AbiTupleType ([AbiType] -> Vector AbiType
forall a. [a] -> Vector a
Vector.fromList [AbiType -> AbiType
AbiArrayDynamicType AbiType
AbiAddressType])) (ByteString -> ByteString
BSLazy.fromStrict ByteString
r) of
                AbiTuple Vector AbiValue
v -> Vector AbiValue
v
                AbiValue
_ -> FilePath -> Vector AbiValue
forall a. HasCallStack => FilePath -> a
internalError FilePath
"fix me with better types"
              targets :: [Addr]
targets = case Vector AbiValue -> [AbiValue]
forall a. Vector a -> [a]
Vector.toList Vector AbiValue
vs of
                [AbiArrayDynamic AbiType
AbiAddressType Vector AbiValue
ts] ->
                  let unAbiAddress :: AbiValue -> Addr
unAbiAddress (AbiAddress Addr
a) = Addr
a
                      unAbiAddress AbiValue
_ = FilePath -> Addr
forall a. HasCallStack => FilePath -> a
internalError FilePath
"fix me with better types"
                  in AbiValue -> Addr
unAbiAddress (AbiValue -> Addr) -> [AbiValue] -> [Addr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector AbiValue -> [AbiValue]
forall a. Vector a -> [a]
Vector.toList Vector AbiValue
ts
                [AbiValue]
_ -> FilePath -> [Addr]
forall a. HasCallStack => FilePath -> a
internalError FilePath
"fix me with better types"
          in [Addr] -> Stepper [Addr]
forall a. a -> ProgramT Action Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Addr]
targets
        Either EvmError (Expr 'Buf)
_ -> FilePath -> Stepper [Addr]
forall a. HasCallStack => FilePath -> a
internalError FilePath
"internal error: unexpected failure code"

exploreRun :: UnitTestOptions -> VM -> ABIMethod -> [ExploreTx] -> IO (Text, Either Text Text, VM)
exploreRun :: UnitTestOptions
-> VM -> Text -> [ExploreTx] -> IO (Text, Either Text Text, VM)
exploreRun opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
..} VM
initialVm Text
testName [ExploreTx]
replayTxs = do
  let oracle :: Fetcher
oracle = SolverGroup -> RpcInfo -> Fetcher
Fetch.oracle SolverGroup
solvers RpcInfo
rpcInfo
  [Addr]
targets <- Fetcher -> VM -> Stepper [Addr] -> IO [Addr]
forall a. Fetcher -> VM -> Stepper a -> IO a
EVM.Stepper.interpret Fetcher
oracle VM
initialVm (UnitTestOptions -> Stepper [Addr]
getTargetContracts UnitTestOptions
opts)
  let depth :: Int
depth = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
20 Maybe Int
maxDepth
  ((Bool
x, RLP
counterex), VM
vm') <-
    if [ExploreTx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExploreTx]
replayTxs then
      (((Bool, RLP), VM) -> Int -> IO ((Bool, RLP), VM))
-> ((Bool, RLP), VM) -> [Int] -> IO ((Bool, RLP), VM)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\a :: ((Bool, RLP), VM)
a@((Bool
success, RLP
_),VM
_) Int
_ ->
               if Bool
success then
                 Fetcher -> VM -> Stepper ((Bool, RLP), VM) -> IO ((Bool, RLP), VM)
forall a. Fetcher -> VM -> Stepper a -> IO a
EVM.Stepper.interpret Fetcher
oracle VM
initialVm (Stepper ((Bool, RLP), VM) -> IO ((Bool, RLP), VM))
-> Stepper ((Bool, RLP), VM) -> IO ((Bool, RLP), VM)
forall a b. (a -> b) -> a -> b
$
                   (,) ((Bool, RLP) -> VM -> ((Bool, RLP), VM))
-> Stepper (Bool, RLP)
-> ProgramT Action Identity (VM -> ((Bool, RLP), VM))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitTestOptions
-> Text -> [ExploreTx] -> [Addr] -> Int -> Stepper (Bool, RLP)
initialExplorationStepper UnitTestOptions
opts Text
testName [] [Addr]
targets Int
depth
                       ProgramT Action Identity (VM -> ((Bool, RLP), VM))
-> Stepper VM -> Stepper ((Bool, RLP), VM)
forall a b.
ProgramT Action Identity (a -> b)
-> ProgramT Action Identity a -> ProgramT Action Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EVM VM -> Stepper VM
forall a. EVM a -> Stepper a
Stepper.evm EVM VM
forall s (m :: * -> *). MonadState s m => m s
get
               else ((Bool, RLP), VM) -> IO ((Bool, RLP), VM)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Bool, RLP), VM)
a)
            ((Bool
True, ([RLP] -> RLP
List [])), VM
initialVm)  -- no canonical "post vm"
            [Int
0..Int
fuzzRuns]
    else Fetcher -> VM -> Stepper ((Bool, RLP), VM) -> IO ((Bool, RLP), VM)
forall a. Fetcher -> VM -> Stepper a -> IO a
EVM.Stepper.interpret Fetcher
oracle VM
initialVm (Stepper ((Bool, RLP), VM) -> IO ((Bool, RLP), VM))
-> Stepper ((Bool, RLP), VM) -> IO ((Bool, RLP), VM)
forall a b. (a -> b) -> a -> b
$
      (,) ((Bool, RLP) -> VM -> ((Bool, RLP), VM))
-> Stepper (Bool, RLP)
-> ProgramT Action Identity (VM -> ((Bool, RLP), VM))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitTestOptions
-> Text -> [ExploreTx] -> [Addr] -> Int -> Stepper (Bool, RLP)
initialExplorationStepper UnitTestOptions
opts Text
testName [ExploreTx]
replayTxs [Addr]
targets ([ExploreTx] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ExploreTx]
replayTxs)
          ProgramT Action Identity (VM -> ((Bool, RLP), VM))
-> Stepper VM -> Stepper ((Bool, RLP), VM)
forall a b.
ProgramT Action Identity (a -> b)
-> ProgramT Action Identity a -> ProgramT Action Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EVM VM -> Stepper VM
forall a. EVM a -> Stepper a
Stepper.evm EVM VM
forall s (m :: * -> *). MonadState s m => m s
get
  if Bool
x
  then (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"\x1b[32m[PASS]\x1b[0m " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
testName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  Text
" (runs: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
fuzzRuns) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
", depth: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
depth) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")",
               Text -> Either Text Text
forall a b. b -> Either a b
Right (VM -> UnitTestOptions -> Text -> Text
passOutput VM
vm' UnitTestOptions
opts Text
testName), VM
vm') -- no canonical "post vm"
  else let replayText :: Text
replayText = if [ExploreTx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExploreTx]
replayTxs
                        then Text
"\nReplay data: '(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
pack (Text -> FilePath
forall a. Show a => a -> FilePath
show Text
testName) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
pack (FilePath -> FilePath
forall a. Show a => a -> FilePath
show (ByteStringS -> FilePath
forall a. Show a => a -> FilePath
show (ByteString -> ByteStringS
ByteStringS (ByteString -> ByteStringS) -> ByteString -> ByteStringS
forall a b. (a -> b) -> a -> b
$ RLP -> ByteString
rlpencode RLP
counterex))) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")'"
                        else Text
" (replayed)"
       in (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"\x1b[31m[FAIL]\x1b[0m " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
testName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
replayText, Text -> Either Text Text
forall a b. a -> Either a b
Left  (VM -> UnitTestOptions -> Text -> Text
failOutput VM
vm' UnitTestOptions
opts Text
testName), VM
vm')

execTest :: UnitTestOptions -> VM -> ABIMethod -> AbiValue -> IO (Bool, VM)
execTest :: UnitTestOptions -> VM -> Text -> AbiValue -> IO (Bool, VM)
execTest opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
..} VM
vm Text
testName AbiValue
args =
  Fetcher -> VM -> Stepper (Bool, VM) -> IO (Bool, VM)
forall a. Fetcher -> VM -> Stepper a -> IO a
EVM.Stepper.interpret (SolverGroup -> RpcInfo -> Fetcher
Fetch.oracle SolverGroup
solvers RpcInfo
rpcInfo) VM
vm (Stepper (Bool, VM) -> IO (Bool, VM))
-> Stepper (Bool, VM) -> IO (Bool, VM)
forall a b. (a -> b) -> a -> b
$ do
    (,) (Bool -> VM -> (Bool, VM))
-> Stepper Bool -> ProgramT Action Identity (VM -> (Bool, VM))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitTestOptions -> Text -> AbiValue -> Stepper Bool
execTestStepper UnitTestOptions
opts Text
testName AbiValue
args
        ProgramT Action Identity (VM -> (Bool, VM))
-> Stepper VM -> Stepper (Bool, VM)
forall a b.
ProgramT Action Identity (a -> b)
-> ProgramT Action Identity a -> ProgramT Action Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EVM VM -> Stepper VM
forall a. EVM a -> Stepper a
Stepper.evm EVM VM
forall s (m :: * -> *). MonadState s m => m s
get

-- | Define the thread spawner for normal test cases
runOne :: UnitTestOptions -> VM -> ABIMethod -> AbiValue -> IO (Text, Either Text Text, VM)
runOne :: UnitTestOptions
-> VM -> Text -> AbiValue -> IO (Text, Either Text Text, VM)
runOne opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
..} VM
vm Text
testName AbiValue
args = do
  let argInfo :: Text
argInfo = FilePath -> Text
pack (if AbiValue
args AbiValue -> AbiValue -> Bool
forall a. Eq a => a -> a -> Bool
== AbiValue
emptyAbi then FilePath
"" else FilePath
" with arguments: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> AbiValue -> FilePath
forall a. Show a => a -> FilePath
show AbiValue
args)
  (Bool
bailed, VM
vm') <- UnitTestOptions -> VM -> Text -> AbiValue -> IO (Bool, VM)
execTest UnitTestOptions
opts VM
vm Text
testName AbiValue
args
  (Bool
success, VM
vm'') <- Fetcher -> VM -> Stepper (Bool, VM) -> IO (Bool, VM)
forall a. Fetcher -> VM -> Stepper a -> IO a
EVM.Stepper.interpret (SolverGroup -> RpcInfo -> Fetcher
Fetch.oracle SolverGroup
solvers RpcInfo
rpcInfo) VM
vm' (Stepper (Bool, VM) -> IO (Bool, VM))
-> Stepper (Bool, VM) -> IO (Bool, VM)
forall a b. (a -> b) -> a -> b
$ do
    (,) (Bool -> VM -> (Bool, VM))
-> Stepper Bool -> ProgramT Action Identity (VM -> (Bool, VM))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnitTestOptions -> Text -> Bool -> Stepper Bool
checkFailures UnitTestOptions
opts Text
testName Bool
bailed)
        ProgramT Action Identity (VM -> (Bool, VM))
-> Stepper VM -> Stepper (Bool, VM)
forall a b.
ProgramT Action Identity (a -> b)
-> ProgramT Action Identity a -> ProgramT Action Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EVM VM -> Stepper VM
forall a. EVM a -> Stepper a
Stepper.evm EVM VM
forall s (m :: * -> *). MonadState s m => m s
get
  if Bool
success
  then
     let gasSpent :: Word64
gasSpent = TestVMParams
testParams.gasCall Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- VM
vm'.state.gas
         gasText :: Text
gasText = FilePath -> Text
pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Integer -> FilePath
forall a. Show a => a -> FilePath
show (Word64 -> Integer
forall target source. From source target => source -> target
into Word64
gasSpent :: Integer)
     in
        (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          (Text
"\x1b[32m[PASS]\x1b[0m "
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
testName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
argInfo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (gas: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
gasText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
          , Text -> Either Text Text
forall a b. b -> Either a b
Right (VM -> UnitTestOptions -> Text -> Text
passOutput VM
vm'' UnitTestOptions
opts Text
testName)
          , VM
vm''
          )
  else if Bool
bailed then
        (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          (Text
"\x1b[31m[BAIL]\x1b[0m "
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
testName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
argInfo
          , Text -> Either Text Text
forall a b. a -> Either a b
Left (VM -> UnitTestOptions -> Text -> Text
failOutput VM
vm'' UnitTestOptions
opts Text
testName)
          , VM
vm''
          )
      else
        (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          (Text
"\x1b[31m[FAIL]\x1b[0m "
           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
testName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
argInfo
          , Text -> Either Text Text
forall a b. a -> Either a b
Left (VM -> UnitTestOptions -> Text -> Text
failOutput VM
vm'' UnitTestOptions
opts Text
testName)
          , VM
vm''
          )

-- | Define the thread spawner for property based tests
fuzzRun :: UnitTestOptions -> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM)
fuzzRun :: UnitTestOptions
-> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM)
fuzzRun opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
..} VM
vm Text
testName [AbiType]
types = do
  let args :: Args
args = Args{ replay :: Maybe (QCGen, Int)
replay          = Maybe (QCGen, Int)
forall a. Maybe a
Nothing
                 , maxSuccess :: Int
maxSuccess      = Int
fuzzRuns
                 , maxDiscardRatio :: Int
maxDiscardRatio = Int
10
                 , maxSize :: Int
maxSize         = Int
100
                 , chatty :: Bool
chatty          = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
verbose
                 , maxShrinks :: Int
maxShrinks      = Int
forall a. Bounded a => a
maxBound
                 }
  Args -> Property -> IO Result
forall prop. Testable prop => Args -> prop -> IO Result
quickCheckWithResult Args
args (UnitTestOptions -> Text -> [AbiType] -> VM -> Property
fuzzTest UnitTestOptions
opts Text
testName [AbiType]
types VM
vm) IO Result
-> (Result -> IO (Text, Either Text Text, VM))
-> IO (Text, Either Text Text, VM)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    QC.Success Int
numTests Int
_ Map [FilePath] Int
_ Map FilePath Int
_ Map FilePath (Map FilePath Int)
_ FilePath
_ ->
      (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"\x1b[32m[PASS]\x1b[0m "
             Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
testName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (runs: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
numTests) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
             -- this isn't the post vm we actually want, as we
             -- can't retrieve the correct vm from quickcheck
           , Text -> Either Text Text
forall a b. b -> Either a b
Right (VM -> UnitTestOptions -> Text -> Text
passOutput VM
vm UnitTestOptions
opts Text
testName)
           , VM
vm
           )
    QC.Failure Int
_ Int
_ Int
_ Int
_ Int
_ QCGen
_ Int
_ FilePath
_ Maybe AnException
_ FilePath
_ [FilePath]
failCase [FilePath]
_ Set FilePath
_ ->
      let abiValue :: AbiValue
abiValue = AbiType -> ByteString -> AbiValue
decodeAbiValue (Vector AbiType -> AbiType
AbiTupleType ([AbiType] -> Vector AbiType
forall a. [a] -> Vector a
Vector.fromList [AbiType]
types)) (ByteString -> AbiValue) -> ByteString -> AbiValue
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSLazy.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
hexText (FilePath -> Text
pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [FilePath]
failCase)
          ppOutput :: Text
ppOutput = FilePath -> Text
pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ AbiValue -> FilePath
forall a. Show a => a -> FilePath
show AbiValue
abiValue
      in do
        -- Run the failing test again to get a proper trace
        VM
vm' <- Fetcher -> VM -> Stepper VM -> IO VM
forall a. Fetcher -> VM -> Stepper a -> IO a
EVM.Stepper.interpret (SolverGroup -> RpcInfo -> Fetcher
Fetch.oracle SolverGroup
solvers RpcInfo
rpcInfo) VM
vm (Stepper VM -> IO VM) -> Stepper VM -> IO VM
forall a b. (a -> b) -> a -> b
$
          UnitTestOptions -> Text -> AbiValue -> Stepper Bool
runUnitTest UnitTestOptions
opts Text
testName AbiValue
abiValue Stepper Bool -> Stepper VM -> Stepper VM
forall a b.
ProgramT Action Identity a
-> ProgramT Action Identity b -> ProgramT Action Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EVM VM -> Stepper VM
forall a. EVM a -> Stepper a
Stepper.evm EVM VM
forall s (m :: * -> *). MonadState s m => m s
get
        (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"\x1b[31m[FAIL]\x1b[0m "
               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
testName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Counterexample: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ppOutput
               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\nRun:\n dapp test --replay '(\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
testName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\",\""
               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
pack ([FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [FilePath]
failCase)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\")'\nto test this case again, or \n dapp debug --replay '(\""
               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
testName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\",\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (FilePath -> Text
pack ([FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [FilePath]
failCase)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\")'\nto debug it."
             , Text -> Either Text Text
forall a b. a -> Either a b
Left (VM -> UnitTestOptions -> Text -> Text
failOutput VM
vm' UnitTestOptions
opts Text
testName)
             , VM
vm'
             )
    Result
_ -> (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"\x1b[31m[OOPS]\x1b[0m "
               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
testName
              , Text -> Either Text Text
forall a b. a -> Either a b
Left (VM -> UnitTestOptions -> Text -> Text
failOutput VM
vm UnitTestOptions
opts Text
testName)
              , VM
vm
              )

-- | Define the thread spawner for symbolic tests
symRun :: UnitTestOptions -> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM)
symRun :: UnitTestOptions
-> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM)
symRun opts :: UnitTestOptions
opts@UnitTestOptions{Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
..} VM
vm Text
testName [AbiType]
types = do
    let cd :: (Expr 'Buf, [Prop])
cd = Text -> [AbiType] -> [FilePath] -> Expr 'Buf -> (Expr 'Buf, [Prop])
symCalldata Text
testName [AbiType]
types [] (Text -> Expr 'Buf
AbstractBuf Text
"txdata")
        shouldFail :: Bool
shouldFail = Text
"proveFail" Text -> Text -> Bool
`isPrefixOf` Text
testName
        testContract :: Addr
testContract = VM
vm.state.contract

    -- define postcondition depending on `shouldFail`
    -- We directly encode the failure conditions from failed() in ds-test since this is easier to encode than a call into failed()
    -- we need to read from slot 0 in the test contract and mask it with 0x10 to get the value of _failed
    -- we don't need to do this when reading the failed from the cheatcode address since we don't do any packing there
    let failed :: Expr 'Storage -> Prop
failed Expr 'Storage
store = (Expr 'EWord -> Expr 'EWord -> Expr 'EWord
And (Expr 'EWord -> Expr 'EWord -> Expr 'Storage -> Expr 'EWord
readStorage' (Addr -> Expr 'EWord
litAddr Addr
testContract) (W256 -> Expr 'EWord
Lit W256
0) Expr 'Storage
store) (W256 -> Expr 'EWord
Lit W256
2) Expr 'EWord -> Expr 'EWord -> Prop
forall (a :: EType). Typeable a => Expr a -> Expr a -> Prop
.== W256 -> Expr 'EWord
Lit W256
2)
                   Prop -> Prop -> Prop
.|| (Expr 'EWord -> Expr 'EWord -> Expr 'Storage -> Expr 'EWord
readStorage' (Addr -> Expr 'EWord
litAddr Addr
cheatCode) (W256 -> Expr 'EWord
Lit W256
0x6661696c65640000000000000000000000000000000000000000000000000000) Expr 'Storage
store Expr 'EWord -> Expr 'EWord -> Prop
forall (a :: EType). Typeable a => Expr a -> Expr a -> Prop
.== W256 -> Expr 'EWord
Lit W256
1)
        postcondition :: VM -> Expr 'End -> Prop
postcondition = ((VM, Expr 'End) -> Prop) -> VM -> Expr 'End -> Prop
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((VM, Expr 'End) -> Prop) -> VM -> Expr 'End -> Prop)
-> ((VM, Expr 'End) -> Prop) -> VM -> Expr 'End -> Prop
forall a b. (a -> b) -> a -> b
$ case Bool
shouldFail of
          Bool
True -> \(VM
_, Expr 'End
post) -> case Expr 'End
post of
                                  Success [Prop]
_ Traces
_ Expr 'Buf
_ Expr 'Storage
store -> Expr 'Storage -> Prop
failed Expr 'Storage
store
                                  Expr 'End
_ -> Bool -> Prop
PBool Bool
True
          Bool
False -> \(VM
_, Expr 'End
post) -> case Expr 'End
post of
                                   Success [Prop]
_ Traces
_ Expr 'Buf
_ Expr 'Storage
store -> Prop -> Prop
PNeg (Expr 'Storage -> Prop
failed Expr 'Storage
store)
                                   Failure [Prop]
_ Traces
_ EvmError
_ -> Bool -> Prop
PBool Bool
False
                                   Partial [Prop]
_ Traces
_ PartialExec
_ -> Bool -> Prop
PBool Bool
True
                                   Expr 'End
_ -> FilePath -> Prop
forall a. HasCallStack => FilePath -> a
internalError FilePath
"Invalid leaf node"

    VM
vm' <- Fetcher -> VM -> Stepper VM -> IO VM
forall a. Fetcher -> VM -> Stepper a -> IO a
EVM.Stepper.interpret (SolverGroup -> RpcInfo -> Fetcher
Fetch.oracle SolverGroup
solvers RpcInfo
rpcInfo) VM
vm (Stepper VM -> IO VM) -> Stepper VM -> IO VM
forall a b. (a -> b) -> a -> b
$
      EVM VM -> Stepper VM
forall a. EVM a -> Stepper a
Stepper.evm (EVM VM -> Stepper VM) -> EVM VM -> Stepper VM
forall a b. (a -> b) -> a -> b
$ do
        TraceData -> EVM ()
pushTrace (Text -> TraceData
EntryTrace Text
testName)
        TestVMParams -> (Expr 'Buf, [Prop]) -> EVM ()
makeTxCall TestVMParams
testParams (Expr 'Buf, [Prop])
cd
        EVM VM
forall s (m :: * -> *). MonadState s m => m s
get

    -- check postconditions against vm
    (Expr 'End
_, [VerifyResult]
results) <- SolverGroup
-> VeriOpts
-> VM
-> Maybe (VM -> Expr 'End -> Prop)
-> IO (Expr 'End, [VerifyResult])
verify SolverGroup
solvers (UnitTestOptions -> VeriOpts
makeVeriOpts UnitTestOptions
opts) VM
vm' ((VM -> Expr 'End -> Prop) -> Maybe (VM -> Expr 'End -> Prop)
forall a. a -> Maybe a
Just VM -> Expr 'End -> Prop
postcondition)

    -- display results
    if (VerifyResult -> Bool) -> [VerifyResult] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all VerifyResult -> Bool
forall a b c. ProofResult a b c -> Bool
isQed [VerifyResult]
results
    then do
      (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"\x1b[32m[PASS]\x1b[0m " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
testName, Text -> Either Text Text
forall a b. b -> Either a b
Right Text
"", VM
vm)
    else do
      let x :: [(Expr 'End, SMTCex)]
x = (VerifyResult -> Maybe (Expr 'End, SMTCex))
-> [VerifyResult] -> [(Expr 'End, SMTCex)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VerifyResult -> Maybe (Expr 'End, SMTCex)
extractCex [VerifyResult]
results
      let y :: Text
y = UnitTestOptions
-> Text -> Expr 'Buf -> [AbiType] -> [(Expr 'End, SMTCex)] -> Text
symFailure UnitTestOptions
opts Text
testName ((Expr 'Buf, [Prop]) -> Expr 'Buf
forall a b. (a, b) -> a
fst (Expr 'Buf, [Prop])
cd) [AbiType]
types [(Expr 'End, SMTCex)]
x
      (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"\x1b[31m[FAIL]\x1b[0m " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
testName, Text -> Either Text Text
forall a b. a -> Either a b
Left Text
y, VM
vm)

symFailure :: UnitTestOptions -> Text -> Expr Buf -> [AbiType] -> [(Expr End, SMTCex)] -> Text
symFailure :: UnitTestOptions
-> Text -> Expr 'Buf -> [AbiType] -> [(Expr 'End, SMTCex)] -> Text
symFailure UnitTestOptions {Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
..} Text
testName Expr 'Buf
cd [AbiType]
types [(Expr 'End, SMTCex)]
failures' =
  [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
    [ Text
"Failure: "
    , Text
testName
    , Text
"\n\n"
    , Text -> [Text] -> Text
intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
indentLines Int
2 (Text -> Text)
-> ((Expr 'End, SMTCex) -> Text) -> (Expr 'End, SMTCex) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr 'End, SMTCex) -> Text
mkMsg ((Expr 'End, SMTCex) -> Text) -> [(Expr 'End, SMTCex)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Expr 'End, SMTCex)]
failures'
    ]
    where
      showRes :: Expr 'End -> Text
showRes = \case
        Success [Prop]
_ Traces
_ Expr 'Buf
_ Expr 'Storage
_ -> if Text
"proveFail" Text -> Text -> Bool
`isPrefixOf` Text
testName
                       then Text
"Successful execution"
                       else Text
"Failed: DSTest Assertion Violation"
        Expr 'End
res ->
          let ?context = DappContext { $sel:info:DappContext :: DappInfo
info = DappInfo
dapp, $sel:env:DappContext :: Map Addr Contract
env = Expr 'End -> Map Addr Contract
traceContext Expr 'End
res}
          in FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Expr 'End -> FilePath
prettyvmresult Expr 'End
res
      mkMsg :: (Expr 'End, SMTCex) -> Text
mkMsg (Expr 'End
leaf, SMTCex
cex) = [Text] -> Text
Text.unlines
        [Text
"Counterexample:"
        ,Text
""
        ,Text
"  result:   " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expr 'End -> Text
showRes Expr 'End
leaf
        ,Text
"  calldata: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> let ?context =  DappInfo -> Map Addr Contract -> DappContext
DappContext DappInfo
dapp (Expr 'End -> Map Addr Contract
traceContext Expr 'End
leaf)
                           in (?context::DappContext) =>
SMTCex -> Expr 'Buf -> Text -> [AbiType] -> Text
SMTCex -> Expr 'Buf -> Text -> [AbiType] -> Text
prettyCalldata SMTCex
cex Expr 'Buf
cd Text
testName [AbiType]
types
        , case Maybe Int
verbose of
            Just Int
_ -> [Text] -> Text
Text.unlines
              [ Text
""
              , Int -> Text -> Text
indentLines Int
2 (DappInfo -> Expr 'End -> Text
showTraceTree' DappInfo
dapp Expr 'End
leaf)
              ]
            Maybe Int
_ -> Text
""
        ]

prettyCalldata :: (?context :: DappContext) => SMTCex -> Expr Buf -> Text -> [AbiType] -> Text
prettyCalldata :: (?context::DappContext) =>
SMTCex -> Expr 'Buf -> Text -> [AbiType] -> Text
prettyCalldata SMTCex
cex Expr 'Buf
buf Text
sig [AbiType]
types = [Text] -> Text
forall a. HasCallStack => [a] -> a
head (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"(" Text
sig) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (?context::DappContext) => SMTCex -> [AbiType] -> Expr 'Buf -> Text
SMTCex -> [AbiType] -> Expr 'Buf -> Text
showCalldata SMTCex
cex [AbiType]
types Expr 'Buf
buf

showCalldata :: (?context :: DappContext) => SMTCex -> [AbiType] -> Expr Buf -> Text
showCalldata :: (?context::DappContext) => SMTCex -> [AbiType] -> Expr 'Buf -> Text
showCalldata SMTCex
cex [AbiType]
tps Expr 'Buf
buf = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
"," ((AbiValue -> Text) -> [AbiValue] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AbiValue -> Text
showVal [AbiValue]
vals) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  where
    argdata :: Expr 'Buf
argdata = W256 -> Expr 'Buf -> Expr 'Buf
Expr.drop W256
4 (Expr 'Buf -> Expr 'Buf) -> Expr 'Buf -> Expr 'Buf
forall a b. (a -> b) -> a -> b
$ Expr 'Buf -> Expr 'Buf
forall (a :: EType). Expr a -> Expr a
simplify (Expr 'Buf -> Expr 'Buf) -> Expr 'Buf -> Expr 'Buf
forall a b. (a -> b) -> a -> b
$ SMTCex -> Expr 'Buf -> Expr 'Buf
forall (a :: EType). SMTCex -> Expr a -> Expr a
subModel SMTCex
cex Expr 'Buf
buf
    vals :: [AbiValue]
vals = case [AbiType] -> Expr 'Buf -> AbiVals
decodeBuf [AbiType]
tps Expr 'Buf
argdata of
             CAbi [AbiValue]
v -> [AbiValue]
v
             AbiVals
_ -> FilePath -> [AbiValue]
forall a. HasCallStack => FilePath -> a
internalError (FilePath -> [AbiValue]) -> FilePath -> [AbiValue]
forall a b. (a -> b) -> a -> b
$ FilePath
"unable to abi decode function arguments:\n" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (Text -> FilePath
Text.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Expr 'Buf -> Text
forall (a :: EType). Expr a -> Text
formatExpr Expr 'Buf
argdata)

showVal :: AbiValue -> Text
showVal :: AbiValue -> Text
showVal (AbiBytes Int
_ ByteString
bs) = ByteString -> Text
formatBytes ByteString
bs
showVal (AbiAddress Addr
addr) = FilePath -> Text
Text.pack  (FilePath -> Text) -> (Addr -> FilePath) -> Addr -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Addr -> FilePath
forall a. Show a => a -> FilePath
show (Addr -> Text) -> Addr -> Text
forall a b. (a -> b) -> a -> b
$ Addr
addr
showVal AbiValue
v = FilePath -> Text
Text.pack (FilePath -> Text) -> (AbiValue -> FilePath) -> AbiValue -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbiValue -> FilePath
forall a. Show a => a -> FilePath
show (AbiValue -> Text) -> AbiValue -> Text
forall a b. (a -> b) -> a -> b
$ AbiValue
v

execSymTest :: UnitTestOptions -> ABIMethod -> (Expr Buf, [Prop]) -> Stepper (Expr End)
execSymTest :: UnitTestOptions
-> Text -> (Expr 'Buf, [Prop]) -> Stepper (Expr 'End)
execSymTest UnitTestOptions{ Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
.. } Text
method (Expr 'Buf, [Prop])
cd = do
  -- Set up the call to the test method
  EVM () -> Stepper ()
forall a. EVM a -> Stepper a
Stepper.evm (EVM () -> Stepper ()) -> EVM () -> Stepper ()
forall a b. (a -> b) -> a -> b
$ do
    TestVMParams -> (Expr 'Buf, [Prop]) -> EVM ()
makeTxCall TestVMParams
testParams (Expr 'Buf, [Prop])
cd
    TraceData -> EVM ()
pushTrace (Text -> TraceData
EntryTrace Text
method)
  -- Try running the test method
  Stepper (Expr 'End)
runExpr

checkSymFailures :: UnitTestOptions -> Stepper VM
checkSymFailures :: UnitTestOptions -> Stepper VM
checkSymFailures UnitTestOptions { Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
.. } = do
  -- Ask whether any assertions failed
  EVM () -> Stepper ()
forall a. EVM a -> Stepper a
Stepper.evm (EVM () -> Stepper ()) -> EVM () -> Stepper ()
forall a b. (a -> b) -> a -> b
$ do
    EVM ()
popTrace
    TestVMParams -> Either (Text, AbiValue) ByteString -> EVM ()
abiCall TestVMParams
testParams ((Text, AbiValue) -> Either (Text, AbiValue) ByteString
forall a b. a -> Either a b
Left (Text
"failed()", AbiValue
emptyAbi))
  Stepper VM
Stepper.runFully

indentLines :: Int -> Text -> Text
indentLines :: Int -> Text -> Text
indentLines Int
n Text
s =
  let p :: Text
p = Int -> Text -> Text
Text.replicate Int
n Text
" "
  in [Text] -> Text
Text.unlines ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
p <>) (Text -> [Text]
Text.lines Text
s))

passOutput :: VM -> UnitTestOptions -> Text -> Text
passOutput :: VM -> UnitTestOptions -> Text -> Text
passOutput VM
vm UnitTestOptions { Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
.. } Text
testName =
  let ?context = DappContext { $sel:info:DappContext :: DappInfo
info = DappInfo
dapp, $sel:env:DappContext :: Map Addr Contract
env = VM
vm.env.contracts }
  in let v :: Int
v = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
verbose
  in if (Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) then
    [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
      [ Text
"Success: "
      , Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Text -> Text -> Maybe Text
stripSuffix Text
"()" Text
testName)
      , Text
"\n"
      , if (Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2) then Int -> Text -> Text
indentLines Int
2 (DappInfo -> VM -> Text
showTraceTree DappInfo
dapp VM
vm) else Text
""
      , Int -> Text -> Text
indentLines Int
2 ((?context::DappContext) => Map W256 Event -> [Expr 'Log] -> Text
Map W256 Event -> [Expr 'Log] -> Text
formatTestLogs DappInfo
dapp.eventMap VM
vm.logs)
      , Text
"\n"
      ]
    else Text
""

-- TODO
failOutput :: VM -> UnitTestOptions -> Text -> Text
failOutput :: VM -> UnitTestOptions -> Text -> Text
failOutput VM
vm UnitTestOptions { Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
.. } Text
testName =
  let ?context = DappContext { $sel:info:DappContext :: DappInfo
info = DappInfo
dapp, $sel:env:DappContext :: Map Addr Contract
env = VM
vm.env.contracts }
  in [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
  [ Text
"Failure: "
  , Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Text -> Text -> Maybe Text
stripSuffix Text
"()" Text
testName)
  , Text
"\n"
  , case Maybe Int
verbose of
      Just Int
_ -> Int -> Text -> Text
indentLines Int
2 (DappInfo -> VM -> Text
showTraceTree DappInfo
dapp VM
vm)
      Maybe Int
_ -> Text
""
  , Int -> Text -> Text
indentLines Int
2 ((?context::DappContext) => Map W256 Event -> [Expr 'Log] -> Text
Map W256 Event -> [Expr 'Log] -> Text
formatTestLogs DappInfo
dapp.eventMap VM
vm.logs)
  , Text
"\n"
  ]

formatTestLogs :: (?context :: DappContext) => Map W256 Event -> [Expr Log] -> Text
formatTestLogs :: (?context::DappContext) => Map W256 Event -> [Expr 'Log] -> Text
formatTestLogs Map W256 Event
events [Expr 'Log]
xs =
  case [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Text] -> [Maybe Text]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((Expr 'Log -> Maybe Text) -> [Expr 'Log] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((?context::DappContext) =>
Map W256 Event -> Expr 'Log -> Maybe Text
Map W256 Event -> Expr 'Log -> Maybe Text
formatTestLog Map W256 Event
events) [Expr 'Log]
xs)) of
    [] -> Text
"\n"
    [Text]
ys -> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
"\n" [Text]
ys Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n"

-- Here we catch and render some special logs emitted by ds-test,
-- with the intent to then present them in a separate view to the
-- regular trace output.
formatTestLog :: (?context :: DappContext) => Map W256 Event -> Expr Log -> Maybe Text
formatTestLog :: (?context::DappContext) =>
Map W256 Event -> Expr 'Log -> Maybe Text
formatTestLog Map W256 Event
_ (LogEntry Expr 'EWord
_ Expr 'Buf
_ []) = Maybe Text
forall a. Maybe a
Nothing
formatTestLog Map W256 Event
_ (GVar GVar 'Log
_) = FilePath -> Maybe Text
forall a. HasCallStack => FilePath -> a
internalError FilePath
"unexpected global variable"
formatTestLog Map W256 Event
events (LogEntry Expr 'EWord
_ Expr 'Buf
args (Expr 'EWord
topic:[Expr 'EWord]
_)) =
  case Expr 'EWord -> Maybe W256
maybeLitWord Expr 'EWord
topic Maybe W256 -> (W256 -> Maybe Event) -> Maybe Event
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \W256
t1 -> (W256 -> Map W256 Event -> Maybe Event
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup W256
t1 Map W256 Event
events) of
    Maybe Event
Nothing -> Maybe Text
forall a. Maybe a
Nothing
    Just (Event Text
name Anonymity
_ [(Text, AbiType, Indexed)]
types) ->
      case (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
parenthesise (AbiType -> Text
abiTypeSolidity (AbiType -> Text) -> [AbiType] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Text, AbiType, Indexed)] -> [AbiType]
unindexed [(Text, AbiType, Indexed)]
types))) of
        Text
"log(string)" -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
unquote (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (?context::DappContext) => AbiType -> Expr 'Buf -> Text
AbiType -> Expr 'Buf -> Text
showValue AbiType
AbiStringType Expr 'Buf
args

        -- log_named_x(string, x)
        Text
"log_named_bytes32(string, bytes32)" -> Maybe Text
log_named
        Text
"log_named_address(string, address)" -> Maybe Text
log_named
        Text
"log_named_int(string, int256)"      -> Maybe Text
log_named
        Text
"log_named_uint(string, uint256)"    -> Maybe Text
log_named
        Text
"log_named_bytes(string, bytes)"     -> Maybe Text
log_named
        Text
"log_named_string(string, string)"   -> Maybe Text
log_named

        -- log_named_decimal_x(string, uint, x)
        Text
"log_named_decimal_int(string, int256, uint256)"   -> Maybe Text
log_named_decimal
        Text
"log_named_decimal_uint(string, uint256, uint256)" -> Maybe Text
log_named_decimal

        -- log_x(x)
        Text
"log_bytes32(bytes32)" -> Maybe Text
log_unnamed
        Text
"log_address(address)" -> Maybe Text
log_unnamed
        Text
"log_int(int256)"      -> Maybe Text
log_unnamed
        Text
"log_uint(uint256)"    -> Maybe Text
log_unnamed
        Text
"log_bytes(bytes)"     -> Maybe Text
log_unnamed
        Text
"log_string(string)"   -> Maybe Text
log_unnamed

        -- log_named_x(bytes32, x), as used in older versions of ds-test.
        -- bytes32 are opportunistically represented as strings in Format.hs
        Text
"log_named_bytes32(bytes32, bytes32)" -> Maybe Text
log_named
        Text
"log_named_address(bytes32, address)" -> Maybe Text
log_named
        Text
"log_named_int(bytes32, int256)"      -> Maybe Text
log_named
        Text
"log_named_uint(bytes32, uint256)"    -> Maybe Text
log_named

        Text
_ -> Maybe Text
forall a. Maybe a
Nothing

        where
          ts :: [AbiType]
ts = [(Text, AbiType, Indexed)] -> [AbiType]
unindexed [(Text, AbiType, Indexed)]
types
          unquote :: Text -> Text
unquote = (Char -> Bool) -> Text -> Text
Text.dropAround (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'«' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'»')
          log_unnamed :: Maybe Text
log_unnamed =
            Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (?context::DappContext) => AbiType -> Expr 'Buf -> Text
AbiType -> Expr 'Buf -> Text
showValue ([AbiType] -> AbiType
forall a. HasCallStack => [a] -> a
head [AbiType]
ts) Expr 'Buf
args
          log_named :: Maybe Text
log_named =
            let (Text
key, Text
val) = case Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
2 ((?context::DappContext) => [AbiType] -> Expr 'Buf -> [Text]
[AbiType] -> Expr 'Buf -> [Text]
textValues [AbiType]
ts Expr 'Buf
args) of
                  [Text
k, Text
v] -> (Text
k, Text
v)
                  [Text]
_ -> FilePath -> (Text, Text)
forall a. HasCallStack => FilePath -> a
internalError FilePath
"shouldn't happen"
            in Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
unquote Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
val
          showDecimal :: source -> i -> Text
showDecimal source
dec i
val =
            FilePath -> Text
pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ DecimalRaw i -> FilePath
forall a. Show a => a -> FilePath
show (DecimalRaw i -> FilePath) -> DecimalRaw i -> FilePath
forall a b. (a -> b) -> a -> b
$ Word8 -> i -> DecimalRaw i
forall i. Word8 -> i -> DecimalRaw i
Decimal (source -> Word8
forall target source.
(HasCallStack, TryFrom source target, Show source, Typeable source,
 Typeable target) =>
source -> target
unsafeInto source
dec) i
val
          log_named_decimal :: Maybe Text
log_named_decimal =
            case Expr 'Buf
args of
              (ConcreteBuf ByteString
b) ->
                case Vector AbiValue -> [AbiValue]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Vector AbiValue -> [AbiValue]) -> Vector AbiValue -> [AbiValue]
forall a b. (a -> b) -> a -> b
$ Get (Vector AbiValue) -> ByteString -> Vector AbiValue
forall a. Get a -> ByteString -> a
runGet (Int -> [AbiType] -> Get (Vector AbiValue)
getAbiSeq ([AbiType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AbiType]
ts) [AbiType]
ts) (ByteString -> ByteString
BSLazy.fromStrict ByteString
b) of
                  [AbiValue
key, (AbiUInt Int
256 Word256
val), (AbiUInt Int
256 Word256
dec)] ->
                    Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text
unquote ((?context::DappContext) => AbiValue -> Text
AbiValue -> Text
showAbiValue AbiValue
key)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word256 -> Word256 -> Text
forall {i} {source}.
(Integral i, TryFrom source Word8, Show i, Show source,
 Typeable source) =>
source -> i -> Text
showDecimal Word256
dec Word256
val
                  [AbiValue
key, (AbiInt Int
256 Int256
val), (AbiUInt Int
256 Word256
dec)] ->
                    Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text
unquote ((?context::DappContext) => AbiValue -> Text
AbiValue -> Text
showAbiValue AbiValue
key)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word256 -> Int256 -> Text
forall {i} {source}.
(Integral i, TryFrom source Word8, Show i, Show source,
 Typeable source) =>
source -> i -> Text
showDecimal Word256
dec Int256
val
                  [AbiValue]
_ -> Maybe Text
forall a. Maybe a
Nothing
              Expr 'Buf
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"<symbolic decimal>"

abiCall :: TestVMParams -> Either (Text, AbiValue) ByteString -> EVM ()
abiCall :: TestVMParams -> Either (Text, AbiValue) ByteString -> EVM ()
abiCall TestVMParams
params Either (Text, AbiValue) ByteString
args =
  let cd :: ByteString
cd = case Either (Text, AbiValue) ByteString
args of
        Left (Text
sig, AbiValue
args') -> Text -> AbiValue -> ByteString
abiMethod Text
sig AbiValue
args'
        Right ByteString
b -> ByteString
b
  in TestVMParams -> (Expr 'Buf, [Prop]) -> EVM ()
makeTxCall TestVMParams
params (ByteString -> Expr 'Buf
ConcreteBuf ByteString
cd, [])

makeTxCall :: TestVMParams -> (Expr Buf, [Prop]) -> EVM ()
makeTxCall :: TestVMParams -> (Expr 'Buf, [Prop]) -> EVM ()
makeTxCall TestVMParams
params (Expr 'Buf
cd, [Prop]
cdProps) = do
  EVM ()
resetState
  Optic A_Lens NoIx VM VM Bool Bool -> Bool -> EVM ()
forall k s (m :: * -> *) (is :: IxList) a b.
(Is k A_Setter, MonadState s m) =>
Optic k is s s a b -> b -> m ()
assign (Optic A_Lens NoIx VM VM TxState TxState
#tx Optic A_Lens NoIx VM VM TxState TxState
-> Optic A_Lens NoIx TxState TxState Bool Bool
-> Optic A_Lens NoIx VM VM Bool Bool
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx TxState TxState Bool Bool
#isCreate) Bool
False
  Addr -> EVM ()
loadContract TestVMParams
params.address
  Optic A_Lens NoIx VM VM (Expr 'Buf) (Expr 'Buf)
-> Expr 'Buf -> EVM ()
forall k s (m :: * -> *) (is :: IxList) a b.
(Is k A_Setter, MonadState s m) =>
Optic k is s s a b -> b -> m ()
assign (Optic A_Lens NoIx VM VM FrameState FrameState
#state Optic A_Lens NoIx VM VM FrameState FrameState
-> Optic A_Lens NoIx FrameState FrameState (Expr 'Buf) (Expr 'Buf)
-> Optic A_Lens NoIx VM VM (Expr 'Buf) (Expr 'Buf)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx FrameState FrameState (Expr 'Buf) (Expr 'Buf)
#calldata) Expr 'Buf
cd
  #constraints %= (<> cdProps)
  Optic A_Lens NoIx VM VM (Expr 'EWord) (Expr 'EWord)
-> Expr 'EWord -> EVM ()
forall k s (m :: * -> *) (is :: IxList) a b.
(Is k A_Setter, MonadState s m) =>
Optic k is s s a b -> b -> m ()
assign (Optic A_Lens NoIx VM VM FrameState FrameState
#state Optic A_Lens NoIx VM VM FrameState FrameState
-> Optic
     A_Lens NoIx FrameState FrameState (Expr 'EWord) (Expr 'EWord)
-> Optic A_Lens NoIx VM VM (Expr 'EWord) (Expr 'EWord)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx FrameState FrameState (Expr 'EWord) (Expr 'EWord)
#caller) (Addr -> Expr 'EWord
litAddr TestVMParams
params.caller)
  Optic A_Lens NoIx VM VM Word64 Word64 -> Word64 -> EVM ()
forall k s (m :: * -> *) (is :: IxList) a b.
(Is k A_Setter, MonadState s m) =>
Optic k is s s a b -> b -> m ()
assign (Optic A_Lens NoIx VM VM FrameState FrameState
#state Optic A_Lens NoIx VM VM FrameState FrameState
-> Optic A_Lens NoIx FrameState FrameState Word64 Word64
-> Optic A_Lens NoIx VM VM Word64 Word64
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx FrameState FrameState Word64 Word64
#gas) TestVMParams
params.gasCall
  Contract
origin' <- Contract -> Maybe Contract -> Contract
forall a. a -> Maybe a -> a
fromMaybe (ContractCode -> Contract
initialContract (RuntimeCode -> ContractCode
RuntimeCode (ByteString -> RuntimeCode
ConcreteRuntimeCode ByteString
""))) (Maybe Contract -> Contract)
-> StateT VM Identity (Maybe Contract)
-> StateT VM Identity Contract
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Optic' A_Lens NoIx VM (Maybe Contract)
-> StateT VM Identity (Maybe Contract)
forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use (Optic A_Lens NoIx VM VM Env Env
#env Optic A_Lens NoIx VM VM Env Env
-> Optic
     A_Lens NoIx Env Env (Map Addr Contract) (Map Addr Contract)
-> Optic A_Lens NoIx VM VM (Map Addr Contract) (Map Addr Contract)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx Env Env (Map Addr Contract) (Map Addr Contract)
#contracts Optic A_Lens NoIx VM VM (Map Addr Contract) (Map Addr Contract)
-> Optic
     A_Lens
     NoIx
     (Map Addr Contract)
     (Map Addr Contract)
     (Maybe Contract)
     (Maybe Contract)
-> Optic' A_Lens NoIx VM (Maybe Contract)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Index (Map Addr Contract)
-> Optic
     A_Lens
     NoIx
     (Map Addr Contract)
     (Map Addr Contract)
     (Maybe (IxValue (Map Addr Contract)))
     (Maybe (IxValue (Map Addr Contract)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at TestVMParams
params.origin)
  let originBal :: W256
originBal = Contract
origin'.balance
  Bool -> EVM () -> EVM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (W256
originBal W256 -> W256 -> Bool
forall a. Ord a => a -> a -> Bool
< TestVMParams
params.gasprice W256 -> W256 -> W256
forall a. Num a => a -> a -> a
* (Word64 -> W256
forall target source. From source target => source -> target
into TestVMParams
params.gasCall)) (EVM () -> EVM ()) -> EVM () -> EVM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> EVM ()
forall a. HasCallStack => FilePath -> a
internalError FilePath
"insufficient balance for gas cost"
  VM
vm <- EVM VM
forall s (m :: * -> *). MonadState s m => m s
get
  VM -> EVM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (VM -> EVM ()) -> VM -> EVM ()
forall a b. (a -> b) -> a -> b
$ VM -> VM
initTx VM
vm

initialUnitTestVm :: UnitTestOptions -> SolcContract -> VM
initialUnitTestVm :: UnitTestOptions -> SolcContract -> VM
initialUnitTestVm (UnitTestOptions {Bool
Int
Integer
Maybe Int
Maybe Integer
Maybe Natural
Maybe (Text, ByteString)
RpcInfo
Maybe Text
Text
SolverGroup
DappInfo
TestVMParams
VM -> VM
$sel:rpcInfo:UnitTestOptions :: UnitTestOptions -> RpcInfo
$sel:solvers:UnitTestOptions :: UnitTestOptions -> SolverGroup
$sel:verbose:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:maxIter:UnitTestOptions :: UnitTestOptions -> Maybe Integer
$sel:askSmtIters:UnitTestOptions :: UnitTestOptions -> Integer
$sel:smtDebug:UnitTestOptions :: UnitTestOptions -> Bool
$sel:maxDepth:UnitTestOptions :: UnitTestOptions -> Maybe Int
$sel:smtTimeout:UnitTestOptions :: UnitTestOptions -> Maybe Natural
$sel:solver:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:covMatch:UnitTestOptions :: UnitTestOptions -> Maybe Text
$sel:match:UnitTestOptions :: UnitTestOptions -> Text
$sel:fuzzRuns:UnitTestOptions :: UnitTestOptions -> Int
$sel:replay:UnitTestOptions :: UnitTestOptions -> Maybe (Text, ByteString)
$sel:vmModifier:UnitTestOptions :: UnitTestOptions -> VM -> VM
$sel:dapp:UnitTestOptions :: UnitTestOptions -> DappInfo
$sel:testParams:UnitTestOptions :: UnitTestOptions -> TestVMParams
$sel:ffiAllowed:UnitTestOptions :: UnitTestOptions -> Bool
rpcInfo :: RpcInfo
solvers :: SolverGroup
verbose :: Maybe Int
maxIter :: Maybe Integer
askSmtIters :: Integer
smtDebug :: Bool
maxDepth :: Maybe Int
smtTimeout :: Maybe Natural
solver :: Maybe Text
covMatch :: Maybe Text
match :: Text
fuzzRuns :: Int
replay :: Maybe (Text, ByteString)
vmModifier :: VM -> VM
dapp :: DappInfo
testParams :: TestVMParams
ffiAllowed :: Bool
..}) SolcContract
theContract =
  let
    vm :: VM
vm = VMOpts -> VM
makeVm (VMOpts -> VM) -> VMOpts -> VM
forall a b. (a -> b) -> a -> b
$ VMOpts
           { $sel:contract:VMOpts :: Contract
contract = ContractCode -> Contract
initialContract (ByteString -> Expr 'Buf -> ContractCode
InitCode SolcContract
theContract.creationCode Expr 'Buf
forall a. Monoid a => a
mempty)
           , $sel:calldata:VMOpts :: (Expr 'Buf, [Prop])
calldata = (Expr 'Buf, [Prop])
forall a. Monoid a => a
mempty
           , $sel:value:VMOpts :: Expr 'EWord
value = W256 -> Expr 'EWord
Lit W256
0
           , $sel:address:VMOpts :: Addr
address = TestVMParams
testParams.address
           , $sel:caller:VMOpts :: Expr 'EWord
caller = Addr -> Expr 'EWord
litAddr TestVMParams
testParams.caller
           , $sel:origin:VMOpts :: Addr
origin = TestVMParams
testParams.origin
           , $sel:gas:VMOpts :: Word64
gas = TestVMParams
testParams.gasCreate
           , $sel:gaslimit:VMOpts :: Word64
gaslimit = TestVMParams
testParams.gasCreate
           , $sel:coinbase:VMOpts :: Addr
coinbase = TestVMParams
testParams.coinbase
           , $sel:number:VMOpts :: W256
number = TestVMParams
testParams.number
           , $sel:timestamp:VMOpts :: Expr 'EWord
timestamp = W256 -> Expr 'EWord
Lit TestVMParams
testParams.timestamp
           , $sel:blockGaslimit:VMOpts :: Word64
blockGaslimit = TestVMParams
testParams.gaslimit
           , $sel:gasprice:VMOpts :: W256
gasprice = TestVMParams
testParams.gasprice
           , $sel:baseFee:VMOpts :: W256
baseFee = TestVMParams
testParams.baseFee
           , $sel:priorityFee:VMOpts :: W256
priorityFee = TestVMParams
testParams.priorityFee
           , $sel:maxCodeSize:VMOpts :: W256
maxCodeSize = TestVMParams
testParams.maxCodeSize
           , $sel:prevRandao:VMOpts :: W256
prevRandao = TestVMParams
testParams.prevrandao
           , $sel:schedule:VMOpts :: FeeSchedule Word64
schedule = FeeSchedule Word64
forall n. Num n => FeeSchedule n
FeeSchedule.berlin
           , $sel:chainId:VMOpts :: W256
chainId = TestVMParams
testParams.chainId
           , $sel:create:VMOpts :: Bool
create = Bool
True
           , $sel:initialStorage:VMOpts :: Expr 'Storage
initialStorage = Expr 'Storage
EmptyStore
           , $sel:txAccessList:VMOpts :: Map Addr [W256]
txAccessList = Map Addr [W256]
forall a. Monoid a => a
mempty -- TODO: support unit test access lists???
           , $sel:allowFFI:VMOpts :: Bool
allowFFI = Bool
ffiAllowed
           }
    creator :: IxValue (Map Addr Contract)
creator =
      ContractCode -> Contract
initialContract (RuntimeCode -> ContractCode
RuntimeCode (ByteString -> RuntimeCode
ConcreteRuntimeCode ByteString
""))
        Contract -> (Contract -> Contract) -> Contract
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Contract Contract W256 W256
-> W256 -> Contract -> Contract
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Optic A_Lens NoIx Contract Contract W256 W256
#nonce W256
1
        Contract
-> (Contract -> IxValue (Map Addr Contract))
-> IxValue (Map Addr Contract)
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Contract (IxValue (Map Addr Contract)) W256 W256
-> W256 -> Contract -> IxValue (Map Addr Contract)
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set Optic A_Lens NoIx Contract (IxValue (Map Addr Contract)) W256 W256
#balance TestVMParams
testParams.balanceCreate
  in VM
vm
    VM -> (VM -> VM) -> VM
forall a b. a -> (a -> b) -> b
& Optic' A_Lens NoIx VM (Maybe (IxValue (Map Addr Contract)))
-> Maybe (IxValue (Map Addr Contract)) -> VM -> VM
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (Optic A_Lens NoIx VM VM Env Env
#env Optic A_Lens NoIx VM VM Env Env
-> Optic
     A_Lens NoIx Env Env (Map Addr Contract) (Map Addr Contract)
-> Optic A_Lens NoIx VM VM (Map Addr Contract) (Map Addr Contract)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx Env Env (Map Addr Contract) (Map Addr Contract)
#contracts Optic A_Lens NoIx VM VM (Map Addr Contract) (Map Addr Contract)
-> Optic
     A_Lens
     NoIx
     (Map Addr Contract)
     (Map Addr Contract)
     (Maybe (IxValue (Map Addr Contract)))
     (Maybe (IxValue (Map Addr Contract)))
-> Optic' A_Lens NoIx VM (Maybe (IxValue (Map Addr Contract)))
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Index (Map Addr Contract)
-> Optic
     A_Lens
     NoIx
     (Map Addr Contract)
     (Map Addr Contract)
     (Maybe (IxValue (Map Addr Contract)))
     (Maybe (IxValue (Map Addr Contract)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Addr Contract)
Addr
ethrunAddress) (IxValue (Map Addr Contract) -> Maybe (IxValue (Map Addr Contract))
forall a. a -> Maybe a
Just IxValue (Map Addr Contract)
creator)


getParametersFromEnvironmentVariables :: Maybe Text -> IO TestVMParams
getParametersFromEnvironmentVariables :: Maybe Text -> IO TestVMParams
getParametersFromEnvironmentVariables Maybe Text
rpc = do
  BlockNumber
block' <- BlockNumber
-> (FilePath -> BlockNumber) -> Maybe FilePath -> BlockNumber
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BlockNumber
Fetch.Latest (W256 -> BlockNumber
Fetch.BlockNumber (W256 -> BlockNumber)
-> (FilePath -> W256) -> FilePath -> BlockNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> W256
forall a. Read a => FilePath -> a
read) (Maybe FilePath -> BlockNumber)
-> IO (Maybe FilePath) -> IO BlockNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"DAPP_TEST_NUMBER")

  (Addr
miner,Expr 'EWord
ts,W256
blockNum,W256
ran,Word64
limit,W256
base) <-
    case Maybe Text
rpc of
      Maybe Text
Nothing  -> (Addr, Expr 'EWord, W256, W256, Word64, W256)
-> IO (Addr, Expr 'EWord, W256, W256, Word64, W256)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Addr
0,W256 -> Expr 'EWord
Lit W256
0,W256
0,W256
0,Word64
0,W256
0)
      Just Text
url -> BlockNumber -> Text -> IO (Maybe Block)
Fetch.fetchBlockFrom BlockNumber
block' Text
url IO (Maybe Block)
-> (Maybe Block
    -> IO (Addr, Expr 'EWord, W256, W256, Word64, W256))
-> IO (Addr, Expr 'EWord, W256, W256, Word64, W256)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe Block
Nothing -> FilePath -> IO (Addr, Expr 'EWord, W256, W256, Word64, W256)
forall a. HasCallStack => FilePath -> a
internalError FilePath
"Could not fetch block"
        Just Block{Word64
FeeSchedule Word64
Addr
W256
Expr 'EWord
coinbase :: Addr
timestamp :: Expr 'EWord
number :: W256
prevRandao :: W256
gaslimit :: Word64
baseFee :: W256
maxCodeSize :: W256
schedule :: FeeSchedule Word64
$sel:coinbase:Block :: Block -> Addr
$sel:timestamp:Block :: Block -> Expr 'EWord
$sel:number:Block :: Block -> W256
$sel:prevRandao:Block :: Block -> W256
$sel:gaslimit:Block :: Block -> Word64
$sel:baseFee:Block :: Block -> W256
$sel:maxCodeSize:Block :: Block -> W256
$sel:schedule:Block :: Block -> FeeSchedule Word64
..} -> (Addr, Expr 'EWord, W256, W256, Word64, W256)
-> IO (Addr, Expr 'EWord, W256, W256, Word64, W256)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Addr
coinbase
                               , Expr 'EWord
timestamp
                               , W256
number
                               , W256
prevRandao
                               , Word64
gaslimit
                               , W256
baseFee
                               )
  let
    getWord :: FilePath -> b -> IO b
getWord FilePath
s b
def = b -> (FilePath -> b) -> Maybe FilePath -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
def FilePath -> b
forall a. Read a => FilePath -> a
read (Maybe FilePath -> b) -> IO (Maybe FilePath) -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
s
    getAddr :: FilePath -> b -> IO b
getAddr FilePath
s b
def = b -> (FilePath -> b) -> Maybe FilePath -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
def FilePath -> b
forall a. Read a => FilePath -> a
read (Maybe FilePath -> b) -> IO (Maybe FilePath) -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
s
    ts' :: W256
ts' = W256 -> Maybe W256 -> W256
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> W256
forall a. HasCallStack => FilePath -> a
internalError FilePath
"received unexpected symbolic timestamp via rpc") (Expr 'EWord -> Maybe W256
maybeLitWord Expr 'EWord
ts)

  Addr
-> Addr
-> Addr
-> Word64
-> Word64
-> W256
-> W256
-> W256
-> Addr
-> W256
-> W256
-> Word64
-> W256
-> W256
-> W256
-> W256
-> TestVMParams
TestVMParams
    (Addr
 -> Addr
 -> Addr
 -> Word64
 -> Word64
 -> W256
 -> W256
 -> W256
 -> Addr
 -> W256
 -> W256
 -> Word64
 -> W256
 -> W256
 -> W256
 -> W256
 -> TestVMParams)
-> IO Addr
-> IO
     (Addr
      -> Addr
      -> Word64
      -> Word64
      -> W256
      -> W256
      -> W256
      -> Addr
      -> W256
      -> W256
      -> Word64
      -> W256
      -> W256
      -> W256
      -> W256
      -> TestVMParams)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Addr -> IO Addr
forall {b}. Read b => FilePath -> b -> IO b
getAddr FilePath
"DAPP_TEST_ADDRESS" (Addr -> W256 -> Addr
createAddress Addr
ethrunAddress W256
1)
    IO
  (Addr
   -> Addr
   -> Word64
   -> Word64
   -> W256
   -> W256
   -> W256
   -> Addr
   -> W256
   -> W256
   -> Word64
   -> W256
   -> W256
   -> W256
   -> W256
   -> TestVMParams)
-> IO Addr
-> IO
     (Addr
      -> Word64
      -> Word64
      -> W256
      -> W256
      -> W256
      -> Addr
      -> W256
      -> W256
      -> Word64
      -> W256
      -> W256
      -> W256
      -> W256
      -> TestVMParams)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> Addr -> IO Addr
forall {b}. Read b => FilePath -> b -> IO b
getAddr FilePath
"DAPP_TEST_CALLER" Addr
ethrunAddress
    IO
  (Addr
   -> Word64
   -> Word64
   -> W256
   -> W256
   -> W256
   -> Addr
   -> W256
   -> W256
   -> Word64
   -> W256
   -> W256
   -> W256
   -> W256
   -> TestVMParams)
-> IO Addr
-> IO
     (Word64
      -> Word64
      -> W256
      -> W256
      -> W256
      -> Addr
      -> W256
      -> W256
      -> Word64
      -> W256
      -> W256
      -> W256
      -> W256
      -> TestVMParams)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> Addr -> IO Addr
forall {b}. Read b => FilePath -> b -> IO b
getAddr FilePath
"DAPP_TEST_ORIGIN" Addr
ethrunAddress
    IO
  (Word64
   -> Word64
   -> W256
   -> W256
   -> W256
   -> Addr
   -> W256
   -> W256
   -> Word64
   -> W256
   -> W256
   -> W256
   -> W256
   -> TestVMParams)
-> IO Word64
-> IO
     (Word64
      -> W256
      -> W256
      -> W256
      -> Addr
      -> W256
      -> W256
      -> Word64
      -> W256
      -> W256
      -> W256
      -> W256
      -> TestVMParams)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> Word64 -> IO Word64
forall {b}. Read b => FilePath -> b -> IO b
getWord FilePath
"DAPP_TEST_GAS_CREATE" Word64
defaultGasForCreating
    IO
  (Word64
   -> W256
   -> W256
   -> W256
   -> Addr
   -> W256
   -> W256
   -> Word64
   -> W256
   -> W256
   -> W256
   -> W256
   -> TestVMParams)
-> IO Word64
-> IO
     (W256
      -> W256
      -> W256
      -> Addr
      -> W256
      -> W256
      -> Word64
      -> W256
      -> W256
      -> W256
      -> W256
      -> TestVMParams)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> Word64 -> IO Word64
forall {b}. Read b => FilePath -> b -> IO b
getWord FilePath
"DAPP_TEST_GAS_CALL" Word64
defaultGasForInvoking
    IO
  (W256
   -> W256
   -> W256
   -> Addr
   -> W256
   -> W256
   -> Word64
   -> W256
   -> W256
   -> W256
   -> W256
   -> TestVMParams)
-> IO W256
-> IO
     (W256
      -> W256
      -> Addr
      -> W256
      -> W256
      -> Word64
      -> W256
      -> W256
      -> W256
      -> W256
      -> TestVMParams)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> W256 -> IO W256
forall {b}. Read b => FilePath -> b -> IO b
getWord FilePath
"DAPP_TEST_BASEFEE" W256
base
    IO
  (W256
   -> W256
   -> Addr
   -> W256
   -> W256
   -> Word64
   -> W256
   -> W256
   -> W256
   -> W256
   -> TestVMParams)
-> IO W256
-> IO
     (W256
      -> Addr
      -> W256
      -> W256
      -> Word64
      -> W256
      -> W256
      -> W256
      -> W256
      -> TestVMParams)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> W256 -> IO W256
forall {b}. Read b => FilePath -> b -> IO b
getWord FilePath
"DAPP_TEST_PRIORITYFEE" W256
0
    IO
  (W256
   -> Addr
   -> W256
   -> W256
   -> Word64
   -> W256
   -> W256
   -> W256
   -> W256
   -> TestVMParams)
-> IO W256
-> IO
     (Addr
      -> W256
      -> W256
      -> Word64
      -> W256
      -> W256
      -> W256
      -> W256
      -> TestVMParams)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> W256 -> IO W256
forall {b}. Read b => FilePath -> b -> IO b
getWord FilePath
"DAPP_TEST_BALANCE" W256
defaultBalanceForTestContract
    IO
  (Addr
   -> W256
   -> W256
   -> Word64
   -> W256
   -> W256
   -> W256
   -> W256
   -> TestVMParams)
-> IO Addr
-> IO
     (W256
      -> W256 -> Word64 -> W256 -> W256 -> W256 -> W256 -> TestVMParams)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> Addr -> IO Addr
forall {b}. Read b => FilePath -> b -> IO b
getAddr FilePath
"DAPP_TEST_COINBASE" Addr
miner
    IO
  (W256
   -> W256 -> Word64 -> W256 -> W256 -> W256 -> W256 -> TestVMParams)
-> IO W256
-> IO
     (W256 -> Word64 -> W256 -> W256 -> W256 -> W256 -> TestVMParams)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> W256 -> IO W256
forall {b}. Read b => FilePath -> b -> IO b
getWord FilePath
"DAPP_TEST_NUMBER" W256
blockNum
    IO (W256 -> Word64 -> W256 -> W256 -> W256 -> W256 -> TestVMParams)
-> IO W256
-> IO (Word64 -> W256 -> W256 -> W256 -> W256 -> TestVMParams)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> W256 -> IO W256
forall {b}. Read b => FilePath -> b -> IO b
getWord FilePath
"DAPP_TEST_TIMESTAMP" W256
ts'
    IO (Word64 -> W256 -> W256 -> W256 -> W256 -> TestVMParams)
-> IO Word64 -> IO (W256 -> W256 -> W256 -> W256 -> TestVMParams)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> Word64 -> IO Word64
forall {b}. Read b => FilePath -> b -> IO b
getWord FilePath
"DAPP_TEST_GAS_LIMIT" Word64
limit
    IO (W256 -> W256 -> W256 -> W256 -> TestVMParams)
-> IO W256 -> IO (W256 -> W256 -> W256 -> TestVMParams)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> W256 -> IO W256
forall {b}. Read b => FilePath -> b -> IO b
getWord FilePath
"DAPP_TEST_GAS_PRICE" W256
0
    IO (W256 -> W256 -> W256 -> TestVMParams)
-> IO W256 -> IO (W256 -> W256 -> TestVMParams)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> W256 -> IO W256
forall {b}. Read b => FilePath -> b -> IO b
getWord FilePath
"DAPP_TEST_MAXCODESIZE" W256
defaultMaxCodeSize
    IO (W256 -> W256 -> TestVMParams)
-> IO W256 -> IO (W256 -> TestVMParams)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> W256 -> IO W256
forall {b}. Read b => FilePath -> b -> IO b
getWord FilePath
"DAPP_TEST_PREVRANDAO" W256
ran
    IO (W256 -> TestVMParams) -> IO W256 -> IO TestVMParams
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FilePath -> W256 -> IO W256
forall {b}. Read b => FilePath -> b -> IO b
getWord FilePath
"DAPP_TEST_CHAINID" W256
99