quickcheck: print progress

QuickCheck has its own progress information which shows number of test
cases done so far and if a test fails also reports the number of
shrinks.  Tasty disables QuickCheck's output by setting 'chatty' option
to 'False'.  We can now feed this information to tasty progress
reporting by defining how 'QuickCheck's speaks to a terminal.

quickcheck/Test/Tasty/QuickCheck.hs

@@ -1,5 +1,5 @@
 -- | This module allows to use QuickCheck properties in tasty.
-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, NamedFieldPuns #-}
 module Test.Tasty.QuickCheck
   ( testProperty
   , testProperties
@@ -24,7 +24,10 @@ import Test.Tasty ( testGroup )
 import Test.Tasty.Providers
 import Test.Tasty.Options
 import qualified Test.QuickCheck as QC
-import Test.Tasty.Runners (formatMessage)
+import qualified Test.QuickCheck.Test as QC
+import qualified Test.QuickCheck.State as QC
+import qualified Test.QuickCheck.Text as QC
+import Test.Tasty.Runners (formatMessage, emptyProgress)
 import Test.QuickCheck hiding -- for re-export
   ( quickCheck
   , Args(..)
@@ -47,6 +50,7 @@ import Test.QuickCheck hiding -- for re-export
   , verboseCheckAll
   )
 
+import qualified Data.Char as Char
 import Data.Typeable
 import Data.List
 import Text.Printf
@@ -199,20 +203,20 @@ instance IsTest QC where
     , Option (Proxy :: Proxy QuickCheckMaxShrinks)
     ]
 
-  run opts (QC prop) _yieldProgress = do
+  run opts (QC prop) yieldProgress = do
     (replaySeed, args) <- optionSetToArgs opts
-
+    -- This IORef contains the number of examples tested so far,
+    -- for displaying progress.
     let
       QuickCheckShowReplay showReplay = lookupOption opts
       QuickCheckVerbose    verbose    = lookupOption opts
       maxSize = QC.maxSize args
-      testRunner = if verbose
-                     then QC.verboseCheckWithResult
-                     else QC.quickCheckWithResult
       replayMsg = makeReplayMsg replaySeed maxSize
 
     -- Quickcheck already catches exceptions, no need to do it here.
-    r <- testRunner args prop
+    r <- quickCheck yieldProgress
+                    args
+                    (if verbose then QC.verbose prop else prop)
 
     qcOutput <- formatMessage $ QC.output r
     let qcOutputNl =
@@ -226,6 +230,25 @@ instance IsTest QC where
       (qcOutputNl ++
         (if putReplayInDesc then replayMsg else ""))
 
+
+-- | Like the original 'QC.quickCheck' but is reporting progress using tasty
+-- callback.
+--
+quickCheck :: (Progress -> IO ())
+           -> QC.Args
+           -> QC.Property
+           -> IO QC.Result
+quickCheck yieldProgress args prop = do
+  tm <- QC.newTerminal
+          (const $ pure ())
+          (\progressText -> yieldProgress emptyProgress { progressText = parseProgress progressText })
+  QC.withState args $ \ s ->
+    QC.test s { QC.terminal = tm } prop
+  where
+    parseProgress :: String -> String
+    parseProgress = takeWhile Char.isDigit
+                  . dropWhile (not . Char.isDigit)
+
 successful :: QC.Result -> Bool
 successful r =
   case r of