diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,22 @@
+Copyright (c) 2008, Maximilian Bolingbroke
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without modification, are permitted
+provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright notice, this list of
+ conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright notice, this list of
+ conditions and the following disclaimer in the documentation and/or other materials
+ provided with the distribution.
+ * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to
+ endorse or promote products derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
+IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
+OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.textile b/README.textile
new file mode 100644
--- /dev/null
+++ b/README.textile
@@ -0,0 +1,93 @@
+h1. Test Framework
+
+You can help improve this README with extra snippets and advice by using the "GitHub wiki":http://github.com/batterseapower/test-framework/wikis/readme.
+
+
+h2. Installing
+
+To just install the library:
+
+
+runghc Setup.lhs configure
+runghc Setup.lhs build
+sudo runghc Setup.lhs install
+
+
+
+If you want to build the example, to check it's all working:
+
+
+runghc Setup.lhs configure -fexample
+runghc Setup.lhs build
+dist/build/test-framework-example/test-framework-example
+
+
+
+
+h2. Description
+
+A test framework, with built-in support for "HUnit":http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HUnit and "QuickCheck":http://hackage.haskell.org/cgi-bin/hackage-scripts/package/QuickCheck tests. The main benefit of using this framework is that you get a nice console based test runner with the following features:
+
+* Run tests in parallel but report results in a deterministic order (to aid diff-based analysis of test output)
+* Progress reporting for individual QuickCheck properties and for the whole suite being run
+* Filter the tests to be run using patterns specified on the command line
+* Hierarchical, colored display of test results
+* Reporting of test statistics (number of tests run, number failed etc.)
+* Extensibility: add your own test providers above and beyond those provided
+* Seed reporting upon a failed QuickCheck run, so you can reproduce the failure if necessary
+
+
+h2. Example
+
+An example testsuite is provided in the package, which you can build by supplying @-fexample@ to the Cabal @configure@ step as described above. You can also view the most recent version online at "GitHub":http://github.com/batterseapower/test-framework/tree/master/Test/Framework/Example.lhs.
+
+There are two essential components to getting running with the test framework: setting up the tests to be run, and making the program run the tests in the provided console test runner.
+
+You specify the tests to run in your code like so:
+
+
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.Framework.Providers.QuickCheck
+
+tests = [
+ testGroup "Sorting Group 1" [
+ testProperty "sort1" prop_sort1,
+ testProperty "sort2" prop_sort2,
+ testProperty "sort3" prop_sort3
+ ],
+ testGroup "Sorting Group 2" [
+ testProperty "sort4" prop_sort4,
+ testProperty "sort5" prop_sort5,
+ testProperty "sort6" prop_sort6,
+ testCase "sort7" test_sort7,
+ testCase "sort8" test_sort8
+ ]
+ ]
+
+
+
+And set up the console runner by including this in your @Main@ module:
+
+main = defaultMain tests
+
+
+h2. Console Runner Manual
+
+A description of the options available can be obtained by using the option @--help@ on the command line.
+
+The test-selection syntax for use with the @-s@ command line option is based on that of shell globs or "Git .gitignore files":http://www.kernel.org/pub/software/scm/git/docs/gitignore.html. Test patterns are treated as follows:
+
+* An optional prefix @!@ which negates the pattern
+* If the pattern ends with a slash, it is removed for the purpose of the following description, but it would only find a match with a test group. In other words, @foo/@ will match a group called @foo@ and any tests underneath it, but will not match a regular test @foo@.
+* If the pattern does not contain a slash @/@, the framework checks for a match against any single component of the path
+* Otherwise, the pattern is treated as a glob, where the wildcard @*@ matches anything within a single path component (i.e. @foo@ but not @foo/bar@), two wildcards @**@ matches anything (i.e. @foo@ and @foo/bar@) and anything else matches exactly that text in the path (i.e. @foo@ would only match a component of the test path called @foo@ (or a substring of that form). For example, @group/*1@ matches @group/test1@ but not @group/subgroup/test1@, whereas both examples would be matched by @group/**1@. A leading slash matches the beginning of the test path; for example, @/test*@ matches @test1@ but not @group/test1@.
+
+A test will be run if it matches __any__ of the patterns supplied with @-s@.
+
+
+h2. Linkage
+
+* "Hackage":http://hackage.haskell.org/cgi-bin/hackage-scripts/package/test-framework/
+* "Bug Tracker":http://bsp.lighthouseapp.com/projects/15661-hs-test-framework
+* "GitHub":http://github.com/batterseapower/test-framework/
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,4 @@
+#! /usr/bin/env runhaskell
+
+> import Distribution.Simple
+> main = defaultMain
diff --git a/Test/Framework.hs b/Test/Framework.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework.hs
@@ -0,0 +1,13 @@
+module Test.Framework (
+ module Test.Framework.Core,
+ module Test.Framework.Options,
+ module Test.Framework.Runners.Console,
+ module Test.Framework.Runners.Options,
+ module Test.Framework.Seed
+ ) where
+
+import Test.Framework.Core (TestName, testGroup, plusTestOptions)
+import Test.Framework.Options
+import Test.Framework.Runners.Console
+import Test.Framework.Runners.Options
+import Test.Framework.Seed
diff --git a/Test/Framework/Core.hs b/Test/Framework/Core.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Core.hs
@@ -0,0 +1,32 @@
+module Test.Framework.Core where
+
+import Test.Framework.Improving
+import Test.Framework.Options
+
+
+-- | Something like the result of a test: works in concert with 'Testlike'
+class (Show i, Show r) => TestResultlike i r | r -> i where
+ testSucceeded :: r -> Bool
+
+-- | Something test-like in its behaviour
+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"
+type TestTypeName = String
+
+-- | Main test data type: build up a list of tests to be run with this.
+data Test = forall i r t. Testlike i r t => Test TestName t
+ | TestGroup TestName [Test]
+ | PlusTestOptions TestOptions Test
+
+testGroup :: TestName -> [Test] -> Test
+testGroup = TestGroup
+
+plusTestOptions :: TestOptions -> Test -> Test
+plusTestOptions = PlusTestOptions
diff --git a/Test/Framework/Example.lhs b/Test/Framework/Example.lhs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Example.lhs
@@ -0,0 +1,110 @@
+== RUNNING ==
+
+ghc -package test-framework -threaded Example.lhs -o Example
+./Example --maximum-generated-tests=5000 +RTS -N2
+
+
+== ATTRIBUTION ==
+
+Tthe example properties come from the parallel QuickCheck driver (pqc),
+see http://code.haskell.org/~dons/code/pqc/. The BSD license is repeated
+below, per the licensing conditions of pqc.
+
+== LICENSING ==
+
+Copyright Don Stewart 2006.
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Don Stewart nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+\begin{code}
+
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.Framework.Providers.QuickCheck
+
+import Test.QuickCheck
+import Test.HUnit
+
+import Data.List
+
+
+main = defaultMain tests
+
+tests = [
+ testGroup "Sorting Group 1" [
+ testProperty "sort1" prop_sort1,
+ testProperty "sort2" prop_sort2,
+ testProperty "sort3" prop_sort3
+ ],
+ testGroup "Sorting Group 2" [
+ testProperty "sort4" prop_sort4,
+ testProperty "sort5" prop_sort5,
+ testProperty "sort6" prop_sort6,
+ testCase "sort7" test_sort7,
+ testCase "sort8" test_sort8
+ ]
+ ]
+
+
+prop_sort1 xs = sort xs == sortBy compare xs
+ where types = (xs :: [Int])
+
+prop_sort2 xs =
+ (not (null xs)) ==>
+ (head (sort xs) == minimum xs)
+ where types = (xs :: [Int])
+
+prop_sort3 xs = (not (null xs)) ==>
+ last (sort xs) == maximum xs
+ where types = (xs :: [Int])
+
+prop_sort4 xs ys =
+ (not (null xs)) ==>
+ (not (null ys)) ==>
+ (head (sort (xs ++ ys)) == min (minimum xs) (minimum ys))
+ where types = (xs :: [Int], ys :: [Int])
+
+prop_sort5 xs ys =
+ (not (null xs)) ==>
+ (not (null ys)) ==>
+ (head (sort (xs ++ ys)) == max (maximum xs) (maximum ys))
+ where types = (xs :: [Int], ys :: [Int])
+
+prop_sort6 xs ys =
+ (not (null xs)) ==>
+ (not (null ys)) ==>
+ (last (sort (xs ++ ys)) == max (maximum xs) (maximum ys))
+ where types = (xs :: [Int], ys :: [Int])
+
+test_sort7 = sort [8, 7, 2, 5, 4, 9, 6, 1, 0, 3] @?= [0..9]
+
+test_sort8 = error "This test deliberately contains a user error"
+\end{code}
diff --git a/Test/Framework/Improving.hs b/Test/Framework/Improving.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Improving.hs
@@ -0,0 +1,66 @@
+module Test.Framework.Improving (
+ (:~>)(..),
+ ImprovingIO, yieldImprovement, runImprovingIO, liftIO,
+ timeoutImprovingIO, maybeTimeoutImprovingIO
+ ) where
+
+import Control.Concurrent
+import Control.Monad
+
+import System.Timeout
+
+
+data i :~> f = Finished f
+ | Improving i (i :~> f)
+
+instance Functor ((:~>) i) where
+ fmap f (Finished x) = Finished (f x)
+ fmap f (Improving x i) = Improving x (fmap f i)
+
+
+newtype ImprovingIO i f a = IIO { unIIO :: Chan (Either i f) -> IO a }
+
+instance Functor (ImprovingIO i f) where
+ fmap = liftM
+
+instance Monad (ImprovingIO i f) where
+ return x = IIO (const $ return x)
+ ma >>= f = IIO $ \chan -> do
+ a <- unIIO ma chan
+ unIIO (f a) chan
+
+yieldImprovement :: i -> ImprovingIO i f ()
+yieldImprovement improvement = IIO $ \chan -> do
+ -- Whenever we yield an improvement, take the opportunity to yield the thread as well.
+ -- The idea here is to introduce frequent yields in users so that if e.g. they get killed
+ -- by the timeout code then they know about it reasonably promptly.
+ yield
+ writeChan chan (Left improvement)
+
+runImprovingIO :: ImprovingIO i f f -> IO (i :~> f, IO ())
+runImprovingIO iio = do
+ chan <- newChan
+ let action = do
+ result <- unIIO iio chan
+ writeChan chan (Right result)
+ improving_value <- getChanContents chan
+ return (reifyListToImproving improving_value, action)
+
+reifyListToImproving :: [Either i f] -> (i :~> f)
+reifyListToImproving (Left improvement:rest) = Improving improvement (reifyListToImproving rest)
+reifyListToImproving (Right final:_) = Finished final
+reifyListToImproving [] = error "reifyListToImproving: list finished before a final value arrived"
+
+liftIO :: IO a -> ImprovingIO i f a
+liftIO io = IIO $ const io
+
+-- | Given a number of microseconds and an improving IO action, run that improving IO action only
+-- for at most the given period before giving up. See also 'System.Timeout.timeout'.
+timeoutImprovingIO :: Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
+timeoutImprovingIO microseconds iio = IIO $ \chan -> timeout microseconds $ unIIO iio chan
+
+-- | As 'timeoutImprovingIO', but don't bother applying a timeout to the action if @Nothing@ is given
+-- as the number of microseconds to apply the time out for.
+maybeTimeoutImprovingIO :: Maybe Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a)
+maybeTimeoutImprovingIO Nothing = fmap Just
+maybeTimeoutImprovingIO (Just microseconds) = timeoutImprovingIO microseconds
diff --git a/Test/Framework/Options.hs b/Test/Framework/Options.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Options.hs
@@ -0,0 +1,35 @@
+module Test.Framework.Options where
+
+import Test.Framework.Seed
+import Test.Framework.Utilities
+
+import Data.Monoid
+
+
+type TestOptions = TestOptions' Maybe
+type CompleteTestOptions = TestOptions' K
+data TestOptions' f = TestOptions {
+ topt_seed :: f Seed,
+ -- ^ Seed that should be used to create random numbers for generated tests
+ topt_maximum_generated_tests :: f Int,
+ -- ^ Maximum number of tests to generate when using something like QuickCheck
+ topt_maximum_unsuitable_generated_tests :: f Int,
+ -- ^ Maximum number of unsuitable tests to consider before giving up when using something like QuickCheck
+ topt_timeout :: f (Maybe Int)
+ -- ^ The number of microseconds to run tests for before considering them a failure
+ }
+
+instance Monoid (TestOptions' Maybe) where
+ mempty = TestOptions {
+ topt_seed = Nothing,
+ topt_maximum_generated_tests = Nothing,
+ topt_maximum_unsuitable_generated_tests = Nothing,
+ topt_timeout = Nothing
+ }
+
+ mappend to1 to2 = TestOptions {
+ topt_seed = getLast (mappendBy (Last . topt_seed) to1 to2),
+ topt_maximum_generated_tests = getLast (mappendBy (Last . topt_maximum_generated_tests) to1 to2),
+ topt_maximum_unsuitable_generated_tests = getLast (mappendBy (Last . topt_maximum_unsuitable_generated_tests) to1 to2),
+ topt_timeout = getLast (mappendBy (Last . topt_timeout) to1 to2)
+ }
diff --git a/Test/Framework/Providers/API.hs b/Test/Framework/Providers/API.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Providers/API.hs
@@ -0,0 +1,21 @@
+-- | This module exports everything that you need to be able to create your own framework test provider.
+-- To create a provider you need to:
+--
+-- * Create an instance of the 'Testlike' class
+--
+-- * Create an instance of the 'TestResultlike' class
+--
+-- * Expose a function that lets people construct 'Test' values using your new instances
+module Test.Framework.Providers.API (
+ module Test.Framework.Core,
+ module Test.Framework.Improving,
+ module Test.Framework.Options,
+ module Test.Framework.Seed,
+ module Test.Framework.Utilities
+ ) where
+
+import Test.Framework.Core
+import Test.Framework.Improving
+import Test.Framework.Options
+import Test.Framework.Seed
+import Test.Framework.Utilities
diff --git a/Test/Framework/Providers/HUnit.hs b/Test/Framework/Providers/HUnit.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Providers/HUnit.hs
@@ -0,0 +1,56 @@
+module Test.Framework.Providers.HUnit (
+ testCase
+ ) where
+
+import Test.Framework.Providers.API
+
+import Test.HUnit.Lang
+
+
+-- | Create a 'Test' for a HUnit 'Assertion'
+testCase :: TestName -> Assertion -> Test
+testCase name = Test name . TestCase
+
+
+instance TestResultlike TestCaseRunning TestCaseResult where
+ testSucceeded = testCaseSucceeded
+
+data TestCaseRunning = TestCaseRunning
+
+instance Show TestCaseRunning where
+ show TestCaseRunning = "Running"
+
+data TestCaseResult = TestCasePassed
+ | TestCaseFailed String
+ | TestCaseError String
+
+instance Show TestCaseResult where
+ show result = case result of
+ TestCasePassed -> "OK"
+ TestCaseFailed message -> "Failed: " ++ message
+ TestCaseError message -> "ERROR: " ++ message
+
+testCaseSucceeded :: TestCaseResult -> Bool
+testCaseSucceeded TestCasePassed = True
+testCaseSucceeded _ = False
+
+
+newtype TestCase = TestCase Assertion
+
+instance Testlike TestCaseRunning TestCaseResult TestCase where
+ runTest topts (TestCase assertion) = runTestCase topts assertion
+ testTypeName _ = "Test Cases"
+
+runTestCase :: CompleteTestOptions -> Assertion -> IO (TestCaseRunning :~> TestCaseResult, IO ())
+runTestCase topts assertion = runImprovingIO $ do
+ yieldImprovement TestCaseRunning
+ mb_result <- maybeTimeoutImprovingIO (unK $ topt_timeout topts) $ liftIO (myPerformTestCase assertion)
+ return (mb_result `orElse` TestCaseError "Timed out")
+
+myPerformTestCase :: Assertion -> IO TestCaseResult
+myPerformTestCase assertion = do
+ result <- performTestCase assertion
+ return $ case result of
+ Nothing -> TestCasePassed
+ Just (True, message) -> TestCaseFailed message
+ Just (False, message) -> TestCaseError message
diff --git a/Test/Framework/Providers/QuickCheck.hs b/Test/Framework/Providers/QuickCheck.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Providers/QuickCheck.hs
@@ -0,0 +1,96 @@
+module Test.Framework.Providers.QuickCheck (
+ testProperty
+ ) where
+
+import Test.Framework.Providers.API
+
+import Test.QuickCheck hiding (Property)
+
+import Data.List
+
+import System.Random
+
+
+-- | Create a 'Test' for a QuickCheck 'Testable' property
+testProperty :: Testable a => TestName -> a -> Test
+testProperty name = Test name . Property
+
+
+instance TestResultlike PropertyTestCount PropertyResult where
+ testSucceeded = propertySucceeded
+
+-- | Used to document numbers which we expect to be intermediate test counts from running properties
+type PropertyTestCount = Int
+
+-- | The failure information from the run of a property
+data PropertyResult = PropertyResult {
+ pr_status :: PropertyStatus,
+ pr_used_seed :: Int,
+ pr_tests_run :: Maybe PropertyTestCount -- Due to technical limitations, it's currently not possible to find out the number of
+ -- tests previously run if the test times out, hence we need a Maybe here for that case.
+ }
+
+data PropertyStatus = PropertyOK -- ^ The property is true as far as we could check it
+ | PropertyArgumentsExhausted -- ^ The property may be true, but we ran out of arguments to try it out on
+ | PropertyFalsifiable [String] -- ^ The property was not true. The list of strings are the arguments inducing failure.
+ | PropertyTimedOut -- ^ The property timed out during execution
+
+instance Show PropertyResult where
+ show (PropertyResult { pr_status = status, pr_used_seed = used_seed, pr_tests_run = mb_tests_run })
+ = case status of
+ PropertyOK -> "OK, passed " ++ tests_run_str ++ " tests"
+ PropertyArgumentsExhausted -> "Arguments exhausted after " ++ tests_run_str ++ " tests"
+ PropertyFalsifiable test_args -> "Falsifiable with seed " ++ show used_seed ++ ", after " ++ tests_run_str ++ " tests:\n" ++ unlinesConcise test_args
+ PropertyTimedOut -> "Timed out after " ++ tests_run_str ++ " tests"
+ where
+ tests_run_str = fmap show mb_tests_run `orElse` "an unknown number of"
+
+propertySucceeded :: PropertyResult -> Bool
+propertySucceeded result = propertyStatusIsSuccess (pr_status result)
+
+propertyStatusIsSuccess :: PropertyStatus -> Bool
+propertyStatusIsSuccess PropertyOK = True
+propertyStatusIsSuccess PropertyArgumentsExhausted = True
+propertyStatusIsSuccess _ = False
+
+
+data Property = forall a. Testable a => Property a
+
+instance Testlike PropertyTestCount PropertyResult Property where
+ runTest topts (Property testable) = runProperty topts testable
+ testTypeName _ = "Properties"
+
+runProperty :: Testable a => CompleteTestOptions -> a -> IO (PropertyTestCount :~> PropertyResult, IO ())
+runProperty topts testable = do
+ (gen, seed) <- newSeededStdGen (unK $ topt_seed topts)
+ runImprovingIO $ do
+ mb_result <- maybeTimeoutImprovingIO (unK (topt_timeout topts)) $ myCheck topts gen testable
+ return $ toPropertyResult seed $ case mb_result of
+ Nothing -> (PropertyTimedOut, Nothing)
+ Just (status, tests_run) -> (status, Just tests_run)
+ where
+ toPropertyResult seed (status, mb_tests_run) = PropertyResult {
+ pr_status = status,
+ pr_used_seed = seed,
+ pr_tests_run = mb_tests_run
+ }
+
+myCheck :: (Testable a) => CompleteTestOptions -> StdGen -> a -> ImprovingIO PropertyTestCount f (PropertyStatus, PropertyTestCount)
+myCheck topts rnd a = myTests topts (evaluate a) rnd 0 0 []
+
+myTests :: CompleteTestOptions -> Gen Result -> StdGen -> PropertyTestCount -> PropertyTestCount -> [[String]] -> ImprovingIO PropertyTestCount f (PropertyStatus, PropertyTestCount)
+myTests topts gen rnd0 ntest nfail stamps
+ | ntest == unK (topt_maximum_generated_tests topts) = do return (PropertyOK, ntest)
+ | nfail == unK (topt_maximum_unsuitable_generated_tests topts) = do return (PropertyArgumentsExhausted, ntest)
+ | otherwise = do
+ yieldImprovement ntest
+ case ok result of
+ Nothing ->
+ myTests topts gen rnd1 ntest (nfail + 1) stamps
+ Just True ->
+ myTests topts gen rnd1 (ntest + 1) nfail (stamp result:stamps)
+ Just False ->
+ return (PropertyFalsifiable (arguments result), ntest)
+ where
+ result = generate (configSize defaultConfig ntest) rnd2 gen
+ (rnd1, rnd2) = split rnd0
diff --git a/Test/Framework/Runners/Console.hs b/Test/Framework/Runners/Console.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Runners/Console.hs
@@ -0,0 +1,210 @@
+module Test.Framework.Runners.Console (
+ defaultMain, defaultMainWithArgs, defaultMainWithOpts
+ ) where
+
+import Test.Framework.Core
+import Test.Framework.Improving
+import Test.Framework.Options
+import Test.Framework.Runners.Console.Colors
+import Test.Framework.Runners.Console.ProgressBar
+import Test.Framework.Runners.Console.Statistics
+import Test.Framework.Runners.Console.Utilities
+import Test.Framework.Runners.Core
+import Test.Framework.Runners.Options
+import Test.Framework.Runners.Processors
+import Test.Framework.Runners.TimedConsumption
+import Test.Framework.Seed
+import Test.Framework.Utilities
+
+import System.Console.ANSI
+import System.Console.GetOpt
+import System.Environment
+import System.Exit
+import System.IO
+
+import Text.PrettyPrint.ANSI.Leijen
+
+import Data.List
+import Data.Maybe
+import Data.Monoid
+
+import Control.Monad
+
+
+instance Functor OptDescr where
+ fmap f (Option a b arg_descr c) = Option a b (fmap f arg_descr) c
+
+instance Functor ArgDescr where
+ fmap f (NoArg a) = NoArg (f a)
+ fmap f (ReqArg g s) = ReqArg (f . g) s
+ fmap f (OptArg g s) = OptArg (f . g) s
+
+-- | @Nothing@ signifies that usage information should be displayed.
+-- @Just@ simply gives us the contribution to overall options by the command line option.
+type SuppliedRunnerOptions = Maybe RunnerOptions
+
+optionsDescription :: [OptDescr SuppliedRunnerOptions]
+optionsDescription = [
+ Option [] ["help"]
+ (NoArg Nothing)
+ "show this help message"
+ ] ++ map (fmap Just) [
+ Option ['j'] ["threads"]
+ (ReqArg (\t -> mempty { ropt_threads = Just (read t) }) "NUMBER")
+ "number of threads to use to run tests",
+ Option [] ["test-seed"]
+ (ReqArg (\t -> mempty { ropt_test_options = Just (mempty { topt_seed = Just (read t) }) }) ("NUMBER|" ++ show RandomSeed))
+ "default seed for test random number generator",
+ Option ['a'] ["maximum-generated-tests"]
+ (ReqArg (\t -> mempty { ropt_test_options = Just (mempty { topt_maximum_generated_tests = Just (read t) }) }) "NUMBER")
+ "how many automated tests something like QuickCheck should try, by default",
+ Option [] ["maximum-unsuitable-generated-tests"]
+ (ReqArg (\t -> mempty { ropt_test_options = Just (mempty { topt_maximum_unsuitable_generated_tests = Just (read t) }) }) "NUMBER")
+ "how many unsuitable candidate tests something like QuickCheck should endure before giving up, by default",
+ Option ['o'] ["timeout"]
+ (ReqArg (\t -> mempty { ropt_test_options = Just (mempty { topt_timeout = Just (Just (secondsToMicroseconds (read t))) }) }) "NUMBER")
+ "how many seconds a test should be run for before giving up, by default",
+ Option [] ["no-timeout"]
+ (NoArg (mempty { ropt_test_options = Just (mempty { topt_timeout = Just Nothing }) }))
+ "specifies that tests should be run without a timeout, by default",
+ Option ['t'] ["select-tests"]
+ (ReqArg (\t -> mempty { ropt_test_patterns = Just [read t] }) "TEST-PATTERN")
+ "only tests that match at least one glob pattern given by an instance of this argument will be run"
+ ]
+
+interpretArgs :: [String] -> IO (Either String (RunnerOptions, [String]))
+interpretArgs args = do
+ prog_name <- getProgName
+ let usage_header = "Usage: " ++ prog_name ++ " [OPTIONS]"
+
+ case getOpt Permute optionsDescription args of
+ (oas, n, []) | Just os <- sequence oas -> return $ Right (mconcat os, n)
+ (_, _, errs) -> return $ Left (concat errs ++ usageInfo usage_header optionsDescription)
+
+
+defaultMain :: [Test] -> IO ()
+defaultMain tests = do
+ args <- getArgs
+ defaultMainWithArgs tests args
+
+defaultMainWithArgs :: [Test] -> [String] -> IO ()
+defaultMainWithArgs tests args = do
+ interpreted_args <- interpretArgs args
+ case interpreted_args of
+ Right (ropts, []) -> defaultMainWithOpts tests ropts
+ Right (_, leftovers) -> do
+ putStrLn $ "Could not understand these extra arguments: " ++ unwords leftovers
+ exitWith (ExitFailure 1)
+ Left error_message -> do
+ putStrLn error_message
+ exitWith (ExitFailure 1)
+
+defaultMainWithOpts :: [Test] -> RunnerOptions -> IO ()
+defaultMainWithOpts tests ropts = hideCursorIn $ do
+ let ropts' = completeRunnerOptions ropts
+
+ -- Get a lazy list of the test results, as executed in parallel
+ run_tests <- runTests ropts' tests
+
+ -- Show those test results to the user as we get them
+ let test_statistics = initialTestStatistics (totalRunTestsList run_tests)
+ test_statistics' <- showRunTests 0 test_statistics run_tests
+
+ -- Show the final statistics
+ putStrLn ""
+ putDoc $ showFinalTestStatistics test_statistics'
+
+ -- Set the error code depending on whether the tests succeded or not
+ exitWith $ if ts_no_failures test_statistics'
+ then ExitSuccess
+ else ExitFailure 1
+
+
+completeRunnerOptions :: RunnerOptions -> CompleteRunnerOptions
+completeRunnerOptions ro = RunnerOptions {
+ ropt_threads = K $ ropt_threads ro `orElse` processorCount,
+ ropt_test_options = K $ ropt_test_options ro `orElse` mempty,
+ ropt_test_patterns = K $ ropt_test_patterns ro `orElse` mempty
+ }
+
+
+totalRunTests :: RunTest -> TestCount
+totalRunTests (RunTest _ test_type _) = adjustTestCount test_type 1 mempty
+totalRunTests (RunTestGroup _ tests) = totalRunTestsList tests
+
+totalRunTestsList :: [RunTest] -> TestCount
+totalRunTestsList = mconcat . map totalRunTests
+
+
+-- This code all /really/ sucks. There must be a better way to seperate out the console-updating
+-- and the improvement-traversing concerns - but how?
+showRunTest :: Int -> TestStatistics -> RunTest -> IO TestStatistics
+showRunTest indent_level test_statistics (RunTest name test_type improving_result) = do
+ let progress_bar = testStatisticsProgressBar test_statistics
+ property_suceeded <- showImprovingTestResult (return ()) indent_level name progress_bar improving_result
+ return $ updateTestStatistics (\count -> adjustTestCount test_type count mempty) property_suceeded test_statistics
+showRunTest indent_level test_statistics (RunTestGroup name tests) = do
+ putDoc $ indent indent_level (text name <> char ':' <> linebreak)
+ showRunTests (indent_level + 2) test_statistics tests
+
+showRunTests :: Int -> TestStatistics -> [RunTest] -> IO TestStatistics
+showRunTests indent_level = foldM (showRunTest indent_level)
+
+
+testStatisticsProgressBar :: TestStatistics -> Doc
+testStatisticsProgressBar test_statistics = showProgressBar (colorPassOrFail no_failures) 80 (Progress run_tests total_tests)
+ where
+ run_tests = testCountTotal (ts_run_tests test_statistics)
+ total_tests = testCountTotal (ts_total_tests test_statistics)
+ no_failures = ts_no_failures test_statistics
+
+updateTestStatistics :: (Int -> TestCount) -> Bool -> TestStatistics -> TestStatistics
+updateTestStatistics count_constructor test_suceeded test_statistics = test_statistics {
+ ts_run_tests = ts_run_tests test_statistics `mappend` (count_constructor 1),
+ ts_failed_tests = ts_failed_tests test_statistics `mappend` (count_constructor (if test_suceeded then 0 else 1)),
+ ts_passed_tests = ts_passed_tests test_statistics `mappend` (count_constructor (if test_suceeded then 1 else 0))
+ }
+
+
+consumeImprovingThing :: (a :~> b) -> [(a :~> b)]
+consumeImprovingThing improving@(Finished _) = [improving]
+consumeImprovingThing improving@(Improving _ rest) = improving : consumeImprovingThing rest
+
+
+showImprovingTestResult :: TestResultlike i r => IO () -> Int -> String -> Doc -> (i :~> r) -> IO Bool
+showImprovingTestResult erase indent_level test_name progress_bar improving = do
+ -- Update the screen every every 200ms
+ improving_list <- consumeListInInterval 200000 (consumeImprovingThing improving)
+ case listToMaybeLast improving_list of
+ Nothing -> do -- 200ms was somehow not long enough for a single result to arrive: try again!
+ showImprovingTestResult erase indent_level test_name progress_bar improving
+ Just improving' -> do -- Display that new improving value to the user
+ showImprovingTestResult' erase indent_level test_name progress_bar improving'
+
+showImprovingTestResult' :: TestResultlike i r => IO () -> Int -> String -> Doc -> (i :~> r) -> IO Bool
+showImprovingTestResult' erase indent_level test_name _ (Finished result) = do
+ erase
+ -- Output the final test status and a trailing newline
+ putTestHeader indent_level test_name result_doc
+ -- There may still be a progress bar on the line below the final test result, so
+ -- remove it as a precautionary measure in case this is the last test in a group
+ -- and hence it will not be erased in the normal course of test display.
+ clearLine
+ -- Output any extra information that may be required, e.g. to show failure reason
+ putDoc extra_doc
+ return success
+ where
+ success = testSucceeded result
+ (result_doc, extra_doc) | success = (brackets $ colorPass (text (show result)), empty)
+ | otherwise = (brackets (colorFail (text "Failed")), text (show result) <> linebreak)
+showImprovingTestResult' erase indent_level test_name progress_bar (Improving intermediate rest) = do
+ erase
+ putTestHeader indent_level test_name (brackets (text intermediate_str))
+ putDoc progress_bar
+ hFlush stdout
+ showImprovingTestResult (previousLine 1 >> clearLine) indent_level test_name progress_bar rest
+ where
+ intermediate_str = show intermediate
+
+putTestHeader :: Int -> String -> Doc -> IO ()
+putTestHeader indent_level test_name result = putDoc $ indent indent_level (text test_name <> char ':' <+> result) <> linebreak
diff --git a/Test/Framework/Runners/Console/Colors.hs b/Test/Framework/Runners/Console/Colors.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Runners/Console/Colors.hs
@@ -0,0 +1,12 @@
+module Test.Framework.Runners.Console.Colors where
+
+import Text.PrettyPrint.ANSI.Leijen
+
+
+colorFail, colorPass :: Doc -> Doc
+colorFail = red
+colorPass = green
+
+colorPassOrFail :: Bool -> Doc -> Doc
+colorPassOrFail True = colorPass
+colorPassOrFail False = colorFail
diff --git a/Test/Framework/Runners/Console/ProgressBar.hs b/Test/Framework/Runners/Console/ProgressBar.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Runners/Console/ProgressBar.hs
@@ -0,0 +1,19 @@
+module Test.Framework.Runners.Console.ProgressBar (
+ Progress(..), showProgressBar
+ ) where
+
+import Text.PrettyPrint.ANSI.Leijen hiding (width)
+
+
+data Progress = Progress Int Int
+
+showProgressBar :: (Doc -> Doc) -> Int -> Progress -> Doc
+showProgressBar color width (Progress count total) = char '[' <> progress_doc <> space_doc <> char ']'
+ where
+ -- The available width takes account of the enclosing brackets
+ available_width = width - 2
+ characters_per_tick = fromIntegral available_width / fromIntegral total :: Double
+ progress_chars = round (characters_per_tick * fromIntegral count)
+ space_chars = available_width - progress_chars
+ progress_doc = color (text (reverse (take progress_chars ('>' : repeat '='))))
+ space_doc = text (replicate space_chars ' ')
diff --git a/Test/Framework/Runners/Console/Statistics.hs b/Test/Framework/Runners/Console/Statistics.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Runners/Console/Statistics.hs
@@ -0,0 +1,97 @@
+module Test.Framework.Runners.Console.Statistics (
+ TestCount, adjustTestCount, testCountTotal,
+ TestStatistics(..), ts_pending_tests, ts_no_failures, initialTestStatistics, showFinalTestStatistics
+ ) where
+
+import Test.Framework.Core (TestTypeName)
+import Test.Framework.Runners.Console.Colors
+import Test.Framework.Runners.Console.Table
+
+import Text.PrettyPrint.ANSI.Leijen
+
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Monoid
+
+
+-- | Records a count of the various kinds of test that have been run
+newtype TestCount = TestCount { unTestCount :: Map TestTypeName Int }
+
+testCountTestTypes :: TestCount -> [TestTypeName]
+testCountTestTypes = Map.keys . unTestCount
+
+testCountForType :: String -> TestCount -> Int
+testCountForType test_type = Map.findWithDefault 0 test_type . unTestCount
+
+adjustTestCount :: String -> Int -> TestCount -> TestCount
+adjustTestCount test_type amount = TestCount . Map.insertWith (+) test_type amount . unTestCount
+
+
+-- | The number of tests of all kinds recorded in the given 'TestCount'
+testCountTotal :: TestCount -> Int
+testCountTotal = sum . Map.elems . unTestCount
+
+instance Monoid TestCount where
+ mempty = TestCount $ Map.empty
+ mappend (TestCount tcm1) (TestCount tcm2) = TestCount $ Map.unionWith (+) tcm1 tcm2
+
+minusTestCount :: TestCount -> TestCount -> TestCount
+minusTestCount (TestCount tcm1) (TestCount tcm2) = TestCount $ Map.unionWith (-) tcm1 tcm2
+
+
+-- | Records information about the run of a number of tests, such
+-- as how many tests have been run, how many are pending and how
+-- many have passed or failed.
+data TestStatistics = TestStatistics {
+ ts_total_tests :: TestCount,
+ ts_run_tests :: TestCount,
+ ts_passed_tests :: TestCount,
+ ts_failed_tests :: TestCount
+ }
+
+ts_pending_tests :: TestStatistics -> TestCount
+ts_pending_tests ts = ts_total_tests ts `minusTestCount` ts_run_tests ts
+
+ts_no_failures :: TestStatistics -> Bool
+ts_no_failures ts = testCountTotal (ts_failed_tests ts) <= 0
+
+-- | Create some test statistics that simply records the total number of
+-- tests to be run, ready to be updated by the actual test runs.
+initialTestStatistics :: TestCount -> TestStatistics
+initialTestStatistics total_tests = TestStatistics {
+ ts_total_tests = total_tests,
+ ts_run_tests = mempty,
+ ts_passed_tests = mempty,
+ ts_failed_tests = mempty
+ }
+
+-- | Displays statistics as a string something like this:
+--
+-- @
+-- Properties Total
+-- Passed 9 9
+-- Failed 1 1
+-- Total 10 10
+-- @
+showFinalTestStatistics :: TestStatistics -> Doc
+showFinalTestStatistics ts = renderTable $ [Column label_column] ++ (map Column test_type_columns) ++ [Column total_column]
+ where
+ test_types = sort $ testCountTestTypes (ts_total_tests ts)
+
+ label_column = [TextCell empty, TextCell (text "Passed"), TextCell (text "Failed"), TextCell (text "Total")]
+ total_column = [TextCell (text "Total"), testStatusTotal colorPass ts_passed_tests, testStatusTotal colorFail ts_failed_tests, testStatusTotal (colorPassOrFail (ts_no_failures ts)) ts_total_tests]
+ test_type_columns = [ [TextCell (text test_type), testStat colorPass (countTests ts_passed_tests), testStat colorFail failures, testStat (colorPassOrFail (failures <= 0)) (countTests ts_total_tests)]
+ | test_type <- test_types
+ , let countTests = testCountForType test_type . ($ ts)
+ failures = countTests ts_failed_tests ]
+
+ testStatusTotal color status_accessor = TextCell (coloredNumber color (testCountTotal (status_accessor ts)))
+ testStat color number = TextCell (coloredNumber color number)
+
+coloredNumber :: (Doc -> Doc) -> Int -> Doc
+coloredNumber color number
+ | number == 0 = number_doc
+ | otherwise = color number_doc
+ where
+ number_doc = text (show number)
diff --git a/Test/Framework/Runners/Console/Table.hs b/Test/Framework/Runners/Console/Table.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Runners/Console/Table.hs
@@ -0,0 +1,72 @@
+module Test.Framework.Runners.Console.Table (
+ Cell(..), Column(..), renderTable
+ ) where
+
+import Test.Framework.Utilities
+
+import Text.PrettyPrint.ANSI.Leijen hiding (column)
+
+
+data Cell = TextCell Doc
+ | SeperatorCell
+
+data Column = Column [Cell]
+ | SeperatorColumn
+
+type ColumnWidth = Int
+
+renderTable :: [Column] -> Doc
+renderTable = renderColumnsWithWidth . map (\column -> (findColumnWidth column, column))
+
+
+findColumnWidth :: Column -> Int
+findColumnWidth SeperatorColumn = 0
+findColumnWidth (Column cells) = maximum (map findCellWidth cells)
+
+findCellWidth :: Cell -> Int
+findCellWidth (TextCell doc) = maximum (0 : map length (lines (shows doc "")))
+findCellWidth SeperatorCell = 0
+
+
+renderColumnsWithWidth :: [(ColumnWidth, Column)] -> Doc
+renderColumnsWithWidth columns
+ | all (columnFinished . snd) columns
+ = empty
+ | otherwise
+ = first_cells_str <> line <>
+ renderColumnsWithWidth (map (onRight columnDropHead) columns)
+ where
+ first_cells_str = hcat $ zipWith (uncurry renderFirstColumnCell) columns (eitherSideSeperator (map snd columns))
+
+
+eitherSideSeperator :: [Column] -> [Bool]
+eitherSideSeperator columns = zipWith (||) (False:column_is_seperator) (tail column_is_seperator ++ [False])
+ where
+ column_is_seperator = map isSeperatorColumn columns
+
+isSeperatorColumn :: Column -> Bool
+isSeperatorColumn SeperatorColumn = False
+isSeperatorColumn (Column cells) = case cells of
+ [] -> False
+ (cell:_) -> isSeperatorCell cell
+
+isSeperatorCell :: Cell -> Bool
+isSeperatorCell SeperatorCell = True
+isSeperatorCell _ = False
+
+
+renderFirstColumnCell :: ColumnWidth -> Column -> Bool -> Doc
+renderFirstColumnCell column_width (Column cells) _ = case cells of
+ [] -> text $ replicate (column_width + 2) ' '
+ (SeperatorCell:_) -> text $ replicate (column_width + 2) '-'
+ (TextCell contents:_) -> char ' ' <> fill column_width contents <> char ' '
+renderFirstColumnCell _ SeperatorColumn either_side_seperator
+ = if either_side_seperator then char '+' else char '|'
+
+columnFinished :: Column -> Bool
+columnFinished (Column cells) = null cells
+columnFinished SeperatorColumn = True
+
+columnDropHead :: Column -> Column
+columnDropHead (Column cells) = Column (drop 1 cells)
+columnDropHead SeperatorColumn = SeperatorColumn
diff --git a/Test/Framework/Runners/Console/Utilities.hs b/Test/Framework/Runners/Console/Utilities.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Runners/Console/Utilities.hs
@@ -0,0 +1,15 @@
+module Test.Framework.Runners.Console.Utilities (
+ hideCursorIn
+ ) where
+
+import System.Console.ANSI
+
+import Control.Exception
+
+import Prelude hiding (catch)
+
+
+hideCursorIn :: IO () -> IO ()
+hideCursorIn action = do
+ hideCursor
+ catch (action >> showCursor) (\exception -> showCursor >> throwIO exception)
diff --git a/Test/Framework/Runners/Core.hs b/Test/Framework/Runners/Core.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Runners/Core.hs
@@ -0,0 +1,70 @@
+module Test.Framework.Runners.Core (
+ RunTest(..), runTests
+ ) 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.Monad
+
+import Data.List
+import Data.Maybe
+import Data.Monoid
+
+
+-- | A test that has been executed
+data RunTest = forall i r. TestResultlike i r => RunTest TestName TestTypeName (i :~> r)
+ | RunTestGroup TestName [RunTest]
+
+runTests :: CompleteRunnerOptions -- ^ Top-level runner options
+ -> [Test] -- ^ Tests to run
+ -> IO [RunTest]
+runTests ropts tests = do
+ let test_patterns = unK $ ropt_test_patterns ropts
+ tests' | null test_patterns = tests
+ | otherwise = filterTests test_patterns [] tests
+ (run_tests, actions) <- runTests' (unK $ ropt_test_options ropts) tests'
+ executeOnPool (unK $ ropt_threads ropts) actions
+ return run_tests
+
+
+filterTests :: [TestPattern] -> [String] -> [Test] -> [Test]
+filterTests patterns path = mapMaybe (filterTest patterns path)
+
+filterTest :: [TestPattern] -> [String] -> Test -> Maybe Test
+filterTest patterns path test@(Test name _)
+ | any (`testPatternMatches` (path ++ [name])) patterns = Just test
+ | otherwise = Nothing
+filterTest patterns path (TestGroup name tests)
+ | null tests' = Nothing
+ | otherwise = Just (TestGroup name tests')
+ where
+ tests' = filterTests patterns (path ++ [name]) tests
+filterTest patterns path (PlusTestOptions topts inner_test)
+ = fmap (PlusTestOptions topts) (filterTest patterns path inner_test)
+
+
+runTest' :: TestOptions -> Test -> IO (RunTest, [IO ()])
+runTest' topts (Test name testlike) = do
+ (result, action) <- runTest (completeTestOptions topts) testlike
+ return (RunTest name (testTypeName testlike) result, [action])
+runTest' topts (TestGroup name tests) = fmap (onLeft (RunTestGroup name)) $ runTests' topts tests
+runTest' topts (PlusTestOptions extra_topts test) = runTest' (topts `mappend` extra_topts) test
+
+runTests' :: TestOptions -> [Test] -> IO ([RunTest], [IO ()])
+runTests' topts = fmap (onRight concat . unzip) . mapM (runTest' topts)
+
+
+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_timeout = K $ topt_timeout to `orElse` Nothing
+ }
diff --git a/Test/Framework/Runners/Options.hs b/Test/Framework/Runners/Options.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Runners/Options.hs
@@ -0,0 +1,29 @@
+module Test.Framework.Runners.Options where
+
+import Test.Framework.Options
+import Test.Framework.Utilities
+import Test.Framework.Runners.TestPattern
+
+import Data.Monoid
+
+
+type RunnerOptions = RunnerOptions' Maybe
+type CompleteRunnerOptions = RunnerOptions' K
+data RunnerOptions' f = RunnerOptions {
+ ropt_threads :: f Int,
+ ropt_test_options :: f TestOptions,
+ ropt_test_patterns :: f [TestPattern]
+ }
+
+instance Monoid (RunnerOptions' Maybe) where
+ mempty = RunnerOptions {
+ ropt_threads = Nothing,
+ ropt_test_options = Nothing,
+ ropt_test_patterns = Nothing
+ }
+
+ mappend ro1 ro2 = RunnerOptions {
+ ropt_threads = getLast (mappendBy (Last . ropt_threads) ro1 ro2),
+ ropt_test_options = mappendBy ropt_test_options ro1 ro2,
+ ropt_test_patterns = mappendBy ropt_test_patterns ro1 ro2
+ }
diff --git a/Test/Framework/Runners/Processors.hs b/Test/Framework/Runners/Processors.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Runners/Processors.hs
@@ -0,0 +1,17 @@
+module Test.Framework.Runners.Processors (
+ processorCount
+ ) where
+
+#ifdef COMPILER_GHC
+
+import GHC.Conc ( numCapabilities )
+
+processorCount :: Int
+processorCount = numCapabilities
+
+#else
+
+processorCount :: Int
+processorCount = 1
+
+#endif
diff --git a/Test/Framework/Runners/TestPattern.hs b/Test/Framework/Runners/TestPattern.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Runners/TestPattern.hs
@@ -0,0 +1,93 @@
+module Test.Framework.Runners.TestPattern (
+ TestPattern, parseTestPattern, testPatternMatches
+ ) where
+
+import Test.Framework.Utilities
+
+import Text.Regex.Posix.Wrap
+import Text.Regex.Posix.String()
+
+import Data.List
+
+
+data Token = SlashToken
+ | WildcardToken
+ | DoubleWildcardToken
+ | LiteralToken Char
+ deriving (Eq)
+
+tokenize :: String -> [Token]
+tokenize ('/':rest) = SlashToken : tokenize rest
+tokenize ('*':'*':rest) = DoubleWildcardToken : tokenize rest
+tokenize ('*':rest) = WildcardToken : tokenize rest
+tokenize (c:rest) = LiteralToken c : tokenize rest
+tokenize [] = []
+
+
+data TestPatternMatchMode = TestMatchMode
+ | PathMatchMode
+
+data TestPattern = TestPattern {
+ tp_categories_only :: Bool,
+ tp_negated :: Bool,
+ tp_match_mode :: TestPatternMatchMode,
+ tp_tokens :: [Token]
+ }
+
+instance Read TestPattern where
+ readsPrec _ string = [(parseTestPattern string, "")]
+
+parseTestPattern :: String -> TestPattern
+parseTestPattern string = TestPattern {
+ tp_categories_only = categories_only,
+ tp_negated = negated,
+ tp_match_mode = match_mode,
+ tp_tokens = tokens''
+ }
+ where
+ tokens = tokenize string
+ (negated, tokens')
+ | (LiteralToken '!'):rest <- tokens = (True, rest)
+ | otherwise = (False, tokens)
+ (categories_only, tokens'')
+ | (prefix, [SlashToken]) <- splitAt (length tokens' - 1) tokens' = (True, prefix)
+ | otherwise = (False, tokens')
+ match_mode
+ | SlashToken `elem` tokens = PathMatchMode
+ | otherwise = TestMatchMode
+
+
+testPatternMatches :: TestPattern -> [String] -> Bool
+testPatternMatches test_pattern path = not_maybe $ any (=~ tokens_regex) things_to_match
+ where
+ not_maybe | tp_negated test_pattern = not
+ | otherwise = id
+ path_to_consider | tp_categories_only test_pattern = dropLast 1 path
+ | otherwise = path
+ tokens_regex = buildTokenRegex (tp_tokens test_pattern)
+
+ things_to_match = case tp_match_mode test_pattern of
+ -- See if the tokens match any single path component
+ TestMatchMode -> path_to_consider
+ -- See if the tokens match any prefix of the path
+ PathMatchMode -> map pathToString $ inits path_to_consider
+
+
+buildTokenRegex :: [Token] -> String
+buildTokenRegex [] = []
+buildTokenRegex (token:tokens) = concat (firstTokenToRegex token : map tokenToRegex tokens)
+ where
+ firstTokenToRegex SlashToken = "^"
+ firstTokenToRegex other = tokenToRegex other
+
+ tokenToRegex SlashToken = "/"
+ tokenToRegex WildcardToken = "[^/]*"
+ tokenToRegex DoubleWildcardToken = "*"
+ tokenToRegex (LiteralToken lit) = regexEscapeChar lit
+
+regexEscapeChar :: Char -> String
+regexEscapeChar c | c `elem` "\\*+?|{}[]()^$." = '\\' : [c]
+ | otherwise = [c]
+
+pathToString :: [String] -> String
+pathToString path = "/" ++ concat (intersperse "/" path)
diff --git a/Test/Framework/Runners/ThreadPool.hs b/Test/Framework/Runners/ThreadPool.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Runners/ThreadPool.hs
@@ -0,0 +1,83 @@
+module Test.Framework.Runners.ThreadPool (
+ executeOnPool
+ ) where
+
+import Control.Concurrent
+import Control.Concurrent.Chan
+import Control.Monad
+
+import qualified Data.IntMap as IM
+
+
+data WorkerEvent token a = WorkerTermination
+ | WorkerItem token a
+
+-- | Execute IO actions on several threads and return their results in the original
+-- order. It is guaranteed that no action from the input list is executed unless all
+-- the items that precede it in the list have been executed or are executing at that
+-- moment.
+executeOnPool :: Int -- ^ Number of threads to use
+ -> [IO a] -- ^ Actions to execute: these will be scheduled left to right
+ -> IO [a] -- ^ Ordered results of executing the given IO actions in parallel
+executeOnPool n actions = do
+ -- Prepare the channels
+ input_chan <- newChan
+ output_chan <- newChan
+
+ -- Write the actions as items to the channel followed by one termination per thread
+ -- that indicates they should terminate. We do this on another thread for
+ -- maximum laziness (in case one the actions we are going to run depend on the
+ -- output from previous actions..)
+ forkIO $ writeList2Chan input_chan (zipWith WorkerItem [0..] actions ++ replicate n WorkerTermination)
+
+ -- Spawn workers
+ forM_ [1..n] (const $ forkIO $ poolWorker input_chan output_chan)
+
+ -- Return the results generated by the worker threads lazily and in
+ -- the same order as we got the inputs
+ fmap (reorderFrom 0 . takeWhileWorkersExist n) $ getChanContents output_chan
+
+poolWorker :: Chan (WorkerEvent token (IO a)) -> Chan (WorkerEvent token a) -> IO ()
+poolWorker input_chan output_chan = do
+ -- Read an action and work out whether we should continue or stop
+ action_item <- readChan input_chan
+ case action_item of
+ WorkerTermination -> writeChan output_chan WorkerTermination -- Must have run out of real actions to execute
+ WorkerItem token action -> do
+ -- Do the action then loop
+ result <- action
+ writeChan output_chan (WorkerItem token result)
+ poolWorker input_chan output_chan
+
+-- | Keep grabbing items out of the infinite list of worker outputs until we have
+-- recieved word that all of the workers have shut down. This lets us turn a possibly
+-- infinite list of outputs into a certainly finite one suitable for use with reorderFrom.
+takeWhileWorkersExist :: Int -> [WorkerEvent token a] -> [(token, a)]
+takeWhileWorkersExist worker_count events
+ | worker_count <= 0 = []
+ | otherwise = case events of
+ (WorkerTermination:events') -> takeWhileWorkersExist (worker_count - 1) events'
+ (WorkerItem token x:events') -> (token, x) : takeWhileWorkersExist worker_count events'
+ [] -> []
+
+-- | This function carefully shuffles the input list so it in the total order
+-- defined by the integers paired with the elements. If the list is @xs@ and
+-- the supplied initial integer is @n@, it must be the case that:
+--
+-- > sort (map fst xs) == [n..n + (length xs - 1)]
+--
+-- This function returns items in the lazy result list as soon as it is sure
+-- it has the right item for that position.
+reorderFrom :: Int -> [(Int, a)] -> [a]
+reorderFrom from initial_things = go from initial_things IM.empty False
+ where go next [] buf _
+ | IM.null buf = [] -- If the buffer and input list is empty, we're done
+ | otherwise = go next (IM.toList buf) IM.empty False -- Make sure we check the buffer even if the list is done
+ go next all_things@((token, x):things) buf buf_useful
+ | token == next -- If the list token matches the one we were expecting we can just take the item
+ = x : go (next + 1) things buf True -- Always worth checking the buffer now because the expected item has changed
+ | buf_useful -- If it's worth checking the buffer, it's possible the token we need is in it
+ , (Just x', buf') <- IM.updateLookupWithKey (const $ const Nothing) next buf -- Delete the found item from the map (if we find it) to save space
+ = x' : go (next + 1) all_things buf' True -- Always worth checking the buffer now because the expected item has changed
+ | otherwise -- Token didn't match, buffer unhelpful: it must be in the tail of the list
+ = go next things (IM.insert token x buf) False -- Since we've already checked the buffer, stop bothering to do so until something changes -}
diff --git a/Test/Framework/Runners/TimedConsumption.hs b/Test/Framework/Runners/TimedConsumption.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Runners/TimedConsumption.hs
@@ -0,0 +1,29 @@
+module Test.Framework.Runners.TimedConsumption (
+ consumeListInInterval
+ ) where
+
+import Test.Framework.Utilities
+
+import System.CPUTime
+
+
+-- | Evaluates the given list for the given number of microseconds. After the time limit
+-- has been reached, a list is returned consisting of the prefix of the list that was
+-- successfully evaluated within the time limit.
+--
+-- This function does /not/ evaluate the elements of the list: it just ensures that the
+-- list spine arrives in good order.
+--
+-- The spine of the list is evaluated on the current thread, so if spine evaluation blocks
+-- this function will also block, potentially for longer than the specificed delay.
+consumeListInInterval :: Int -> [a] -> IO [a]
+consumeListInInterval delay list = do
+ initial_time_ps <- getCPUTime
+ go initial_time_ps (microsecondsToPicoseconds (fromIntegral delay)) list
+ where
+ go _ _ [] = return []
+ go initial_time_ps delay_ps (x:xs) = do
+ this_time <- getCPUTime
+ if this_time - initial_time_ps < delay_ps
+ then go initial_time_ps delay_ps xs >>= return . (x:)
+ else return []
diff --git a/Test/Framework/Seed.hs b/Test/Framework/Seed.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Seed.hs
@@ -0,0 +1,32 @@
+module Test.Framework.Seed where
+
+import Test.Framework.Utilities
+
+import System.Random
+
+import Data.Char
+
+
+data Seed = FixedSeed Int
+ | RandomSeed
+
+instance Show Seed where
+ show RandomSeed = "random"
+ show (FixedSeed n) = show n
+
+instance Read Seed where
+ readsPrec prec xs = if map toLower random_prefix == "random"
+ then [(RandomSeed, rest)]
+ else map (FixedSeed `onLeft`) (readsPrec prec xs)
+ where (random_prefix, rest) = splitAt 6 xs
+
+-- | Given a 'Seed', returns a new random number generator based on that seed and the
+-- actual numeric seed that was used to build that generator, so it can be recreated.
+newSeededStdGen :: Seed -> IO (StdGen, Int)
+newSeededStdGen (FixedSeed seed) = return $ (mkStdGen seed, seed)
+newSeededStdGen RandomSeed = newStdGenWithKnownSeed
+
+newStdGenWithKnownSeed :: IO (StdGen, Int)
+newStdGenWithKnownSeed = do
+ seed <- randomIO
+ return (mkStdGen seed, seed)
diff --git a/Test/Framework/Tests.hs b/Test/Framework/Tests.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Tests.hs
@@ -0,0 +1,12 @@
+module Main where
+
+import qualified Test.Framework.Tests.Runners.ThreadPool as TP
+
+import Test.HUnit
+
+
+-- I wish I could use my test framework to test my framework...
+main :: IO ()
+main = do
+ runTestTT $ TestList TP.tests
+ return ()
diff --git a/Test/Framework/Utilities.hs b/Test/Framework/Utilities.hs
new file mode 100644
--- /dev/null
+++ b/Test/Framework/Utilities.hs
@@ -0,0 +1,60 @@
+module Test.Framework.Utilities where
+
+import Data.Maybe
+import Data.Monoid
+
+
+newtype K a = K { unK :: a }
+
+
+secondsToMicroseconds :: Num a => a -> a
+secondsToMicroseconds = (1000000*)
+
+microsecondsToPicoseconds :: Num a => a -> a
+microsecondsToPicoseconds = (1000000*)
+
+listToMaybeLast :: [a] -> Maybe a
+listToMaybeLast = listToMaybe . reverse
+
+mappendBy :: Monoid b => (a -> b) -> a -> a -> b
+mappendBy f left right = (f left) `mappend` (f right)
+
+orElse :: Maybe a -> a -> a
+orElse = flip fromMaybe
+
+onLeft :: (a -> c) -> (a, b) -> (c, b)
+onLeft f (x, y) = (f x, y)
+
+onRight :: (b -> c) -> (a, b) -> (a, c)
+onRight f (x, y) = (x, f y)
+
+-- | Like 'unlines', but does not append a trailing newline if there
+-- is at least one line. For example:
+--
+-- > unlinesConcise ["A", "B"] == "A\nB"
+-- > unlinesConcise [] == ""
+--
+-- Whereas:
+--
+-- > unlines ["A", "B"] == "A\nB\n"
+-- > unlines [] == ""
+--
+-- This is closer to the behaviour of 'unwords', which does not append
+-- a trailing space.
+unlinesConcise :: [String] -> String
+unlinesConcise [] = []
+unlinesConcise [l] = l
+unlinesConcise (l:ls) = l ++ '\n' : unlinesConcise ls
+
+mapAccumLM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
+mapAccumLM _ acc [] = return (acc, [])
+mapAccumLM f acc (x:xs) = do
+ (acc', y) <- f acc x
+ (acc'', ys) <- mapAccumLM f acc' xs
+ return (acc'', y:ys)
+
+padRight :: Int -> String -> String
+padRight desired_length s = s ++ replicate (desired_length - length s) ' '
+
+dropLast :: Int -> [a] -> [a]
+dropLast n = reverse . drop n . reverse
diff --git a/test-framework.cabal b/test-framework.cabal
new file mode 100644
--- /dev/null
+++ b/test-framework.cabal
@@ -0,0 +1,141 @@
+Name: test-framework
+Version: 0.1
+Cabal-Version: >= 1.2
+Category: Testing
+Synopsis: Framework for running and organising tests, with HUnit and QuickCheck support
+Description: Allows QuickCheck properties and HUnit test cases to be assembled into test groups, run in parallel (but reported
+ in deterministic order, to aid diff interpretation) and filtered and controlled by command line options.
+ All of this comes with colored test output, progress reporting and test statistics output.
+License: BSD3
+License-File: LICENSE
+Extra-Source-Files: README.textile
+Author: Max Bolingbroke
+Maintainer: batterseapower@hotmail.com
+Homepage: http://github.com/batterseapower/test-framework
+Build-Type: Simple
+
+Flag SplitBase
+ Description: Choose the new smaller, split-up base package
+ Default: True
+
+Flag Tests
+ Description: Build the tests
+ Default: False
+
+Flag Example
+ Description: Build the example testsuite
+ Default: False
+
+Flag HUnit
+ Description: Enable HUnit integration: disabling this is not recommended, as it changes the package API
+ Default: True
+
+Flag QuickCheck
+ Description: Enable QuickCheck integration: disabling this is not recommended, as it changes the package API
+ Default: True
+
+
+Library
+ Exposed-Modules: Test.Framework
+ Test.Framework.Options
+ Test.Framework.Providers.API
+ Test.Framework.Runners.Console
+ Test.Framework.Runners.Options
+ Test.Framework.Seed
+
+ Other-Modules: Test.Framework.Core
+ Test.Framework.Improving
+ Test.Framework.Runners.Console.Colors
+ Test.Framework.Runners.Console.ProgressBar
+ Test.Framework.Runners.Console.Statistics
+ Test.Framework.Runners.Console.Table
+ Test.Framework.Runners.Console.Utilities
+ Test.Framework.Runners.Core
+ Test.Framework.Runners.Processors
+ Test.Framework.Runners.TestPattern
+ Test.Framework.Runners.ThreadPool
+ Test.Framework.Runners.TimedConsumption
+ Test.Framework.Utilities
+
+ if flag(quickcheck)
+ Build-Depends: QuickCheck >= 1.1
+ Exposed-Modules: Test.Framework.Providers.QuickCheck
+
+ if flag(hunit)
+ Build-Depends: HUnit >= 1.2
+ Exposed-Modules: Test.Framework.Providers.HUnit
+
+ Build-Depends: ansi-terminal >= 0.2.1, ansi-wl-pprint >= 0.2, regex-posix >= 0.72
+ if flag(splitBase)
+ Build-Depends: base >= 3, random >= 1.0, containers >= 0.1
+ else
+ Build-Depends: base < 3
+
+ Extensions: CPP
+ PatternGuards
+ ExistentialQuantification
+ RecursiveDo
+ FlexibleInstances
+ TypeSynonymInstances
+ TypeOperators
+ FunctionalDependencies
+ MultiParamTypeClasses
+
+ Ghc-Options: -Wall
+
+ if impl(ghc)
+ Cpp-Options: -DCOMPILER_GHC
+
+Executable test-framework-tests
+ Main-Is: Test/Framework/Tests.hs
+
+ Build-Depends: QuickCheck >= 1.1, HUnit >= 1.2, ansi-terminal >= 0.2.1, ansi-wl-pprint >= 0.2, regex-posix >= 0.72
+ if flag(splitBase)
+ Build-Depends: base >= 3, random >= 1.0, containers >= 0.1
+ else
+ Build-Depends: base < 3
+
+ Extensions: CPP
+ PatternGuards
+ ExistentialQuantification
+ RecursiveDo
+ FlexibleInstances
+ TypeSynonymInstances
+ TypeOperators
+ FunctionalDependencies
+ MultiParamTypeClasses
+
+ Ghc-Options: -Wall -threaded
+
+ if impl(ghc)
+ Cpp-Options: -DCOMPILER_GHC
+
+ if !flag(tests)
+ Buildable: False
+
+Executable test-framework-example
+ Main-Is: Test/Framework/Example.lhs
+
+ Build-Depends: QuickCheck >= 1.1, HUnit >= 1.2, ansi-terminal >= 0.2.1, ansi-wl-pprint >= 0.2, regex-posix >= 0.72
+ if flag(splitBase)
+ Build-Depends: base >= 3, random >= 1.0, containers >= 0.1
+ else
+ Build-Depends: base < 3
+
+ Extensions: CPP
+ PatternGuards
+ ExistentialQuantification
+ RecursiveDo
+ FlexibleInstances
+ TypeSynonymInstances
+ TypeOperators
+ FunctionalDependencies
+ MultiParamTypeClasses
+
+ Ghc-Options: -threaded
+
+ if impl(ghc)
+ Cpp-Options: -DCOMPILER_GHC
+
+ if !flag(example)
+ Buildable: False