{-# LANGUAGE UndecidableInstances, DeriveDataTypeable #-}
module Test.Framework.Core where

import Test.Framework.Improving
import Test.Framework.Options

import Control.Arrow (first, second)
import Control.Concurrent.MVar ( withMVar, newMVar, MVar )
import Data.Typeable ( Typeable )


-- | Something like the result of a test: works in concert with 'Testlike'.
-- The type parameters are the type that is used for progress reports and the
-- type of the final output of the test respectively.
class (Show i, Show r) => TestResultlike i r | r -> i where
    testSucceeded :: r -> Bool

-- | Something test-like in its behaviour. The type parameters are the type that
-- is used for progress reports, the type of the final output of the test and the
-- data type encapsulating the whole potential to do a test respectively.
class TestResultlike i r => Testlike i r t | t -> i r, r -> i where
    runTest :: CompleteTestOptions -> t -> IO (i :~> r, IO ())
    testTypeName :: t -> TestTypeName


-- | Test names or descriptions. These are shown to the user
type TestName = String

-- | The name of a type of test, such as "Properties" or "Test Cases". Tests of
-- types of the same names will be grouped together in the test run summary.
type TestTypeName = String

-- | Main test data type: builds up a list of tests to be run. Users should use the
-- utility functions in e.g. the test-framework-hunit and test-framework-quickcheck2
-- packages to create instances of 'Test', and then build them up into testsuites
-- by using 'testGroup' and lists.
--
-- For an example of how to use test-framework, please see
-- <http://github.com/batterseapower/test-framework/raw/master/example/Test/Framework/Example.lhs>
data Test = forall i r t.
            (Testlike i r t, Typeable t) => Test TestName t -- ^ A single test of some particular type
          | TestGroup TestName [Test]                       -- ^ Assemble a number of tests into a cohesive group
          | PlusTestOptions TestOptions Test                -- ^ Add some options to child tests
          | BuildTestBracketed (IO (Test, IO ()))           -- ^ Convenience for creating tests from an 'IO' action, with cleanup

-- | Assemble a number of tests into a cohesive group
testGroup :: TestName -> [Test] -> Test
testGroup :: TestName -> [Test] -> Test
testGroup = TestName -> [Test] -> Test
TestGroup

-- | Add some options to child tests
plusTestOptions :: TestOptions -> Test -> Test
plusTestOptions :: TestOptions -> Test -> Test
plusTestOptions = TestOptions -> Test -> Test
PlusTestOptions

-- | Convenience for creating tests from an 'IO' action
buildTest :: IO Test -> Test
buildTest :: IO Test -> Test
buildTest IO Test
mx = IO (Test, IO ()) -> Test
BuildTestBracketed ((Test -> (Test, IO ())) -> IO Test -> IO (Test, IO ())
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Test -> IO () -> (Test, IO ())) -> IO () -> Test -> (Test, IO ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())) IO Test
mx)

-- | Convenience for creating tests from an 'IO' action, with a cleanup handler for when tests are finished
buildTestBracketed :: IO (Test, IO ()) -> Test
buildTestBracketed :: IO (Test, IO ()) -> Test
buildTestBracketed = IO (Test, IO ()) -> Test
BuildTestBracketed


data MutuallyExcluded t = ME (MVar ()) t
    deriving Typeable

-- This requires UndecidableInstances, but I think it can't be made inconsistent?
instance Testlike i r t => Testlike i r (MutuallyExcluded t) where
    runTest :: CompleteTestOptions -> MutuallyExcluded t -> IO (i :~> r, IO ())
runTest CompleteTestOptions
cto (ME MVar ()
mvar t
x) = ((i :~> r, IO ()) -> (i :~> r, IO ()))
-> IO (i :~> r, IO ()) -> IO (i :~> r, 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 ()) -> (i :~> r, IO ()) -> (i :~> r, IO ())
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (\IO ()
act -> MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
mvar ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \() -> IO ()
act)) (IO (i :~> r, IO ()) -> IO (i :~> r, IO ()))
-> IO (i :~> r, IO ()) -> IO (i :~> r, IO ())
forall a b. (a -> b) -> a -> b
$ CompleteTestOptions -> t -> IO (i :~> r, IO ())
forall i r t.
Testlike i r t =>
CompleteTestOptions -> t -> IO (i :~> r, IO ())
runTest CompleteTestOptions
cto t
x
    testTypeName :: MutuallyExcluded t -> TestName
testTypeName ~(ME MVar ()
_ t
x) = t -> TestName
forall i r t. Testlike i r t => t -> TestName
testTypeName t
x

-- | Mark all tests in this portion of the tree as mutually exclusive, so only one runs at a time
{-# NOINLINE mutuallyExclusive #-}
mutuallyExclusive :: Test -> Test
mutuallyExclusive :: Test -> Test
mutuallyExclusive Test
init_t = IO Test -> Test
buildTest (IO Test -> Test) -> IO Test -> Test
forall a b. (a -> b) -> a -> b
$ do
    MVar ()
mvar <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
    let go :: Test -> Test
go (Test TestName
tn t
t)                = TestName -> MutuallyExcluded t -> Test
forall i r t. (Testlike i r t, Typeable t) => TestName -> t -> Test
Test TestName
tn (MVar () -> t -> MutuallyExcluded t
forall t. MVar () -> t -> MutuallyExcluded t
ME MVar ()
mvar t
t)
        go (TestGroup TestName
tn [Test]
ts)          = TestName -> [Test] -> Test
TestGroup TestName
tn ((Test -> Test) -> [Test] -> [Test]
forall a b. (a -> b) -> [a] -> [b]
map Test -> Test
go [Test]
ts)
        go (PlusTestOptions TestOptions
to Test
t)     = TestOptions -> Test -> Test
PlusTestOptions TestOptions
to (Test -> Test
go Test
t)
        go (BuildTestBracketed IO (Test, IO ())
build) = IO (Test, IO ()) -> Test
BuildTestBracketed (((Test, IO ()) -> (Test, IO ()))
-> IO (Test, IO ()) -> IO (Test, IO ())
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Test -> Test) -> (Test, IO ()) -> (Test, IO ())
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Test -> Test
go) IO (Test, IO ())
build)
    Test -> IO Test
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Test -> Test
go Test
init_t)