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
import Control.Exception (mask, finally, onException)
import Control.Monad
import Data.Maybe
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif
import Data.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 (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 ropts tests = do
    let test_patterns = unK $ ropt_test_patterns ropts
        test_options  = unK $ ropt_test_options  ropts
    (run_tests, actions) <- runTests' $ map (runTestTree test_options test_patterns) 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 initialOpts pats topTest = go initialOpts [] topTest
    where
    go opts path t = case t of
        Test name testlike ->
            if null pats || any (`testPatternMatches` (path ++ [name])) pats
                then runSimpleTest opts name testlike
                else skipTest
        TestGroup name tests ->
            let path' = path ++ [name]
            in runGroup name $ map (go opts path') tests
        PlusTestOptions extra_topts test -> go (opts `mappend` extra_topts) path test
        BuildTestBracketed build ->
            runIOTest $ onLeft (go opts path) `fmap` build

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

instance TestRunner StdRunner where
    runSimpleTest topts name testlike = StdRunner $ do
        (result, action) <- runTest (completeTestOptions topts) testlike
        return (Just (RunTest name (testTypeName testlike) (SomeImproving result), [action]))

    skipTest = StdRunner $ return Nothing

    runGroup name tests = StdRunner $ do
        (results, actions) <- runTests' tests
        return $ if null results then Nothing else Just ((RunTestGroup name results), actions)

    runIOTest ioTest = StdRunner $ mask $ \restore -> ioTest >>= \(StdRunner test, cleanup) -> do
        mb_res <- restore test `onException` cleanup
        case mb_res of
            -- No sub-tests: perform the cleanup NOW
            Nothing                  -> cleanup >> return Nothing
            Just (run_test, actions) -> do
                -- Sub-tests: perform the cleanup as soon as each of them have completed
                (mvars, actions') <- liftM unzip $ forM actions $ \action -> do
                    mvar <- 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' = fmap (onRight concat . unzip . catMaybes) . mapM run

completeTestOptions :: TestOptions -> CompleteTestOptions
completeTestOptions to = TestOptions {
            topt_seed = K $ topt_seed to `orElse` RandomSeed,
            topt_maximum_generated_tests = K $ topt_maximum_generated_tests to `orElse` 100,
            topt_maximum_unsuitable_generated_tests = K $ topt_maximum_unsuitable_generated_tests to `orElse` 1000,
            topt_maximum_test_size = K $ topt_maximum_test_size to `orElse` 100,
            topt_maximum_test_depth = K $ topt_maximum_test_depth to `orElse` 5,
            topt_timeout = K $ topt_timeout to `orElse` Nothing
        }