1{-# LANGUAGE RecordWildCards #-} 2module Test.Hspec.Core.QuickCheckUtil where 3 4import Prelude () 5import Test.Hspec.Core.Compat 6 7import Control.Exception 8import Data.List 9import Data.Maybe 10import Data.Int 11import System.Random 12 13import Test.QuickCheck 14import Test.QuickCheck.Text (isOneLine) 15import qualified Test.QuickCheck.Property as QCP 16import Test.QuickCheck.Property hiding (Result(..)) 17import Test.QuickCheck.Gen 18import Test.QuickCheck.IO () 19import Test.QuickCheck.Random 20import qualified Test.QuickCheck.Test as QC (showTestCount) 21import Test.QuickCheck.State (State(..)) 22 23import Test.Hspec.Core.Util 24 25aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property 26aroundProperty action p = MkProperty . MkGen $ \r n -> aroundProp action $ \a -> (unGen . unProperty $ p a) r n 27 28aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop 29aroundProp action p = MkProp $ aroundRose action (\a -> unProp $ p a) 30 31aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result 32aroundRose action r = ioRose $ do 33 ref <- newIORef (return QCP.succeeded) 34 action $ \a -> reduceRose (r a) >>= writeIORef ref 35 readIORef ref 36 37newSeed :: IO Int 38newSeed = fst . randomR (0, fromIntegral (maxBound :: Int32)) <$> 39 newQCGen 40 41mkGen :: Int -> QCGen 42mkGen = mkQCGen 43 44formatNumbers :: Int -> Int -> String 45formatNumbers n shrinks = "(after " ++ pluralize n "test" ++ shrinks_ ++ ")" 46 where 47 shrinks_ 48 | shrinks > 0 = " and " ++ pluralize shrinks "shrink" 49 | otherwise = "" 50 51data QuickCheckResult = QuickCheckResult { 52 quickCheckResultNumTests :: Int 53, quickCheckResultInfo :: String 54, quickCheckResultStatus :: Status 55} deriving Show 56 57data Status = 58 QuickCheckSuccess 59 | QuickCheckFailure QuickCheckFailure 60 | QuickCheckOtherFailure String 61 deriving Show 62 63data QuickCheckFailure = QCFailure { 64 quickCheckFailureNumShrinks :: Int 65, quickCheckFailureException :: Maybe SomeException 66, quickCheckFailureReason :: String 67, quickCheckFailureCounterexample :: [String] 68} deriving Show 69 70parseQuickCheckResult :: Result -> QuickCheckResult 71parseQuickCheckResult r = case r of 72 Success {..} -> result output QuickCheckSuccess 73 74 Failure {..} -> 75 case stripSuffix outputWithoutVerbose output of 76 Just xs -> result verboseOutput (QuickCheckFailure $ QCFailure numShrinks theException reason failingTestCase) 77 where 78 verboseOutput 79 | xs == "*** Failed! " = "" 80 | otherwise = maybeStripSuffix "*** Failed!" (strip xs) 81 Nothing -> couldNotParse output 82 where 83 outputWithoutVerbose = reasonAndNumbers ++ unlines failingTestCase 84 reasonAndNumbers 85 | isOneLine reason = reason ++ " " ++ numbers ++ colonNewline 86 | otherwise = numbers ++ colonNewline ++ ensureTrailingNewline reason 87 numbers = formatNumbers numTests numShrinks 88 colonNewline = ":\n" 89 90 GaveUp {..} -> 91 case stripSuffix outputWithoutVerbose output of 92 Just info -> otherFailure info ("Gave up after " ++ numbers ++ "!") 93 Nothing -> couldNotParse output 94 where 95 numbers = showTestCount numTests numDiscarded 96 outputWithoutVerbose = "*** Gave up! Passed only " ++ numbers ++ " tests.\n" 97 98 NoExpectedFailure {..} -> case splitBy "*** Failed! " output of 99 Just (info, err) -> otherFailure info err 100 Nothing -> couldNotParse output 101 102 where 103 result = QuickCheckResult (numTests r) . strip 104 otherFailure info err = result info (QuickCheckOtherFailure $ strip err) 105 couldNotParse = result "" . QuickCheckOtherFailure 106 107showTestCount :: Int -> Int -> String 108showTestCount success discarded = QC.showTestCount state 109 where 110 state = MkState { 111 terminal = undefined 112 , maxSuccessTests = undefined 113 , maxDiscardedRatio = undefined 114 , coverageConfidence = undefined 115 , computeSize = undefined 116 , numTotMaxShrinks = 0 117 , numSuccessTests = success 118 , numDiscardedTests = discarded 119 , numRecentlyDiscardedTests = 0 120 , labels = mempty 121 , classes = mempty 122 , tables = mempty 123 , requiredCoverage = mempty 124 , expected = True 125 , randomSeed = mkGen 0 126 , numSuccessShrinks = 0 127 , numTryShrinks = 0 128 , numTotTryShrinks = 0 129 } 130 131ensureTrailingNewline :: String -> String 132ensureTrailingNewline = unlines . lines 133 134maybeStripPrefix :: String -> String -> String 135maybeStripPrefix prefix m = fromMaybe m (stripPrefix prefix m) 136 137maybeStripSuffix :: String -> String -> String 138maybeStripSuffix suffix = reverse . maybeStripPrefix (reverse suffix) . reverse 139 140stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] 141stripSuffix suffix = fmap reverse . stripPrefix (reverse suffix) . reverse 142 143splitBy :: String -> String -> Maybe (String, String) 144splitBy sep xs = listToMaybe [ 145 (x, y) | (x, Just y) <- zip (inits xs) (map stripSep $ tails xs) 146 ] 147 where 148 stripSep = stripPrefix sep 149