{-# LANGUAGE DeriveAnyClass #-}
module EVM.Dev where

import System.Directory

import Prelude hiding (Word)

import EVM.Types
import EVM.Dapp
import EVM.Solidity
import EVM.UnitTest
import EVM.Symbolic

import EVM hiding (path)
import qualified EVM.Fetch
import qualified EVM.TTY
import qualified EVM.Emacs
import qualified EVM.Facts     as Facts
import qualified EVM.Facts.Git as Git
import qualified EVM.Stepper
import qualified EVM.VMTest    as VMTest

import Data.SBV hiding (Word)
import qualified Data.Aeson           as JSON
import Options.Generic
import Data.SBV.Trans.Control
import Data.Maybe (fromMaybe)
import Control.Monad.State.Strict (execStateT)

import qualified Data.Map as Map
import qualified Data.ByteString.Lazy   as LazyByteString
import qualified Data.ByteString      as BS
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Control.Monad.State.Class as State
import Control.Monad.State.Strict (runState, liftIO, StateT, get)
import Control.Lens hiding (op, passing)
import Control.Monad.Operational (ProgramViewT(..), ProgramView)
import qualified Control.Monad.Operational as Operational

loadDappInfo :: String -> String -> IO DappInfo
loadDappInfo :: String -> String -> IO DappInfo
loadDappInfo String
path String
file =
  String -> IO DappInfo -> IO DappInfo
forall a. String -> IO a -> IO a
withCurrentDirectory String
path (IO DappInfo -> IO DappInfo) -> IO DappInfo -> IO DappInfo
forall a b. (a -> b) -> a -> b
$
    String -> IO (Maybe (Map Text SolcContract, SourceCache))
readSolc String
file IO (Maybe (Map Text SolcContract, SourceCache))
-> (Maybe (Map Text SolcContract, SourceCache) -> IO DappInfo)
-> IO DappInfo
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      \case
        Just (Map Text SolcContract
contractMap, SourceCache
sourcecache) ->
          DappInfo -> IO DappInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Map Text SolcContract -> SourceCache -> DappInfo
dappInfo String
"." Map Text SolcContract
contractMap SourceCache
sourcecache)
        Maybe (Map Text SolcContract, SourceCache)
_ ->
          String -> IO DappInfo
forall a. HasCallStack => String -> a
error String
"nope, sorry"

ghciTest :: String -> String -> Maybe String -> IO [Bool]
ghciTest :: String -> String -> Maybe String -> IO [Bool]
ghciTest String
root String
path Maybe String
statePath =
  String -> IO [Bool] -> IO [Bool]
forall a. String -> IO a -> IO a
withCurrentDirectory String
root (IO [Bool] -> IO [Bool]) -> IO [Bool] -> IO [Bool]
forall a b. (a -> b) -> a -> b
$ do
    VM -> VM
loadFacts <-
      case Maybe String
statePath of
        Maybe String
Nothing ->
          (VM -> VM) -> IO (VM -> VM)
forall (f :: * -> *) a. Applicative f => a -> f a
pure VM -> VM
forall a. a -> a
id
        Just String
repoPath -> do
          Set Fact
facts <- RepoAt -> IO (Set Fact)
Git.loadFacts (String -> RepoAt
Git.RepoAt String
repoPath)
          (VM -> VM) -> IO (VM -> VM)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VM -> Set Fact -> VM) -> Set Fact -> VM -> VM
forall a b c. (a -> b -> c) -> b -> a -> c
flip VM -> Set Fact -> VM
Facts.apply Set Fact
facts)
    TestVMParams
params <- Maybe Text -> IO TestVMParams
getParametersFromEnvironmentVariables Maybe Text
forall a. Maybe a
Nothing
    DappInfo
dapp <- String -> String -> IO DappInfo
loadDappInfo String
root String
path
    let
      opts :: UnitTestOptions
opts = UnitTestOptions :: (Query -> IO (EVM ()))
-> Maybe Int
-> Maybe Integer
-> Maybe Integer
-> Maybe Int
-> Maybe Integer
-> Maybe State
-> Maybe Text
-> Maybe Text
-> Text
-> Int
-> Maybe (Text, ByteString)
-> (VM -> VM)
-> DappInfo
-> TestVMParams
-> Bool
-> UnitTestOptions
UnitTestOptions
        { oracle :: Query -> IO (EVM ())
oracle = Query -> IO (EVM ())
EVM.Fetch.zero
        , verbose :: Maybe Int
verbose = Maybe Int
forall a. Maybe a
Nothing
        , maxIter :: Maybe Integer
maxIter = Maybe Integer
forall a. Maybe a
Nothing
        , askSmtIters :: Maybe Integer
askSmtIters = Maybe Integer
forall a. Maybe a
Nothing
        , smtTimeout :: Maybe Integer
smtTimeout = Maybe Integer
forall a. Maybe a
Nothing
        , smtState :: Maybe State
smtState = Maybe State
forall a. Maybe a
Nothing
        , solver :: Maybe Text
solver = Maybe Text
forall a. Maybe a
Nothing
        , match :: Text
match = Text
""
        , covMatch :: Maybe Text
covMatch = Maybe Text
forall a. Maybe a
Nothing
        , fuzzRuns :: Int
fuzzRuns = Int
100
        , replay :: Maybe (Text, ByteString)
replay = Maybe (Text, ByteString)
forall a. Maybe a
Nothing
        , vmModifier :: VM -> VM
vmModifier = VM -> VM
loadFacts
        , dapp :: DappInfo
dapp = DappInfo
dapp
        , testParams :: TestVMParams
testParams = TestVMParams
params
        , maxDepth :: Maybe Int
maxDepth = Maybe Int
forall a. Maybe a
Nothing
        , ffiAllowed :: Bool
ffiAllowed = Bool
False
        }
    String -> IO (Maybe (Map Text SolcContract, SourceCache))
readSolc String
path IO (Maybe (Map Text SolcContract, SourceCache))
-> (Maybe (Map Text SolcContract, SourceCache) -> IO [Bool])
-> IO [Bool]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      \case
        Just (Map Text SolcContract
contractMap, SourceCache
_) -> do
          let unitTests :: [(Text, [(Test, [AbiType])])]
unitTests = [SolcContract] -> [(Text, [(Test, [AbiType])])]
findAllUnitTests (Map Text SolcContract -> [SolcContract]
forall k a. Map k a -> [a]
Map.elems Map Text SolcContract
contractMap)
          [(Bool, VM)]
results <- Symbolic [(Bool, VM)] -> IO [(Bool, VM)]
forall a. Symbolic a -> IO a
runSMT (Symbolic [(Bool, VM)] -> IO [(Bool, VM)])
-> Symbolic [(Bool, VM)] -> IO [(Bool, VM)]
forall a b. (a -> b) -> a -> b
$ QueryT IO [(Bool, VM)] -> Symbolic [(Bool, VM)]
forall (m :: * -> *) a. ExtractIO m => QueryT m a -> SymbolicT m a
query (QueryT IO [(Bool, VM)] -> Symbolic [(Bool, VM)])
-> QueryT IO [(Bool, VM)] -> Symbolic [(Bool, VM)]
forall a b. (a -> b) -> a -> b
$ ((Text, [(Test, [AbiType])]) -> QueryT IO [(Bool, VM)])
-> [(Text, [(Test, [AbiType])])] -> QueryT IO [(Bool, VM)]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (UnitTestOptions
-> Map Text SolcContract
-> (Text, [(Test, [AbiType])])
-> QueryT IO [(Bool, VM)]
runUnitTestContract UnitTestOptions
opts Map Text SolcContract
contractMap) [(Text, [(Test, [AbiType])])]
unitTests
          let ([Bool]
passing, [VM]
_) = [(Bool, VM)] -> ([Bool], [VM])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Bool, VM)]
results
          [Bool] -> IO [Bool]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Bool]
passing

        Maybe (Map Text SolcContract, SourceCache)
Nothing ->
          String -> IO [Bool]
forall a. HasCallStack => String -> a
error (String
"Failed to read Solidity JSON for `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")

runBCTest :: (String, VMTest.Case) -> IO Bool
runBCTest :: (String, Case) -> IO Bool
runBCTest (String
name, Case
x) = do
  let vm0 :: VM
vm0 = Case -> VM
VMTest.vmForCase Case
x
  String -> IO ()
putStr (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ")
  VM
out <-
    StateT VM IO (Either Error Buffer) -> VM -> IO VM
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT ((Query -> IO (EVM ()))
-> Stepper (Either Error Buffer)
-> StateT VM IO (Either Error Buffer)
forall a. (Query -> IO (EVM ())) -> Stepper a -> StateT VM IO a
EVM.Stepper.interpret Query -> IO (EVM ())
EVM.Fetch.zero Stepper (Either Error Buffer)
EVM.Stepper.execFully) VM
vm0
  Bool
ok <- HasCallStack => Bool -> Case -> VM -> IO Bool
Bool -> Case -> VM -> IO Bool
VMTest.checkExpectation Bool
False Case
x VM
out
  String -> IO ()
putStrLn (if Bool
ok then String
"ok" else String
"")
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ok

ghciBCTest :: String -> IO ()
ghciBCTest :: String -> IO ()
ghciBCTest String
file = do
  let parser :: ByteString -> Either String (Map String Case)
parser = ByteString -> Either String (Map String Case)
VMTest.parseBCSuite
  Either String (Map String Case)
parsed <- ByteString -> Either String (Map String Case)
parser (ByteString -> Either String (Map String Case))
-> IO ByteString -> IO (Either String (Map String Case))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
LazyByteString.readFile String
file
  case Either String (Map String Case)
parsed of
     Left String
"No cases to check." -> String -> IO ()
putStrLn String
"no-cases ok"
     Left String
err -> String -> IO ()
forall a. Show a => a -> IO ()
print String
err
     Right Map String Case
allTests ->
        ((String, Case) -> IO Bool) -> [(String, Case)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String, Case) -> IO Bool
runBCTest (Map String Case -> [(String, Case)]
forall k a. Map k a -> [(k, a)]
Map.toList Map String Case
allTests)

ghciTty :: String -> String -> Maybe String -> IO ()
ghciTty :: String -> String -> Maybe String -> IO ()
ghciTty String
root String
path Maybe String
statePath =
  String -> IO () -> IO ()
forall a. String -> IO a -> IO a
withCurrentDirectory String
root (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    VM -> VM
loadFacts <-
      case Maybe String
statePath of
        Maybe String
Nothing ->
          (VM -> VM) -> IO (VM -> VM)
forall (f :: * -> *) a. Applicative f => a -> f a
pure VM -> VM
forall a. a -> a
id
        Just String
repoPath -> do
          Set Fact
facts <- RepoAt -> IO (Set Fact)
Git.loadFacts (String -> RepoAt
Git.RepoAt String
repoPath)
          (VM -> VM) -> IO (VM -> VM)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VM -> Set Fact -> VM) -> Set Fact -> VM -> VM
forall a b c. (a -> b -> c) -> b -> a -> c
flip VM -> Set Fact -> VM
Facts.apply Set Fact
facts)
    TestVMParams
params <- Maybe Text -> IO TestVMParams
getParametersFromEnvironmentVariables Maybe Text
forall a. Maybe a
Nothing
    let
      testOpts :: UnitTestOptions
testOpts = UnitTestOptions :: (Query -> IO (EVM ()))
-> Maybe Int
-> Maybe Integer
-> Maybe Integer
-> Maybe Int
-> Maybe Integer
-> Maybe State
-> Maybe Text
-> Maybe Text
-> Text
-> Int
-> Maybe (Text, ByteString)
-> (VM -> VM)
-> DappInfo
-> TestVMParams
-> Bool
-> UnitTestOptions
UnitTestOptions
        { oracle :: Query -> IO (EVM ())
oracle = Query -> IO (EVM ())
EVM.Fetch.zero
        , verbose :: Maybe Int
verbose = Maybe Int
forall a. Maybe a
Nothing
        , maxIter :: Maybe Integer
maxIter = Maybe Integer
forall a. Maybe a
Nothing
        , askSmtIters :: Maybe Integer
askSmtIters = Maybe Integer
forall a. Maybe a
Nothing
        , smtTimeout :: Maybe Integer
smtTimeout = Maybe Integer
forall a. Maybe a
Nothing
        , smtState :: Maybe State
smtState = Maybe State
forall a. Maybe a
Nothing
        , solver :: Maybe Text
solver = Maybe Text
forall a. Maybe a
Nothing
        , match :: Text
match = Text
""
        , covMatch :: Maybe Text
covMatch = Maybe Text
forall a. Maybe a
Nothing
        , fuzzRuns :: Int
fuzzRuns = Int
100
        , replay :: Maybe (Text, ByteString)
replay = Maybe (Text, ByteString)
forall a. Maybe a
Nothing
        , vmModifier :: VM -> VM
vmModifier = VM -> VM
loadFacts
        , dapp :: DappInfo
dapp = DappInfo
emptyDapp
        , testParams :: TestVMParams
testParams = TestVMParams
params
        , maxDepth :: Maybe Int
maxDepth = Maybe Int
forall a. Maybe a
Nothing
        , ffiAllowed :: Bool
ffiAllowed = Bool
False
        }
    UnitTestOptions -> String -> String -> IO ()
EVM.TTY.main UnitTestOptions
testOpts String
root String
path

ghciEmacs :: IO ()
ghciEmacs :: IO ()
ghciEmacs =
  IO ()
EVM.Emacs.main

foo :: IO ()
foo :: IO ()
foo = IO ()
ghciEmacs

data VMTrace =
  VMTrace
  { VMTrace -> Int
pc      :: Int
  , VMTrace -> Int
op      :: Int
  , VMTrace -> [Word]
stack   :: [Word]
  , VMTrace -> Int
memSize :: Int
  , VMTrace -> Int
depth   :: Int
  , VMTrace -> Word
gas     :: Word
  } deriving ((forall x. VMTrace -> Rep VMTrace x)
-> (forall x. Rep VMTrace x -> VMTrace) -> Generic VMTrace
forall x. Rep VMTrace x -> VMTrace
forall x. VMTrace -> Rep VMTrace x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep VMTrace x -> VMTrace
$cfrom :: forall x. VMTrace -> Rep VMTrace x
Generic, [VMTrace] -> Encoding
[VMTrace] -> Value
VMTrace -> Encoding
VMTrace -> Value
(VMTrace -> Value)
-> (VMTrace -> Encoding)
-> ([VMTrace] -> Value)
-> ([VMTrace] -> Encoding)
-> ToJSON VMTrace
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [VMTrace] -> Encoding
$ctoEncodingList :: [VMTrace] -> Encoding
toJSONList :: [VMTrace] -> Value
$ctoJSONList :: [VMTrace] -> Value
toEncoding :: VMTrace -> Encoding
$ctoEncoding :: VMTrace -> Encoding
toJSON :: VMTrace -> Value
$ctoJSON :: VMTrace -> Value
JSON.ToJSON)

data VMTraceResult =
  VMTraceResult
  { VMTraceResult -> String
output  :: String
  , VMTraceResult -> Word
gasUsed :: Word
  } deriving ((forall x. VMTraceResult -> Rep VMTraceResult x)
-> (forall x. Rep VMTraceResult x -> VMTraceResult)
-> Generic VMTraceResult
forall x. Rep VMTraceResult x -> VMTraceResult
forall x. VMTraceResult -> Rep VMTraceResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep VMTraceResult x -> VMTraceResult
$cfrom :: forall x. VMTraceResult -> Rep VMTraceResult x
Generic, [VMTraceResult] -> Encoding
[VMTraceResult] -> Value
VMTraceResult -> Encoding
VMTraceResult -> Value
(VMTraceResult -> Value)
-> (VMTraceResult -> Encoding)
-> ([VMTraceResult] -> Value)
-> ([VMTraceResult] -> Encoding)
-> ToJSON VMTraceResult
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [VMTraceResult] -> Encoding
$ctoEncodingList :: [VMTraceResult] -> Encoding
toJSONList :: [VMTraceResult] -> Value
$ctoJSONList :: [VMTraceResult] -> Value
toEncoding :: VMTraceResult -> Encoding
$ctoEncoding :: VMTraceResult -> Encoding
toJSON :: VMTraceResult -> Value
$ctoJSON :: VMTraceResult -> Value
JSON.ToJSON)

getOp :: VM -> Word8
getOp :: VM -> Word8
getOp VM
vm =
  let i :: Int
i  = VM
vm VM -> Getting Int VM Int -> Int
forall s a. s -> Getting a s a -> a
^. (FrameState -> Const Int FrameState) -> VM -> Const Int VM
Lens' VM FrameState
state ((FrameState -> Const Int FrameState) -> VM -> Const Int VM)
-> ((Int -> Const Int Int) -> FrameState -> Const Int FrameState)
-> Getting Int VM Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> FrameState -> Const Int FrameState
Lens' FrameState Int
EVM.pc
      code' :: Buffer
code' = VM
vm VM -> Getting Buffer VM Buffer -> Buffer
forall s a. s -> Getting a s a -> a
^. (FrameState -> Const Buffer FrameState) -> VM -> Const Buffer VM
Lens' VM FrameState
state ((FrameState -> Const Buffer FrameState) -> VM -> Const Buffer VM)
-> ((Buffer -> Const Buffer Buffer)
    -> FrameState -> Const Buffer FrameState)
-> Getting Buffer VM Buffer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Buffer -> Const Buffer Buffer)
-> FrameState -> Const Buffer FrameState
Lens' FrameState Buffer
code
      xs :: Buffer
xs = case Buffer
code' of
        ConcreteBuffer ByteString
xs' -> ByteString -> Buffer
ConcreteBuffer (Int -> ByteString -> ByteString
BS.drop Int
i ByteString
xs')
        SymbolicBuffer [SWord 8]
xs' -> [SWord 8] -> Buffer
SymbolicBuffer (Int -> [SWord 8] -> [SWord 8]
forall a. Int -> [a] -> [a]
drop Int
i [SWord 8]
xs')
  in if Buffer -> Int
len Buffer
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Word8
0
  else case Buffer
xs of
       ConcreteBuffer ByteString
b -> ByteString -> Int -> Word8
BS.index ByteString
b Int
0
       SymbolicBuffer [SWord 8]
b -> WordN 8 -> FromSized (WordN 8)
forall a. FromSizedBV a => a -> FromSized a
fromSized (WordN 8 -> FromSized (WordN 8)) -> WordN 8 -> FromSized (WordN 8)
forall a b. (a -> b) -> a -> b
$ WordN 8 -> Maybe (WordN 8) -> WordN 8
forall a. a -> Maybe a -> a
fromMaybe (String -> WordN 8
forall a. HasCallStack => String -> a
error String
"unexpected symbolic code") (SWord 8 -> Maybe (WordN 8)
forall a. SymVal a => SBV a -> Maybe a
unliteral ([SWord 8]
b [SWord 8] -> Int -> SWord 8
forall a. [a] -> Int -> a
!! Int
0))

vmtrace :: VM -> VMTrace
vmtrace :: VM -> VMTrace
vmtrace VM
vm =
  let
    -- Convenience function to access parts of the current VM state.
    -- Arcane type signature needed to avoid monomorphism restriction.
    the :: (b -> VM -> Const a VM) -> ((a -> Const a a) -> b) -> a
    the :: (b -> VM -> Const a VM) -> ((a -> Const a a) -> b) -> a
the b -> VM -> Const a VM
f (a -> Const a a) -> b
g = Getting a VM a -> VM -> a
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (b -> VM -> Const a VM
f (b -> VM -> Const a VM)
-> ((a -> Const a a) -> b) -> Getting a VM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Const a a) -> b
g) VM
vm
    memsize :: Int
memsize = ((FrameState -> Const Int FrameState) -> VM -> Const Int VM)
-> ((Int -> Const Int Int) -> FrameState -> Const Int FrameState)
-> Int
forall b a. (b -> VM -> Const a VM) -> ((a -> Const a a) -> b) -> a
the (FrameState -> Const Int FrameState) -> VM -> Const Int VM
Lens' VM FrameState
state (Int -> Const Int Int) -> FrameState -> Const Int FrameState
Lens' FrameState Int
memorySize
  in VMTrace :: Int -> Int -> [Word] -> Int -> Int -> Word -> VMTrace
VMTrace { pc :: Int
pc = ((FrameState -> Const Int FrameState) -> VM -> Const Int VM)
-> ((Int -> Const Int Int) -> FrameState -> Const Int FrameState)
-> Int
forall b a. (b -> VM -> Const a VM) -> ((a -> Const a a) -> b) -> a
the (FrameState -> Const Int FrameState) -> VM -> Const Int VM
Lens' VM FrameState
state (Int -> Const Int Int) -> FrameState -> Const Int FrameState
Lens' FrameState Int
EVM.pc
             , op :: Int
op = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
num (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ VM -> Word8
getOp VM
vm
             , gas :: Word
gas = ((FrameState -> Const Word FrameState) -> VM -> Const Word VM)
-> ((Word -> Const Word Word)
    -> FrameState -> Const Word FrameState)
-> Word
forall b a. (b -> VM -> Const a VM) -> ((a -> Const a a) -> b) -> a
the (FrameState -> Const Word FrameState) -> VM -> Const Word VM
Lens' VM FrameState
state (Word -> Const Word Word) -> FrameState -> Const Word FrameState
Lens' FrameState Word
EVM.gas
             , memSize :: Int
memSize = Int
memsize
             -- increment to match geth format
             , depth :: Int
depth = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Frame] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Getting [Frame] VM [Frame] -> VM -> [Frame]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Frame] VM [Frame]
Lens' VM [Frame]
frames VM
vm)
             -- reverse to match geth format
             , stack :: [Word]
stack = [Word] -> [Word]
forall a. [a] -> [a]
reverse ([Word] -> [Word]) -> [Word] -> [Word]
forall a b. (a -> b) -> a -> b
$ SymWord -> Word
forceLit (SymWord -> Word) -> [SymWord] -> [Word]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((FrameState -> Const [SymWord] FrameState)
 -> VM -> Const [SymWord] VM)
-> (([SymWord] -> Const [SymWord] [SymWord])
    -> FrameState -> Const [SymWord] FrameState)
-> [SymWord]
forall b a. (b -> VM -> Const a VM) -> ((a -> Const a a) -> b) -> a
the (FrameState -> Const [SymWord] FrameState)
-> VM -> Const [SymWord] VM
Lens' VM FrameState
state ([SymWord] -> Const [SymWord] [SymWord])
-> FrameState -> Const [SymWord] FrameState
Lens' FrameState [SymWord]
EVM.stack
             }

vmres :: VM -> VMTraceResult
vmres :: VM -> VMTraceResult
vmres VM
vm =
  let
    gasUsed' :: Word
gasUsed' = Getting Word VM Word -> VM -> Word
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((TxState -> Const Word TxState) -> VM -> Const Word VM
Lens' VM TxState
tx ((TxState -> Const Word TxState) -> VM -> Const Word VM)
-> ((Word -> Const Word Word) -> TxState -> Const Word TxState)
-> Getting Word VM Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word -> Const Word Word) -> TxState -> Const Word TxState
Lens' TxState Word
txgaslimit) VM
vm 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
EVM.gas) VM
vm
    res :: ByteString
res = case Getting (Maybe VMResult) VM (Maybe VMResult)
-> VM -> Maybe VMResult
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe VMResult) VM (Maybe VMResult)
Lens' VM (Maybe VMResult)
result VM
vm of
      Just (VMSuccess Buffer
out) -> Buffer -> ByteString
forceBuffer Buffer
out
      Just (VMFailure (Revert ByteString
out)) -> ByteString
out
      Maybe VMResult
_ -> ByteString
forall a. Monoid a => a
mempty
  in VMTraceResult :: String -> Word -> VMTraceResult
VMTraceResult
     -- more oddities to comply with geth
     { output :: String
output = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ByteStringS -> String
forall a. Show a => a -> String
show (ByteStringS -> String) -> ByteStringS -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteStringS
ByteStringS ByteString
res
     , gasUsed :: Word
gasUsed = Word
gasUsed'
     }

interpretWithTrace :: EVM.Fetch.Fetcher -> EVM.Stepper.Stepper a -> StateT VM IO a
interpretWithTrace :: (Query -> IO (EVM ())) -> Stepper a -> StateT VM IO a
interpretWithTrace Query -> IO (EVM ())
fetcher =
  ProgramView Action a -> StateT VM IO a
forall a. ProgramView Action a -> StateT VM IO a
eval (ProgramView Action a -> StateT VM IO a)
-> (Stepper a -> ProgramView Action a)
-> Stepper a
-> StateT VM 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
      :: ProgramView EVM.Stepper.Action a
      -> StateT VM IO a

    eval :: ProgramView Action a -> StateT VM IO a
eval (Return a
x) = do
      VM
vm <- StateT VM IO VM
forall s (m :: * -> *). MonadState s m => m s
get
      IO () -> StateT VM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT VM IO ()) -> IO () -> StateT VM IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
B.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ VMTraceResult -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode (VMTraceResult -> ByteString) -> VMTraceResult -> ByteString
forall a b. (a -> b) -> a -> b
$ VM -> VMTraceResult
vmres VM
vm
      a -> StateT VM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

    eval (Action b
action :>>= b -> ProgramT Action Identity a
k) = do
      VM
vm <- StateT VM IO VM
forall s (m :: * -> *). MonadState s m => m s
get
      case Action b
action of
        Action b
EVM.Stepper.Run -> do
          -- Have we reached the final result of this action?
          Getting (Maybe VMResult) VM (Maybe VMResult)
-> StateT VM IO (Maybe VMResult)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Maybe VMResult) VM (Maybe VMResult)
Lens' VM (Maybe VMResult)
result StateT VM IO (Maybe VMResult)
-> (Maybe VMResult -> StateT VM IO a) -> StateT VM IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just VMResult
_ -> do
              -- Yes, proceed with the next action.
              (Query -> IO (EVM ()))
-> ProgramT Action Identity a -> StateT VM IO a
forall a. (Query -> IO (EVM ())) -> Stepper a -> StateT VM IO a
interpretWithTrace Query -> IO (EVM ())
fetcher (b -> ProgramT Action Identity a
k b
VM
vm)
            Maybe VMResult
Nothing -> do
              IO () -> StateT VM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT VM IO ()) -> IO () -> StateT VM IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
B.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ VMTrace -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode (VMTrace -> ByteString) -> VMTrace -> ByteString
forall a b. (a -> b) -> a -> b
$ VM -> VMTrace
vmtrace VM
vm

              -- No, keep performing the current action
              (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)
              (Query -> IO (EVM ()))
-> ProgramT Action Identity a -> StateT VM IO a
forall a. (Query -> IO (EVM ())) -> Stepper a -> StateT VM IO a
interpretWithTrace Query -> IO (EVM ())
fetcher (Stepper VM
EVM.Stepper.run Stepper VM
-> (VM -> ProgramT Action Identity a) -> ProgramT Action Identity a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> ProgramT Action Identity a
VM -> ProgramT Action Identity a
k)

        -- Stepper wants to keep executing?
        Action b
EVM.Stepper.Exec -> do
          -- Have we reached the final result of this action?
          Getting (Maybe VMResult) VM (Maybe VMResult)
-> StateT VM IO (Maybe VMResult)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Maybe VMResult) VM (Maybe VMResult)
Lens' VM (Maybe VMResult)
result StateT VM IO (Maybe VMResult)
-> (Maybe VMResult -> StateT VM IO a) -> StateT VM IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just VMResult
r -> do
              -- Yes, proceed with the next action.
              (Query -> IO (EVM ()))
-> ProgramT Action Identity a -> StateT VM IO a
forall a. (Query -> IO (EVM ())) -> Stepper a -> StateT VM IO a
interpretWithTrace Query -> IO (EVM ())
fetcher (b -> ProgramT Action Identity a
k b
VMResult
r)
            Maybe VMResult
Nothing -> do
              IO () -> StateT VM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT VM IO ()) -> IO () -> StateT VM IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
B.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ VMTrace -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode (VMTrace -> ByteString) -> VMTrace -> ByteString
forall a b. (a -> b) -> a -> b
$ VM -> VMTrace
vmtrace VM
vm

              -- No, keep performing the current action
              (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)
              (Query -> IO (EVM ()))
-> ProgramT Action Identity a -> StateT VM IO a
forall a. (Query -> IO (EVM ())) -> Stepper a -> StateT VM IO a
interpretWithTrace Query -> IO (EVM ())
fetcher (Stepper VMResult
EVM.Stepper.exec Stepper VMResult
-> (VMResult -> ProgramT Action Identity a)
-> ProgramT Action Identity a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> ProgramT Action Identity a
VMResult -> ProgramT Action Identity a
k)
        EVM.Stepper.Wait Query
q ->
          do EVM ()
m <- IO (EVM ()) -> StateT VM IO (EVM ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Query -> IO (EVM ())
fetcher Query
q)
             (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 VM IO () -> StateT VM IO a -> StateT VM IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Query -> IO (EVM ()))
-> ProgramT Action Identity a -> StateT VM IO a
forall a. (Query -> IO (EVM ())) -> Stepper a -> StateT VM IO a
interpretWithTrace Query -> IO (EVM ())
fetcher (b -> ProgramT Action Identity a
k ())
        EVM.Stepper.Ask Choose
_ ->
          String -> StateT VM IO a
forall a. HasCallStack => String -> a
error String
"cannot make choices with this interpretWithTraceer"
        EVM.Stepper.IOAct StateT VM IO b
m ->
          StateT VM IO b
m StateT VM IO b -> (b -> StateT VM IO a) -> StateT VM IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Query -> IO (EVM ()))
-> ProgramT Action Identity a -> StateT VM IO a
forall a. (Query -> IO (EVM ())) -> Stepper a -> StateT VM IO a
interpretWithTrace Query -> IO (EVM ())
fetcher (ProgramT Action Identity a -> StateT VM IO a)
-> (b -> ProgramT Action Identity a) -> b -> StateT VM IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> ProgramT Action Identity a
k
        EVM.Stepper.EVM EVM b
m -> do
          b
r <- (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)
          (Query -> IO (EVM ()))
-> ProgramT Action Identity a -> StateT VM IO a
forall a. (Query -> IO (EVM ())) -> Stepper a -> StateT VM IO a
interpretWithTrace Query -> IO (EVM ())
fetcher (b -> ProgramT Action Identity a
k b
r)