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