packages feed

test-framework 0.4.2.3 → 0.8.2.3

raw patch · 54 files changed

Files

+ ChangeLog.md view
@@ -0,0 +1,37 @@+#### 0.8.2.3++_2026-01-05, Andreas Abel_++- Remove obsolete `deriving Typeable`+- Tested building with GHC 8.0 - 9.14.1++#### 0.8.2.2++_2025-04-11, Andreas Abel_++- Drop `libxml` dependency in testsuite+- Tested building with GHC 8.0 - 9.12.2++#### 0.8.2.1++_2025-02-26, Andreas Abel_++- Support `random-1.3` and other latest dependencies+- Drop support for GHC 7+- Drop support for dependency versions that predate Stackage LTS 9.21+- Tested building with GHC 8.0 - 9.12.1++### 0.8.2.0++- Add `Semigroup` instances+- Avoid orphan-instance clashing by using `base-orphans`'s orphan `Functor` instances `base` < 4.7+- Make `-Wall` clean++#### 0.8.1.1++- Fix a build warning that happens to be a fatal error with GHC 7.4 when using `ansi-wl-pprint` < 0.6.6++### 0.8.1.0++- Add `Applicative` instances+- Add support for `time-1.5.0`
− Setup.lhs 
@@ -1,4 +0,0 @@-#! /usr/bin/env runhaskell--> import Distribution.Simple-> main = defaultMain
− Test/Framework.hs 
@@ -1,17 +0,0 @@--- | A generic test framework for all types of Haskell test.------ For an example of how to use test-framework, please see--- <http://github.com/batterseapower/test-framework/raw/master/example/Test/Framework/Example.lhs>-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 (Test, TestName, testGroup, plusTestOptions, buildTest, mutuallyExclusive)-import Test.Framework.Options-import Test.Framework.Runners.Console-import Test.Framework.Runners.Options-import Test.Framework.Seed
− Test/Framework/Core.hs 
@@ -1,72 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-module Test.Framework.Core where--import Test.Framework.Improving-import Test.Framework.Options--import Control.Concurrent.MVar----- | Something like the result of a test: works in concert with 'Testlike'.--- The type parameters are the type that is used for progress reports and the--- type of the final output of the test respectively.-class (Show i, Show r) => TestResultlike i r | r -> i where-    testSucceeded :: r -> Bool---- | Something test-like in its behaviour. The type parameters are the type that--- is used for progress reports, the type of the final output of the test and the--- data type encapsulating the whole potential to do a test respectively.-class TestResultlike i r => Testlike i r t | t -> i r, r -> i where-    runTest :: CompleteTestOptions -> t -> IO (i :~> r, IO ())-    testTypeName :: t -> TestTypeName----- | Test names or descriptions. These are shown to the user-type TestName = String---- | The name of a type of test, such as "Properties" or "Test Cases". Tests of--- types of the same names will be grouped together in the test run summary.-type TestTypeName = String---- | Main test data type: builds up a list of tests to be run. Users should use the--- utility functions in e.g. the test-framework-hunit and test-framework-quickcheck--- packages to create instances of 'Test', and then build them up into testsuites--- by using 'testGroup' and lists.------ For an example of how to use test-framework, please see--- <http://github.com/batterseapower/test-framework/raw/master/example/Test/Framework/Example.lhs>-data Test = forall i r t. Testlike i r t => Test TestName t -- ^ A single test of some particular type-          | TestGroup TestName [Test]                       -- ^ Assemble a number of tests into a cohesive group-          | PlusTestOptions TestOptions Test                -- ^ Add some options to child tests-          | BuildTest (IO Test)                             -- ^ Convenience for creating tests from an 'IO' action---- | Assemble a number of tests into a cohesive group-testGroup :: TestName -> [Test] -> Test-testGroup = TestGroup---- | Add some options to child tests-plusTestOptions :: TestOptions -> Test -> Test-plusTestOptions = PlusTestOptions---- | Convenience for creating tests from an 'IO' action-buildTest :: IO Test -> Test-buildTest = BuildTest---data MutuallyExcluded t = ME (MVar ()) t---- This requires UndecidableInstances, but I think it can't be made inconsistent?-instance Testlike i r t => Testlike i r (MutuallyExcluded t) where-    runTest cto (ME mvar x) = withMVar mvar $ \() -> runTest cto x-    testTypeName ~(ME _ x) = testTypeName x---- | Mark all tests in this portion of the tree as mutually exclusive, so only one runs at a time-{-# NOINLINE mutuallyExclusive #-}-mutuallyExclusive :: Test -> Test-mutuallyExclusive init_t = BuildTest $ do-    mvar <- newMVar ()-    let go (Test tn t)            = Test tn (ME mvar t)-        go (TestGroup tn ts)      = TestGroup tn (map go ts)-        go (PlusTestOptions to t) = PlusTestOptions to (go t)-        go (BuildTest build)      = BuildTest (fmap go build)-    return (go init_t)
− Test/Framework/Improving.hs 
@@ -1,78 +0,0 @@-module Test.Framework.Improving (-        (:~>)(..), bimapImproving, improvingLast, consumeImproving,-        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)--bimapImproving :: (a -> c) -> (b -> d) -> (a :~> b) -> (c :~> d)-bimapImproving _ g (Finished b)            = Finished (g b)-bimapImproving f g (Improving a improving) = Improving (f a) (bimapImproving f g improving)--improvingLast :: (a :~> b) -> b-improvingLast (Finished r)       = r-improvingLast (Improving _ rest) = improvingLast rest--consumeImproving :: (a :~> b) -> [(a :~> b)]-consumeImproving improving@(Finished _)       = [improving]-consumeImproving improving@(Improving _ rest) = improving : consumeImproving rest---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 
@@ -1,39 +0,0 @@-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_maximum_test_depth :: f Int,-        -- ^ Maximum depth of generated tests when using something like SmallCheck-        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_maximum_test_depth = 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_maximum_test_depth = getLast (mappendBy (Last . topt_maximum_test_depth) to1 to2),-            topt_timeout = getLast (mappendBy (Last . topt_timeout) to1 to2)-        }
− Test/Framework/Providers/API.hs 
@@ -1,21 +0,0 @@--- | 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/Runners/Console.hs 
@@ -1,151 +0,0 @@-module Test.Framework.Runners.Console (-        defaultMain, defaultMainWithArgs, defaultMainWithOpts,-        interpretArgs, interpretArgsOrExit-    ) where--import Test.Framework.Core-import Test.Framework.Options-import Test.Framework.Runners.Console.Run-import Test.Framework.Runners.Core-import Test.Framework.Runners.Options-import Test.Framework.Runners.Processors-import Test.Framework.Runners.Statistics-import qualified Test.Framework.Runners.XML as XML-import Test.Framework.Seed-import Test.Framework.Utilities--import System.Console.GetOpt-import System.Environment-import System.Exit-import System.IO--import Data.Monoid---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 ['d'] ["maximum-test-depth"]-            (ReqArg (\t -> mempty { ropt_test_options = Just (mempty { topt_maximum_test_depth = Just (read t) }) }) "NUMBER")-            "to what depth something like SmallCheck should test the properties, 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",-        Option [] ["jxml"]-            (ReqArg (\t -> mempty { ropt_xml_output = Just (Just t) }) "FILE")-            "write a JUnit XML summary of the output to FILE",-        Option [] ["jxml-nested"]-            (NoArg (mempty { ropt_xml_nested = Just True }))-            "use nested testsuites to represent groups in JUnit XML (not standards compliant)",-        Option [] ["plain"]-            (NoArg (mempty { ropt_plain_output = Just True }))-            "do not use any ANSI terminal features to display the test run",-        Option [] ["hide-successes"]-            (NoArg (mempty { ropt_hide_successes = Just True }))-            "hide sucessful tests, and only show failures"-    ]---- | Parse the specified command line arguments into a 'RunnerOptions' and some remaining arguments,--- or return a reason as to why we can't.-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)---- | A version of 'interpretArgs' that ends the process if it fails.-interpretArgsOrExit :: [String] -> IO RunnerOptions-interpretArgsOrExit args = do-    interpreted_args <- interpretArgs args-    case interpreted_args of-        Right (ropts, [])    -> return ropts-        Right (_, leftovers) -> do-            hPutStrLn stderr $ "Could not understand these extra arguments: " ++ unwords leftovers-            exitWith (ExitFailure 1)-        Left error_message   -> do-            hPutStrLn stderr error_message-            exitWith (ExitFailure 1)---defaultMain :: [Test] -> IO ()-defaultMain tests = do-    args <- getArgs-    defaultMainWithArgs tests args---- | A version of 'defaultMain' that lets you ignore the command line arguments--- in favour of another list of 'String's.-defaultMainWithArgs :: [Test] -> [String] -> IO ()-defaultMainWithArgs tests args = do-    ropts <- interpretArgsOrExit args-    defaultMainWithOpts tests ropts---- | A version of 'defaultMain' that lets you ignore the command line arguments--- in favour of an explicit set of 'RunnerOptions'.-defaultMainWithOpts :: [Test] -> RunnerOptions -> IO ()-defaultMainWithOpts tests ropts = do-    let ropts' = completeRunnerOptions ropts-    -    -- Get a lazy list of the test results, as executed in parallel-    running_tests <- runTests ropts' tests-    -    -- Show those test results to the user as we get them-    fin_tests <- showRunTestsTop (unK $ ropt_plain_output ropts') (unK $ ropt_hide_successes ropts') running_tests-    let test_statistics' = gatherStatistics fin_tests-    -    -- Output XML report (if requested)-    case ropt_xml_output ropts' of-        K (Just file) -> XML.produceReport (unK (ropt_xml_nested ropts')) test_statistics' fin_tests >>= writeFile file-        _ -> return ()-    -    -- 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,-            ropt_xml_output = K $ ropt_xml_output ro `orElse` Nothing,-            ropt_xml_nested = K $ ropt_xml_nested ro `orElse` False,-            ropt_plain_output = K $ ropt_plain_output ro `orElse` False,-            ropt_hide_successes = K $ ropt_hide_successes ro `orElse` False-        }
− Test/Framework/Runners/Console/Colors.hs 
@@ -1,12 +0,0 @@-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 
@@ -1,19 +0,0 @@-module Test.Framework.Runners.Console.ProgressBar (-        Progress(..), progressBar-    ) where--import Text.PrettyPrint.ANSI.Leijen hiding (width)---data Progress = Progress Int Int--progressBar :: (Doc -> Doc) -> Int -> Progress -> Doc-progressBar 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/Run.hs 
@@ -1,117 +0,0 @@-module Test.Framework.Runners.Console.Run (-        showRunTestsTop-    ) where--import Test.Framework.Core-import Test.Framework.Improving-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.Statistics-import Test.Framework.Runners.TimedConsumption-import Test.Framework.Utilities--import System.Console.ANSI-import System.IO--import Text.PrettyPrint.ANSI.Leijen--import Data.Monoid (mempty)--import Control.Arrow (second, (&&&))-import Control.Monad (unless)---showRunTestsTop :: Bool -> Bool -> [RunningTest] -> IO [FinishedTest]-showRunTestsTop isplain hide_successes running_tests = (if isplain then id else hideCursorDuring) $ do-    -- Show those test results to the user as we get them. Gather statistics on the fly for a progress bar-    let test_statistics = initialTestStatistics (totalRunTestsList running_tests)-    (test_statistics', finished_tests) <- showRunTests isplain hide_successes 0 test_statistics running_tests-    -    -- Show the final statistics-    putStrLn ""-    putDoc $ possiblyPlain isplain $ showFinalTestStatistics test_statistics'-    -    return finished_tests----- 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 :: Bool -> Bool -> Int -> TestStatistics -> RunningTest -> IO (TestStatistics, FinishedTest)-showRunTest isplain hide_successes indent_level test_statistics (RunTest name test_type (SomeImproving improving_result)) = do-    let progress_bar = testStatisticsProgressBar test_statistics-    (property_text, property_suceeded) <- showImprovingTestResult isplain hide_successes indent_level name progress_bar improving_result-    return (updateTestStatistics (\count -> adjustTestCount test_type count mempty) property_suceeded test_statistics, RunTest name test_type (property_text, property_suceeded))-showRunTest isplain hide_successes indent_level test_statistics (RunTestGroup name tests) = do-    putDoc $ (indent indent_level (text name <> char ':')) <> linebreak-    fmap (second $ RunTestGroup name) $ showRunTests isplain hide_successes (indent_level + 2) test_statistics tests--showRunTests :: Bool -> Bool -> Int -> TestStatistics -> [RunningTest] -> IO (TestStatistics, [FinishedTest])-showRunTests isplain hide_successes indent_level = mapAccumLM (showRunTest isplain hide_successes indent_level)---testStatisticsProgressBar :: TestStatistics -> Doc-testStatisticsProgressBar test_statistics = progressBar (colorPassOrFail no_failures) terminal_width (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-    -- We assume a terminal width of 80, but we can't make the progress bar 80 characters wide.  Why?  Because if we-    -- do so, when we write the progress bar out Windows will move the cursor onto the next line!  By using a slightly-    -- smaller width we prevent this from happening.  Bit of a hack, but it does the job.-    terminal_width = 79---showImprovingTestResult :: TestResultlike i r => Bool -> Bool -> Int -> String -> Doc -> (i :~> r) -> IO (String, Bool)-showImprovingTestResult isplain hide_successes indent_level test_name progress_bar improving = do-    -- Consume the improving value until the end, displaying progress if we are not in "plain" mode-    (result, success) <- if isplain then return $ improvingLast improving'-                                    else showImprovingTestResultProgress (return ()) indent_level test_name progress_bar improving'-    unless (success && hide_successes) $ do-        let (result_doc, extra_doc) | success   = (brackets $ colorPass (text result), empty)-                                    | otherwise = (brackets (colorFail (text "Failed")), text result <> linebreak)-        -        -- Output the final test status and a trailing newline-        putTestHeader indent_level test_name (possiblyPlain isplain result_doc)-        -- Output any extra information that may be required, e.g. to show failure reason-        putDoc extra_doc--    return (result, success)-  where-    improving' = bimapImproving show (show &&& testSucceeded) improving--showImprovingTestResultProgress :: IO () -> Int -> String -> Doc -> (String :~> (String, Bool)) -> IO (String, Bool)-showImprovingTestResultProgress erase indent_level test_name progress_bar improving = do-    -- Update the screen every every 200ms-    improving_list <- consumeListInInterval 200000 (consumeImproving improving)-    case listToMaybeLast improving_list of-        Nothing         -> do -- 200ms was somehow not long enough for a single result to arrive: try again!-            showImprovingTestResultProgress erase indent_level test_name progress_bar improving-        Just improving' -> do -- Display that new improving value to the user-            showImprovingTestResultProgress' erase indent_level test_name progress_bar improving'--showImprovingTestResultProgress' :: IO () -> Int -> String -> Doc -> (String :~> (String, Bool)) -> IO (String, Bool)-showImprovingTestResultProgress' erase _ _ _ (Finished result) = do-    erase-    -- 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.-    putStrLn ""-    clearLine-    cursorUpLine 1-    return result-showImprovingTestResultProgress' erase indent_level test_name progress_bar (Improving intermediate rest) = do-    erase-    putTestHeader indent_level test_name (brackets (text intermediate))-    putDoc progress_bar-    hFlush stdout-    showImprovingTestResultProgress (cursorUpLine 1 >> clearLine) indent_level test_name progress_bar rest--possiblyPlain :: Bool -> Doc -> Doc-possiblyPlain True  = plain-possiblyPlain False = id--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/Statistics.hs 
@@ -1,42 +0,0 @@-module Test.Framework.Runners.Console.Statistics (-        showFinalTestStatistics-    ) where--import Test.Framework.Runners.Statistics-import Test.Framework.Runners.Console.Colors-import Test.Framework.Runners.Console.Table--import Text.PrettyPrint.ANSI.Leijen--import Data.List----- | 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 
@@ -1,72 +0,0 @@-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 
@@ -1,12 +0,0 @@-module Test.Framework.Runners.Console.Utilities (-        hideCursorDuring-    ) where--import System.Console.ANSI-import System.IO--import Control.Exception.Extensible---hideCursorDuring :: IO a -> IO a-hideCursorDuring action = bracket hideCursor (const (showCursor >> hFlush stdout)) (const action)
− Test/Framework/Runners/Core.hs 
@@ -1,64 +0,0 @@-module Test.Framework.Runners.Core (-        RunTest(..), RunningTest, SomeImproving(..), FinishedTest, 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 Data.Maybe-import Data.Monoid----- | A test that has been executed or is in the process of execution-data RunTest a = RunTest TestName TestTypeName a-               | RunTestGroup TestName [RunTest a]-               deriving (Show)--data SomeImproving = forall i r. TestResultlike i r => SomeImproving (i :~> r)-type RunningTest = RunTest SomeImproving--type FinishedTest = RunTest (String, Bool)--runTests :: CompleteRunnerOptions -- ^ Top-level runner options-         -> [Test]                -- ^ Tests to run-         -> IO [RunningTest]-runTests ropts tests = do-    let test_patterns = unK $ ropt_test_patterns ropts-        use_test path name = null test_patterns || any (`testPatternMatches` (path ++ [name])) test_patterns-    (run_tests, actions) <- runTests' use_test [] (unK $ ropt_test_options ropts) tests-    _ <- executeOnPool (unK $ ropt_threads ropts) actions-    return run_tests---runTest' :: ([String] -> String -> Bool) -> [String]-         -> TestOptions -> Test -> IO (Maybe (RunningTest, [IO ()]))-runTest' use_test path topts (Test name testlike)-  | use_test path name = do-    (result, action) <- runTest (completeTestOptions topts) testlike-    return (Just (RunTest name (testTypeName testlike) (SomeImproving result), [action]))-  | otherwise = return Nothing-runTest' use_test path topts (TestGroup name tests) = do-    (results, actions) <- runTests' use_test (path ++ [name]) topts tests-    return $ if null results then Nothing else Just ((RunTestGroup name results), actions)-runTest' use_test path topts (PlusTestOptions extra_topts test) = runTest' use_test path (topts `mappend` extra_topts) test-runTest' use_test path topts (BuildTest build) = build >>= runTest' use_test path topts--runTests' :: ([String] -> String -> Bool) -> [String]-          -> TestOptions -> [Test] -> IO ([RunningTest], [IO ()])-runTests' use_test path topts = fmap (onRight concat . unzip . catMaybes) . mapM (runTest' use_test path 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_maximum_test_depth = K $ topt_maximum_test_depth to `orElse` 5,-            topt_timeout = K $ topt_timeout to `orElse` Nothing-        }
− Test/Framework/Runners/Options.hs 
@@ -1,41 +0,0 @@-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],-        ropt_xml_output :: f (Maybe FilePath),-        ropt_xml_nested :: f Bool,-        ropt_plain_output :: f Bool,-        ropt_hide_successes :: f Bool-    }--instance Monoid (RunnerOptions' Maybe) where-    mempty = RunnerOptions {-            ropt_threads = Nothing,-            ropt_test_options = Nothing,-            ropt_test_patterns = Nothing,-            ropt_xml_output = Nothing,-            ropt_xml_nested = Nothing,-            ropt_plain_output = Nothing,-            ropt_hide_successes = 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,-            ropt_xml_output = mappendBy ropt_xml_output ro1 ro2,-            ropt_xml_nested = getLast (mappendBy (Last . ropt_xml_nested) ro1 ro2),-            ropt_plain_output = getLast (mappendBy (Last . ropt_plain_output) ro1 ro2),-            ropt_hide_successes = getLast (mappendBy (Last . ropt_hide_successes) ro1 ro2)-        }
− Test/Framework/Runners/Processors.hs 
@@ -1,17 +0,0 @@-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/Statistics.hs 
@@ -1,99 +0,0 @@-module Test.Framework.Runners.Statistics (-        TestCount, testCountTestTypes, testCountForType, adjustTestCount, testCountTotal,-        TestStatistics(..), ts_pending_tests, ts_no_failures,-        initialTestStatistics, updateTestStatistics,-        totalRunTestsList, gatherStatistics-  ) where--import Test.Framework.Core (TestTypeName)-import Test.Framework.Runners.Core--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-    }--instance Monoid TestStatistics where-    mempty = TestStatistics mempty mempty mempty mempty-    mappend (TestStatistics tot1 run1 pas1 fai1) (TestStatistics tot2 run2 pas2 fai2) = TestStatistics (tot1 `mappend` tot2) (run1 `mappend` run2) (pas1 `mappend` pas2) (fai1 `mappend` fai2)--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-    }--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))-    }---totalRunTests :: RunTest a -> TestCount-totalRunTests (RunTest _ test_type _) = adjustTestCount test_type 1 mempty-totalRunTests (RunTestGroup _ tests)  = totalRunTestsList tests--totalRunTestsList :: [RunTest a] -> TestCount-totalRunTestsList = mconcat . map totalRunTests--gatherStatistics :: [FinishedTest] -> TestStatistics-gatherStatistics = mconcat . map f-  where-    f (RunTest _ test_type (_, success)) = singleTestStatistics test_type success-    f (RunTestGroup _ tests)             = gatherStatistics tests--    singleTestStatistics :: String -> Bool -> TestStatistics-    singleTestStatistics test_type success = TestStatistics {-            ts_total_tests = one,-            ts_run_tests = one,-            ts_passed_tests = if success then one else mempty,-            ts_failed_tests = if success then mempty else one-        }-      where one = adjustTestCount test_type 1 mempty
− Test/Framework/Runners/TestPattern.hs 
@@ -1,93 +0,0 @@-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 
@@ -1,104 +0,0 @@-module Test.Framework.Runners.ThreadPool (-        executeOnPool-    ) where--import Control.Concurrent-import Control.Monad--import qualified Data.IntMap as IM--import Foreign.StablePtr---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)--    -- Short version: make sure we do the right thing if a test blocks on dead-    -- MVars or TVars.-    -- Long version: GHC is clever enough to throw an exception (BlockedOnDeadMVar-    -- or BlockedIndefinitely) when a thread is waiting for a MVar or TVar that can't-    -- be written to. However, it doesn't know anything about the handlers for those-    -- exceptions. Therefore, when a worker runs a test that causes this exception,-    -- since the main thread is blocking on the worker, the main thread gets the-    -- exception too despite the fact that the main thread will be runnable as soon-    -- as the worker catches its own exception. The below makes sure the main thread-    -- is always reachable by the GC, which is the mechanism for finding threads-    -- that are unrunnable.-    -- See also the ticket where SimonM (semi-cryptically) explains this:-    -- http://hackage.haskell.org/trac/ghc/ticket/3291-    ---    -- NB: this actually leaks stable pointers. We could prevent this by making-    -- takeWhileWorkersExist do |unsafePerformIO newStablePtr| when returning the-    -- lazily-demanded tail of the list, but its a bit of a pain. For now, just-    -- grit our teeth and accept the leak.-    _stablePtr <- myThreadId >>= newStablePtr-    -    -- 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 
@@ -1,29 +0,0 @@-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/Runners/XML.hs 
@@ -1,48 +0,0 @@-module Test.Framework.Runners.XML (-        produceReport-    ) where--import Test.Framework.Runners.Statistics       ( testCountTotal, TestStatistics(..) )-import Test.Framework.Runners.Core             ( FinishedTest )-import Test.Framework.Runners.XML.JUnitWriter  ( RunDescription(..), serialize )--import Data.Time.Format    ( formatTime )-import Data.Time.LocalTime ( getZonedTime )--import System.Locale       ( defaultTimeLocale )--import Network.HostName    ( getHostName )---produceReport :: Bool -> TestStatistics -> [FinishedTest] -> IO String-produceReport nested test_statistics fin_tests = fmap (serialize nested) $ mergeResults test_statistics fin_tests----- | Generates a description of the complete test run, given some--- initial over-all test statistics and the list of tests that was--- run.------ This is only specific to the XML code because the console output--- @Runner@ doesn't need this level of detail to produce summary--- information, and the per-test details are generated during--- execution.------ This could be done better by using a State monad in the notifier--- defined within `issueTests`.-mergeResults :: TestStatistics -> [FinishedTest] -> IO RunDescription-mergeResults test_statistics fin_tests = do-  host <- getHostName-  theTime <- getZonedTime-  return RunDescription {-            errors = 0                  -- not yet available-          , failedCount = testCountTotal (ts_failed_tests test_statistics) -- this includes errors-          , skipped = Nothing           -- not yet applicable-          , hostname = Just host-          , suiteName = "test-framework tests" -- not yet available-          , testCount = testCountTotal (ts_total_tests test_statistics)-          , time = 0.0                  -- We don't currently measure the test run time.-          , timeStamp = Just $ formatTime defaultTimeLocale "%a %B %e %k:%M:%S %Z %Y" theTime -- e.g. Thu May  6 22:09:10 BST 2010-          , runId = Nothing             -- not applicable-          , package = Nothing           -- not yet available-          , tests = fin_tests-          }
− Test/Framework/Runners/XML/JUnitWriter.hs 
@@ -1,89 +0,0 @@-module Test.Framework.Runners.XML.JUnitWriter (-        RunDescription(..),-        serialize,-#ifdef TEST-        morphFlatTestCase, morphNestedTestCase-#endif-    ) where--import Test.Framework.Core (TestName)-import Test.Framework.Runners.Core (RunTest(..), FinishedTest)--import Data.List  ( intercalate )-import Data.Maybe ( fromMaybe )-import Text.XML.Light ( ppTopElement, unqual, unode-                      , Attr(..), Element(..) )----- | An overall description of the test suite run.  This is currently--- styled after the JUnit xml.  It contains records that are not yet--- used, however, it provides a sensible structure to populate as we--- are able, and the serialiazation code behaves as though these are--- filled.-data RunDescription = RunDescription {-    errors :: Int -- ^ The number of tests that triggered error-                  -- conditions (unanticipated failures)-  , failedCount :: Int        -- ^ Count of tests that invalidated stated assertions.-  , skipped :: Maybe Int      -- ^ Count of tests that were provided but not run.-  , hostname :: Maybe String  -- ^ The hostname that ran the test suite.-  , suiteName :: String       -- ^ The name of the test suite.-  , testCount :: Int          -- ^ The total number of tests provided.-  , time :: Double            -- ^ The total execution time for the test suite.-  , timeStamp :: Maybe String -- ^ The time stamp that identifies when this run happened.-  , runId :: Maybe String     -- ^ Included for completness w/ junit.-  , package :: Maybe String   -- ^ holdover from Junit spec. Could be-                              -- used to specify the module under test.-  , tests :: [FinishedTest]   -- ^ detailed description and results for each test run.-  } deriving (Show)----- | Serializes a `RunDescription` value to a `String`.-serialize :: Bool -> RunDescription -> String-serialize nested = ppTopElement . toXml nested---- | Maps a `RunDescription` value to an XML Element-toXml :: Bool -> RunDescription -> Element-toXml nested runDesc = unode "testsuite" (attrs, morph_cases (tests runDesc))-  where-    morph_cases | nested    = map morphNestedTestCase-                | otherwise = concatMap (morphFlatTestCase [])--    -- | Top-level attributes for the first @testsuite@ tag.-    attrs :: [Attr]-    attrs = map (\(x,f)->Attr (unqual x) (f runDesc)) fields-    fields = [ ("errors",    show . errors)-             , ("failures",  show . failedCount)-             , ("skipped",   fromMaybe "" . fmap show . skipped)-             , ("hostname",  fromMaybe "" . hostname)-             , ("name",      id . suiteName)-             , ("tests",     show . testCount)-             , ("time",      show . time)-             , ("timeStamp", fromMaybe "" . timeStamp)-             , ("id",        fromMaybe "" . runId)-             , ("package",   fromMaybe "" . package)-             ]--morphFlatTestCase :: [String] -> FinishedTest -> [Element]-morphFlatTestCase path (RunTestGroup gname testList)-  = concatMap (morphFlatTestCase (gname:path)) testList-morphFlatTestCase path (RunTest tName _ res) = [morphOneTestCase cName tName res]-  where cName | null path = "<none>"-              | otherwise = intercalate "." (reverse path)--morphNestedTestCase :: FinishedTest -> Element-morphNestedTestCase (RunTestGroup gname testList) =-  unode "testsuite" (attrs, map morphNestedTestCase testList)-  where attrs = [ Attr (unqual "name") gname ]-morphNestedTestCase (RunTest tName _ res) = morphOneTestCase "" tName res--morphOneTestCase :: String -> TestName -> (String, Bool) -> Element-morphOneTestCase cName tName (tout, pass) = case pass of-  True  -> unode "testcase" caseAttrs-  False -> unode "testcase" (caseAttrs, unode "failure" (failAttrs, tout))-  where caseAttrs = [ Attr (unqual "name") tName-                    , Attr (unqual "classname") cName-                    , Attr (unqual "time") ""-                    ]-        failAttrs = [ Attr (unqual "message") ""-                    , Attr (unqual "type") ""-                    ]
− Test/Framework/Seed.hs 
@@ -1,32 +0,0 @@-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 
@@ -1,16 +0,0 @@-module Main where--import qualified Test.Framework.Tests.Runners.ThreadPool as TP-import qualified Test.Framework.Tests.Runners.XMLTests as XT--import Test.HUnit-import Test.QuickCheck---- I wish I could use my test framework to test my framework...-main :: IO ()-main = do-    _ <- runTestTT $ TestList [-    	TestList TP.tests,-    	XT.test-      ]-    quickCheck XT.property
− Test/Framework/Utilities.hs 
@@ -1,62 +0,0 @@-module Test.Framework.Utilities where--import Control.Arrow (first, second)--import Data.Function (on)-import Data.Maybe-import Data.Monoid-import Data.List (intercalate)---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 = mappend `on` f--orElse :: Maybe a -> a -> a-orElse = flip fromMaybe--onLeft :: (a -> c) -> (a, b) -> (c, b)-onLeft = first--onRight :: (b -> c) -> (a, b) -> (a, c)-onRight = second---- | 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 = intercalate "\n"--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
+ src/Test/Framework.hs view
@@ -0,0 +1,17 @@+-- | A generic test framework for all types of Haskell test.+--+-- For an example of how to use test-framework, please see+-- <http://github.com/batterseapower/test-framework/raw/master/example/Test/Framework/Example.lhs>+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 (Test, TestName, testGroup, plusTestOptions, buildTest, buildTestBracketed, mutuallyExclusive)+import Test.Framework.Options+import Test.Framework.Runners.Console+import Test.Framework.Runners.Options+import Test.Framework.Seed
+ src/Test/Framework/Core.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE UndecidableInstances #-}++module Test.Framework.Core where++import Test.Framework.Improving+import Test.Framework.Options++import Control.Arrow (first, second)+import Control.Concurrent.MVar ( withMVar, newMVar, MVar )+import Data.Typeable ( Typeable )+++-- | Something like the result of a test: works in concert with 'Testlike'.+-- The type parameters are the type that is used for progress reports and the+-- type of the final output of the test respectively.+class (Show i, Show r) => TestResultlike i r | r -> i where+    testSucceeded :: r -> Bool++-- | Something test-like in its behaviour. The type parameters are the type that+-- is used for progress reports, the type of the final output of the test and the+-- data type encapsulating the whole potential to do a test respectively.+class TestResultlike i r => Testlike i r t | t -> i r, r -> i where+    runTest :: CompleteTestOptions -> t -> IO (i :~> r, IO ())+    testTypeName :: t -> TestTypeName+++-- | Test names or descriptions. These are shown to the user+type TestName = String++-- | The name of a type of test, such as "Properties" or "Test Cases". Tests of+-- types of the same names will be grouped together in the test run summary.+type TestTypeName = String++-- | Main test data type: builds up a list of tests to be run. Users should use the+-- utility functions in e.g. the test-framework-hunit and test-framework-quickcheck2+-- packages to create instances of 'Test', and then build them up into testsuites+-- by using 'testGroup' and lists.+--+-- For an example of how to use test-framework, please see+-- <http://github.com/batterseapower/test-framework/raw/master/example/Test/Framework/Example.lhs>+data Test = forall i r t.+            (Testlike i r t, Typeable t) => Test TestName t -- ^ A single test of some particular type+          | TestGroup TestName [Test]                       -- ^ Assemble a number of tests into a cohesive group+          | PlusTestOptions TestOptions Test                -- ^ Add some options to child tests+          | BuildTestBracketed (IO (Test, IO ()))           -- ^ Convenience for creating tests from an 'IO' action, with cleanup++-- | Assemble a number of tests into a cohesive group+testGroup :: TestName -> [Test] -> Test+testGroup = TestGroup++-- | Add some options to child tests+plusTestOptions :: TestOptions -> Test -> Test+plusTestOptions = PlusTestOptions++-- | Convenience for creating tests from an 'IO' action+buildTest :: IO Test -> Test+buildTest mx = BuildTestBracketed (fmap (flip (,) (return ())) mx)++-- | Convenience for creating tests from an 'IO' action, with a cleanup handler for when tests are finished+buildTestBracketed :: IO (Test, IO ()) -> Test+buildTestBracketed = BuildTestBracketed++data MutuallyExcluded t = ME (MVar ()) t++-- This requires UndecidableInstances, but I think it can't be made inconsistent?+instance Testlike i r t => Testlike i r (MutuallyExcluded t) where+    runTest cto (ME mvar x) = fmap (second (\act -> withMVar mvar $ \() -> act)) $ runTest cto x+    testTypeName ~(ME _ x) = testTypeName x++-- | Mark all tests in this portion of the tree as mutually exclusive, so only one runs at a time+{-# NOINLINE mutuallyExclusive #-}+mutuallyExclusive :: Test -> Test+mutuallyExclusive init_t = buildTest $ do+    mvar <- newMVar ()+    let go (Test tn t)                = Test tn (ME mvar t)+        go (TestGroup tn ts)          = TestGroup tn (map go ts)+        go (PlusTestOptions to t)     = PlusTestOptions to (go t)+        go (BuildTestBracketed build) = BuildTestBracketed (fmap (first go) build)+    return (go init_t)
+ src/Test/Framework/Improving.hs view
@@ -0,0 +1,87 @@+module Test.Framework.Improving (+        (:~>)(..), bimapImproving, improvingLast, consumeImproving,+        ImprovingIO, yieldImprovement, runImprovingIO, tunnelImprovingIO, liftIO,+        timeoutImprovingIO, maybeTimeoutImprovingIO+    ) where++import Control.Concurrent+    ( yield, getChanContents, newChan, writeChan, Chan )+import Control.Monad (ap, liftM)++import System.Timeout ( 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)++bimapImproving :: (a -> c) -> (b -> d) -> (a :~> b) -> (c :~> d)+bimapImproving _ g (Finished b)            = Finished (g b)+bimapImproving f g (Improving a improving) = Improving (f a) (bimapImproving f g improving)++improvingLast :: (a :~> b) -> b+improvingLast (Finished r)       = r+improvingLast (Improving _ rest) = improvingLast rest++consumeImproving :: (a :~> b) -> [(a :~> b)]+consumeImproving improving@(Finished _)       = [improving]+consumeImproving improving@(Improving _ rest) = improving : consumeImproving rest+++newtype ImprovingIO i f a = IIO { unIIO :: Chan (Either i f) -> IO a }++instance Functor (ImprovingIO i f) where+    fmap = liftM++instance Applicative (ImprovingIO i f) where+    pure x = IIO (const $ return x)+    (<*>) = ap++instance Monad (ImprovingIO i f) where+    return = pure+    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)++-- NB: could have a more general type but it would be impredicative+tunnelImprovingIO :: ImprovingIO i f (ImprovingIO i f a -> IO a)+tunnelImprovingIO = IIO $ \chan -> return $ \iio -> unIIO iio chan++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
+ src/Test/Framework/Options.hs view
@@ -0,0 +1,47 @@+module Test.Framework.Options where++import Test.Framework.Seed+import Test.Framework.Utilities++import Data.Monoid ( Last(Last, getLast) )+import Data.Semigroup as Sem ( Semigroup((<>)) )+++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_maximum_test_size :: f Int,+        -- ^ Maximum size of generated tests when using something like QuickCheck+        topt_maximum_test_depth :: f Int,+        -- ^ Maximum depth of generated tests when using something like SmallCheck+        topt_timeout :: f (Maybe Int)+        -- ^ The number of microseconds to run tests for before considering them a failure+    }++instance Sem.Semigroup (TestOptions' Maybe) where+    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_maximum_test_size = getLast (mappendBy (Last . topt_maximum_test_size) to1 to2),+            topt_maximum_test_depth = getLast (mappendBy (Last . topt_maximum_test_depth) to1 to2),+            topt_timeout = getLast (mappendBy (Last . topt_timeout) to1 to2)+        }++instance Monoid (TestOptions' Maybe) where+    mempty = TestOptions {+            topt_seed = Nothing,+            topt_maximum_generated_tests = Nothing,+            topt_maximum_unsuitable_generated_tests = Nothing,+            topt_maximum_test_size = Nothing,+            topt_maximum_test_depth = Nothing,+            topt_timeout = Nothing+        }++    mappend = (Sem.<>)
+ src/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
+ src/Test/Framework/Runners/API.hs view
@@ -0,0 +1,8 @@+-- | This module exports everything that you need to be able to create your own test runner.+module Test.Framework.Runners.API (+        module Test.Framework.Runners.Options,+        TestRunner(..), runTestTree+    ) where++import Test.Framework.Runners.Options+import Test.Framework.Runners.Core
+ src/Test/Framework/Runners/Console.hs view
@@ -0,0 +1,181 @@+module Test.Framework.Runners.Console (+        defaultMain, defaultMainWithArgs, defaultMainWithOpts,+        SuppliedRunnerOptions, optionsDescription,+        interpretArgs, interpretArgsOrExit+    ) where++import Test.Framework.Core+import Test.Framework.Options+import Test.Framework.Runners.Console.Run+import Test.Framework.Runners.Core+import Test.Framework.Runners.Options+import Test.Framework.Runners.Processors+import Test.Framework.Runners.Statistics+import qualified Test.Framework.Runners.XML as XML+import Test.Framework.Seed+import Test.Framework.Utilities++import Control.Monad (when)+import System.Console.GetOpt+    ( getOpt,+      usageInfo,+      ArgDescr(NoArg, ReqArg),+      ArgOrder(Permute),+      OptDescr(..) )+import System.Environment ( getArgs, getProgName )+import System.Exit+    ( exitSuccess, exitWith, ExitCode(ExitFailure, ExitSuccess) )+import System.IO ( hIsTerminalDevice, hPutStrLn, stderr, stdout )++-- | @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++-- | Options understood by test-framework. This can be used to add more+-- options to the tester executable.+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 ['s'] ["maximum-test-size"]+            (ReqArg (\t -> mempty {ropt_test_options = Just (mempty { topt_maximum_test_size = Just (read t) }) }) "NUMBER")+            "to what size something like QuickCheck should test the properties, by default",+        Option ['d'] ["maximum-test-depth"]+            (ReqArg (\t -> mempty { ropt_test_options = Just (mempty { topt_maximum_test_depth = Just (read t) }) }) "NUMBER")+            "to what depth something like SmallCheck should test the properties, 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 ['l'] ["list-tests"]+            (NoArg (mempty { ropt_list_only = Just True }))+            "list available tests but don't run any; useful to guide subsequent --select-tests",+        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",+        Option [] ["jxml"]+            (ReqArg (\t -> mempty { ropt_xml_output = Just (Just t) }) "FILE")+            "write a JUnit XML summary of the output to FILE",+        Option [] ["jxml-nested"]+            (NoArg (mempty { ropt_xml_nested = Just True }))+            "use nested testsuites to represent groups in JUnit XML (not standards compliant)",+        Option [] ["plain"]+            (NoArg (mempty { ropt_color_mode = Just ColorNever }))+            "do not use any ANSI terminal features to display the test run",+        Option [] ["color"]+            (NoArg (mempty { ropt_color_mode = Just ColorAlways }))+            "use ANSI terminal features to display the test run",+        Option [] ["hide-successes"]+            (NoArg (mempty { ropt_hide_successes = Just True }))+            "hide sucessful tests, and only show failures"+    ]++-- | Parse the specified command line arguments into a 'RunnerOptions' and some remaining arguments,+-- or return a reason as to why we can't.+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)++-- | A version of 'interpretArgs' that ends the process if it fails.+interpretArgsOrExit :: [String] -> IO RunnerOptions+interpretArgsOrExit args = do+    interpreted_args <- interpretArgs args+    case interpreted_args of+        Right (ropts, [])    -> return ropts+        Right (_, leftovers) -> do+            hPutStrLn stderr $ "Could not understand these extra arguments: " ++ unwords leftovers+            exitWith (ExitFailure 1)+        Left error_message   -> do+            hPutStrLn stderr error_message+            exitWith (ExitFailure 1)+++defaultMain :: [Test] -> IO ()+defaultMain tests = do+    args <- getArgs+    defaultMainWithArgs tests args++-- | A version of 'defaultMain' that lets you ignore the command line arguments+-- in favour of another list of 'String's.+defaultMainWithArgs :: [Test] -> [String] -> IO ()+defaultMainWithArgs tests args = do+    ropts <- interpretArgsOrExit args+    defaultMainWithOpts tests ropts++-- | A version of 'defaultMain' that lets you ignore the command line arguments+-- in favour of an explicit set of 'RunnerOptions'.+defaultMainWithOpts :: [Test] -> RunnerOptions -> IO ()+defaultMainWithOpts tests ropts = do+    let ropts' = completeRunnerOptions ropts++    when (unK$ ropt_list_only ropts') $ do+      putStr $ listTests tests+      exitSuccess++    -- Get a lazy list of the test results, as executed in parallel+    running_tests <- runTests ropts' tests++    isplain <- case unK $ ropt_color_mode ropts' of+        ColorAuto   -> not `fmap` hIsTerminalDevice stdout+        ColorNever  -> return True+        ColorAlways -> return False++    -- Show those test results to the user as we get them+    fin_tests <- showRunTestsTop isplain (unK $ ropt_hide_successes ropts') running_tests+    let test_statistics' = gatherStatistics fin_tests++    -- Output XML report (if requested)+    case ropt_xml_output ropts' of+        K (Just file) -> XML.produceReport (unK (ropt_xml_nested ropts')) test_statistics' fin_tests >>= writeFile file+        _ -> return ()++    -- Set the error code depending on whether the tests succeeded or not+    exitWith $ if ts_no_failures test_statistics'+               then ExitSuccess+               else ExitFailure 1++-- | Print out a list of available tests.+listTests :: [Test] -> String+listTests tests = "\ntest-framework: All available tests:\n"+++                  "====================================\n"+++                  concat (map (++"\n") (concatMap (showTest "") tests))+  where+    showTest :: String -> Test -> [String]+    showTest path (Test name _testlike)    = ["  "++path ++ name]+    showTest path (TestGroup name gtests)   = concatMap (showTest (path++":"++name)) gtests+    showTest path (PlusTestOptions _ test) = showTest path test+    showTest path (BuildTestBracketed _)   = ["  "++path ++ "<created at runtime>"]+++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,+            ropt_xml_output = K $ ropt_xml_output ro `orElse` Nothing,+            ropt_xml_nested = K $ ropt_xml_nested ro `orElse` False,+            ropt_color_mode = K $ ropt_color_mode ro `orElse` ColorAuto,+            ropt_hide_successes = K $ ropt_hide_successes ro `orElse` False,+            ropt_list_only      = K $ ropt_list_only      ro `orElse` False+        }
+ src/Test/Framework/Runners/Console/Colors.hs view
@@ -0,0 +1,12 @@+module Test.Framework.Runners.Console.Colors where++import Text.PrettyPrint.ANSI.Leijen ( green, red, Doc )+++colorFail, colorPass :: Doc -> Doc+colorFail = red+colorPass = green++colorPassOrFail :: Bool -> Doc -> Doc+colorPassOrFail True  = colorPass+colorPassOrFail False = colorFail
+ src/Test/Framework/Runners/Console/ProgressBar.hs view
@@ -0,0 +1,19 @@+module Test.Framework.Runners.Console.ProgressBar (+        Progress(..), progressBar+    ) where++import Text.PrettyPrint.ANSI.Leijen ( (<>), char, text, Doc )+++data Progress = Progress Int Int++progressBar :: (Doc -> Doc) -> Int -> Progress -> Doc+progressBar 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 ' ')
+ src/Test/Framework/Runners/Console/Run.hs view
@@ -0,0 +1,118 @@+module Test.Framework.Runners.Console.Run (+        showRunTestsTop+    ) where++import Test.Framework.Core+import Test.Framework.Improving+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.Statistics+import Test.Framework.Runners.TimedConsumption+import Test.Framework.Utilities++import System.Console.ANSI ( clearLine, cursorUpLine )+import System.IO ( hFlush, stdout )++import Text.PrettyPrint.ANSI.Leijen+    ( (<>), (<+>),+      brackets, char, empty, indent, linebreak, plain, putDoc, text,+      Doc )++import Control.Arrow (second, (&&&))+import Control.Monad (unless)+++showRunTestsTop :: Bool -> Bool -> [RunningTest] -> IO [FinishedTest]+showRunTestsTop isplain hide_successes running_tests = (if isplain then id else hideCursorDuring) $ do+    -- Show those test results to the user as we get them. Gather statistics on the fly for a progress bar+    let test_statistics = initialTestStatistics (totalRunTestsList running_tests)+    (test_statistics', finished_tests) <- showRunTests isplain hide_successes 0 test_statistics running_tests++    -- Show the final statistics+    putStrLn ""+    putDoc $ possiblyPlain isplain $ showFinalTestStatistics test_statistics'++    return finished_tests+++-- This code all /really/ sucks.  There must be a better way to separate out the console-updating+-- and the improvement-traversing concerns - but how?+showRunTest :: Bool -> Bool -> Int -> TestStatistics -> RunningTest -> IO (TestStatistics, FinishedTest)+showRunTest isplain hide_successes indent_level test_statistics (RunTest name test_type (SomeImproving improving_result)) = do+    let progress_bar = testStatisticsProgressBar test_statistics+    (property_text, property_suceeded) <- showImprovingTestResult isplain hide_successes indent_level name progress_bar improving_result+    return (updateTestStatistics (\count -> adjustTestCount test_type count mempty) property_suceeded test_statistics, RunTest name test_type (property_text, property_suceeded))+showRunTest isplain hide_successes indent_level test_statistics (RunTestGroup name tests) = do+    putDoc $ (indent indent_level (text name <> char ':')) <> linebreak+    fmap (second $ RunTestGroup name) $ showRunTests isplain hide_successes (indent_level + 2) test_statistics tests++showRunTests :: Bool -> Bool -> Int -> TestStatistics -> [RunningTest] -> IO (TestStatistics, [FinishedTest])+showRunTests isplain hide_successes indent_level = mapAccumLM (showRunTest isplain hide_successes indent_level)+++testStatisticsProgressBar :: TestStatistics -> Doc+testStatisticsProgressBar test_statistics = progressBar (colorPassOrFail no_failures) terminal_width (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+    -- We assume a terminal width of 80, but we can't make the progress bar 80 characters wide.  Why?  Because if we+    -- do so, when we write the progress bar out Windows will move the cursor onto the next line!  By using a slightly+    -- smaller width we prevent this from happening.  Bit of a hack, but it does the job.+    terminal_width = 79+++showImprovingTestResult :: TestResultlike i r => Bool -> Bool -> Int -> String -> Doc -> (i :~> r) -> IO (String, Bool)+showImprovingTestResult isplain hide_successes indent_level test_name progress_bar improving = do+    -- Consume the improving value until the end, displaying progress if we are not in "plain" mode+    (result, success) <- if isplain then return $ improvingLast improving'+                                    else showImprovingTestResultProgress (return ()) indent_level test_name progress_bar improving'+    unless (success && hide_successes) $ do+        let (result_doc, extra_doc) | success   = (brackets $ colorPass (text result), empty)+                                    | otherwise = (brackets (colorFail (text "Failed")), text result <> linebreak)++        -- Output the final test status and a trailing newline+        putTestHeader indent_level test_name (possiblyPlain isplain result_doc)+        -- Output any extra information that may be required, e.g. to show failure reason+        putDoc extra_doc++    return (result, success)+  where+    improving' = bimapImproving show (show &&& testSucceeded) improving++showImprovingTestResultProgress :: IO () -> Int -> String -> Doc -> (String :~> (String, Bool)) -> IO (String, Bool)+showImprovingTestResultProgress erase indent_level test_name progress_bar improving = do+    -- Update the screen every every 200ms+    improving_list <- consumeListInInterval 200000 (consumeImproving improving)+    case listToMaybeLast improving_list of+        Nothing         -> do -- 200ms was somehow not long enough for a single result to arrive: try again!+            showImprovingTestResultProgress erase indent_level test_name progress_bar improving+        Just improving' -> do -- Display that new improving value to the user+            showImprovingTestResultProgress' erase indent_level test_name progress_bar improving'++showImprovingTestResultProgress' :: IO () -> Int -> String -> Doc -> (String :~> (String, Bool)) -> IO (String, Bool)+showImprovingTestResultProgress' erase _ _ _ (Finished result) = do+    erase+    -- 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.+    putStrLn ""+    clearLine+    cursorUpLine 1+    return result+showImprovingTestResultProgress' erase indent_level test_name progress_bar (Improving intermediate rest) = do+    erase+    putTestHeader indent_level test_name (brackets (text intermediate))+    putDoc progress_bar+    hFlush stdout+    showImprovingTestResultProgress (cursorUpLine 1 >> clearLine) indent_level test_name progress_bar rest++possiblyPlain :: Bool -> Doc -> Doc+possiblyPlain True  = plain+possiblyPlain False = id++putTestHeader :: Int -> String -> Doc -> IO ()+putTestHeader indent_level test_name result = putDoc $ (indent indent_level (text test_name <> char ':' <+> result)) <> linebreak
+ src/Test/Framework/Runners/Console/Statistics.hs view
@@ -0,0 +1,42 @@+module Test.Framework.Runners.Console.Statistics (+        showFinalTestStatistics+    ) where++import Test.Framework.Runners.Statistics+import Test.Framework.Runners.Console.Colors+import Test.Framework.Runners.Console.Table++import Text.PrettyPrint.ANSI.Leijen ( empty, text, Doc )++import Data.List ( sort )+++-- | 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)
+ src/Test/Framework/Runners/Console/Table.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}++module Test.Framework.Runners.Console.Table (+        Cell(..), Column(..), renderTable+    ) where++import Test.Framework.Utilities++import Text.PrettyPrint.ANSI.Leijen+    ( (<>), char, empty, fill, hcat, line, text, Doc )++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
+ src/Test/Framework/Runners/Console/Utilities.hs view
@@ -0,0 +1,12 @@+module Test.Framework.Runners.Console.Utilities (+        hideCursorDuring+    ) where++import System.Console.ANSI ( hideCursor, showCursor )+import System.IO ( hFlush, stdout )++import Control.Exception (bracket)+++hideCursorDuring :: IO a -> IO a+hideCursorDuring action = bracket hideCursor (const (showCursor >> hFlush stdout)) (const action)
+ src/Test/Framework/Runners/Core.hs view
@@ -0,0 +1,120 @@+module Test.Framework.Runners.Core (+        RunTest(..), RunningTest, SomeImproving(..), FinishedTest, runTests,+        TestRunner(..), runTestTree+    ) where++import Test.Framework.Core+import Test.Framework.Improving+import Test.Framework.Options+import Test.Framework.Runners.Options+import Test.Framework.Runners.TestPattern+import Test.Framework.Runners.ThreadPool+import Test.Framework.Seed+import Test.Framework.Utilities++import Control.Concurrent.MVar ( newEmptyMVar, putMVar, takeMVar )+import Control.Exception (mask, finally, onException)+import Control.Monad ( liftM, forM )+import Data.Maybe ( catMaybes )+import Data.Typeable ( Typeable )+++-- | A test that has been executed or is in the process of execution+data RunTest a = RunTest TestName TestTypeName a+               | RunTestGroup TestName [RunTest a]+               deriving (Show)++data SomeImproving = forall i r. TestResultlike i r => SomeImproving (i :~> r)+type RunningTest = RunTest SomeImproving++type FinishedTest = RunTest (String, Bool)++runTests :: CompleteRunnerOptions -- ^ Top-level runner options+         -> [Test]                -- ^ Tests to run+         -> IO [RunningTest]+runTests ropts tests = do+    let test_patterns = unK $ ropt_test_patterns ropts+        test_options  = unK $ ropt_test_options  ropts+    (run_tests, actions) <- runTests' $ map (runTestTree test_options test_patterns) tests+    _ <- executeOnPool (unK $ ropt_threads ropts) actions+    return run_tests++-- | 'TestRunner' class simplifies folding a 'Test'. You need to specify+-- the important semantic actions by instantiating this class, and+-- 'runTestTree' will take care of recursion and test filtering.+class TestRunner b where+    -- | How to handle a single test+    runSimpleTest :: (Testlike i r t, Typeable t) => TestOptions -> TestName -> t -> b+    -- | How to skip a test that doesn't satisfy the pattern+    skipTest :: b+    -- | How to handle an IO test (created with 'buildTestBracketed')+    runIOTest :: IO (b, IO ()) -> b+    -- | How to run a test group+    runGroup :: TestName -> [b] -> b++-- | Run the test tree using a 'TestRunner'+runTestTree+    :: TestRunner b+    => TestOptions+    -> [TestPattern]+    -- ^ skip the tests that do not match any of these patterns, unless+    -- the list is empty+    -> Test+    -> b+runTestTree initialOpts pats topTest = go initialOpts [] topTest+    where+    go opts path t = case t of+        Test name testlike ->+            if null pats || any (`testPatternMatches` (path ++ [name])) pats+                then runSimpleTest opts name testlike+                else skipTest+        TestGroup name tests ->+            let path' = path ++ [name]+            in runGroup name $ map (go opts path') tests+        PlusTestOptions extra_topts test -> go (opts `mappend` extra_topts) path test+        BuildTestBracketed build ->+            runIOTest $ onLeft (go opts path) `fmap` build++newtype StdRunner = StdRunner { run :: IO (Maybe (RunningTest, [IO ()])) }++instance TestRunner StdRunner where+    runSimpleTest topts name testlike = StdRunner $ do+        (result, action) <- runTest (completeTestOptions topts) testlike+        return (Just (RunTest name (testTypeName testlike) (SomeImproving result), [action]))++    skipTest = StdRunner $ return Nothing++    runGroup name tests = StdRunner $ do+        (results, actions) <- runTests' tests+        return $ if null results then Nothing else Just ((RunTestGroup name results), actions)++    runIOTest ioTest = StdRunner $ mask $ \restore -> ioTest >>= \(StdRunner test, cleanup) -> do+        mb_res <- restore test `onException` cleanup+        case mb_res of+            -- No sub-tests: perform the cleanup NOW+            Nothing                  -> cleanup >> return Nothing+            Just (run_test, actions) -> do+                -- Sub-tests: perform the cleanup as soon as each of them have completed+                (mvars, actions') <- liftM unzip $ forM actions $ \action -> do+                    mvar <- newEmptyMVar+                    return (mvar, action `finally` putMVar mvar ())+                -- NB: the takeMVar action MUST be last in the list because the returned actions are+                -- scheduled left-to-right, and we want all the actions we depend on to be scheduled+                -- before we wait for them to complete, or we might deadlock.+                --+                -- FIXME: this is a bit of a hack because it uses one pool thread just waiting+                -- for some other pool threads to complete! Switch to parallel-io?+                return $ Just (run_test, actions' ++ [(cleanup >> mapM_ takeMVar mvars)])++runTests' :: [StdRunner] -> IO ([RunningTest], [IO ()])+runTests' = fmap (onRight concat . unzip . catMaybes) . mapM run++completeTestOptions :: TestOptions -> CompleteTestOptions+completeTestOptions to = TestOptions {+            topt_seed = K $ topt_seed to `orElse` RandomSeed,+            topt_maximum_generated_tests = K $ topt_maximum_generated_tests to `orElse` 100,+            topt_maximum_unsuitable_generated_tests = K $ topt_maximum_unsuitable_generated_tests to `orElse` 1000,+            topt_maximum_test_size = K $ topt_maximum_test_size to `orElse` 100,+            topt_maximum_test_depth = K $ topt_maximum_test_depth to `orElse` 5,+            topt_timeout = K $ topt_timeout to `orElse` Nothing+        }
+ src/Test/Framework/Runners/Options.hs view
@@ -0,0 +1,52 @@+module Test.Framework.Runners.Options (+        module Test.Framework.Runners.Options,+        TestPattern+    ) where++import Test.Framework.Options+import Test.Framework.Utilities+import Test.Framework.Runners.TestPattern++import Data.Monoid ( Last(Last, getLast) )+import Data.Semigroup as Sem ( Semigroup((<>)) )++data ColorMode = ColorAuto | ColorNever | ColorAlways++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],+        ropt_xml_output :: f (Maybe FilePath),+        ropt_xml_nested :: f Bool,+        ropt_color_mode :: f ColorMode,+        ropt_hide_successes :: f Bool,+        ropt_list_only  :: f Bool+    }++instance Semigroup (RunnerOptions' Maybe) where+    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,+            ropt_xml_output = mappendBy ropt_xml_output ro1 ro2,+            ropt_xml_nested = getLast (mappendBy (Last . ropt_xml_nested) ro1 ro2),+            ropt_color_mode = getLast (mappendBy (Last . ropt_color_mode) ro1 ro2),+            ropt_hide_successes = getLast (mappendBy (Last . ropt_hide_successes) ro1 ro2),+            ropt_list_only      = getLast (mappendBy (Last . ropt_list_only)      ro1 ro2)+        }++instance Monoid (RunnerOptions' Maybe) where+    mempty = RunnerOptions {+            ropt_threads = Nothing,+            ropt_test_options = Nothing,+            ropt_test_patterns = Nothing,+            ropt_xml_output = Nothing,+            ropt_xml_nested = Nothing,+            ropt_color_mode = Nothing,+            ropt_hide_successes = Nothing,+            ropt_list_only      = Nothing+        }++    mappend = (Sem.<>)
+ src/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
+ src/Test/Framework/Runners/Statistics.hs view
@@ -0,0 +1,105 @@+module Test.Framework.Runners.Statistics (+        TestCount, testCountTestTypes, testCountForType, adjustTestCount, testCountTotal,+        TestStatistics(..), ts_pending_tests, ts_no_failures,+        initialTestStatistics, updateTestStatistics,+        totalRunTestsList, gatherStatistics+  ) where++import Test.Framework.Core (TestTypeName)+import Test.Framework.Runners.Core++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Semigroup as Sem+++-- | 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 Semigroup TestCount where+    TestCount tcm1 <> TestCount tcm2 = TestCount $ Map.unionWith (+) tcm1 tcm2++instance Monoid TestCount where+    mempty = TestCount $ Map.empty+    mappend = (Sem.<>)++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+    }++instance Semigroup TestStatistics where+    TestStatistics tot1 run1 pas1 fai1 <> TestStatistics tot2 run2 pas2 fai2 = TestStatistics (tot1 Sem.<> tot2) (run1 Sem.<> run2) (pas1 Sem.<> pas2) (fai1 Sem.<> fai2)++instance Monoid TestStatistics where+    mempty = TestStatistics mempty mempty mempty mempty+    mappend = (Sem.<>)++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+    }++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))+    }+++totalRunTests :: RunTest a -> TestCount+totalRunTests (RunTest _ test_type _) = adjustTestCount test_type 1 mempty+totalRunTests (RunTestGroup _ tests)  = totalRunTestsList tests++totalRunTestsList :: [RunTest a] -> TestCount+totalRunTestsList = mconcat . map totalRunTests++gatherStatistics :: [FinishedTest] -> TestStatistics+gatherStatistics = mconcat . map f+  where+    f (RunTest _ test_type (_, success)) = singleTestStatistics test_type success+    f (RunTestGroup _ tests)             = gatherStatistics tests++    singleTestStatistics :: String -> Bool -> TestStatistics+    singleTestStatistics test_type success = TestStatistics {+            ts_total_tests = one,+            ts_run_tests = one,+            ts_passed_tests = if success then one else mempty,+            ts_failed_tests = if success then mempty else one+        }+      where one = adjustTestCount test_type 1 mempty
+ src/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 ( inits, intersperse )+++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)
+ src/Test/Framework/Runners/ThreadPool.hs view
@@ -0,0 +1,112 @@+module Test.Framework.Runners.ThreadPool (+        executeOnPool+    ) where++import Control.Concurrent+    ( getChanContents,+      newChan,+      readChan,+      writeChan,+      writeList2Chan,+      forkIO,+      myThreadId,+      Chan )+import Control.Monad ( forM_ )++import qualified Data.IntMap as IM++import Foreign.StablePtr ( newStablePtr )+++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)++    -- Short version: make sure we do the right thing if a test blocks on dead+    -- MVars or TVars.+    -- Long version: GHC is clever enough to throw an exception (BlockedOnDeadMVar+    -- or BlockedIndefinitely) when a thread is waiting for a MVar or TVar that can't+    -- be written to. However, it doesn't know anything about the handlers for those+    -- exceptions. Therefore, when a worker runs a test that causes this exception,+    -- since the main thread is blocking on the worker, the main thread gets the+    -- exception too despite the fact that the main thread will be runnable as soon+    -- as the worker catches its own exception. The below makes sure the main thread+    -- is always reachable by the GC, which is the mechanism for finding threads+    -- that are unrunnable.+    -- See also the ticket where SimonM (semi-cryptically) explains this:+    -- http://hackage.haskell.org/trac/ghc/ticket/3291+    --+    -- NB: this actually leaks stable pointers. We could prevent this by making+    -- takeWhileWorkersExist do |unsafePerformIO newStablePtr| when returning the+    -- lazily-demanded tail of the list, but its a bit of a pain. For now, just+    -- grit our teeth and accept the leak.+    _stablePtr <- myThreadId >>= newStablePtr++    -- 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+-- received 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 -}
+ src/Test/Framework/Runners/TimedConsumption.hs view
@@ -0,0 +1,29 @@+module Test.Framework.Runners.TimedConsumption (+        consumeListInInterval+    ) where++import Test.Framework.Utilities++import System.CPUTime ( getCPUTime )+++-- | 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 []
+ src/Test/Framework/Runners/XML.hs view
@@ -0,0 +1,47 @@+module Test.Framework.Runners.XML (+        produceReport+    ) where++import Test.Framework.Runners.Statistics       ( testCountTotal, TestStatistics(..) )+import Test.Framework.Runners.Core             ( FinishedTest )+import Test.Framework.Runners.XML.JUnitWriter  ( RunDescription(..), serialize )++import Data.Time.Format    ( formatTime )+import Data.Time.LocalTime ( getZonedTime )+import Data.Time.Format    ( defaultTimeLocale )++import Network.HostName    ( getHostName )+++produceReport :: Bool -> TestStatistics -> [FinishedTest] -> IO String+produceReport nested test_statistics fin_tests = fmap (serialize nested) $ mergeResults test_statistics fin_tests+++-- | Generates a description of the complete test run, given some+-- initial over-all test statistics and the list of tests that was+-- run.+--+-- This is only specific to the XML code because the console output+-- @Runner@ doesn't need this level of detail to produce summary+-- information, and the per-test details are generated during+-- execution.+--+-- This could be done better by using a State monad in the notifier+-- defined within `issueTests`.+mergeResults :: TestStatistics -> [FinishedTest] -> IO RunDescription+mergeResults test_statistics fin_tests = do+  host <- getHostName+  theTime <- getZonedTime+  return RunDescription {+            errors = 0                  -- not yet available+          , failedCount = testCountTotal (ts_failed_tests test_statistics) -- this includes errors+          , skipped = Nothing           -- not yet applicable+          , hostname = Just host+          , suiteName = "test-framework tests" -- not yet available+          , testCount = testCountTotal (ts_total_tests test_statistics)+          , time = 0.0                  -- We don't currently measure the test run time.+          , timeStamp = Just $ formatTime defaultTimeLocale "%a %B %e %k:%M:%S %Z %Y" theTime -- e.g. Thu May  6 22:09:10 BST 2010+          , runId = Nothing             -- not applicable+          , package = Nothing           -- not yet available+          , tests = fin_tests+          }
+ src/Test/Framework/Runners/XML/JUnitWriter.hs view
@@ -0,0 +1,89 @@+module Test.Framework.Runners.XML.JUnitWriter (+        RunDescription(..),+        serialize,+#ifdef TEST+        morphFlatTestCase, morphNestedTestCase+#endif+    ) where++import Test.Framework.Core (TestName)+import Test.Framework.Runners.Core (RunTest(..), FinishedTest)++import Data.List  ( intercalate )+import Data.Maybe ( fromMaybe )+import Text.XML.Light ( ppTopElement, unqual, unode+                      , Attr(..), Element(..) )+++-- | An overall description of the test suite run.  This is currently+-- styled after the JUnit xml.  It contains records that are not yet+-- used, however, it provides a sensible structure to populate as we+-- are able, and the serialization code behaves as though these are+-- filled.+data RunDescription = RunDescription {+    errors :: Int -- ^ The number of tests that triggered error+                  -- conditions (unanticipated failures)+  , failedCount :: Int        -- ^ Count of tests that invalidated stated assertions.+  , skipped :: Maybe Int      -- ^ Count of tests that were provided but not run.+  , hostname :: Maybe String  -- ^ The hostname that ran the test suite.+  , suiteName :: String       -- ^ The name of the test suite.+  , testCount :: Int          -- ^ The total number of tests provided.+  , time :: Double            -- ^ The total execution time for the test suite.+  , timeStamp :: Maybe String -- ^ The time stamp that identifies when this run happened.+  , runId :: Maybe String     -- ^ Included for completness w/ junit.+  , package :: Maybe String   -- ^ holdover from Junit spec. Could be+                              -- used to specify the module under test.+  , tests :: [FinishedTest]   -- ^ detailed description and results for each test run.+  } deriving (Show)+++-- | Serializes a `RunDescription` value to a `String`.+serialize :: Bool -> RunDescription -> String+serialize nested = ppTopElement . toXml nested++-- | Maps a `RunDescription` value to an XML Element+toXml :: Bool -> RunDescription -> Element+toXml nested runDesc = unode "testsuite" (attrs, morph_cases (tests runDesc))+  where+    morph_cases | nested    = map morphNestedTestCase+                | otherwise = concatMap (morphFlatTestCase [])++    -- | Top-level attributes for the first @testsuite@ tag.+    attrs :: [Attr]+    attrs = map (\(x,f)->Attr (unqual x) (f runDesc)) fields+    fields = [ ("errors",    show . errors)+             , ("failures",  show . failedCount)+             , ("skipped",   fromMaybe "" . fmap show . skipped)+             , ("hostname",  fromMaybe "" . hostname)+             , ("name",      id . suiteName)+             , ("tests",     show . testCount)+             , ("time",      show . time)+             , ("timestamp", fromMaybe "" . timeStamp)+             , ("id",        fromMaybe "" . runId)+             , ("package",   fromMaybe "" . package)+             ]++morphFlatTestCase :: [String] -> FinishedTest -> [Element]+morphFlatTestCase path (RunTestGroup gname testList)+  = concatMap (morphFlatTestCase (gname:path)) testList+morphFlatTestCase path (RunTest tName _ res) = [morphOneTestCase cName tName res]+  where cName | null path = "<none>"+              | otherwise = intercalate "." (reverse path)++morphNestedTestCase :: FinishedTest -> Element+morphNestedTestCase (RunTestGroup gname testList) =+  unode "testsuite" (attrs, map morphNestedTestCase testList)+  where attrs = [ Attr (unqual "name") gname ]+morphNestedTestCase (RunTest tName _ res) = morphOneTestCase "" tName res++morphOneTestCase :: String -> TestName -> (String, Bool) -> Element+morphOneTestCase cName tName (tout, pass) = case pass of+  True  -> unode "testcase" caseAttrs+  False -> unode "testcase" (caseAttrs, unode "failure" (failAttrs, tout))+  where caseAttrs = [ Attr (unqual "name") tName+                    , Attr (unqual "classname") cName+                    , Attr (unqual "time") ""+                    ]+        failAttrs = [ Attr (unqual "message") ""+                    , Attr (unqual "type") ""+                    ]
+ src/Test/Framework/Seed.hs view
@@ -0,0 +1,32 @@+module Test.Framework.Seed where++import Test.Framework.Utilities++import System.Random (StdGen, mkStdGen, randomIO)++import Data.Char ( toLower )+++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)
+ src/Test/Framework/Utilities.hs view
@@ -0,0 +1,61 @@+module Test.Framework.Utilities where++import Control.Arrow (first, second)++import Data.Function (on)+import Data.Maybe ( fromMaybe, listToMaybe )+import Data.List (intercalate)+++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 = mappend `on` f++orElse :: Maybe a -> a -> a+orElse = flip fromMaybe++onLeft :: (a -> c) -> (a, b) -> (c, b)+onLeft = first++onRight :: (b -> c) -> (a, b) -> (a, c)+onRight = second++-- | 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 = intercalate "\n"++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
@@ -1,6 +1,7 @@+Cabal-Version:       1.18 Name:                test-framework-Version:             0.4.2.3-Cabal-Version:       >= 1.2.3+Version:             0.8.2.3+ Category:            Testing Synopsis:            Framework for running and organising tests, with HUnit and QuickCheck support Description:         Allows tests such as QuickCheck properties and HUnit test cases to be assembled into test groups, run in@@ -9,25 +10,38 @@ License:             BSD3 License-File:        LICENSE Author:              Max Bolingbroke <batterseapower@hotmail.com>-Maintainer:          Max Bolingbroke <batterseapower@hotmail.com>-Homepage:            http://batterseapower.github.com/test-framework/+Maintainer:          Andreas Abel+Homepage:            https://github.com/haskell/test-framework#readme+Bug-Reports:         https://github.com/haskell/test-framework/issues Build-Type:          Simple -Flag SplitBase-        Description:    Choose the new smaller, split-up base package-        Default:        True--Flag Tests-        Description:    Build the tests-        Default:        False+Tested-With:+  GHC == 9.14.1+  GHC == 9.12.2+  GHC == 9.10.3+  GHC == 9.8.4+  GHC == 9.6.7+  GHC == 9.4.8+  GHC == 9.2.8+  GHC == 9.0.2+  GHC == 8.10.7+  GHC == 8.8.4+  GHC == 8.6.5+  GHC == 8.4.4+  GHC == 8.2.2+  GHC == 8.0.2 +Extra-Doc-Files: ChangeLog.md  Library+        hs-source-dirs:         src         Exposed-Modules:        Test.Framework                                 Test.Framework.Options                                 Test.Framework.Providers.API                                 Test.Framework.Runners.Console                                 Test.Framework.Runners.Options+                                Test.Framework.Runners.TestPattern+                                Test.Framework.Runners.API                                 Test.Framework.Seed          Other-Modules:          Test.Framework.Core@@ -41,23 +55,25 @@                                 Test.Framework.Runners.Core                                 Test.Framework.Runners.Processors                                 Test.Framework.Runners.Statistics-                                Test.Framework.Runners.TestPattern                                 Test.Framework.Runners.ThreadPool                                 Test.Framework.Runners.TimedConsumption                                 Test.Framework.Runners.XML.JUnitWriter                                 Test.Framework.Runners.XML                                 Test.Framework.Utilities -        Build-Depends:          ansi-terminal >= 0.4.0, ansi-wl-pprint >= 0.5.1,-                                regex-posix >= 0.72, extensible-exceptions >= 0.1.1,-                                old-locale >= 1.0, time >= 1.1.2,-                                xml >= 1.3.5, hostname >= 1.0-        if flag(splitBase)-                Build-Depends:          base >= 3 && < 5, random >= 1.0, containers >= 0.1-        else-                Build-Depends:          base < 3+        -- Lower bounds picked from LTS-7.24 (GHC 8.0.1)+        Build-Depends:          base           >= 4.9      && < 5+                              , ansi-terminal  >= 0.6.3    && < 1.2+                              , ansi-wl-pprint >= 0.6.7    && < 1.1+                              , random         >= 1.1      && < 1.4+                              , containers     >= 0.5.7    && < 1+                              , regex-posix    >= 0.95.2   && < 0.97+                              , time           >= 1.6      && < 2+                              , xml            >= 1.3.14   && < 1.4+                              , hostname       >= 1.0      && < 1.1 -        Extensions:             CPP+        Default-Language:       Haskell2010+        Default-Extensions:     CPP                                 PatternGuards                                 ExistentialQuantification                                 RecursiveDo@@ -66,42 +82,66 @@                                 TypeOperators                                 FunctionalDependencies                                 MultiParamTypeClasses+                                NondecreasingIndentation+                                  -- workaround https://github.com/haskell/cabal/issues/4443 -        Ghc-Options:            -Wall+        Ghc-Options:            -Wno-deprecations+                                   -- This package is legacy and won't address deprecation warnings.          if impl(ghc)-                Cpp-Options:            -DCOMPILER_GHC+                Cpp-Options:    -DCOMPILER_GHC -Executable test-framework-tests-        Main-Is:                Test/Framework/Tests.hs -        if !flag(tests)-                Buildable:              False-        else-                Build-Depends:          HUnit >= 1.2, QuickCheck >= 2.3 && < 2.5,-                                        ansi-terminal >= 0.4.0, ansi-wl-pprint >= 0.5.1,-                                        regex-posix >= 0.72, extensible-exceptions >= 0.1.1,-                                        old-locale >= 1.0, time >= 1.1.2,-                                        xml >= 1.3.5, hostname >= 1.0,-                                        libxml >= 0.1.1, bytestring >= 0.9-                if flag(splitBase)-                        Build-Depends:          base >= 3 && < 5, random >= 1.0, containers >= 0.1-                else-                        Build-Depends:          base < 3+Test-Suite test-framework-tests+        hs-source-dirs:         test src+        other-modules:          Test.Framework.Tests.Runners.ThreadPool+                                Test.Framework.Tests.Runners.XMLTests -                Extensions:             CPP-                                        PatternGuards-                                        ExistentialQuantification-                                        RecursiveDo-                                        FlexibleInstances-                                        TypeSynonymInstances-                                        TypeOperators-                                        FunctionalDependencies-                                        MultiParamTypeClasses+                                Test.Framework.Core+                                Test.Framework.Improving+                                Test.Framework.Options+                                Test.Framework.Runners.Core+                                Test.Framework.Runners.Options+                                Test.Framework.Runners.TestPattern+                                Test.Framework.Runners.ThreadPool+                                Test.Framework.Runners.XML.JUnitWriter+                                Test.Framework.Seed+                                Test.Framework.Utilities+        Main-Is:                Tests.hs+        Type:                   exitcode-stdio-1.0 -                Cpp-Options:            -DTEST+        -- Lower bounds from LTS-9.21 (GHC 8.0.2)+        Build-Depends:          HUnit          >= 1.5.0.0+                              , QuickCheck     >= 2.9.2   && < 3+                              , base           >= 4.9     && < 5+                              , random         >= 1.1+                              , containers     >= 0.5.7+                              , regex-posix    >= 0.95.2+                              , xml            >= 1.3.14 -                Ghc-Options:            -Wall -threaded+        Default-Language:       Haskell2010+        Default-Extensions:     CPP+                                PatternGuards+                                ExistentialQuantification+                                RecursiveDo+                                FlexibleInstances+                                TypeSynonymInstances+                                TypeOperators+                                FunctionalDependencies+                                MultiParamTypeClasses+                                NondecreasingIndentation -                if impl(ghc)-                        Cpp-Options:            -DCOMPILER_GHC+        Cpp-Options:            -DTEST++        Ghc-Options:            -threaded+                                -Wall+                                -Wno-deprecations+                                   -- This package is legacy and won't address deprecation warnings.++        if impl(ghc)+                Cpp-Options:    -DCOMPILER_GHC++Source-Repository head+  Type:     git+  Location: https://github.com/haskell/test-framework.git+  subdir:   core
+ test/Test/Framework/Tests/Runners/ThreadPool.hs view
@@ -0,0 +1,35 @@+module Test.Framework.Tests.Runners.ThreadPool (tests) where++import Test.Framework.Runners.ThreadPool++import Test.HUnit ( (@=?), Test(TestCase, TestLabel), Assertion )++import System.Random ( getStdGen, Random(randomRs) )++import Control.Concurrent ( threadDelay )+++tests :: [Test]+tests = [TestLabel "ThreadPool.executeOnPool preserves order"                         (TestCase test_execute_preserves_order),+         TestLabel "ThreadPool.executeOnPool preserves order even with delays"        (TestCase test_execute_preserves_order_even_with_delay),+         TestLabel "ThreadPool.executeOnPool input list can depend on previous items" (TestCase test_execute_schedules_lazily)]++test_execute_preserves_order :: Assertion+test_execute_preserves_order = do+    let input = [1..1000] :: [Int]+    output <- executeOnPool 4 $ map return input+    input @=? output++test_execute_preserves_order_even_with_delay :: Assertion+test_execute_preserves_order_even_with_delay = do+    gen <- getStdGen+    let -- Execute 100 actions with a random delay of up to 50ms each+        input = [1..100] :: [Int]+        actions = zipWith (\n delay -> threadDelay delay >> return n) input (randomRs (0, 50000) gen)+    output <- executeOnPool 4 actions+    input @=? output++test_execute_schedules_lazily :: Assertion+test_execute_schedules_lazily = mdo+    ~(first_output:rest) <- executeOnPool 4 $ return 10 : (return 20) : replicate first_output (return 99) :: IO [Int]+    [10, 20] ++ (replicate 10 99) @=? (first_output:rest)
+ test/Test/Framework/Tests/Runners/XMLTests.hs view
@@ -0,0 +1,97 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Test.Framework.Tests.Runners.XMLTests (+    test, property+  ) where++import Test.Framework.Runners.Core ( RunTest(..), FinishedTest )+import Test.Framework.Runners.XML.JUnitWriter ( RunDescription(..), morphFlatTestCase, serialize )++import Test.HUnit.Base               ( Test(..), (@?=) )+import Test.QuickCheck               ( Arbitrary, sized, Gen, oneof, listOf, arbitrary )+import qualified Test.QuickCheck.Property as QC ( Property, property )++import Control.Monad ( ap, liftM2, liftM3 )++import Data.Maybe ( isJust )++import qualified Text.XML.Light as XML         ( Element, findAttr, unqual )+import qualified Text.XML.Light.Input as XML   ( parseXMLDoc )++-- | `Arbitrary` instance for `TestResult` generation.+instance Arbitrary FinishedTest where+  arbitrary = sized testResult++-- | Size-constrained generator for `TestResult`+testResult :: Int -> Gen FinishedTest+testResult n | n <= 0    = arbitraryTR+             | otherwise = oneof [ liftM2 RunTestGroup arbitraryXmlStr (listOf subResult),+                                  subResult]+               where arbitraryTR = liftM3 RunTest arbitraryXmlStr arbitraryXmlStr+                                   (liftM2 (,) arbitraryXmlStr arbitrary)+                     -- | drastically cut the size at each level.+                     -- round .. -1 is a hack.  It works a bit better+                     -- (is more extreme) than floor and we're really+                     -- just trying to bound the size so that the+                     -- tests finish quickly.  To see how @floor /=+                     -- (-1) + round@ consider the inputs: 0.5, 1.5,+                     -- and 2.5.+                     subResult :: Gen FinishedTest+                     subResult = let reduce x = (round (logBase 32 (fromIntegral x) :: Double)) - 1+                                 in testResult $ reduce n++-- | `RunDescription` generator.  All string records are restricted to valid xml characters.+instance Arbitrary RunDescription where+  arbitrary = do+              return RunDescription+              `ap` arbitrary            -- errors+              `ap` arbitrary            -- failed count+              `ap` arbitrary            -- skipped+              `ap` arbitraryMaybeXmlStr -- hostname+              `ap` arbitraryXmlStr      -- suiteName+              `ap` arbitrary            -- testCount+              `ap` arbitrary            -- time+              `ap` arbitraryMaybeXmlStr -- timeStamp+              `ap` arbitraryMaybeXmlStr -- runId+              `ap` arbitraryMaybeXmlStr -- package+              `ap` arbitrary            -- tests++-- | Generator for strings that only contain valid XML codepoints, and+-- are wrapped in Maybe.  If/when empty strings are generated, they+-- have a 50% chance of being `Nothing`, so this generator should be biased+-- to create `Just` `String`s over `Nothing`+arbitraryMaybeXmlStr :: Gen (Maybe String)+arbitraryMaybeXmlStr = do+  str <- arbitraryXmlStr+  if null str  -- if we have an empty string, we have a chance of generating @Nothing@+    then oneof [return (Just str), return Nothing]+    else return (Just str)++-- | String generator that does not include invalid XML characters.  The+-- set of invalid characters is specified here:+-- http://www.w3.org/TR/2000/REC-xml-20001006#NT-Char+arbitraryXmlStr :: Gen String+arbitraryXmlStr = listOf arbitraryXmlChar+  where+    arbitraryXmlChar :: Gen Char+    arbitraryXmlChar = do c <- arbitrary+                          if validXmlChar (fromEnum c)+                            then return c+                            else arbitraryXmlChar+    validXmlChar c = c == 0x9 || c == 0xA || c == 0xD+                         || (c >= 0x20 && c <= 0xD7FF)+                         || (c >= 0xE000 && c <= 0xFFFD)+                         || (c >= 0x10000 && c <= 0x10FFFF)++-- | Generate random `RunDescriptions`, serialize to (flat) XML strings, then check that they are XML+-- TODO: check them against the JUnit schema+property :: RunDescription -> QC.Property+property = QC.property . isJust . parseSerialize++parseSerialize :: RunDescription -> Maybe XML.Element+parseSerialize = XML.parseXMLDoc . serialize False++-- | Verify that the group names are properly prepended to sub-tests.+test :: Test+test = TestLabel "Check the composition of group names" $ TestCase $+       XML.findAttr (XML.unqual "classname") x @?= Just "top.g1"+  where x = head $ morphFlatTestCase [] $ RunTestGroup "top" [RunTestGroup "g1" [RunTest "t1" "" ("", True)]]
+ test/Tests.hs view
@@ -0,0 +1,16 @@+module Main where++import qualified Test.Framework.Tests.Runners.ThreadPool as TP+import qualified Test.Framework.Tests.Runners.XMLTests as XT++import Test.HUnit ( runTestTT, Test(TestList) )+import Test.QuickCheck ( quickCheck )++-- I wish I could use my test framework to test my framework...+main :: IO ()+main = do+    _ <- runTestTT $ TestList [+      TestList TP.tests,+      XT.test+      ]+    quickCheck XT.property