{-# LANGUAGE RecordWildCards #-} module Test.Hspec.Core.QuickCheckUtil where import Prelude () import Test.Hspec.Core.Compat import Control.Exception import Data.List import Data.Maybe 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 aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property aroundProperty action :: (a -> IO ()) -> IO () action p :: 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 $ \r :: QCGen r n :: Int n -> ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop forall a. ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop aroundProp (a -> IO ()) -> IO () action ((a -> Prop) -> Prop) -> (a -> Prop) -> Prop forall a b. (a -> b) -> a -> b $ \a :: 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 :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop aroundProp action :: (a -> IO ()) -> IO () action p :: 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 () action (\a :: 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 :: ((a -> IO ()) -> IO ()) -> (a -> Rose Result) -> Rose Result aroundRose action :: (a -> IO ()) -> IO () action r :: 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 IORef (Rose Result) ref <- Rose Result -> IO (IORef (Rose Result)) forall a. a -> IO (IORef a) newIORef (Result -> Rose Result forall (m :: * -> *) a. Monad m => a -> m a return Result QCP.succeeded) (a -> IO ()) -> IO () action ((a -> IO ()) -> IO ()) -> (a -> IO ()) -> IO () forall a b. (a -> b) -> a -> b $ \a :: a a -> Rose Result -> IO (Rose Result) reduceRose (a -> Rose Result r a a) IO (Rose Result) -> (Rose Result -> IO ()) -> IO () forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= IORef (Rose Result) -> Rose Result -> IO () forall a. IORef a -> a -> IO () writeIORef IORef (Rose Result) ref IORef (Rose Result) -> IO (Rose Result) forall a. IORef a -> IO a readIORef IORef (Rose Result) ref 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 a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g) randomR (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 n :: Int n shrinks :: Int shrinks = "(after " String -> String -> String forall a. [a] -> [a] -> [a] ++ Int -> String -> String pluralize Int n "test" String -> String -> String forall a. [a] -> [a] -> [a] ++ String shrinks_ String -> String -> String forall a. [a] -> [a] -> [a] ++ ")" where shrinks_ :: String shrinks_ | Int shrinks Int -> Int -> Bool forall a. Ord a => a -> a -> Bool > 0 = " and " String -> String -> String forall a. [a] -> [a] -> [a] ++ Int -> String -> String pluralize Int shrinks "shrink" | Bool otherwise = "" 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 showList :: [QuickCheckResult] -> String -> String $cshowList :: [QuickCheckResult] -> String -> String show :: QuickCheckResult -> String $cshow :: QuickCheckResult -> String showsPrec :: Int -> QuickCheckResult -> String -> String $cshowsPrec :: Int -> 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 showList :: [Status] -> String -> String $cshowList :: [Status] -> String -> String show :: Status -> String $cshow :: Status -> String showsPrec :: Int -> Status -> String -> String $cshowsPrec :: Int -> 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 showList :: [QuickCheckFailure] -> String -> String $cshowList :: [QuickCheckFailure] -> String -> String show :: QuickCheckFailure -> String $cshow :: QuickCheckFailure -> String showsPrec :: Int -> QuickCheckFailure -> String -> String $cshowsPrec :: Int -> QuickCheckFailure -> String -> String Show parseQuickCheckResult :: Result -> QuickCheckResult parseQuickCheckResult :: Result -> QuickCheckResult parseQuickCheckResult r :: Result r = case Result r of Success {..} -> String -> Status -> QuickCheckResult result String output Status QuickCheckSuccess Failure {..} -> case String -> String -> Maybe String forall a. Eq a => [a] -> [a] -> Maybe [a] stripSuffix String outputWithoutVerbose String output of Just xs :: 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 == "*** Failed! " = "" | Bool otherwise = String -> String -> String maybeStripSuffix "*** Failed!" (String -> String strip String xs) 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 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 = ":\n" GaveUp {..} -> case String -> String -> Maybe String forall a. Eq a => [a] -> [a] -> Maybe [a] stripSuffix String outputWithoutVerbose String output of Just info :: String info -> String -> String -> QuickCheckResult otherFailure String info ("Gave up after " String -> String -> String forall a. [a] -> [a] -> [a] ++ String numbers String -> String -> String forall a. [a] -> [a] -> [a] ++ "!") Nothing -> String -> QuickCheckResult couldNotParse String output where numbers :: String numbers = Int -> Int -> String showTestCount Int numTests Int numDiscarded outputWithoutVerbose :: String outputWithoutVerbose = "*** Gave up! Passed only " String -> String -> String forall a. [a] -> [a] -> [a] ++ String numbers String -> String -> String forall a. [a] -> [a] -> [a] ++ " tests.\n" NoExpectedFailure {..} -> case String -> String -> Maybe (String, String) splitBy "*** Failed! " String output of Just (info :: String info, err :: String err) -> String -> String -> QuickCheckResult otherFailure String info String err 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 info :: String info err :: 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 "" (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 success :: Int success discarded :: Int discarded = State -> String QC.showTestCount State state where state :: State state = $WMkState :: Terminal -> Int -> Int -> Maybe Confidence -> (Int -> Int -> Int) -> Int -> Int -> Int -> Int -> Map [String] Int -> Map String Int -> Map String (Map String Int) -> Map (Maybe String, String) Double -> Bool -> QCGen -> Int -> Int -> Int -> 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 , computeSize :: Int -> Int -> Int computeSize = Int -> Int -> Int forall a. HasCallStack => a undefined , numTotMaxShrinks :: Int numTotMaxShrinks = 0 , numSuccessTests :: Int numSuccessTests = Int success , numDiscardedTests :: Int numDiscardedTests = Int discarded , numRecentlyDiscardedTests :: Int numRecentlyDiscardedTests = 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 0 , numSuccessShrinks :: Int numSuccessShrinks = 0 , numTryShrinks :: Int numTryShrinks = 0 , numTotTryShrinks :: Int numTotTryShrinks = 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 prefix :: String prefix m :: 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 suffix :: 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 :: [a] -> [a] -> Maybe [a] stripSuffix suffix :: [a] suffix = ([a] -> [a]) -> Maybe [a] -> Maybe [a] 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 sep :: String sep xs :: String xs = [(String, String)] -> Maybe (String, String) forall a. [a] -> Maybe a listToMaybe [ (String x, String y) | (x :: String x, Just y :: 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