diff --git a/quickcheck/Test/Tasty/QuickCheck.hs b/quickcheck/Test/Tasty/QuickCheck.hs index cfcaf5bc..3e8ca625 100644 --- 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 index 1d0a7f23..23ca58b3 100644 --- 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