diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,12 @@ +#### 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 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Test/Framework.hs b/Test/Framework.hs deleted file mode 100644 --- a/Test/Framework.hs +++ /dev/null @@ -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 --- -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 diff --git a/Test/Framework/Core.hs b/Test/Framework/Core.hs deleted file mode 100644 --- a/Test/Framework/Core.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE UndecidableInstances, DeriveDataTypeable #-} -module Test.Framework.Core where - -import Test.Framework.Improving -import Test.Framework.Options - -import Control.Arrow (first, second) -import Control.Concurrent.MVar -import Data.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 --- -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 - deriving Typeable - --- This requires UndecidableInstances, but I think it can't be made inconsistent? -instance Testlike i r t => Testlike i r (MutuallyExcluded t) where - runTest 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) diff --git a/Test/Framework/Improving.hs b/Test/Framework/Improving.hs deleted file mode 100644 --- a/Test/Framework/Improving.hs +++ /dev/null @@ -1,87 +0,0 @@ -module Test.Framework.Improving ( - (:~>)(..), bimapImproving, improvingLast, consumeImproving, - ImprovingIO, yieldImprovement, runImprovingIO, tunnelImprovingIO, liftIO, - timeoutImprovingIO, maybeTimeoutImprovingIO - ) where - -import Control.Concurrent -import Control.Monad -import Control.Applicative as App - -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 Applicative (ImprovingIO i f) where - pure x = IIO (const $ return x) - (<*>) = ap - -instance Monad (ImprovingIO i f) where - return = App.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 diff --git a/Test/Framework/Options.hs b/Test/Framework/Options.hs deleted file mode 100644 --- a/Test/Framework/Options.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Test.Framework.Options where - -import Test.Framework.Seed -import Test.Framework.Utilities - -import Data.Monoid -import Data.Semigroup as Sem hiding (Last(..)) - - -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.<>) diff --git a/Test/Framework/Providers/API.hs b/Test/Framework/Providers/API.hs deleted file mode 100644 --- a/Test/Framework/Providers/API.hs +++ /dev/null @@ -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 diff --git a/Test/Framework/Runners/API.hs b/Test/Framework/Runners/API.hs deleted file mode 100644 --- a/Test/Framework/Runners/API.hs +++ /dev/null @@ -1,8 +0,0 @@ --- | 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 diff --git a/Test/Framework/Runners/Console.hs b/Test/Framework/Runners/Console.hs deleted file mode 100644 --- a/Test/Framework/Runners/Console.hs +++ /dev/null @@ -1,182 +0,0 @@ -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 -import System.Environment -import System.Exit -import System.IO - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -#endif -#if !(MIN_VERSION_base(4,7,0)) -import Data.Orphans () -#endif - --- | @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 succeded 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 ++ ""] - - -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 - } diff --git a/Test/Framework/Runners/Console/Colors.hs b/Test/Framework/Runners/Console/Colors.hs deleted file mode 100644 --- a/Test/Framework/Runners/Console/Colors.hs +++ /dev/null @@ -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 diff --git a/Test/Framework/Runners/Console/ProgressBar.hs b/Test/Framework/Runners/Console/ProgressBar.hs deleted file mode 100644 --- a/Test/Framework/Runners/Console/ProgressBar.hs +++ /dev/null @@ -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 ' ') diff --git a/Test/Framework/Runners/Console/Run.hs b/Test/Framework/Runners/Console/Run.hs deleted file mode 100644 --- a/Test/Framework/Runners/Console/Run.hs +++ /dev/null @@ -1,119 +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 - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (mempty) -#endif - -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 diff --git a/Test/Framework/Runners/Console/Statistics.hs b/Test/Framework/Runners/Console/Statistics.hs deleted file mode 100644 --- a/Test/Framework/Runners/Console/Statistics.hs +++ /dev/null @@ -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) diff --git a/Test/Framework/Runners/Console/Table.hs b/Test/Framework/Runners/Console/Table.hs deleted file mode 100644 --- a/Test/Framework/Runners/Console/Table.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Test.Framework.Runners.Console.Table ( - Cell(..), Column(..), renderTable - ) where - -import Test.Framework.Utilities - -#if MIN_VERSION_ansi_wl_pprint(0,6,6) -import Text.PrettyPrint.ANSI.Leijen hiding (column, columns) -#else -import Text.PrettyPrint.ANSI.Leijen hiding (column) -#endif - -data Cell = TextCell Doc - | SeperatorCell - -data Column = Column [Cell] - | SeperatorColumn - -type ColumnWidth = Int - -renderTable :: [Column] -> Doc -renderTable = renderColumnsWithWidth . map (\column -> (findColumnWidth column, column)) - - -findColumnWidth :: Column -> Int -findColumnWidth SeperatorColumn = 0 -findColumnWidth (Column cells) = maximum (map findCellWidth cells) - -findCellWidth :: Cell -> Int -findCellWidth (TextCell doc) = maximum (0 : map length (lines (shows doc ""))) -findCellWidth SeperatorCell = 0 - - -renderColumnsWithWidth :: [(ColumnWidth, Column)] -> Doc -renderColumnsWithWidth columns - | all (columnFinished . snd) columns - = empty - | otherwise - = first_cells_str <> line <> - renderColumnsWithWidth (map (onRight columnDropHead) columns) - where - first_cells_str = hcat $ zipWith (uncurry renderFirstColumnCell) columns (eitherSideSeperator (map snd columns)) - - -eitherSideSeperator :: [Column] -> [Bool] -eitherSideSeperator columns = zipWith (||) (False:column_is_seperator) (tail column_is_seperator ++ [False]) - where - column_is_seperator = map isSeperatorColumn columns - -isSeperatorColumn :: Column -> Bool -isSeperatorColumn SeperatorColumn = False -isSeperatorColumn (Column cells) = case cells of - [] -> False - (cell:_) -> isSeperatorCell cell - -isSeperatorCell :: Cell -> Bool -isSeperatorCell SeperatorCell = True -isSeperatorCell _ = False - - -renderFirstColumnCell :: ColumnWidth -> Column -> Bool -> Doc -renderFirstColumnCell column_width (Column cells) _ = case cells of - [] -> text $ replicate (column_width + 2) ' ' - (SeperatorCell:_) -> text $ replicate (column_width + 2) '-' - (TextCell contents:_) -> char ' ' <> fill column_width contents <> char ' ' -renderFirstColumnCell _ SeperatorColumn either_side_seperator - = if either_side_seperator then char '+' else char '|' - -columnFinished :: Column -> Bool -columnFinished (Column cells) = null cells -columnFinished SeperatorColumn = True - -columnDropHead :: Column -> Column -columnDropHead (Column cells) = Column (drop 1 cells) -columnDropHead SeperatorColumn = SeperatorColumn diff --git a/Test/Framework/Runners/Console/Utilities.hs b/Test/Framework/Runners/Console/Utilities.hs deleted file mode 100644 --- a/Test/Framework/Runners/Console/Utilities.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Test.Framework.Runners.Console.Utilities ( - hideCursorDuring - ) where - -import System.Console.ANSI -import System.IO - -import Control.Exception (bracket) - - -hideCursorDuring :: IO a -> IO a -hideCursorDuring action = bracket hideCursor (const (showCursor >> hFlush stdout)) (const action) diff --git a/Test/Framework/Runners/Core.hs b/Test/Framework/Runners/Core.hs deleted file mode 100644 --- a/Test/Framework/Runners/Core.hs +++ /dev/null @@ -1,123 +0,0 @@ -module Test.Framework.Runners.Core ( - RunTest(..), RunningTest, SomeImproving(..), FinishedTest, runTests, - TestRunner(..), runTestTree - ) where - -import Test.Framework.Core -import Test.Framework.Improving -import Test.Framework.Options -import Test.Framework.Runners.Options -import Test.Framework.Runners.TestPattern -import Test.Framework.Runners.ThreadPool -import Test.Framework.Seed -import Test.Framework.Utilities - -import Control.Concurrent.MVar -import Control.Exception (mask, finally, onException) -import Control.Monad -import Data.Maybe -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -#endif -import Data.Typeable - - --- | A test that has been executed or is in the process of execution -data RunTest a = RunTest TestName TestTypeName a - | RunTestGroup TestName [RunTest a] - deriving (Show) - -data SomeImproving = forall i r. TestResultlike i r => SomeImproving (i :~> r) -type RunningTest = RunTest SomeImproving - -type FinishedTest = RunTest (String, Bool) - -runTests :: CompleteRunnerOptions -- ^ Top-level runner options - -> [Test] -- ^ Tests to run - -> IO [RunningTest] -runTests ropts tests = do - let test_patterns = unK $ ropt_test_patterns ropts - test_options = unK $ ropt_test_options ropts - (run_tests, actions) <- runTests' $ map (runTestTree test_options test_patterns) tests - _ <- executeOnPool (unK $ ropt_threads ropts) actions - return run_tests - --- | 'TestRunner' class simplifies folding a 'Test'. You need to specify --- the important semantic actions by instantiating this class, and --- 'runTestTree' will take care of recursion and test filtering. -class TestRunner b where - -- | How to handle a single test - runSimpleTest :: (Testlike i r t, Typeable t) => TestOptions -> TestName -> t -> b - -- | How to skip a test that doesn't satisfy the pattern - skipTest :: b - -- | How to handle an IO test (created with 'buildTestBracketed') - runIOTest :: IO (b, IO ()) -> b - -- | How to run a test group - runGroup :: TestName -> [b] -> b - --- | Run the test tree using a 'TestRunner' -runTestTree - :: TestRunner b - => TestOptions - -> [TestPattern] - -- ^ skip the tests that do not match any of these patterns, unless - -- the list is empty - -> Test - -> b -runTestTree initialOpts pats topTest = go initialOpts [] topTest - where - go opts path t = case t of - Test name testlike -> - if null pats || any (`testPatternMatches` (path ++ [name])) pats - then runSimpleTest opts name testlike - else skipTest - TestGroup name tests -> - let path' = path ++ [name] - in runGroup name $ map (go opts path') tests - PlusTestOptions extra_topts test -> go (opts `mappend` extra_topts) path test - BuildTestBracketed build -> - runIOTest $ onLeft (go opts path) `fmap` build - -newtype StdRunner = StdRunner { run :: IO (Maybe (RunningTest, [IO ()])) } - -instance TestRunner StdRunner where - runSimpleTest topts name testlike = StdRunner $ do - (result, action) <- runTest (completeTestOptions topts) testlike - return (Just (RunTest name (testTypeName testlike) (SomeImproving result), [action])) - - skipTest = StdRunner $ return Nothing - - runGroup name tests = StdRunner $ do - (results, actions) <- runTests' tests - return $ if null results then Nothing else Just ((RunTestGroup name results), actions) - - runIOTest ioTest = StdRunner $ mask $ \restore -> ioTest >>= \(StdRunner test, cleanup) -> do - mb_res <- restore test `onException` cleanup - case mb_res of - -- No sub-tests: perform the cleanup NOW - Nothing -> cleanup >> return Nothing - Just (run_test, actions) -> do - -- Sub-tests: perform the cleanup as soon as each of them have completed - (mvars, actions') <- liftM unzip $ forM actions $ \action -> do - mvar <- newEmptyMVar - return (mvar, action `finally` putMVar mvar ()) - -- NB: the takeMVar action MUST be last in the list because the returned actions are - -- scheduled left-to-right, and we want all the actions we depend on to be scheduled - -- before we wait for them to complete, or we might deadlock. - -- - -- FIXME: this is a bit of a hack because it uses one pool thread just waiting - -- for some other pool threads to complete! Switch to parallel-io? - return $ Just (run_test, actions' ++ [(cleanup >> mapM_ takeMVar mvars)]) - -runTests' :: [StdRunner] -> IO ([RunningTest], [IO ()]) -runTests' = fmap (onRight concat . unzip . catMaybes) . mapM run - -completeTestOptions :: TestOptions -> CompleteTestOptions -completeTestOptions to = TestOptions { - topt_seed = K $ topt_seed to `orElse` RandomSeed, - topt_maximum_generated_tests = K $ topt_maximum_generated_tests to `orElse` 100, - topt_maximum_unsuitable_generated_tests = K $ topt_maximum_unsuitable_generated_tests to `orElse` 1000, - topt_maximum_test_size = K $ topt_maximum_test_size to `orElse` 100, - topt_maximum_test_depth = K $ topt_maximum_test_depth to `orElse` 5, - topt_timeout = K $ topt_timeout to `orElse` Nothing - } diff --git a/Test/Framework/Runners/Options.hs b/Test/Framework/Runners/Options.hs deleted file mode 100644 --- a/Test/Framework/Runners/Options.hs +++ /dev/null @@ -1,52 +0,0 @@ -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 -import Data.Semigroup as Sem hiding (Last(..)) - -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.<>) diff --git a/Test/Framework/Runners/Processors.hs b/Test/Framework/Runners/Processors.hs deleted file mode 100644 --- a/Test/Framework/Runners/Processors.hs +++ /dev/null @@ -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 diff --git a/Test/Framework/Runners/Statistics.hs b/Test/Framework/Runners/Statistics.hs deleted file mode 100644 --- a/Test/Framework/Runners/Statistics.hs +++ /dev/null @@ -1,108 +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 -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -#endif -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 diff --git a/Test/Framework/Runners/TestPattern.hs b/Test/Framework/Runners/TestPattern.hs deleted file mode 100644 --- a/Test/Framework/Runners/TestPattern.hs +++ /dev/null @@ -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) diff --git a/Test/Framework/Runners/ThreadPool.hs b/Test/Framework/Runners/ThreadPool.hs deleted file mode 100644 --- a/Test/Framework/Runners/ThreadPool.hs +++ /dev/null @@ -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 -} diff --git a/Test/Framework/Runners/TimedConsumption.hs b/Test/Framework/Runners/TimedConsumption.hs deleted file mode 100644 --- a/Test/Framework/Runners/TimedConsumption.hs +++ /dev/null @@ -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 [] diff --git a/Test/Framework/Runners/XML.hs b/Test/Framework/Runners/XML.hs deleted file mode 100644 --- a/Test/Framework/Runners/XML.hs +++ /dev/null @@ -1,52 +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 ) - -#if MIN_VERSION_time(1,5,0) -import Data.Time.Format ( defaultTimeLocale ) -#else -import System.Locale ( defaultTimeLocale ) -#endif - -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 - } diff --git a/Test/Framework/Runners/XML/JUnitWriter.hs b/Test/Framework/Runners/XML/JUnitWriter.hs deleted file mode 100644 --- a/Test/Framework/Runners/XML/JUnitWriter.hs +++ /dev/null @@ -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 = "" - | 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") "" - ] diff --git a/Test/Framework/Seed.hs b/Test/Framework/Seed.hs deleted file mode 100644 --- a/Test/Framework/Seed.hs +++ /dev/null @@ -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) diff --git a/Test/Framework/Tests.hs b/Test/Framework/Tests.hs deleted file mode 100644 --- a/Test/Framework/Tests.hs +++ /dev/null @@ -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 diff --git a/Test/Framework/Utilities.hs b/Test/Framework/Utilities.hs deleted file mode 100644 --- a/Test/Framework/Utilities.hs +++ /dev/null @@ -1,64 +0,0 @@ -module Test.Framework.Utilities where - -import Control.Arrow (first, second) - -import Data.Function (on) -import Data.Maybe -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -#endif -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 diff --git a/src/Test/Framework.hs b/src/Test/Framework.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework.hs @@ -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 +-- +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 diff --git a/src/Test/Framework/Core.hs b/src/Test/Framework/Core.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Core.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE UndecidableInstances, DeriveDataTypeable #-} +module Test.Framework.Core where + +import Test.Framework.Improving +import Test.Framework.Options + +import Control.Arrow (first, second) +import Control.Concurrent.MVar ( withMVar, newMVar, MVar ) +import Data.Typeable ( Typeable ) + + +-- | Something like the result of a test: works in concert with 'Testlike'. +-- The type parameters are the type that is used for progress reports and the +-- type of the final output of the test respectively. +class (Show i, Show r) => TestResultlike i r | r -> i where + testSucceeded :: r -> Bool + +-- | Something test-like in its behaviour. The type parameters are the type that +-- is used for progress reports, the type of the final output of the test and the +-- data type encapsulating the whole potential to do a test respectively. +class TestResultlike i r => Testlike i r t | t -> i r, r -> i where + runTest :: CompleteTestOptions -> t -> IO (i :~> r, IO ()) + testTypeName :: t -> TestTypeName + + +-- | Test names or descriptions. These are shown to the user +type TestName = String + +-- | The name of a type of test, such as "Properties" or "Test Cases". Tests of +-- types of the same names will be grouped together in the test run summary. +type TestTypeName = String + +-- | Main test data type: builds up a list of tests to be run. Users should use the +-- utility functions in e.g. the test-framework-hunit and test-framework-quickcheck2 +-- packages to create instances of 'Test', and then build them up into testsuites +-- by using 'testGroup' and lists. +-- +-- For an example of how to use test-framework, please see +-- +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 + deriving Typeable + +-- This requires UndecidableInstances, but I think it can't be made inconsistent? +instance Testlike i r t => Testlike i r (MutuallyExcluded t) where + runTest 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) diff --git a/src/Test/Framework/Improving.hs b/src/Test/Framework/Improving.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Improving.hs @@ -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 diff --git a/src/Test/Framework/Options.hs b/src/Test/Framework/Options.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Options.hs @@ -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.<>) diff --git a/src/Test/Framework/Providers/API.hs b/src/Test/Framework/Providers/API.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Providers/API.hs @@ -0,0 +1,21 @@ +-- | This module exports everything that you need to be able to create your own framework test provider. +-- To create a provider you need to: +-- +-- * Create an instance of the 'Testlike' class +-- +-- * Create an instance of the 'TestResultlike' class +-- +-- * Expose a function that lets people construct 'Test' values using your new instances +module Test.Framework.Providers.API ( + module Test.Framework.Core, + module Test.Framework.Improving, + module Test.Framework.Options, + module Test.Framework.Seed, + module Test.Framework.Utilities + ) where + +import Test.Framework.Core +import Test.Framework.Improving +import Test.Framework.Options +import Test.Framework.Seed +import Test.Framework.Utilities diff --git a/src/Test/Framework/Runners/API.hs b/src/Test/Framework/Runners/API.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/API.hs @@ -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 diff --git a/src/Test/Framework/Runners/Console.hs b/src/Test/Framework/Runners/Console.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/Console.hs @@ -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 ++ ""] + + +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 + } diff --git a/src/Test/Framework/Runners/Console/Colors.hs b/src/Test/Framework/Runners/Console/Colors.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/Console/Colors.hs @@ -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 diff --git a/src/Test/Framework/Runners/Console/ProgressBar.hs b/src/Test/Framework/Runners/Console/ProgressBar.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/Console/ProgressBar.hs @@ -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 ' ') diff --git a/src/Test/Framework/Runners/Console/Run.hs b/src/Test/Framework/Runners/Console/Run.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/Console/Run.hs @@ -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 diff --git a/src/Test/Framework/Runners/Console/Statistics.hs b/src/Test/Framework/Runners/Console/Statistics.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/Console/Statistics.hs @@ -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) diff --git a/src/Test/Framework/Runners/Console/Table.hs b/src/Test/Framework/Runners/Console/Table.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/Console/Table.hs @@ -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 diff --git a/src/Test/Framework/Runners/Console/Utilities.hs b/src/Test/Framework/Runners/Console/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/Console/Utilities.hs @@ -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) diff --git a/src/Test/Framework/Runners/Core.hs b/src/Test/Framework/Runners/Core.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/Core.hs @@ -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 + } diff --git a/src/Test/Framework/Runners/Options.hs b/src/Test/Framework/Runners/Options.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/Options.hs @@ -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.<>) diff --git a/src/Test/Framework/Runners/Processors.hs b/src/Test/Framework/Runners/Processors.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/Processors.hs @@ -0,0 +1,17 @@ +module Test.Framework.Runners.Processors ( + processorCount + ) where + +#ifdef COMPILER_GHC + +import GHC.Conc ( numCapabilities ) + +processorCount :: Int +processorCount = numCapabilities + +#else + +processorCount :: Int +processorCount = 1 + +#endif diff --git a/src/Test/Framework/Runners/Statistics.hs b/src/Test/Framework/Runners/Statistics.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/Statistics.hs @@ -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 diff --git a/src/Test/Framework/Runners/TestPattern.hs b/src/Test/Framework/Runners/TestPattern.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/TestPattern.hs @@ -0,0 +1,93 @@ +module Test.Framework.Runners.TestPattern ( + TestPattern, parseTestPattern, testPatternMatches + ) where + +import Test.Framework.Utilities + +import Text.Regex.Posix.Wrap ( (=~) ) +import Text.Regex.Posix.String() + +import Data.List ( 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) diff --git a/src/Test/Framework/Runners/ThreadPool.hs b/src/Test/Framework/Runners/ThreadPool.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/ThreadPool.hs @@ -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 -} diff --git a/src/Test/Framework/Runners/TimedConsumption.hs b/src/Test/Framework/Runners/TimedConsumption.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/TimedConsumption.hs @@ -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 [] diff --git a/src/Test/Framework/Runners/XML.hs b/src/Test/Framework/Runners/XML.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/XML.hs @@ -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 + } diff --git a/src/Test/Framework/Runners/XML/JUnitWriter.hs b/src/Test/Framework/Runners/XML/JUnitWriter.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Runners/XML/JUnitWriter.hs @@ -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 = "" + | 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") "" + ] diff --git a/src/Test/Framework/Seed.hs b/src/Test/Framework/Seed.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Seed.hs @@ -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) diff --git a/src/Test/Framework/Utilities.hs b/src/Test/Framework/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Utilities.hs @@ -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 diff --git a/test-framework.cabal b/test-framework.cabal --- a/test-framework.cabal +++ b/test-framework.cabal @@ -1,6 +1,6 @@ +Cabal-Version: 1.18 Name: test-framework -Version: 0.8.2.0 -Cabal-Version: >= 1.10 +Version: 0.8.2.1 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,15 +9,30 @@ License: BSD3 License-File: LICENSE Author: Max Bolingbroke -Maintainer: Libraries List -Homepage: http://haskell.github.io/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 -Tested-With: GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 -Extra-Source-Files: ChangeLog.md +Tested-With: + GHC == 9.12.1 + GHC == 9.10.1 + GHC == 9.8.4 + GHC == 9.6.6 + 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 @@ -44,23 +59,17 @@ Test.Framework.Runners.XML Test.Framework.Utilities - Build-Depends: base >= 4.3 && < 5 - , ansi-terminal >= 0.4.0 && < 0.9 - , ansi-wl-pprint >= 0.5.1 && < 0.7 - , random >= 1.0 && < 1.2 - , containers >= 0.1 && < 0.6 - , regex-posix >= 0.72 && < 0.96 + Build-Depends: base >= 4.9 && < 5 + , ansi-terminal >= 0.4.0 && < 1.2 + , ansi-wl-pprint >= 0.6.7 && < 1.1 + , random >= 1.1 && < 1.4 + , containers >= 0.1 && < 0.8 + , regex-posix >= 0.72 && < 0.97 , old-locale >= 1.0 && < 1.1 - , time >= 1.1.2 && < 1.9 + , time >= 1.6 && < 1.15 , xml >= 1.3.5 && < 1.4 , hostname >= 1.0 && < 1.1 - if !impl(ghc >= 7.8) - Build-Depends: base-orphans >= 0.1 && < 0.5 - - if !impl(ghc >= 8.0) - Build-Depends: semigroups >= 0.18 && < 0.19 - Default-Language: Haskell2010 Default-Extensions: CPP PatternGuards @@ -71,38 +80,53 @@ TypeOperators FunctionalDependencies MultiParamTypeClasses + NondecreasingIndentation + -- workaround https://github.com/haskell/cabal/issues/4443 - -- workaround https://github.com/haskell/cabal/issues/4443 - if impl(ghc >= 7.2) - Default-Extensions: NondecreasingIndentation - 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 - if impl(ghc >= 8.0) - Ghc-Options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances Test-Suite test-framework-tests - Main-Is: Test/Framework/Tests.hs + hs-source-dirs: test src + other-modules: Test.Framework.Tests.Runners.ThreadPool + Test.Framework.Tests.Runners.XMLTests + + 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 + -- Doe to libxml dependency, the testsuite is not buildable on e.g. MacOS -- Buildable: False - Build-Depends: HUnit >= 1.2 - , QuickCheck >= 2.3 && < 2.10 - , base >= 4.3 - , random >= 1.0 + + Build-Depends: HUnit >= 1.5.0.0 + , QuickCheck >= 2.9.2 && < 2.16 + , base >= 4.9 && < 5 + , random >= 1.1 , containers >= 0.1 , ansi-terminal >= 0.4.0 - , ansi-wl-pprint >= 0.5.1 + , ansi-wl-pprint >= 0.6.7 , regex-posix >= 0.72 , old-locale >= 1.0 - , time >= 1.1.2 + , time >= 1.6 , xml >= 1.3.5 , hostname >= 1.0 , libxml >= 0.1.1 , bytestring >= 0.9 , semigroups >= 0.18 + , utf8-string >= 1.0.1.1 && <1.1 Default-Language: Haskell2010 Default-Extensions: CPP @@ -114,16 +138,17 @@ TypeOperators FunctionalDependencies MultiParamTypeClasses - - if impl(ghc >= 7.2) - Default-Extensions: NondecreasingIndentation + NondecreasingIndentation Cpp-Options: -DTEST - Ghc-Options: -Wall -threaded + Ghc-Options: -threaded + -Wall + -Wno-deprecations + -- This package is legacy and won't address deprecation warnings. if impl(ghc) - Cpp-Options: -DCOMPILER_GHC + Cpp-Options: -DCOMPILER_GHC Source-Repository head Type: git diff --git a/test/Test/Framework/Tests/Runners/ThreadPool.hs b/test/Test/Framework/Tests/Runners/ThreadPool.hs new file mode 100644 --- /dev/null +++ b/test/Test/Framework/Tests/Runners/ThreadPool.hs @@ -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) diff --git a/test/Test/Framework/Tests/Runners/XMLTests.hs b/test/Test/Framework/Tests/Runners/XMLTests.hs new file mode 100644 --- /dev/null +++ b/test/Test/Framework/Tests/Runners/XMLTests.hs @@ -0,0 +1,102 @@ +{-# 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 Test.QuickCheck.Property as P ( Property ) + +import Control.Monad ( ap, liftM2, liftM3 ) + +import Data.Maybe ( isJust ) + +import qualified Data.ByteString.UTF8 as UTF8 + +import qualified Text.XML.Light as XML ( findAttr, unqual ) +import qualified Text.XML.LibXML.Parser as XML ( parseMemory_ ) +import qualified Text.XML.LibXML.Types as XML ( Document ) + +import Test.QuickCheck.Property as P (morallyDubiousIOProperty) + +-- | `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 -> P.Property +property = morallyDubiousIOProperty . fmap isJust . parseSerialize + +parseSerialize :: RunDescription -> IO (Maybe XML.Document) +parseSerialize = XML.parseMemory_ . UTF8.fromString . 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)]] diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -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