{-# LANGUAGE CPP #-}
#ifndef NO_SAFE_HASKELL
{-# LANGUAGE Safe #-}
#endif
{-# OPTIONS_HADDOCK hide #-}
module Test.QuickCheck.Features where
import Test.QuickCheck.Property hiding (Result, reason)
import qualified Test.QuickCheck.Property as P
import Test.QuickCheck.Test
import Test.QuickCheck.Gen
import Test.QuickCheck.State
import Test.QuickCheck.Text
import qualified Data.Set as Set
import Data.Set(Set)
import Data.List (intersperse)
import Data.IORef
import Data.Maybe
features :: [String] -> Set String -> Set String
features :: [String] -> Set String -> Set String
features [String]
labels Set String
classes =
forall a. Ord a => [a] -> Set a
Set.fromList [String]
labels forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set String
classes
prop_noNewFeatures :: Testable prop => Set String -> prop -> Property
prop_noNewFeatures :: forall prop. Testable prop => Set String -> prop -> Property
prop_noNewFeatures Set String
feats prop
prop =
forall prop.
Testable prop =>
(Result -> Result) -> prop -> Property
mapResult Result -> Result
f prop
prop
where
f :: Result -> Result
f Result
res =
case Result -> Maybe Bool
ok Result
res of
Just Bool
True
| Bool -> Bool
not ([String] -> Set String -> Set String
features (Result -> [String]
P.labels Result
res) (forall a. Ord a => [a] -> Set a
Set.fromList (Result -> [String]
P.classes Result
res)) forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set String
feats) ->
Result
res{ok :: Maybe Bool
ok = forall a. a -> Maybe a
Just Bool
False, reason :: String
P.reason = String
"New feature found"}
Maybe Bool
_ -> Result
res
labelledExamples :: Testable prop => prop -> IO ()
labelledExamples :: forall prop. Testable prop => prop -> IO ()
labelledExamples prop
prop = forall prop. Testable prop => Args -> prop -> IO ()
labelledExamplesWith Args
stdArgs prop
prop
labelledExamplesWith :: Testable prop => Args -> prop -> IO ()
labelledExamplesWith :: forall prop. Testable prop => Args -> prop -> IO ()
labelledExamplesWith Args
args prop
prop = forall prop. Testable prop => Args -> prop -> IO Result
labelledExamplesWithResult Args
args prop
prop forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
labelledExamplesResult :: Testable prop => prop -> IO Result
labelledExamplesResult :: forall prop. Testable prop => prop -> IO Result
labelledExamplesResult prop
prop = forall prop. Testable prop => Args -> prop -> IO Result
labelledExamplesWithResult Args
stdArgs prop
prop
labelledExamplesWithResult :: Testable prop => Args -> prop -> IO Result
labelledExamplesWithResult :: forall prop. Testable prop => Args -> prop -> IO Result
labelledExamplesWithResult Args
args prop
prop =
forall a. Args -> (State -> IO a) -> IO a
withState Args
args forall a b. (a -> b) -> a -> b
$ \State
state -> do
let
loop :: Set String -> State -> IO Result
loop :: Set String -> State -> IO Result
loop Set String
feats State
state = forall a. (Terminal -> IO a) -> IO a
withNullTerminal forall a b. (a -> b) -> a -> b
$ \Terminal
nullterm -> do
Result
res <- State -> Property -> IO Result
test State
state{terminal :: Terminal
terminal = Terminal
nullterm} (forall prop. Testable prop => prop -> Property
property (forall prop. Testable prop => Set String -> prop -> Property
prop_noNewFeatures Set String
feats prop
prop))
let feats' :: Set String
feats' = [String] -> Set String -> Set String
features (Result -> [String]
failingLabels Result
res) (Result -> Set String
failingClasses Result
res)
case Result
res of
Failure{reason :: Result -> String
reason = String
"New feature found"} -> do
Terminal -> String -> IO ()
putLine (State -> Terminal
terminal State
state) forall a b. (a -> b) -> a -> b
$
String
"*** Found example of " forall a. [a] -> [a] -> [a]
++
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse String
", " (forall a. Set a -> [a]
Set.toList (Set String
feats' forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set String
feats)))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Terminal -> String -> IO ()
putLine (State -> Terminal
terminal State
state)) (Result -> [String]
failingTestCase Result
res)
String -> IO ()
putStrLn String
""
Set String -> State -> IO Result
loop (forall a. Ord a => Set a -> Set a -> Set a
Set.union Set String
feats Set String
feats')
State
state{randomSeed :: QCGen
randomSeed = Result -> QCGen
usedSeed Result
res, computeSize :: Int -> Int -> Int
computeSize = State -> Int -> Int -> Int
computeSize State
state forall {t} {t} {p}.
(Eq t, Eq t, Num t, Num t) =>
(t -> t -> p) -> p -> t -> t -> p
`at0` Result -> Int
usedSize Result
res}
Result
_ -> do
String
out <- Terminal -> IO String
terminalOutput Terminal
nullterm
String -> IO ()
putStr String
out
forall (m :: * -> *) a. Monad m => a -> m a
return Result
res
at0 :: (t -> t -> p) -> p -> t -> t -> p
at0 t -> t -> p
f p
s t
0 t
0 = p
s
at0 t -> t -> p
f p
s t
n t
d = t -> t -> p
f t
n t
d
Set String -> State -> IO Result
loop forall a. Set a
Set.empty State
state