Fix and reorganize shrinking

lib/Echidna/ABI.hs

@@ -267,7 +267,9 @@ canShrinkAbiValue = \case
   _                   -> True
 
 shrinkInt :: (Integral a, MonadRandom m) => a -> m a
-shrinkInt x = fromIntegral <$> getRandomR (0, toInteger x)
+shrinkInt x = fromIntegral <$> getRandomR range
+  where range | x >= 0 = (0, toInteger x)
+              | otherwise = (toInteger x, 0)
 
 -- | Given an 'AbiValue', generate a random \"smaller\" (simpler) value of the same 'AbiType'.
 shrinkAbiValue :: MonadRandom m => AbiValue -> m AbiValue

lib/Echidna/Shrink.hs

@@ -1,8 +1,7 @@
 module Echidna.Shrink (shrinkTest) where
 
-import Control.Monad ((<=<))
 import Control.Monad.Catch (MonadThrow)
-import Control.Monad.Random.Strict (MonadRandom, getRandomR, uniform)
+import Control.Monad.Random.Strict (MonadRandom, uniform, weighted)
 import Control.Monad.Reader.Class (MonadReader (ask), asks)
 import Control.Monad.State.Strict (MonadIO)
 import Control.Monad.ST (RealWorld)
@@ -96,8 +95,8 @@ shrinkSeq
   -> [Tx]
   -> m (Maybe ([Tx], TestValue, VM Concrete RealWorld))
 shrinkSeq vm f v txs = do
-  -- apply one of the two possible simplification strategies (shrunk or shorten) with equal probability
-  txs' <- uniform =<< sequence [shorten, shrunk]
+  -- apply the simplification strategy
+  txs' <- shrunk
   -- remove certain type of "no calls"
   let txs'' = removeUselessNoCalls txs'
   -- check if the sequence still triggers a failed transaction
@@ -113,11 +112,25 @@ shrinkSeq vm f v txs = do
     check (x:xs') vm' = do
       (_, vm'') <- execTx vm' x
       check xs' vm''
-    -- | Simplify a sequence of transactions reducing the complexity of its arguments (using shrinkTx)
-    -- and then reducing its sender (using shrinkSender)
-    shrunk = mapM (shrinkSender <=< shrinkTx) txs
-    -- | Simplifiy a sequence of transactions randomly dropping one transaction (with uniform selection)
-    shorten = (\i -> take i txs ++ drop (i + 1) txs) <$> getRandomR (0, length txs)
+    -- maybe shrink a NoCall (delay) with a simplified strategy
+    maybeShrink tx@Tx{call = NoCall} = do
+      tool <- weighted [
+          (shrinkDelay,         6), -- 60% try to reduce or remove delay
+          (pure,                4)  -- 40% do nothing
+        ]
+      tool tx
+    -- maybe shrink other types of transactions
+    maybeShrink tx = do
+      tool <- weighted [
+          (shrinkSender,              10), --  5% shrink sender
+          (shrinkTx,                  70), -- 35% shrink args, value, gas price, delay or (rarely) remove
+          (pure . removeCallTx,       60), -- 30% remove
+          (pure,                      60)  -- 30% do nothing
+        ]
+      tool tx
+    -- | Simplify a sequence of transactions sometimes reducing the complexity
+    -- of its arguments (using shrinkTx) and the sender (using shrinkSender)
+    shrunk = mapM maybeShrink txs
 
 -- | Given a transaction, replace the sender of the transaction by another one
 -- which is simpler (e.g. it is closer to zero). Usually this means that

lib/Echidna/Transaction.hs

@@ -120,6 +120,19 @@ canShrinkTx _ = True
 removeCallTx :: Tx -> Tx
 removeCallTx t = Tx NoCall t.src t.dst 0 0 0 t.delay
 
+shrinkDelay :: MonadRandom m => Tx -> m Tx
+shrinkDelay tx = do
+  let
+    (time, blocks) = tx.delay
+    lower 0 = pure 0
+    lower x = getRandomR (0 :: Integer, fromIntegral x)
+                >>= (\r -> uniform [0, r]) . fromIntegral -- try 0 quicker
+  delay' <- join $ uniform [ (time,) <$> lower blocks
+                          , (,blocks) <$> lower time
+                          , (,) <$> lower time <*> lower blocks
+                          ]
+  pure tx { delay = level delay' }
+
 -- | Given a 'Transaction', generate a random \"smaller\" 'Transaction', preserving origin,
 -- destination, value, and call signature.
 shrinkTx :: MonadRandom m => Tx -> m Tx
@@ -138,12 +151,7 @@ shrinkTx tx =
            pure tx { Echidna.Types.Tx.value = value' }
       , do gasprice' <- lower tx.gasprice
            pure tx { Echidna.Types.Tx.gasprice = gasprice' }
-      , do let (time, blocks) = tx.delay
-           delay' <- join $ uniform [ (time,) <$> lower blocks
-                                    , (,blocks) <$> lower time
-                                    , (,) <$> lower time <*> lower blocks
-                                    ]
-           pure tx { delay = level delay' }
+      , shrinkDelay tx
       ]
   in join $ usuallyRarely (join (uniform possibilities)) (pure $ removeCallTx tx)
 

src/test/Common.hs

@@ -67,7 +67,7 @@ overrideQuiet conf =
 overrideLimits :: EConfig -> EConfig
 overrideLimits conf =
   conf { campaignConf = conf.campaignConf { testLimit = 10000
-                                          , shrinkLimit = 4000 }}
+                                          , shrinkLimit = 10000 }}
 
 type SolcVersion = Version
 type SolcVersionComp = Version -> Bool