Multicore support

QuickCheck.cabal

@@ -102,7 +102,6 @@ library
     Test.QuickCheck.Test,
     Test.QuickCheck.Text,
     Test.QuickCheck.Poly,
-    Test.QuickCheck.State,
     Test.QuickCheck.Random,
     Test.QuickCheck.Exception,
     Test.QuickCheck.Features

README

@@ -1,3 +1,36 @@
+Roberts fork: this fork contains experimental support for running tests in parallel, and shrinking in parallel.
+Only the internal evaluation of a property is changed, so the API of QC remains unchanged. There is a module
+`Test.QuickCheck.Features` which I've completely commented out for now, so that will obviously not work.
+
+In order to try this out yourself, you must follow three steps:
+
+1: You need to make sure cabal knows where my fork of QC exists. You do this by either cloning this repository onto your local machine and pointing your `cabal.project` to it.
+You do this e.g. by adding the line `packages: *.cabal <path-to-qc>/QuickCheck.cabal`. You can also optionally point your cabal to this remote repository. You do this by
+editing your `cabal.project` to say
+```
+source-repository-package
+    type: git
+    location: https://github.com/Rewbert/quickcheck.git
+    -- optionally also add this to point to a particular commit, otherwise you will always get the freshest master commit
+    -- tag: <commit hash of the version you want>
+```
+
+2: You need to add some flags when you compile your code. Specifically, `-threaded -feager-blackholing -rtsopts`.
+
+3: Finally, all that is left is to change the call to `quickCheck` with a call to `quickCheckPar`. If you don't want parallel shrinking, you should call `quickCheckParWith (stdArgs { parallelShrinking = False}) property`.
+
+4: You also need to pass in the runtime option that actually creates more HECs. You need to either instead of `cabal run executable` do `cabal run executable -- +RTS -N` or `-Nx` where x is a number between 1 and the number of cores you have. You can also ddd another compilation option `-with-rtsopts=-N` or `-with-rtsopts=-Nx`
+
+As a sanity check of whether you are using my fork or not, if you run `quickCheckPar` with just 1 HEC available, the word `donkey` will be printed.
+
+
+
+
+
+
+
+
+
 This is QuickCheck 2, a library for random testing of program properties.
 
 Add `QuickCheck` to your package dependencies to use it in tests or REPL.

src/Test/QuickCheck.hs

@@ -51,6 +51,56 @@ module Test.QuickCheck
   , verboseCheckWith
   , verboseCheckWithResult
   , verboseCheckResult
+    -- ** Running tests in parallel
+    {- | After intense labour by Lord Robert von Krook Af Göhteborgh, the internal
+    testing loop can be instructed to run tests in parallel. Note. Not running properties
+    in parallel, but the tests of a property.
+
+    As an example, running the property above with 4 HECs
+
+@
+quickCheckPar $ withMaxSuccess 10000 prop_reverse
++++ OK, passed 10000 tests                                
+  tester 0: 2693 tests
+  tester 1: 2514 tests
+  tester 2: 2503 tests
+  tester 3: 2290 tests
+@
+
+    To make use of this functionality, GHC needs the options @-threaded@ and @-rtsopts@.
+    Furthermore, the runtime options need to specify that more HECs should be used, with
+    the @-with-rtsopts=-N@ flag. You could optionally specify exactly how many HECs to
+    use, e.g @-with-rtsopts=-N4@. This is where the API fetches the number of parallel
+    workers to launch. It will be equal to however many you instruct the RTS to use.
+    I've found @-feager-blackholing@ to benefit parallel Haskell before.
+
+    Example of an options section in a cabal file
+
+@
+ghc-options:
+  -threaded
+  -rtsopts
+  -feager-blackholing
+  -with-rtsopts=-N4
+@
+
+    The parallelism is implemented using @Control.Concurrent@ and @forkIO@. Instead of
+    running one sequential test loop, quickCheck will spawn n sequential test loops
+    with @forkIO@. The threads are all assigned an equal share of the desired number of
+    tests to run, but by default attempt to steal the right to run more tests from
+    sibling threads if they run out. Please see `rightToWorkSteal`.
+
+    The functions below behave the same as their non-parallel counterparts, with the
+    exception that they ask the RTS how many schedulers are available, and populate the
+    @numTesters@ field with that number. E.g @quickCheckPar p@ when you compiled with
+    @-N4@ is equivalent to @quickCheckWith (stdArgs { numTesters = 4 }) p@.
+
+    -}
+  , quickCheckPar
+  , SizeStrategy(..)
+  , quickCheckParWith
+  , quickCheckParResult
+  , quickCheckParWithResult
 #ifndef NO_TEMPLATE_HASKELL
     -- ** Testing all properties in a module
 
@@ -270,6 +320,9 @@ module Test.QuickCheck
   , withMaxSuccess
   , within
   , discardAfter
+  , withDiscardRatio
+  , withMaxSize
+  , withMaxShrinks
   , once
   , again
   , mapSize
@@ -307,7 +360,6 @@ module Test.QuickCheck
 
 --------------------------------------------------------------------------
 -- imports
-
 import Test.QuickCheck.Gen
 import Test.QuickCheck.Arbitrary
 import Test.QuickCheck.Modifiers
@@ -318,7 +370,6 @@ import Test.QuickCheck.Exception
 import Test.QuickCheck.Function
 #endif
 import Test.QuickCheck.Features
-import Test.QuickCheck.State
 #ifndef NO_TEMPLATE_HASKELL
 import Test.QuickCheck.All
 #endif

src/Test/QuickCheck/Features.hs

@@ -5,7 +5,6 @@ import Test.QuickCheck.Property hiding (Result, reason)
 import qualified Test.QuickCheck.Property as P
 import Test.QuickCheck.Test
 import Test.QuickCheck.Gen
-import Test.QuickCheck.State
 import Test.QuickCheck.Text
 import qualified Data.Set as Set
 import Data.Set(Set)
@@ -17,16 +16,16 @@ features :: [String] -> Set String -> Set String
 features labels classes =
   Set.fromList labels `Set.union` classes
 
-prop_noNewFeatures :: Testable prop => Set String -> prop -> Property
-prop_noNewFeatures feats prop =
-  mapResult f prop
-  where
-    f res =
-      case ok res of
-        Just True
-          | not (features (P.labels res) (Set.fromList (P.classes res)) `Set.isSubsetOf` feats) ->
-            res{ok = Just False, P.reason = "New feature found"}
-        _ -> res
+-- prop_noNewFeatures :: Testable prop => Set String -> prop -> Property
+-- prop_noNewFeatures feats prop =
+--   mapResult f prop
+--   where
+--     f res =
+--       case ok res of
+--         Just True
+--           | not (features (P.labels res) (Set.fromList (P.classes res)) `Set.isSubsetOf` feats) ->
+--             res{ok = Just False, P.reason = "New feature found"}
+--         _ -> res
 
 -- | Given a property, which must use 'label', 'collect', 'classify' or 'cover'
 -- to associate labels with test cases, find an example test case for each possible label.
@@ -81,26 +80,26 @@ labelledExamplesResult prop = labelledExamplesWithResult stdArgs prop
 
 -- | A variant of 'labelledExamples' that takes test arguments and returns a result.
 labelledExamplesWithResult :: Testable prop => Args -> prop -> IO Result
-labelledExamplesWithResult args prop =
-  withState args $ \state -> do
-    let
-      loop :: Set String -> State -> IO Result
-      loop feats state = withNullTerminal $ \nullterm -> do
-        res <- test state{terminal = nullterm} (property (prop_noNewFeatures feats prop))
-        let feats' = features (failingLabels res) (failingClasses res)
-        case res of
-          Failure{reason = "New feature found"} -> do
-            putLine (terminal state) $
-              "*** Found example of " ++
-              concat (intersperse ", " (Set.toList (feats' Set.\\ feats)))
-            mapM_ (putLine (terminal state)) (failingTestCase res)
-            putStrLn ""
-            loop (Set.union feats feats')
-              state{randomSeed = usedSeed res, computeSize = computeSize state `at0` usedSize res}
-          _ -> do
-            out <- terminalOutput nullterm
-            putStr out
-            return res
-      at0 f s 0 0 = s
-      at0 f s n d = f n d
-    loop Set.empty state
+labelledExamplesWithResult args prop = undefined -- TODO fix this
+  -- withState args (\state -> do
+  --   let
+  --     loop :: Set String -> State -> IO Result
+  --     loop feats state = withNullTerminal $ \nullterm -> do
+  --       res <- test state{terminal = nullterm} (property (prop_noNewFeatures feats prop))
+  --       let feats' = features (failingLabels res) (failingClasses res)
+  --       case res of
+  --         Failure{reason = "New feature found"} -> do
+  --           putLine (terminal state) $
+  --             "*** Found example of " ++
+  --             concat (intersperse ", " (Set.toList (feats' Set.\\ feats)))
+  --           mapM_ (putLine (terminal state)) (failingTestCase res)
+  --           putStrLn ""
+  --           loop (Set.union feats feats')
+  --             state{randomSeed = usedSeed res, computeSize = computeSize state `at0` usedSize res}
+  --         _ -> do
+  --           out <- terminalOutput nullterm
+  --           putStr out
+  --           return res
+  --     at0 f s 0 0 = s
+  --     at0 f s n d = f n d
+  --   loop Set.empty state) Nothing 0

src/Test/QuickCheck/Monadic.hs

@@ -63,6 +63,7 @@ module Test.QuickCheck.Monadic (
   , forAllM
   , monitor
   , stop
+  , graceful
 
   -- * Run functions
   , monadic
@@ -85,6 +86,8 @@ import Control.Monad(liftM, liftM2)
 
 import Control.Monad.ST
 import Control.Applicative
+import Control.Exception hiding (assert)
+import Control.Concurrent
 
 #ifndef NO_TRANSFORMERS
 import Control.Monad.IO.Class
@@ -273,6 +276,51 @@ monadic' (MkPropertyM m) = m (\prop -> return (return (property prop)))
 monadicIO :: Testable a => PropertyM IO a -> Property
 monadicIO = monadic ioProperty
 
+{- | Add a graceful optional termination of an IO action. If your test needs to perform
+some IO that, if interrupted by CTRL-C being pressed, needs to do some teardown, this
+combinator is for you!
+
+Example:
+
+@
+prop_graceful :: Property
+prop_graceful = monadicIO $ do
+    -- first IO action that might leave unwanted artifacts
+    c1 <- graceful
+            (do writeFile "firstfile.txt" "hi"
+                c <- readFile "firstfile.txt"
+                removeFile "firstfile.txt"
+                return c)
+            -- cleanup function only called if ctrl-c pressed
+            (do b <- doesFileExist "firstfile.txt"
+                if b then removeFile "firstfile.txt" else return ())
+
+    -- second IO action that might leave unwanted artifacts
+    c2 <- graceful
+           (do writeFile "secondfile.txt" "hi"
+               c <- readFile "secondfile.txt"
+               removeFile "secondfile.txt"
+               return c)
+           -- cleanup function only called if ctrl-c pressed
+           (do b <- doesFileExist "secondfile.txt"
+               if b then removeFile "secondfile.txt" else return ())
+
+    -- donkey property
+    assert (c1 == c2)
+@
+
+-}
+graceful :: IO a -> IO () -> PropertyM IO a
+-- TODO piggybacking on UserInterrupt here, but this should really be a QC internal exception
+-- this was just placed here for my evaluation
+--
+-- design of this combinator might have to change
+graceful prop ioa = run $ prop `catch` \UserInterrupt -> do
+  ioa
+  tid <- myThreadId
+  throwTo tid UserInterrupt -- defer to default handler
+  error "this will never evaluate, but will have the correct type!"
+
 #ifndef NO_ST_MONAD
 -- | Runs the property monad for 'ST'-computations.
 --