    module Test.Framework.Runners.Core (
            RunTest(..), RunningTest, SomeImproving(..), FinishedTest, runTests,
            TestRunner(..), runTestTree
        ) where

    import Test.Framework.Core
    import Test.Framework.Improving
    import Test.Framework.Options
    import Test.Framework.Runners.Options
    import Test.Framework.Runners.TestPattern
    import Test.Framework.Runners.ThreadPool
    import Test.Framework.Seed
    import Test.Framework.Utilities

    import Control.Concurrent.MVar ( newEmptyMVar, putMVar, takeMVar )
    import Control.Exception (mask, finally, onException)
    import Control.Monad ( liftM, forM )
    import Data.Maybe ( catMaybes )
    import Data.Typeable ( Typeable )

    -- | A test that has been executed or is in the process of execution
    data RunTest a = RunTest TestName TestTypeName a
                   | RunTestGroup TestName [RunTest a]
                   deriving (Int -> RunTest a -> ShowS
    [RunTest a] -> ShowS
    RunTest a -> String
    (Int -> RunTest a -> ShowS)
    -> (RunTest a -> String)
    -> ([RunTest a] -> ShowS)
    -> Show (RunTest a)
    forall a. Show a => Int -> RunTest a -> ShowS
    forall a. Show a => [RunTest a] -> ShowS
    forall a. Show a => RunTest a -> String
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: forall a. Show a => Int -> RunTest a -> ShowS
    showsPrec :: Int -> RunTest a -> ShowS
    $cshow :: forall a. Show a => RunTest a -> String
    show :: RunTest a -> String
    $cshowList :: forall a. Show a => [RunTest a] -> ShowS
    showList :: [RunTest a] -> ShowS
    Show)

    data SomeImproving = forall i r. TestResultlike i r => SomeImproving (i :~> r)
    type RunningTest = RunTest SomeImproving

    type FinishedTest = RunTest (String, Bool)

    runTests :: CompleteRunnerOptions -- ^ Top-level runner options
             -> [Test]                -- ^ Tests to run
             -> IO [RunningTest]
    runTests :: CompleteRunnerOptions -> [Test] -> IO [RunningTest]
    runTests CompleteRunnerOptions
    ropts [Test]
    tests = do
        let test_patterns :: [TestPattern]
    test_patterns = K [TestPattern] -> [TestPattern]
    forall a. K a -> a
    unK (K [TestPattern] -> [TestPattern])
    -> K [TestPattern] -> [TestPattern]
    forall a b. (a -> b) -> a -> b
    $ CompleteRunnerOptions -> K [TestPattern]
    forall (f :: * -> *). RunnerOptions' f -> f [TestPattern]
    ropt_test_patterns CompleteRunnerOptions
    ropts
            test_options :: TestOptions
    test_options  = K TestOptions -> TestOptions
    forall a. K a -> a
    unK (K TestOptions -> TestOptions) -> K TestOptions -> TestOptions
    forall a b. (a -> b) -> a -> b
    $ CompleteRunnerOptions -> K TestOptions
    forall (f :: * -> *). RunnerOptions' f -> f TestOptions
    ropt_test_options  CompleteRunnerOptions
    ropts
        (run_tests, actions) <- [StdRunner] -> IO ([RunningTest], [IO ()])
    runTests' ([StdRunner] -> IO ([RunningTest], [IO ()]))
    -> [StdRunner] -> IO ([RunningTest], [IO ()])
    forall a b. (a -> b) -> a -> b
    $ (Test -> StdRunner) -> [Test] -> [StdRunner]
    forall a b. (a -> b) -> [a] -> [b]
    map (TestOptions -> [TestPattern] -> Test -> StdRunner
    forall b. TestRunner b => TestOptions -> [TestPattern] -> Test -> b
    runTestTree TestOptions
    test_options [TestPattern]
    test_patterns) [Test]
    tests
        _ <- executeOnPool (unK $ ropt_threads ropts) actions
        return run_tests

    -- | 'TestRunner' class simplifies folding a 'Test'. You need to specify
    -- the important semantic actions by instantiating this class, and
    -- 'runTestTree' will take care of recursion and test filtering.
    class TestRunner b where
        -- | How to handle a single test
        runSimpleTest :: (Testlike i r t, Typeable t) => TestOptions -> TestName -> t -> b
        -- | How to skip a test that doesn't satisfy the pattern
        skipTest :: b
        -- | How to handle an IO test (created with 'buildTestBracketed')
        runIOTest :: IO (b, IO ()) -> b
        -- | How to run a test group
        runGroup :: TestName -> [b] -> b

    -- | Run the test tree using a 'TestRunner'
    runTestTree
        :: TestRunner b
        => TestOptions
        -> [TestPattern]
        -- ^ skip the tests that do not match any of these patterns, unless
        -- the list is empty
        -> Test
        -> b
    runTestTree :: forall b. TestRunner b => TestOptions -> [TestPattern] -> Test -> b
    runTestTree TestOptions
    initialOpts [TestPattern]
    pats Test
    topTest = TestOptions -> [String] -> Test -> b
    forall {t}. TestRunner t => TestOptions -> [String] -> Test -> t
    go TestOptions
    initialOpts [] Test
    topTest
        where
        go :: TestOptions -> [String] -> Test -> t
    go TestOptions
    opts [String]
    path Test
    t = case Test
    t of
            Test String
    name t
    testlike ->
                if [TestPattern] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TestPattern]
    pats Bool -> Bool -> Bool
    || (TestPattern -> Bool) -> [TestPattern] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (TestPattern -> [String] -> Bool
    `testPatternMatches` ([String]
    path [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ [String
    name])) [TestPattern]
    pats
                    then TestOptions -> String -> t -> t
    forall b i r t.
    (TestRunner b, Testlike i r t, Typeable t) =>
    TestOptions -> String -> t -> b
    forall i r t.
    (Testlike i r t, Typeable t) =>
    TestOptions -> String -> t -> t
    runSimpleTest TestOptions
    opts String
    name t
    testlike
                    else t
    forall b. TestRunner b => b
    skipTest
            TestGroup String
    name [Test]
    tests ->
                let path' :: [String]
    path' = [String]
    path [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ [String
    name]
                in String -> [t] -> t
    forall b. TestRunner b => String -> [b] -> b
    runGroup String
    name ([t] -> t) -> [t] -> t
    forall a b. (a -> b) -> a -> b
    $ (Test -> t) -> [Test] -> [t]
    forall a b. (a -> b) -> [a] -> [b]
    map (TestOptions -> [String] -> Test -> t
    go TestOptions
    opts [String]
    path') [Test]
    tests
            PlusTestOptions TestOptions
    extra_topts Test
    test -> TestOptions -> [String] -> Test -> t
    go (TestOptions
    opts TestOptions -> TestOptions -> TestOptions
    forall a. Monoid a => a -> a -> a
    `mappend` TestOptions
    extra_topts) [String]
    path Test
    test
            BuildTestBracketed IO (Test, IO ())
    build ->
                IO (t, IO ()) -> t
    forall b. TestRunner b => IO (b, IO ()) -> b
    runIOTest (IO (t, IO ()) -> t) -> IO (t, IO ()) -> t
    forall a b. (a -> b) -> a -> b
    $ (Test -> t) -> (Test, IO ()) -> (t, IO ())
    forall a c b. (a -> c) -> (a, b) -> (c, b)
    onLeft (TestOptions -> [String] -> Test -> t
    go TestOptions
    opts [String]
    path) ((Test, IO ()) -> (t, IO ())) -> IO (Test, IO ()) -> IO (t, IO ())
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` IO (Test, IO ())
    build

    newtype StdRunner = StdRunner { StdRunner -> IO (Maybe (RunningTest, [IO ()]))
    run :: IO (Maybe (RunningTest, [IO ()])) }

    instance TestRunner StdRunner where
        runSimpleTest :: forall i r t.
    (Testlike i r t, Typeable t) =>
    TestOptions -> String -> t -> StdRunner
    runSimpleTest TestOptions
    topts String
    name t
    testlike = IO (Maybe (RunningTest, [IO ()])) -> StdRunner
    StdRunner (IO (Maybe (RunningTest, [IO ()])) -> StdRunner)
    -> IO (Maybe (RunningTest, [IO ()])) -> StdRunner
    forall a b. (a -> b) -> a -> b
    $ do
            (result, action) <- CompleteTestOptions -> t -> IO (i :~> r, IO ())
    forall i r t.
    Testlike i r t =>
    CompleteTestOptions -> t -> IO (i :~> r, IO ())
    runTest (TestOptions -> CompleteTestOptions
    completeTestOptions TestOptions
    topts) t
    testlike
            return (Just (RunTest name (testTypeName testlike) (SomeImproving result), [action]))

        skipTest :: StdRunner
    skipTest = IO (Maybe (RunningTest, [IO ()])) -> StdRunner
    StdRunner (IO (Maybe (RunningTest, [IO ()])) -> StdRunner)
    -> IO (Maybe (RunningTest, [IO ()])) -> StdRunner
    forall a b. (a -> b) -> a -> b
    $ Maybe (RunningTest, [IO ()]) -> IO (Maybe (RunningTest, [IO ()]))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (RunningTest, [IO ()])
    forall a. Maybe a
    Nothing

        runGroup :: String -> [StdRunner] -> StdRunner
    runGroup String
    name [StdRunner]
    tests = IO (Maybe (RunningTest, [IO ()])) -> StdRunner
    StdRunner (IO (Maybe (RunningTest, [IO ()])) -> StdRunner)
    -> IO (Maybe (RunningTest, [IO ()])) -> StdRunner
    forall a b. (a -> b) -> a -> b
    $ do
            (results, actions) <- [StdRunner] -> IO ([RunningTest], [IO ()])
    runTests' [StdRunner]
    tests
            return $ if null results then Nothing else Just ((RunTestGroup name results), actions)

        runIOTest :: IO (StdRunner, IO ()) -> StdRunner
    runIOTest IO (StdRunner, IO ())
    ioTest = IO (Maybe (RunningTest, [IO ()])) -> StdRunner
    StdRunner (IO (Maybe (RunningTest, [IO ()])) -> StdRunner)
    -> IO (Maybe (RunningTest, [IO ()])) -> StdRunner
    forall a b. (a -> b) -> a -> b
    $ ((forall a. IO a -> IO a) -> IO (Maybe (RunningTest, [IO ()])))
    -> IO (Maybe (RunningTest, [IO ()]))
    forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
    mask (((forall a. IO a -> IO a) -> IO (Maybe (RunningTest, [IO ()])))
     -> IO (Maybe (RunningTest, [IO ()])))
    -> ((forall a. IO a -> IO a) -> IO (Maybe (RunningTest, [IO ()])))
    -> IO (Maybe (RunningTest, [IO ()]))
    forall a b. (a -> b) -> a -> b
    $ \forall a. IO a -> IO a
    restore -> IO (StdRunner, IO ())
    ioTest IO (StdRunner, IO ())
    -> ((StdRunner, IO ()) -> IO (Maybe (RunningTest, [IO ()])))
    -> IO (Maybe (RunningTest, [IO ()]))
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \(StdRunner IO (Maybe (RunningTest, [IO ()]))
    test, IO ()
    cleanup) -> do
            mb_res <- IO (Maybe (RunningTest, [IO ()]))
    -> IO (Maybe (RunningTest, [IO ()]))
    forall a. IO a -> IO a
    restore IO (Maybe (RunningTest, [IO ()]))
    test IO (Maybe (RunningTest, [IO ()]))
    -> IO () -> IO (Maybe (RunningTest, [IO ()]))
    forall a b. IO a -> IO b -> IO a
    `onException` IO ()
    cleanup
            case mb_res of
                -- No sub-tests: perform the cleanup NOW
                Maybe (RunningTest, [IO ()])
    Nothing                  -> IO ()
    cleanup IO ()
    -> IO (Maybe (RunningTest, [IO ()]))
    -> IO (Maybe (RunningTest, [IO ()]))
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Maybe (RunningTest, [IO ()]) -> IO (Maybe (RunningTest, [IO ()]))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (RunningTest, [IO ()])
    forall a. Maybe a
    Nothing
                Just (RunningTest
    run_test, [IO ()]
    actions) -> do
                    -- Sub-tests: perform the cleanup as soon as each of them have completed
                    (mvars, actions') <- ([(MVar (), IO ())] -> ([MVar ()], [IO ()]))
    -> IO [(MVar (), IO ())] -> IO ([MVar ()], [IO ()])
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM [(MVar (), IO ())] -> ([MVar ()], [IO ()])
    forall a b. [(a, b)] -> ([a], [b])
    unzip (IO [(MVar (), IO ())] -> IO ([MVar ()], [IO ()]))
    -> IO [(MVar (), IO ())] -> IO ([MVar ()], [IO ()])
    forall a b. (a -> b) -> a -> b
    $ [IO ()] -> (IO () -> IO (MVar (), IO ())) -> IO [(MVar (), IO ())]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    t a -> (a -> m b) -> m (t b)
    forM [IO ()]
    actions ((IO () -> IO (MVar (), IO ())) -> IO [(MVar (), IO ())])
    -> (IO () -> IO (MVar (), IO ())) -> IO [(MVar (), IO ())]
    forall a b. (a -> b) -> a -> b
    $ \IO ()
    action -> do
                        mvar <- IO (MVar ())
    forall a. IO (MVar a)
    newEmptyMVar
                        return (mvar, action `finally` putMVar mvar ())
                    -- NB: the takeMVar action MUST be last in the list because the returned actions are
                    -- scheduled left-to-right, and we want all the actions we depend on to be scheduled
                    -- before we wait for them to complete, or we might deadlock.
                    --
                    -- FIXME: this is a bit of a hack because it uses one pool thread just waiting
                    -- for some other pool threads to complete! Switch to parallel-io?
                    return $ Just (run_test, actions' ++ [(cleanup >> mapM_ takeMVar mvars)])

    runTests' :: [StdRunner] -> IO ([RunningTest], [IO ()])
    runTests' :: [StdRunner] -> IO ([RunningTest], [IO ()])
    runTests' = ([Maybe (RunningTest, [IO ()])] -> ([RunningTest], [IO ()]))
    -> IO [Maybe (RunningTest, [IO ()])] -> IO ([RunningTest], [IO ()])
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (([[IO ()]] -> [IO ()])
    -> ([RunningTest], [[IO ()]]) -> ([RunningTest], [IO ()])
    forall b c a. (b -> c) -> (a, b) -> (a, c)
    onRight [[IO ()]] -> [IO ()]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat (([RunningTest], [[IO ()]]) -> ([RunningTest], [IO ()]))
    -> ([Maybe (RunningTest, [IO ()])] -> ([RunningTest], [[IO ()]]))
    -> [Maybe (RunningTest, [IO ()])]
    -> ([RunningTest], [IO ()])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [(RunningTest, [IO ()])] -> ([RunningTest], [[IO ()]])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ([(RunningTest, [IO ()])] -> ([RunningTest], [[IO ()]]))
    -> ([Maybe (RunningTest, [IO ()])] -> [(RunningTest, [IO ()])])
    -> [Maybe (RunningTest, [IO ()])]
    -> ([RunningTest], [[IO ()]])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Maybe (RunningTest, [IO ()])] -> [(RunningTest, [IO ()])]
    forall a. [Maybe a] -> [a]
    catMaybes) (IO [Maybe (RunningTest, [IO ()])] -> IO ([RunningTest], [IO ()]))
    -> ([StdRunner] -> IO [Maybe (RunningTest, [IO ()])])
    -> [StdRunner]
    -> IO ([RunningTest], [IO ()])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (StdRunner -> IO (Maybe (RunningTest, [IO ()])))
    -> [StdRunner] -> IO [Maybe (RunningTest, [IO ()])]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM StdRunner -> IO (Maybe (RunningTest, [IO ()]))
    run

    completeTestOptions :: TestOptions -> CompleteTestOptions
    completeTestOptions :: TestOptions -> CompleteTestOptions
    completeTestOptions TestOptions
    to = TestOptions {
                topt_seed :: K Seed
    topt_seed = Seed -> K Seed
    forall a. a -> K a
    K (Seed -> K Seed) -> Seed -> K Seed
    forall a b. (a -> b) -> a -> b
    $ TestOptions -> Maybe Seed
    forall (f :: * -> *). TestOptions' f -> f Seed
    topt_seed TestOptions
    to Maybe Seed -> Seed -> Seed
    forall a. Maybe a -> a -> a
    `orElse` Seed
    RandomSeed,
                topt_maximum_generated_tests :: K Int
    topt_maximum_generated_tests = Int -> K Int
    forall a. a -> K a
    K (Int -> K Int) -> Int -> K Int
    forall a b. (a -> b) -> a -> b
    $ TestOptions -> Maybe Int
    forall (f :: * -> *). TestOptions' f -> f Int
    topt_maximum_generated_tests TestOptions
    to Maybe Int -> Int -> Int
    forall a. Maybe a -> a -> a
    `orElse` Int
    100,
                topt_maximum_unsuitable_generated_tests :: K Int
    topt_maximum_unsuitable_generated_tests = Int -> K Int
    forall a. a -> K a
    K (Int -> K Int) -> Int -> K Int
    forall a b. (a -> b) -> a -> b
    $ TestOptions -> Maybe Int
    forall (f :: * -> *). TestOptions' f -> f Int
    topt_maximum_unsuitable_generated_tests TestOptions
    to Maybe Int -> Int -> Int
    forall a. Maybe a -> a -> a
    `orElse` Int
    1000,
                topt_maximum_test_size :: K Int
    topt_maximum_test_size = Int -> K Int
    forall a. a -> K a
    K (Int -> K Int) -> Int -> K Int
    forall a b. (a -> b) -> a -> b
    $ TestOptions -> Maybe Int
    forall (f :: * -> *). TestOptions' f -> f Int
    topt_maximum_test_size TestOptions
    to Maybe Int -> Int -> Int
    forall a. Maybe a -> a -> a
    `orElse` Int
    100,
                topt_maximum_test_depth :: K Int
    topt_maximum_test_depth = Int -> K Int
    forall a. a -> K a
    K (Int -> K Int) -> Int -> K Int
    forall a b. (a -> b) -> a -> b
    $ TestOptions -> Maybe Int
    forall (f :: * -> *). TestOptions' f -> f Int
    topt_maximum_test_depth TestOptions
    to Maybe Int -> Int -> Int
    forall a. Maybe a -> a -> a
    `orElse` Int
    5,
                topt_timeout :: K (Maybe Int)
    topt_timeout = Maybe Int -> K (Maybe Int)
    forall a. a -> K a
    K (Maybe Int -> K (Maybe Int)) -> Maybe Int -> K (Maybe Int)
    forall a b. (a -> b) -> a -> b
    $ TestOptions -> Maybe (Maybe Int)
    forall (f :: * -> *). TestOptions' f -> f (Maybe Int)
    topt_timeout TestOptions
    to Maybe (Maybe Int) -> Maybe Int -> Maybe Int
    forall a. Maybe a -> a -> a
    `orElse` Maybe Int
    forall a. Maybe a
    Nothing
            }