test-framework (empty) → 0.1
raw patch · 27 files changed
+1539/−0 lines, 27 filesdep +HUnitdep +QuickCheckdep +ansi-terminalsetup-changed
Dependencies added: HUnit, QuickCheck, ansi-terminal, ansi-wl-pprint, base, containers, random, regex-posix
Files
- LICENSE +22/−0
- README.textile +93/−0
- Setup.lhs +4/−0
- Test/Framework.hs +13/−0
- Test/Framework/Core.hs +32/−0
- Test/Framework/Example.lhs +110/−0
- Test/Framework/Improving.hs +66/−0
- Test/Framework/Options.hs +35/−0
- Test/Framework/Providers/API.hs +21/−0
- Test/Framework/Providers/HUnit.hs +56/−0
- Test/Framework/Providers/QuickCheck.hs +96/−0
- Test/Framework/Runners/Console.hs +210/−0
- Test/Framework/Runners/Console/Colors.hs +12/−0
- Test/Framework/Runners/Console/ProgressBar.hs +19/−0
- Test/Framework/Runners/Console/Statistics.hs +97/−0
- Test/Framework/Runners/Console/Table.hs +72/−0
- Test/Framework/Runners/Console/Utilities.hs +15/−0
- Test/Framework/Runners/Core.hs +70/−0
- Test/Framework/Runners/Options.hs +29/−0
- Test/Framework/Runners/Processors.hs +17/−0
- Test/Framework/Runners/TestPattern.hs +93/−0
- Test/Framework/Runners/ThreadPool.hs +83/−0
- Test/Framework/Runners/TimedConsumption.hs +29/−0
- Test/Framework/Seed.hs +32/−0
- Test/Framework/Tests.hs +12/−0
- Test/Framework/Utilities.hs +60/−0
- test-framework.cabal +141/−0
+ LICENSE view
@@ -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.
+ README.textile view
@@ -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: + +<pre> +<code>runghc Setup.lhs configure +runghc Setup.lhs build +sudo runghc Setup.lhs install +</pre> +</code> + +If you want to build the example, to check it's all working: + +<pre> +<code>runghc Setup.lhs configure -fexample +runghc Setup.lhs build +dist/build/test-framework-example/test-framework-example +</pre> +</code> + + +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: + +<pre> +<code>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 + ] + ] +</pre> +</code> + +And set up the console runner by including this in your @Main@ module: + +<pre><code>main = defaultMain tests</pre></code> + + +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/
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ Test/Framework.hs view
@@ -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
+ Test/Framework/Core.hs view
@@ -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
+ Test/Framework/Example.lhs view
@@ -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}
+ Test/Framework/Improving.hs view
@@ -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
+ Test/Framework/Options.hs view
@@ -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)+ }
+ Test/Framework/Providers/API.hs view
@@ -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
+ Test/Framework/Providers/HUnit.hs view
@@ -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
+ Test/Framework/Providers/QuickCheck.hs view
@@ -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
+ Test/Framework/Runners/Console.hs view
@@ -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
+ Test/Framework/Runners/Console/Colors.hs view
@@ -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
+ Test/Framework/Runners/Console/ProgressBar.hs view
@@ -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 ' ')
+ Test/Framework/Runners/Console/Statistics.hs view
@@ -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)
+ Test/Framework/Runners/Console/Table.hs view
@@ -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
+ Test/Framework/Runners/Console/Utilities.hs view
@@ -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)
+ Test/Framework/Runners/Core.hs view
@@ -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+ }
+ Test/Framework/Runners/Options.hs view
@@ -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+ }
+ Test/Framework/Runners/Processors.hs view
@@ -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
+ Test/Framework/Runners/TestPattern.hs view
@@ -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)
+ Test/Framework/Runners/ThreadPool.hs view
@@ -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 -}
+ Test/Framework/Runners/TimedConsumption.hs view
@@ -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 []
+ Test/Framework/Seed.hs view
@@ -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)
+ Test/Framework/Tests.hs view
@@ -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 ()
+ Test/Framework/Utilities.hs view
@@ -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
+ test-framework.cabal view
@@ -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