{-# Language DataKinds #-}
{-# Language ImplicitParams #-}
{-# Language TemplateHaskell #-}
module EVM.Format where

import Prelude hiding (Word)
import qualified EVM
import EVM.Dapp (DappInfo (..), dappSolcByHash, dappAbiMap, showTraceLocation, dappEventMap)
import EVM.Dapp (DappContext (..), contextInfo, contextEnv)
import EVM.Concrete ( wordValue )
import EVM (VM, VMResult(..), cheatCode, traceForest, traceData, Error (..), result)
import EVM (Trace, TraceData (..), Log (..), Query (..), FrameContext (..), Storage(..))
import EVM.SymExec
import EVM.Symbolic (len, litWord)
import EVM.Types (maybeLitWord, Word (..), Whiff(..), SymWord(..), W256 (..), num)
import EVM.Types (Addr, Buffer(..), ByteStringS(..))
import EVM.ABI (AbiValue (..), Event (..), AbiType (..))
import EVM.ABI (Indexed (NotIndexed), getAbiSeq)
import EVM.ABI (parseTypeName, formatString)
import EVM.Solidity (SolcContract(..), contractName, abiMap)
import EVM.Solidity (methodOutput, methodSignature, methodName)

import Control.Arrow ((>>>))
import Control.Lens (view, preview, ix, _2, to, makeLenses, over, each, (^?!))
import Data.Binary.Get (runGetOrFail)
import Data.Bits       (shiftR)
import Data.ByteString (ByteString)
import Data.ByteString.Builder (byteStringHex, toLazyByteString)
import Data.ByteString.Lazy (toStrict, fromStrict)
import Data.DoubleWord (signedWord)
import Data.Foldable (toList)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text, pack, unpack, intercalate)
import Data.Text (dropEnd, splitOn)
import Data.Text.Encoding (decodeUtf8, decodeUtf8')
import Data.Tree (Tree (Node))
import Data.Tree.View (showTree)
import Data.Vector (Vector)
import Data.Word (Word32)

import qualified Data.ByteString as BS
import qualified Data.Char as Char
import qualified Data.Map as Map
import qualified Data.Text as Text

data Signedness = Signed | Unsigned
  deriving (Int -> Signedness -> ShowS
[Signedness] -> ShowS
Signedness -> String
(Int -> Signedness -> ShowS)
-> (Signedness -> String)
-> ([Signedness] -> ShowS)
-> Show Signedness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Signedness] -> ShowS
$cshowList :: [Signedness] -> ShowS
show :: Signedness -> String
$cshow :: Signedness -> String
showsPrec :: Int -> Signedness -> ShowS
$cshowsPrec :: Int -> Signedness -> ShowS
Show)

showDec :: Signedness -> W256 -> Text
showDec :: Signedness -> W256 -> Text
showDec Signedness
signed (W256 Word256
w) =
  let
    i :: Integer
i = case Signedness
signed of
          Signedness
Signed   -> Int256 -> Integer
forall a b. (Integral a, Num b) => a -> b
num (Word256 -> SignedWord Word256
forall w. BinaryWord w => w -> SignedWord w
signedWord Word256
w)
          Signedness
Unsigned -> Word256 -> Integer
forall a b. (Integral a, Num b) => a -> b
num Word256
w
  in
    if Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Addr -> Integer
forall a b. (Integral a, Num b) => a -> b
num Addr
cheatCode
    then Text
"<hevm cheat address>"
    else if (Integer
i :: Integer) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
2 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
256 :: Integer) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
    then Text
"MAX_UINT256"
    else String -> Text
Text.pack (Integer -> String
forall a. Show a => a -> String
show (Integer
i :: Integer))

showWordExact :: Word -> Text
showWordExact :: Word -> Text
showWordExact (C Whiff
_ (W256 Word256
w)) = Word256 -> Text
forall a. (Num a, Integral a, Show a) => a -> Text
humanizeInteger Word256
w

showWordExplanation :: W256 -> DappInfo -> Text
showWordExplanation :: W256 -> DappInfo -> Text
showWordExplanation W256
w DappInfo
_ | W256
w W256 -> W256 -> Bool
forall a. Ord a => a -> a -> Bool
> W256
0xffffffff = Signedness -> W256 -> Text
showDec Signedness
Unsigned W256
w
showWordExplanation W256
w DappInfo
dapp =
  case Word32 -> Map Word32 Method -> Maybe Method
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (W256 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral W256
w) (Getting (Map Word32 Method) DappInfo (Map Word32 Method)
-> DappInfo -> Map Word32 Method
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Word32 Method) DappInfo (Map Word32 Method)
Lens' DappInfo (Map Word32 Method)
dappAbiMap DappInfo
dapp) of
    Maybe Method
Nothing -> Signedness -> W256 -> Text
showDec Signedness
Unsigned W256
w
    Just Method
x  -> Text
"keccak(\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Getting Text Method Text -> Method -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Method Text
Lens' Method Text
methodSignature Method
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\")"

humanizeInteger :: (Num a, Integral a, Show a) => a -> Text
humanizeInteger :: a -> Text
humanizeInteger =
  Text -> [Text] -> Text
Text.intercalate Text
","
  ([Text] -> Text) -> (a -> [Text]) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse
  ([Text] -> [Text]) -> (a -> [Text]) -> a -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Text.reverse
  ([Text] -> [Text]) -> (a -> [Text]) -> a -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> [Text]
Text.chunksOf Int
3
  (Text -> [Text]) -> (a -> Text) -> a -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.reverse
  (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
  (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

showAbiValue :: (?context :: DappContext) => AbiValue -> Text
showAbiValue :: AbiValue -> Text
showAbiValue (AbiBytes Int
_ ByteString
bs) =
  ByteString -> Text
formatBytes ByteString
bs  -- opportunistically decodes recognisable strings
showAbiValue (AbiAddress Addr
addr) =
  let dappinfo :: DappInfo
dappinfo = Getting DappInfo DappContext DappInfo -> DappContext -> DappInfo
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting DappInfo DappContext DappInfo
Lens' DappContext DappInfo
contextInfo ?context::DappContext
DappContext
?context
      contracts :: Map Addr Contract
contracts = Getting (Map Addr Contract) DappContext (Map Addr Contract)
-> DappContext -> Map Addr Contract
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Addr Contract) DappContext (Map Addr Contract)
Lens' DappContext (Map Addr Contract)
contextEnv ?context::DappContext
DappContext
?context
      name :: Text
name = case (Addr -> Map Addr Contract -> Maybe Contract
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Addr
addr Map Addr Contract
contracts) of
        Maybe Contract
Nothing -> Text
""
        Just Contract
contract ->
          let hash :: W256
hash = 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
EVM.codehash Contract
contract
              solcContract :: Maybe SolcContract
solcContract = (Getting (First SolcContract) DappInfo SolcContract
-> DappInfo -> Maybe SolcContract
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((Map W256 (CodeType, SolcContract)
 -> Const (First SolcContract) (Map W256 (CodeType, SolcContract)))
-> DappInfo -> Const (First SolcContract) DappInfo
Lens' DappInfo (Map W256 (CodeType, SolcContract))
dappSolcByHash ((Map W256 (CodeType, SolcContract)
  -> Const (First SolcContract) (Map W256 (CodeType, SolcContract)))
 -> DappInfo -> Const (First SolcContract) DappInfo)
-> ((SolcContract -> Const (First SolcContract) SolcContract)
    -> Map W256 (CodeType, SolcContract)
    -> Const (First SolcContract) (Map W256 (CodeType, SolcContract)))
-> Getting (First SolcContract) DappInfo 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 (((CodeType, SolcContract)
  -> Const (First SolcContract) (CodeType, SolcContract))
 -> Map W256 (CodeType, SolcContract)
 -> Const (First SolcContract) (Map W256 (CodeType, SolcContract)))
-> ((SolcContract -> Const (First SolcContract) SolcContract)
    -> (CodeType, SolcContract)
    -> Const (First SolcContract) (CodeType, SolcContract))
-> (SolcContract -> Const (First SolcContract) SolcContract)
-> Map W256 (CodeType, SolcContract)
-> Const (First SolcContract) (Map W256 (CodeType, SolcContract))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SolcContract -> Const (First SolcContract) SolcContract)
-> (CodeType, SolcContract)
-> Const (First SolcContract) (CodeType, SolcContract)
forall s t a b. Field2 s t a b => Lens s t a b
_2) DappInfo
dappinfo)
          in Maybe SolcContract -> Text
maybeContractName' Maybe SolcContract
solcContract
  in
    Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Addr -> String
forall a. Show a => a -> String
show Addr
addr)
showAbiValue AbiValue
v = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ AbiValue -> String
forall a. Show a => a -> String
show AbiValue
v

showAbiValues :: (?context :: DappContext) => Vector AbiValue -> Text
showAbiValues :: Vector AbiValue -> Text
showAbiValues Vector AbiValue
vs = [Text] -> Text
parenthesise ((?context::DappContext) => Vector AbiValue -> [Text]
Vector AbiValue -> [Text]
textAbiValues Vector AbiValue
vs)

textAbiValues :: (?context :: DappContext) => Vector AbiValue -> [Text]
textAbiValues :: Vector AbiValue -> [Text]
textAbiValues Vector AbiValue
vs = Vector Text -> [Text]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((AbiValue -> Text) -> Vector AbiValue -> Vector Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (?context::DappContext) => AbiValue -> Text
AbiValue -> Text
showAbiValue Vector AbiValue
vs)

textValues :: (?context :: DappContext) => [AbiType] -> Buffer -> [Text]
textValues :: [AbiType] -> Buffer -> [Text]
textValues [AbiType]
ts (SymbolicBuffer  [SWord 8]
_) = [String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ AbiType -> String
forall a. Show a => a -> String
show AbiType
t | AbiType
t <- [AbiType]
ts]
textValues [AbiType]
ts (ConcreteBuffer ByteString
bs) =
  case Get (Vector AbiValue)
-> ByteString
-> Either
     (ByteString, ByteOffset, String)
     (ByteString, ByteOffset, Vector AbiValue)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
runGetOrFail (Int -> [AbiType] -> Get (Vector AbiValue)
getAbiSeq ([AbiType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [AbiType]
ts) [AbiType]
ts) (ByteString -> ByteString
fromStrict ByteString
bs) of
    Right (ByteString
_, ByteOffset
_, Vector AbiValue
xs) -> (?context::DappContext) => Vector AbiValue -> [Text]
Vector AbiValue -> [Text]
textAbiValues Vector AbiValue
xs
    Left (ByteString
_, ByteOffset
_, String
_)   -> [ByteString -> Text
formatBinary ByteString
bs]

parenthesise :: [Text] -> Text
parenthesise :: [Text] -> Text
parenthesise [Text]
ts = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
", " [Text]
ts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

showValues :: (?context :: DappContext) => [AbiType] -> Buffer -> Text
showValues :: [AbiType] -> Buffer -> Text
showValues [AbiType]
ts Buffer
b = [Text] -> Text
parenthesise ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (?context::DappContext) => [AbiType] -> Buffer -> [Text]
[AbiType] -> Buffer -> [Text]
textValues [AbiType]
ts Buffer
b

showValue :: (?context :: DappContext) => AbiType -> Buffer -> Text
showValue :: AbiType -> Buffer -> Text
showValue AbiType
t Buffer
b = [Text] -> Text
forall a. [a] -> a
head ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (?context::DappContext) => [AbiType] -> Buffer -> [Text]
[AbiType] -> Buffer -> [Text]
textValues [AbiType
t] Buffer
b

showCall :: (?context :: DappContext) => [AbiType] -> Buffer -> Text
showCall :: [AbiType] -> Buffer -> Text
showCall [AbiType]
ts (SymbolicBuffer [SWord 8]
bs) = (?context::DappContext) => [AbiType] -> Buffer -> Text
[AbiType] -> Buffer -> Text
showValues [AbiType]
ts (Buffer -> Text) -> Buffer -> Text
forall a b. (a -> b) -> a -> b
$ [SWord 8] -> Buffer
SymbolicBuffer (Int -> [SWord 8] -> [SWord 8]
forall a. Int -> [a] -> [a]
drop Int
4 [SWord 8]
bs)
showCall [AbiType]
ts (ConcreteBuffer ByteString
bs) = (?context::DappContext) => [AbiType] -> Buffer -> Text
[AbiType] -> Buffer -> Text
showValues [AbiType]
ts (Buffer -> Text) -> Buffer -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Buffer
ConcreteBuffer (Int -> ByteString -> ByteString
BS.drop Int
4 ByteString
bs)

showError :: (?context :: DappContext) => ByteString -> Text
showError :: ByteString -> Text
showError ByteString
bs = case Int -> ByteString -> ByteString
BS.take Int
4 ByteString
bs of
  -- Method ID for Error(string)
  ByteString
"\b\195y\160" -> (?context::DappContext) => [AbiType] -> Buffer -> Text
[AbiType] -> Buffer -> Text
showCall [AbiType
AbiStringType] (ByteString -> Buffer
ConcreteBuffer ByteString
bs)
  ByteString
_             -> ByteString -> Text
formatBinary ByteString
bs


-- the conditions under which bytes will be decoded and rendered as a string
isPrintable :: ByteString -> Bool
isPrintable :: ByteString -> Bool
isPrintable =
  ByteString -> Either UnicodeException Text
decodeUtf8' (ByteString -> Either UnicodeException Text)
-> (Either UnicodeException Text -> Bool) -> ByteString -> Bool
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
    (UnicodeException -> Bool)
-> (Text -> Bool) -> Either UnicodeException Text -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
      (Bool -> UnicodeException -> Bool
forall a b. a -> b -> a
const Bool
False)
      ((Char -> Bool) -> Text -> Bool
Text.all (\Char
c-> Char -> Bool
Char.isPrint Char
c Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
Char.isControl) Char
c))

formatBytes :: ByteString -> Text
formatBytes :: ByteString -> Text
formatBytes ByteString
b =
  let (ByteString
s, ByteString
_) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.spanEnd (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) ByteString
b
  in
    if ByteString -> Bool
isPrintable ByteString
s
    then ByteString -> Text
formatBString ByteString
s
    else ByteString -> Text
formatBinary ByteString
b

formatSBytes :: Buffer -> Text
formatSBytes :: Buffer -> Text
formatSBytes (SymbolicBuffer [SWord 8]
b) = Text
"<" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Int -> String
forall a. Show a => a -> String
show ([SWord 8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SWord 8]
b)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" symbolic bytes>"
formatSBytes (ConcreteBuffer ByteString
b) = ByteString -> Text
formatBytes ByteString
b

-- a string that came from bytes, displayed with special quotes
formatBString :: ByteString -> Text
formatBString :: ByteString -> Text
formatBString ByteString
b = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [ Text
"«",  (Char -> Bool) -> Text -> Text
Text.dropAround (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'"') (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> String
formatString ByteString
b), Text
"»" ]

formatSString :: Buffer -> Text
formatSString :: Buffer -> Text
formatSString (SymbolicBuffer [SWord 8]
bs) = Text
"<" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Int -> String
forall a. Show a => a -> String
show ([SWord 8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SWord 8]
bs)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" symbolic bytes (string)>"
formatSString (ConcreteBuffer ByteString
bs) = String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> String
formatString ByteString
bs

formatBinary :: ByteString -> Text
formatBinary :: ByteString -> Text
formatBinary =
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) Text
"0x" (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (ByteString -> Builder) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteStringHex

formatSBinary :: Buffer -> Text
formatSBinary :: Buffer -> Text
formatSBinary (SymbolicBuffer [SWord 8]
bs) = Text
"<" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Int -> String
forall a. Show a => a -> String
show ([SWord 8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SWord 8]
bs)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" symbolic bytes>"
formatSBinary (ConcreteBuffer ByteString
bs) = ByteString -> Text
formatBinary ByteString
bs

showTraceTree :: DappInfo -> VM -> Text
showTraceTree :: DappInfo -> VM -> Text
showTraceTree DappInfo
dapp VM
vm =
  let forest :: Forest Trace
forest = VM -> Forest Trace
traceForest VM
vm
      traces :: [Tree String]
traces = (Tree Trace -> Tree String) -> Forest Trace -> [Tree String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Trace -> String) -> Tree Trace -> Tree String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> String
unpack (Text -> String) -> (Trace -> Text) -> Trace -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DappInfo -> VM -> Trace -> Text
showTrace DappInfo
dapp VM
vm)) Forest Trace
forest
  in String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (Tree String -> String) -> [Tree String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree String -> String
showTree [Tree String]
traces

unindexed :: [(AbiType, Indexed)] -> [AbiType]
unindexed :: [(AbiType, Indexed)] -> [AbiType]
unindexed [(AbiType, Indexed)]
ts = [AbiType
t | (AbiType
t, Indexed
NotIndexed) <- [(AbiType, Indexed)]
ts]

showTrace :: DappInfo -> VM -> Trace -> Text
showTrace :: DappInfo -> VM -> Trace -> Text
showTrace DappInfo
dapp VM
vm Trace
trace =
  let ?context = DappContext { _contextInfo = dapp, _contextEnv = vm ^?! EVM.env . EVM.contracts }
  in let
    pos :: Text
pos =
      case DappInfo -> Trace -> Either Text Text
showTraceLocation DappInfo
dapp Trace
trace of
        Left Text
x -> Text
" \x1b[1m" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\x1b[0m"
        Right Text
x -> Text
" \x1b[1m(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")\x1b[0m"
    fullAbiMap :: Map Word32 Method
fullAbiMap = Getting (Map Word32 Method) DappInfo (Map Word32 Method)
-> DappInfo -> Map Word32 Method
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Word32 Method) DappInfo (Map Word32 Method)
Lens' DappInfo (Map Word32 Method)
dappAbiMap DappInfo
dapp
  in case Getting TraceData Trace TraceData -> Trace -> TraceData
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting TraceData Trace TraceData
Lens' Trace TraceData
traceData Trace
trace of
    EventTrace (Log Addr
_ Buffer
bytes [SymWord]
topics) ->
      let logn :: Text
logn = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"\x1b[36m"
            , Text
"log" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (Int -> String
forall a. Show a => a -> String
show ([SymWord] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SymWord]
topics)))
            , [Text] -> Text
parenthesise (((SymWord -> Text) -> [SymWord] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
pack (String -> Text) -> (SymWord -> String) -> SymWord -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymWord -> String
forall a. Show a => a -> String
show) [SymWord]
topics) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Buffer -> Text
formatSBinary Buffer
bytes])
            , Text
"\x1b[0m"
            ] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos
          knownTopic :: Text -> [(AbiType, Indexed)] -> Text
knownTopic Text
name [(AbiType, Indexed)]
types = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"\x1b[36m"
            , Text
name
            , (?context::DappContext) => [AbiType] -> Buffer -> Text
[AbiType] -> Buffer -> Text
showValues ([(AbiType, Indexed)] -> [AbiType]
unindexed [(AbiType, Indexed)]
types) Buffer
bytes
            -- todo: show indexed
            , Text
"\x1b[0m"
            ] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos
          lognote :: Text -> Text -> Text
lognote Text
sig Text
usr = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"\x1b[36m"
            , Text
"LogNote"
            , [Text] -> Text
parenthesise [Text
sig, Text
usr, Text
"..."]
            , Text
"\x1b[0m"
            ] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos
      in case [SymWord]
topics of
        [] ->
          Text
logn
        (SymWord
t1:[SymWord]
_) ->
          case SymWord -> Maybe Word
maybeLitWord SymWord
t1 of
            Just Word
topic ->
              case W256 -> Map W256 Event -> Maybe Event
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Word -> W256
wordValue Word
topic) (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) of
                Just (Event Text
name Anonymity
_ [(AbiType, Indexed)]
types) ->
                  Text -> [(AbiType, Indexed)] -> Text
knownTopic Text
name [(AbiType, Indexed)]
types
                Maybe Event
Nothing ->
                  case [SymWord]
topics of
                    [SymWord
_, SymWord
t2, SymWord
_, SymWord
_] ->
                      -- check for ds-note logs.. possibly catching false positives
                      -- event LogNote(
                      --     bytes4   indexed  sig,
                      --     address  indexed  usr,
                      --     bytes32  indexed  arg1,
                      --     bytes32  indexed  arg2,
                      --     bytes             data
                      -- ) anonymous;
                      let
                        sig :: Word32
sig = W256 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (W256 -> Word32) -> W256 -> Word32
forall a b. (a -> b) -> a -> b
$ W256 -> Int -> W256
forall a. Bits a => a -> Int -> a
shiftR (Word -> W256
wordValue Word
topic) Int
224 :: Word32
                        usr :: Text
usr = case SymWord -> Maybe Word
maybeLitWord SymWord
t2 of
                          Just Word
w ->
                            String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Addr -> String
forall a. Show a => a -> String
show (Addr -> String) -> Addr -> String
forall a b. (a -> b) -> a -> b
$ (Word -> Addr
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
w :: Addr)
                          Maybe Word
Nothing  ->
                            Text
"<symbolic>"
                      in
                        case Word32 -> Map Word32 Method -> Maybe Method
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word32
sig (Getting (Map Word32 Method) DappInfo (Map Word32 Method)
-> DappInfo -> Map Word32 Method
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Word32 Method) DappInfo (Map Word32 Method)
Lens' DappInfo (Map Word32 Method)
dappAbiMap DappInfo
dapp) of
                          Just Method
m ->
                           Text -> Text -> Text
lognote (Getting Text Method Text -> Method -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Method Text
Lens' Method Text
methodSignature Method
m) Text
usr
                          Maybe Method
Nothing ->
                            Text
logn
                    [SymWord]
_ ->
                      Text
logn
            Maybe Word
Nothing ->
              Text
logn

    QueryTrace Query
q ->
      case Query
q of
        PleaseFetchContract Addr
addr StorageModel
_ Contract -> EVM ()
_ ->
          Text
"fetch contract " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Addr -> String
forall a. Show a => a -> String
show Addr
addr) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos
        PleaseFetchSlot Addr
addr Word
slot Word -> EVM ()
_ ->
          Text
"fetch storage slot " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Word -> String
forall a. Show a => a -> String
show Word
slot) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Addr -> String
forall a. Show a => a -> String
show Addr
addr) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos
        PleaseAskSMT {} ->
          Text
"ask smt" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos
        PleaseMakeUnique {} ->
          Text
"make unique value" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos
        PleaseDoFFI [String]
cmd ByteString -> EVM ()
_ ->
          Text
"execute ffi " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack ([String] -> String
forall a. Show a => a -> String
show [String]
cmd) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos

    ErrorTrace Error
e ->
      case Error
e of
        Revert ByteString
out ->
          Text
"\x1b[91merror\x1b[0m " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Revert " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (?context::DappContext) => ByteString -> Text
ByteString -> Text
showError ByteString
out Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos
        Error
_ ->
          Text
"\x1b[91merror\x1b[0m " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Error -> String
forall a. Show a => a -> String
show Error
e) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos

    ReturnTrace Buffer
out (CallContext Addr
_ Addr
_ Word
_ Word
_ W256
_ (Just Word
abi) Buffer
_ Map Addr Contract
_ SubState
_) ->
      Text
"← " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
        case Word32 -> Map Word32 Method -> Maybe Method
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Word -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
abi) Map Word32 Method
fullAbiMap of
          Just Method
m  ->
            case [(Text, AbiType)] -> ([Text], [AbiType])
forall a b. [(a, b)] -> ([a], [b])
unzip (Getting [(Text, AbiType)] Method [(Text, AbiType)]
-> Method -> [(Text, AbiType)]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [(Text, AbiType)] Method [(Text, AbiType)]
Lens' Method [(Text, AbiType)]
methodOutput Method
m) of
              ([], []) ->
                Buffer -> Text
formatSBinary Buffer
out
              ([Text]
_, [AbiType]
ts) ->
                (?context::DappContext) => [AbiType] -> Buffer -> Text
[AbiType] -> Buffer -> Text
showValues [AbiType]
ts Buffer
out
          Maybe Method
Nothing ->
            Buffer -> Text
formatSBinary Buffer
out
    ReturnTrace Buffer
out (CallContext {}) ->
      Text
"← " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Buffer -> Text
formatSBinary Buffer
out
    ReturnTrace Buffer
out (CreationContext {}) ->
      Text
"← " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Int -> String
forall a. Show a => a -> String
show (Buffer -> Int
len Buffer
out)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes of code"

    EntryTrace Text
t ->
      Text
t
    FrameTrace (CreationContext Addr
addr W256
hash Map Addr Contract
_ SubState
_ ) ->
      Text
"create "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe SolcContract -> Text
maybeContractName (Getting (First SolcContract) DappInfo SolcContract
-> DappInfo -> Maybe SolcContract
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((Map W256 (CodeType, SolcContract)
 -> Const (First SolcContract) (Map W256 (CodeType, SolcContract)))
-> DappInfo -> Const (First SolcContract) DappInfo
Lens' DappInfo (Map W256 (CodeType, SolcContract))
dappSolcByHash ((Map W256 (CodeType, SolcContract)
  -> Const (First SolcContract) (Map W256 (CodeType, SolcContract)))
 -> DappInfo -> Const (First SolcContract) DappInfo)
-> ((SolcContract -> Const (First SolcContract) SolcContract)
    -> Map W256 (CodeType, SolcContract)
    -> Const (First SolcContract) (Map W256 (CodeType, SolcContract)))
-> Getting (First SolcContract) DappInfo 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 (((CodeType, SolcContract)
  -> Const (First SolcContract) (CodeType, SolcContract))
 -> Map W256 (CodeType, SolcContract)
 -> Const (First SolcContract) (Map W256 (CodeType, SolcContract)))
-> ((SolcContract -> Const (First SolcContract) SolcContract)
    -> (CodeType, SolcContract)
    -> Const (First SolcContract) (CodeType, SolcContract))
-> (SolcContract -> Const (First SolcContract) SolcContract)
-> Map W256 (CodeType, SolcContract)
-> Const (First SolcContract) (Map W256 (CodeType, SolcContract))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SolcContract -> Const (First SolcContract) SolcContract)
-> (CodeType, SolcContract)
-> Const (First SolcContract) (CodeType, SolcContract)
forall s t a b. Field2 s t a b => Lens s t a b
_2) DappInfo
dapp)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Addr -> String
forall a. Show a => a -> String
show Addr
addr)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos
    FrameTrace (CallContext Addr
target Addr
context Word
_ Word
_ W256
hash Maybe Word
abi Buffer
calldata Map Addr Contract
_ SubState
_) ->
      let calltype :: Text
calltype = if Addr
target Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
context
                     then Text
"call "
                     else Text
"delegatecall "
      in case Getting (First SolcContract) DappInfo SolcContract
-> DappInfo -> Maybe SolcContract
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((Map W256 (CodeType, SolcContract)
 -> Const (First SolcContract) (Map W256 (CodeType, SolcContract)))
-> DappInfo -> Const (First SolcContract) DappInfo
Lens' DappInfo (Map W256 (CodeType, SolcContract))
dappSolcByHash ((Map W256 (CodeType, SolcContract)
  -> Const (First SolcContract) (Map W256 (CodeType, SolcContract)))
 -> DappInfo -> Const (First SolcContract) DappInfo)
-> ((SolcContract -> Const (First SolcContract) SolcContract)
    -> Map W256 (CodeType, SolcContract)
    -> Const (First SolcContract) (Map W256 (CodeType, SolcContract)))
-> Getting (First SolcContract) DappInfo 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 (((CodeType, SolcContract)
  -> Const (First SolcContract) (CodeType, SolcContract))
 -> Map W256 (CodeType, SolcContract)
 -> Const (First SolcContract) (Map W256 (CodeType, SolcContract)))
-> ((SolcContract -> Const (First SolcContract) SolcContract)
    -> (CodeType, SolcContract)
    -> Const (First SolcContract) (CodeType, SolcContract))
-> (SolcContract -> Const (First SolcContract) SolcContract)
-> Map W256 (CodeType, SolcContract)
-> Const (First SolcContract) (Map W256 (CodeType, SolcContract))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SolcContract -> Const (First SolcContract) SolcContract)
-> (CodeType, SolcContract)
-> Const (First SolcContract) (CodeType, SolcContract)
forall s t a b. Field2 s t a b => Lens s t a b
_2) DappInfo
dapp of
        Maybe SolcContract
Nothing ->
          Text
calltype
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Addr -> String
forall a. Show a => a -> String
show Addr
target)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
"::"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> case Word32 -> Map Word32 Method -> Maybe Method
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Word -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Maybe Word -> Word
forall a. a -> Maybe a -> a
fromMaybe Word
0x00 Maybe Word
abi)) Map Word32 Method
fullAbiMap of
                 Just Method
m  ->
                   Text
"\x1b[1m"
                   Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Getting Text Method Text -> Method -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Method Text
Lens' Method Text
methodName Method
m
                   Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\x1b[0m"
                   Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (?context::DappContext) => [AbiType] -> Buffer -> Text
[AbiType] -> Buffer -> Text
showCall ([Maybe AbiType] -> [AbiType]
forall a. [Maybe a] -> [a]
catMaybes (Text -> [Maybe AbiType]
getAbiTypes (Getting Text Method Text -> Method -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Method Text
Lens' Method Text
methodSignature Method
m))) Buffer
calldata
                 Maybe Method
Nothing ->
                   Buffer -> Text
formatSBinary Buffer
calldata
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos

        Just SolcContract
solc ->
          Text
calltype
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\x1b[1m"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Getting Text SolcContract Text -> SolcContract -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Text SolcContract Text
Lens' SolcContract Text
contractName Getting Text SolcContract Text
-> ((Text -> Const Text Text) -> Text -> Const Text Text)
-> Getting Text SolcContract Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text)
-> (Text -> Const Text Text) -> Text -> Const Text Text
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Text -> Text
contractNamePart) SolcContract
solc
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"::"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Word -> Text) -> Maybe Word -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"[fallback function]"
                 (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"[unknown method]" (Maybe Text -> Text) -> (Word -> Maybe Text) -> Word -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SolcContract -> Word -> Maybe Text
maybeAbiName SolcContract
solc)
                 Maybe Word
abi
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> ([Maybe AbiType] -> Text) -> Maybe [Maybe AbiType] -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Buffer -> Text
formatSBinary Buffer
calldata Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
                 (\[Maybe AbiType]
x -> (?context::DappContext) => [AbiType] -> Buffer -> Text
[AbiType] -> Buffer -> Text
showCall ([Maybe AbiType] -> [AbiType]
forall a. [Maybe a] -> [a]
catMaybes [Maybe AbiType]
x) Buffer
calldata)
                 (Maybe Word
abi Maybe Word
-> (Word -> Maybe [Maybe AbiType]) -> Maybe [Maybe AbiType]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> [Maybe AbiType]) -> Maybe Text -> Maybe [Maybe AbiType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Maybe AbiType]
getAbiTypes (Maybe Text -> Maybe [Maybe AbiType])
-> (Word -> Maybe Text) -> Word -> Maybe [Maybe AbiType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SolcContract -> Word -> Maybe Text
maybeAbiName SolcContract
solc)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\x1b[0m"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos

getAbiTypes :: Text -> [Maybe AbiType]
getAbiTypes :: Text -> [Maybe AbiType]
getAbiTypes Text
abi = (Text -> Maybe AbiType) -> [Text] -> [Maybe AbiType]
forall a b. (a -> b) -> [a] -> [b]
map (Vector AbiType -> Text -> Maybe AbiType
parseTypeName Vector AbiType
forall a. Monoid a => a
mempty) [Text]
types
  where
    types :: [Text]
types =
      (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
        Text -> Text -> [Text]
splitOn Text
"," (Int -> Text -> Text
dropEnd Int
1 ([Text] -> Text
forall a. [a] -> a
last (Text -> Text -> [Text]
splitOn Text
"(" Text
abi)))

maybeContractName :: Maybe SolcContract -> Text
maybeContractName :: Maybe SolcContract -> Text
maybeContractName =
  Text -> (SolcContract -> Text) -> Maybe SolcContract -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"<unknown contract>" (Getting Text SolcContract Text -> SolcContract -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Text SolcContract Text
Lens' SolcContract Text
contractName Getting Text SolcContract Text
-> ((Text -> Const Text Text) -> Text -> Const Text Text)
-> Getting Text SolcContract Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text)
-> (Text -> Const Text Text) -> Text -> Const Text Text
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Text -> Text
contractNamePart))

maybeContractName' :: Maybe SolcContract -> Text
maybeContractName' :: Maybe SolcContract -> Text
maybeContractName' =
  Text -> (SolcContract -> Text) -> Maybe SolcContract -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Getting Text SolcContract Text -> SolcContract -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Text SolcContract Text
Lens' SolcContract Text
contractName Getting Text SolcContract Text
-> ((Text -> Const Text Text) -> Text -> Const Text Text)
-> Getting Text SolcContract Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text)
-> (Text -> Const Text Text) -> Text -> Const Text Text
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Text -> Text
contractNamePart))

maybeAbiName :: SolcContract -> Word -> Maybe Text
maybeAbiName :: SolcContract -> Word -> Maybe Text
maybeAbiName SolcContract
solc Word
abi = Getting (First Text) SolcContract Text
-> SolcContract -> Maybe Text
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((Map Word32 Method -> Const (First Text) (Map Word32 Method))
-> SolcContract -> Const (First Text) SolcContract
Lens' SolcContract (Map Word32 Method)
abiMap ((Map Word32 Method -> Const (First Text) (Map Word32 Method))
 -> SolcContract -> Const (First Text) SolcContract)
-> ((Text -> Const (First Text) Text)
    -> Map Word32 Method -> Const (First Text) (Map Word32 Method))
-> Getting (First Text) SolcContract Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Word32 Method)
-> Traversal' (Map Word32 Method) (IxValue (Map Word32 Method))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (Word -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
abi) ((Method -> Const (First Text) Method)
 -> Map Word32 Method -> Const (First Text) (Map Word32 Method))
-> ((Text -> Const (First Text) Text)
    -> Method -> Const (First Text) Method)
-> (Text -> Const (First Text) Text)
-> Map Word32 Method
-> Const (First Text) (Map Word32 Method)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (First Text) Text)
-> Method -> Const (First Text) Method
Lens' Method Text
methodSignature) SolcContract
solc

contractNamePart :: Text -> Text
contractNamePart :: Text -> Text
contractNamePart Text
x = (Char -> Bool) -> Text -> [Text]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') Text
x [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
1

contractPathPart :: Text -> Text
contractPathPart :: Text -> Text
contractPathPart Text
x = (Char -> Bool) -> Text -> [Text]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') Text
x [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int
0

prettyvmresult :: (?context :: DappContext) => VMResult -> String
prettyvmresult :: VMResult -> String
prettyvmresult (EVM.VMFailure (EVM.Revert ByteString
""))  = String
"Revert"
prettyvmresult (EVM.VMFailure (EVM.Revert ByteString
msg)) = String
"Revert" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ (?context::DappContext) => ByteString -> Text
ByteString -> Text
showError ByteString
msg)
prettyvmresult (EVM.VMFailure (EVM.UnrecognizedOpcode Word8
254)) = String
"Assertion violation"
prettyvmresult (EVM.VMFailure Error
err) = String
"Failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Error -> String
forall a. Show a => a -> String
show Error
err
prettyvmresult (EVM.VMSuccess (ConcreteBuffer ByteString
msg)) =
  if ByteString -> Bool
BS.null ByteString
msg
  then String
"Stop"
  else String
"Return: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ByteStringS -> String
forall a. Show a => a -> String
show (ByteString -> ByteStringS
ByteStringS ByteString
msg)
prettyvmresult (EVM.VMSuccess (SymbolicBuffer [SWord 8]
msg)) =
  String
"Return: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([SWord 8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SWord 8]
msg) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" symbolic bytes"

currentSolc :: DappInfo -> VM -> Maybe SolcContract
currentSolc :: DappInfo -> VM -> Maybe SolcContract
currentSolc DappInfo
dapp VM
vm =
  let
    this :: Contract
this = VM
vm VM -> Getting (Endo Contract) VM Contract -> Contract
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! (Env -> Const (Endo Contract) Env)
-> VM -> Const (Endo Contract) VM
Lens' VM Env
EVM.env ((Env -> Const (Endo Contract) Env)
 -> VM -> Const (Endo Contract) VM)
-> ((Contract -> Const (Endo Contract) Contract)
    -> Env -> Const (Endo Contract) Env)
-> Getting (Endo Contract) VM Contract
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Addr Contract -> Const (Endo Contract) (Map Addr Contract))
-> Env -> Const (Endo Contract) Env
Lens' Env (Map Addr Contract)
EVM.contracts ((Map Addr Contract -> Const (Endo Contract) (Map Addr Contract))
 -> Env -> Const (Endo Contract) Env)
-> ((Contract -> Const (Endo Contract) Contract)
    -> Map Addr Contract -> Const (Endo Contract) (Map Addr Contract))
-> (Contract -> Const (Endo Contract) Contract)
-> Env
-> Const (Endo Contract) 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 (Getting Addr VM Addr -> VM -> Addr
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((FrameState -> Const Addr FrameState) -> VM -> Const Addr VM
Lens' VM FrameState
EVM.state ((FrameState -> Const Addr FrameState) -> VM -> Const Addr VM)
-> ((Addr -> Const Addr Addr)
    -> FrameState -> Const Addr FrameState)
-> Getting Addr VM Addr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Addr -> Const Addr Addr) -> FrameState -> Const Addr FrameState
Lens' FrameState Addr
EVM.contract) VM
vm)
    h :: W256
h = 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
EVM.codehash Contract
this
  in
    Getting (First SolcContract) DappInfo SolcContract
-> DappInfo -> Maybe SolcContract
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((Map W256 (CodeType, SolcContract)
 -> Const (First SolcContract) (Map W256 (CodeType, SolcContract)))
-> DappInfo -> Const (First SolcContract) DappInfo
Lens' DappInfo (Map W256 (CodeType, SolcContract))
dappSolcByHash ((Map W256 (CodeType, SolcContract)
  -> Const (First SolcContract) (Map W256 (CodeType, SolcContract)))
 -> DappInfo -> Const (First SolcContract) DappInfo)
-> ((SolcContract -> Const (First SolcContract) SolcContract)
    -> Map W256 (CodeType, SolcContract)
    -> Const (First SolcContract) (Map W256 (CodeType, SolcContract)))
-> Getting (First SolcContract) DappInfo 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
h (((CodeType, SolcContract)
  -> Const (First SolcContract) (CodeType, SolcContract))
 -> Map W256 (CodeType, SolcContract)
 -> Const (First SolcContract) (Map W256 (CodeType, SolcContract)))
-> ((SolcContract -> Const (First SolcContract) SolcContract)
    -> (CodeType, SolcContract)
    -> Const (First SolcContract) (CodeType, SolcContract))
-> (SolcContract -> Const (First SolcContract) SolcContract)
-> Map W256 (CodeType, SolcContract)
-> Const (First SolcContract) (Map W256 (CodeType, SolcContract))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SolcContract -> Const (First SolcContract) SolcContract)
-> (CodeType, SolcContract)
-> Const (First SolcContract) (CodeType, SolcContract)
forall s t a b. Field2 s t a b => Lens s t a b
_2) DappInfo
dapp

-- TODO: display in an 'act' format

-- TreeLine describes a singe line of the tree
-- it contains the indentation which is prefixed to it
-- and its content which contains the rest
data TreeLine = TreeLine {
  TreeLine -> String
_indent   :: String,
  TreeLine -> String
_content  :: String
  }

makeLenses ''TreeLine

-- SHOW TREE

showTreeIndentSymbol :: Bool      -- ^ isLastChild
                     -> Bool      -- ^ isTreeHead
                     -> String
showTreeIndentSymbol :: Bool -> Bool -> String
showTreeIndentSymbol Bool
True  Bool
True  = String
"\x2514" -- └
showTreeIndentSymbol Bool
False Bool
True  = String
"\x251c" -- ├
showTreeIndentSymbol Bool
True  Bool
False = String
" "
showTreeIndentSymbol Bool
False Bool
False = String
"\x2502" -- │

flattenTree :: Int -> -- total number of cases
               Int -> -- case index
               Tree [String] ->
               [TreeLine]
-- this case should never happen for our use case, here for generality
flattenTree :: Int -> Int -> Tree [String] -> [TreeLine]
flattenTree Int
_ Int
_ (Node [] Forest [String]
_)  = []

flattenTree Int
totalCases Int
i (Node (String
x:[String]
xs) Forest [String]
cs) = let
  isLastCase :: Bool
isLastCase       = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
totalCases
  indenthead :: String
indenthead       = Bool -> Bool -> String
showTreeIndentSymbol Bool
isLastCase Bool
True String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" "
  indentchild :: String
indentchild      = Bool -> Bool -> String
showTreeIndentSymbol Bool
isLastCase Bool
False String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" "
  in String -> String -> TreeLine
TreeLine String
indenthead String
x
  TreeLine -> [TreeLine] -> [TreeLine]
forall a. a -> [a] -> [a]
: ((String -> String -> TreeLine
TreeLine String
indentchild (String -> TreeLine) -> [String] -> [TreeLine]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
xs) [TreeLine] -> [TreeLine] -> [TreeLine]
forall a. [a] -> [a] -> [a]
++ ASetter [TreeLine] [TreeLine] String String
-> ShowS -> [TreeLine] -> [TreeLine]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((TreeLine -> Identity TreeLine)
-> [TreeLine] -> Identity [TreeLine]
forall s t a b. Each s t a b => Traversal s t a b
each ((TreeLine -> Identity TreeLine)
 -> [TreeLine] -> Identity [TreeLine])
-> ((String -> Identity String) -> TreeLine -> Identity TreeLine)
-> ASetter [TreeLine] [TreeLine] String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Identity String) -> TreeLine -> Identity TreeLine
Lens' TreeLine String
indent) (String -> ShowS
forall a. Semigroup a => a -> a -> a
(<>) String
indentchild) (Forest [String] -> [TreeLine]
flattenForest Forest [String]
cs))

flattenForest :: [Tree [String]] -> [TreeLine]
flattenForest :: Forest [String] -> [TreeLine]
flattenForest Forest [String]
forest = [[TreeLine]] -> [TreeLine]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[TreeLine]] -> [TreeLine]) -> [[TreeLine]] -> [TreeLine]
forall a b. (a -> b) -> a -> b
$ (Int -> Tree [String] -> [TreeLine])
-> [Int] -> Forest [String] -> [[TreeLine]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> Int -> Tree [String] -> [TreeLine]
flattenTree (Forest [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest [String]
forest)) [Int
0..] Forest [String]
forest

leftpad :: Int -> String -> String
leftpad :: Int -> ShowS
leftpad Int
n = String -> ShowS
forall a. Semigroup a => a -> a -> a
(<>) (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' '

showTree' :: Tree [String] -> String
showTree' :: Tree [String] -> String
showTree' (Node [String]
s []) = [String] -> String
unlines [String]
s
showTree' (Node [String]
_ Forest [String]
children) =
  let
    treeLines :: [TreeLine]
treeLines = Forest [String] -> [TreeLine]
flattenForest Forest [String]
children
    maxIndent :: Int
maxIndent = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> (TreeLine -> String) -> TreeLine -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeLine -> String
_indent (TreeLine -> Int) -> [TreeLine] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TreeLine]
treeLines)
    showTreeLine :: TreeLine -> String
showTreeLine (TreeLine String
colIndent String
colContent) =
      let indentSize :: Int
indentSize = Int
maxIndent Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
colIndent
      in String
colIndent String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> ShowS
leftpad Int
indentSize String
colContent
  in [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ TreeLine -> String
showTreeLine (TreeLine -> String) -> [TreeLine] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TreeLine]
treeLines


-- RENDER TREE

showStorage :: [(SymWord, SymWord)] -> [String]
showStorage :: [(SymWord, SymWord)] -> [String]
showStorage = ((SymWord, SymWord) -> String) -> [(SymWord, SymWord)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(SymWord
k, SymWord
v) -> SymWord -> String
forall a. Show a => a -> String
show SymWord
k String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" => " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SymWord -> String
forall a. Show a => a -> String
show SymWord
v)

showLeafInfo :: DappInfo -> BranchInfo -> [String]
showLeafInfo :: DappInfo -> BranchInfo -> [String]
showLeafInfo DappInfo
srcInfo (BranchInfo VM
vm Maybe Whiff
_) = let
  ?context = DappContext { _contextInfo = srcInfo, _contextEnv = vm ^?! EVM.env . EVM.contracts }
  in let
  self :: Addr
self    = Getting Addr VM Addr -> VM -> Addr
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((FrameState -> Const Addr FrameState) -> VM -> Const Addr VM
Lens' VM FrameState
EVM.state ((FrameState -> Const Addr FrameState) -> VM -> Const Addr VM)
-> ((Addr -> Const Addr Addr)
    -> FrameState -> Const Addr FrameState)
-> Getting Addr VM Addr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Addr -> Const Addr Addr) -> FrameState -> Const Addr FrameState
Lens' FrameState Addr
EVM.contract) VM
vm
  updates :: [(SymWord, SymWord)]
updates = case 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 ((Env -> Const (Map Addr Contract) Env)
-> VM -> Const (Map Addr Contract) VM
Lens' VM Env
EVM.env ((Env -> Const (Map Addr Contract) Env)
 -> VM -> Const (Map Addr Contract) VM)
-> ((Map Addr Contract
     -> Const (Map Addr Contract) (Map Addr Contract))
    -> Env -> Const (Map Addr Contract) Env)
-> 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))
-> Env -> Const (Map Addr Contract) Env
Lens' Env (Map Addr Contract)
EVM.contracts) VM
vm Map Addr Contract
-> Getting (Endo Storage) (Map Addr Contract) Storage -> Storage
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! 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
self ((Contract -> Const (Endo Storage) Contract)
 -> Map Addr Contract -> Const (Endo Storage) (Map Addr Contract))
-> ((Storage -> Const (Endo Storage) Storage)
    -> Contract -> Const (Endo Storage) Contract)
-> Getting (Endo Storage) (Map Addr Contract) Storage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Storage -> Const (Endo Storage) Storage)
-> Contract -> Const (Endo Storage) Contract
Lens' Contract Storage
EVM.storage of
    Symbolic [(SymWord, SymWord)]
v SArray (WordN 256) (WordN 256)
_ -> [(SymWord, SymWord)]
v
    Concrete Map Word SymWord
x -> [(Word -> SymWord
litWord Word
k,SymWord
v) | (Word
k, SymWord
v) <- Map Word SymWord -> [(Word, SymWord)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Word SymWord
x]
  showResult :: [String]
showResult = [(?context::DappContext) => VMResult -> String
VMResult -> String
prettyvmresult VMResult
res | Just VMResult
res <- [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]]
  in [String]
showResult
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [(SymWord, SymWord)] -> [String]
showStorage [(SymWord, SymWord)]
updates
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
""]

showBranchInfoWithAbi :: DappInfo -> BranchInfo -> [String]
showBranchInfoWithAbi :: DappInfo -> BranchInfo -> [String]
showBranchInfoWithAbi DappInfo
_ (BranchInfo VM
_ Maybe Whiff
Nothing) = [String
""]
showBranchInfoWithAbi DappInfo
srcInfo (BranchInfo VM
vm (Just Whiff
y)) =
  case Whiff
y of
    (IsZero (Eq (Literal W256
x) Whiff
_)) ->
      let
        abimap :: Maybe (Map Word32 Method)
abimap = 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 -> Map Word32 Method)
-> Maybe SolcContract -> Maybe (Map Word32 Method)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DappInfo -> VM -> Maybe SolcContract
currentSolc DappInfo
srcInfo VM
vm
        method :: Maybe Method
method = Maybe (Map Word32 Method)
abimap Maybe (Map Word32 Method)
-> (Map Word32 Method -> Maybe Method) -> Maybe Method
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word32 -> Map Word32 Method -> Maybe Method
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (W256 -> Word32
forall a b. (Integral a, Num b) => a -> b
num W256
x)
      in [String -> (Method -> String) -> Maybe Method -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Whiff -> String
forall a. Show a => a -> String
show Whiff
y) (Text -> String
forall a. Show a => a -> String
show (Text -> String) -> (Method -> Text) -> Method -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Text Method Text -> Method -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Method Text
Lens' Method Text
methodSignature) Maybe Method
method]
    Whiff
y' -> [Whiff -> String
forall a. Show a => a -> String
show Whiff
y']

renderTree :: (a -> [String])
           -> (a -> [String])
           -> Tree a
           -> Tree [String]
renderTree :: (a -> [String]) -> (a -> [String]) -> Tree a -> Tree [String]
renderTree a -> [String]
showBranch a -> [String]
showLeaf (Node a
b []) = [String] -> Forest [String] -> Tree [String]
forall a. a -> Forest a -> Tree a
Node (a -> [String]
showBranch a
b [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ a -> [String]
showLeaf a
b) []
renderTree a -> [String]
showBranch a -> [String]
showLeaf (Node a
b [Tree a]
cs) = [String] -> Forest [String] -> Tree [String]
forall a. a -> Forest a -> Tree a
Node (a -> [String]
showBranch a
b) ((a -> [String]) -> (a -> [String]) -> Tree a -> Tree [String]
forall a.
(a -> [String]) -> (a -> [String]) -> Tree a -> Tree [String]
renderTree a -> [String]
showBranch a -> [String]
showLeaf (Tree a -> Tree [String]) -> [Tree a] -> Forest [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree a]
cs)