{-# 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 signed :: Signedness
signed (W256 w :: Word256
w) =
  let
    i :: Integer
i = case Signedness
signed of
          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)
          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 "<hevm cheat address>"
    else if (Integer
i :: Integer) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 2 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (256 :: Integer) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 1
    then "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 _ (W256 w :: 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 w :: W256
w _ | W256
w W256 -> W256 -> Bool
forall a. Ord a => a -> a -> Bool
> 0xffffffff = Signedness -> W256 -> Text
showDec Signedness
Unsigned W256
w
showWordExplanation w :: W256
w dapp :: 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
    Nothing -> Signedness -> W256 -> Text
showDec Signedness
Unsigned W256
w
    Just x :: Method
x  -> "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
<> "\")"

humanizeInteger :: (Num a, Integral a, Show a) => a -> Text
humanizeInteger :: a -> Text
humanizeInteger =
  Text -> [Text] -> Text
Text.intercalate ","
  ([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 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 _ bs :: ByteString
bs) =
  ByteString -> Text
formatBytes ByteString
bs  -- opportunistically decodes recognisable strings
showAbiValue (AbiAddress addr :: 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 ((Env -> Const (Map Addr Contract) Env)
-> DappContext -> Const (Map Addr Contract) DappContext
Lens' DappContext Env
contextEnv ((Env -> Const (Map Addr Contract) Env)
 -> DappContext -> Const (Map Addr Contract) DappContext)
-> ((Map Addr Contract
     -> Const (Map Addr Contract) (Map Addr Contract))
    -> Env -> Const (Map Addr Contract) Env)
-> Getting (Map Addr Contract) DappContext (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) ?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
        Nothing -> ""
        Just contract :: 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
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 v :: 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 vs :: 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 vs :: 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 ts :: [AbiType]
ts (SymbolicBuffer  _) = [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 ts :: [AbiType]
ts (ConcreteBuffer bs :: 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 (_, _, xs :: Vector AbiValue
xs) -> (?context::DappContext) => Vector AbiValue -> [Text]
Vector AbiValue -> [Text]
textAbiValues Vector AbiValue
xs
    Left (_, _, _)   -> [ByteString -> Text
formatBinary ByteString
bs]

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

showValues :: (?context :: DappContext) => [AbiType] -> Buffer -> Text
showValues :: [AbiType] -> Buffer -> Text
showValues ts :: [AbiType]
ts b :: 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 t :: AbiType
t b :: 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 ts :: [AbiType]
ts (SymbolicBuffer bs :: [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 4 [SWord 8]
bs)
showCall ts :: [AbiType]
ts (ConcreteBuffer bs :: 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 4 ByteString
bs)

showError :: (?context :: DappContext) => ByteString -> Text
showError :: ByteString -> Text
showError bs :: ByteString
bs = case Int -> ByteString -> ByteString
BS.take 4 ByteString
bs of
  -- Method ID for Error(string)
  "\b\195y\160" -> (?context::DappContext) => [AbiType] -> Buffer -> Text
[AbiType] -> Buffer -> Text
showCall [AbiType
AbiStringType] (ByteString -> Buffer
ConcreteBuffer ByteString
bs)
  _             -> 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 (\c :: 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 b :: ByteString
b =
  let (s :: ByteString
s, _) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.spanEnd (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 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 b :: [SWord 8]
b) = "<" 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
<> " symbolic bytes>"
formatSBytes (ConcreteBuffer b :: ByteString
b) = ByteString -> Text
formatBytes ByteString
b

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

formatSString :: Buffer -> Text
formatSString :: Buffer -> Text
formatSString (SymbolicBuffer bs :: [SWord 8]
bs) = "<" 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
<> " symbolic bytes (string)>"
formatSString (ConcreteBuffer bs :: 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
(<>) "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 bs :: [SWord 8]
bs) = "<" 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
<> " symbolic bytes>"
formatSBinary (ConcreteBuffer bs :: ByteString
bs) = ByteString -> Text
formatBinary ByteString
bs

showTraceTree :: DappInfo -> VM -> Text
showTraceTree :: DappInfo -> VM -> Text
showTraceTree dapp :: DappInfo
dapp vm :: 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 ts :: [(AbiType, Indexed)]
ts = [AbiType
t | (t :: AbiType
t, NotIndexed) <- [(AbiType, Indexed)]
ts]

showTrace :: DappInfo -> VM -> Trace -> Text
showTrace :: DappInfo -> VM -> Trace -> Text
showTrace dapp :: DappInfo
dapp vm :: VM
vm trace :: Trace
trace =
  let ?context = DappContext { _contextInfo = dapp, _contextEnv = vm ^?! EVM.env }
  in let
    pos :: Text
pos =
      case DappInfo -> Trace -> Either Text Text
showTraceLocation DappInfo
dapp Trace
trace of
        Left x :: Text
x -> " \x1b[1m" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\x1b[0m"
        Right x :: Text
x -> " \x1b[1m(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")\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 _ bytes :: Buffer
bytes topics :: [SymWord]
topics) ->
      let logn :: Text
logn = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ "\x1b[36m"
            , "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])
            , "\x1b[0m"
            ] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos
          knownTopic :: Text -> [(AbiType, Indexed)] -> Text
knownTopic name :: Text
name types :: [(AbiType, Indexed)]
types = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ "\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
            , "\x1b[0m"
            ] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos
          lognote :: Text -> Text -> Text
lognote sig :: Text
sig usr :: Text
usr = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ "\x1b[36m"
            , "LogNote"
            , [Text] -> Text
parenthesise [Text
sig, Text
usr, "..."]
            , "\x1b[0m"
            ] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos
      in case [SymWord]
topics of
        [] ->
          Text
logn
        (t1 :: SymWord
t1:_) ->
          case SymWord -> Maybe Word
maybeLitWord SymWord
t1 of
            Just topic :: 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 name :: Text
name _ types :: [(AbiType, Indexed)]
types) ->
                  Text -> [(AbiType, Indexed)] -> Text
knownTopic Text
name [(AbiType, Indexed)]
types
                Nothing ->
                  case [SymWord]
topics of
                    [_, t2 :: SymWord
t2, _, _] ->
                      -- 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) 224 :: Word32
                        usr :: Text
usr = case SymWord -> Maybe Word
maybeLitWord SymWord
t2 of
                          Just w :: 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)
                          Nothing  ->
                            "<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 m :: 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
                          Nothing ->
                            Text
logn
                    _ ->
                      Text
logn
            Nothing ->
              Text
logn

    QueryTrace q :: Query
q ->
      case Query
q of
        PleaseFetchContract addr :: Addr
addr _ _ ->
          "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
addr slot :: Word
slot _ ->
          "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
<> " 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 _ _ _ ->
          "ask smt" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos
        PleaseMakeUnique _ _ _ ->
          "make unique value" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos

    ErrorTrace e :: Error
e ->
      case Error
e of
        Revert out :: ByteString
out ->
          "\x1b[91merror\x1b[0m " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "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
        _ ->
          "\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 out :: Buffer
out (CallContext _ _ _ _ _ (Just abi :: Word
abi) _ _ _) ->
      "← " 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 m :: 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
              (_, ts :: [AbiType]
ts) ->
                (?context::DappContext) => [AbiType] -> Buffer -> Text
[AbiType] -> Buffer -> Text
showValues [AbiType]
ts Buffer
out
          Nothing ->
            Buffer -> Text
formatSBinary Buffer
out
    ReturnTrace out :: Buffer
out (CallContext {}) ->
      "← " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Buffer -> Text
formatSBinary Buffer
out
    ReturnTrace out :: Buffer
out (CreationContext {}) ->
      "← " 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
<> " bytes of code"

    EntryTrace t :: Text
t ->
      Text
t
    FrameTrace (CreationContext addr :: Addr
addr hash :: W256
hash _ _ ) ->
      "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
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 target :: Addr
target context :: Addr
context _ _ hash :: W256
hash abi :: Maybe Word
abi calldata :: Buffer
calldata _ _) ->
      let calltype :: Text
calltype = if Addr
target Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
context
                     then "call "
                     else "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
        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 "::"
            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 0x00 Maybe Word
abi)) Map Word32 Method
fullAbiMap of
                 Just m :: Method
m  ->
                   "\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
<> "\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
                 Nothing ->
                   Buffer -> Text
formatSBinary Buffer
calldata
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos

        Just solc :: SolcContract
solc ->
          Text
calltype
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\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
forall a. Semigroup a => a -> a -> a
<> Text -> (Word -> Text) -> Maybe Word -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "[fallback function]"
                 (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "[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
forall a. Semigroup a => a -> a -> a
<> Buffer -> Text
formatSBinary Buffer
calldata Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")")
                 (\x :: [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
<> "\x1b[0m"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pos

getAbiTypes :: Text -> [Maybe AbiType]
getAbiTypes :: Text -> [Maybe AbiType]
getAbiTypes abi :: 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]
forall a b. (a -> b) -> a -> b
$
        Text -> Text -> [Text]
splitOn "," (Int -> Text -> Text
dropEnd 1 ([Text] -> Text
forall a. [a] -> a
last (Text -> Text -> [Text]
splitOn "(" 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 "<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 "" (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 solc :: SolcContract
solc abi :: 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 x :: Text
x = (Char -> Bool) -> Text -> [Text]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ':') Text
x [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! 1

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

prettyvmresult :: (?context :: DappContext) => VMResult -> String
prettyvmresult :: VMResult -> String
prettyvmresult (EVM.VMFailure (EVM.Revert ""))  = "Revert"
prettyvmresult (EVM.VMFailure (EVM.Revert msg :: ByteString
msg)) = "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 254)) = "Assertion violation"
prettyvmresult (EVM.VMFailure err :: Error
err) = "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 msg :: ByteString
msg)) =
  if ByteString -> Bool
BS.null ByteString
msg
  then "Stop"
  else "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 msg :: [SWord 8]
msg)) =
  "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
<> " symbolic bytes"

currentSolc :: DappInfo -> VM -> Maybe SolcContract
currentSolc :: DappInfo -> VM -> Maybe SolcContract
currentSolc dapp :: DappInfo
dapp vm :: 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 True  True  = "\x2514" -- └
showTreeIndentSymbol False True  = "\x251c" -- ├
showTreeIndentSymbol True  False = " "
showTreeIndentSymbol False False = "\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 _ _ (Node [] _)  = []

flattenTree totalCases :: Int
totalCases i :: Int
i (Node (x :: String
x:xs :: [String]
xs) cs :: Forest [String]
cs) = let
  isLastCase :: Bool
isLastCase       = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 -> 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
<> " "
  indentchild :: String
indentchild      = Bool -> Bool -> String
showTreeIndentSymbol Bool
isLastCase Bool
False String -> ShowS
forall a. Semigroup a => a -> a -> a
<> " "
  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 :: 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)) [0..] Forest [String]
forest

leftpad :: Int -> String -> String
leftpad :: Int -> ShowS
leftpad n :: 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 ' '

showTree' :: Tree [String] -> String
showTree' :: Tree [String] -> String
showTree' (Node s :: [String]
s []) = [String] -> String
unlines [String]
s
showTree' (Node _ children :: Forest [String]
children) =
  let
    treeLines :: [TreeLine]
treeLines = Forest [String] -> [TreeLine]
flattenForest Forest [String]
children
    maxIndent :: Int
maxIndent = 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 colIndent :: String
colIndent colContent :: 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 (\(k :: SymWord
k, v :: SymWord
v) -> SymWord -> String
forall a. Show a => a -> String
show SymWord
k String -> ShowS
forall a. Semigroup a => a -> a -> a
<> " => " 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 srcInfo :: DappInfo
srcInfo (BranchInfo vm :: VM
vm _) = let
  ?context = DappContext { _contextInfo = srcInfo, _contextEnv = vm ^?! EVM.env }
  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 v :: [(SymWord, SymWord)]
v _ -> [(SymWord, SymWord)]
v
    Concrete x :: Map Word SymWord
x -> [(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
x]
  showResult :: [String]
showResult = [(?context::DappContext) => VMResult -> String
VMResult -> String
prettyvmresult VMResult
res | Just res :: 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]
++ [""]

showBranchInfoWithAbi :: DappInfo -> BranchInfo -> [String]
showBranchInfoWithAbi :: DappInfo -> BranchInfo -> [String]
showBranchInfoWithAbi _ (BranchInfo _ Nothing) = [""]
showBranchInfoWithAbi srcInfo :: DappInfo
srcInfo (BranchInfo vm :: VM
vm (Just y :: Whiff
y)) =
  case Whiff
y of
    (IsZero (Eq (Literal x :: W256
x) _)) ->
      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]
    y' :: 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 showBranch :: a -> [String]
showBranch showLeaf :: a -> [String]
showLeaf (Node b :: 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 showBranch :: a -> [String]
showBranch showLeaf :: a -> [String]
showLeaf (Node b :: a
b cs :: Forest 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]) -> Forest a -> Forest [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Forest a
cs)