fixed quickcheck percent done error (#419)

* fixed quickcheck percent done error * switched to using callbacks * trailing whitespace Co-authored-by: ˌbodʲɪˈɡrʲim <andrew.lelechenko@gmail.com> * manual test Co-authored-by: ˌbodʲɪˈɡrʲim <andrew.lelechenko@gmail.com> --------- Co-authored-by: ˌbodʲɪˈɡrʲim <andrew.lelechenko@gmail.com>
UnkindPartition · Jun 9, 2024 · 6eb9711 · 6eb9711
1 parent dcbf320
commit 6eb9711
Show file tree

Hide file tree

Showing 2 changed files with 12 additions and 19 deletions.
diff --git a/quickcheck/Test/Tasty/QuickCheck.hs b/quickcheck/Test/Tasty/QuickCheck.hs
@@ -24,9 +24,8 @@ import Test.Tasty ( testGroup )
 import Test.Tasty.Providers
 import Test.Tasty.Options
 import qualified Test.QuickCheck as QC
-import qualified Test.QuickCheck.Test as QC
+import qualified Test.QuickCheck.Property as QCP
 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
@@ -51,11 +50,9 @@ import Test.QuickCheck hiding -- for re-export
   )
 
 import Control.Applicative
-import qualified Data.Char as Char
 import Data.Typeable
 import Data.List
 import Text.Printf
-import Text.Read (readMaybe)
 import Test.QuickCheck.Random (QCGen, mkQCGen)
 import Options.Applicative (metavar)
 import System.Random (getStdRandom, randomR)
@@ -259,21 +256,12 @@ quickCheck :: (Progress -> IO ())
            -> QC.Args
            -> QC.Property
            -> IO QC.Result
-quickCheck yieldProgress args prop = do
-  -- Here we rely on the fact that QuickCheck currently prints its progress to
-  -- stderr and the overall status (which we don't need) to stdout
-  tm <- QC.newTerminal
-          (const $ pure ())
-          (\progressText -> yieldProgress emptyProgress { progressPercent = parseProgress progressText })
-  QC.withState args $ \ s ->
-    QC.test s { QC.terminal = tm } prop
-  where
-    -- QuickCheck outputs something like "(15461 tests)\b\b\b\b\b\b\b\b\b\b\b\b\b"
-    parseProgress :: String -> Float
-    parseProgress = maybe 0 (\n -> fromIntegral (n :: Int) / fromIntegral (QC.maxSuccess args))
-                  . readMaybe
-                  . takeWhile Char.isDigit
-                  . drop 1
+quickCheck yieldProgress args
+  = (.) (QC.quickCheckWithResult args)
+  $ QCP.callback
+  $ QCP.PostTest QCP.NotCounterexample
+  $ \QC.MkState {QC.maxSuccessTests, QC.numSuccessTests} _ ->
+    yieldProgress $ emptyProgress {progressPercent = fromIntegral numSuccessTests / fromIntegral maxSuccessTests}
 
 successful :: QC.Result -> Bool
 successful r =

diff --git a/quickcheck/tests/test.hs b/quickcheck/tests/test.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+import Control.Concurrent (threadDelay)
 import Test.Tasty
 import Test.Tasty.Options
 import Test.Tasty.Providers as Tasty
@@ -107,6 +109,9 @@ main =
           resultDescription =~ "Failed.*expected failure"
           resultDescription =~ "Use .* to reproduce"
 
+      -- Run the test suite manually and check that progress does not go beyond 100%
+      , testProperty "Percent Complete" $ withMaxSuccess 1000 $ \(_ :: Int) -> ioProperty $ threadDelay 10000
+
       ]
 
 run' :: Testable p => p -> IO Result