├── .gitignore ├── README ├── TODO ├── core ├── .ghci ├── LICENSE ├── Setup.lhs ├── Test │ ├── Framework.hs │ └── Framework │ │ ├── Core.hs │ │ ├── Improving.hs │ │ ├── Options.hs │ │ ├── Providers │ │ └── API.hs │ │ ├── Runners │ │ ├── API.hs │ │ ├── Console.hs │ │ ├── Console │ │ │ ├── Colors.hs │ │ │ ├── ProgressBar.hs │ │ │ ├── Run.hs │ │ │ ├── Statistics.hs │ │ │ ├── Table.hs │ │ │ └── Utilities.hs │ │ ├── Core.hs │ │ ├── Options.hs │ │ ├── Processors.hs │ │ ├── Statistics.hs │ │ ├── TestPattern.hs │ │ ├── ThreadPool.hs │ │ ├── TimedConsumption.hs │ │ ├── XML.hs │ │ └── XML │ │ │ └── JUnitWriter.hs │ │ ├── Seed.hs │ │ ├── Tests.hs │ │ ├── Tests │ │ └── Runners │ │ │ ├── ThreadPool.hs │ │ │ └── XMLTests.hs │ │ └── Utilities.hs └── test-framework.cabal ├── example ├── LICENSE ├── Setup.lhs ├── Test │ └── Framework │ │ └── Example.lhs └── test-framework-example.cabal ├── hunit ├── LICENSE ├── Setup.lhs ├── Test │ └── Framework │ │ └── Providers │ │ └── HUnit.hs └── test-framework-hunit.cabal ├── quickcheck ├── LICENSE ├── Setup.lhs ├── Test │ └── Framework │ │ └── Providers │ │ └── QuickCheck.hs └── test-framework-quickcheck.cabal ├── quickcheck2 ├── LICENSE ├── Setup.lhs ├── Test │ └── Framework │ │ └── Providers │ │ └── QuickCheck2.hs └── test-framework-quickcheck2.cabal └── release /.gitignore: -------------------------------------------------------------------------------- 1 | # Operating system junk 2 | .DS_Store 3 | 4 | # Cabal temporary locations 5 | dist/ 6 | 7 | # Build output 8 | *.hi 9 | *.o 10 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | You may want to look at the branch of this project at https://github.com/haskell/test-framework instead, 2 | it may be more actively maintained. -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | === High Priority === 2 | 3 | === Medium Priority === 4 | 5 | === Low Priority === 6 | * Report the number of tests run when a QuickCheck run times out 7 | * Make the cursor un-hide when Ctrl-C is used to exit the program: may involve something like myThreadId >>= \main_thread -> installHandler sigINT (Catch (throwTo main_thread $ ExitException $ ExitFailure 1)) Nothing 8 | * Make the QuickCheck2 provider correlate arguments with test failures (need to change QuickCheck2 upstream...) -------------------------------------------------------------------------------- /core/.ghci: -------------------------------------------------------------------------------- 1 | :set -XCPP -XPatternGuards -XExistentialQuantification -XRecursiveDo -XFlexibleInstances -XTypeOperators -XFunctionalDependencies -XMultiParamTypeClasses -XTypeSynonymInstances 2 | :set -Wall 3 | :set -DTEST 4 | -------------------------------------------------------------------------------- /core/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008, Maximilian Bolingbroke 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted 5 | provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this list of 8 | conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above copyright notice, this list of 10 | conditions and the following disclaimer in the documentation and/or other materials 11 | provided with the distribution. 12 | * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to 13 | endorse or promote products derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 17 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 18 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 20 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 21 | IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 22 | OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /core/Setup.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env runhaskell 2 | 3 | > import Distribution.Simple 4 | > main = defaultMain -------------------------------------------------------------------------------- /core/Test/Framework.hs: -------------------------------------------------------------------------------- 1 | -- | A generic test framework for all types of Haskell test. 2 | -- 3 | -- For an example of how to use test-framework, please see 4 | -- 5 | module Test.Framework ( 6 | module Test.Framework.Core, 7 | module Test.Framework.Options, 8 | module Test.Framework.Runners.Console, 9 | module Test.Framework.Runners.Options, 10 | module Test.Framework.Seed 11 | ) where 12 | 13 | import Test.Framework.Core (Test, TestName, testGroup, plusTestOptions, buildTest, buildTestBracketed, mutuallyExclusive) 14 | import Test.Framework.Options 15 | import Test.Framework.Runners.Console 16 | import Test.Framework.Runners.Options 17 | import Test.Framework.Seed -------------------------------------------------------------------------------- /core/Test/Framework/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, DeriveDataTypeable #-} 2 | module Test.Framework.Core where 3 | 4 | import Test.Framework.Improving 5 | import Test.Framework.Options 6 | 7 | import Control.Arrow (first, second) 8 | import Control.Concurrent.MVar 9 | import Data.Typeable 10 | 11 | 12 | -- | Something like the result of a test: works in concert with 'Testlike'. 13 | -- The type parameters are the type that is used for progress reports and the 14 | -- type of the final output of the test respectively. 15 | class (Show i, Show r) => TestResultlike i r | r -> i where 16 | testSucceeded :: r -> Bool 17 | 18 | -- | Something test-like in its behaviour. The type parameters are the type that 19 | -- is used for progress reports, the type of the final output of the test and the 20 | -- data type encapsulating the whole potential to do a test respectively. 21 | class TestResultlike i r => Testlike i r t | t -> i r, r -> i where 22 | runTest :: CompleteTestOptions -> t -> IO (i :~> r, IO ()) 23 | testTypeName :: t -> TestTypeName 24 | 25 | 26 | -- | Test names or descriptions. These are shown to the user 27 | type TestName = String 28 | 29 | -- | The name of a type of test, such as "Properties" or "Test Cases". Tests of 30 | -- types of the same names will be grouped together in the test run summary. 31 | type TestTypeName = String 32 | 33 | -- | Main test data type: builds up a list of tests to be run. Users should use the 34 | -- utility functions in e.g. the test-framework-hunit and test-framework-quickcheck 35 | -- packages to create instances of 'Test', and then build them up into testsuites 36 | -- by using 'testGroup' and lists. 37 | -- 38 | -- For an example of how to use test-framework, please see 39 | -- 40 | data Test = forall i r t. 41 | (Testlike i r t, Typeable t) => Test TestName t -- ^ A single test of some particular type 42 | | TestGroup TestName [Test] -- ^ Assemble a number of tests into a cohesive group 43 | | PlusTestOptions TestOptions Test -- ^ Add some options to child tests 44 | | BuildTestBracketed (IO (Test, IO ())) -- ^ Convenience for creating tests from an 'IO' action, with cleanup 45 | 46 | -- | Assemble a number of tests into a cohesive group 47 | testGroup :: TestName -> [Test] -> Test 48 | testGroup = TestGroup 49 | 50 | -- | Add some options to child tests 51 | plusTestOptions :: TestOptions -> Test -> Test 52 | plusTestOptions = PlusTestOptions 53 | 54 | -- | Convenience for creating tests from an 'IO' action 55 | buildTest :: IO Test -> Test 56 | buildTest mx = BuildTestBracketed (fmap (flip (,) (return ())) mx) 57 | 58 | -- | Convenience for creating tests from an 'IO' action, with a cleanup handler for when tests are finished 59 | buildTestBracketed :: IO (Test, IO ()) -> Test 60 | buildTestBracketed = BuildTestBracketed 61 | 62 | 63 | data MutuallyExcluded t = ME (MVar ()) t 64 | deriving Typeable 65 | 66 | -- This requires UndecidableInstances, but I think it can't be made inconsistent? 67 | instance Testlike i r t => Testlike i r (MutuallyExcluded t) where 68 | runTest cto (ME mvar x) = fmap (second (\act -> withMVar mvar $ \() -> act)) $ runTest cto x 69 | testTypeName ~(ME _ x) = testTypeName x 70 | 71 | -- | Mark all tests in this portion of the tree as mutually exclusive, so only one runs at a time 72 | {-# NOINLINE mutuallyExclusive #-} 73 | mutuallyExclusive :: Test -> Test 74 | mutuallyExclusive init_t = buildTest $ do 75 | mvar <- newMVar () 76 | let go (Test tn t) = Test tn (ME mvar t) 77 | go (TestGroup tn ts) = TestGroup tn (map go ts) 78 | go (PlusTestOptions to t) = PlusTestOptions to (go t) 79 | go (BuildTestBracketed build) = BuildTestBracketed (fmap (first go) build) 80 | return (go init_t) 81 | -------------------------------------------------------------------------------- /core/Test/Framework/Improving.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Improving ( 2 | (:~>)(..), bimapImproving, improvingLast, consumeImproving, 3 | ImprovingIO, yieldImprovement, runImprovingIO, tunnelImprovingIO, liftIO, 4 | timeoutImprovingIO, maybeTimeoutImprovingIO 5 | ) where 6 | 7 | import Control.Concurrent 8 | import Control.Monad 9 | 10 | import System.Timeout 11 | 12 | 13 | data i :~> f = Finished f 14 | | Improving i (i :~> f) 15 | 16 | instance Functor ((:~>) i) where 17 | fmap f (Finished x) = Finished (f x) 18 | fmap f (Improving x i) = Improving x (fmap f i) 19 | 20 | bimapImproving :: (a -> c) -> (b -> d) -> (a :~> b) -> (c :~> d) 21 | bimapImproving _ g (Finished b) = Finished (g b) 22 | bimapImproving f g (Improving a improving) = Improving (f a) (bimapImproving f g improving) 23 | 24 | improvingLast :: (a :~> b) -> b 25 | improvingLast (Finished r) = r 26 | improvingLast (Improving _ rest) = improvingLast rest 27 | 28 | consumeImproving :: (a :~> b) -> [(a :~> b)] 29 | consumeImproving improving@(Finished _) = [improving] 30 | consumeImproving improving@(Improving _ rest) = improving : consumeImproving rest 31 | 32 | 33 | newtype ImprovingIO i f a = IIO { unIIO :: Chan (Either i f) -> IO a } 34 | 35 | instance Functor (ImprovingIO i f) where 36 | fmap = liftM 37 | 38 | instance Monad (ImprovingIO i f) where 39 | return x = IIO (const $ return x) 40 | ma >>= f = IIO $ \chan -> do 41 | a <- unIIO ma chan 42 | unIIO (f a) chan 43 | 44 | yieldImprovement :: i -> ImprovingIO i f () 45 | yieldImprovement improvement = IIO $ \chan -> do 46 | -- Whenever we yield an improvement, take the opportunity to yield the thread as well. 47 | -- The idea here is to introduce frequent yields in users so that if e.g. they get killed 48 | -- by the timeout code then they know about it reasonably promptly. 49 | yield 50 | writeChan chan (Left improvement) 51 | 52 | -- NB: could have a more general type but it would be impredicative 53 | tunnelImprovingIO :: ImprovingIO i f (ImprovingIO i f a -> IO a) 54 | tunnelImprovingIO = IIO $ \chan -> return $ \iio -> unIIO iio chan 55 | 56 | runImprovingIO :: ImprovingIO i f f -> IO (i :~> f, IO ()) 57 | runImprovingIO iio = do 58 | chan <- newChan 59 | let action = do 60 | result <- unIIO iio chan 61 | writeChan chan (Right result) 62 | improving_value <- getChanContents chan 63 | return (reifyListToImproving improving_value, action) 64 | 65 | reifyListToImproving :: [Either i f] -> (i :~> f) 66 | reifyListToImproving (Left improvement:rest) = Improving improvement (reifyListToImproving rest) 67 | reifyListToImproving (Right final:_) = Finished final 68 | reifyListToImproving [] = error "reifyListToImproving: list finished before a final value arrived" 69 | 70 | liftIO :: IO a -> ImprovingIO i f a 71 | liftIO io = IIO $ const io 72 | 73 | -- | Given a number of microseconds and an improving IO action, run that improving IO action only 74 | -- for at most the given period before giving up. See also 'System.Timeout.timeout'. 75 | timeoutImprovingIO :: Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a) 76 | timeoutImprovingIO microseconds iio = IIO $ \chan -> timeout microseconds $ unIIO iio chan 77 | 78 | -- | As 'timeoutImprovingIO', but don't bother applying a timeout to the action if @Nothing@ is given 79 | -- as the number of microseconds to apply the time out for. 80 | maybeTimeoutImprovingIO :: Maybe Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a) 81 | maybeTimeoutImprovingIO Nothing = fmap Just 82 | maybeTimeoutImprovingIO (Just microseconds) = timeoutImprovingIO microseconds -------------------------------------------------------------------------------- /core/Test/Framework/Options.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Options where 2 | 3 | import Test.Framework.Seed 4 | import Test.Framework.Utilities 5 | 6 | import Data.Monoid 7 | 8 | 9 | type TestOptions = TestOptions' Maybe 10 | type CompleteTestOptions = TestOptions' K 11 | data TestOptions' f = TestOptions { 12 | topt_seed :: f Seed, 13 | -- ^ Seed that should be used to create random numbers for generated tests 14 | topt_maximum_generated_tests :: f Int, 15 | -- ^ Maximum number of tests to generate when using something like QuickCheck 16 | topt_maximum_unsuitable_generated_tests :: f Int, 17 | -- ^ Maximum number of unsuitable tests to consider before giving up when using something like QuickCheck 18 | topt_maximum_test_size :: f Int, 19 | -- ^ Maximum size of generated tests when using something like QuickCheck 20 | topt_maximum_test_depth :: f Int, 21 | -- ^ Maximum depth of generated tests when using something like SmallCheck 22 | topt_timeout :: f (Maybe Int) 23 | -- ^ The number of microseconds to run tests for before considering them a failure 24 | } 25 | 26 | instance Monoid (TestOptions' Maybe) where 27 | mempty = TestOptions { 28 | topt_seed = Nothing, 29 | topt_maximum_generated_tests = Nothing, 30 | topt_maximum_unsuitable_generated_tests = Nothing, 31 | topt_maximum_test_size = Nothing, 32 | topt_maximum_test_depth = Nothing, 33 | topt_timeout = Nothing 34 | } 35 | 36 | mappend to1 to2 = TestOptions { 37 | topt_seed = getLast (mappendBy (Last . topt_seed) to1 to2), 38 | topt_maximum_generated_tests = getLast (mappendBy (Last . topt_maximum_generated_tests) to1 to2), 39 | topt_maximum_unsuitable_generated_tests = getLast (mappendBy (Last . topt_maximum_unsuitable_generated_tests) to1 to2), 40 | topt_maximum_test_size = getLast (mappendBy (Last . topt_maximum_test_size) to1 to2), 41 | topt_maximum_test_depth = getLast (mappendBy (Last . topt_maximum_test_depth) to1 to2), 42 | topt_timeout = getLast (mappendBy (Last . topt_timeout) to1 to2) 43 | } 44 | -------------------------------------------------------------------------------- /core/Test/Framework/Providers/API.hs: -------------------------------------------------------------------------------- 1 | -- | This module exports everything that you need to be able to create your own framework test provider. 2 | -- To create a provider you need to: 3 | -- 4 | -- * Create an instance of the 'Testlike' class 5 | -- 6 | -- * Create an instance of the 'TestResultlike' class 7 | -- 8 | -- * Expose a function that lets people construct 'Test' values using your new instances 9 | module Test.Framework.Providers.API ( 10 | module Test.Framework.Core, 11 | module Test.Framework.Improving, 12 | module Test.Framework.Options, 13 | module Test.Framework.Seed, 14 | module Test.Framework.Utilities 15 | ) where 16 | 17 | import Test.Framework.Core 18 | import Test.Framework.Improving 19 | import Test.Framework.Options 20 | import Test.Framework.Seed 21 | import Test.Framework.Utilities -------------------------------------------------------------------------------- /core/Test/Framework/Runners/API.hs: -------------------------------------------------------------------------------- 1 | -- | This module exports everything that you need to be able to create your own test runner. 2 | module Test.Framework.Runners.API ( 3 | module Test.Framework.Runners.Options, 4 | TestRunner(..), runTestTree 5 | ) where 6 | 7 | import Test.Framework.Runners.Options 8 | import Test.Framework.Runners.Core 9 | -------------------------------------------------------------------------------- /core/Test/Framework/Runners/Console.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Runners.Console ( 2 | defaultMain, defaultMainWithArgs, defaultMainWithOpts, 3 | SuppliedRunnerOptions, optionsDescription, 4 | interpretArgs, interpretArgsOrExit 5 | ) where 6 | 7 | import Test.Framework.Core 8 | import Test.Framework.Options 9 | import Test.Framework.Runners.Console.Run 10 | import Test.Framework.Runners.Core 11 | import Test.Framework.Runners.Options 12 | import Test.Framework.Runners.Processors 13 | import Test.Framework.Runners.Statistics 14 | import qualified Test.Framework.Runners.XML as XML 15 | import Test.Framework.Seed 16 | import Test.Framework.Utilities 17 | 18 | import Control.Monad (when) 19 | import System.Console.GetOpt 20 | import System.Environment 21 | import System.Exit 22 | import System.IO 23 | 24 | import Data.Monoid 25 | 26 | #if !MIN_VERSION_base(4,7,0) 27 | instance Functor OptDescr where 28 | fmap f (Option a b arg_descr c) = Option a b (fmap f arg_descr) c 29 | 30 | instance Functor ArgDescr where 31 | fmap f (NoArg a) = NoArg (f a) 32 | fmap f (ReqArg g s) = ReqArg (f . g) s 33 | fmap f (OptArg g s) = OptArg (f . g) s 34 | #endif 35 | 36 | -- | @Nothing@ signifies that usage information should be displayed. 37 | -- @Just@ simply gives us the contribution to overall options by the command line option. 38 | type SuppliedRunnerOptions = Maybe RunnerOptions 39 | 40 | -- | Options understood by test-framework. This can be used to add more 41 | -- options to the tester executable. 42 | optionsDescription :: [OptDescr SuppliedRunnerOptions] 43 | optionsDescription = [ 44 | Option [] ["help"] 45 | (NoArg Nothing) 46 | "show this help message" 47 | ] ++ map (fmap Just) [ 48 | Option ['j'] ["threads"] 49 | (ReqArg (\t -> mempty { ropt_threads = Just (read t) }) "NUMBER") 50 | "number of threads to use to run tests", 51 | Option [] ["test-seed"] 52 | (ReqArg (\t -> mempty { ropt_test_options = Just (mempty { topt_seed = Just (read t) }) }) ("NUMBER|" ++ show RandomSeed)) 53 | "default seed for test random number generator", 54 | Option ['a'] ["maximum-generated-tests"] 55 | (ReqArg (\t -> mempty { ropt_test_options = Just (mempty { topt_maximum_generated_tests = Just (read t) }) }) "NUMBER") 56 | "how many automated tests something like QuickCheck should try, by default", 57 | Option [] ["maximum-unsuitable-generated-tests"] 58 | (ReqArg (\t -> mempty { ropt_test_options = Just (mempty { topt_maximum_unsuitable_generated_tests = Just (read t) }) }) "NUMBER") 59 | "how many unsuitable candidate tests something like QuickCheck should endure before giving up, by default", 60 | Option ['s'] ["maximum-test-size"] 61 | (ReqArg (\t -> mempty {ropt_test_options = Just (mempty { topt_maximum_test_size = Just (read t) }) }) "NUMBER") 62 | "to what size something like QuickCheck should test the properties, by default", 63 | Option ['d'] ["maximum-test-depth"] 64 | (ReqArg (\t -> mempty { ropt_test_options = Just (mempty { topt_maximum_test_depth = Just (read t) }) }) "NUMBER") 65 | "to what depth something like SmallCheck should test the properties, by default", 66 | Option ['o'] ["timeout"] 67 | (ReqArg (\t -> mempty { ropt_test_options = Just (mempty { topt_timeout = Just (Just (secondsToMicroseconds (read t))) }) }) "NUMBER") 68 | "how many seconds a test should be run for before giving up, by default", 69 | Option [] ["no-timeout"] 70 | (NoArg (mempty { ropt_test_options = Just (mempty { topt_timeout = Just Nothing }) })) 71 | "specifies that tests should be run without a timeout, by default", 72 | Option ['l'] ["list-tests"] 73 | (NoArg (mempty { ropt_list_only = Just True })) 74 | "list available tests but don't run any; useful to guide subsequent --select-tests", 75 | Option ['t'] ["select-tests"] 76 | (ReqArg (\t -> mempty { ropt_test_patterns = Just [read t] }) "TEST-PATTERN") 77 | "only tests that match at least one glob pattern given by an instance of this argument will be run", 78 | Option [] ["jxml"] 79 | (ReqArg (\t -> mempty { ropt_xml_output = Just (Just t) }) "FILE") 80 | "write a JUnit XML summary of the output to FILE", 81 | Option [] ["jxml-nested"] 82 | (NoArg (mempty { ropt_xml_nested = Just True })) 83 | "use nested testsuites to represent groups in JUnit XML (not standards compliant)", 84 | Option [] ["plain"] 85 | (NoArg (mempty { ropt_color_mode = Just ColorNever })) 86 | "do not use any ANSI terminal features to display the test run", 87 | Option [] ["color"] 88 | (NoArg (mempty { ropt_color_mode = Just ColorAlways })) 89 | "use ANSI terminal features to display the test run", 90 | Option [] ["hide-successes"] 91 | (NoArg (mempty { ropt_hide_successes = Just True })) 92 | "hide sucessful tests, and only show failures" 93 | ] 94 | 95 | -- | Parse the specified command line arguments into a 'RunnerOptions' and some remaining arguments, 96 | -- or return a reason as to why we can't. 97 | interpretArgs :: [String] -> IO (Either String (RunnerOptions, [String])) 98 | interpretArgs args = do 99 | prog_name <- getProgName 100 | let usage_header = "Usage: " ++ prog_name ++ " [OPTIONS]" 101 | 102 | case getOpt Permute optionsDescription args of 103 | (oas, n, []) | Just os <- sequence oas -> return $ Right (mconcat os, n) 104 | (_, _, errs) -> return $ Left (concat errs ++ usageInfo usage_header optionsDescription) 105 | 106 | -- | A version of 'interpretArgs' that ends the process if it fails. 107 | interpretArgsOrExit :: [String] -> IO RunnerOptions 108 | interpretArgsOrExit args = do 109 | interpreted_args <- interpretArgs args 110 | case interpreted_args of 111 | Right (ropts, []) -> return ropts 112 | Right (_, leftovers) -> do 113 | hPutStrLn stderr $ "Could not understand these extra arguments: " ++ unwords leftovers 114 | exitWith (ExitFailure 1) 115 | Left error_message -> do 116 | hPutStrLn stderr error_message 117 | exitWith (ExitFailure 1) 118 | 119 | 120 | defaultMain :: [Test] -> IO () 121 | defaultMain tests = do 122 | args <- getArgs 123 | defaultMainWithArgs tests args 124 | 125 | -- | A version of 'defaultMain' that lets you ignore the command line arguments 126 | -- in favour of another list of 'String's. 127 | defaultMainWithArgs :: [Test] -> [String] -> IO () 128 | defaultMainWithArgs tests args = do 129 | ropts <- interpretArgsOrExit args 130 | defaultMainWithOpts tests ropts 131 | 132 | -- | A version of 'defaultMain' that lets you ignore the command line arguments 133 | -- in favour of an explicit set of 'RunnerOptions'. 134 | defaultMainWithOpts :: [Test] -> RunnerOptions -> IO () 135 | defaultMainWithOpts tests ropts = do 136 | let ropts' = completeRunnerOptions ropts 137 | 138 | when (unK$ ropt_list_only ropts') $ do 139 | putStr $ listTests tests 140 | exitSuccess 141 | 142 | -- Get a lazy list of the test results, as executed in parallel 143 | running_tests <- runTests ropts' tests 144 | 145 | isplain <- case unK $ ropt_color_mode ropts' of 146 | ColorAuto -> not `fmap` hIsTerminalDevice stdout 147 | ColorNever -> return True 148 | ColorAlways -> return False 149 | 150 | -- Show those test results to the user as we get them 151 | fin_tests <- showRunTestsTop isplain (unK $ ropt_hide_successes ropts') running_tests 152 | let test_statistics' = gatherStatistics fin_tests 153 | 154 | -- Output XML report (if requested) 155 | case ropt_xml_output ropts' of 156 | K (Just file) -> XML.produceReport (unK (ropt_xml_nested ropts')) test_statistics' fin_tests >>= writeFile file 157 | _ -> return () 158 | 159 | -- Set the error code depending on whether the tests succeded or not 160 | exitWith $ if ts_no_failures test_statistics' 161 | then ExitSuccess 162 | else ExitFailure 1 163 | 164 | -- | Print out a list of available tests. 165 | listTests :: [Test] -> String 166 | listTests tests = "\ntest-framework: All available tests:\n"++ 167 | "====================================\n"++ 168 | concat (map (++"\n") (concatMap (showTest "") tests)) 169 | where 170 | showTest :: String -> Test -> [String] 171 | showTest path (Test name _testlike) = [" "++path ++ name] 172 | showTest path (TestGroup name tests) = concatMap (showTest (path++":"++name)) tests 173 | showTest path (PlusTestOptions _ test) = showTest path test 174 | showTest path (BuildTestBracketed _) = [" "++path ++ ""] 175 | 176 | 177 | completeRunnerOptions :: RunnerOptions -> CompleteRunnerOptions 178 | completeRunnerOptions ro = RunnerOptions { 179 | ropt_threads = K $ ropt_threads ro `orElse` processorCount, 180 | ropt_test_options = K $ ropt_test_options ro `orElse` mempty, 181 | ropt_test_patterns = K $ ropt_test_patterns ro `orElse` mempty, 182 | ropt_xml_output = K $ ropt_xml_output ro `orElse` Nothing, 183 | ropt_xml_nested = K $ ropt_xml_nested ro `orElse` False, 184 | ropt_color_mode = K $ ropt_color_mode ro `orElse` ColorAuto, 185 | ropt_hide_successes = K $ ropt_hide_successes ro `orElse` False, 186 | ropt_list_only = K $ ropt_list_only ro `orElse` False 187 | } 188 | -------------------------------------------------------------------------------- /core/Test/Framework/Runners/Console/Colors.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Runners.Console.Colors where 2 | 3 | import Text.PrettyPrint.ANSI.Leijen 4 | 5 | 6 | colorFail, colorPass :: Doc -> Doc 7 | colorFail = red 8 | colorPass = green 9 | 10 | colorPassOrFail :: Bool -> Doc -> Doc 11 | colorPassOrFail True = colorPass 12 | colorPassOrFail False = colorFail -------------------------------------------------------------------------------- /core/Test/Framework/Runners/Console/ProgressBar.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Runners.Console.ProgressBar ( 2 | Progress(..), progressBar 3 | ) where 4 | 5 | import Text.PrettyPrint.ANSI.Leijen hiding (width) 6 | 7 | 8 | data Progress = Progress Int Int 9 | 10 | progressBar :: (Doc -> Doc) -> Int -> Progress -> Doc 11 | progressBar color width (Progress count total) = char '[' <> progress_doc <> space_doc <> char ']' 12 | where 13 | -- The available width takes account of the enclosing brackets 14 | available_width = width - 2 15 | characters_per_tick = fromIntegral available_width / fromIntegral total :: Double 16 | progress_chars = round (characters_per_tick * fromIntegral count) 17 | space_chars = available_width - progress_chars 18 | progress_doc = color (text (reverse (take progress_chars ('>' : repeat '=')))) 19 | space_doc = text (replicate space_chars ' ') -------------------------------------------------------------------------------- /core/Test/Framework/Runners/Console/Run.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Runners.Console.Run ( 2 | showRunTestsTop 3 | ) where 4 | 5 | import Test.Framework.Core 6 | import Test.Framework.Improving 7 | import Test.Framework.Runners.Console.Colors 8 | import Test.Framework.Runners.Console.ProgressBar 9 | import Test.Framework.Runners.Console.Statistics 10 | import Test.Framework.Runners.Console.Utilities 11 | import Test.Framework.Runners.Core 12 | import Test.Framework.Runners.Statistics 13 | import Test.Framework.Runners.TimedConsumption 14 | import Test.Framework.Utilities 15 | 16 | import System.Console.ANSI 17 | import System.IO 18 | 19 | import Text.PrettyPrint.ANSI.Leijen 20 | 21 | import Data.Monoid (mempty) 22 | 23 | import Control.Arrow (second, (&&&)) 24 | import Control.Monad (unless) 25 | 26 | 27 | showRunTestsTop :: Bool -> Bool -> [RunningTest] -> IO [FinishedTest] 28 | showRunTestsTop isplain hide_successes running_tests = (if isplain then id else hideCursorDuring) $ do 29 | -- Show those test results to the user as we get them. Gather statistics on the fly for a progress bar 30 | let test_statistics = initialTestStatistics (totalRunTestsList running_tests) 31 | (test_statistics', finished_tests) <- showRunTests isplain hide_successes 0 test_statistics running_tests 32 | 33 | -- Show the final statistics 34 | putStrLn "" 35 | putDoc $ possiblyPlain isplain $ showFinalTestStatistics test_statistics' 36 | 37 | return finished_tests 38 | 39 | 40 | -- This code all /really/ sucks. There must be a better way to seperate out the console-updating 41 | -- and the improvement-traversing concerns - but how? 42 | showRunTest :: Bool -> Bool -> Int -> TestStatistics -> RunningTest -> IO (TestStatistics, FinishedTest) 43 | showRunTest isplain hide_successes indent_level test_statistics (RunTest name test_type (SomeImproving improving_result)) = do 44 | let progress_bar = testStatisticsProgressBar test_statistics 45 | (property_text, property_suceeded) <- showImprovingTestResult isplain hide_successes indent_level name progress_bar improving_result 46 | return (updateTestStatistics (\count -> adjustTestCount test_type count mempty) property_suceeded test_statistics, RunTest name test_type (property_text, property_suceeded)) 47 | showRunTest isplain hide_successes indent_level test_statistics (RunTestGroup name tests) = do 48 | putDoc $ (indent indent_level (text name <> char ':')) <> linebreak 49 | fmap (second $ RunTestGroup name) $ showRunTests isplain hide_successes (indent_level + 2) test_statistics tests 50 | 51 | showRunTests :: Bool -> Bool -> Int -> TestStatistics -> [RunningTest] -> IO (TestStatistics, [FinishedTest]) 52 | showRunTests isplain hide_successes indent_level = mapAccumLM (showRunTest isplain hide_successes indent_level) 53 | 54 | 55 | testStatisticsProgressBar :: TestStatistics -> Doc 56 | testStatisticsProgressBar test_statistics = progressBar (colorPassOrFail no_failures) terminal_width (Progress run_tests total_tests) 57 | where 58 | run_tests = testCountTotal (ts_run_tests test_statistics) 59 | total_tests = testCountTotal (ts_total_tests test_statistics) 60 | no_failures = ts_no_failures test_statistics 61 | -- We assume a terminal width of 80, but we can't make the progress bar 80 characters wide. Why? Because if we 62 | -- do so, when we write the progress bar out Windows will move the cursor onto the next line! By using a slightly 63 | -- smaller width we prevent this from happening. Bit of a hack, but it does the job. 64 | terminal_width = 79 65 | 66 | 67 | showImprovingTestResult :: TestResultlike i r => Bool -> Bool -> Int -> String -> Doc -> (i :~> r) -> IO (String, Bool) 68 | showImprovingTestResult isplain hide_successes indent_level test_name progress_bar improving = do 69 | -- Consume the improving value until the end, displaying progress if we are not in "plain" mode 70 | (result, success) <- if isplain then return $ improvingLast improving' 71 | else showImprovingTestResultProgress (return ()) indent_level test_name progress_bar improving' 72 | unless (success && hide_successes) $ do 73 | let (result_doc, extra_doc) | success = (brackets $ colorPass (text result), empty) 74 | | otherwise = (brackets (colorFail (text "Failed")), text result <> linebreak) 75 | 76 | -- Output the final test status and a trailing newline 77 | putTestHeader indent_level test_name (possiblyPlain isplain result_doc) 78 | -- Output any extra information that may be required, e.g. to show failure reason 79 | putDoc extra_doc 80 | 81 | return (result, success) 82 | where 83 | improving' = bimapImproving show (show &&& testSucceeded) improving 84 | 85 | showImprovingTestResultProgress :: IO () -> Int -> String -> Doc -> (String :~> (String, Bool)) -> IO (String, Bool) 86 | showImprovingTestResultProgress erase indent_level test_name progress_bar improving = do 87 | -- Update the screen every every 200ms 88 | improving_list <- consumeListInInterval 200000 (consumeImproving improving) 89 | case listToMaybeLast improving_list of 90 | Nothing -> do -- 200ms was somehow not long enough for a single result to arrive: try again! 91 | showImprovingTestResultProgress erase indent_level test_name progress_bar improving 92 | Just improving' -> do -- Display that new improving value to the user 93 | showImprovingTestResultProgress' erase indent_level test_name progress_bar improving' 94 | 95 | showImprovingTestResultProgress' :: IO () -> Int -> String -> Doc -> (String :~> (String, Bool)) -> IO (String, Bool) 96 | showImprovingTestResultProgress' erase _ _ _ (Finished result) = do 97 | erase 98 | -- There may still be a progress bar on the line below the final test result, so 99 | -- remove it as a precautionary measure in case this is the last test in a group 100 | -- and hence it will not be erased in the normal course of test display. 101 | putStrLn "" 102 | clearLine 103 | cursorUpLine 1 104 | return result 105 | showImprovingTestResultProgress' erase indent_level test_name progress_bar (Improving intermediate rest) = do 106 | erase 107 | putTestHeader indent_level test_name (brackets (text intermediate)) 108 | putDoc progress_bar 109 | hFlush stdout 110 | showImprovingTestResultProgress (cursorUpLine 1 >> clearLine) indent_level test_name progress_bar rest 111 | 112 | possiblyPlain :: Bool -> Doc -> Doc 113 | possiblyPlain True = plain 114 | possiblyPlain False = id 115 | 116 | putTestHeader :: Int -> String -> Doc -> IO () 117 | putTestHeader indent_level test_name result = putDoc $ (indent indent_level (text test_name <> char ':' <+> result)) <> linebreak 118 | -------------------------------------------------------------------------------- /core/Test/Framework/Runners/Console/Statistics.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Runners.Console.Statistics ( 2 | showFinalTestStatistics 3 | ) where 4 | 5 | import Test.Framework.Runners.Statistics 6 | import Test.Framework.Runners.Console.Colors 7 | import Test.Framework.Runners.Console.Table 8 | 9 | import Text.PrettyPrint.ANSI.Leijen 10 | 11 | import Data.List 12 | 13 | 14 | -- | Displays statistics as a string something like this: 15 | -- 16 | -- @ 17 | -- Properties Total 18 | -- Passed 9 9 19 | -- Failed 1 1 20 | -- Total 10 10 21 | -- @ 22 | showFinalTestStatistics :: TestStatistics -> Doc 23 | showFinalTestStatistics ts = renderTable $ [Column label_column] ++ (map Column test_type_columns) ++ [Column total_column] 24 | where 25 | test_types = sort $ testCountTestTypes (ts_total_tests ts) 26 | 27 | label_column = [TextCell empty, TextCell (text "Passed"), TextCell (text "Failed"), TextCell (text "Total")] 28 | total_column = [TextCell (text "Total"), testStatusTotal colorPass ts_passed_tests, testStatusTotal colorFail ts_failed_tests, testStatusTotal (colorPassOrFail (ts_no_failures ts)) ts_total_tests] 29 | test_type_columns = [ [TextCell (text test_type), testStat colorPass (countTests ts_passed_tests), testStat colorFail failures, testStat (colorPassOrFail (failures <= 0)) (countTests ts_total_tests)] 30 | | test_type <- test_types 31 | , let countTests = testCountForType test_type . ($ ts) 32 | failures = countTests ts_failed_tests ] 33 | 34 | testStatusTotal color status_accessor = TextCell (coloredNumber color (testCountTotal (status_accessor ts))) 35 | testStat color number = TextCell (coloredNumber color number) 36 | 37 | coloredNumber :: (Doc -> Doc) -> Int -> Doc 38 | coloredNumber color number 39 | | number == 0 = number_doc 40 | | otherwise = color number_doc 41 | where 42 | number_doc = text (show number) -------------------------------------------------------------------------------- /core/Test/Framework/Runners/Console/Table.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Runners.Console.Table ( 2 | Cell(..), Column(..), renderTable 3 | ) where 4 | 5 | import Test.Framework.Utilities 6 | 7 | import Text.PrettyPrint.ANSI.Leijen hiding (column) 8 | 9 | 10 | data Cell = TextCell Doc 11 | | SeperatorCell 12 | 13 | data Column = Column [Cell] 14 | | SeperatorColumn 15 | 16 | type ColumnWidth = Int 17 | 18 | renderTable :: [Column] -> Doc 19 | renderTable = renderColumnsWithWidth . map (\column -> (findColumnWidth column, column)) 20 | 21 | 22 | findColumnWidth :: Column -> Int 23 | findColumnWidth SeperatorColumn = 0 24 | findColumnWidth (Column cells) = maximum (map findCellWidth cells) 25 | 26 | findCellWidth :: Cell -> Int 27 | findCellWidth (TextCell doc) = maximum (0 : map length (lines (shows doc ""))) 28 | findCellWidth SeperatorCell = 0 29 | 30 | 31 | renderColumnsWithWidth :: [(ColumnWidth, Column)] -> Doc 32 | renderColumnsWithWidth columns 33 | | all (columnFinished . snd) columns 34 | = empty 35 | | otherwise 36 | = first_cells_str <> line <> 37 | renderColumnsWithWidth (map (onRight columnDropHead) columns) 38 | where 39 | first_cells_str = hcat $ zipWith (uncurry renderFirstColumnCell) columns (eitherSideSeperator (map snd columns)) 40 | 41 | 42 | eitherSideSeperator :: [Column] -> [Bool] 43 | eitherSideSeperator columns = zipWith (||) (False:column_is_seperator) (tail column_is_seperator ++ [False]) 44 | where 45 | column_is_seperator = map isSeperatorColumn columns 46 | 47 | isSeperatorColumn :: Column -> Bool 48 | isSeperatorColumn SeperatorColumn = False 49 | isSeperatorColumn (Column cells) = case cells of 50 | [] -> False 51 | (cell:_) -> isSeperatorCell cell 52 | 53 | isSeperatorCell :: Cell -> Bool 54 | isSeperatorCell SeperatorCell = True 55 | isSeperatorCell _ = False 56 | 57 | 58 | renderFirstColumnCell :: ColumnWidth -> Column -> Bool -> Doc 59 | renderFirstColumnCell column_width (Column cells) _ = case cells of 60 | [] -> text $ replicate (column_width + 2) ' ' 61 | (SeperatorCell:_) -> text $ replicate (column_width + 2) '-' 62 | (TextCell contents:_) -> char ' ' <> fill column_width contents <> char ' ' 63 | renderFirstColumnCell _ SeperatorColumn either_side_seperator 64 | = if either_side_seperator then char '+' else char '|' 65 | 66 | columnFinished :: Column -> Bool 67 | columnFinished (Column cells) = null cells 68 | columnFinished SeperatorColumn = True 69 | 70 | columnDropHead :: Column -> Column 71 | columnDropHead (Column cells) = Column (drop 1 cells) 72 | columnDropHead SeperatorColumn = SeperatorColumn -------------------------------------------------------------------------------- /core/Test/Framework/Runners/Console/Utilities.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Runners.Console.Utilities ( 2 | hideCursorDuring 3 | ) where 4 | 5 | import System.Console.ANSI 6 | import System.IO 7 | 8 | import Control.Exception (bracket) 9 | 10 | 11 | hideCursorDuring :: IO a -> IO a 12 | hideCursorDuring action = bracket hideCursor (const (showCursor >> hFlush stdout)) (const action) 13 | -------------------------------------------------------------------------------- /core/Test/Framework/Runners/Core.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Runners.Core ( 2 | RunTest(..), RunningTest, SomeImproving(..), FinishedTest, runTests, 3 | TestRunner(..), runTestTree 4 | ) where 5 | 6 | import Test.Framework.Core 7 | import Test.Framework.Improving 8 | import Test.Framework.Options 9 | import Test.Framework.Runners.Options 10 | import Test.Framework.Runners.TestPattern 11 | import Test.Framework.Runners.ThreadPool 12 | import Test.Framework.Seed 13 | import Test.Framework.Utilities 14 | 15 | import Control.Concurrent.MVar 16 | import Control.Exception (mask, finally, onException) 17 | import Control.Monad 18 | import Data.Maybe 19 | import Data.Monoid 20 | import Data.Typeable 21 | 22 | 23 | -- | A test that has been executed or is in the process of execution 24 | data RunTest a = RunTest TestName TestTypeName a 25 | | RunTestGroup TestName [RunTest a] 26 | deriving (Show) 27 | 28 | data SomeImproving = forall i r. TestResultlike i r => SomeImproving (i :~> r) 29 | type RunningTest = RunTest SomeImproving 30 | 31 | type FinishedTest = RunTest (String, Bool) 32 | 33 | runTests :: CompleteRunnerOptions -- ^ Top-level runner options 34 | -> [Test] -- ^ Tests to run 35 | -> IO [RunningTest] 36 | runTests ropts tests = do 37 | let test_patterns = unK $ ropt_test_patterns ropts 38 | test_options = unK $ ropt_test_options ropts 39 | (run_tests, actions) <- runTests' $ map (runTestTree test_options test_patterns) tests 40 | _ <- executeOnPool (unK $ ropt_threads ropts) actions 41 | return run_tests 42 | 43 | -- | 'TestRunner' class simplifies folding a 'Test'. You need to specify 44 | -- the important semantic actions by instantiating this class, and 45 | -- 'runTestTree' will take care of recursion and test filtering. 46 | class TestRunner b where 47 | -- | How to handle a single test 48 | runSimpleTest :: (Testlike i r t, Typeable t) => TestOptions -> TestName -> t -> b 49 | -- | How to skip a test that doesn't satisfy the pattern 50 | skipTest :: b 51 | -- | How to handle an IO test (created with 'buildTestBracketed') 52 | runIOTest :: IO (b, IO ()) -> b 53 | -- | How to run a test group 54 | runGroup :: TestName -> [b] -> b 55 | 56 | -- | Run the test tree using a 'TestRunner' 57 | runTestTree 58 | :: TestRunner b 59 | => TestOptions 60 | -> [TestPattern] 61 | -- ^ skip the tests that do not match any of these patterns, unless 62 | -- the list is empty 63 | -> Test 64 | -> b 65 | runTestTree initialOpts pats topTest = go initialOpts [] topTest 66 | where 67 | go opts path t = case t of 68 | Test name testlike -> 69 | if null pats || any (`testPatternMatches` (path ++ [name])) pats 70 | then runSimpleTest opts name testlike 71 | else skipTest 72 | TestGroup name tests -> 73 | let path' = path ++ [name] 74 | in runGroup name $ map (go opts path') tests 75 | PlusTestOptions extra_topts test -> go (opts `mappend` extra_topts) path test 76 | BuildTestBracketed build -> 77 | runIOTest $ onLeft (go opts path) `fmap` build 78 | 79 | newtype StdRunner = StdRunner { run :: IO (Maybe (RunningTest, [IO ()])) } 80 | 81 | instance TestRunner StdRunner where 82 | runSimpleTest topts name testlike = StdRunner $ do 83 | (result, action) <- runTest (completeTestOptions topts) testlike 84 | return (Just (RunTest name (testTypeName testlike) (SomeImproving result), [action])) 85 | 86 | skipTest = StdRunner $ return Nothing 87 | 88 | runGroup name tests = StdRunner $ do 89 | (results, actions) <- runTests' tests 90 | return $ if null results then Nothing else Just ((RunTestGroup name results), actions) 91 | 92 | runIOTest ioTest = StdRunner $ mask $ \restore -> ioTest >>= \(StdRunner test, cleanup) -> do 93 | mb_res <- restore test `onException` cleanup 94 | case mb_res of 95 | -- No sub-tests: perform the cleanup NOW 96 | Nothing -> cleanup >> return Nothing 97 | Just (run_test, actions) -> do 98 | -- Sub-tests: perform the cleanup as soon as each of them have completed 99 | (mvars, actions') <- liftM unzip $ forM actions $ \action -> do 100 | mvar <- newEmptyMVar 101 | return (mvar, action `finally` putMVar mvar ()) 102 | -- NB: the takeMVar action MUST be last in the list because the returned actions are 103 | -- scheduled left-to-right, and we want all the actions we depend on to be scheduled 104 | -- before we wait for them to complete, or we might deadlock. 105 | -- 106 | -- FIXME: this is a bit of a hack because it uses one pool thread just waiting 107 | -- for some other pool threads to complete! Switch to parallel-io? 108 | return $ Just (run_test, actions' ++ [(cleanup >> mapM_ takeMVar mvars)]) 109 | 110 | runTests' :: [StdRunner] -> IO ([RunningTest], [IO ()]) 111 | runTests' = fmap (onRight concat . unzip . catMaybes) . mapM run 112 | 113 | completeTestOptions :: TestOptions -> CompleteTestOptions 114 | completeTestOptions to = TestOptions { 115 | topt_seed = K $ topt_seed to `orElse` RandomSeed, 116 | topt_maximum_generated_tests = K $ topt_maximum_generated_tests to `orElse` 100, 117 | topt_maximum_unsuitable_generated_tests = K $ topt_maximum_unsuitable_generated_tests to `orElse` 1000, 118 | topt_maximum_test_size = K $ topt_maximum_test_size to `orElse` 100, 119 | topt_maximum_test_depth = K $ topt_maximum_test_depth to `orElse` 5, 120 | topt_timeout = K $ topt_timeout to `orElse` Nothing 121 | } 122 | -------------------------------------------------------------------------------- /core/Test/Framework/Runners/Options.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Runners.Options ( 2 | module Test.Framework.Runners.Options, 3 | TestPattern 4 | ) where 5 | 6 | import Test.Framework.Options 7 | import Test.Framework.Utilities 8 | import Test.Framework.Runners.TestPattern 9 | 10 | import Data.Monoid 11 | 12 | data ColorMode = ColorAuto | ColorNever | ColorAlways 13 | 14 | type RunnerOptions = RunnerOptions' Maybe 15 | type CompleteRunnerOptions = RunnerOptions' K 16 | data RunnerOptions' f = RunnerOptions { 17 | ropt_threads :: f Int, 18 | ropt_test_options :: f TestOptions, 19 | ropt_test_patterns :: f [TestPattern], 20 | ropt_xml_output :: f (Maybe FilePath), 21 | ropt_xml_nested :: f Bool, 22 | ropt_color_mode :: f ColorMode, 23 | ropt_hide_successes :: f Bool, 24 | ropt_list_only :: f Bool 25 | } 26 | 27 | instance Monoid (RunnerOptions' Maybe) where 28 | mempty = RunnerOptions { 29 | ropt_threads = Nothing, 30 | ropt_test_options = Nothing, 31 | ropt_test_patterns = Nothing, 32 | ropt_xml_output = Nothing, 33 | ropt_xml_nested = Nothing, 34 | ropt_color_mode = Nothing, 35 | ropt_hide_successes = Nothing, 36 | ropt_list_only = Nothing 37 | } 38 | 39 | mappend ro1 ro2 = RunnerOptions { 40 | ropt_threads = getLast (mappendBy (Last . ropt_threads) ro1 ro2), 41 | ropt_test_options = mappendBy ropt_test_options ro1 ro2, 42 | ropt_test_patterns = mappendBy ropt_test_patterns ro1 ro2, 43 | ropt_xml_output = mappendBy ropt_xml_output ro1 ro2, 44 | ropt_xml_nested = getLast (mappendBy (Last . ropt_xml_nested) ro1 ro2), 45 | ropt_color_mode = getLast (mappendBy (Last . ropt_color_mode) ro1 ro2), 46 | ropt_hide_successes = getLast (mappendBy (Last . ropt_hide_successes) ro1 ro2), 47 | ropt_list_only = getLast (mappendBy (Last . ropt_list_only) ro1 ro2) 48 | } 49 | -------------------------------------------------------------------------------- /core/Test/Framework/Runners/Processors.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Runners.Processors ( 2 | processorCount 3 | ) where 4 | 5 | #ifdef COMPILER_GHC 6 | 7 | import GHC.Conc ( numCapabilities ) 8 | 9 | processorCount :: Int 10 | processorCount = numCapabilities 11 | 12 | #else 13 | 14 | processorCount :: Int 15 | processorCount = 1 16 | 17 | #endif -------------------------------------------------------------------------------- /core/Test/Framework/Runners/Statistics.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Runners.Statistics ( 2 | TestCount, testCountTestTypes, testCountForType, adjustTestCount, testCountTotal, 3 | TestStatistics(..), ts_pending_tests, ts_no_failures, 4 | initialTestStatistics, updateTestStatistics, 5 | totalRunTestsList, gatherStatistics 6 | ) where 7 | 8 | import Test.Framework.Core (TestTypeName) 9 | import Test.Framework.Runners.Core 10 | 11 | import Data.Map (Map) 12 | import qualified Data.Map as Map 13 | import Data.Monoid 14 | 15 | 16 | -- | Records a count of the various kinds of test that have been run 17 | newtype TestCount = TestCount { unTestCount :: Map TestTypeName Int } 18 | 19 | testCountTestTypes :: TestCount -> [TestTypeName] 20 | testCountTestTypes = Map.keys . unTestCount 21 | 22 | testCountForType :: String -> TestCount -> Int 23 | testCountForType test_type = Map.findWithDefault 0 test_type . unTestCount 24 | 25 | adjustTestCount :: String -> Int -> TestCount -> TestCount 26 | adjustTestCount test_type amount = TestCount . Map.insertWith (+) test_type amount . unTestCount 27 | 28 | 29 | -- | The number of tests of all kinds recorded in the given 'TestCount' 30 | testCountTotal :: TestCount -> Int 31 | testCountTotal = sum . Map.elems . unTestCount 32 | 33 | instance Monoid TestCount where 34 | mempty = TestCount $ Map.empty 35 | mappend (TestCount tcm1) (TestCount tcm2) = TestCount $ Map.unionWith (+) tcm1 tcm2 36 | 37 | minusTestCount :: TestCount -> TestCount -> TestCount 38 | minusTestCount (TestCount tcm1) (TestCount tcm2) = TestCount $ Map.unionWith (-) tcm1 tcm2 39 | 40 | 41 | -- | Records information about the run of a number of tests, such 42 | -- as how many tests have been run, how many are pending and how 43 | -- many have passed or failed. 44 | data TestStatistics = TestStatistics { 45 | ts_total_tests :: TestCount, 46 | ts_run_tests :: TestCount, 47 | ts_passed_tests :: TestCount, 48 | ts_failed_tests :: TestCount 49 | } 50 | 51 | instance Monoid TestStatistics where 52 | mempty = TestStatistics mempty mempty mempty mempty 53 | mappend (TestStatistics tot1 run1 pas1 fai1) (TestStatistics tot2 run2 pas2 fai2) = TestStatistics (tot1 `mappend` tot2) (run1 `mappend` run2) (pas1 `mappend` pas2) (fai1 `mappend` fai2) 54 | 55 | ts_pending_tests :: TestStatistics -> TestCount 56 | ts_pending_tests ts = ts_total_tests ts `minusTestCount` ts_run_tests ts 57 | 58 | ts_no_failures :: TestStatistics -> Bool 59 | ts_no_failures ts = testCountTotal (ts_failed_tests ts) <= 0 60 | 61 | -- | Create some test statistics that simply records the total number of 62 | -- tests to be run, ready to be updated by the actual test runs. 63 | initialTestStatistics :: TestCount -> TestStatistics 64 | initialTestStatistics total_tests = TestStatistics { 65 | ts_total_tests = total_tests, 66 | ts_run_tests = mempty, 67 | ts_passed_tests = mempty, 68 | ts_failed_tests = mempty 69 | } 70 | 71 | updateTestStatistics :: (Int -> TestCount) -> Bool -> TestStatistics -> TestStatistics 72 | updateTestStatistics count_constructor test_suceeded test_statistics = test_statistics { 73 | ts_run_tests = ts_run_tests test_statistics `mappend` (count_constructor 1), 74 | ts_failed_tests = ts_failed_tests test_statistics `mappend` (count_constructor (if test_suceeded then 0 else 1)), 75 | ts_passed_tests = ts_passed_tests test_statistics `mappend` (count_constructor (if test_suceeded then 1 else 0)) 76 | } 77 | 78 | 79 | totalRunTests :: RunTest a -> TestCount 80 | totalRunTests (RunTest _ test_type _) = adjustTestCount test_type 1 mempty 81 | totalRunTests (RunTestGroup _ tests) = totalRunTestsList tests 82 | 83 | totalRunTestsList :: [RunTest a] -> TestCount 84 | totalRunTestsList = mconcat . map totalRunTests 85 | 86 | gatherStatistics :: [FinishedTest] -> TestStatistics 87 | gatherStatistics = mconcat . map f 88 | where 89 | f (RunTest _ test_type (_, success)) = singleTestStatistics test_type success 90 | f (RunTestGroup _ tests) = gatherStatistics tests 91 | 92 | singleTestStatistics :: String -> Bool -> TestStatistics 93 | singleTestStatistics test_type success = TestStatistics { 94 | ts_total_tests = one, 95 | ts_run_tests = one, 96 | ts_passed_tests = if success then one else mempty, 97 | ts_failed_tests = if success then mempty else one 98 | } 99 | where one = adjustTestCount test_type 1 mempty 100 | -------------------------------------------------------------------------------- /core/Test/Framework/Runners/TestPattern.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Runners.TestPattern ( 2 | TestPattern, parseTestPattern, testPatternMatches 3 | ) where 4 | 5 | import Test.Framework.Utilities 6 | 7 | import Text.Regex.Posix.Wrap 8 | import Text.Regex.Posix.String() 9 | 10 | import Data.List 11 | 12 | 13 | data Token = SlashToken 14 | | WildcardToken 15 | | DoubleWildcardToken 16 | | LiteralToken Char 17 | deriving (Eq) 18 | 19 | tokenize :: String -> [Token] 20 | tokenize ('/':rest) = SlashToken : tokenize rest 21 | tokenize ('*':'*':rest) = DoubleWildcardToken : tokenize rest 22 | tokenize ('*':rest) = WildcardToken : tokenize rest 23 | tokenize (c:rest) = LiteralToken c : tokenize rest 24 | tokenize [] = [] 25 | 26 | 27 | data TestPatternMatchMode = TestMatchMode 28 | | PathMatchMode 29 | 30 | data TestPattern = TestPattern { 31 | tp_categories_only :: Bool, 32 | tp_negated :: Bool, 33 | tp_match_mode :: TestPatternMatchMode, 34 | tp_tokens :: [Token] 35 | } 36 | 37 | instance Read TestPattern where 38 | readsPrec _ string = [(parseTestPattern string, "")] 39 | 40 | parseTestPattern :: String -> TestPattern 41 | parseTestPattern string = TestPattern { 42 | tp_categories_only = categories_only, 43 | tp_negated = negated, 44 | tp_match_mode = match_mode, 45 | tp_tokens = tokens'' 46 | } 47 | where 48 | tokens = tokenize string 49 | (negated, tokens') 50 | | (LiteralToken '!'):rest <- tokens = (True, rest) 51 | | otherwise = (False, tokens) 52 | (categories_only, tokens'') 53 | | (prefix, [SlashToken]) <- splitAt (length tokens' - 1) tokens' = (True, prefix) 54 | | otherwise = (False, tokens') 55 | match_mode 56 | | SlashToken `elem` tokens = PathMatchMode 57 | | otherwise = TestMatchMode 58 | 59 | 60 | testPatternMatches :: TestPattern -> [String] -> Bool 61 | testPatternMatches test_pattern path = not_maybe $ any (=~ tokens_regex) things_to_match 62 | where 63 | not_maybe | tp_negated test_pattern = not 64 | | otherwise = id 65 | path_to_consider | tp_categories_only test_pattern = dropLast 1 path 66 | | otherwise = path 67 | tokens_regex = buildTokenRegex (tp_tokens test_pattern) 68 | 69 | things_to_match = case tp_match_mode test_pattern of 70 | -- See if the tokens match any single path component 71 | TestMatchMode -> path_to_consider 72 | -- See if the tokens match any prefix of the path 73 | PathMatchMode -> map pathToString $ inits path_to_consider 74 | 75 | 76 | buildTokenRegex :: [Token] -> String 77 | buildTokenRegex [] = [] 78 | buildTokenRegex (token:tokens) = concat (firstTokenToRegex token : map tokenToRegex tokens) 79 | where 80 | firstTokenToRegex SlashToken = "^" 81 | firstTokenToRegex other = tokenToRegex other 82 | 83 | tokenToRegex SlashToken = "/" 84 | tokenToRegex WildcardToken = "[^/]*" 85 | tokenToRegex DoubleWildcardToken = "*" 86 | tokenToRegex (LiteralToken lit) = regexEscapeChar lit 87 | 88 | regexEscapeChar :: Char -> String 89 | regexEscapeChar c | c `elem` "\\*+?|{}[]()^$." = '\\' : [c] 90 | | otherwise = [c] 91 | 92 | pathToString :: [String] -> String 93 | pathToString path = "/" ++ concat (intersperse "/" path) -------------------------------------------------------------------------------- /core/Test/Framework/Runners/ThreadPool.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Runners.ThreadPool ( 2 | executeOnPool 3 | ) where 4 | 5 | import Control.Concurrent 6 | import Control.Monad 7 | 8 | import qualified Data.IntMap as IM 9 | 10 | import Foreign.StablePtr 11 | 12 | 13 | data WorkerEvent token a = WorkerTermination 14 | | WorkerItem token a 15 | 16 | -- | Execute IO actions on several threads and return their results in the original 17 | -- order. It is guaranteed that no action from the input list is executed unless all 18 | -- the items that precede it in the list have been executed or are executing at that 19 | -- moment. 20 | executeOnPool :: Int -- ^ Number of threads to use 21 | -> [IO a] -- ^ Actions to execute: these will be scheduled left to right 22 | -> IO [a] -- ^ Ordered results of executing the given IO actions in parallel 23 | executeOnPool n actions = do 24 | -- Prepare the channels 25 | input_chan <- newChan 26 | output_chan <- newChan 27 | 28 | -- Write the actions as items to the channel followed by one termination per thread 29 | -- that indicates they should terminate. We do this on another thread for 30 | -- maximum laziness (in case one the actions we are going to run depend on the 31 | -- output from previous actions..) 32 | _ <- forkIO $ writeList2Chan input_chan (zipWith WorkerItem [0..] actions ++ replicate n WorkerTermination) 33 | 34 | -- Spawn workers 35 | forM_ [1..n] (const $ forkIO $ poolWorker input_chan output_chan) 36 | 37 | -- Short version: make sure we do the right thing if a test blocks on dead 38 | -- MVars or TVars. 39 | -- Long version: GHC is clever enough to throw an exception (BlockedOnDeadMVar 40 | -- or BlockedIndefinitely) when a thread is waiting for a MVar or TVar that can't 41 | -- be written to. However, it doesn't know anything about the handlers for those 42 | -- exceptions. Therefore, when a worker runs a test that causes this exception, 43 | -- since the main thread is blocking on the worker, the main thread gets the 44 | -- exception too despite the fact that the main thread will be runnable as soon 45 | -- as the worker catches its own exception. The below makes sure the main thread 46 | -- is always reachable by the GC, which is the mechanism for finding threads 47 | -- that are unrunnable. 48 | -- See also the ticket where SimonM (semi-cryptically) explains this: 49 | -- http://hackage.haskell.org/trac/ghc/ticket/3291 50 | -- 51 | -- NB: this actually leaks stable pointers. We could prevent this by making 52 | -- takeWhileWorkersExist do |unsafePerformIO newStablePtr| when returning the 53 | -- lazily-demanded tail of the list, but its a bit of a pain. For now, just 54 | -- grit our teeth and accept the leak. 55 | _stablePtr <- myThreadId >>= newStablePtr 56 | 57 | -- Return the results generated by the worker threads lazily and in 58 | -- the same order as we got the inputs 59 | fmap (reorderFrom 0 . takeWhileWorkersExist n) $ getChanContents output_chan 60 | 61 | poolWorker :: Chan (WorkerEvent token (IO a)) -> Chan (WorkerEvent token a) -> IO () 62 | poolWorker input_chan output_chan = do 63 | -- Read an action and work out whether we should continue or stop 64 | action_item <- readChan input_chan 65 | case action_item of 66 | WorkerTermination -> writeChan output_chan WorkerTermination -- Must have run out of real actions to execute 67 | WorkerItem token action -> do 68 | -- Do the action then loop 69 | result <- action 70 | writeChan output_chan (WorkerItem token result) 71 | poolWorker input_chan output_chan 72 | 73 | -- | Keep grabbing items out of the infinite list of worker outputs until we have 74 | -- recieved word that all of the workers have shut down. This lets us turn a possibly 75 | -- infinite list of outputs into a certainly finite one suitable for use with reorderFrom. 76 | takeWhileWorkersExist :: Int -> [WorkerEvent token a] -> [(token, a)] 77 | takeWhileWorkersExist worker_count events 78 | | worker_count <= 0 = [] 79 | | otherwise = case events of 80 | (WorkerTermination:events') -> takeWhileWorkersExist (worker_count - 1) events' 81 | (WorkerItem token x:events') -> (token, x) : takeWhileWorkersExist worker_count events' 82 | [] -> [] 83 | 84 | -- | This function carefully shuffles the input list so it in the total order 85 | -- defined by the integers paired with the elements. If the list is @xs@ and 86 | -- the supplied initial integer is @n@, it must be the case that: 87 | -- 88 | -- > sort (map fst xs) == [n..n + (length xs - 1)] 89 | -- 90 | -- This function returns items in the lazy result list as soon as it is sure 91 | -- it has the right item for that position. 92 | reorderFrom :: Int -> [(Int, a)] -> [a] 93 | reorderFrom from initial_things = go from initial_things IM.empty False 94 | where go next [] buf _ 95 | | IM.null buf = [] -- If the buffer and input list is empty, we're done 96 | | otherwise = go next (IM.toList buf) IM.empty False -- Make sure we check the buffer even if the list is done 97 | go next all_things@((token, x):things) buf buf_useful 98 | | token == next -- If the list token matches the one we were expecting we can just take the item 99 | = x : go (next + 1) things buf True -- Always worth checking the buffer now because the expected item has changed 100 | | buf_useful -- If it's worth checking the buffer, it's possible the token we need is in it 101 | , (Just x', buf') <- IM.updateLookupWithKey (const $ const Nothing) next buf -- Delete the found item from the map (if we find it) to save space 102 | = x' : go (next + 1) all_things buf' True -- Always worth checking the buffer now because the expected item has changed 103 | | otherwise -- Token didn't match, buffer unhelpful: it must be in the tail of the list 104 | = go next things (IM.insert token x buf) False -- Since we've already checked the buffer, stop bothering to do so until something changes -} -------------------------------------------------------------------------------- /core/Test/Framework/Runners/TimedConsumption.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Runners.TimedConsumption ( 2 | consumeListInInterval 3 | ) where 4 | 5 | import Test.Framework.Utilities 6 | 7 | import System.CPUTime 8 | 9 | 10 | -- | Evaluates the given list for the given number of microseconds. After the time limit 11 | -- has been reached, a list is returned consisting of the prefix of the list that was 12 | -- successfully evaluated within the time limit. 13 | -- 14 | -- This function does /not/ evaluate the elements of the list: it just ensures that the 15 | -- list spine arrives in good order. 16 | -- 17 | -- The spine of the list is evaluated on the current thread, so if spine evaluation blocks 18 | -- this function will also block, potentially for longer than the specificed delay. 19 | consumeListInInterval :: Int -> [a] -> IO [a] 20 | consumeListInInterval delay list = do 21 | initial_time_ps <- getCPUTime 22 | go initial_time_ps (microsecondsToPicoseconds (fromIntegral delay)) list 23 | where 24 | go _ _ [] = return [] 25 | go initial_time_ps delay_ps (x:xs) = do 26 | this_time <- getCPUTime 27 | if this_time - initial_time_ps < delay_ps 28 | then go initial_time_ps delay_ps xs >>= return . (x:) 29 | else return [] -------------------------------------------------------------------------------- /core/Test/Framework/Runners/XML.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Runners.XML ( 2 | produceReport 3 | ) where 4 | 5 | import Test.Framework.Runners.Statistics ( testCountTotal, TestStatistics(..) ) 6 | import Test.Framework.Runners.Core ( FinishedTest ) 7 | import Test.Framework.Runners.XML.JUnitWriter ( RunDescription(..), serialize ) 8 | 9 | import Data.Time.Format ( formatTime ) 10 | import Data.Time.LocalTime ( getZonedTime ) 11 | 12 | import System.Locale ( defaultTimeLocale ) 13 | 14 | import Network.HostName ( getHostName ) 15 | 16 | 17 | produceReport :: Bool -> TestStatistics -> [FinishedTest] -> IO String 18 | produceReport nested test_statistics fin_tests = fmap (serialize nested) $ mergeResults test_statistics fin_tests 19 | 20 | 21 | -- | Generates a description of the complete test run, given some 22 | -- initial over-all test statistics and the list of tests that was 23 | -- run. 24 | -- 25 | -- This is only specific to the XML code because the console output 26 | -- @Runner@ doesn't need this level of detail to produce summary 27 | -- information, and the per-test details are generated during 28 | -- execution. 29 | -- 30 | -- This could be done better by using a State monad in the notifier 31 | -- defined within `issueTests`. 32 | mergeResults :: TestStatistics -> [FinishedTest] -> IO RunDescription 33 | mergeResults test_statistics fin_tests = do 34 | host <- getHostName 35 | theTime <- getZonedTime 36 | return RunDescription { 37 | errors = 0 -- not yet available 38 | , failedCount = testCountTotal (ts_failed_tests test_statistics) -- this includes errors 39 | , skipped = Nothing -- not yet applicable 40 | , hostname = Just host 41 | , suiteName = "test-framework tests" -- not yet available 42 | , testCount = testCountTotal (ts_total_tests test_statistics) 43 | , time = 0.0 -- We don't currently measure the test run time. 44 | , timeStamp = Just $ formatTime defaultTimeLocale "%a %B %e %k:%M:%S %Z %Y" theTime -- e.g. Thu May 6 22:09:10 BST 2010 45 | , runId = Nothing -- not applicable 46 | , package = Nothing -- not yet available 47 | , tests = fin_tests 48 | } 49 | -------------------------------------------------------------------------------- /core/Test/Framework/Runners/XML/JUnitWriter.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Runners.XML.JUnitWriter ( 2 | RunDescription(..), 3 | serialize, 4 | #ifdef TEST 5 | morphFlatTestCase, morphNestedTestCase 6 | #endif 7 | ) where 8 | 9 | import Test.Framework.Core (TestName) 10 | import Test.Framework.Runners.Core (RunTest(..), FinishedTest) 11 | 12 | import Data.List ( intercalate ) 13 | import Data.Maybe ( fromMaybe ) 14 | import Text.XML.Light ( ppTopElement, unqual, unode 15 | , Attr(..), Element(..) ) 16 | 17 | 18 | -- | An overall description of the test suite run. This is currently 19 | -- styled after the JUnit xml. It contains records that are not yet 20 | -- used, however, it provides a sensible structure to populate as we 21 | -- are able, and the serialiazation code behaves as though these are 22 | -- filled. 23 | data RunDescription = RunDescription { 24 | errors :: Int -- ^ The number of tests that triggered error 25 | -- conditions (unanticipated failures) 26 | , failedCount :: Int -- ^ Count of tests that invalidated stated assertions. 27 | , skipped :: Maybe Int -- ^ Count of tests that were provided but not run. 28 | , hostname :: Maybe String -- ^ The hostname that ran the test suite. 29 | , suiteName :: String -- ^ The name of the test suite. 30 | , testCount :: Int -- ^ The total number of tests provided. 31 | , time :: Double -- ^ The total execution time for the test suite. 32 | , timeStamp :: Maybe String -- ^ The time stamp that identifies when this run happened. 33 | , runId :: Maybe String -- ^ Included for completness w/ junit. 34 | , package :: Maybe String -- ^ holdover from Junit spec. Could be 35 | -- used to specify the module under test. 36 | , tests :: [FinishedTest] -- ^ detailed description and results for each test run. 37 | } deriving (Show) 38 | 39 | 40 | -- | Serializes a `RunDescription` value to a `String`. 41 | serialize :: Bool -> RunDescription -> String 42 | serialize nested = ppTopElement . toXml nested 43 | 44 | -- | Maps a `RunDescription` value to an XML Element 45 | toXml :: Bool -> RunDescription -> Element 46 | toXml nested runDesc = unode "testsuite" (attrs, morph_cases (tests runDesc)) 47 | where 48 | morph_cases | nested = map morphNestedTestCase 49 | | otherwise = concatMap (morphFlatTestCase []) 50 | 51 | -- | Top-level attributes for the first @testsuite@ tag. 52 | attrs :: [Attr] 53 | attrs = map (\(x,f)->Attr (unqual x) (f runDesc)) fields 54 | fields = [ ("errors", show . errors) 55 | , ("failures", show . failedCount) 56 | , ("skipped", fromMaybe "" . fmap show . skipped) 57 | , ("hostname", fromMaybe "" . hostname) 58 | , ("name", id . suiteName) 59 | , ("tests", show . testCount) 60 | , ("time", show . time) 61 | , ("timestamp", fromMaybe "" . timeStamp) 62 | , ("id", fromMaybe "" . runId) 63 | , ("package", fromMaybe "" . package) 64 | ] 65 | 66 | morphFlatTestCase :: [String] -> FinishedTest -> [Element] 67 | morphFlatTestCase path (RunTestGroup gname testList) 68 | = concatMap (morphFlatTestCase (gname:path)) testList 69 | morphFlatTestCase path (RunTest tName _ res) = [morphOneTestCase cName tName res] 70 | where cName | null path = "" 71 | | otherwise = intercalate "." (reverse path) 72 | 73 | morphNestedTestCase :: FinishedTest -> Element 74 | morphNestedTestCase (RunTestGroup gname testList) = 75 | unode "testsuite" (attrs, map morphNestedTestCase testList) 76 | where attrs = [ Attr (unqual "name") gname ] 77 | morphNestedTestCase (RunTest tName _ res) = morphOneTestCase "" tName res 78 | 79 | morphOneTestCase :: String -> TestName -> (String, Bool) -> Element 80 | morphOneTestCase cName tName (tout, pass) = case pass of 81 | True -> unode "testcase" caseAttrs 82 | False -> unode "testcase" (caseAttrs, unode "failure" (failAttrs, tout)) 83 | where caseAttrs = [ Attr (unqual "name") tName 84 | , Attr (unqual "classname") cName 85 | , Attr (unqual "time") "" 86 | ] 87 | failAttrs = [ Attr (unqual "message") "" 88 | , Attr (unqual "type") "" 89 | ] 90 | -------------------------------------------------------------------------------- /core/Test/Framework/Seed.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Seed where 2 | 3 | import Test.Framework.Utilities 4 | 5 | import System.Random 6 | 7 | import Data.Char 8 | 9 | 10 | data Seed = FixedSeed Int 11 | | RandomSeed 12 | 13 | instance Show Seed where 14 | show RandomSeed = "random" 15 | show (FixedSeed n) = show n 16 | 17 | instance Read Seed where 18 | readsPrec prec xs = if map toLower random_prefix == "random" 19 | then [(RandomSeed, rest)] 20 | else map (FixedSeed `onLeft`) (readsPrec prec xs) 21 | where (random_prefix, rest) = splitAt 6 xs 22 | 23 | -- | Given a 'Seed', returns a new random number generator based on that seed and the 24 | -- actual numeric seed that was used to build that generator, so it can be recreated. 25 | newSeededStdGen :: Seed -> IO (StdGen, Int) 26 | newSeededStdGen (FixedSeed seed) = return $ (mkStdGen seed, seed) 27 | newSeededStdGen RandomSeed = newStdGenWithKnownSeed 28 | 29 | newStdGenWithKnownSeed :: IO (StdGen, Int) 30 | newStdGenWithKnownSeed = do 31 | seed <- randomIO 32 | return (mkStdGen seed, seed) -------------------------------------------------------------------------------- /core/Test/Framework/Tests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Test.Framework.Tests.Runners.ThreadPool as TP 4 | import qualified Test.Framework.Tests.Runners.XMLTests as XT 5 | 6 | import Test.HUnit 7 | import Test.QuickCheck 8 | 9 | -- I wish I could use my test framework to test my framework... 10 | main :: IO () 11 | main = do 12 | _ <- runTestTT $ TestList [ 13 | TestList TP.tests, 14 | XT.test 15 | ] 16 | quickCheck XT.property 17 | -------------------------------------------------------------------------------- /core/Test/Framework/Tests/Runners/ThreadPool.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Tests.Runners.ThreadPool (tests) where 2 | 3 | import Test.Framework.Runners.ThreadPool 4 | 5 | import Test.HUnit 6 | 7 | import System.Random 8 | 9 | import Control.Concurrent 10 | 11 | import Prelude hiding (catch) 12 | 13 | 14 | tests :: [Test] 15 | tests = [TestLabel "ThreadPool.executeOnPool preserves order" (TestCase test_execute_preserves_order), 16 | TestLabel "ThreadPool.executeOnPool preserves order even with delays" (TestCase test_execute_preserves_order_even_with_delay), 17 | TestLabel "ThreadPool.executeOnPool input list can depend on previous items" (TestCase test_execute_schedules_lazily)] 18 | 19 | test_execute_preserves_order :: Assertion 20 | test_execute_preserves_order = do 21 | let input = [1..1000] :: [Int] 22 | output <- executeOnPool 4 $ map return input 23 | input @=? output 24 | 25 | test_execute_preserves_order_even_with_delay :: Assertion 26 | test_execute_preserves_order_even_with_delay = do 27 | gen <- getStdGen 28 | let -- Execute 100 actions with a random delay of up to 50ms each 29 | input = [1..100] :: [Int] 30 | actions = zipWith (\n delay -> threadDelay delay >> return n) input (randomRs (0, 50000) gen) 31 | output <- executeOnPool 4 actions 32 | input @=? output 33 | 34 | test_execute_schedules_lazily :: Assertion 35 | test_execute_schedules_lazily = mdo 36 | ~(first_output:rest) <- executeOnPool 4 $ return 10 : (return 20) : replicate first_output (return 99) :: IO [Int] 37 | [10, 20] ++ (replicate 10 99) @=? (first_output:rest) -------------------------------------------------------------------------------- /core/Test/Framework/Tests/Runners/XMLTests.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module Test.Framework.Tests.Runners.XMLTests ( 3 | test, property 4 | ) where 5 | 6 | import Test.Framework.Runners.Core ( RunTest(..), FinishedTest ) 7 | import Test.Framework.Runners.XML.JUnitWriter ( RunDescription(..), morphFlatTestCase, serialize ) 8 | 9 | import Test.HUnit.Base ( Test(..), (@?=) ) 10 | import Test.QuickCheck ( Arbitrary, sized, Gen, oneof, listOf, arbitrary ) 11 | import Test.QuickCheck.Property as P ( Property ) 12 | 13 | import Control.Monad 14 | 15 | import Data.ByteString.Char8 as BS ( pack ) 16 | import Data.Maybe 17 | 18 | import qualified Text.XML.Light as XML ( findAttr, unqual ) 19 | import qualified Text.XML.LibXML.Parser as XML ( parseMemory_ ) 20 | import qualified Text.XML.LibXML.Types as XML ( Document ) 21 | 22 | 23 | -- #ifdef MIN_VERSION_QuickCheck(2, 4, 0) 24 | import Test.QuickCheck.Property as P (morallyDubiousIOProperty) 25 | -- #else 26 | -- import qualified Test.QuickCheck.Property as P (succeeded, failed, liftIOResult) 27 | 28 | -- morallyDubiousIOProperty :: IO Bool -> Property 29 | -- morallyDubiousIOProperty it = P.liftIOResult $ fmap (\err -> if err then P.failed else P.succeeded) it 30 | -- #endif 31 | 32 | -- | `Arbitrary` instance for `TestResult` generation. 33 | instance Arbitrary FinishedTest where 34 | arbitrary = sized testResult 35 | 36 | -- | Size-constrained generator for `TestResult` 37 | testResult :: Int -> Gen FinishedTest 38 | testResult n | n <= 0 = arbitraryTR 39 | | otherwise = oneof [ liftM2 RunTestGroup arbitraryXmlStr (listOf subResult), 40 | subResult] 41 | where arbitraryTR = liftM3 RunTest arbitraryXmlStr arbitraryXmlStr 42 | (liftM2 (,) arbitraryXmlStr arbitrary) 43 | -- | drastically cut the size at each level. 44 | -- round .. -1 is a hack. It works a bit better 45 | -- (is more extreme) than floor and we're really 46 | -- just trying to bound the size so that the 47 | -- tests finish quickly. To see how @floor /= 48 | -- (-1) + round@ consider the inputs: 0.5, 1.5, 49 | -- and 2.5. 50 | subResult :: Gen FinishedTest 51 | subResult = let reduce x = (round (logBase 32 (fromIntegral x) :: Double)) - 1 52 | in testResult $ reduce n 53 | 54 | -- | `RunDescription` generator. All string records are restricted to valid xml characters. 55 | instance Arbitrary RunDescription where 56 | arbitrary = do 57 | return RunDescription 58 | `ap` arbitrary -- errors 59 | `ap` arbitrary -- failed count 60 | `ap` arbitrary -- skipped 61 | `ap` arbitraryMaybeXmlStr -- hostname 62 | `ap` arbitraryXmlStr -- suiteName 63 | `ap` arbitrary -- testCount 64 | `ap` arbitrary -- time 65 | `ap` arbitraryMaybeXmlStr -- timeStamp 66 | `ap` arbitraryMaybeXmlStr -- runId 67 | `ap` arbitraryMaybeXmlStr -- package 68 | `ap` arbitrary -- tests 69 | 70 | -- | Generator for strings that only contain valid XML codepoints, and 71 | -- are wrapped in Maybe. If/when empty strings are generated, they 72 | -- have a 50% chance of being `Nothing`, so this generator should be biased 73 | -- to create `Just` `String`s over `Nothing` 74 | arbitraryMaybeXmlStr :: Gen (Maybe String) 75 | arbitraryMaybeXmlStr = do 76 | str <- arbitraryXmlStr 77 | if null str -- if we have an empty string, we have a chance of generating @Nothing@ 78 | then oneof [return (Just str), return Nothing] 79 | else return (Just str) 80 | 81 | -- | String generator that does not include invalid XML characters. The 82 | -- set of invalid characters is specified here: 83 | -- http://www.w3.org/TR/2000/REC-xml-20001006#NT-Char 84 | arbitraryXmlStr :: Gen String 85 | arbitraryXmlStr = listOf arbitraryXmlChar 86 | where 87 | arbitraryXmlChar :: Gen Char 88 | arbitraryXmlChar = do c <- arbitrary 89 | if validXmlChar (fromEnum c) 90 | then return c 91 | else arbitraryXmlChar 92 | validXmlChar c = c == 0x9 || c == 0xA || c == 0xD 93 | || (c >= 0x20 && c <= 0xD7FF) 94 | || (c >= 0xE000 && c <= 0xFFFD) 95 | || (c >= 0x10000 && c <= 0x10FFFF) 96 | 97 | -- | Generate random `RunDescriptions`, serialize to (flat) XML strings, then check that they are XML 98 | -- TODO: check them against the JUnit schema 99 | property :: RunDescription -> P.Property 100 | property = morallyDubiousIOProperty . fmap isJust . parseSerialize 101 | 102 | parseSerialize :: RunDescription -> IO (Maybe XML.Document) 103 | parseSerialize = XML.parseMemory_ . BS.pack . serialize False 104 | 105 | -- | Verify that the group names are properly pre-pended to sub-tests. 106 | test :: Test 107 | test = TestLabel "Check the composition of group names" $ TestCase $ 108 | XML.findAttr (XML.unqual "classname") x @?= Just "top.g1" 109 | where x = head $ morphFlatTestCase [] $ RunTestGroup "top" [RunTestGroup "g1" [RunTest "t1" "" ("", True)]] 110 | -------------------------------------------------------------------------------- /core/Test/Framework/Utilities.hs: -------------------------------------------------------------------------------- 1 | module Test.Framework.Utilities where 2 | 3 | import Control.Arrow (first, second) 4 | 5 | import Data.Function (on) 6 | import Data.Maybe 7 | import Data.Monoid 8 | import Data.List (intercalate) 9 | 10 | 11 | newtype K a = K { unK :: a } 12 | 13 | 14 | secondsToMicroseconds :: Num a => a -> a 15 | secondsToMicroseconds = (1000000*) 16 | 17 | microsecondsToPicoseconds :: Num a => a -> a 18 | microsecondsToPicoseconds = (1000000*) 19 | 20 | listToMaybeLast :: [a] -> Maybe a 21 | listToMaybeLast = listToMaybe . reverse 22 | 23 | mappendBy :: Monoid b => (a -> b) -> a -> a -> b 24 | mappendBy f = mappend `on` f 25 | 26 | orElse :: Maybe a -> a -> a 27 | orElse = flip fromMaybe 28 | 29 | onLeft :: (a -> c) -> (a, b) -> (c, b) 30 | onLeft = first 31 | 32 | onRight :: (b -> c) -> (a, b) -> (a, c) 33 | onRight = second 34 | 35 | -- | Like 'unlines', but does not append a trailing newline if there 36 | -- is at least one line. For example: 37 | -- 38 | -- > unlinesConcise ["A", "B"] == "A\nB" 39 | -- > unlinesConcise [] == "" 40 | -- 41 | -- Whereas: 42 | -- 43 | -- > unlines ["A", "B"] == "A\nB\n" 44 | -- > unlines [] == "" 45 | -- 46 | -- This is closer to the behaviour of 'unwords', which does not append 47 | -- a trailing space. 48 | unlinesConcise :: [String] -> String 49 | unlinesConcise = intercalate "\n" 50 | 51 | mapAccumLM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y]) 52 | mapAccumLM _ acc [] = return (acc, []) 53 | mapAccumLM f acc (x:xs) = do 54 | (acc', y) <- f acc x 55 | (acc'', ys) <- mapAccumLM f acc' xs 56 | return (acc'', y:ys) 57 | 58 | padRight :: Int -> String -> String 59 | padRight desired_length s = s ++ replicate (desired_length - length s) ' ' 60 | 61 | dropLast :: Int -> [a] -> [a] 62 | dropLast n = reverse . drop n . reverse -------------------------------------------------------------------------------- /core/test-framework.cabal: -------------------------------------------------------------------------------- 1 | Name: test-framework 2 | Version: 0.8.0.2 3 | Cabal-Version: >= 1.6 4 | Category: Testing 5 | Synopsis: Framework for running and organising tests, with HUnit and QuickCheck support 6 | Description: Allows tests such as QuickCheck properties and HUnit test cases to be assembled into test groups, run in 7 | parallel (but reported in deterministic order, to aid diff interpretation) and filtered and controlled by 8 | command line options. All of this comes with colored test output, progress reporting and test statistics output. 9 | License: BSD3 10 | License-File: LICENSE 11 | Author: Max Bolingbroke 12 | Maintainer: Libraries List 13 | Homepage: http://batterseapower.github.io/test-framework/ 14 | Bug-Reports: https://github.com/haskell/test-framework/issues/ 15 | Build-Type: Simple 16 | 17 | Flag Tests 18 | Description: Build the tests 19 | Default: False 20 | 21 | 22 | Library 23 | Exposed-Modules: Test.Framework 24 | Test.Framework.Options 25 | Test.Framework.Providers.API 26 | Test.Framework.Runners.Console 27 | Test.Framework.Runners.Options 28 | Test.Framework.Runners.TestPattern 29 | Test.Framework.Runners.API 30 | Test.Framework.Seed 31 | 32 | Other-Modules: Test.Framework.Core 33 | Test.Framework.Improving 34 | Test.Framework.Runners.Console.Colors 35 | Test.Framework.Runners.Console.ProgressBar 36 | Test.Framework.Runners.Console.Run 37 | Test.Framework.Runners.Console.Statistics 38 | Test.Framework.Runners.Console.Table 39 | Test.Framework.Runners.Console.Utilities 40 | Test.Framework.Runners.Core 41 | Test.Framework.Runners.Processors 42 | Test.Framework.Runners.Statistics 43 | Test.Framework.Runners.ThreadPool 44 | Test.Framework.Runners.TimedConsumption 45 | Test.Framework.Runners.XML.JUnitWriter 46 | Test.Framework.Runners.XML 47 | Test.Framework.Utilities 48 | 49 | Build-Depends: ansi-terminal >= 0.4.0, ansi-wl-pprint >= 0.5.1, 50 | base >= 4.3 && < 5, random >= 1.0, containers >= 0.1, 51 | regex-posix >= 0.72, 52 | old-locale >= 1.0, time >= 1.1.2, 53 | xml >= 1.3.5, hostname >= 1.0 54 | 55 | Extensions: CPP 56 | PatternGuards 57 | ExistentialQuantification 58 | RecursiveDo 59 | FlexibleInstances 60 | TypeSynonymInstances 61 | TypeOperators 62 | FunctionalDependencies 63 | MultiParamTypeClasses 64 | 65 | Ghc-Options: -Wall 66 | 67 | if impl(ghc) 68 | Cpp-Options: -DCOMPILER_GHC 69 | 70 | Executable test-framework-tests 71 | Main-Is: Test/Framework/Tests.hs 72 | 73 | if !flag(tests) 74 | Buildable: False 75 | else 76 | Build-Depends: HUnit >= 1.2, QuickCheck >= 2.3 && < 2.5, 77 | base >= 4.3 && < 5, random >= 1.0, containers >= 0.1, 78 | ansi-terminal >= 0.4.0, ansi-wl-pprint >= 0.5.1, 79 | regex-posix >= 0.72, 80 | old-locale >= 1.0, time >= 1.1.2, 81 | xml >= 1.3.5, hostname >= 1.0, 82 | libxml >= 0.1.1, bytestring >= 0.9 83 | 84 | Extensions: CPP 85 | PatternGuards 86 | ExistentialQuantification 87 | RecursiveDo 88 | FlexibleInstances 89 | TypeSynonymInstances 90 | TypeOperators 91 | FunctionalDependencies 92 | MultiParamTypeClasses 93 | 94 | Cpp-Options: -DTEST 95 | 96 | Ghc-Options: -Wall -threaded 97 | 98 | if impl(ghc) 99 | Cpp-Options: -DCOMPILER_GHC 100 | 101 | Source-Repository head 102 | Type: git 103 | Location: https://github.com/haskell/test-framework 104 | -------------------------------------------------------------------------------- /example/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008, Maximilian Bolingbroke 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted 5 | provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this list of 8 | conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above copyright notice, this list of 10 | conditions and the following disclaimer in the documentation and/or other materials 11 | provided with the distribution. 12 | * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to 13 | endorse or promote products derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 17 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 18 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 20 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 21 | IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 22 | OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /example/Setup.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env runhaskell 2 | 3 | > import Distribution.Simple 4 | > main = defaultMain -------------------------------------------------------------------------------- /example/Test/Framework/Example.lhs: -------------------------------------------------------------------------------- 1 | == RUNNING == 2 | 3 | Compile the test suite: 4 | 5 | ghc -package test-framework -package test-framework-quickcheck2 \ 6 | -package test-framework-hunit -threaded Example.lhs -o Example 7 | 8 | To run the test suite with the default options, simply execute the 9 | resulting binary: 10 | 11 | ./Example 12 | 13 | Test options can also be supplied on the command-line: 14 | 15 | ./Example --maximum-generated-tests=5000 +RTS -N2 16 | 17 | To see the available options, run: 18 | 19 | ./Example --help 20 | 21 | These options can also be specified in the code. An alternate main 22 | function, mainWithOpts, with compile-time options is provided: 23 | 24 | ghc -package test-framework -package test-framework-quickcheck2 \ 25 | -package test-framework-hunit -main-is mainWithOpts \ 26 | -threaded Example.lhs -o Example 27 | ./Example 28 | 29 | == ATTRIBUTION == 30 | 31 | The example properties come from the parallel QuickCheck driver (pqc), 32 | see http://code.haskell.org/~dons/code/pqc/. The BSD license is repeated 33 | below, per the licensing conditions of pqc. 34 | 35 | == LICENSING == 36 | 37 | Copyright Don Stewart 2006. 38 | 39 | All rights reserved. 40 | 41 | Redistribution and use in source and binary forms, with or without 42 | modification, are permitted provided that the following conditions are 43 | met: 44 | 45 | * Redistributions of source code must retain the above copyright 46 | notice, this list of conditions and the following disclaimer. 47 | 48 | * Redistributions in binary form must reproduce the above 49 | copyright notice, this list of conditions and the following 50 | disclaimer in the documentation and/or other materials provided 51 | with the distribution. 52 | 53 | * Neither the name of Don Stewart nor the names of other 54 | contributors may be used to endorse or promote products derived 55 | from this software without specific prior written permission. 56 | 57 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 58 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 59 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 60 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 61 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 62 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 63 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 64 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 65 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 66 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 67 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 68 | 69 | \begin{code} 70 | 71 | module Main 72 | where 73 | 74 | import Data.Monoid (mempty) 75 | import Test.Framework (defaultMain, defaultMainWithOpts, testGroup) 76 | import Test.Framework.Options (TestOptions, TestOptions'(..)) 77 | import Test.Framework.Runners.Options (RunnerOptions, RunnerOptions'(..)) 78 | import Test.Framework.Providers.HUnit 79 | import Test.Framework.Providers.QuickCheck2 (testProperty) 80 | 81 | import Test.QuickCheck 82 | import Test.HUnit 83 | 84 | import Data.List 85 | 86 | main = defaultMain tests 87 | 88 | mainWithOpts = do 89 | -- Test options can also be specified in the code. The TestOptions 90 | -- type is an instance of the Monoid type class, so the easiest way 91 | -- to get an empty set of options is with `mempty`. 92 | let empty_test_opts = mempty :: TestOptions 93 | 94 | -- We update the empty TestOptions with our desired values. 95 | let my_test_opts = empty_test_opts { 96 | topt_maximum_generated_tests = Just 500 97 | } 98 | 99 | -- Now we create an empty RunnerOptions in the same way, and add 100 | -- our TestOptions to it. 101 | let empty_runner_opts = mempty :: RunnerOptions 102 | let my_runner_opts = empty_runner_opts { 103 | ropt_test_options = Just my_test_opts 104 | } 105 | 106 | defaultMainWithOpts tests my_runner_opts 107 | 108 | tests = [ 109 | testGroup "Sorting Group 1" [ 110 | testProperty "sort1" prop_sort1, 111 | testProperty "sort2" prop_sort2, 112 | testProperty "sort3" prop_sort3 113 | ], 114 | testGroup "Sorting Group 2" [ 115 | testGroup "Nested Group 1" [ 116 | testProperty "sort4" prop_sort4, 117 | testProperty "sort5" prop_sort5, 118 | testProperty "sort6" prop_sort6 119 | ], 120 | testProperty "sort7" prop_sort7, 121 | testCase "sort8" test_sort8, 122 | testCase "sort9" test_sort9 123 | ] 124 | ] 125 | 126 | 127 | prop_sort1 xs = sort xs == sortBy compare xs 128 | where types = (xs :: [Int]) 129 | 130 | prop_sort2 xs = 131 | (not (null xs)) ==> 132 | (head (sort xs) == minimum xs) 133 | where types = (xs :: [Int]) 134 | 135 | prop_sort3 xs = (not (null xs)) ==> 136 | last (sort xs) == maximum xs 137 | where types = (xs :: [Int]) 138 | 139 | prop_sort4 xs ys = 140 | (not (null xs)) ==> 141 | (not (null ys)) ==> 142 | (head (sort (xs ++ ys)) == min (minimum xs) (minimum ys)) 143 | where types = (xs :: [Int], ys :: [Int]) 144 | 145 | prop_sort5 xs ys = 146 | (not (null xs)) ==> 147 | (not (null ys)) ==> 148 | (head (sort (xs ++ ys)) == max (maximum xs) (maximum ys)) 149 | where types = (xs :: [Int], ys :: [Int]) 150 | 151 | prop_sort6 xs ys = 152 | (not (null xs)) ==> 153 | (not (null ys)) ==> 154 | (last (sort (xs ++ ys)) == max (maximum xs) (maximum ys)) 155 | where types = (xs :: [Int], ys :: [Int]) 156 | 157 | prop_sort7 xs = if null xs then error "This property deliberately contains a user error" else True 158 | where types = (xs :: [Int]) 159 | 160 | test_sort8 = sort [8, 7, 2, 5, 4, 9, 6, 1, 0, 3] @?= [0..9] 161 | 162 | test_sort9 = error "This test deliberately contains a user error" 163 | \end{code} 164 | -------------------------------------------------------------------------------- /example/test-framework-example.cabal: -------------------------------------------------------------------------------- 1 | Name: test-framework-example 2 | Version: 0.2.1 3 | Cabal-Version: >= 1.2 4 | Category: Testing 5 | Synopsis: Example testsuite for the test-framework package 6 | License: BSD3 7 | License-File: LICENSE 8 | Author: Max Bolingbroke 9 | Maintainer: Max Bolingbroke 10 | Homepage: http://batterseapower.github.com/test-framework/ 11 | Build-Type: Simple 12 | 13 | Flag SplitBase 14 | Description: Choose the new smaller, split-up base package 15 | Default: True 16 | 17 | 18 | Executable test-framework-example 19 | Main-Is: Test/Framework/Example.lhs 20 | 21 | Build-Depends: test-framework >= 0.2.0, 22 | test-framework-quickcheck2 >= 0.2.0, QuickCheck >= 2, 23 | test-framework-hunit >= 0.2.0, HUnit >= 1.2 && < 2 24 | if flag(splitBase) 25 | Build-Depends: base >= 3 && < 5 26 | else 27 | Build-Depends: base < 3 28 | 29 | Ghc-Options: -threaded -O0 -------------------------------------------------------------------------------- /hunit/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008, Maximilian Bolingbroke 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted 5 | provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this list of 8 | conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above copyright notice, this list of 10 | conditions and the following disclaimer in the documentation and/or other materials 11 | provided with the distribution. 12 | * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to 13 | endorse or promote products derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 17 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 18 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 20 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 21 | IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 22 | OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /hunit/Setup.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env runhaskell 2 | 3 | > import Distribution.Simple 4 | > main = defaultMain -------------------------------------------------------------------------------- /hunit/Test/Framework/Providers/HUnit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | -- | Allows HUnit test cases to be used with the test-framework package. 3 | -- 4 | -- For an example of how to use test-framework, please see 5 | module Test.Framework.Providers.HUnit ( 6 | testCase, 7 | hUnitTestToTests, 8 | ) where 9 | 10 | import Test.Framework.Providers.API 11 | 12 | import qualified Test.HUnit.Base 13 | import Test.HUnit.Lang 14 | 15 | import Data.Typeable 16 | 17 | -- | Create a 'Test' for a HUnit 'Assertion' 18 | testCase :: TestName -> Assertion -> Test 19 | testCase name = Test name . TestCase 20 | 21 | -- | Adapt an existing HUnit test into a list of test-framework tests. 22 | -- This is useful when migrating your existing HUnit test suite to test-framework. 23 | hUnitTestToTests :: Test.HUnit.Base.Test -> [Test] 24 | hUnitTestToTests = go "" 25 | where 26 | go desc (Test.HUnit.Base.TestCase a) = [testCase desc a] 27 | go desc (Test.HUnit.Base.TestLabel s t) = go (desc ++ ":" ++ s) t 28 | go desc (Test.HUnit.Base.TestList ts) 29 | -- If the list occurs at the top level (with no description above it), 30 | -- just return that list straightforwardly 31 | | null desc = concatMap (go desc) ts 32 | -- If the list occurs with a description, turn that into a honest-to-god 33 | -- test group. This is heuristic, but likely to give good results 34 | | otherwise = [testGroup desc (concatMap (go "") ts)] 35 | 36 | 37 | instance TestResultlike TestCaseRunning TestCaseResult where 38 | testSucceeded = testCaseSucceeded 39 | 40 | data TestCaseRunning = TestCaseRunning 41 | 42 | instance Show TestCaseRunning where 43 | show TestCaseRunning = "Running" 44 | 45 | data TestCaseResult = TestCasePassed 46 | | TestCaseFailed String 47 | | TestCaseError String 48 | 49 | instance Show TestCaseResult where 50 | show result = case result of 51 | TestCasePassed -> "OK" 52 | TestCaseFailed message -> message 53 | TestCaseError message -> "ERROR: " ++ message 54 | 55 | testCaseSucceeded :: TestCaseResult -> Bool 56 | testCaseSucceeded TestCasePassed = True 57 | testCaseSucceeded _ = False 58 | 59 | 60 | newtype TestCase = TestCase Assertion 61 | deriving Typeable 62 | 63 | instance Testlike TestCaseRunning TestCaseResult TestCase where 64 | runTest topts (TestCase assertion) = runTestCase topts assertion 65 | testTypeName _ = "Test Cases" 66 | 67 | runTestCase :: CompleteTestOptions -> Assertion -> IO (TestCaseRunning :~> TestCaseResult, IO ()) 68 | runTestCase topts assertion = runImprovingIO $ do 69 | yieldImprovement TestCaseRunning 70 | mb_result <- maybeTimeoutImprovingIO (unK $ topt_timeout topts) $ liftIO (myPerformTestCase assertion) 71 | return (mb_result `orElse` TestCaseError "Timed out") 72 | 73 | myPerformTestCase :: Assertion -> IO TestCaseResult 74 | myPerformTestCase assertion = do 75 | result <- performTestCase assertion 76 | return $ case result of 77 | Nothing -> TestCasePassed 78 | Just (True, message) -> TestCaseFailed message 79 | Just (False, message) -> TestCaseError message 80 | -------------------------------------------------------------------------------- /hunit/test-framework-hunit.cabal: -------------------------------------------------------------------------------- 1 | Name: test-framework-hunit 2 | Version: 0.3.0 3 | Cabal-Version: >= 1.2.3 4 | Category: Testing 5 | Synopsis: HUnit support for the test-framework package. 6 | License: BSD3 7 | License-File: LICENSE 8 | Author: Max Bolingbroke 9 | Maintainer: Max Bolingbroke 10 | Homepage: http://batterseapower.github.com/test-framework/ 11 | Build-Type: Simple 12 | 13 | Flag Base4 14 | Description: Choose base version 4 15 | Default: True 16 | 17 | Flag Base3 18 | Description: Choose base version 3 19 | Default: False 20 | 21 | 22 | Library 23 | Exposed-Modules: Test.Framework.Providers.HUnit 24 | 25 | Build-Depends: test-framework >= 0.2.0, HUnit >= 1.2 && < 2, extensible-exceptions >= 0.1.1 && < 0.2.0 26 | if flag(base3) 27 | Build-Depends: base >= 3 && < 4 28 | else 29 | if flag(base4) 30 | Build-Depends: base >= 4 && < 5 31 | 32 | Extensions: TypeOperators 33 | MultiParamTypeClasses 34 | 35 | Ghc-Options: -Wall -------------------------------------------------------------------------------- /quickcheck/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008, Maximilian Bolingbroke 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted 5 | provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this list of 8 | conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above copyright notice, this list of 10 | conditions and the following disclaimer in the documentation and/or other materials 11 | provided with the distribution. 12 | * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to 13 | endorse or promote products derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 17 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 18 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 20 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 21 | IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 22 | OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /quickcheck/Setup.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env runhaskell 2 | 3 | > import Distribution.Simple 4 | > main = defaultMain -------------------------------------------------------------------------------- /quickcheck/Test/Framework/Providers/QuickCheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | -- | Allows QuickCheck1 properties to be used with the test-framework package. 3 | -- 4 | -- For an example of how to use test-framework, please see 5 | module Test.Framework.Providers.QuickCheck ( 6 | testProperty 7 | ) where 8 | 9 | import Test.Framework.Providers.API 10 | 11 | import Test.QuickCheck hiding (Property) 12 | 13 | import qualified Control.Exception.Extensible as E 14 | import Control.DeepSeq (rnf) 15 | 16 | import System.Random 17 | import Data.Typeable 18 | 19 | 20 | -- | Create a 'Test' for a QuickCheck 'Testable' property 21 | testProperty :: Testable a => TestName -> a -> Test 22 | testProperty name = Test name . Property 23 | 24 | 25 | instance TestResultlike PropertyTestCount PropertyResult where 26 | testSucceeded = propertySucceeded 27 | 28 | -- | Used to document numbers which we expect to be intermediate test counts from running properties 29 | type PropertyTestCount = Int 30 | 31 | -- | The failure information from the run of a property 32 | data PropertyResult = PropertyResult { 33 | pr_status :: PropertyStatus, 34 | pr_used_seed :: Int, 35 | pr_tests_run :: Maybe PropertyTestCount -- Due to technical limitations, it's currently not possible to find out the number of 36 | -- tests previously run if the test times out, hence we need a Maybe here for that case. 37 | } 38 | 39 | data PropertyStatus = PropertyOK -- ^ The property is true as far as we could check it 40 | | PropertyArgumentsExhausted -- ^ The property may be true, but we ran out of arguments to try it out on 41 | | PropertyFalsifiable [String] -- ^ The property was not true. The list of strings are the arguments inducing failure. 42 | | PropertyTimedOut -- ^ The property timed out during execution 43 | | PropertyException String -- ^ The property raised an exception during execution 44 | 45 | instance Show PropertyResult where 46 | show (PropertyResult { pr_status = status, pr_used_seed = used_seed, pr_tests_run = mb_tests_run }) 47 | = case status of 48 | PropertyOK -> "OK, passed " ++ tests_run_str ++ " tests" 49 | PropertyArgumentsExhausted -> "Arguments exhausted after " ++ tests_run_str ++ " tests" 50 | PropertyFalsifiable test_args -> "Falsifiable with seed " ++ show used_seed ++ ", after " ++ tests_run_str ++ " tests:\n" ++ unlinesConcise test_args 51 | PropertyTimedOut -> "Timed out after " ++ tests_run_str ++ " tests" 52 | PropertyException text -> "Got an exception: " ++ text 53 | where 54 | tests_run_str = fmap show mb_tests_run `orElse` "an unknown number of" 55 | 56 | propertySucceeded :: PropertyResult -> Bool 57 | propertySucceeded (PropertyResult { pr_status = status, pr_tests_run = mb_n }) = case status of 58 | PropertyOK -> True 59 | PropertyArgumentsExhausted -> maybe False (/= 0) mb_n 60 | _ -> False 61 | 62 | 63 | data Property = forall a. Testable a => Property a 64 | deriving Typeable 65 | 66 | instance Testlike PropertyTestCount PropertyResult Property where 67 | runTest topts (Property testable) = runProperty topts testable 68 | testTypeName _ = "Properties" 69 | 70 | runProperty :: Testable a => CompleteTestOptions -> a -> IO (PropertyTestCount :~> PropertyResult, IO ()) 71 | runProperty topts testable = do 72 | (gen, seed) <- newSeededStdGen (unK $ topt_seed topts) 73 | runImprovingIO $ do 74 | mb_result <- maybeTimeoutImprovingIO (unK (topt_timeout topts)) $ myCheck topts gen testable 75 | return $ toPropertyResult seed $ case mb_result of 76 | Nothing -> (PropertyTimedOut, Nothing) 77 | Just (status, tests_run) -> (status, Just tests_run) 78 | where 79 | toPropertyResult seed (status, mb_tests_run) = PropertyResult { 80 | pr_status = status, 81 | pr_used_seed = seed, 82 | pr_tests_run = mb_tests_run 83 | } 84 | 85 | myCheck :: (Testable a) => CompleteTestOptions -> StdGen -> a -> ImprovingIO PropertyTestCount f (PropertyStatus, PropertyTestCount) 86 | myCheck topts rnd a = myTests topts (evaluate a) rnd 0 0 [] 87 | 88 | myTests :: CompleteTestOptions -> Gen Result -> StdGen -> PropertyTestCount -> PropertyTestCount -> [[String]] -> ImprovingIO PropertyTestCount f (PropertyStatus, PropertyTestCount) 89 | myTests topts gen rnd0 ntest nfail stamps 90 | | ntest == unK (topt_maximum_generated_tests topts) = do return (PropertyOK, ntest) 91 | | nfail == unK (topt_maximum_unsuitable_generated_tests topts) = do return (PropertyArgumentsExhausted, ntest) 92 | | otherwise = do 93 | yieldImprovement ntest 94 | -- Rather clunky code that tries to catch exceptions early. If we don't do this then errors 95 | -- in your properties just kill the test framework - very bad! 96 | mb_exception <- liftIO $ E.catch (fmap (const Nothing) $ E.evaluate (rnfResult result)) 97 | (return . Just . show :: E.SomeException -> IO (Maybe String)) 98 | case mb_exception of 99 | Just e -> return (PropertyException e, ntest) 100 | Nothing -> case ok result of 101 | Nothing -> 102 | myTests topts gen rnd1 ntest (nfail + 1) stamps 103 | Just True -> 104 | myTests topts gen rnd1 (ntest + 1) nfail (stamp result:stamps) 105 | Just False -> 106 | return (PropertyFalsifiable (arguments result), ntest) 107 | where 108 | result = generate (configSize defaultConfig ntest) rnd2 gen 109 | (rnd1, rnd2) = split rnd0 110 | 111 | -- Reduce a Result to RNF before we poke at it in order to uncover hidden exceptions 112 | rnfResult r = rnf (ok r) `seq` rnf (stamp r) `seq` rnf (arguments r) 113 | -------------------------------------------------------------------------------- /quickcheck/test-framework-quickcheck.cabal: -------------------------------------------------------------------------------- 1 | Name: test-framework-quickcheck 2 | Version: 0.3.0 3 | Cabal-Version: >= 1.2.3 4 | Category: Testing 5 | Synopsis: QuickCheck support for the test-framework package. 6 | License: BSD3 7 | License-File: LICENSE 8 | Author: Max Bolingbroke 9 | Maintainer: Max Bolingbroke 10 | Homepage: http://batterseapower.github.com/test-framework/ 11 | Build-Type: Simple 12 | 13 | Flag Base4 14 | Description: Choose base version 4 15 | Default: True 16 | 17 | Flag Base3 18 | Description: Choose base version 3 19 | Default: False 20 | 21 | 22 | Library 23 | Exposed-Modules: Test.Framework.Providers.QuickCheck 24 | 25 | Build-Depends: test-framework >= 0.2.0, QuickCheck >= 1.1 && < 2, extensible-exceptions >= 0.1.1 && < 0.2.0 26 | if flag(base3) 27 | Build-Depends: base >= 3 && < 4, random >= 1, deepseq >= 1.1 && < 1.4 28 | else 29 | if flag(base4) 30 | Build-Depends: base >= 4 && < 5, random >= 1, deepseq >= 1.1 && < 1.4 31 | 32 | Extensions: TypeSynonymInstances 33 | TypeOperators 34 | MultiParamTypeClasses 35 | ExistentialQuantification 36 | 37 | Ghc-Options: -Wall 38 | -------------------------------------------------------------------------------- /quickcheck2/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2008, Maximilian Bolingbroke 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted 5 | provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this list of 8 | conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above copyright notice, this list of 10 | conditions and the following disclaimer in the documentation and/or other materials 11 | provided with the distribution. 12 | * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to 13 | endorse or promote products derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 17 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 18 | CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 20 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 21 | IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 22 | OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /quickcheck2/Setup.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env runhaskell 2 | 3 | > import Distribution.Simple 4 | > main = defaultMain -------------------------------------------------------------------------------- /quickcheck2/Test/Framework/Providers/QuickCheck2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | -- | Allows QuickCheck2 properties to be used with the test-framework package. 3 | -- 4 | -- For an example of how to use test-framework, please see 5 | module Test.Framework.Providers.QuickCheck2 ( 6 | testProperty 7 | ) where 8 | 9 | import Test.Framework.Providers.API 10 | 11 | import Test.QuickCheck.Property (Testable, Callback(PostTest), CallbackKind(NotCounterexample), callback) 12 | import Test.QuickCheck.State (numSuccessTests) 13 | import Test.QuickCheck.Test 14 | 15 | import Data.Typeable 16 | 17 | 18 | -- | Create a 'Test' for a QuickCheck2 'Testable' property 19 | testProperty :: Testable a => TestName -> a -> Test 20 | testProperty name = Test name . Property 21 | 22 | 23 | instance TestResultlike PropertyTestCount PropertyResult where 24 | testSucceeded = propertySucceeded 25 | 26 | -- | Used to document numbers which we expect to be intermediate test counts from running properties 27 | type PropertyTestCount = Int 28 | 29 | -- | The failure information from the run of a property 30 | data PropertyResult = PropertyResult { 31 | pr_status :: PropertyStatus, 32 | pr_used_seed :: Int, 33 | pr_tests_run :: Maybe PropertyTestCount -- Due to technical limitations, it's currently not possible to find out the number of 34 | -- tests previously run if the test times out, hence we need a Maybe here for that case. 35 | } 36 | 37 | data PropertyStatus = PropertyOK -- ^ The property is true as far as we could check it 38 | | PropertyArgumentsExhausted -- ^ The property may be true, but we ran out of arguments to try it out on 39 | | PropertyFalsifiable String String -- ^ The property was not true. The strings are the reason and the output. 40 | | PropertyNoExpectedFailure -- ^ We expected that a property would fail but it didn't 41 | | PropertyTimedOut -- ^ The property timed out during execution 42 | 43 | instance Show PropertyResult where 44 | show (PropertyResult { pr_status = status, pr_used_seed = used_seed, pr_tests_run = mb_tests_run }) 45 | = case status of 46 | PropertyOK -> "OK, passed " ++ tests_run_str ++ " tests" 47 | PropertyArgumentsExhausted -> "Arguments exhausted after " ++ tests_run_str ++ " tests" 48 | PropertyFalsifiable _rsn otpt -> otpt ++ "(used seed " ++ show used_seed ++ ")" 49 | PropertyNoExpectedFailure -> "No expected failure with seed " ++ show used_seed ++ ", after " ++ tests_run_str ++ " tests" 50 | PropertyTimedOut -> "Timed out after " ++ tests_run_str ++ " tests" 51 | where 52 | tests_run_str = fmap show mb_tests_run `orElse` "an unknown number of" 53 | 54 | propertySucceeded :: PropertyResult -> Bool 55 | propertySucceeded (PropertyResult { pr_status = status, pr_tests_run = mb_n }) = case status of 56 | PropertyOK -> True 57 | PropertyArgumentsExhausted -> maybe False (/= 0) mb_n 58 | _ -> False 59 | 60 | 61 | data Property = forall a. Testable a => Property a 62 | deriving Typeable 63 | 64 | instance Testlike PropertyTestCount PropertyResult Property where 65 | runTest topts (Property testable) = runProperty topts testable 66 | testTypeName _ = "Properties" 67 | 68 | runProperty :: Testable a => CompleteTestOptions -> a -> IO (PropertyTestCount :~> PropertyResult, IO ()) 69 | runProperty topts testable = do 70 | (gen, seed) <- newSeededStdGen (unK $ topt_seed topts) 71 | let max_success = unK $ topt_maximum_generated_tests topts 72 | max_discard = unK $ topt_maximum_unsuitable_generated_tests topts 73 | args = stdArgs { replay = Just (gen, 0) -- NB: the 0 is the saved size. Defaults to 0 if you supply "Nothing" for "replay". 74 | , maxSuccess = max_success 75 | #if MIN_VERSION_QuickCheck(2,5,0) 76 | , maxDiscardRatio = max_discard `div` max_success 77 | #else 78 | , maxDiscard = max_discard 79 | #endif 80 | , maxSize = unK $ topt_maximum_test_size topts 81 | , chatty = False } 82 | -- FIXME: yield gradual improvement after each test 83 | runImprovingIO $ do 84 | tunnel <- tunnelImprovingIO 85 | mb_result <- maybeTimeoutImprovingIO (unK (topt_timeout topts)) $ 86 | liftIO $ quickCheckWithResult args (callback (PostTest NotCounterexample (\s _r -> tunnel $ yieldImprovement $ numSuccessTests s)) testable) 87 | return $ case mb_result of 88 | Nothing -> PropertyResult { pr_status = PropertyTimedOut, pr_used_seed = seed, pr_tests_run = Nothing } 89 | Just result -> PropertyResult { 90 | pr_status = toPropertyStatus result, 91 | pr_used_seed = seed, 92 | pr_tests_run = Just (numTests result) 93 | } 94 | where 95 | toPropertyStatus (Success {}) = PropertyOK 96 | toPropertyStatus (GaveUp {}) = PropertyArgumentsExhausted 97 | toPropertyStatus (Failure { reason = rsn, output = otpt }) = PropertyFalsifiable rsn otpt 98 | toPropertyStatus (NoExpectedFailure {}) = PropertyNoExpectedFailure 99 | -------------------------------------------------------------------------------- /quickcheck2/test-framework-quickcheck2.cabal: -------------------------------------------------------------------------------- 1 | Name: test-framework-quickcheck2 2 | Version: 0.3.0.2 3 | Cabal-Version: >= 1.6 4 | Category: Testing 5 | Synopsis: QuickCheck2 support for the test-framework package. 6 | License: BSD3 7 | License-File: LICENSE 8 | Author: Max Bolingbroke 9 | Maintainer: Haskell Libraries 10 | Homepage: http://batterseapower.github.io/test-framework/ 11 | Bug-Reports: https://github.com/haskell/test-framework/ 12 | Build-Type: Simple 13 | Description: QuickCheck2 support for the test-framework package. 14 | 15 | Flag Base4 16 | Description: Choose base version 4 17 | Default: True 18 | 19 | Flag Base3 20 | Description: Choose base version 3 21 | Default: False 22 | 23 | 24 | Library 25 | Exposed-Modules: Test.Framework.Providers.QuickCheck2 26 | 27 | Build-Depends: test-framework >= 0.7.1, QuickCheck >= 2.4 && < 2.7, extensible-exceptions >= 0.1.1 && < 0.2.0 28 | if flag(base3) 29 | Build-Depends: base >= 3 && < 4, random >= 1 30 | else 31 | if flag(base4) 32 | Build-Depends: base >= 4 && < 5, random >= 1 33 | 34 | Extensions: TypeSynonymInstances 35 | TypeOperators 36 | MultiParamTypeClasses 37 | ExistentialQuantification 38 | CPP 39 | 40 | Ghc-Options: -Wall 41 | 42 | Source-Repository head 43 | Type: git 44 | Location: https://github.com/haskell/test-framework 45 | -------------------------------------------------------------------------------- /release: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | 4 | if [ "$(git branch | grep '* ')" != "* master" ]; then 5 | echo "You are not on the master branch!" 6 | exit 1 7 | fi 8 | 9 | echo "Have you updated the version number? Type 'yes' if you have!" 10 | read version_response 11 | 12 | if [ "$version_response" != "yes" ]; then 13 | echo "Go and update the version number" 14 | exit 1 15 | fi 16 | 17 | 18 | # Not 'example' as well because we don't really want to upload a simple example package to Hackage. 19 | declare -a subdirectories=(core hunit quickcheck quickcheck2) 20 | declare -a filenames 21 | 22 | index=0 23 | while [ "$index" -lt "${#subdirectories[@]}" ]; do 24 | # Find out the working subdirectory and enter it 25 | subdirectory=${subdirectories[index]} 26 | cd $subdirectory 27 | 28 | # For those directories that use CPP, we need to configure before sdist will work without a warning 29 | runghc Setup.lhs configure --user 30 | 31 | # OK, build the tarball 32 | sdist_output=`runghc Setup.lhs sdist` 33 | 34 | if [ "$?" != "0" ]; then 35 | echo "Cabal sdist failed, aborting" 36 | exit 1 37 | fi 38 | 39 | 40 | # Want to find a line like: 41 | # Source tarball created: dist/ansi-terminal-0.1.tar.gz 42 | 43 | # Test this with: 44 | # runghc Setup.lhs sdist | grep ... 45 | filename=`echo $sdist_output | sed 's/.*Source tarball created: \([^ ]*\).*/\1/'` 46 | filenames[$index]="$subdirectory/$filename" 47 | echo "Filename: $filename" 48 | 49 | if [ "$filename" = "$sdist_output" ]; then 50 | echo "Could not find filename, aborting" 51 | exit 1 52 | fi 53 | 54 | 55 | if [ "$subdirectory" = "core" ]; then 56 | # Test this with: 57 | # echo dist/ansi-terminal-0.1.tar.gz | sed ... 58 | version=`echo $filename | sed 's/^[^0-9]*\([0-9\.]*\).tar.gz$/\1/'` 59 | echo "Version: $version" 60 | 61 | if [ "$version" = "$filename" ]; then 62 | echo "Could not find version, aborting" 63 | exit 1 64 | fi 65 | fi 66 | 67 | 68 | # Move to the next directory 69 | cd .. 70 | let "index = $index + 1" 71 | done 72 | 73 | 74 | echo "This is your last chance to abort! I'm going to upload v$version in 10 seconds" 75 | sleep 10 76 | 77 | 78 | if [ -n "$version" ]; then 79 | git tag "v$version" 80 | 81 | if [ "$?" != "0" ]; then 82 | echo "Git tag failed, aborting" 83 | exit 1 84 | fi 85 | fi 86 | 87 | 88 | index=0 89 | while [ "$index" -lt "${#filenames[@]}" ]; do 90 | # You need to have stored your Hackage username and password as directed by cabal-upload 91 | # I use -v5 because otherwise the error messages can be cryptic :-) 92 | filename=${filenames[index]} 93 | cabal upload -v3 $filename 94 | 95 | if [ "$?" != "0" ]; then 96 | echo "Hackage upload of $filename failed, aborting" 97 | exit 1 98 | fi 99 | 100 | let "index = $index + 1" 101 | done 102 | 103 | # Success! 104 | exit 0 105 | --------------------------------------------------------------------------------