be more careful about shrinking by moving actions to the main thread

Author: MaximilianAlgehed

quickcheck-dynamic/src/Test/QuickCheck/ParallelActions.hs

@@ -1,6 +1,11 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
-module Test.QuickCheck.ParallelActions where
+module Test.QuickCheck.ParallelActions
+  ( RunModelPar(..)
+  , Forking(..)
+  , ParallelActions
+  , runParActions
+  ) where
 
 import Data.Set qualified as Set
 import Control.Monad
@@ -39,6 +44,12 @@ threadActions ParallelActions{linearActions = Actions steps, ..} =
   | thread <- threads
   ]
 
+firstParAction :: ParallelActions state -> Maybe Int
+firstParAction ParallelActions{..}
+  | null idxs = Nothing
+  | otherwise = Just $ minimum idxs
+  where idxs = concat threads
+
 instance StateModel state => Show (ParallelActions state) where
   show pas =
     unlines $ [ "-- Common Prefix:"
@@ -55,13 +66,13 @@ instance StateModel state => Show (ParallelActions state) where
 instance StateModel state => Arbitrary (ParallelActions state) where
   arbitrary = genParActions
 
-  shrink (ParallelActions actions trs) =
-    filter checkParallelActions $ [ ParallelActions actions $ filter (not . null) $ map (filter (`Set.member` vars)) trs
-                                  | actions <- shrink actions
-                                  , let vars = unsafeIndexSet $ allVariables actions
-                                  ] ++
-                                  [ ParallelActions actions $ trs ++ [ tr | not $ null tr ] ++ trs'
-                                  | (trs, _:tr, trs') <- holes' trs ]
+  shrink pas@(ParallelActions actions trs) =
+    [ ParallelActions actions $ map (filter (/= i)) trs | Just i <- [firstParAction pas]] ++
+    filter checkParallelActions
+      [ ParallelActions actions $ filter (not . null) $ map (filter (`Set.member` vars)) trs
+      | actions <- shrink actions
+      , let vars = unsafeIndexSet $ allVariables actions
+      ]
 
 checkParallelActions :: StateModel state => ParallelActions state -> Bool
 checkParallelActions pas = all (checkWellTypedness commonCtx) (threadActions pas)
@@ -151,7 +162,7 @@ runParActions pas = do
     monitor $ counterexample $ "\n-- Thread " ++ [n, ':']
     monitorTrace used env tr
   let ilvs = prepend trC $ interleavings trs
-  monitor $ tabulate "TraceTree size" (map (bucket . length) ilvs)
+  monitor $ tabulate "Trace tree size" (map (bucket . length) ilvs)
   assert $ null ilvs || any (checkTrace initialAnnotatedState mempty) ilvs
   -- TODO: stats collection and cleanup
 
@@ -204,10 +215,6 @@ holes :: [a] -> [(a, [a])]
 holes [] = []
 holes (a:as) = (a, as) : map (second (a:)) (holes as)
 
-holes' :: [a] -> [([a], a, [a])]
-holes' [] = []
-holes' (a:as) = ([], a, as) : [ (a:bs, a', as') | (bs, a', as') <- holes' as ]
-
 -- TODO:
 --  - More examples
 --  - Refactor normal QCD so that you don't have two implementations