    {-# 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 (((String, Bool) -> String) -> [(String, Bool)] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (String, Bool) -> String
    forall a b. (a, b) -> a
    fst ([(String, Bool)] -> [String]) -> [(String, Bool)] -> [String]
    forall a b. (a -> b) -> a -> b
    $ ((String, Bool) -> Bool) -> [(String, Bool)] -> [(String, Bool)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (String, Bool) -> Bool
    forall a b. (a, b) -> b
    snd ([(String, Bool)] -> [(String, Bool)])
    -> [(String, Bool)] -> [(String, Bool)]
    forall a b. (a -> b) -> a -> b
    $ Result -> [(String, Bool)]
    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
            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' = [String] -> Set String -> Set String
    features (Result -> [String]
    failingLabels Result
    res) (Result -> Set String
    failingClasses Result
    res)
            case 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, replayStartSize = Just $ usedSize res}
              Result
    _ -> do
                out <- Terminal -> IO String
    terminalOutput Terminal
    nullterm
                putStr out
                return 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