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
        }