{-# 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 =
  [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
labels Set String -> Set String -> Set String
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 =
  (Result -> Result) -> prop -> Property
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) ([String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList (Result -> [String]
P.classes Result
res)) Set String -> Set String -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set String
feats) ->
            Result
res{ok = Just False, P.reason = "New feature found"}
        Maybe Bool
_ -> Result
res

-- | Given a property, which must use 'label', 'collect', 'classify' or 'cover'
-- to associate labels with test cases, find an example test case for each possible label.
-- The example test cases are minimised using shrinking.
--
-- For example, suppose we test @'Data.List.delete' x xs@ and record the number
-- of times that @x@ occurs in @xs@:
--
-- > prop_delete :: Int -> [Int] -> Property
-- > prop_delete x xs =
-- >   classify (count x xs == 0) "count x xs == 0" $
-- >   classify (count x xs == 1) "count x xs == 1" $
-- >   classify (count x xs >= 2) "count x xs >= 2" $
-- >   counterexample (show (delete x xs)) $
-- >   count x (delete x xs) == max 0 (count x xs-1)
-- >   where count x xs = length (filter (== x) xs)
--
-- 'labelledExamples' generates three example test cases, one for each label:
-- 
-- >>> labelledExamples prop_delete
-- *** Found example of count x xs == 0
-- 0
-- []
-- []
-- <BLANKLINE>
-- *** Found example of count x xs == 1
-- 0
-- [0]
-- []
-- <BLANKLINE>
-- *** Found example of count x xs >= 2
-- 5
-- [5,5]
-- [5]
-- <BLANKLINE>
-- +++ OK, passed 100 tests:
-- 78% count x xs == 0
-- 21% count x xs == 1
--  1% count x xs >= 2


labelledExamples :: Testable prop => prop -> IO ()
labelledExamples :: forall prop. Testable prop => prop -> IO ()
labelledExamples prop
prop = Args -> prop -> IO ()
forall prop. Testable prop => Args -> prop -> IO ()
labelledExamplesWith Args
stdArgs prop
prop

-- | A variant of 'labelledExamples' that takes test arguments.
labelledExamplesWith :: Testable prop => Args -> prop -> IO ()
labelledExamplesWith :: forall prop. Testable prop => Args -> prop -> IO ()
labelledExamplesWith Args
args prop
prop = Args -> prop -> IO Result
forall prop. Testable prop => Args -> prop -> IO Result
labelledExamplesWithResult Args
args prop
prop IO Result -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | A variant of 'labelledExamples' that returns a result.
labelledExamplesResult :: Testable prop => prop -> IO Result
labelledExamplesResult :: forall prop. Testable prop => prop -> IO Result
labelledExamplesResult prop
prop = Args -> prop -> IO Result
forall prop. Testable prop => Args -> prop -> IO Result
labelledExamplesWithResult Args
stdArgs prop
prop

-- | A variant of 'labelledExamples' that takes test arguments and returns a result.
labelledExamplesWithResult :: Testable prop => Args -> prop -> IO Result
labelledExamplesWithResult :: forall prop. Testable prop => Args -> prop -> IO Result
labelledExamplesWithResult Args
args prop
prop =
  Args -> (State -> IO Result) -> IO Result
forall a. Args -> (State -> IO a) -> IO a
withState Args
args ((State -> IO Result) -> IO Result)
-> (State -> IO Result) -> IO Result
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 = (Terminal -> IO Result) -> IO Result
forall a. (Terminal -> IO a) -> IO a
withNullTerminal ((Terminal -> IO Result) -> IO Result)
-> (Terminal -> IO Result) -> IO Result
forall a b. (a -> b) -> a -> b
$ \Terminal
nullterm -> do
        Result
res <- State -> Property -> IO Result
test State
state{terminal = nullterm} (Property -> Property
forall prop. Testable prop => prop -> Property
property (Set String -> prop -> 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) (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"*** Found example of " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " (Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String
feats' Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set String
feats)))
            (String -> IO ()) -> [String] -> IO ()
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 (Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set String
feats Set String
feats')
              State
state{randomSeed = usedSeed res, computeSize = computeSize state `at0` usedSize res}
          Result
_ -> do
            String
out <- Terminal -> IO String
terminalOutput Terminal
nullterm
            String -> IO ()
putStr String
out
            Result -> IO Result
forall a. a -> IO a
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 Set String
forall a. Set a
Set.empty State
state