content: 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
  import Data.Monoid
  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
          }
  