the purge compiles...

Author: d-xo

cli/cli.hs

@@ -4,7 +4,7 @@ cradle:
       component: "lib:hevm"
     - path: "./bench"
       component: "bench"
-    - path: "./hevm-cli"
+    - path: "./cli"
       component: "exe:hevm"
     - path: "./test/test.hs"
       component: "test:test"

hie.yaml

@@ -37,6 +37,7 @@ module EVM.ABI
   , SolError (..)
   , Anonymity (..)
   , Indexed (..)
+  , Sig(..)
   , putAbi
   , getAbi
   , getAbiSeq
@@ -82,13 +83,17 @@ import Data.Vector (Vector, toList)
 import Data.Vector qualified as Vector
 import Data.Word (Word32)
 import GHC.Generics (Generic)
-
 import Test.QuickCheck hiding ((.&.), label)
+
 import Text.Megaparsec qualified as P
 import Text.Megaparsec.Char qualified as P
 import Text.ParserCombinators.ReadP
 import Witch (unsafeInto, into)
 
+-- | A method name, and the (ordered) types of it's arguments
+data Sig = Sig Text [AbiType]
+  deriving (Show, Eq)
+
 data AbiValue
   = AbiUInt         Int Word256
   | AbiInt          Int Int256
@@ -410,80 +415,6 @@ getBytesWith256BitPadding i =
     <* skip ((roundTo32Bytes n) - n)
   where n = fromIntegral i
 
--- QuickCheck instances
-
-genAbiValue :: AbiType -> Gen AbiValue
-genAbiValue = \case
-   AbiUIntType n -> AbiUInt n <$> genUInt n
-   AbiIntType n -> do
-     x <- genUInt n
-     pure $ AbiInt n (signedWord (x - 2^(n-1)))
-   AbiAddressType ->
-     AbiAddress . fromIntegral <$> genUInt 20
-   AbiBoolType ->
-     elements [AbiBool False, AbiBool True]
-   AbiBytesType n ->
-     do xs <- replicateM n arbitrary
-        pure (AbiBytes n (BS.pack xs))
-   AbiBytesDynamicType ->
-     AbiBytesDynamic . BS.pack <$> listOf arbitrary
-   AbiStringType ->
-     AbiString . BS.pack <$> listOf arbitrary
-   AbiArrayDynamicType t ->
-     do xs <- listOf1 (scale (`div` 2) (genAbiValue t))
-        pure (AbiArrayDynamic t (Vector.fromList xs))
-   AbiArrayType n t ->
-     AbiArray n t . Vector.fromList <$>
-       replicateM n (scale (`div` 2) (genAbiValue t))
-   AbiTupleType ts ->
-     AbiTuple <$> mapM genAbiValue ts
-   AbiFunctionType ->
-     do xs <- replicateM 24 arbitrary
-        pure (AbiFunction (BS.pack xs))
-  where
-    genUInt :: Int -> Gen Word256
-    genUInt n = arbitraryIntegralWithMax (2^n-1) :: Gen Word256
-
-instance Arbitrary AbiType where
-  arbitrary = oneof
-    [ (AbiUIntType . (* 8)) <$> choose (1, 32)
-    , (AbiIntType . (* 8)) <$> choose (1, 32)
-    , pure AbiAddressType
-    , pure AbiBoolType
-    , AbiBytesType <$> choose (1,32)
-    , pure AbiBytesDynamicType
-    , pure AbiStringType
-    , AbiArrayDynamicType <$> scale (`div` 2) arbitrary
-    , AbiArrayType
-        <$> (getPositive <$> arbitrary)
-        <*> scale (`div` 2) arbitrary
-    ]
-
-instance Arbitrary AbiValue where
-  arbitrary = arbitrary >>= genAbiValue
-  shrink = \case
-    AbiArrayDynamic t v ->
-      Vector.toList v ++
-        map (AbiArrayDynamic t . Vector.fromList)
-            (shrinkList shrink (Vector.toList v))
-    AbiBytesDynamic b -> AbiBytesDynamic . BS.pack <$> shrinkList shrinkIntegral (BS.unpack b)
-    AbiString b -> AbiString . BS.pack <$> shrinkList shrinkIntegral (BS.unpack b)
-    AbiBytes n a | n <= 32 -> shrink $ AbiUInt (n * 8) (word256 a)
-    --bytesN for N > 32 don't really exist right now anyway..
-    AbiBytes _ _ | otherwise -> []
-    AbiArray _ t v ->
-      Vector.toList v ++
-        map (\x -> AbiArray (length x) t (Vector.fromList x))
-            (shrinkList shrink (Vector.toList v))
-    AbiTuple v -> Vector.toList $ AbiTuple . Vector.fromList . shrink <$> v
-    AbiUInt n a -> AbiUInt n <$> (shrinkIntegral a)
-    AbiInt n a -> AbiInt n <$> (shrinkIntegral a)
-    AbiBool b -> AbiBool <$> shrink b
-    AbiAddress a -> [AbiAddress 0xacab, AbiAddress 0xdeadbeef, AbiAddress 0xbabeface]
-      <> (AbiAddress <$> shrinkIntegral a)
-    AbiFunction b -> shrink $ AbiBytes 24 b
-
-
 -- Bool synonym with custom read instance
 -- to be able to parse lower case 'false' and 'true'
 newtype Boolz = Boolz Bool
@@ -572,3 +503,93 @@ decodeBuf tps buf
 decodeStaticArgs :: Int -> Int -> Expr Buf -> [Expr EWord]
 decodeStaticArgs offset numArgs b =
   [readWord (Lit . unsafeInto $ i) b | i <- [offset,(offset+32) .. (offset + (numArgs-1)*32)]]
+
+-- QuickCheck instances
+
+genAbiValue :: AbiType -> Gen AbiValue
+genAbiValue = \case
+   AbiUIntType n -> AbiUInt n <$> genUInt n
+   AbiIntType n -> do
+     x <- genUInt n
+     pure $ AbiInt n (signedWord (x - 2^(n-1)))
+   AbiAddressType ->
+     AbiAddress . fromIntegral <$> genUInt 20
+   AbiBoolType ->
+     elements [AbiBool False, AbiBool True]
+   AbiBytesType n ->
+     do xs <- replicateM n arbitrary
+        pure (AbiBytes n (BS.pack xs))
+   AbiBytesDynamicType ->
+     AbiBytesDynamic . BS.pack <$> listOf arbitrary
+   AbiStringType ->
+     AbiString . BS.pack <$> listOf arbitrary
+   AbiArrayDynamicType t ->
+     do xs <- listOf1 (scale (`div` 2) (genAbiValue t))
+        pure (AbiArrayDynamic t (Vector.fromList xs))
+   AbiArrayType n t ->
+     AbiArray n t . Vector.fromList <$>
+       replicateM n (scale (`div` 2) (genAbiValue t))
+   AbiTupleType ts ->
+     AbiTuple <$> mapM genAbiValue ts
+   AbiFunctionType ->
+     do xs <- replicateM 24 arbitrary
+        pure (AbiFunction (BS.pack xs))
+  where
+    genUInt :: Int -> Gen Word256
+    genUInt n = arbitraryIntegralWithMax (2^n-1) :: Gen Word256
+
+instance Arbitrary AbiType where
+  arbitrary = oneof
+    [ (AbiUIntType . (* 8)) <$> choose (1, 32)
+    , (AbiIntType . (* 8)) <$> choose (1, 32)
+    , pure AbiAddressType
+    , pure AbiBoolType
+    , AbiBytesType <$> choose (1,32)
+    , pure AbiBytesDynamicType
+    , pure AbiStringType
+    , AbiArrayDynamicType <$> scale (`div` 2) arbitrary
+    , AbiArrayType
+        <$> (getPositive <$> arbitrary)
+        <*> scale (`div` 2) arbitrary
+    ]
+
+instance Arbitrary AbiValue where
+  arbitrary = arbitrary >>= genAbiValue
+  shrink = \case
+    AbiArrayDynamic t v ->
+      Vector.toList v ++
+        map (AbiArrayDynamic t . Vector.fromList)
+            (shrinkList shrink (Vector.toList v))
+    AbiBytesDynamic b -> AbiBytesDynamic . BS.pack <$> shrinkList shrinkIntegral (BS.unpack b)
+    AbiString b -> AbiString . BS.pack <$> shrinkList shrinkIntegral (BS.unpack b)
+    AbiBytes n a | n <= 32 -> shrink $ AbiUInt (n * 8) (word256 a)
+    --bytesN for N > 32 don't really exist right now anyway..
+    AbiBytes _ _ | otherwise -> []
+    AbiArray _ t v ->
+      Vector.toList v ++
+        map (\x -> AbiArray (length x) t (Vector.fromList x))
+            (shrinkList shrink (Vector.toList v))
+    AbiTuple v -> Vector.toList $ AbiTuple . Vector.fromList . shrink <$> v
+    AbiUInt n a -> AbiUInt n <$> (shrinkIntegral a)
+    AbiInt n a -> AbiInt n <$> (shrinkIntegral a)
+    AbiBool b -> AbiBool <$> shrink b
+    AbiAddress a -> [AbiAddress 0xacab, AbiAddress 0xdeadbeef, AbiAddress 0xbabeface]
+      <> (AbiAddress <$> shrinkIntegral a)
+    AbiFunction b -> shrink $ AbiBytes 24 b
+
+-- A modification of 'arbitrarySizedBoundedIntegral' quickcheck library
+-- which takes the maxbound explicitly rather than relying on a Bounded instance.
+-- Essentially a mix between three types of generators:
+-- one that strongly prefers values close to 0, one that prefers values close to max
+-- and one that chooses uniformly.
+arbitraryIntegralWithMax :: (Integral a) => Integer -> Gen a
+arbitraryIntegralWithMax maxbound =
+  sized $ \s ->
+    do let mn = 0 :: Int
+           mx = maxbound
+           bits n | n `quot` 2 == 0 = 0
+                  | otherwise = 1 + bits (n `quot` 2)
+           k  = 2^(s*(bits mn `max` bits mx `max` 40) `div` 100)
+       smol <- choose (toInteger mn `max` (-k), toInteger mx `min` k)
+       mid <- choose (0, maxbound)
+       elements [fromIntegral smol, fromIntegral mid, fromIntegral (maxbound - (fromIntegral smol))]

src/EVM/ABI.hs

@@ -7,15 +7,15 @@ import EVM.Types
 
 import Control.Arrow ((>>>))
 import Data.Aeson (Value)
-import Data.Bifunctor (first, second)
+import Data.Bifunctor (second)
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
 import Data.List (find, sort)
 import Data.Map (Map)
 import Data.Map qualified as Map
-import Data.Maybe (isJust, fromJust, mapMaybe)
+import Data.Maybe (mapMaybe)
 import Data.Sequence qualified as Seq
-import Data.Text (Text, isPrefixOf, pack, unpack)
+import Data.Text (Text, isPrefixOf, pack)
 import Data.Text.Encoding (encodeUtf8)
 import Data.Vector qualified as V
 import Optics.Core
@@ -27,7 +27,7 @@ data DappInfo = DappInfo
   , solcByHash :: Map W256 (CodeType, SolcContract)
   , solcByCode :: [(Code, SolcContract)] -- for contracts with `immutable` vars.
   , sources    :: SourceCache
-  , unitTests  :: [(Text, [(Test, [AbiType])])]
+  , unitTests  :: [(Text, [Sig])]
   , abiMap     :: Map FunctionSelector Method
   , eventMap   :: Map W256 Event
   , errorMap   :: Map W256 SolError
@@ -47,11 +47,6 @@ data DappContext = DappContext
   , env  :: Map Addr Contract
   }
 
-data Test = ConcreteTest Text | SymbolicTest Text | InvariantTest Text
-
-instance Show Test where
-  show t = unpack $ extractSig t
-
 dappInfo :: FilePath -> BuildOutput -> DappInfo
 dappInfo root (BuildOutput (Contracts cs) sources) =
   let
@@ -87,29 +82,28 @@ emptyDapp :: DappInfo
 emptyDapp = dappInfo "" mempty
 
 -- Dapp unit tests are detected by searching within abi methods
--- that begin with "test" or "prove", that are in a contract with
+-- that begin with "check" or "prove", that are in a contract with
 -- the "IS_TEST()" abi marker, for a given regular expression.
 --
 -- The regex is matched on the full test method name, including path
 -- and contract, i.e. "path/to/file.sol:TestContract.test_name()".
---
--- Tests beginning with "test" are interpreted as concrete tests, whereas
--- tests beginning with "prove" are interpreted as symbolic tests.
 
 unitTestMarkerAbi :: FunctionSelector
 unitTestMarkerAbi = abiKeccak (encodeUtf8 "IS_TEST()")
 
-findAllUnitTests :: [SolcContract] -> [(Text, [(Test, [AbiType])])]
-findAllUnitTests = findUnitTests ".*:.*\\.(test|prove|invariant).*"
+findAllUnitTests :: [SolcContract] -> [(Text, [Sig])]
+findAllUnitTests = findUnitTests ".*:.*\\.(check|prove).*"
 
-mkTest :: Text -> Maybe Test
-mkTest sig
-  | "test" `isPrefixOf` sig = Just (ConcreteTest sig)
-  | "prove" `isPrefixOf` sig = Just (SymbolicTest sig)
-  | "invariant" `isPrefixOf` sig = Just (InvariantTest sig)
+mkSig :: Method -> Maybe Sig
+mkSig method
+  | "prove" `isPrefixOf` testname = Just (Sig testname argtypes)
+  | "check" `isPrefixOf` testname = Just (Sig testname argtypes)
   | otherwise = Nothing
+  where
+    testname = method.methodSignature
+    argtypes = snd <$> method.inputs
 
-findUnitTests :: Text -> ([SolcContract] -> [(Text, [(Test, [AbiType])])])
+findUnitTests :: Text -> ([SolcContract] -> [(Text, [Sig])])
 findUnitTests match =
   concatMap $ \c ->
     case Map.lookup unitTestMarkerAbi c.abiMap of
@@ -118,25 +112,16 @@ findUnitTests match =
         let testNames = unitTestMethodsFiltered (regexMatches match) c
         in [(c.contractName, testNames) | not (BS.null c.runtimeCode) && not (null testNames)]
 
-unitTestMethodsFiltered :: (Text -> Bool) -> (SolcContract -> [(Test, [AbiType])])
+unitTestMethodsFiltered :: (Text -> Bool) -> (SolcContract -> [Sig])
 unitTestMethodsFiltered matcher c =
-  let
-    testName method = c.contractName <> "." <> (extractSig (fst method))
-  in
-    filter (matcher . testName) (unitTestMethods c)
+  let testName (Sig n _) = c.contractName <> "." <> n
+  in filter (matcher . testName) (unitTestMethods c)
 
-unitTestMethods :: SolcContract -> [(Test, [AbiType])]
+unitTestMethods :: SolcContract -> [Sig]
 unitTestMethods =
   (.abiMap)
   >>> Map.elems
-  >>> map (\f -> (mkTest f.methodSignature, snd <$> f.inputs))
-  >>> filter (isJust . fst)
-  >>> fmap (first fromJust)
-
-extractSig :: Test -> Text
-extractSig (ConcreteTest sig) = sig
-extractSig (SymbolicTest sig) = sig
-extractSig (InvariantTest sig) = sig
+  >>> mapMaybe mkSig
 
 traceSrcMap :: DappInfo -> Trace -> Maybe SrcMap
 traceSrcMap dapp trace = srcMap dapp trace.contract trace.opIx

src/EVM/Dapp.hs

@@ -40,17 +40,14 @@ import EVM.Stepper qualified as Stepper
 import EVM.Traversals
 import EVM.Types
 import EVM.Concrete (createAddress)
-import EVM.FeeSchedule qualified as FeeSchedule
+import EVM.FeeSchedule (feeSchedule)
 import EVM.Format (indent, formatBinary)
 import GHC.Conc (getNumProcessors)
 import GHC.Generics (Generic)
 import Optics.Core
 import Options.Generic (ParseField, ParseFields, ParseRecord)
 import Witch (into, unsafeInto)
 
--- | A method name, and the (ordered) types of it's arguments
-data Sig = Sig Text [AbiType]
-
 data LoopHeuristic
   = Naive
   | StackBased
@@ -233,7 +230,7 @@ loadSymVM x initStore addr callvalue cd create =
     , baseFee = 0
     , priorityFee = 0
     , maxCodeSize = 0xffffffff
-    , schedule = FeeSchedule.berlin
+    , schedule = feeSchedule
     , chainId = 1
     , create = create
     , txAccessList = mempty