{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} module Test.Hspec.Core.QuickCheck.Util ( liftHook , aroundProperty , QuickCheckResult(..) , Status(..) , QuickCheckFailure(..) , parseQuickCheckResult , formatNumbers , mkGen , newSeed #ifdef TEST , stripSuffix , splitBy #endif ) where import Prelude () import Test.Hspec.Core.Compat import Data.Int import System.Random import Test.QuickCheck import Test.QuickCheck.Text (isOneLine) import qualified Test.QuickCheck.Property as QCP import Test.QuickCheck.Property hiding (Result(..)) import Test.QuickCheck.Gen import Test.QuickCheck.IO () import Test.QuickCheck.Random import qualified Test.QuickCheck.Test as QC (showTestCount) import Test.QuickCheck.State (State(..)) import Test.Hspec.Core.Util liftHook :: r -> ((a -> IO ()) -> IO ()) -> (a -> IO r) -> IO r liftHook :: forall r a. r -> ((a -> IO ()) -> IO ()) -> (a -> IO r) -> IO r liftHook r def (a -> IO ()) -> IO () hook a -> IO r inner = do IORef r ref <- r -> IO (IORef r) forall a. a -> IO (IORef a) newIORef r def (a -> IO ()) -> IO () hook ((a -> IO ()) -> IO ()) -> (a -> IO ()) -> IO () forall a b. (a -> b) -> a -> b $ a -> IO r inner (a -> IO r) -> (r -> IO ()) -> a -> IO () forall (m :: * -> *) a b c. Monad m => (a -> m b) -> (b -> m c) -> a -> m c >=> IORef r -> r -> IO () forall a. IORef a -> a -> IO () writeIORef IORef r ref IORef r -> IO r forall a. IORef a -> IO a readIORef IORef r ref aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property aroundProperty :: forall a. ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property aroundProperty (a -> IO ()) -> IO () hook a -> Property p = Gen Prop -> Property MkProperty (Gen Prop -> Property) -> ((QCGen -> Int -> Prop) -> Gen Prop) -> (QCGen -> Int -> Prop) -> Property forall b c a. (b -> c) -> (a -> b) -> a -> c . (QCGen -> Int -> Prop) -> Gen Prop forall a. (QCGen -> Int -> a) -> Gen a MkGen ((QCGen -> Int -> Prop) -> Property) -> (QCGen -> Int -> Prop) -> Property forall a b. (a -> b) -> a -> b $ \QCGen r Int n -> ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop forall a. ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop aroundProp (a -> IO ()) -> IO () hook ((a -> Prop) -> Prop) -> (a -> Prop) -> Prop forall a b. (a -> b) -> a -> b $ \a a -> (Gen Prop -> QCGen -> Int -> Prop forall a. Gen a -> QCGen -> Int -> a unGen (Gen Prop -> QCGen -> Int -> Prop) -> (Property -> Gen Prop) -> Property -> QCGen -> Int -> Prop forall b c a. (b -> c) -> (a -> b) -> a -> c . Property -> Gen Prop unProperty (Property -> QCGen -> Int -> Prop) -> Property -> QCGen -> Int -> Prop forall a b. (a -> b) -> a -> b $ a -> Property p a a) QCGen r Int n aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop aroundProp :: forall a. ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop aroundProp (a -> IO ()) -> IO () hook a -> Prop p = Rose Result -> Prop MkProp (Rose Result -> Prop) -> Rose Result -> Prop forall a b. (a -> b) -> a -> b $ ((a -> IO ()) -> IO ()) -> (a -> Rose Result) -> Rose Result forall a. ((a -> IO ()) -> IO ()) -> (a -> Rose Result) -> Rose Result aroundRose (a -> IO ()) -> IO () hook (\a a -> Prop -> Rose Result unProp (Prop -> Rose Result) -> Prop -> Rose Result forall a b. (a -> b) -> a -> b $ a -> Prop p a a) aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result aroundRose :: forall a. ((a -> IO ()) -> IO ()) -> (a -> Rose Result) -> Rose Result aroundRose (a -> IO ()) -> IO () hook a -> Rose Result r = IO (Rose Result) -> Rose Result ioRose (IO (Rose Result) -> Rose Result) -> IO (Rose Result) -> Rose Result forall a b. (a -> b) -> a -> b $ do Rose Result -> ((a -> IO ()) -> IO ()) -> (a -> IO (Rose Result)) -> IO (Rose Result) forall r a. r -> ((a -> IO ()) -> IO ()) -> (a -> IO r) -> IO r liftHook (Result -> Rose Result forall a. a -> Rose a forall (m :: * -> *) a. Monad m => a -> m a return Result QCP.succeeded) (a -> IO ()) -> IO () hook ((a -> IO (Rose Result)) -> IO (Rose Result)) -> (a -> IO (Rose Result)) -> IO (Rose Result) forall a b. (a -> b) -> a -> b $ \ a a -> Rose Result -> IO (Rose Result) reduceRose (a -> Rose Result r a a) newSeed :: IO Int newSeed :: IO Int newSeed = (Int, QCGen) -> Int forall a b. (a, b) -> a fst ((Int, QCGen) -> Int) -> (QCGen -> (Int, QCGen)) -> QCGen -> Int forall b c a. (b -> c) -> (a -> b) -> a -> c . (Int, Int) -> QCGen -> (Int, QCGen) forall g. RandomGen g => (Int, Int) -> g -> (Int, g) forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g) randomR (Int 0, Int32 -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral (Int32 forall a. Bounded a => a maxBound :: Int32)) (QCGen -> Int) -> IO QCGen -> IO Int forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> IO QCGen newQCGen mkGen :: Int -> QCGen mkGen :: Int -> QCGen mkGen = Int -> QCGen mkQCGen formatNumbers :: Int -> Int -> String formatNumbers :: Int -> Int -> String formatNumbers Int n Int shrinks = String "(after " String -> String -> String forall a. [a] -> [a] -> [a] ++ Int -> String -> String pluralize Int n String "test" String -> String -> String forall a. [a] -> [a] -> [a] ++ String shrinks_ String -> String -> String forall a. [a] -> [a] -> [a] ++ String ")" where shrinks_ :: String shrinks_ | Int shrinks Int -> Int -> Bool forall a. Ord a => a -> a -> Bool > Int 0 = String " and " String -> String -> String forall a. [a] -> [a] -> [a] ++ Int -> String -> String pluralize Int shrinks String "shrink" | Bool otherwise = String "" data QuickCheckResult = QuickCheckResult { QuickCheckResult -> Int quickCheckResultNumTests :: Int , QuickCheckResult -> String quickCheckResultInfo :: String , QuickCheckResult -> Status quickCheckResultStatus :: Status } deriving Int -> QuickCheckResult -> String -> String [QuickCheckResult] -> String -> String QuickCheckResult -> String (Int -> QuickCheckResult -> String -> String) -> (QuickCheckResult -> String) -> ([QuickCheckResult] -> String -> String) -> Show QuickCheckResult forall a. (Int -> a -> String -> String) -> (a -> String) -> ([a] -> String -> String) -> Show a $cshowsPrec :: Int -> QuickCheckResult -> String -> String showsPrec :: Int -> QuickCheckResult -> String -> String $cshow :: QuickCheckResult -> String show :: QuickCheckResult -> String $cshowList :: [QuickCheckResult] -> String -> String showList :: [QuickCheckResult] -> String -> String Show data Status = QuickCheckSuccess | QuickCheckFailure QuickCheckFailure | QuickCheckOtherFailure String deriving Int -> Status -> String -> String [Status] -> String -> String Status -> String (Int -> Status -> String -> String) -> (Status -> String) -> ([Status] -> String -> String) -> Show Status forall a. (Int -> a -> String -> String) -> (a -> String) -> ([a] -> String -> String) -> Show a $cshowsPrec :: Int -> Status -> String -> String showsPrec :: Int -> Status -> String -> String $cshow :: Status -> String show :: Status -> String $cshowList :: [Status] -> String -> String showList :: [Status] -> String -> String Show data QuickCheckFailure = QCFailure { QuickCheckFailure -> Int quickCheckFailureNumShrinks :: Int , QuickCheckFailure -> Maybe SomeException quickCheckFailureException :: Maybe SomeException , QuickCheckFailure -> String quickCheckFailureReason :: String , QuickCheckFailure -> [String] quickCheckFailureCounterexample :: [String] } deriving Int -> QuickCheckFailure -> String -> String [QuickCheckFailure] -> String -> String QuickCheckFailure -> String (Int -> QuickCheckFailure -> String -> String) -> (QuickCheckFailure -> String) -> ([QuickCheckFailure] -> String -> String) -> Show QuickCheckFailure forall a. (Int -> a -> String -> String) -> (a -> String) -> ([a] -> String -> String) -> Show a $cshowsPrec :: Int -> QuickCheckFailure -> String -> String showsPrec :: Int -> QuickCheckFailure -> String -> String $cshow :: QuickCheckFailure -> String show :: QuickCheckFailure -> String $cshowList :: [QuickCheckFailure] -> String -> String showList :: [QuickCheckFailure] -> String -> String Show parseQuickCheckResult :: Result -> QuickCheckResult parseQuickCheckResult :: Result -> QuickCheckResult parseQuickCheckResult Result r = case Result r of Success {Int String Map String Int Map String (Map String Int) Map [String] Int numTests :: Int numDiscarded :: Int labels :: Map [String] Int classes :: Map String Int tables :: Map String (Map String Int) output :: String numTests :: Result -> Int numDiscarded :: Result -> Int labels :: Result -> Map [String] Int classes :: Result -> Map String Int tables :: Result -> Map String (Map String Int) output :: Result -> String ..} -> String -> Status -> QuickCheckResult result String output Status QuickCheckSuccess Failure {Int String [String] [Witness] Maybe SomeException QCGen Set String numTests :: Result -> Int numDiscarded :: Result -> Int output :: Result -> String numTests :: Int numDiscarded :: Int numShrinks :: Int numShrinkTries :: Int numShrinkFinal :: Int usedSeed :: QCGen usedSize :: Int reason :: String theException :: Maybe SomeException output :: String failingTestCase :: [String] failingLabels :: [String] failingClasses :: Set String witnesses :: [Witness] numShrinks :: Result -> Int numShrinkTries :: Result -> Int numShrinkFinal :: Result -> Int usedSeed :: Result -> QCGen usedSize :: Result -> Int reason :: Result -> String theException :: Result -> Maybe SomeException failingTestCase :: Result -> [String] failingLabels :: Result -> [String] failingClasses :: Result -> Set String witnesses :: Result -> [Witness] ..} -> case String -> String -> Maybe String forall a. Eq a => [a] -> [a] -> Maybe [a] stripSuffix String outputWithoutVerbose String output of Just String xs -> String -> Status -> QuickCheckResult result String verboseOutput (QuickCheckFailure -> Status QuickCheckFailure (QuickCheckFailure -> Status) -> QuickCheckFailure -> Status forall a b. (a -> b) -> a -> b $ Int -> Maybe SomeException -> String -> [String] -> QuickCheckFailure QCFailure Int numShrinks Maybe SomeException theException String reason [String] failingTestCase) where verboseOutput :: String verboseOutput | String xs String -> String -> Bool forall a. Eq a => a -> a -> Bool == String "*** Failed! " = String "" | Bool otherwise = String -> String -> String maybeStripSuffix String "*** Failed!" (String -> String strip String xs) Maybe String Nothing -> String -> QuickCheckResult couldNotParse String output where outputWithoutVerbose :: String outputWithoutVerbose = String reasonAndNumbers String -> String -> String forall a. [a] -> [a] -> [a] ++ [String] -> String unlines [String] failingTestCase reasonAndNumbers :: String reasonAndNumbers | String -> Bool isOneLine String reason = String reason String -> String -> String forall a. [a] -> [a] -> [a] ++ String " " String -> String -> String forall a. [a] -> [a] -> [a] ++ String numbers String -> String -> String forall a. [a] -> [a] -> [a] ++ String colonNewline | Bool otherwise = String numbers String -> String -> String forall a. [a] -> [a] -> [a] ++ String colonNewline String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String ensureTrailingNewline String reason numbers :: String numbers = Int -> Int -> String formatNumbers Int numTests Int numShrinks colonNewline :: String colonNewline = String ":\n" GaveUp {Int String Map String Int Map String (Map String Int) Map [String] Int numTests :: Result -> Int numDiscarded :: Result -> Int labels :: Result -> Map [String] Int classes :: Result -> Map String Int tables :: Result -> Map String (Map String Int) output :: Result -> String numTests :: Int numDiscarded :: Int labels :: Map [String] Int classes :: Map String Int tables :: Map String (Map String Int) output :: String ..} -> case String -> String -> Maybe String forall a. Eq a => [a] -> [a] -> Maybe [a] stripSuffix String outputWithoutVerbose String output of Just String info -> String -> String -> QuickCheckResult otherFailure String info (String "Gave up after " String -> String -> String forall a. [a] -> [a] -> [a] ++ String numbers String -> String -> String forall a. [a] -> [a] -> [a] ++ String "!") Maybe String Nothing -> String -> QuickCheckResult couldNotParse String output where numbers :: String numbers = Int -> Int -> String showTestCount Int numTests Int numDiscarded outputWithoutVerbose :: String outputWithoutVerbose = String "*** Gave up! Passed only " String -> String -> String forall a. [a] -> [a] -> [a] ++ String numbers String -> String -> String forall a. [a] -> [a] -> [a] ++ String " tests.\n" NoExpectedFailure {Int String Map String Int Map String (Map String Int) Map [String] Int numTests :: Result -> Int numDiscarded :: Result -> Int labels :: Result -> Map [String] Int classes :: Result -> Map String Int tables :: Result -> Map String (Map String Int) output :: Result -> String numTests :: Int numDiscarded :: Int labels :: Map [String] Int classes :: Map String Int tables :: Map String (Map String Int) output :: String ..} -> case String -> String -> Maybe (String, String) splitBy String "*** Failed! " String output of Just (String info, String err) -> String -> String -> QuickCheckResult otherFailure String info String err Maybe (String, String) Nothing -> String -> QuickCheckResult couldNotParse String output where result :: String -> Status -> QuickCheckResult result = Int -> String -> Status -> QuickCheckResult QuickCheckResult (Result -> Int numTests Result r) (String -> Status -> QuickCheckResult) -> (String -> String) -> String -> Status -> QuickCheckResult forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> String strip otherFailure :: String -> String -> QuickCheckResult otherFailure String info String err = String -> Status -> QuickCheckResult result String info (String -> Status QuickCheckOtherFailure (String -> Status) -> String -> Status forall a b. (a -> b) -> a -> b $ String -> String strip String err) couldNotParse :: String -> QuickCheckResult couldNotParse = String -> Status -> QuickCheckResult result String "" (Status -> QuickCheckResult) -> (String -> Status) -> String -> QuickCheckResult forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Status QuickCheckOtherFailure showTestCount :: Int -> Int -> String showTestCount :: Int -> Int -> String showTestCount Int success Int discarded = State -> String QC.showTestCount State state where state :: State state = MkState { terminal :: Terminal terminal = Terminal forall a. HasCallStack => a undefined , maxSuccessTests :: Int maxSuccessTests = Int forall a. HasCallStack => a undefined , maxDiscardedRatio :: Int maxDiscardedRatio = Int forall a. HasCallStack => a undefined , coverageConfidence :: Maybe Confidence coverageConfidence = Maybe Confidence forall a. HasCallStack => a undefined #if MIN_VERSION_QuickCheck(2,15,0) , maxTestSize :: Int maxTestSize = Int 0 , replayStartSize :: Maybe Int replayStartSize = Maybe Int forall a. HasCallStack => a undefined #else , computeSize = undefined #endif , numTotMaxShrinks :: Int numTotMaxShrinks = Int 0 , numSuccessTests :: Int numSuccessTests = Int success , numDiscardedTests :: Int numDiscardedTests = Int discarded , numRecentlyDiscardedTests :: Int numRecentlyDiscardedTests = Int 0 , labels :: Map [String] Int labels = Map [String] Int forall a. Monoid a => a mempty , classes :: Map String Int classes = Map String Int forall a. Monoid a => a mempty , tables :: Map String (Map String Int) tables = Map String (Map String Int) forall a. Monoid a => a mempty , requiredCoverage :: Map (Maybe String, String) Double requiredCoverage = Map (Maybe String, String) Double forall a. Monoid a => a mempty , expected :: Bool expected = Bool True , randomSeed :: QCGen randomSeed = Int -> QCGen mkGen Int 0 , numSuccessShrinks :: Int numSuccessShrinks = Int 0 , numTryShrinks :: Int numTryShrinks = Int 0 , numTotTryShrinks :: Int numTotTryShrinks = Int 0 } ensureTrailingNewline :: String -> String ensureTrailingNewline :: String -> String ensureTrailingNewline = [String] -> String unlines ([String] -> String) -> (String -> [String]) -> String -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> [String] lines maybeStripPrefix :: String -> String -> String maybeStripPrefix :: String -> String -> String maybeStripPrefix String prefix String m = String -> Maybe String -> String forall a. a -> Maybe a -> a fromMaybe String m (String -> String -> Maybe String forall a. Eq a => [a] -> [a] -> Maybe [a] stripPrefix String prefix String m) maybeStripSuffix :: String -> String -> String maybeStripSuffix :: String -> String -> String maybeStripSuffix String suffix = String -> String forall a. [a] -> [a] reverse (String -> String) -> (String -> String) -> String -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> String -> String maybeStripPrefix (String -> String forall a. [a] -> [a] reverse String suffix) (String -> String) -> (String -> String) -> String -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> String forall a. [a] -> [a] reverse stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] stripSuffix :: forall a. Eq a => [a] -> [a] -> Maybe [a] stripSuffix [a] suffix = ([a] -> [a]) -> Maybe [a] -> Maybe [a] forall a b. (a -> b) -> Maybe a -> Maybe b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap [a] -> [a] forall a. [a] -> [a] reverse (Maybe [a] -> Maybe [a]) -> ([a] -> Maybe [a]) -> [a] -> Maybe [a] forall b c a. (b -> c) -> (a -> b) -> a -> c . [a] -> [a] -> Maybe [a] forall a. Eq a => [a] -> [a] -> Maybe [a] stripPrefix ([a] -> [a] forall a. [a] -> [a] reverse [a] suffix) ([a] -> Maybe [a]) -> ([a] -> [a]) -> [a] -> Maybe [a] forall b c a. (b -> c) -> (a -> b) -> a -> c . [a] -> [a] forall a. [a] -> [a] reverse splitBy :: String -> String -> Maybe (String, String) splitBy :: String -> String -> Maybe (String, String) splitBy String sep String xs = [(String, String)] -> Maybe (String, String) forall a. [a] -> Maybe a listToMaybe [ (String x, String y) | (String x, Just String y) <- [String] -> [Maybe String] -> [(String, Maybe String)] forall a b. [a] -> [b] -> [(a, b)] zip (String -> [String] forall a. [a] -> [[a]] inits String xs) ((String -> Maybe String) -> [String] -> [Maybe String] forall a b. (a -> b) -> [a] -> [b] map String -> Maybe String stripSep ([String] -> [Maybe String]) -> [String] -> [Maybe String] forall a b. (a -> b) -> a -> b $ String -> [String] forall a. [a] -> [[a]] tails String xs) ] where stripSep :: String -> Maybe String stripSep = String -> String -> Maybe String forall a. Eq a => [a] -> [a] -> Maybe [a] stripPrefix String sep