{-# Language LambdaCase #-}
{-# Language DataKinds #-}
{-# Language ImplicitParams #-}

module EVM.UnitTest where

import Prelude hiding (Word)

import EVM
import EVM.ABI
import EVM.Concrete hiding (readMemoryWord)
import EVM.Symbolic
import EVM.Dapp
import EVM.Debug (srcMapCodePos)
import EVM.Exec
import EVM.Format
import EVM.Solidity
import EVM.SymExec
import EVM.Types
import EVM.Transaction (initTx)
import qualified EVM.Fetch

import qualified EVM.FeeSchedule as FeeSchedule

import EVM.Stepper (Stepper, interpret)
import qualified EVM.Stepper as Stepper
import qualified Control.Monad.Operational as Operational

import Control.Lens hiding (Indexed)
import Control.Monad.State.Strict hiding (state)
import qualified Control.Monad.State.Strict as State

import Control.Monad.Par.Class (spawn_)
import Control.Monad.Par.IO (runParIO)

import qualified Data.ByteString.Lazy as BSLazy
import qualified Data.SBV.Trans.Control as SBV (Query, getValue, resetAssertions)
import qualified Data.SBV.Internals as SBV (State)
import Data.Binary.Get    (runGet)
import Data.ByteString    (ByteString)
import Data.SBV    hiding (verbose)
import Data.SBV.Control   (CheckSatResult(..), checkSat)
import Data.Decimal       (DecimalRaw(..))
import Data.Either        (isRight, lefts)
import Data.Foldable      (toList)
import Data.Map           (Map)
import Data.Maybe         (fromMaybe, catMaybes, fromJust, isJust, fromMaybe, mapMaybe)
import Data.Text          (isPrefixOf, stripSuffix, intercalate, Text, pack, unpack)
import Data.Text.Encoding (encodeUtf8)
import System.Environment (lookupEnv)
import System.IO          (hFlush, stdout)

import qualified Control.Monad.Par.Class as Par
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified Data.Text.IO as Text

import Data.MultiSet (MultiSet)
import qualified Data.MultiSet as MultiSet

import Data.Set (Set)
import qualified Data.Set as Set

import Data.Vector (Vector)
import qualified Data.Vector as Vector

import Test.QuickCheck hiding (verbose)

data UnitTestOptions = UnitTestOptions
  { UnitTestOptions -> Query -> IO (EVM ())
oracle     :: EVM.Query -> IO (EVM ())
  , UnitTestOptions -> Maybe Int
verbose    :: Maybe Int
  , UnitTestOptions -> Maybe Integer
maxIter    :: Maybe Integer
  , UnitTestOptions -> Maybe Integer
smtTimeout :: Maybe Integer
  , UnitTestOptions -> Maybe State
smtState   :: Maybe SBV.State
  , UnitTestOptions -> Maybe Text
solver     :: 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
  }

data TestVMParams = TestVMParams
  { TestVMParams -> Addr
testAddress       :: Addr
  , TestVMParams -> Addr
testCaller        :: Addr
  , TestVMParams -> Addr
testOrigin        :: Addr
  , TestVMParams -> W256
testGasCreate     :: W256
  , TestVMParams -> W256
testGasCall       :: W256
  , TestVMParams -> W256
testBalanceCreate :: W256
  , TestVMParams -> W256
testBalanceCall   :: W256
  , TestVMParams -> Addr
testCoinbase      :: Addr
  , TestVMParams -> W256
testNumber        :: W256
  , TestVMParams -> W256
testTimestamp     :: W256
  , TestVMParams -> W256
testGaslimit      :: W256
  , TestVMParams -> W256
testGasprice      :: W256
  , TestVMParams -> W256
testMaxCodeSize   :: W256
  , TestVMParams -> W256
testDifficulty    :: W256
  , TestVMParams -> W256
testChainId       :: W256
  }

defaultGasForCreating :: W256
defaultGasForCreating :: W256
defaultGasForCreating = 0xffffffffffff

defaultGasForInvoking :: W256
defaultGasForInvoking :: W256
defaultGasForInvoking = 0xffffffffffff

defaultBalanceForCreator :: W256
defaultBalanceForCreator :: W256
defaultBalanceForCreator = 0xffffffffffffffffffffffff

defaultBalanceForCreated :: W256
defaultBalanceForCreated :: W256
defaultBalanceForCreated = 0xffffffffffffffffffffffff

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

type ABIMethod = Text

-- | 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 { .. } theContract :: SolcContract
theContract = do

  let addr :: Addr
addr = TestVMParams -> Addr
testAddress TestVMParams
testParams

  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 VM -> VM
vmModifier
    -- Make a trace entry for running the constructor
    TraceData -> EVM ()
pushTrace (Text -> TraceData
EntryTrace "constructor")

  -- Constructor is loaded; run until it returns code
  ProgramT Action Identity (Either Error Buffer) -> Stepper ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ProgramT Action Identity (Either Error Buffer)
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 -> Identity Env) -> VM -> Identity VM
Lens' VM Env
env ((Env -> Identity Env) -> VM -> Identity VM)
-> ((Word -> Identity Word) -> Env -> Identity Env)
-> (Word -> Identity Word)
-> VM
-> Identity VM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Addr Contract -> Identity (Map Addr Contract))
-> Env -> Identity Env
Lens' Env (Map Addr Contract)
contracts ((Map Addr Contract -> Identity (Map Addr Contract))
 -> Env -> Identity Env)
-> ((Word -> Identity Word)
    -> Map Addr Contract -> Identity (Map Addr Contract))
-> (Word -> Identity Word)
-> Env
-> Identity Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Addr Contract)
-> Traversal' (Map Addr Contract) (IxValue (Map Addr Contract))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Map Addr Contract)
Addr
addr ((Contract -> Identity Contract)
 -> Map Addr Contract -> Identity (Map Addr Contract))
-> ((Word -> Identity Word) -> Contract -> Identity Contract)
-> (Word -> Identity Word)
-> Map Addr Contract
-> Identity (Map Addr Contract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word -> Identity Word) -> Contract -> Identity Contract
Lens' Contract Word
balance ((Word -> Identity Word) -> VM -> Identity VM) -> Word -> EVM ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= W256 -> Word
w256 (TestVMParams -> W256
testBalanceCreate TestVMParams
testParams)

    -- call setUp(), if it exists, to initialize the test contract
    let theAbi :: Map Word32 Method
theAbi = Getting (Map Word32 Method) SolcContract (Map Word32 Method)
-> SolcContract -> Map Word32 Method
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Word32 Method) SolcContract (Map Word32 Method)
Lens' SolcContract (Map Word32 Method)
abiMap SolcContract
theContract
        setUp :: Word32
setUp  = ByteString -> Word32
abiKeccak (Text -> ByteString
encodeUtf8 "setUp()")

    Bool -> EVM () -> EVM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Method -> Bool
forall a. Maybe a -> Bool
isJust (Word32 -> Map Word32 Method -> Maybe Method
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word32
setUp Map Word32 Method
theAbi)) (EVM () -> EVM ()) -> EVM () -> EVM ()
forall a b. (a -> b) -> a -> b
$ do
      TestVMParams -> Text -> AbiValue -> EVM ()
abiCall TestVMParams
testParams "setUp()" AbiValue
emptyAbi
      EVM ()
popTrace
      TraceData -> EVM ()
pushTrace (Text -> TraceData
EntryTrace "setUp()")

  -- Let `setUp()' run to completion
  Either Error Buffer
res <- ProgramT Action Identity (Either Error Buffer)
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 Error Buffer
res of
    Left e :: Error
e -> TraceData -> EVM ()
pushTrace (Error -> TraceData
ErrorTrace Error
e)
    _ -> 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 a :: UnitTestOptions
a method :: Text
method args :: AbiValue
args = do
  Bool
x <- UnitTestOptions -> Text -> AbiValue -> Stepper Bool
execTest UnitTestOptions
a Text
method AbiValue
args
  UnitTestOptions -> Text -> Bool -> Stepper Bool
checkFailures UnitTestOptions
a Text
method Bool
x

execTest :: UnitTestOptions -> ABIMethod -> AbiValue -> Stepper Bool
execTest :: UnitTestOptions -> Text -> AbiValue -> Stepper Bool
execTest UnitTestOptions { .. } method :: Text
method args :: AbiValue
args = 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 -> Text -> AbiValue -> EVM ()
abiCall TestVMParams
testParams Text
method AbiValue
args
    TraceData -> EVM ()
pushTrace (Text -> TraceData
EntryTrace Text
method)
  -- Try running the test method
  ProgramT Action Identity (Either Error Buffer)
Stepper.execFully ProgramT Action Identity (Either Error Buffer)
-> (Either Error Buffer -> Stepper Bool) -> Stepper Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
     -- If we failed, put the error in the trace.
    Left e :: Error
e -> EVM () -> Stepper ()
forall a. EVM a -> Stepper a
Stepper.evm (TraceData -> EVM ()
pushTrace (Error -> TraceData
ErrorTrace Error
e)) Stepper () -> Stepper Bool -> Stepper Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Stepper Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    _ -> Bool -> Stepper Bool
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 { .. } method :: Text
method bailed :: Bool
bailed = do
   -- Decide whether the test is supposed to fail or succeed
  let shouldFail :: Bool
shouldFail = "testFail" Text -> Text -> Bool
`isPrefixOf` Text
method
  if Bool
bailed then
    Bool -> Stepper Bool
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 -> Text -> AbiValue -> EVM ()
abiCall TestVMParams
testParams "failed()" AbiValue
emptyAbi
    Either Error Buffer
res <- ProgramT Action Identity (Either Error Buffer)
Stepper.execFully
    case Either Error Buffer
res of
      Right (ConcreteBuffer r :: ByteString
r) ->
        let AbiBool failed :: Bool
failed = AbiType -> ByteString -> AbiValue
decodeAbiValue AbiType
AbiBoolType (ByteString -> ByteString
BSLazy.fromStrict ByteString
r)
        in Bool -> Stepper Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
shouldFail Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
failed)
      _ -> [Char] -> Stepper Bool
forall a. HasCallStack => [Char] -> a
error "internal error: unexpected failure code"

-- | 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 sig :: Text
sig types :: [AbiType]
types vm :: VM
vm = Gen AbiValue
-> (AbiValue -> [Char]) -> (AbiValue -> Property) -> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [Char]) -> (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 -> [Char]
forall a. Show a => a -> [Char]
show (ByteStringS -> [Char])
-> (AbiValue -> ByteStringS) -> AbiValue -> [Char]
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
$ \args :: 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
$
    (Bool, VM) -> Bool
forall a b. (a, b) -> a
fst ((Bool, VM) -> Bool) -> IO (Bool, VM) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT VM IO Bool -> VM -> IO (Bool, VM)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((Query -> IO (EVM ())) -> Stepper Bool -> StateT VM IO Bool
forall a. (Query -> IO (EVM ())) -> Stepper a -> StateT VM IO a
EVM.Stepper.interpret (UnitTestOptions -> Query -> IO (EVM ())
oracle UnitTestOptions
opts) (UnitTestOptions -> Text -> AbiValue -> Stepper Bool
runUnitTest UnitTestOptions
opts Text
sig AbiValue
args)) VM
vm

tick :: Text -> IO ()
tick :: Text -> IO ()
tick x :: Text
x = Text -> IO ()
Text.putStr Text
x IO () -> IO () -> IO ()
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 -> W256
srcCodehash :: !W256
  , OpLocation -> Int
srcOpIx     :: !Int
  } deriving (OpLocation -> OpLocation -> Bool
(OpLocation -> OpLocation -> Bool)
-> (OpLocation -> OpLocation -> Bool) -> Eq OpLocation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OpLocation -> OpLocation -> Bool
$c/= :: OpLocation -> OpLocation -> Bool
== :: OpLocation -> OpLocation -> Bool
$c== :: OpLocation -> OpLocation -> Bool
Eq, Eq OpLocation
Eq OpLocation =>
(OpLocation -> OpLocation -> Ordering)
-> (OpLocation -> OpLocation -> Bool)
-> (OpLocation -> OpLocation -> Bool)
-> (OpLocation -> OpLocation -> Bool)
-> (OpLocation -> OpLocation -> Bool)
-> (OpLocation -> OpLocation -> OpLocation)
-> (OpLocation -> OpLocation -> OpLocation)
-> Ord OpLocation
OpLocation -> OpLocation -> Bool
OpLocation -> OpLocation -> Ordering
OpLocation -> OpLocation -> OpLocation
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: OpLocation -> OpLocation -> OpLocation
$cmin :: OpLocation -> OpLocation -> OpLocation
max :: OpLocation -> OpLocation -> OpLocation
$cmax :: OpLocation -> OpLocation -> OpLocation
>= :: OpLocation -> OpLocation -> Bool
$c>= :: OpLocation -> OpLocation -> Bool
> :: OpLocation -> OpLocation -> Bool
$c> :: OpLocation -> OpLocation -> Bool
<= :: OpLocation -> OpLocation -> Bool
$c<= :: OpLocation -> OpLocation -> Bool
< :: OpLocation -> OpLocation -> Bool
$c< :: OpLocation -> OpLocation -> Bool
compare :: OpLocation -> OpLocation -> Ordering
$ccompare :: OpLocation -> OpLocation -> Ordering
$cp1Ord :: Eq OpLocation
Ord, Int -> OpLocation -> ShowS
[OpLocation] -> ShowS
OpLocation -> [Char]
(Int -> OpLocation -> ShowS)
-> (OpLocation -> [Char])
-> ([OpLocation] -> ShowS)
-> Show OpLocation
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [OpLocation] -> ShowS
$cshowList :: [OpLocation] -> ShowS
show :: OpLocation -> [Char]
$cshow :: OpLocation -> [Char]
showsPrec :: Int -> OpLocation -> ShowS
$cshowsPrec :: Int -> OpLocation -> ShowS
Show)

srcMapForOpLocation :: DappInfo -> OpLocation -> Maybe SrcMap
srcMapForOpLocation :: DappInfo -> OpLocation -> Maybe SrcMap
srcMapForOpLocation dapp :: DappInfo
dapp (OpLocation hash :: W256
hash opIx :: Int
opIx) =
  case Getting
  (First (CodeType, SolcContract)) DappInfo (CodeType, SolcContract)
-> DappInfo -> Maybe (CodeType, SolcContract)
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((Map W256 (CodeType, SolcContract)
 -> Const
      (First (CodeType, SolcContract))
      (Map W256 (CodeType, SolcContract)))
-> DappInfo -> Const (First (CodeType, SolcContract)) DappInfo
Lens' DappInfo (Map W256 (CodeType, SolcContract))
dappSolcByHash ((Map W256 (CodeType, SolcContract)
  -> Const
       (First (CodeType, SolcContract))
       (Map W256 (CodeType, SolcContract)))
 -> DappInfo -> Const (First (CodeType, SolcContract)) DappInfo)
-> (((CodeType, SolcContract)
     -> Const (First (CodeType, SolcContract)) (CodeType, SolcContract))
    -> Map W256 (CodeType, SolcContract)
    -> Const
         (First (CodeType, SolcContract))
         (Map W256 (CodeType, SolcContract)))
-> Getting
     (First (CodeType, SolcContract)) DappInfo (CodeType, SolcContract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map W256 (CodeType, SolcContract))
-> Traversal'
     (Map W256 (CodeType, SolcContract))
     (IxValue (Map W256 (CodeType, SolcContract)))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Map W256 (CodeType, SolcContract))
W256
hash) DappInfo
dapp of
    Nothing -> Maybe SrcMap
forall a. Maybe a
Nothing
    Just (codeType :: CodeType
codeType, sol :: SolcContract
sol) ->
      let
        vec :: Seq SrcMap
vec =
          case CodeType
codeType of
            Runtime  -> Getting (Seq SrcMap) SolcContract (Seq SrcMap)
-> SolcContract -> Seq SrcMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Seq SrcMap) SolcContract (Seq SrcMap)
Lens' SolcContract (Seq SrcMap)
runtimeSrcmap SolcContract
sol
            Creation -> Getting (Seq SrcMap) SolcContract (Seq SrcMap)
-> SolcContract -> Seq SrcMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Seq SrcMap) SolcContract (Seq SrcMap)
Lens' SolcContract (Seq SrcMap)
creationSrcmap SolcContract
sol
      in
        Getting (First SrcMap) (Seq SrcMap) SrcMap
-> Seq SrcMap -> Maybe SrcMap
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Index (Seq SrcMap)
-> Traversal' (Seq SrcMap) (IxValue (Seq SrcMap))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
Index (Seq SrcMap)
opIx) Seq SrcMap
vec

type CoverageState = (VM, MultiSet OpLocation)

currentOpLocation :: VM -> OpLocation
currentOpLocation :: VM -> OpLocation
currentOpLocation vm :: VM
vm =
  case VM -> Maybe Contract
currentContract VM
vm of
    Nothing ->
      [Char] -> OpLocation
forall a. HasCallStack => [Char] -> a
error "internal error: why no contract?"
    Just c :: Contract
c ->
      W256 -> Int -> OpLocation
OpLocation
        (Getting W256 Contract W256 -> Contract -> W256
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting W256 Contract W256
Lens' Contract W256
codehash Contract
c)
        (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Int
forall a. HasCallStack => [Char] -> a
error "internal error: 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
<$> Getting (Maybe VMResult) CoverageState (Maybe VMResult)
-> StateT CoverageState IO (Maybe VMResult)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((VM -> Const (Maybe VMResult) VM)
-> CoverageState -> Const (Maybe VMResult) CoverageState
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((VM -> Const (Maybe VMResult) VM)
 -> CoverageState -> Const (Maybe VMResult) CoverageState)
-> ((Maybe VMResult -> Const (Maybe VMResult) (Maybe VMResult))
    -> VM -> Const (Maybe VMResult) VM)
-> Getting (Maybe VMResult) CoverageState (Maybe VMResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe VMResult -> Const (Maybe VMResult) (Maybe VMResult))
-> VM -> Const (Maybe VMResult) VM
Lens' VM (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 <- Getting VM CoverageState VM -> StateT CoverageState IO VM
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting VM CoverageState VM
forall s t a b. Field1 s t a b => Lens s t a b
_1
  case ((Maybe VMResult -> Const (Maybe VMResult) (Maybe VMResult))
 -> VM -> Const (Maybe VMResult) VM)
-> VM -> Maybe VMResult
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Maybe VMResult -> Const (Maybe VMResult) (Maybe VMResult))
-> VM -> Const (Maybe VMResult) VM
Lens' VM (Maybe VMResult)
result VM
vm0 of
    Nothing -> do
      VM
vm1 <- LensLike' (Zoomed (StateT VM IO) VM) CoverageState VM
-> StateT VM IO VM -> StateT CoverageState IO VM
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike' (Zoomed (StateT VM IO) VM) CoverageState VM
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((VM -> ((), VM)) -> StateT VM IO ()
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT VM IO VM
forall s (m :: * -> *). MonadState s m => m s
get)
      LensLike'
  (Zoomed (StateT (MultiSet OpLocation) IO) ())
  CoverageState
  (MultiSet OpLocation)
-> StateT (MultiSet OpLocation) IO () -> StateT CoverageState IO ()
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed (StateT (MultiSet OpLocation) IO) ())
  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 _ -> VM -> StateT CoverageState IO VM
forall (f :: * -> *) a. Applicative f => a -> f a
pure VM
vm0


interpretWithCoverage
  :: UnitTestOptions
  -> Stepper a
  -> StateT CoverageState IO a
interpretWithCoverage :: UnitTestOptions -> Stepper a -> StateT CoverageState IO a
interpretWithCoverage opts :: UnitTestOptions
opts =
  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 :: ProgramView Action a -> StateT CoverageState IO a
eval (Operational.Return x :: a
x) =
      a -> StateT CoverageState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

    eval (action :: Action b
action Operational.:>>= k :: b -> ProgramT Action Identity a
k) =
      case Action b
action of
        Stepper.Exec ->
          StateT CoverageState IO VMResult
execWithCoverage StateT CoverageState IO VMResult
-> (VMResult -> StateT CoverageState IO a)
-> StateT CoverageState IO a
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.Run ->
          StateT CoverageState IO VM
runWithCoverage StateT CoverageState IO VM
-> (VM -> StateT CoverageState IO a) -> StateT CoverageState IO a
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.Wait q :: Query
q ->
          do EVM ()
m <- IO (EVM ()) -> StateT CoverageState IO (EVM ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (UnitTestOptions -> Query -> IO (EVM ())
oracle UnitTestOptions
opts Query
q)
             LensLike' (Zoomed (StateT VM IO) ()) CoverageState VM
-> StateT VM IO () -> StateT CoverageState IO ()
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike' (Zoomed (StateT VM IO) ()) CoverageState VM
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((VM -> ((), VM)) -> StateT VM IO ()
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 (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 _ ->
          [Char] -> StateT CoverageState IO a
forall a. HasCallStack => [Char] -> a
error "cannot make choice in this interpreter"
        Stepper.EVM m :: EVM b
m ->
          LensLike' (Zoomed (StateT VM IO) b) CoverageState VM
-> StateT VM IO b -> StateT CoverageState IO b
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike' (Zoomed (StateT VM IO) b) CoverageState 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 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 (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 Text (Vector (Int, ByteString))
coverageReport :: DappInfo -> MultiSet SrcMap -> Map Text (Vector (Int, ByteString))
coverageReport dapp :: DappInfo
dapp cov :: MultiSet SrcMap
cov =
  let
    sources :: SourceCache
    sources :: SourceCache
sources = Getting SourceCache DappInfo SourceCache -> DappInfo -> SourceCache
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting SourceCache DappInfo SourceCache
Lens' DappInfo SourceCache
dappSources DappInfo
dapp

    allPositions :: Set (Text, Int)
    allPositions :: Set (Text, Int)
allPositions =
      ( [(Text, Int)] -> Set (Text, Int)
forall a. Ord a => [a] -> Set a
Set.fromList
      ([(Text, Int)] -> Set (Text, Int))
-> (Seq SrcMap -> [(Text, Int)]) -> Seq SrcMap -> Set (Text, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SrcMap -> Maybe (Text, Int)) -> [SrcMap] -> [(Text, Int)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SourceCache -> SrcMap -> Maybe (Text, Int)
srcMapCodePos SourceCache
sources)
      ([SrcMap] -> [(Text, Int)])
-> (Seq SrcMap -> [SrcMap]) -> Seq SrcMap -> [(Text, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq SrcMap -> [SrcMap]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
      (Seq SrcMap -> Set (Text, Int)) -> Seq SrcMap -> Set (Text, Int)
forall a b. (a -> b) -> a -> b
$ [Seq SrcMap] -> Seq SrcMap
forall a. Monoid a => [a] -> a
mconcat
        ( Getting (Map Text SolcContract) DappInfo (Map Text SolcContract)
-> DappInfo -> Map Text SolcContract
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Text SolcContract) DappInfo (Map Text SolcContract)
Lens' DappInfo (Map Text SolcContract)
dappSolcByName DappInfo
dapp
        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 (\x :: SolcContract
x -> Getting (Seq SrcMap) SolcContract (Seq SrcMap)
-> SolcContract -> Seq SrcMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Seq SrcMap) SolcContract (Seq SrcMap)
Lens' SolcContract (Seq SrcMap)
runtimeSrcmap SolcContract
x Seq SrcMap -> Seq SrcMap -> Seq SrcMap
forall a. Semigroup a => a -> a -> a
<> Getting (Seq SrcMap) SolcContract (Seq SrcMap)
-> SolcContract -> Seq SrcMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Seq SrcMap) SolcContract (Seq SrcMap)
Lens' SolcContract (Seq SrcMap)
creationSrcmap SolcContract
x)
        )
      )

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

    -- linesByName :: Map Text (Vector ByteString)
    linesByName :: Map Text (Vector ByteString)
linesByName =
      ( [(Text, Vector ByteString)] -> Map Text (Vector ByteString)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      ([(Text, Vector ByteString)] -> Map Text (Vector ByteString))
-> (Map Int (Vector ByteString) -> [(Text, Vector ByteString)])
-> Map Int (Vector ByteString)
-> Map Text (Vector ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Vector ByteString) -> (Text, Vector ByteString))
-> [(Int, Vector ByteString)] -> [(Text, Vector ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map
          (\(k :: Int
k, v :: Vector ByteString
v) ->
             ((Text, ByteString) -> Text
forall a b. (a, b) -> a
fst (Maybe (Text, ByteString) -> (Text, ByteString)
forall a. HasCallStack => Maybe a -> a
fromJust (Int -> Map Int (Text, ByteString) -> Maybe (Text, ByteString)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
k (Getting
  (Map Int (Text, ByteString))
  SourceCache
  (Map Int (Text, ByteString))
-> SourceCache -> Map Int (Text, ByteString)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Map Int (Text, ByteString))
  SourceCache
  (Map Int (Text, ByteString))
Lens' SourceCache (Map Int (Text, ByteString))
sourceFiles SourceCache
sources))), Vector ByteString
v))
      ([(Int, Vector ByteString)] -> [(Text, Vector ByteString)])
-> (Map Int (Vector ByteString) -> [(Int, Vector ByteString)])
-> Map Int (Vector ByteString)
-> [(Text, Vector ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Int (Vector ByteString) -> [(Int, Vector ByteString)]
forall k a. Map k a -> [(k, a)]
Map.toList
      (Map Int (Vector ByteString) -> Map Text (Vector ByteString))
-> Map Int (Vector ByteString) -> Map Text (Vector ByteString)
forall a b. (a -> b) -> a -> b
$ Getting
  (Map Int (Vector ByteString))
  SourceCache
  (Map Int (Vector ByteString))
-> SourceCache -> Map Int (Vector ByteString)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Map Int (Vector ByteString))
  SourceCache
  (Map Int (Vector ByteString))
Lens' SourceCache (Map Int (Vector ByteString))
sourceLines SourceCache
sources
      )

    f :: Text -> Vector ByteString -> Vector (Int, ByteString)
    f :: Text -> Vector ByteString -> Vector (Int, ByteString)
f name :: Text
name =
      (Int -> ByteString -> (Int, ByteString))
-> Vector ByteString -> Vector (Int, ByteString)
forall a b. (Int -> a -> b) -> Vector a -> Vector b
Vector.imap
        (\i :: Int
i bs :: ByteString
bs ->
           let
             n :: Int
n =
               if (Text, Int) -> Set (Text, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Text
name, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Set (Text, Int)
allPositions
               then (Text, Int) -> MultiSet (Text, Int) -> Int
forall a. Ord a => a -> MultiSet a -> Int
MultiSet.occur (Text
name, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) MultiSet (Text, Int)
srcMapCov
               else -1
           in (Int
n, ByteString
bs))
  in
    (Text -> Vector ByteString -> Vector (Int, ByteString))
-> Map Text (Vector ByteString)
-> Map Text (Vector (Int, ByteString))
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Text -> Vector ByteString -> Vector (Int, ByteString)
f Map Text (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 {..}) contractMap :: Map Text SolcContract
contractMap _ (name :: Text
name, testNames :: [(Test, [AbiType])]
testNames) = do

  -- Look for the wanted contract by name from the Solidity info
  case Getting (First SolcContract) (Map Text SolcContract) SolcContract
-> Map Text SolcContract -> Maybe SolcContract
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Index (Map Text SolcContract)
-> Traversal'
     (Map Text SolcContract) (IxValue (Map Text SolcContract))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Text
Index (Map Text SolcContract)
name) Map Text SolcContract
contractMap of
    Nothing ->
      -- Fail if there's no such contract
      [Char] -> IO (MultiSet SrcMap)
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO (MultiSet SrcMap)) -> [Char] -> IO (MultiSet SrcMap)
forall a b. (a -> b) -> a -> b
$ "Contract " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ " not found"

    Just theContract :: 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
      (vm1 :: VM
vm1, cov1 :: 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 (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
test, _) = ParIO (MultiSet OpLocation) -> ParIO (IVar (MultiSet OpLocation))
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 (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
          (_, (_, cov :: 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 (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)
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 (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)
mapM IVar (MultiSet OpLocation) -> ParIO (MultiSet OpLocation)
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 (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])])
  -> SBV.Query [(Bool, VM)]
runUnitTestContract :: UnitTestOptions
-> Map Text SolcContract
-> (Text, [(Test, [AbiType])])
-> Query [(Bool, VM)]
runUnitTestContract
  opts :: UnitTestOptions
opts@(UnitTestOptions {..}) contractMap :: Map Text SolcContract
contractMap (name :: Text
name, testSigs :: [(Test, [AbiType])]
testSigs) = do

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

  -- Look for the wanted contract by name from the Solidity info
  case Getting (First SolcContract) (Map Text SolcContract) SolcContract
-> Map Text SolcContract -> Maybe SolcContract
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Index (Map Text SolcContract)
-> Traversal'
     (Map Text SolcContract) (IxValue (Map Text SolcContract))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Text
Index (Map Text SolcContract)
name) Map Text SolcContract
contractMap of
    Nothing ->
      -- Fail if there's no such contract
      [Char] -> Query [(Bool, VM)]
forall a. HasCallStack => [Char] -> a
error ([Char] -> Query [(Bool, VM)]) -> [Char] -> Query [(Bool, VM)]
forall a b. (a -> b) -> a -> b
$ "Contract " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ " not found"

    Just theContract :: 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 -> QueryT IO VM
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO VM -> QueryT IO VM) -> IO VM -> QueryT IO VM
forall a b. (a -> b) -> a -> b
$ StateT VM IO () -> VM -> IO VM
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT
          ((Query -> IO (EVM ())) -> Stepper () -> StateT VM IO ()
forall a. (Query -> IO (EVM ())) -> Stepper a -> StateT VM IO a
EVM.Stepper.interpret Query -> IO (EVM ())
oracle
            (Text -> Stepper ()
Stepper.enter Text
name Stepper () -> Stepper () -> Stepper ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UnitTestOptions -> SolcContract -> Stepper ()
initializeUnitTest UnitTestOptions
opts SolcContract
theContract))
          VM
vm0

      case ((Maybe VMResult -> Const (Maybe VMResult) (Maybe VMResult))
 -> VM -> Const (Maybe VMResult) VM)
-> VM -> Maybe VMResult
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Maybe VMResult -> Const (Maybe VMResult) (Maybe VMResult))
-> VM -> Const (Maybe VMResult) VM
Lens' VM (Maybe VMResult)
result VM
vm1 of
        Nothing -> [Char] -> Query [(Bool, VM)]
forall a. HasCallStack => [Char] -> a
error "internal error: setUp() did not end with a result"
        Just (VMFailure _) -> IO [(Bool, VM)] -> Query [(Bool, VM)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Bool, VM)] -> Query [(Bool, VM)])
-> IO [(Bool, VM)] -> Query [(Bool, VM)]
forall a b. (a -> b) -> a -> b
$ do
          Text -> IO ()
Text.putStrLn "\x1b[31m[BAIL]\x1b[0m setUp() "
          Text -> IO ()
tick "\n"
          Text -> IO ()
tick (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ VM -> UnitTestOptions -> Text -> Text
failOutput VM
vm1 UnitTestOptions
opts "setUp()"
          [(Bool, VM)] -> IO [(Bool, VM)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Bool
False, VM
vm1)]
        Just (VMSuccess _) -> do
          let
            runCache :: ([(Either Text Text, VM)], VM) -> (Test, [AbiType])
                        -> SBV.Query ([(Either Text Text, VM)], VM)
            runCache :: ([(Either Text Text, VM)], VM)
-> (Test, [AbiType]) -> Query ([(Either Text Text, VM)], VM)
runCache (results :: [(Either Text Text, VM)]
results, vm :: VM
vm) (test :: Test
test, types :: [AbiType]
types) = do
              (t :: Text
t, r :: Either Text Text
r, vm' :: VM
vm') <- UnitTestOptions
-> VM -> (Test, [AbiType]) -> Query (Text, Either Text Text, VM)
runTest UnitTestOptions
opts VM
vm (Test
test, [AbiType]
types)
              IO () -> QueryT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> QueryT IO ()) -> IO () -> QueryT IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
Text.putStrLn Text
t
              let vmCached :: VM
vmCached = VM
vm VM -> (VM -> VM) -> VM
forall a b. a -> (a -> b) -> b
& ASetter VM VM (Map Addr Contract) (Map Addr Contract)
-> Map Addr Contract -> VM -> VM
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Cache -> Identity Cache) -> VM -> Identity VM
Lens' VM Cache
cache ((Cache -> Identity Cache) -> VM -> Identity VM)
-> ((Map Addr Contract -> Identity (Map Addr Contract))
    -> Cache -> Identity Cache)
-> ASetter VM VM (Map Addr Contract) (Map Addr Contract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Addr Contract -> Identity (Map Addr Contract))
-> Cache -> Identity Cache
Lens' Cache (Map Addr Contract)
fetched) (Getting (Map Addr Contract) VM (Map Addr Contract)
-> VM -> Map Addr Contract
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Cache -> Const (Map Addr Contract) Cache)
-> VM -> Const (Map Addr Contract) VM
Lens' VM Cache
cache ((Cache -> Const (Map Addr Contract) Cache)
 -> VM -> Const (Map Addr Contract) VM)
-> ((Map Addr Contract
     -> Const (Map Addr Contract) (Map Addr Contract))
    -> Cache -> Const (Map Addr Contract) Cache)
-> Getting (Map Addr Contract) VM (Map Addr Contract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Addr Contract
 -> Const (Map Addr Contract) (Map Addr Contract))
-> Cache -> Const (Map Addr Contract) Cache
Lens' Cache (Map Addr Contract)
fetched) VM
vm')
              ([(Either Text Text, VM)], VM)
-> Query ([(Either Text Text, VM)], VM)
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
          (details :: [(Either Text Text, VM)]
details, _) <- (([(Either Text Text, VM)], VM)
 -> (Test, [AbiType]) -> Query ([(Either Text Text, VM)], VM))
-> ([(Either Text Text, VM)], VM)
-> [(Test, [AbiType])]
-> Query ([(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]) -> Query ([(Either Text Text, VM)], VM)
runCache ([], VM
vm1) [(Test, [AbiType])]
testSigs

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

          IO () -> QueryT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> QueryT IO ()) -> IO () -> QueryT IO ()
forall a b. (a -> b) -> a -> b
$ do
            Text -> IO ()
tick "\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 -> 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]
bailing))

          [(Bool, VM)] -> Query [(Bool, VM)]
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) | (r :: Either Text Text
r, vm :: VM
vm) <- [(Either Text Text, VM)]
details]


runTest :: UnitTestOptions -> VM -> (Test, [AbiType]) -> SBV.Query (Text, Either Text Text, VM)
runTest :: UnitTestOptions
-> VM -> (Test, [AbiType]) -> Query (Text, Either Text Text, VM)
runTest opts :: UnitTestOptions
opts@UnitTestOptions{..} vm :: VM
vm (ConcreteTest testName :: Text
testName, []) = IO (Text, Either Text Text, VM)
-> Query (Text, Either Text Text, VM)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Text, Either Text Text, VM)
 -> Query (Text, Either Text Text, VM))
-> IO (Text, Either Text Text, VM)
-> Query (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{..} vm :: VM
vm (ConcreteTest testName :: Text
testName, types :: [AbiType]
types) = IO (Text, Either Text Text, VM)
-> Query (Text, Either Text Text, VM)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Text, Either Text Text, VM)
 -> Query (Text, Either Text Text, VM))
-> IO (Text, Either Text Text, VM)
-> Query (Text, Either Text Text, VM)
forall a b. (a -> b) -> a -> b
$ case Maybe (Text, ByteString)
replay of
  Nothing ->
    UnitTestOptions
-> VM -> Text -> [AbiType] -> IO (Text, Either Text Text, VM)
fuzzRun UnitTestOptions
opts VM
vm Text
testName [AbiType]
types
  Just (sig :: Text
sig, callData :: 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 vm :: VM
vm (SymbolicTest testName :: Text
testName, types :: [AbiType]
types) = UnitTestOptions
-> VM -> Text -> [AbiType] -> Query (Text, Either Text Text, VM)
symRun UnitTestOptions
opts VM
vm Text
testName [AbiType]
types

-- | 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{..} vm :: VM
vm testName :: Text
testName args :: AbiValue
args = do
  let argInfo :: Text
argInfo = [Char] -> Text
pack (if AbiValue
args AbiValue -> AbiValue -> Bool
forall a. Eq a => a -> a -> Bool
== AbiValue
emptyAbi then "" else " with arguments: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> AbiValue -> [Char]
forall a. Show a => a -> [Char]
show AbiValue
args)
  (bailed :: Bool
bailed, vm' :: VM
vm') <-
    StateT VM IO Bool -> VM -> IO (Bool, VM)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
      ((Query -> IO (EVM ())) -> Stepper Bool -> StateT VM IO Bool
forall a. (Query -> IO (EVM ())) -> Stepper a -> StateT VM IO a
EVM.Stepper.interpret Query -> IO (EVM ())
oracle (UnitTestOptions -> Text -> AbiValue -> Stepper Bool
execTest UnitTestOptions
opts Text
testName AbiValue
args))
      VM
vm
  (success :: Bool
success, vm'' :: VM
vm'') <-
    StateT VM IO Bool -> VM -> IO (Bool, VM)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
      ((Query -> IO (EVM ())) -> Stepper Bool -> StateT VM IO Bool
forall a. (Query -> IO (EVM ())) -> Stepper a -> StateT VM IO a
EVM.Stepper.interpret Query -> IO (EVM ())
oracle (UnitTestOptions -> Text -> Bool -> Stepper Bool
checkFailures UnitTestOptions
opts Text
testName Bool
bailed)) VM
vm'
  if Bool
success
  then
     let gasSpent :: Word
gasSpent = W256 -> Word
forall a b. (Integral a, Num b) => a -> b
num (TestVMParams -> W256
testGasCall TestVMParams
testParams) Word -> Word -> Word
forall a. Num a => a -> a -> a
- Getting Word VM Word -> VM -> Word
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((FrameState -> Const Word FrameState) -> VM -> Const Word VM
Lens' VM FrameState
state ((FrameState -> Const Word FrameState) -> VM -> Const Word VM)
-> ((Word -> Const Word Word)
    -> FrameState -> Const Word FrameState)
-> Getting Word VM Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word -> Const Word Word) -> FrameState -> Const Word FrameState
Lens' FrameState Word
gas) VM
vm'
         gasText :: Text
gasText = [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Integer -> [Char]
forall a. Show a => a -> [Char]
show (Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
gasSpent :: Integer)
     in
        (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ("\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
<> " (gas: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
gasText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
          , 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 (f :: * -> *) a. Applicative f => a -> f a
pure
          ("\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 (f :: * -> *) a. Applicative f => a -> f a
pure
          ("\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{..} vm :: VM
vm testName :: Text
testName types :: [AbiType]
types = do
  let args :: Args
args = Args :: Maybe (QCGen, Int) -> Int -> Int -> Int -> Bool -> Int -> Args
Args{ replay :: Maybe (QCGen, Int)
replay          = Maybe (QCGen, Int)
forall a. Maybe a
Nothing
                 , maxSuccess :: Int
maxSuccess      = Int
fuzzRuns
                 , maxDiscardRatio :: Int
maxDiscardRatio = 10
                 , maxSize :: Int
maxSize         = 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Success numTests :: Int
numTests _ _ _ _ _ ->
      (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ("\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
<> " (runs: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ([Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
numTests) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
             -- 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
           )
    Failure _ _ _ _ _ _ _ _ _ _ failCase :: [[Char]]
failCase _ _ ->
      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 ([Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]]
failCase)
          ppOutput :: Text
ppOutput = [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ AbiValue -> [Char]
forall a. Show a => a -> [Char]
show AbiValue
abiValue
      in do
        -- Run the failing test again to get a proper trace
        VM
vm' <- StateT VM IO Bool -> VM -> IO VM
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT ((Query -> IO (EVM ())) -> Stepper Bool -> StateT VM IO Bool
forall a. (Query -> IO (EVM ())) -> Stepper a -> StateT VM IO a
EVM.Stepper.interpret Query -> IO (EVM ())
oracle (UnitTestOptions -> Text -> AbiValue -> Stepper Bool
runUnitTest UnitTestOptions
opts Text
testName AbiValue
abiValue)) VM
vm
        (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ("\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
<> ". Counterexample: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ppOutput
               Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\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
forall a. Semigroup a => a -> a -> a
<> ([Char] -> Text
pack ([[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]]
failCase)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\")'\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
forall a. Semigroup a => a -> a -> a
<> ([Char] -> Text
pack ([[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]]
failCase)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\")'\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'
             )
    _ -> (Text, Either Text Text, VM) -> IO (Text, Either Text Text, VM)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ("\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
-- TODO: return a list of VM's
symRun :: UnitTestOptions -> VM -> Text -> [AbiType] -> SBV.Query (Text, Either Text Text, VM)
symRun :: UnitTestOptions
-> VM -> Text -> [AbiType] -> Query (Text, Either Text Text, VM)
symRun opts :: UnitTestOptions
opts@UnitTestOptions{..} concreteVm :: VM
concreteVm testName :: Text
testName types :: [AbiType]
types = do
    QueryT IO ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m ()
SBV.resetAssertions
    let vm :: VM
vm = VM -> VM
symbolify VM
concreteVm
    (cd :: [SWord 8]
cd, cdlen :: W256
cdlen) <- Text -> [AbiType] -> [[Char]] -> Query ([SWord 8], W256)
symCalldata Text
testName [AbiType]
types []
    let cd' :: (Buffer, SymWord)
cd' = ([SWord 8] -> Buffer
SymbolicBuffer [SWord 8]
cd, W256 -> SymWord
w256lit W256
cdlen)
        shouldFail :: Bool
shouldFail = "proveFail" Text -> Text -> Bool
`isPrefixOf` Text
testName

    -- get all posible postVMs for the test method
    [(Bool, VM)]
allPaths <- ([(Bool, VM)], VM) -> [(Bool, VM)]
forall a b. (a, b) -> a
fst (([(Bool, VM)], VM) -> [(Bool, VM)])
-> Query ([(Bool, VM)], VM) -> Query [(Bool, VM)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT VM Query [(Bool, VM)] -> VM -> Query ([(Bool, VM)], VM)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
        ((Query -> IO (EVM ()))
-> Maybe Integer
-> Stepper (Bool, VM)
-> StateT VM Query [(Bool, VM)]
forall a.
(Query -> IO (EVM ()))
-> Maybe Integer -> Stepper a -> StateT VM Query [a]
EVM.SymExec.interpret Query -> IO (EVM ())
oracle Maybe Integer
maxIter (UnitTestOptions -> Text -> (Buffer, SymWord) -> Stepper (Bool, VM)
execSymTest UnitTestOptions
opts Text
testName (Buffer, SymWord)
cd')) VM
vm
    let consistentPaths :: [(Bool, VM)]
consistentPaths = (((Bool, VM) -> Bool) -> [(Bool, VM)] -> [(Bool, VM)])
-> [(Bool, VM)] -> ((Bool, VM) -> Bool) -> [(Bool, VM)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Bool, VM) -> Bool) -> [(Bool, VM)] -> [(Bool, VM)]
forall a. (a -> Bool) -> [a] -> [a]
filter [(Bool, VM)]
allPaths (((Bool, VM) -> Bool) -> [(Bool, VM)])
-> ((Bool, VM) -> Bool) -> [(Bool, VM)]
forall a b. (a -> b) -> a -> b
$
          \(_, vm' :: VM
vm') -> case ((Maybe VMResult -> Const (Maybe VMResult) (Maybe VMResult))
 -> VM -> Const (Maybe VMResult) VM)
-> VM -> Maybe VMResult
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Maybe VMResult -> Const (Maybe VMResult) (Maybe VMResult))
-> VM -> Const (Maybe VMResult) VM
Lens' VM (Maybe VMResult)
result VM
vm' of
            Just (VMFailure DeadPath) -> Bool
False
            _ -> Bool
True
    [Either (VM, Text) ()]
results <- [(Bool, VM)]
-> ((Bool, VM) -> QueryT IO (Either (VM, Text) ()))
-> QueryT IO [Either (VM, Text) ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Bool, VM)]
consistentPaths (((Bool, VM) -> QueryT IO (Either (VM, Text) ()))
 -> QueryT IO [Either (VM, Text) ()])
-> ((Bool, VM) -> QueryT IO (Either (VM, Text) ()))
-> QueryT IO [Either (VM, Text) ()]
forall a b. (a -> b) -> a -> b
$
      -- If the vm execution succeeded, check if the vm is reachable,
      -- and if any ds-test assertions were triggered
      -- Report a failure depending on the prefix of the test name

      -- If the vm execution failed, check if the vm is reachable, and if so,
      -- report a failure unless the test is supposed to fail.

      \(bailed :: Bool
bailed, vm' :: VM
vm') -> do
        let ?context = DappContext { _contextInfo = dapp, _contextEnv = vm ^?! EVM.env }
        QueryT IO ()
forall (m :: * -> *). (MonadIO m, MonadQuery m) => m ()
SBV.resetAssertions
        SBool -> QueryT IO ()
forall (m :: * -> *). SolverContext m => SBool -> m ()
constrain (SBool -> QueryT IO ()) -> SBool -> QueryT IO ()
forall a b. (a -> b) -> a -> b
$ [SBool] -> SBool
sAnd ((SBool, Whiff) -> SBool
forall a b. (a, b) -> a
fst ((SBool, Whiff) -> SBool) -> [(SBool, Whiff)] -> [SBool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting [(SBool, Whiff)] VM [(SBool, Whiff)]
-> VM -> [(SBool, Whiff)]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [(SBool, Whiff)] VM [(SBool, Whiff)]
Lens' VM [(SBool, Whiff)]
EVM.constraints VM
vm')
        Bool -> QueryT IO () -> QueryT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
bailed (QueryT IO () -> QueryT IO ()) -> QueryT IO () -> QueryT IO ()
forall a b. (a -> b) -> a -> b
$
          case ((Maybe VMResult -> Const (Maybe VMResult) (Maybe VMResult))
 -> VM -> Const (Maybe VMResult) VM)
-> VM -> Maybe VMResult
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Maybe VMResult -> Const (Maybe VMResult) (Maybe VMResult))
-> VM -> Const (Maybe VMResult) VM
Lens' VM (Maybe VMResult)
result VM
vm' of
            Just (VMSuccess (SymbolicBuffer buf :: [SWord 8]
buf)) ->
              SBool -> QueryT IO ()
forall (m :: * -> *). SolverContext m => SBool -> m ()
constrain (SBool -> QueryT IO ()) -> SBool -> QueryT IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [SWord 8]
litBytes (AbiValue -> ByteString
encodeAbiValue (AbiValue -> ByteString) -> AbiValue -> ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> AbiValue
AbiBool (Bool -> AbiValue) -> Bool -> AbiValue
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
shouldFail) [SWord 8] -> [SWord 8] -> SBool
forall a. EqSymbolic a => a -> a -> SBool
.== [SWord 8]
buf
            r :: Maybe VMResult
r -> [Char] -> QueryT IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> QueryT IO ()) -> [Char] -> QueryT IO ()
forall a b. (a -> b) -> a -> b
$ "unexpected return value: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe VMResult -> [Char]
forall a. Show a => a -> [Char]
show Maybe VMResult
r
        Query CheckSatResult
checkSat Query CheckSatResult
-> (CheckSatResult -> QueryT IO (Either (VM, Text) ()))
-> QueryT IO (Either (VM, Text) ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Sat -> do
            Text
prettyCd <- (?context::DappContext) =>
(Buffer, SymWord) -> Text -> [AbiType] -> Query Text
(Buffer, SymWord) -> Text -> [AbiType] -> Query Text
prettyCalldata (Buffer, SymWord)
cd' Text
testName [AbiType]
types
            let explorationFailed :: Bool
explorationFailed = case ((Maybe VMResult -> Const (Maybe VMResult) (Maybe VMResult))
 -> VM -> Const (Maybe VMResult) VM)
-> VM -> Maybe VMResult
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Maybe VMResult -> Const (Maybe VMResult) (Maybe VMResult))
-> VM -> Const (Maybe VMResult) VM
Lens' VM (Maybe VMResult)
result VM
vm' of
                  Just (VMFailure e :: Error
e) -> case Error
e of
                                          NotUnique _ -> Bool
True
                                          UnexpectedSymbolicArg -> Bool
True
                                          _ -> Bool
False
                  _ -> Bool
False
            Either (VM, Text) () -> QueryT IO (Either (VM, Text) ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (VM, Text) () -> QueryT IO (Either (VM, Text) ()))
-> Either (VM, Text) () -> QueryT IO (Either (VM, Text) ())
forall a b. (a -> b) -> a -> b
$
              if Bool
shouldFail Bool -> Bool -> Bool
&& Bool
bailed Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
explorationFailed
              then () -> Either (VM, Text) ()
forall a b. b -> Either a b
Right ()
              else (VM, Text) -> Either (VM, Text) ()
forall a b. a -> Either a b
Left (VM
vm', Text
prettyCd)
          Unsat -> Either (VM, Text) () -> QueryT IO (Either (VM, Text) ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (VM, Text) () -> QueryT IO (Either (VM, Text) ()))
-> Either (VM, Text) () -> QueryT IO (Either (VM, Text) ())
forall a b. (a -> b) -> a -> b
$ () -> Either (VM, Text) ()
forall a b. b -> Either a b
Right ()
          Unk -> Either (VM, Text) () -> QueryT IO (Either (VM, Text) ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (VM, Text) () -> QueryT IO (Either (VM, Text) ()))
-> Either (VM, Text) () -> QueryT IO (Either (VM, Text) ())
forall a b. (a -> b) -> a -> b
$ (VM, Text) -> Either (VM, Text) ()
forall a b. a -> Either a b
Left (VM
vm', "unknown; query timeout")
          DSat _ -> [Char] -> QueryT IO (Either (VM, Text) ())
forall a. HasCallStack => [Char] -> a
error "Unexpected DSat"

    if [(VM, Text)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(VM, Text)] -> Bool) -> [(VM, Text)] -> Bool
forall a b. (a -> b) -> a -> b
$ [Either (VM, Text) ()] -> [(VM, Text)]
forall a b. [Either a b] -> [a]
lefts [Either (VM, Text) ()]
results
    then
      (Text, Either Text Text, VM) -> Query (Text, Either Text Text, VM)
forall (m :: * -> *) a. Monad m => a -> m a
return ("\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 "", VM
vm)
    else
      (Text, Either Text Text, VM) -> Query (Text, Either Text Text, VM)
forall (m :: * -> *) a. Monad m => a -> m a
return ("\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 -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ UnitTestOptions -> Text -> [(VM, Text)] -> Text
symFailure UnitTestOptions
opts Text
testName ([Either (VM, Text) ()] -> [(VM, Text)]
forall a b. [Either a b] -> [a]
lefts [Either (VM, Text) ()]
results), VM
vm)

symFailure :: UnitTestOptions -> Text -> [(VM, Text)] -> Text
symFailure :: UnitTestOptions -> Text -> [(VM, Text)] -> Text
symFailure UnitTestOptions {..} testName :: Text
testName failures' :: [(VM, Text)]
failures' = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
  [ "Failure: "
  , Text
testName
  , "\n\n"
  , Text -> [Text] -> Text
intercalate "\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
indentLines 2 (Text -> Text) -> ((VM, Text) -> Text) -> (VM, Text) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VM, Text) -> Text
mkMsg ((VM, Text) -> Text) -> [(VM, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(VM, Text)]
failures'
  ]
  where
    showRes :: VM -> [Char]
showRes vm :: VM
vm = let Just res :: VMResult
res = ((Maybe VMResult -> Const (Maybe VMResult) (Maybe VMResult))
 -> VM -> Const (Maybe VMResult) VM)
-> VM -> Maybe VMResult
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Maybe VMResult -> Const (Maybe VMResult) (Maybe VMResult))
-> VM -> Const (Maybe VMResult) VM
Lens' VM (Maybe VMResult)
result VM
vm in
                 case VMResult
res of
                   VMFailure _ ->
                     let ?context = DappContext { _contextInfo = dapp, _contextEnv = vm ^?! EVM.env }
                     in (?context::DappContext) => VMResult -> [Char]
VMResult -> [Char]
prettyvmresult VMResult
res
                   VMSuccess _ -> if "proveFail" Text -> Text -> Bool
`isPrefixOf` Text
testName
                                  then "Successful execution"
                                  else "Failed: DSTest Assertion Violation"
    mkMsg :: (VM, Text) -> Text
mkMsg (vm :: VM
vm, cd :: Text
cd) = [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
      ["Counterexample:"
      ,""
      ,"  result:   " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> VM -> [Char]
showRes VM
vm
      ,"  calldata: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
unpack Text
cd
      , case Maybe Int
verbose of
          Just _ -> [[Char]] -> [Char]
unlines
            [ ""
            , Text -> [Char]
unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
indentLines 2 (DappInfo -> VM -> Text
showTraceTree DappInfo
dapp VM
vm)
            ]
          _ -> ""
      ]

prettyCalldata :: (?context :: DappContext) => (Buffer, SymWord) -> Text -> [AbiType]-> SBV.Query Text
prettyCalldata :: (Buffer, SymWord) -> Text -> [AbiType] -> Query Text
prettyCalldata (buffer :: Buffer
buffer, S _ cdlen :: SWord 256
cdlen) sig :: Text
sig types :: [AbiType]
types = do
  Int
cdlen' <- WordN 256 -> Int
forall a b. (Integral a, Num b) => a -> b
num (WordN 256 -> Int) -> QueryT IO (WordN 256) -> QueryT IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SWord 256 -> QueryT IO (WordN 256)
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m, SymVal a) =>
SBV a -> m a
SBV.getValue SWord 256
cdlen
  ByteString
cd <- case Buffer
buffer of
    SymbolicBuffer cd :: [SWord 8]
cd -> (SWord 8 -> QueryT IO Word8) -> [SWord 8] -> QueryT IO [Word8]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SBV Word8 -> QueryT IO Word8
forall (m :: * -> *) a.
(MonadIO m, MonadQuery m, SymVal a) =>
SBV a -> m a
SBV.getValue (SBV Word8 -> QueryT IO Word8)
-> (SWord 8 -> SBV Word8) -> SWord 8 -> QueryT IO Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SWord 8 -> SBV Word8
forall a. FromSizedBV a => a -> FromSized a
fromSized) (Int -> [SWord 8] -> [SWord 8]
forall a. Int -> [a] -> [a]
take Int
cdlen' [SWord 8]
cd) QueryT IO [Word8]
-> ([Word8] -> ByteString) -> QueryT IO ByteString
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [Word8] -> ByteString
BS.pack
    ConcreteBuffer cd :: ByteString
cd -> ByteString -> QueryT IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> QueryT IO ByteString)
-> ByteString -> QueryT IO ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
cdlen' ByteString
cd
  Text -> Query Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Query Text) -> Text -> Query Text
forall a b. (a -> b) -> a -> b
$ ([Text] -> Text
forall a. [a] -> a
head (Text -> Text -> [Text]
Text.splitOn "(" Text
sig)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (?context::DappContext) => [AbiType] -> Buffer -> Text
[AbiType] -> Buffer -> Text
showCall [AbiType]
types (ByteString -> Buffer
ConcreteBuffer ByteString
cd)

execSymTest :: UnitTestOptions -> ABIMethod -> (Buffer, SymWord) -> Stepper (Bool, VM)
execSymTest :: UnitTestOptions -> Text -> (Buffer, SymWord) -> Stepper (Bool, VM)
execSymTest opts :: UnitTestOptions
opts@UnitTestOptions{ .. } method :: Text
method cd :: (Buffer, SymWord)
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 -> (Buffer, SymWord) -> EVM ()
makeTxCall TestVMParams
testParams (Buffer, SymWord)
cd
    TraceData -> EVM ()
pushTrace (Text -> TraceData
EntryTrace Text
method)
  -- Try running the test method
  Stepper VM
Stepper.runFully Stepper VM -> (VM -> Stepper (Bool, VM)) -> Stepper (Bool, VM)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \vm' :: VM
vm' -> case ((Maybe VMResult -> Const (Maybe VMResult) (Maybe VMResult))
 -> VM -> Const (Maybe VMResult) VM)
-> VM -> Maybe VMResult
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Maybe VMResult -> Const (Maybe VMResult) (Maybe VMResult))
-> VM -> Const (Maybe VMResult) VM
Lens' VM (Maybe VMResult)
result VM
vm' of
    Just (VMFailure err :: Error
err) ->
      -- If we failed, put the error in the trace.
      EVM () -> Stepper ()
forall a. EVM a -> Stepper a
Stepper.evm (TraceData -> EVM ()
pushTrace (Error -> TraceData
ErrorTrace Error
err)) Stepper () -> Stepper (Bool, VM) -> Stepper (Bool, VM)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ((Bool, VM) -> Stepper (Bool, VM)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, VM
vm'))
    Just (VMSuccess _) -> do
      VM
postVm <- UnitTestOptions -> Stepper VM
checkSymFailures UnitTestOptions
opts
      (Bool, VM) -> Stepper (Bool, VM)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, VM
postVm)
    Nothing -> [Char] -> Stepper (Bool, VM)
forall a. HasCallStack => [Char] -> a
error "Internal Error: execSymTest: vm has not completed execution!"

checkSymFailures :: UnitTestOptions -> Stepper VM
checkSymFailures :: UnitTestOptions -> Stepper VM
checkSymFailures UnitTestOptions { .. } = 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 -> Text -> AbiValue -> EVM ()
abiCall TestVMParams
testParams "failed()" AbiValue
emptyAbi
  Stepper VM
Stepper.runFully

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

passOutput :: VM -> UnitTestOptions -> Text -> Text
passOutput :: VM -> UnitTestOptions -> Text -> Text
passOutput vm :: VM
vm UnitTestOptions { .. } testName :: Text
testName =
  let ?context = DappContext { _contextInfo = dapp, _contextEnv = vm ^?! EVM.env }
  in let v :: Int
v = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 0 Maybe Int
verbose
  in if (Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1) then
    [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
      [ "Success: "
      , Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "" (Text -> Text -> Maybe Text
stripSuffix "()" Text
testName)
      , "\n"
      , if (Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 2) then Int -> Text -> Text
indentLines 2 (DappInfo -> VM -> Text
showTraceTree DappInfo
dapp VM
vm) else ""
      , Int -> Text -> Text
indentLines 2 ((?context::DappContext) => Map W256 Event -> Seq Log -> Text
Map W256 Event -> Seq Log -> Text
formatTestLogs (Getting (Map W256 Event) DappInfo (Map W256 Event)
-> DappInfo -> Map W256 Event
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map W256 Event) DappInfo (Map W256 Event)
Lens' DappInfo (Map W256 Event)
dappEventMap DappInfo
dapp) (Getting (Seq Log) VM (Seq Log) -> VM -> Seq Log
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Seq Log) VM (Seq Log)
Lens' VM (Seq Log)
logs VM
vm))
      , "\n"
      ]
    else ""

failOutput :: VM -> UnitTestOptions -> Text -> Text
failOutput :: VM -> UnitTestOptions -> Text -> Text
failOutput vm :: VM
vm UnitTestOptions { .. } testName :: Text
testName =
  let ?context = DappContext { _contextInfo = dapp, _contextEnv = vm ^?! EVM.env }
  in [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
  [ "Failure: "
  , Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "" (Text -> Text -> Maybe Text
stripSuffix "()" Text
testName)
  , "\n"
  , case Maybe Int
verbose of
      Just _ -> Int -> Text -> Text
indentLines 2 (DappInfo -> VM -> Text
showTraceTree DappInfo
dapp VM
vm)
      _ -> ""
  , Int -> Text -> Text
indentLines 2 ((?context::DappContext) => Map W256 Event -> Seq Log -> Text
Map W256 Event -> Seq Log -> Text
formatTestLogs (Getting (Map W256 Event) DappInfo (Map W256 Event)
-> DappInfo -> Map W256 Event
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map W256 Event) DappInfo (Map W256 Event)
Lens' DappInfo (Map W256 Event)
dappEventMap DappInfo
dapp) (Getting (Seq Log) VM (Seq Log) -> VM -> Seq Log
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Seq Log) VM (Seq Log)
Lens' VM (Seq Log)
logs VM
vm))
  , "\n"
  ]

formatTestLogs :: (?context :: DappContext) => Map W256 Event -> Seq.Seq Log -> Text
formatTestLogs :: Map W256 Event -> Seq Log -> Text
formatTestLogs events :: Map W256 Event
events xs :: Seq Log
xs =
  case [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes (Seq (Maybe Text) -> [Maybe Text]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((Log -> Maybe Text) -> Seq Log -> Seq (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((?context::DappContext) => Map W256 Event -> Log -> Maybe Text
Map W256 Event -> Log -> Maybe Text
formatTestLog Map W256 Event
events) Seq Log
xs)) of
    [] -> "\n"
    ys :: [Text]
ys -> "\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate "\n" [Text]
ys Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\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 -> Log -> Maybe Text
formatTestLog :: Map W256 Event -> Log -> Maybe Text
formatTestLog _ (Log _ _ []) = Maybe Text
forall a. Maybe a
Nothing
formatTestLog events :: Map W256 Event
events (Log _ args :: Buffer
args (topic :: SymWord
topic:_)) =
  case SymWord -> Maybe Word
maybeLitWord SymWord
topic Maybe Word -> (Word -> Maybe Event) -> Maybe Event
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \t1 :: Word
t1 -> (W256 -> Map W256 Event -> Maybe Event
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Word -> W256
wordValue Word
t1) Map W256 Event
events) of
    Nothing -> Maybe Text
forall a. Maybe a
Nothing
    Just (Event name :: Text
name _ types :: [(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
<$> ([(AbiType, Indexed)] -> [AbiType]
unindexed [(AbiType, Indexed)]
types))) of
        "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 -> Buffer -> Text
AbiType -> Buffer -> Text
showValue AbiType
AbiStringType Buffer
args

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

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

        -- log_x(x)
        "log_bytes32(bytes32)" -> Maybe Text
log_unnamed
        "log_address(address)" -> Maybe Text
log_unnamed
        "log_int(int256)"      -> Maybe Text
log_unnamed
        "log_uint(uint256)"    -> Maybe Text
log_unnamed
        "log_bytes(bytes)"     -> Maybe Text
log_unnamed
        "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
        "log_named_bytes32(bytes32, bytes32)" -> Maybe Text
log_named
        "log_named_address(bytes32, address)" -> Maybe Text
log_named
        "log_named_int(bytes32, int256)"      -> Maybe Text
log_named
        "log_named_uint(bytes32, uint256)"    -> Maybe Text
log_named

        _ -> Maybe Text
forall a. Maybe a
Nothing

        where
          ts :: [AbiType]
ts = [(AbiType, Indexed)] -> [AbiType]
unindexed [(AbiType, Indexed)]
types
          unquote :: Text -> Text
unquote = (Char -> Bool) -> Text -> Text
Text.dropAround (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '"' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '«' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '»')
          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 -> Buffer -> Text
AbiType -> Buffer -> Text
showValue ([AbiType] -> AbiType
forall a. [a] -> a
head [AbiType]
ts) Buffer
args
          log_named :: Maybe Text
log_named =
            let [key :: Text
key, val :: Text
val] = Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take 2 ((?context::DappContext) => [AbiType] -> Buffer -> [Text]
[AbiType] -> Buffer -> [Text]
textValues [AbiType]
ts Buffer
args)
            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
forall a. Semigroup a => a -> a -> a
<> Text
val
          showDecimal :: a -> i -> Text
showDecimal dec :: a
dec val :: i
val =
            [Char] -> Text
pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ DecimalRaw i -> [Char]
forall a. Show a => a -> [Char]
show (DecimalRaw i -> [Char]) -> DecimalRaw i -> [Char]
forall a b. (a -> b) -> a -> b
$ Word8 -> i -> DecimalRaw i
forall i. Word8 -> i -> DecimalRaw i
Decimal (a -> Word8
forall a b. (Integral a, Num b) => a -> b
num a
dec) i
val
          log_named_decimal :: Maybe Text
log_named_decimal =
            case Buffer
args of
              (ConcreteBuffer b :: ByteString
b) ->
                case Vector AbiValue -> [AbiValue]
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 (t :: * -> *) a. Foldable t => t a -> Int
length [AbiType]
ts) [AbiType]
ts) (ByteString -> ByteString
BSLazy.fromStrict ByteString
b) of
                  [key :: AbiValue
key, (AbiUInt 256 val :: Word256
val), (AbiUInt 256 dec :: 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
forall a. Semigroup a => a -> a -> a
<> Word256 -> Word256 -> Text
forall i a. (Show i, Integral i, Integral a) => a -> i -> Text
showDecimal Word256
dec Word256
val
                  [key :: AbiValue
key, (AbiInt 256 val :: Int256
val), (AbiUInt 256 dec :: 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
forall a. Semigroup a => a -> a -> a
<> Word256 -> Int256 -> Text
forall i a. (Show i, Integral i, Integral a) => a -> i -> Text
showDecimal Word256
dec Int256
val
                  _ -> Maybe Text
forall a. Maybe a
Nothing
              (SymbolicBuffer _) -> Text -> Maybe Text
forall a. a -> Maybe a
Just "<symbolic decimal>"


word32Bytes :: Word32 -> ByteString
word32Bytes :: Word32 -> ByteString
word32Bytes x :: Word32
x = [Word8] -> ByteString
BS.pack [Word32 -> Int -> Word8
forall a b. (Bits a, Bits b, Integral a, Num b) => a -> Int -> b
byteAt Word32
x (3 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) | Int
i <- [0..3]]

abiCall :: TestVMParams -> Text -> AbiValue -> EVM ()
abiCall :: TestVMParams -> Text -> AbiValue -> EVM ()
abiCall params :: TestVMParams
params sig :: Text
sig args :: AbiValue
args =
  let cd :: ByteString
cd = Text -> AbiValue -> ByteString
abiMethod Text
sig AbiValue
args
      l :: Word
l = Int -> Word
forall a b. (Integral a, Num b) => a -> b
num (Int -> Word) -> (ByteString -> Int) -> ByteString -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
BS.length (ByteString -> Word) -> ByteString -> Word
forall a b. (a -> b) -> a -> b
$ ByteString
cd
  in TestVMParams -> (Buffer, SymWord) -> EVM ()
makeTxCall TestVMParams
params (ByteString -> Buffer
ConcreteBuffer ByteString
cd, Word -> SymWord
litWord Word
l)

makeTxCall :: TestVMParams -> (Buffer, SymWord) -> EVM ()
makeTxCall :: TestVMParams -> (Buffer, SymWord) -> EVM ()
makeTxCall TestVMParams{..} cd :: (Buffer, SymWord)
cd = do
  EVM ()
resetState
  ASetter VM VM Bool Bool -> Bool -> EVM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ((TxState -> Identity TxState) -> VM -> Identity VM
Lens' VM TxState
tx ((TxState -> Identity TxState) -> VM -> Identity VM)
-> ((Bool -> Identity Bool) -> TxState -> Identity TxState)
-> ASetter VM VM Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool) -> TxState -> Identity TxState
Lens' TxState Bool
isCreate) Bool
False
  Addr -> EVM ()
loadContract Addr
testAddress
  ASetter VM VM (Buffer, SymWord) (Buffer, SymWord)
-> (Buffer, SymWord) -> EVM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ((FrameState -> Identity FrameState) -> VM -> Identity VM
Lens' VM FrameState
state ((FrameState -> Identity FrameState) -> VM -> Identity VM)
-> (((Buffer, SymWord) -> Identity (Buffer, SymWord))
    -> FrameState -> Identity FrameState)
-> ASetter VM VM (Buffer, SymWord) (Buffer, SymWord)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Buffer, SymWord) -> Identity (Buffer, SymWord))
-> FrameState -> Identity FrameState
Lens' FrameState (Buffer, SymWord)
calldata) (Buffer, SymWord)
cd
  ASetter VM VM SAddr SAddr -> SAddr -> EVM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ((FrameState -> Identity FrameState) -> VM -> Identity VM
Lens' VM FrameState
state ((FrameState -> Identity FrameState) -> VM -> Identity VM)
-> ((SAddr -> Identity SAddr) -> FrameState -> Identity FrameState)
-> ASetter VM VM SAddr SAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SAddr -> Identity SAddr) -> FrameState -> Identity FrameState
Lens' FrameState SAddr
caller) (Addr -> SAddr
litAddr Addr
testCaller)
  ((Word -> Identity Word) -> VM -> Identity VM) -> Word -> EVM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
assign ((FrameState -> Identity FrameState) -> VM -> Identity VM
Lens' VM FrameState
state ((FrameState -> Identity FrameState) -> VM -> Identity VM)
-> ((Word -> Identity Word) -> FrameState -> Identity FrameState)
-> (Word -> Identity Word)
-> VM
-> Identity VM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word -> Identity Word) -> FrameState -> Identity FrameState
Lens' FrameState Word
gas) (W256 -> Word
w256 W256
testGasCall)
  Contract
origin' <- Contract -> Maybe Contract -> Contract
forall a. a -> Maybe a -> a
fromMaybe (ContractCode -> Contract
initialContract (Buffer -> ContractCode
RuntimeCode Buffer
forall a. Monoid a => a
mempty)) (Maybe Contract -> Contract)
-> StateT VM Identity (Maybe Contract)
-> StateT VM Identity Contract
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Maybe Contract) VM (Maybe Contract)
-> StateT VM Identity (Maybe Contract)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((Env -> Const (Maybe Contract) Env)
-> VM -> Const (Maybe Contract) VM
Lens' VM Env
env ((Env -> Const (Maybe Contract) Env)
 -> VM -> Const (Maybe Contract) VM)
-> ((Maybe Contract -> Const (Maybe Contract) (Maybe Contract))
    -> Env -> Const (Maybe Contract) Env)
-> Getting (Maybe Contract) VM (Maybe Contract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Addr Contract -> Const (Maybe Contract) (Map Addr Contract))
-> Env -> Const (Maybe Contract) Env
Lens' Env (Map Addr Contract)
contracts ((Map Addr Contract -> Const (Maybe Contract) (Map Addr Contract))
 -> Env -> Const (Maybe Contract) Env)
-> ((Maybe Contract -> Const (Maybe Contract) (Maybe Contract))
    -> Map Addr Contract -> Const (Maybe Contract) (Map Addr Contract))
-> (Maybe Contract -> Const (Maybe Contract) (Maybe Contract))
-> Env
-> Const (Maybe Contract) Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Addr Contract)
-> Lens' (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
testOrigin)
  let originBal :: Word
originBal = Getting Word Contract Word -> Contract -> Word
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Word Contract Word
Lens' Contract Word
balance Contract
origin'
  Bool -> EVM () -> EVM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
originBal Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< (W256 -> Word
w256 W256
testGasprice) Word -> Word -> Word
forall a. Num a => a -> a -> a
* (W256 -> Word
w256 W256
testGasCall)) (EVM () -> EVM ()) -> EVM () -> EVM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> EVM ()
forall a. HasCallStack => [Char] -> a
error "insufficient balance for gas cost"
  VM
vm <- StateT VM Identity 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 {..}) theContract :: SolcContract
theContract =
  let
    TestVMParams {..} = TestVMParams
testParams
    vm :: VM
vm = VMOpts -> VM
makeVm (VMOpts -> VM) -> VMOpts -> VM
forall a b. (a -> b) -> a -> b
$ $WVMOpts :: Contract
-> (Buffer, SymWord)
-> SymWord
-> Addr
-> SAddr
-> Addr
-> W256
-> W256
-> W256
-> SymWord
-> Addr
-> W256
-> W256
-> W256
-> W256
-> FeeSchedule Integer
-> W256
-> Bool
-> StorageModel
-> Map Addr [W256]
-> VMOpts
VMOpts
           { vmoptContract :: Contract
vmoptContract = ContractCode -> Contract
initialContract (Buffer -> ContractCode
InitCode (ByteString -> Buffer
ConcreteBuffer (Getting ByteString SolcContract ByteString
-> SolcContract -> ByteString
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ByteString SolcContract ByteString
Lens' SolcContract ByteString
creationCode SolcContract
theContract)))
           , vmoptCalldata :: (Buffer, SymWord)
vmoptCalldata = (Buffer
forall a. Monoid a => a
mempty, 0)
           , vmoptValue :: SymWord
vmoptValue = 0
           , vmoptAddress :: Addr
vmoptAddress = Addr
testAddress
           , vmoptCaller :: SAddr
vmoptCaller = Addr -> SAddr
litAddr Addr
testCaller
           , vmoptOrigin :: Addr
vmoptOrigin = Addr
testOrigin
           , vmoptGas :: W256
vmoptGas = W256
testGasCreate
           , vmoptGaslimit :: W256
vmoptGaslimit = W256
testGasCreate
           , vmoptCoinbase :: Addr
vmoptCoinbase = Addr
testCoinbase
           , vmoptNumber :: W256
vmoptNumber = W256
testNumber
           , vmoptTimestamp :: SymWord
vmoptTimestamp = Word -> SymWord
litWord (Word -> SymWord) -> Word -> SymWord
forall a b. (a -> b) -> a -> b
$ W256 -> Word
w256 W256
testTimestamp
           , vmoptBlockGaslimit :: W256
vmoptBlockGaslimit = W256
testGaslimit
           , vmoptGasprice :: W256
vmoptGasprice = W256
testGasprice
           , vmoptMaxCodeSize :: W256
vmoptMaxCodeSize = W256
testMaxCodeSize
           , vmoptDifficulty :: W256
vmoptDifficulty = W256
testDifficulty
           , vmoptSchedule :: FeeSchedule Integer
vmoptSchedule = FeeSchedule Integer
forall n. Num n => FeeSchedule n
FeeSchedule.berlin
           , vmoptChainId :: W256
vmoptChainId = W256
testChainId
           , vmoptCreate :: Bool
vmoptCreate = Bool
True
           , vmoptStorageModel :: StorageModel
vmoptStorageModel = StorageModel
ConcreteS -- TODO: support RPC
           , vmoptTxAccessList :: Map Addr [W256]
vmoptTxAccessList = Map Addr [W256]
forall a. Monoid a => a
mempty -- TODO: support unit test access lists???
           }
    creator :: Contract
creator =
      ContractCode -> Contract
initialContract (Buffer -> ContractCode
RuntimeCode Buffer
forall a. Monoid a => a
mempty)
        Contract -> (Contract -> Contract) -> Contract
forall a b. a -> (a -> b) -> b
& ((Word -> Identity Word) -> Contract -> Identity Contract)
-> Word -> Contract -> Contract
forall s t a b. ASetter s t a b -> b -> s -> t
set (Word -> Identity Word) -> Contract -> Identity Contract
Lens' Contract Word
nonce 1
        Contract -> (Contract -> Contract) -> Contract
forall a b. a -> (a -> b) -> b
& ((Word -> Identity Word) -> Contract -> Identity Contract)
-> Word -> Contract -> Contract
forall s t a b. ASetter s t a b -> b -> s -> t
set (Word -> Identity Word) -> Contract -> Identity Contract
Lens' Contract Word
balance (W256 -> Word
w256 W256
testBalanceCreate)
  in VM
vm
    VM -> (VM -> VM) -> VM
forall a b. a -> (a -> b) -> b
& ASetter VM VM (Maybe Contract) (Maybe Contract)
-> Maybe Contract -> VM -> VM
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Env -> Identity Env) -> VM -> Identity VM
Lens' VM Env
env ((Env -> Identity Env) -> VM -> Identity VM)
-> ((Maybe Contract -> Identity (Maybe Contract))
    -> Env -> Identity Env)
-> ASetter VM VM (Maybe Contract) (Maybe Contract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Addr Contract -> Identity (Map Addr Contract))
-> Env -> Identity Env
Lens' Env (Map Addr Contract)
contracts ((Map Addr Contract -> Identity (Map Addr Contract))
 -> Env -> Identity Env)
-> ((Maybe Contract -> Identity (Maybe Contract))
    -> Map Addr Contract -> Identity (Map Addr Contract))
-> (Maybe Contract -> Identity (Maybe Contract))
-> Env
-> Identity Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Addr Contract)
-> Lens' (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) (Contract -> Maybe Contract
forall a. a -> Maybe a
Just Contract
creator)


-- | takes a concrete VM and makes all storage symbolic
symbolify :: VM -> VM
symbolify :: VM -> VM
symbolify vm :: VM
vm =
  VM
vm VM -> (VM -> VM) -> VM
forall a b. a -> (a -> b) -> b
& ASetter VM VM Storage Storage -> (Storage -> Storage) -> VM -> VM
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Env -> Identity Env) -> VM -> Identity VM
Lens' VM Env
env ((Env -> Identity Env) -> VM -> Identity VM)
-> ((Storage -> Identity Storage) -> Env -> Identity Env)
-> ASetter VM VM Storage Storage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Addr Contract -> Identity (Map Addr Contract))
-> Env -> Identity Env
Lens' Env (Map Addr Contract)
contracts ((Map Addr Contract -> Identity (Map Addr Contract))
 -> Env -> Identity Env)
-> ((Storage -> Identity Storage)
    -> Map Addr Contract -> Identity (Map Addr Contract))
-> (Storage -> Identity Storage)
-> Env
-> Identity Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Contract -> Identity Contract)
-> Map Addr Contract -> Identity (Map Addr Contract)
forall s t a b. Each s t a b => Traversal s t a b
each ((Contract -> Identity Contract)
 -> Map Addr Contract -> Identity (Map Addr Contract))
-> ((Storage -> Identity Storage) -> Contract -> Identity Contract)
-> (Storage -> Identity Storage)
-> Map Addr Contract
-> Identity (Map Addr Contract)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Storage -> Identity Storage) -> Contract -> Identity Contract
Lens' Contract Storage
storage) Storage -> Storage
mkSymStorage
     VM -> (VM -> VM) -> VM
forall a b. a -> (a -> b) -> b
& ASetter VM VM StorageModel StorageModel -> StorageModel -> VM -> VM
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Env -> Identity Env) -> VM -> Identity VM
Lens' VM Env
env ((Env -> Identity Env) -> VM -> Identity VM)
-> ((StorageModel -> Identity StorageModel) -> Env -> Identity Env)
-> ASetter VM VM StorageModel StorageModel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StorageModel -> Identity StorageModel) -> Env -> Identity Env
Lens' Env StorageModel
storageModel) StorageModel
InitialS
  where
    mkSymStorage :: Storage -> Storage
    mkSymStorage :: Storage -> Storage
mkSymStorage (Symbolic _ _) = [Char] -> Storage
forall a. HasCallStack => [Char] -> a
error "should not happen"
    mkSymStorage (Concrete s :: Map Word SymWord
s) =
      let
        list :: [(SWord 256, SWord 256)]
list = [(WordN 256 -> SWord 256
forall a. SymVal a => a -> SBV a
literal (WordN 256 -> SWord 256) -> WordN 256 -> SWord 256
forall a b. (a -> b) -> a -> b
$ W256 -> ToSizzle W256
forall a. ToSizzleBV a => a -> ToSizzle a
toSizzle W256
k, SWord 256
v) | (C _ k :: W256
k, S _ v :: SWord 256
v) <- Map Word SymWord -> [(Word, SymWord)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Word SymWord
s]
        symlist :: [(SymWord, SymWord)]
symlist = [(Word -> SymWord
litWord Word
k, SymWord
v) | (k :: Word
k, v :: SymWord
v) <- Map Word SymWord -> [(Word, SymWord)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Word SymWord
s]
      in [(SymWord, SymWord)] -> SArray (WordN 256) (WordN 256) -> Storage
Symbolic [(SymWord, SymWord)]
symlist (SArray (WordN 256) (WordN 256) -> Storage)
-> SArray (WordN 256) (WordN 256) -> Storage
forall a b. (a -> b) -> a -> b
$ WordN 256
-> [(SWord 256, SWord 256)] -> SArray (WordN 256) (WordN 256)
forall (array :: * -> * -> *) a b.
(SymArray array, HasKind a, SymVal b) =>
b -> [(SBV a, SBV b)] -> array a b
sListArray 0 [(SWord 256, SWord 256)]
list

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

  (miner :: Addr
miner,ts :: W256
ts,blockNum :: W256
blockNum,diff :: W256
diff) <-
    case Maybe Text
rpc of
      Nothing  -> (Addr, W256, W256, W256) -> IO (Addr, W256, W256, W256)
forall (m :: * -> *) a. Monad m => a -> m a
return (0,0,0,0)
      Just url :: Text
url -> BlockNumber -> Text -> IO (Maybe Block)
EVM.Fetch.fetchBlockFrom BlockNumber
block' Text
url IO (Maybe Block)
-> (Maybe Block -> IO (Addr, W256, W256, W256))
-> IO (Addr, W256, W256, W256)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Nothing -> [Char] -> IO (Addr, W256, W256, W256)
forall a. HasCallStack => [Char] -> a
error "Could not fetch block"
        Just EVM.Block{..} -> (Addr, W256, W256, W256) -> IO (Addr, W256, W256, W256)
forall (m :: * -> *) a. Monad m => a -> m a
return (  Addr
_coinbase
                                      , Word -> W256
wordValue (Word -> W256) -> Word -> W256
forall a b. (a -> b) -> a -> b
$ SymWord -> Word
forceLit SymWord
_timestamp
                                      , Word -> W256
wordValue Word
_number
                                      , Word -> W256
wordValue Word
_difficulty
                                      )
  let
    getWord :: [Char] -> b -> IO b
getWord s :: [Char]
s def :: b
def = b -> ([Char] -> b) -> Maybe [Char] -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
def [Char] -> b
forall a. Read a => [Char] -> a
read (Maybe [Char] -> b) -> IO (Maybe [Char]) -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
s
    getAddr :: [Char] -> b -> IO b
getAddr s :: [Char]
s def :: b
def = b -> ([Char] -> b) -> Maybe [Char] -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
def [Char] -> b
forall a. Read a => [Char] -> a
read (Maybe [Char] -> b) -> IO (Maybe [Char]) -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
s

  Addr
-> Addr
-> Addr
-> W256
-> W256
-> W256
-> W256
-> Addr
-> W256
-> W256
-> W256
-> W256
-> W256
-> W256
-> W256
-> TestVMParams
TestVMParams
    (Addr
 -> Addr
 -> Addr
 -> W256
 -> W256
 -> W256
 -> W256
 -> Addr
 -> W256
 -> W256
 -> W256
 -> W256
 -> W256
 -> W256
 -> W256
 -> TestVMParams)
-> IO Addr
-> IO
     (Addr
      -> Addr
      -> W256
      -> W256
      -> W256
      -> W256
      -> Addr
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> TestVMParams)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Addr -> IO Addr
forall b. Read b => [Char] -> b -> IO b
getAddr "DAPP_TEST_ADDRESS" (Addr -> W256 -> Addr
createAddress Addr
ethrunAddress 1)
    IO
  (Addr
   -> Addr
   -> W256
   -> W256
   -> W256
   -> W256
   -> Addr
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> TestVMParams)
-> IO Addr
-> IO
     (Addr
      -> W256
      -> W256
      -> W256
      -> W256
      -> Addr
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> TestVMParams)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> Addr -> IO Addr
forall b. Read b => [Char] -> b -> IO b
getAddr "DAPP_TEST_CALLER" Addr
ethrunAddress
    IO
  (Addr
   -> W256
   -> W256
   -> W256
   -> W256
   -> Addr
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> TestVMParams)
-> IO Addr
-> IO
     (W256
      -> W256
      -> W256
      -> W256
      -> Addr
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> TestVMParams)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> Addr -> IO Addr
forall b. Read b => [Char] -> b -> IO b
getAddr "DAPP_TEST_ORIGIN" Addr
ethrunAddress
    IO
  (W256
   -> W256
   -> W256
   -> W256
   -> Addr
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> TestVMParams)
-> IO W256
-> IO
     (W256
      -> W256
      -> W256
      -> Addr
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> TestVMParams)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> W256 -> IO W256
forall b. Read b => [Char] -> b -> IO b
getWord "DAPP_TEST_GAS_CREATE" W256
defaultGasForCreating
    IO
  (W256
   -> W256
   -> W256
   -> Addr
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> TestVMParams)
-> IO W256
-> IO
     (W256
      -> W256
      -> Addr
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> TestVMParams)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> W256 -> IO W256
forall b. Read b => [Char] -> b -> IO b
getWord "DAPP_TEST_GAS_CALL" W256
defaultGasForInvoking
    IO
  (W256
   -> W256
   -> Addr
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> TestVMParams)
-> IO W256
-> IO
     (W256
      -> Addr
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> TestVMParams)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> W256 -> IO W256
forall b. Read b => [Char] -> b -> IO b
getWord "DAPP_TEST_BALANCE_CREATE" W256
defaultBalanceForCreator
    IO
  (W256
   -> Addr
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> TestVMParams)
-> IO W256
-> IO
     (Addr
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> W256
      -> TestVMParams)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> W256 -> IO W256
forall b. Read b => [Char] -> b -> IO b
getWord "DAPP_TEST_BALANCE_CALL" W256
defaultBalanceForCreated
    IO
  (Addr
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> W256
   -> TestVMParams)
-> IO Addr
-> IO
     (W256
      -> W256 -> W256 -> W256 -> W256 -> W256 -> W256 -> TestVMParams)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> Addr -> IO Addr
forall b. Read b => [Char] -> b -> IO b
getAddr "DAPP_TEST_COINBASE" Addr
miner
    IO
  (W256
   -> W256 -> W256 -> W256 -> W256 -> W256 -> W256 -> TestVMParams)
-> IO W256
-> IO
     (W256 -> W256 -> W256 -> W256 -> W256 -> W256 -> TestVMParams)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> W256 -> IO W256
forall b. Read b => [Char] -> b -> IO b
getWord "DAPP_TEST_NUMBER" W256
blockNum
    IO (W256 -> W256 -> W256 -> W256 -> W256 -> W256 -> TestVMParams)
-> IO W256
-> IO (W256 -> W256 -> W256 -> W256 -> W256 -> TestVMParams)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> W256 -> IO W256
forall b. Read b => [Char] -> b -> IO b
getWord "DAPP_TEST_TIMESTAMP" W256
ts
    IO (W256 -> W256 -> W256 -> W256 -> W256 -> TestVMParams)
-> IO W256 -> IO (W256 -> W256 -> W256 -> W256 -> TestVMParams)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> W256 -> IO W256
forall b. Read b => [Char] -> b -> IO b
getWord "DAPP_TEST_GAS_LIMIT" 0
    IO (W256 -> W256 -> W256 -> W256 -> TestVMParams)
-> IO W256 -> IO (W256 -> W256 -> W256 -> TestVMParams)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> W256 -> IO W256
forall b. Read b => [Char] -> b -> IO b
getWord "DAPP_TEST_GAS_PRICE" 0
    IO (W256 -> W256 -> W256 -> TestVMParams)
-> IO W256 -> IO (W256 -> W256 -> TestVMParams)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> W256 -> IO W256
forall b. Read b => [Char] -> b -> IO b
getWord "DAPP_TEST_MAXCODESIZE" W256
defaultMaxCodeSize
    IO (W256 -> W256 -> TestVMParams)
-> IO W256 -> IO (W256 -> TestVMParams)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> W256 -> IO W256
forall b. Read b => [Char] -> b -> IO b
getWord "DAPP_TEST_DIFFICULTY" W256
diff
    IO (W256 -> TestVMParams) -> IO W256 -> IO TestVMParams
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> W256 -> IO W256
forall b. Read b => [Char] -> b -> IO b
getWord "DAPP_TEST_CHAINID" 99