test-framework-0.8.1.1/0000755000000000000000000000000012453651525013027 5ustar0000000000000000test-framework-0.8.1.1/LICENSE0000644000000000000000000000276612453651525014047 0ustar0000000000000000Copyright (c) 2008, Maximilian Bolingbroke All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.test-framework-0.8.1.1/Setup.lhs0000644000000000000000000000011512453651525014634 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMaintest-framework-0.8.1.1/test-framework.cabal0000644000000000000000000001166712453651525017000 0ustar0000000000000000Name: test-framework Version: 0.8.1.1 Cabal-Version: >= 1.6 Category: Testing Synopsis: Framework for running and organising tests, with HUnit and QuickCheck support Description: Allows tests such as QuickCheck properties and HUnit test cases to be assembled into test groups, run in parallel (but reported in deterministic order, to aid diff interpretation) and filtered and controlled by command line options. All of this comes with colored test output, progress reporting and test statistics output. License: BSD3 License-File: LICENSE Author: Max Bolingbroke Maintainer: Libraries List Homepage: https://batterseapower.github.io/test-framework/ Bug-Reports: https://github.com/haskell/test-framework/issues/ Build-Type: Simple Flag Tests Description: Build the tests Default: False Library Exposed-Modules: Test.Framework Test.Framework.Options Test.Framework.Providers.API Test.Framework.Runners.Console Test.Framework.Runners.Options Test.Framework.Runners.TestPattern Test.Framework.Runners.API Test.Framework.Seed Other-Modules: Test.Framework.Core Test.Framework.Improving Test.Framework.Runners.Console.Colors Test.Framework.Runners.Console.ProgressBar Test.Framework.Runners.Console.Run Test.Framework.Runners.Console.Statistics Test.Framework.Runners.Console.Table Test.Framework.Runners.Console.Utilities Test.Framework.Runners.Core Test.Framework.Runners.Processors Test.Framework.Runners.Statistics Test.Framework.Runners.ThreadPool Test.Framework.Runners.TimedConsumption Test.Framework.Runners.XML.JUnitWriter Test.Framework.Runners.XML Test.Framework.Utilities Build-Depends: ansi-terminal >= 0.4.0, ansi-wl-pprint >= 0.5.1, base >= 4.3 && < 5, random >= 1.0, containers >= 0.1, regex-posix >= 0.72, old-locale >= 1.0, time >= 1.1.2 && < 1.6, xml >= 1.3.5, hostname >= 1.0 Extensions: CPP PatternGuards ExistentialQuantification RecursiveDo FlexibleInstances TypeSynonymInstances TypeOperators FunctionalDependencies MultiParamTypeClasses Ghc-Options: -Wall if impl(ghc) Cpp-Options: -DCOMPILER_GHC Executable test-framework-tests Main-Is: Test/Framework/Tests.hs if !flag(tests) Buildable: False else Build-Depends: HUnit >= 1.2, QuickCheck >= 2.3 && < 2.5, base >= 4.3 && < 5, random >= 1.0, containers >= 0.1, ansi-terminal >= 0.4.0, ansi-wl-pprint >= 0.5.1, regex-posix >= 0.72, old-locale >= 1.0, time >= 1.1.2, xml >= 1.3.5, hostname >= 1.0, libxml >= 0.1.1, bytestring >= 0.9 Extensions: CPP PatternGuards ExistentialQuantification RecursiveDo FlexibleInstances TypeSynonymInstances TypeOperators FunctionalDependencies MultiParamTypeClasses Cpp-Options: -DTEST Ghc-Options: -Wall -threaded if impl(ghc) Cpp-Options: -DCOMPILER_GHC Source-Repository head Type: git Location: https://github.com/haskell/test-framework test-framework-0.8.1.1/Test/0000755000000000000000000000000012453651525013746 5ustar0000000000000000test-framework-0.8.1.1/Test/Framework.hs0000644000000000000000000000131512453651525016237 0ustar0000000000000000-- | A generic test framework for all types of Haskell test. -- -- For an example of how to use test-framework, please see -- module Test.Framework ( module Test.Framework.Core, module Test.Framework.Options, module Test.Framework.Runners.Console, module Test.Framework.Runners.Options, module Test.Framework.Seed ) where import Test.Framework.Core (Test, TestName, testGroup, plusTestOptions, buildTest, buildTestBracketed, mutuallyExclusive) import Test.Framework.Options import Test.Framework.Runners.Console import Test.Framework.Runners.Options import Test.Framework.Seedtest-framework-0.8.1.1/Test/Framework/0000755000000000000000000000000012453651525015703 5ustar0000000000000000test-framework-0.8.1.1/Test/Framework/Core.hs0000644000000000000000000000703312453651525017132 0ustar0000000000000000{-# LANGUAGE UndecidableInstances, DeriveDataTypeable #-} module Test.Framework.Core where import Test.Framework.Improving import Test.Framework.Options import Control.Arrow (first, second) import Control.Concurrent.MVar import Data.Typeable -- | Something like the result of a test: works in concert with 'Testlike'. -- The type parameters are the type that is used for progress reports and the -- type of the final output of the test respectively. class (Show i, Show r) => TestResultlike i r | r -> i where testSucceeded :: r -> Bool -- | Something test-like in its behaviour. The type parameters are the type that -- is used for progress reports, the type of the final output of the test and the -- data type encapsulating the whole potential to do a test respectively. class TestResultlike i r => Testlike i r t | t -> i r, r -> i where runTest :: CompleteTestOptions -> t -> IO (i :~> r, IO ()) testTypeName :: t -> TestTypeName -- | Test names or descriptions. These are shown to the user type TestName = String -- | The name of a type of test, such as "Properties" or "Test Cases". Tests of -- types of the same names will be grouped together in the test run summary. type TestTypeName = String -- | Main test data type: builds up a list of tests to be run. Users should use the -- utility functions in e.g. the test-framework-hunit and test-framework-quickcheck -- packages to create instances of 'Test', and then build them up into testsuites -- by using 'testGroup' and lists. -- -- For an example of how to use test-framework, please see -- data Test = forall i r t. (Testlike i r t, Typeable t) => Test TestName t -- ^ A single test of some particular type | TestGroup TestName [Test] -- ^ Assemble a number of tests into a cohesive group | PlusTestOptions TestOptions Test -- ^ Add some options to child tests | BuildTestBracketed (IO (Test, IO ())) -- ^ Convenience for creating tests from an 'IO' action, with cleanup -- | Assemble a number of tests into a cohesive group testGroup :: TestName -> [Test] -> Test testGroup = TestGroup -- | Add some options to child tests plusTestOptions :: TestOptions -> Test -> Test plusTestOptions = PlusTestOptions -- | Convenience for creating tests from an 'IO' action buildTest :: IO Test -> Test buildTest mx = BuildTestBracketed (fmap (flip (,) (return ())) mx) -- | Convenience for creating tests from an 'IO' action, with a cleanup handler for when tests are finished buildTestBracketed :: IO (Test, IO ()) -> Test buildTestBracketed = BuildTestBracketed data MutuallyExcluded t = ME (MVar ()) t deriving Typeable -- This requires UndecidableInstances, but I think it can't be made inconsistent? instance Testlike i r t => Testlike i r (MutuallyExcluded t) where runTest cto (ME mvar x) = fmap (second (\act -> withMVar mvar $ \() -> act)) $ runTest cto x testTypeName ~(ME _ x) = testTypeName x -- | Mark all tests in this portion of the tree as mutually exclusive, so only one runs at a time {-# NOINLINE mutuallyExclusive #-} mutuallyExclusive :: Test -> Test mutuallyExclusive init_t = buildTest $ do mvar <- newMVar () let go (Test tn t) = Test tn (ME mvar t) go (TestGroup tn ts) = TestGroup tn (map go ts) go (PlusTestOptions to t) = PlusTestOptions to (go t) go (BuildTestBracketed build) = BuildTestBracketed (fmap (first go) build) return (go init_t) test-framework-0.8.1.1/Test/Framework/Improving.hs0000644000000000000000000000665012453651525020220 0ustar0000000000000000module Test.Framework.Improving ( (:~>)(..), bimapImproving, improvingLast, consumeImproving, ImprovingIO, yieldImprovement, runImprovingIO, tunnelImprovingIO, liftIO, timeoutImprovingIO, maybeTimeoutImprovingIO ) where import Control.Concurrent import Control.Monad import Control.Applicative import System.Timeout data i :~> f = Finished f | Improving i (i :~> f) instance Functor ((:~>) i) where fmap f (Finished x) = Finished (f x) fmap f (Improving x i) = Improving x (fmap f i) bimapImproving :: (a -> c) -> (b -> d) -> (a :~> b) -> (c :~> d) bimapImproving _ g (Finished b) = Finished (g b) bimapImproving f g (Improving a improving) = Improving (f a) (bimapImproving f g improving) improvingLast :: (a :~> b) -> b improvingLast (Finished r) = r improvingLast (Improving _ rest) = improvingLast rest consumeImproving :: (a :~> b) -> [(a :~> b)] consumeImproving improving@(Finished _) = [improving] consumeImproving improving@(Improving _ rest) = improving : consumeImproving rest newtype ImprovingIO i f a = IIO { unIIO :: Chan (Either i f) -> IO a } instance Functor (ImprovingIO i f) where fmap = liftM instance Applicative (ImprovingIO i f) where pure = return (<*>) = ap instance Monad (ImprovingIO i f) where return x = IIO (const $ return x) ma >>= f = IIO $ \chan -> do a <- unIIO ma chan unIIO (f a) chan yieldImprovement :: i -> ImprovingIO i f () yieldImprovement improvement = IIO $ \chan -> do -- Whenever we yield an improvement, take the opportunity to yield the thread as well. -- The idea here is to introduce frequent yields in users so that if e.g. they get killed -- by the timeout code then they know about it reasonably promptly. yield writeChan chan (Left improvement) -- NB: could have a more general type but it would be impredicative tunnelImprovingIO :: ImprovingIO i f (ImprovingIO i f a -> IO a) tunnelImprovingIO = IIO $ \chan -> return $ \iio -> unIIO iio chan runImprovingIO :: ImprovingIO i f f -> IO (i :~> f, IO ()) runImprovingIO iio = do chan <- newChan let action = do result <- unIIO iio chan writeChan chan (Right result) improving_value <- getChanContents chan return (reifyListToImproving improving_value, action) reifyListToImproving :: [Either i f] -> (i :~> f) reifyListToImproving (Left improvement:rest) = Improving improvement (reifyListToImproving rest) reifyListToImproving (Right final:_) = Finished final reifyListToImproving [] = error "reifyListToImproving: list finished before a final value arrived" liftIO :: IO a -> ImprovingIO i f a liftIO io = IIO $ const io -- | Given a number of microseconds and an improving IO action, run that improving IO action only -- for at most the given period before giving up. See also 'System.Timeout.timeout'. timeoutImprovingIO :: Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a) timeoutImprovingIO microseconds iio = IIO $ \chan -> timeout microseconds $ unIIO iio chan -- | As 'timeoutImprovingIO', but don't bother applying a timeout to the action if @Nothing@ is given -- as the number of microseconds to apply the time out for. maybeTimeoutImprovingIO :: Maybe Int -> ImprovingIO i f a -> ImprovingIO i f (Maybe a) maybeTimeoutImprovingIO Nothing = fmap Just maybeTimeoutImprovingIO (Just microseconds) = timeoutImprovingIO microseconds test-framework-0.8.1.1/Test/Framework/Options.hs0000644000000000000000000000375712453651525017706 0ustar0000000000000000module Test.Framework.Options where import Test.Framework.Seed import Test.Framework.Utilities import Data.Monoid type TestOptions = TestOptions' Maybe type CompleteTestOptions = TestOptions' K data TestOptions' f = TestOptions { topt_seed :: f Seed, -- ^ Seed that should be used to create random numbers for generated tests topt_maximum_generated_tests :: f Int, -- ^ Maximum number of tests to generate when using something like QuickCheck topt_maximum_unsuitable_generated_tests :: f Int, -- ^ Maximum number of unsuitable tests to consider before giving up when using something like QuickCheck topt_maximum_test_size :: f Int, -- ^ Maximum size of generated tests when using something like QuickCheck topt_maximum_test_depth :: f Int, -- ^ Maximum depth of generated tests when using something like SmallCheck topt_timeout :: f (Maybe Int) -- ^ The number of microseconds to run tests for before considering them a failure } instance Monoid (TestOptions' Maybe) where mempty = TestOptions { topt_seed = Nothing, topt_maximum_generated_tests = Nothing, topt_maximum_unsuitable_generated_tests = Nothing, topt_maximum_test_size = Nothing, topt_maximum_test_depth = Nothing, topt_timeout = Nothing } mappend to1 to2 = TestOptions { topt_seed = getLast (mappendBy (Last . topt_seed) to1 to2), topt_maximum_generated_tests = getLast (mappendBy (Last . topt_maximum_generated_tests) to1 to2), topt_maximum_unsuitable_generated_tests = getLast (mappendBy (Last . topt_maximum_unsuitable_generated_tests) to1 to2), topt_maximum_test_size = getLast (mappendBy (Last . topt_maximum_test_size) to1 to2), topt_maximum_test_depth = getLast (mappendBy (Last . topt_maximum_test_depth) to1 to2), topt_timeout = getLast (mappendBy (Last . topt_timeout) to1 to2) } test-framework-0.8.1.1/Test/Framework/Seed.hs0000644000000000000000000000171612453651525017124 0ustar0000000000000000module Test.Framework.Seed where import Test.Framework.Utilities import System.Random import Data.Char data Seed = FixedSeed Int | RandomSeed instance Show Seed where show RandomSeed = "random" show (FixedSeed n) = show n instance Read Seed where readsPrec prec xs = if map toLower random_prefix == "random" then [(RandomSeed, rest)] else map (FixedSeed `onLeft`) (readsPrec prec xs) where (random_prefix, rest) = splitAt 6 xs -- | Given a 'Seed', returns a new random number generator based on that seed and the -- actual numeric seed that was used to build that generator, so it can be recreated. newSeededStdGen :: Seed -> IO (StdGen, Int) newSeededStdGen (FixedSeed seed) = return $ (mkStdGen seed, seed) newSeededStdGen RandomSeed = newStdGenWithKnownSeed newStdGenWithKnownSeed :: IO (StdGen, Int) newStdGenWithKnownSeed = do seed <- randomIO return (mkStdGen seed, seed) test-framework-0.8.1.1/Test/Framework/Tests.hs0000644000000000000000000000057212453651525017345 0ustar0000000000000000module Main where import qualified Test.Framework.Tests.Runners.ThreadPool as TP import qualified Test.Framework.Tests.Runners.XMLTests as XT import Test.HUnit import Test.QuickCheck -- I wish I could use my test framework to test my framework... main :: IO () main = do _ <- runTestTT $ TestList [ TestList TP.tests, XT.test ] quickCheck XT.property test-framework-0.8.1.1/Test/Framework/Utilities.hs0000644000000000000000000000277212453651525020222 0ustar0000000000000000module Test.Framework.Utilities where import Control.Arrow (first, second) import Data.Function (on) import Data.Maybe import Data.Monoid import Data.List (intercalate) newtype K a = K { unK :: a } secondsToMicroseconds :: Num a => a -> a secondsToMicroseconds = (1000000*) microsecondsToPicoseconds :: Num a => a -> a microsecondsToPicoseconds = (1000000*) listToMaybeLast :: [a] -> Maybe a listToMaybeLast = listToMaybe . reverse mappendBy :: Monoid b => (a -> b) -> a -> a -> b mappendBy f = mappend `on` f orElse :: Maybe a -> a -> a orElse = flip fromMaybe onLeft :: (a -> c) -> (a, b) -> (c, b) onLeft = first onRight :: (b -> c) -> (a, b) -> (a, c) onRight = second -- | Like 'unlines', but does not append a trailing newline if there -- is at least one line. For example: -- -- > unlinesConcise ["A", "B"] == "A\nB" -- > unlinesConcise [] == "" -- -- Whereas: -- -- > unlines ["A", "B"] == "A\nB\n" -- > unlines [] == "" -- -- This is closer to the behaviour of 'unwords', which does not append -- a trailing space. unlinesConcise :: [String] -> String unlinesConcise = intercalate "\n" mapAccumLM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y]) mapAccumLM _ acc [] = return (acc, []) mapAccumLM f acc (x:xs) = do (acc', y) <- f acc x (acc'', ys) <- mapAccumLM f acc' xs return (acc'', y:ys) padRight :: Int -> String -> String padRight desired_length s = s ++ replicate (desired_length - length s) ' ' dropLast :: Int -> [a] -> [a] dropLast n = reverse . drop n . reversetest-framework-0.8.1.1/Test/Framework/Providers/0000755000000000000000000000000012453651525017660 5ustar0000000000000000test-framework-0.8.1.1/Test/Framework/Providers/API.hs0000644000000000000000000000133412453651525020626 0ustar0000000000000000-- | This module exports everything that you need to be able to create your own framework test provider. -- To create a provider you need to: -- -- * Create an instance of the 'Testlike' class -- -- * Create an instance of the 'TestResultlike' class -- -- * Expose a function that lets people construct 'Test' values using your new instances module Test.Framework.Providers.API ( module Test.Framework.Core, module Test.Framework.Improving, module Test.Framework.Options, module Test.Framework.Seed, module Test.Framework.Utilities ) where import Test.Framework.Core import Test.Framework.Improving import Test.Framework.Options import Test.Framework.Seed import Test.Framework.Utilitiestest-framework-0.8.1.1/Test/Framework/Runners/0000755000000000000000000000000012453651525017337 5ustar0000000000000000test-framework-0.8.1.1/Test/Framework/Runners/API.hs0000644000000000000000000000045212453651525020305 0ustar0000000000000000-- | This module exports everything that you need to be able to create your own test runner. module Test.Framework.Runners.API ( module Test.Framework.Runners.Options, TestRunner(..), runTestTree ) where import Test.Framework.Runners.Options import Test.Framework.Runners.Core test-framework-0.8.1.1/Test/Framework/Runners/Console.hs0000644000000000000000000002143312453651525021300 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Framework.Runners.Console ( defaultMain, defaultMainWithArgs, defaultMainWithOpts, SuppliedRunnerOptions, optionsDescription, interpretArgs, interpretArgsOrExit ) where import Test.Framework.Core import Test.Framework.Options import Test.Framework.Runners.Console.Run import Test.Framework.Runners.Core import Test.Framework.Runners.Options import Test.Framework.Runners.Processors import Test.Framework.Runners.Statistics import qualified Test.Framework.Runners.XML as XML import Test.Framework.Seed import Test.Framework.Utilities import Control.Monad (when) import System.Console.GetOpt import System.Environment import System.Exit import System.IO import Data.Monoid #if !MIN_VERSION_base(4,7,0) instance Functor OptDescr where fmap f (Option a b arg_descr c) = Option a b (fmap f arg_descr) c instance Functor ArgDescr where fmap f (NoArg a) = NoArg (f a) fmap f (ReqArg g s) = ReqArg (f . g) s fmap f (OptArg g s) = OptArg (f . g) s #endif -- | @Nothing@ signifies that usage information should be displayed. -- @Just@ simply gives us the contribution to overall options by the command line option. type SuppliedRunnerOptions = Maybe RunnerOptions -- | Options understood by test-framework. This can be used to add more -- options to the tester executable. optionsDescription :: [OptDescr SuppliedRunnerOptions] optionsDescription = [ Option [] ["help"] (NoArg Nothing) "show this help message" ] ++ map (fmap Just) [ Option ['j'] ["threads"] (ReqArg (\t -> mempty { ropt_threads = Just (read t) }) "NUMBER") "number of threads to use to run tests", Option [] ["test-seed"] (ReqArg (\t -> mempty { ropt_test_options = Just (mempty { topt_seed = Just (read t) }) }) ("NUMBER|" ++ show RandomSeed)) "default seed for test random number generator", Option ['a'] ["maximum-generated-tests"] (ReqArg (\t -> mempty { ropt_test_options = Just (mempty { topt_maximum_generated_tests = Just (read t) }) }) "NUMBER") "how many automated tests something like QuickCheck should try, by default", Option [] ["maximum-unsuitable-generated-tests"] (ReqArg (\t -> mempty { ropt_test_options = Just (mempty { topt_maximum_unsuitable_generated_tests = Just (read t) }) }) "NUMBER") "how many unsuitable candidate tests something like QuickCheck should endure before giving up, by default", Option ['s'] ["maximum-test-size"] (ReqArg (\t -> mempty {ropt_test_options = Just (mempty { topt_maximum_test_size = Just (read t) }) }) "NUMBER") "to what size something like QuickCheck should test the properties, by default", Option ['d'] ["maximum-test-depth"] (ReqArg (\t -> mempty { ropt_test_options = Just (mempty { topt_maximum_test_depth = Just (read t) }) }) "NUMBER") "to what depth something like SmallCheck should test the properties, by default", Option ['o'] ["timeout"] (ReqArg (\t -> mempty { ropt_test_options = Just (mempty { topt_timeout = Just (Just (secondsToMicroseconds (read t))) }) }) "NUMBER") "how many seconds a test should be run for before giving up, by default", Option [] ["no-timeout"] (NoArg (mempty { ropt_test_options = Just (mempty { topt_timeout = Just Nothing }) })) "specifies that tests should be run without a timeout, by default", Option ['l'] ["list-tests"] (NoArg (mempty { ropt_list_only = Just True })) "list available tests but don't run any; useful to guide subsequent --select-tests", Option ['t'] ["select-tests"] (ReqArg (\t -> mempty { ropt_test_patterns = Just [read t] }) "TEST-PATTERN") "only tests that match at least one glob pattern given by an instance of this argument will be run", Option [] ["jxml"] (ReqArg (\t -> mempty { ropt_xml_output = Just (Just t) }) "FILE") "write a JUnit XML summary of the output to FILE", Option [] ["jxml-nested"] (NoArg (mempty { ropt_xml_nested = Just True })) "use nested testsuites to represent groups in JUnit XML (not standards compliant)", Option [] ["plain"] (NoArg (mempty { ropt_color_mode = Just ColorNever })) "do not use any ANSI terminal features to display the test run", Option [] ["color"] (NoArg (mempty { ropt_color_mode = Just ColorAlways })) "use ANSI terminal features to display the test run", Option [] ["hide-successes"] (NoArg (mempty { ropt_hide_successes = Just True })) "hide sucessful tests, and only show failures" ] -- | Parse the specified command line arguments into a 'RunnerOptions' and some remaining arguments, -- or return a reason as to why we can't. interpretArgs :: [String] -> IO (Either String (RunnerOptions, [String])) interpretArgs args = do prog_name <- getProgName let usage_header = "Usage: " ++ prog_name ++ " [OPTIONS]" case getOpt Permute optionsDescription args of (oas, n, []) | Just os <- sequence oas -> return $ Right (mconcat os, n) (_, _, errs) -> return $ Left (concat errs ++ usageInfo usage_header optionsDescription) -- | A version of 'interpretArgs' that ends the process if it fails. interpretArgsOrExit :: [String] -> IO RunnerOptions interpretArgsOrExit args = do interpreted_args <- interpretArgs args case interpreted_args of Right (ropts, []) -> return ropts Right (_, leftovers) -> do hPutStrLn stderr $ "Could not understand these extra arguments: " ++ unwords leftovers exitWith (ExitFailure 1) Left error_message -> do hPutStrLn stderr error_message exitWith (ExitFailure 1) defaultMain :: [Test] -> IO () defaultMain tests = do args <- getArgs defaultMainWithArgs tests args -- | A version of 'defaultMain' that lets you ignore the command line arguments -- in favour of another list of 'String's. defaultMainWithArgs :: [Test] -> [String] -> IO () defaultMainWithArgs tests args = do ropts <- interpretArgsOrExit args defaultMainWithOpts tests ropts -- | A version of 'defaultMain' that lets you ignore the command line arguments -- in favour of an explicit set of 'RunnerOptions'. defaultMainWithOpts :: [Test] -> RunnerOptions -> IO () defaultMainWithOpts tests ropts = do let ropts' = completeRunnerOptions ropts when (unK$ ropt_list_only ropts') $ do putStr $ listTests tests exitSuccess -- Get a lazy list of the test results, as executed in parallel running_tests <- runTests ropts' tests isplain <- case unK $ ropt_color_mode ropts' of ColorAuto -> not `fmap` hIsTerminalDevice stdout ColorNever -> return True ColorAlways -> return False -- Show those test results to the user as we get them fin_tests <- showRunTestsTop isplain (unK $ ropt_hide_successes ropts') running_tests let test_statistics' = gatherStatistics fin_tests -- Output XML report (if requested) case ropt_xml_output ropts' of K (Just file) -> XML.produceReport (unK (ropt_xml_nested ropts')) test_statistics' fin_tests >>= writeFile file _ -> return () -- Set the error code depending on whether the tests succeded or not exitWith $ if ts_no_failures test_statistics' then ExitSuccess else ExitFailure 1 -- | Print out a list of available tests. listTests :: [Test] -> String listTests tests = "\ntest-framework: All available tests:\n"++ "====================================\n"++ concat (map (++"\n") (concatMap (showTest "") tests)) where showTest :: String -> Test -> [String] showTest path (Test name _testlike) = [" "++path ++ name] showTest path (TestGroup name gtests) = concatMap (showTest (path++":"++name)) gtests showTest path (PlusTestOptions _ test) = showTest path test showTest path (BuildTestBracketed _) = [" "++path ++ ""] completeRunnerOptions :: RunnerOptions -> CompleteRunnerOptions completeRunnerOptions ro = RunnerOptions { ropt_threads = K $ ropt_threads ro `orElse` processorCount, ropt_test_options = K $ ropt_test_options ro `orElse` mempty, ropt_test_patterns = K $ ropt_test_patterns ro `orElse` mempty, ropt_xml_output = K $ ropt_xml_output ro `orElse` Nothing, ropt_xml_nested = K $ ropt_xml_nested ro `orElse` False, ropt_color_mode = K $ ropt_color_mode ro `orElse` ColorAuto, ropt_hide_successes = K $ ropt_hide_successes ro `orElse` False, ropt_list_only = K $ ropt_list_only ro `orElse` False } test-framework-0.8.1.1/Test/Framework/Runners/Core.hs0000644000000000000000000001233112453651525020563 0ustar0000000000000000module Test.Framework.Runners.Core ( RunTest(..), RunningTest, SomeImproving(..), FinishedTest, runTests, TestRunner(..), runTestTree ) where import Test.Framework.Core import Test.Framework.Improving import Test.Framework.Options import Test.Framework.Runners.Options import Test.Framework.Runners.TestPattern import Test.Framework.Runners.ThreadPool import Test.Framework.Seed import Test.Framework.Utilities import Control.Concurrent.MVar import Control.Exception (mask, finally, onException) import Control.Monad import Data.Maybe import Data.Monoid import Data.Typeable -- | A test that has been executed or is in the process of execution data RunTest a = RunTest TestName TestTypeName a | RunTestGroup TestName [RunTest a] deriving (Show) data SomeImproving = forall i r. TestResultlike i r => SomeImproving (i :~> r) type RunningTest = RunTest SomeImproving type FinishedTest = RunTest (String, Bool) runTests :: CompleteRunnerOptions -- ^ Top-level runner options -> [Test] -- ^ Tests to run -> IO [RunningTest] runTests ropts tests = do let test_patterns = unK $ ropt_test_patterns ropts test_options = unK $ ropt_test_options ropts (run_tests, actions) <- runTests' $ map (runTestTree test_options test_patterns) tests _ <- executeOnPool (unK $ ropt_threads ropts) actions return run_tests -- | 'TestRunner' class simplifies folding a 'Test'. You need to specify -- the important semantic actions by instantiating this class, and -- 'runTestTree' will take care of recursion and test filtering. class TestRunner b where -- | How to handle a single test runSimpleTest :: (Testlike i r t, Typeable t) => TestOptions -> TestName -> t -> b -- | How to skip a test that doesn't satisfy the pattern skipTest :: b -- | How to handle an IO test (created with 'buildTestBracketed') runIOTest :: IO (b, IO ()) -> b -- | How to run a test group runGroup :: TestName -> [b] -> b -- | Run the test tree using a 'TestRunner' runTestTree :: TestRunner b => TestOptions -> [TestPattern] -- ^ skip the tests that do not match any of these patterns, unless -- the list is empty -> Test -> b runTestTree initialOpts pats topTest = go initialOpts [] topTest where go opts path t = case t of Test name testlike -> if null pats || any (`testPatternMatches` (path ++ [name])) pats then runSimpleTest opts name testlike else skipTest TestGroup name tests -> let path' = path ++ [name] in runGroup name $ map (go opts path') tests PlusTestOptions extra_topts test -> go (opts `mappend` extra_topts) path test BuildTestBracketed build -> runIOTest $ onLeft (go opts path) `fmap` build newtype StdRunner = StdRunner { run :: IO (Maybe (RunningTest, [IO ()])) } instance TestRunner StdRunner where runSimpleTest topts name testlike = StdRunner $ do (result, action) <- runTest (completeTestOptions topts) testlike return (Just (RunTest name (testTypeName testlike) (SomeImproving result), [action])) skipTest = StdRunner $ return Nothing runGroup name tests = StdRunner $ do (results, actions) <- runTests' tests return $ if null results then Nothing else Just ((RunTestGroup name results), actions) runIOTest ioTest = StdRunner $ mask $ \restore -> ioTest >>= \(StdRunner test, cleanup) -> do mb_res <- restore test `onException` cleanup case mb_res of -- No sub-tests: perform the cleanup NOW Nothing -> cleanup >> return Nothing Just (run_test, actions) -> do -- Sub-tests: perform the cleanup as soon as each of them have completed (mvars, actions') <- liftM unzip $ forM actions $ \action -> do mvar <- newEmptyMVar return (mvar, action `finally` putMVar mvar ()) -- NB: the takeMVar action MUST be last in the list because the returned actions are -- scheduled left-to-right, and we want all the actions we depend on to be scheduled -- before we wait for them to complete, or we might deadlock. -- -- FIXME: this is a bit of a hack because it uses one pool thread just waiting -- for some other pool threads to complete! Switch to parallel-io? return $ Just (run_test, actions' ++ [(cleanup >> mapM_ takeMVar mvars)]) runTests' :: [StdRunner] -> IO ([RunningTest], [IO ()]) runTests' = fmap (onRight concat . unzip . catMaybes) . mapM run completeTestOptions :: TestOptions -> CompleteTestOptions completeTestOptions to = TestOptions { topt_seed = K $ topt_seed to `orElse` RandomSeed, topt_maximum_generated_tests = K $ topt_maximum_generated_tests to `orElse` 100, topt_maximum_unsuitable_generated_tests = K $ topt_maximum_unsuitable_generated_tests to `orElse` 1000, topt_maximum_test_size = K $ topt_maximum_test_size to `orElse` 100, topt_maximum_test_depth = K $ topt_maximum_test_depth to `orElse` 5, topt_timeout = K $ topt_timeout to `orElse` Nothing } test-framework-0.8.1.1/Test/Framework/Runners/Options.hs0000644000000000000000000000346012453651525021331 0ustar0000000000000000module Test.Framework.Runners.Options ( module Test.Framework.Runners.Options, TestPattern ) where import Test.Framework.Options import Test.Framework.Utilities import Test.Framework.Runners.TestPattern import Data.Monoid data ColorMode = ColorAuto | ColorNever | ColorAlways type RunnerOptions = RunnerOptions' Maybe type CompleteRunnerOptions = RunnerOptions' K data RunnerOptions' f = RunnerOptions { ropt_threads :: f Int, ropt_test_options :: f TestOptions, ropt_test_patterns :: f [TestPattern], ropt_xml_output :: f (Maybe FilePath), ropt_xml_nested :: f Bool, ropt_color_mode :: f ColorMode, ropt_hide_successes :: f Bool, ropt_list_only :: f Bool } instance Monoid (RunnerOptions' Maybe) where mempty = RunnerOptions { ropt_threads = Nothing, ropt_test_options = Nothing, ropt_test_patterns = Nothing, ropt_xml_output = Nothing, ropt_xml_nested = Nothing, ropt_color_mode = Nothing, ropt_hide_successes = Nothing, ropt_list_only = Nothing } mappend ro1 ro2 = RunnerOptions { ropt_threads = getLast (mappendBy (Last . ropt_threads) ro1 ro2), ropt_test_options = mappendBy ropt_test_options ro1 ro2, ropt_test_patterns = mappendBy ropt_test_patterns ro1 ro2, ropt_xml_output = mappendBy ropt_xml_output ro1 ro2, ropt_xml_nested = getLast (mappendBy (Last . ropt_xml_nested) ro1 ro2), ropt_color_mode = getLast (mappendBy (Last . ropt_color_mode) ro1 ro2), ropt_hide_successes = getLast (mappendBy (Last . ropt_hide_successes) ro1 ro2), ropt_list_only = getLast (mappendBy (Last . ropt_list_only) ro1 ro2) } test-framework-0.8.1.1/Test/Framework/Runners/Processors.hs0000644000000000000000000000037012453651525022035 0ustar0000000000000000module Test.Framework.Runners.Processors ( processorCount ) where #ifdef COMPILER_GHC import GHC.Conc ( numCapabilities ) processorCount :: Int processorCount = numCapabilities #else processorCount :: Int processorCount = 1 #endiftest-framework-0.8.1.1/Test/Framework/Runners/Statistics.hs0000644000000000000000000001000212453651525022016 0ustar0000000000000000module Test.Framework.Runners.Statistics ( TestCount, testCountTestTypes, testCountForType, adjustTestCount, testCountTotal, TestStatistics(..), ts_pending_tests, ts_no_failures, initialTestStatistics, updateTestStatistics, totalRunTestsList, gatherStatistics ) where import Test.Framework.Core (TestTypeName) import Test.Framework.Runners.Core import Data.Map (Map) import qualified Data.Map as Map import Data.Monoid -- | Records a count of the various kinds of test that have been run newtype TestCount = TestCount { unTestCount :: Map TestTypeName Int } testCountTestTypes :: TestCount -> [TestTypeName] testCountTestTypes = Map.keys . unTestCount testCountForType :: String -> TestCount -> Int testCountForType test_type = Map.findWithDefault 0 test_type . unTestCount adjustTestCount :: String -> Int -> TestCount -> TestCount adjustTestCount test_type amount = TestCount . Map.insertWith (+) test_type amount . unTestCount -- | The number of tests of all kinds recorded in the given 'TestCount' testCountTotal :: TestCount -> Int testCountTotal = sum . Map.elems . unTestCount instance Monoid TestCount where mempty = TestCount $ Map.empty mappend (TestCount tcm1) (TestCount tcm2) = TestCount $ Map.unionWith (+) tcm1 tcm2 minusTestCount :: TestCount -> TestCount -> TestCount minusTestCount (TestCount tcm1) (TestCount tcm2) = TestCount $ Map.unionWith (-) tcm1 tcm2 -- | Records information about the run of a number of tests, such -- as how many tests have been run, how many are pending and how -- many have passed or failed. data TestStatistics = TestStatistics { ts_total_tests :: TestCount, ts_run_tests :: TestCount, ts_passed_tests :: TestCount, ts_failed_tests :: TestCount } instance Monoid TestStatistics where mempty = TestStatistics mempty mempty mempty mempty mappend (TestStatistics tot1 run1 pas1 fai1) (TestStatistics tot2 run2 pas2 fai2) = TestStatistics (tot1 `mappend` tot2) (run1 `mappend` run2) (pas1 `mappend` pas2) (fai1 `mappend` fai2) ts_pending_tests :: TestStatistics -> TestCount ts_pending_tests ts = ts_total_tests ts `minusTestCount` ts_run_tests ts ts_no_failures :: TestStatistics -> Bool ts_no_failures ts = testCountTotal (ts_failed_tests ts) <= 0 -- | Create some test statistics that simply records the total number of -- tests to be run, ready to be updated by the actual test runs. initialTestStatistics :: TestCount -> TestStatistics initialTestStatistics total_tests = TestStatistics { ts_total_tests = total_tests, ts_run_tests = mempty, ts_passed_tests = mempty, ts_failed_tests = mempty } updateTestStatistics :: (Int -> TestCount) -> Bool -> TestStatistics -> TestStatistics updateTestStatistics count_constructor test_suceeded test_statistics = test_statistics { ts_run_tests = ts_run_tests test_statistics `mappend` (count_constructor 1), ts_failed_tests = ts_failed_tests test_statistics `mappend` (count_constructor (if test_suceeded then 0 else 1)), ts_passed_tests = ts_passed_tests test_statistics `mappend` (count_constructor (if test_suceeded then 1 else 0)) } totalRunTests :: RunTest a -> TestCount totalRunTests (RunTest _ test_type _) = adjustTestCount test_type 1 mempty totalRunTests (RunTestGroup _ tests) = totalRunTestsList tests totalRunTestsList :: [RunTest a] -> TestCount totalRunTestsList = mconcat . map totalRunTests gatherStatistics :: [FinishedTest] -> TestStatistics gatherStatistics = mconcat . map f where f (RunTest _ test_type (_, success)) = singleTestStatistics test_type success f (RunTestGroup _ tests) = gatherStatistics tests singleTestStatistics :: String -> Bool -> TestStatistics singleTestStatistics test_type success = TestStatistics { ts_total_tests = one, ts_run_tests = one, ts_passed_tests = if success then one else mempty, ts_failed_tests = if success then mempty else one } where one = adjustTestCount test_type 1 mempty test-framework-0.8.1.1/Test/Framework/Runners/TestPattern.hs0000644000000000000000000000611312453651525022151 0ustar0000000000000000module Test.Framework.Runners.TestPattern ( TestPattern, parseTestPattern, testPatternMatches ) where import Test.Framework.Utilities import Text.Regex.Posix.Wrap import Text.Regex.Posix.String() import Data.List data Token = SlashToken | WildcardToken | DoubleWildcardToken | LiteralToken Char deriving (Eq) tokenize :: String -> [Token] tokenize ('/':rest) = SlashToken : tokenize rest tokenize ('*':'*':rest) = DoubleWildcardToken : tokenize rest tokenize ('*':rest) = WildcardToken : tokenize rest tokenize (c:rest) = LiteralToken c : tokenize rest tokenize [] = [] data TestPatternMatchMode = TestMatchMode | PathMatchMode data TestPattern = TestPattern { tp_categories_only :: Bool, tp_negated :: Bool, tp_match_mode :: TestPatternMatchMode, tp_tokens :: [Token] } instance Read TestPattern where readsPrec _ string = [(parseTestPattern string, "")] parseTestPattern :: String -> TestPattern parseTestPattern string = TestPattern { tp_categories_only = categories_only, tp_negated = negated, tp_match_mode = match_mode, tp_tokens = tokens'' } where tokens = tokenize string (negated, tokens') | (LiteralToken '!'):rest <- tokens = (True, rest) | otherwise = (False, tokens) (categories_only, tokens'') | (prefix, [SlashToken]) <- splitAt (length tokens' - 1) tokens' = (True, prefix) | otherwise = (False, tokens') match_mode | SlashToken `elem` tokens = PathMatchMode | otherwise = TestMatchMode testPatternMatches :: TestPattern -> [String] -> Bool testPatternMatches test_pattern path = not_maybe $ any (=~ tokens_regex) things_to_match where not_maybe | tp_negated test_pattern = not | otherwise = id path_to_consider | tp_categories_only test_pattern = dropLast 1 path | otherwise = path tokens_regex = buildTokenRegex (tp_tokens test_pattern) things_to_match = case tp_match_mode test_pattern of -- See if the tokens match any single path component TestMatchMode -> path_to_consider -- See if the tokens match any prefix of the path PathMatchMode -> map pathToString $ inits path_to_consider buildTokenRegex :: [Token] -> String buildTokenRegex [] = [] buildTokenRegex (token:tokens) = concat (firstTokenToRegex token : map tokenToRegex tokens) where firstTokenToRegex SlashToken = "^" firstTokenToRegex other = tokenToRegex other tokenToRegex SlashToken = "/" tokenToRegex WildcardToken = "[^/]*" tokenToRegex DoubleWildcardToken = "*" tokenToRegex (LiteralToken lit) = regexEscapeChar lit regexEscapeChar :: Char -> String regexEscapeChar c | c `elem` "\\*+?|{}[]()^$." = '\\' : [c] | otherwise = [c] pathToString :: [String] -> String pathToString path = "/" ++ concat (intersperse "/" path)test-framework-0.8.1.1/Test/Framework/Runners/ThreadPool.hs0000644000000000000000000001357412453651525021746 0ustar0000000000000000module Test.Framework.Runners.ThreadPool ( executeOnPool ) where import Control.Concurrent import Control.Monad import qualified Data.IntMap as IM import Foreign.StablePtr data WorkerEvent token a = WorkerTermination | WorkerItem token a -- | Execute IO actions on several threads and return their results in the original -- order. It is guaranteed that no action from the input list is executed unless all -- the items that precede it in the list have been executed or are executing at that -- moment. executeOnPool :: Int -- ^ Number of threads to use -> [IO a] -- ^ Actions to execute: these will be scheduled left to right -> IO [a] -- ^ Ordered results of executing the given IO actions in parallel executeOnPool n actions = do -- Prepare the channels input_chan <- newChan output_chan <- newChan -- Write the actions as items to the channel followed by one termination per thread -- that indicates they should terminate. We do this on another thread for -- maximum laziness (in case one the actions we are going to run depend on the -- output from previous actions..) _ <- forkIO $ writeList2Chan input_chan (zipWith WorkerItem [0..] actions ++ replicate n WorkerTermination) -- Spawn workers forM_ [1..n] (const $ forkIO $ poolWorker input_chan output_chan) -- Short version: make sure we do the right thing if a test blocks on dead -- MVars or TVars. -- Long version: GHC is clever enough to throw an exception (BlockedOnDeadMVar -- or BlockedIndefinitely) when a thread is waiting for a MVar or TVar that can't -- be written to. However, it doesn't know anything about the handlers for those -- exceptions. Therefore, when a worker runs a test that causes this exception, -- since the main thread is blocking on the worker, the main thread gets the -- exception too despite the fact that the main thread will be runnable as soon -- as the worker catches its own exception. The below makes sure the main thread -- is always reachable by the GC, which is the mechanism for finding threads -- that are unrunnable. -- See also the ticket where SimonM (semi-cryptically) explains this: -- http://hackage.haskell.org/trac/ghc/ticket/3291 -- -- NB: this actually leaks stable pointers. We could prevent this by making -- takeWhileWorkersExist do |unsafePerformIO newStablePtr| when returning the -- lazily-demanded tail of the list, but its a bit of a pain. For now, just -- grit our teeth and accept the leak. _stablePtr <- myThreadId >>= newStablePtr -- Return the results generated by the worker threads lazily and in -- the same order as we got the inputs fmap (reorderFrom 0 . takeWhileWorkersExist n) $ getChanContents output_chan poolWorker :: Chan (WorkerEvent token (IO a)) -> Chan (WorkerEvent token a) -> IO () poolWorker input_chan output_chan = do -- Read an action and work out whether we should continue or stop action_item <- readChan input_chan case action_item of WorkerTermination -> writeChan output_chan WorkerTermination -- Must have run out of real actions to execute WorkerItem token action -> do -- Do the action then loop result <- action writeChan output_chan (WorkerItem token result) poolWorker input_chan output_chan -- | Keep grabbing items out of the infinite list of worker outputs until we have -- recieved word that all of the workers have shut down. This lets us turn a possibly -- infinite list of outputs into a certainly finite one suitable for use with reorderFrom. takeWhileWorkersExist :: Int -> [WorkerEvent token a] -> [(token, a)] takeWhileWorkersExist worker_count events | worker_count <= 0 = [] | otherwise = case events of (WorkerTermination:events') -> takeWhileWorkersExist (worker_count - 1) events' (WorkerItem token x:events') -> (token, x) : takeWhileWorkersExist worker_count events' [] -> [] -- | This function carefully shuffles the input list so it in the total order -- defined by the integers paired with the elements. If the list is @xs@ and -- the supplied initial integer is @n@, it must be the case that: -- -- > sort (map fst xs) == [n..n + (length xs - 1)] -- -- This function returns items in the lazy result list as soon as it is sure -- it has the right item for that position. reorderFrom :: Int -> [(Int, a)] -> [a] reorderFrom from initial_things = go from initial_things IM.empty False where go next [] buf _ | IM.null buf = [] -- If the buffer and input list is empty, we're done | otherwise = go next (IM.toList buf) IM.empty False -- Make sure we check the buffer even if the list is done go next all_things@((token, x):things) buf buf_useful | token == next -- If the list token matches the one we were expecting we can just take the item = x : go (next + 1) things buf True -- Always worth checking the buffer now because the expected item has changed | buf_useful -- If it's worth checking the buffer, it's possible the token we need is in it , (Just x', buf') <- IM.updateLookupWithKey (const $ const Nothing) next buf -- Delete the found item from the map (if we find it) to save space = x' : go (next + 1) all_things buf' True -- Always worth checking the buffer now because the expected item has changed | otherwise -- Token didn't match, buffer unhelpful: it must be in the tail of the list = go next things (IM.insert token x buf) False -- Since we've already checked the buffer, stop bothering to do so until something changes -}test-framework-0.8.1.1/Test/Framework/Runners/TimedConsumption.hs0000644000000000000000000000217112453651525023175 0ustar0000000000000000module Test.Framework.Runners.TimedConsumption ( consumeListInInterval ) where import Test.Framework.Utilities import System.CPUTime -- | Evaluates the given list for the given number of microseconds. After the time limit -- has been reached, a list is returned consisting of the prefix of the list that was -- successfully evaluated within the time limit. -- -- This function does /not/ evaluate the elements of the list: it just ensures that the -- list spine arrives in good order. -- -- The spine of the list is evaluated on the current thread, so if spine evaluation blocks -- this function will also block, potentially for longer than the specificed delay. consumeListInInterval :: Int -> [a] -> IO [a] consumeListInInterval delay list = do initial_time_ps <- getCPUTime go initial_time_ps (microsecondsToPicoseconds (fromIntegral delay)) list where go _ _ [] = return [] go initial_time_ps delay_ps (x:xs) = do this_time <- getCPUTime if this_time - initial_time_ps < delay_ps then go initial_time_ps delay_ps xs >>= return . (x:) else return []test-framework-0.8.1.1/Test/Framework/Runners/XML.hs0000644000000000000000000000420612453651525020335 0ustar0000000000000000module Test.Framework.Runners.XML ( produceReport ) where import Test.Framework.Runners.Statistics ( testCountTotal, TestStatistics(..) ) import Test.Framework.Runners.Core ( FinishedTest ) import Test.Framework.Runners.XML.JUnitWriter ( RunDescription(..), serialize ) import Data.Time.Format ( formatTime ) import Data.Time.LocalTime ( getZonedTime ) #if MIN_VERSION_time(1,5,0) import Data.Time.Format ( defaultTimeLocale ) #else import System.Locale ( defaultTimeLocale ) #endif import Network.HostName ( getHostName ) produceReport :: Bool -> TestStatistics -> [FinishedTest] -> IO String produceReport nested test_statistics fin_tests = fmap (serialize nested) $ mergeResults test_statistics fin_tests -- | Generates a description of the complete test run, given some -- initial over-all test statistics and the list of tests that was -- run. -- -- This is only specific to the XML code because the console output -- @Runner@ doesn't need this level of detail to produce summary -- information, and the per-test details are generated during -- execution. -- -- This could be done better by using a State monad in the notifier -- defined within `issueTests`. mergeResults :: TestStatistics -> [FinishedTest] -> IO RunDescription mergeResults test_statistics fin_tests = do host <- getHostName theTime <- getZonedTime return RunDescription { errors = 0 -- not yet available , failedCount = testCountTotal (ts_failed_tests test_statistics) -- this includes errors , skipped = Nothing -- not yet applicable , hostname = Just host , suiteName = "test-framework tests" -- not yet available , testCount = testCountTotal (ts_total_tests test_statistics) , time = 0.0 -- We don't currently measure the test run time. , timeStamp = Just $ formatTime defaultTimeLocale "%a %B %e %k:%M:%S %Z %Y" theTime -- e.g. Thu May 6 22:09:10 BST 2010 , runId = Nothing -- not applicable , package = Nothing -- not yet available , tests = fin_tests } test-framework-0.8.1.1/Test/Framework/Runners/Console/0000755000000000000000000000000012453651525020741 5ustar0000000000000000test-framework-0.8.1.1/Test/Framework/Runners/Console/Colors.hs0000644000000000000000000000041112453651525022532 0ustar0000000000000000module Test.Framework.Runners.Console.Colors where import Text.PrettyPrint.ANSI.Leijen colorFail, colorPass :: Doc -> Doc colorFail = red colorPass = green colorPassOrFail :: Bool -> Doc -> Doc colorPassOrFail True = colorPass colorPassOrFail False = colorFailtest-framework-0.8.1.1/Test/Framework/Runners/Console/ProgressBar.hs0000644000000000000000000000142012453651525023523 0ustar0000000000000000module Test.Framework.Runners.Console.ProgressBar ( Progress(..), progressBar ) where import Text.PrettyPrint.ANSI.Leijen hiding (width) data Progress = Progress Int Int progressBar :: (Doc -> Doc) -> Int -> Progress -> Doc progressBar color width (Progress count total) = char '[' <> progress_doc <> space_doc <> char ']' where -- The available width takes account of the enclosing brackets available_width = width - 2 characters_per_tick = fromIntegral available_width / fromIntegral total :: Double progress_chars = round (characters_per_tick * fromIntegral count) space_chars = available_width - progress_chars progress_doc = color (text (reverse (take progress_chars ('>' : repeat '=')))) space_doc = text (replicate space_chars ' ')test-framework-0.8.1.1/Test/Framework/Runners/Console/Run.hs0000644000000000000000000001427412453651525022051 0ustar0000000000000000module Test.Framework.Runners.Console.Run ( showRunTestsTop ) where import Test.Framework.Core import Test.Framework.Improving import Test.Framework.Runners.Console.Colors import Test.Framework.Runners.Console.ProgressBar import Test.Framework.Runners.Console.Statistics import Test.Framework.Runners.Console.Utilities import Test.Framework.Runners.Core import Test.Framework.Runners.Statistics import Test.Framework.Runners.TimedConsumption import Test.Framework.Utilities import System.Console.ANSI import System.IO import Text.PrettyPrint.ANSI.Leijen import Data.Monoid (mempty) import Control.Arrow (second, (&&&)) import Control.Monad (unless) showRunTestsTop :: Bool -> Bool -> [RunningTest] -> IO [FinishedTest] showRunTestsTop isplain hide_successes running_tests = (if isplain then id else hideCursorDuring) $ do -- Show those test results to the user as we get them. Gather statistics on the fly for a progress bar let test_statistics = initialTestStatistics (totalRunTestsList running_tests) (test_statistics', finished_tests) <- showRunTests isplain hide_successes 0 test_statistics running_tests -- Show the final statistics putStrLn "" putDoc $ possiblyPlain isplain $ showFinalTestStatistics test_statistics' return finished_tests -- This code all /really/ sucks. There must be a better way to seperate out the console-updating -- and the improvement-traversing concerns - but how? showRunTest :: Bool -> Bool -> Int -> TestStatistics -> RunningTest -> IO (TestStatistics, FinishedTest) showRunTest isplain hide_successes indent_level test_statistics (RunTest name test_type (SomeImproving improving_result)) = do let progress_bar = testStatisticsProgressBar test_statistics (property_text, property_suceeded) <- showImprovingTestResult isplain hide_successes indent_level name progress_bar improving_result return (updateTestStatistics (\count -> adjustTestCount test_type count mempty) property_suceeded test_statistics, RunTest name test_type (property_text, property_suceeded)) showRunTest isplain hide_successes indent_level test_statistics (RunTestGroup name tests) = do putDoc $ (indent indent_level (text name <> char ':')) <> linebreak fmap (second $ RunTestGroup name) $ showRunTests isplain hide_successes (indent_level + 2) test_statistics tests showRunTests :: Bool -> Bool -> Int -> TestStatistics -> [RunningTest] -> IO (TestStatistics, [FinishedTest]) showRunTests isplain hide_successes indent_level = mapAccumLM (showRunTest isplain hide_successes indent_level) testStatisticsProgressBar :: TestStatistics -> Doc testStatisticsProgressBar test_statistics = progressBar (colorPassOrFail no_failures) terminal_width (Progress run_tests total_tests) where run_tests = testCountTotal (ts_run_tests test_statistics) total_tests = testCountTotal (ts_total_tests test_statistics) no_failures = ts_no_failures test_statistics -- We assume a terminal width of 80, but we can't make the progress bar 80 characters wide. Why? Because if we -- do so, when we write the progress bar out Windows will move the cursor onto the next line! By using a slightly -- smaller width we prevent this from happening. Bit of a hack, but it does the job. terminal_width = 79 showImprovingTestResult :: TestResultlike i r => Bool -> Bool -> Int -> String -> Doc -> (i :~> r) -> IO (String, Bool) showImprovingTestResult isplain hide_successes indent_level test_name progress_bar improving = do -- Consume the improving value until the end, displaying progress if we are not in "plain" mode (result, success) <- if isplain then return $ improvingLast improving' else showImprovingTestResultProgress (return ()) indent_level test_name progress_bar improving' unless (success && hide_successes) $ do let (result_doc, extra_doc) | success = (brackets $ colorPass (text result), empty) | otherwise = (brackets (colorFail (text "Failed")), text result <> linebreak) -- Output the final test status and a trailing newline putTestHeader indent_level test_name (possiblyPlain isplain result_doc) -- Output any extra information that may be required, e.g. to show failure reason putDoc extra_doc return (result, success) where improving' = bimapImproving show (show &&& testSucceeded) improving showImprovingTestResultProgress :: IO () -> Int -> String -> Doc -> (String :~> (String, Bool)) -> IO (String, Bool) showImprovingTestResultProgress erase indent_level test_name progress_bar improving = do -- Update the screen every every 200ms improving_list <- consumeListInInterval 200000 (consumeImproving improving) case listToMaybeLast improving_list of Nothing -> do -- 200ms was somehow not long enough for a single result to arrive: try again! showImprovingTestResultProgress erase indent_level test_name progress_bar improving Just improving' -> do -- Display that new improving value to the user showImprovingTestResultProgress' erase indent_level test_name progress_bar improving' showImprovingTestResultProgress' :: IO () -> Int -> String -> Doc -> (String :~> (String, Bool)) -> IO (String, Bool) showImprovingTestResultProgress' erase _ _ _ (Finished result) = do erase -- There may still be a progress bar on the line below the final test result, so -- remove it as a precautionary measure in case this is the last test in a group -- and hence it will not be erased in the normal course of test display. putStrLn "" clearLine cursorUpLine 1 return result showImprovingTestResultProgress' erase indent_level test_name progress_bar (Improving intermediate rest) = do erase putTestHeader indent_level test_name (brackets (text intermediate)) putDoc progress_bar hFlush stdout showImprovingTestResultProgress (cursorUpLine 1 >> clearLine) indent_level test_name progress_bar rest possiblyPlain :: Bool -> Doc -> Doc possiblyPlain True = plain possiblyPlain False = id putTestHeader :: Int -> String -> Doc -> IO () putTestHeader indent_level test_name result = putDoc $ (indent indent_level (text test_name <> char ':' <+> result)) <> linebreak test-framework-0.8.1.1/Test/Framework/Runners/Console/Statistics.hs0000644000000000000000000000351512453651525023433 0ustar0000000000000000module Test.Framework.Runners.Console.Statistics ( showFinalTestStatistics ) where import Test.Framework.Runners.Statistics import Test.Framework.Runners.Console.Colors import Test.Framework.Runners.Console.Table import Text.PrettyPrint.ANSI.Leijen import Data.List -- | Displays statistics as a string something like this: -- -- @ -- Properties Total -- Passed 9 9 -- Failed 1 1 -- Total 10 10 -- @ showFinalTestStatistics :: TestStatistics -> Doc showFinalTestStatistics ts = renderTable $ [Column label_column] ++ (map Column test_type_columns) ++ [Column total_column] where test_types = sort $ testCountTestTypes (ts_total_tests ts) label_column = [TextCell empty, TextCell (text "Passed"), TextCell (text "Failed"), TextCell (text "Total")] total_column = [TextCell (text "Total"), testStatusTotal colorPass ts_passed_tests, testStatusTotal colorFail ts_failed_tests, testStatusTotal (colorPassOrFail (ts_no_failures ts)) ts_total_tests] test_type_columns = [ [TextCell (text test_type), testStat colorPass (countTests ts_passed_tests), testStat colorFail failures, testStat (colorPassOrFail (failures <= 0)) (countTests ts_total_tests)] | test_type <- test_types , let countTests = testCountForType test_type . ($ ts) failures = countTests ts_failed_tests ] testStatusTotal color status_accessor = TextCell (coloredNumber color (testCountTotal (status_accessor ts))) testStat color number = TextCell (coloredNumber color number) coloredNumber :: (Doc -> Doc) -> Int -> Doc coloredNumber color number | number == 0 = number_doc | otherwise = color number_doc where number_doc = text (show number)test-framework-0.8.1.1/Test/Framework/Runners/Console/Table.hs0000644000000000000000000000464712453651525022337 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Framework.Runners.Console.Table ( Cell(..), Column(..), renderTable ) where import Test.Framework.Utilities #if MIN_VERSION_ansi_wl_pprint(0,6,6) import Text.PrettyPrint.ANSI.Leijen hiding (column, columns) #else import Text.PrettyPrint.ANSI.Leijen hiding (column) #endif data Cell = TextCell Doc | SeperatorCell data Column = Column [Cell] | SeperatorColumn type ColumnWidth = Int renderTable :: [Column] -> Doc renderTable = renderColumnsWithWidth . map (\column -> (findColumnWidth column, column)) findColumnWidth :: Column -> Int findColumnWidth SeperatorColumn = 0 findColumnWidth (Column cells) = maximum (map findCellWidth cells) findCellWidth :: Cell -> Int findCellWidth (TextCell doc) = maximum (0 : map length (lines (shows doc ""))) findCellWidth SeperatorCell = 0 renderColumnsWithWidth :: [(ColumnWidth, Column)] -> Doc renderColumnsWithWidth columns | all (columnFinished . snd) columns = empty | otherwise = first_cells_str <> line <> renderColumnsWithWidth (map (onRight columnDropHead) columns) where first_cells_str = hcat $ zipWith (uncurry renderFirstColumnCell) columns (eitherSideSeperator (map snd columns)) eitherSideSeperator :: [Column] -> [Bool] eitherSideSeperator columns = zipWith (||) (False:column_is_seperator) (tail column_is_seperator ++ [False]) where column_is_seperator = map isSeperatorColumn columns isSeperatorColumn :: Column -> Bool isSeperatorColumn SeperatorColumn = False isSeperatorColumn (Column cells) = case cells of [] -> False (cell:_) -> isSeperatorCell cell isSeperatorCell :: Cell -> Bool isSeperatorCell SeperatorCell = True isSeperatorCell _ = False renderFirstColumnCell :: ColumnWidth -> Column -> Bool -> Doc renderFirstColumnCell column_width (Column cells) _ = case cells of [] -> text $ replicate (column_width + 2) ' ' (SeperatorCell:_) -> text $ replicate (column_width + 2) '-' (TextCell contents:_) -> char ' ' <> fill column_width contents <> char ' ' renderFirstColumnCell _ SeperatorColumn either_side_seperator = if either_side_seperator then char '+' else char '|' columnFinished :: Column -> Bool columnFinished (Column cells) = null cells columnFinished SeperatorColumn = True columnDropHead :: Column -> Column columnDropHead (Column cells) = Column (drop 1 cells) columnDropHead SeperatorColumn = SeperatorColumn test-framework-0.8.1.1/Test/Framework/Runners/Console/Utilities.hs0000644000000000000000000000045512453651525023254 0ustar0000000000000000module Test.Framework.Runners.Console.Utilities ( hideCursorDuring ) where import System.Console.ANSI import System.IO import Control.Exception (bracket) hideCursorDuring :: IO a -> IO a hideCursorDuring action = bracket hideCursor (const (showCursor >> hFlush stdout)) (const action) test-framework-0.8.1.1/Test/Framework/Runners/XML/0000755000000000000000000000000012453651525017777 5ustar0000000000000000test-framework-0.8.1.1/Test/Framework/Runners/XML/JUnitWriter.hs0000644000000000000000000000767312453651525022576 0ustar0000000000000000module Test.Framework.Runners.XML.JUnitWriter ( RunDescription(..), serialize, #ifdef TEST morphFlatTestCase, morphNestedTestCase #endif ) where import Test.Framework.Core (TestName) import Test.Framework.Runners.Core (RunTest(..), FinishedTest) import Data.List ( intercalate ) import Data.Maybe ( fromMaybe ) import Text.XML.Light ( ppTopElement, unqual, unode , Attr(..), Element(..) ) -- | An overall description of the test suite run. This is currently -- styled after the JUnit xml. It contains records that are not yet -- used, however, it provides a sensible structure to populate as we -- are able, and the serialiazation code behaves as though these are -- filled. data RunDescription = RunDescription { errors :: Int -- ^ The number of tests that triggered error -- conditions (unanticipated failures) , failedCount :: Int -- ^ Count of tests that invalidated stated assertions. , skipped :: Maybe Int -- ^ Count of tests that were provided but not run. , hostname :: Maybe String -- ^ The hostname that ran the test suite. , suiteName :: String -- ^ The name of the test suite. , testCount :: Int -- ^ The total number of tests provided. , time :: Double -- ^ The total execution time for the test suite. , timeStamp :: Maybe String -- ^ The time stamp that identifies when this run happened. , runId :: Maybe String -- ^ Included for completness w/ junit. , package :: Maybe String -- ^ holdover from Junit spec. Could be -- used to specify the module under test. , tests :: [FinishedTest] -- ^ detailed description and results for each test run. } deriving (Show) -- | Serializes a `RunDescription` value to a `String`. serialize :: Bool -> RunDescription -> String serialize nested = ppTopElement . toXml nested -- | Maps a `RunDescription` value to an XML Element toXml :: Bool -> RunDescription -> Element toXml nested runDesc = unode "testsuite" (attrs, morph_cases (tests runDesc)) where morph_cases | nested = map morphNestedTestCase | otherwise = concatMap (morphFlatTestCase []) -- | Top-level attributes for the first @testsuite@ tag. attrs :: [Attr] attrs = map (\(x,f)->Attr (unqual x) (f runDesc)) fields fields = [ ("errors", show . errors) , ("failures", show . failedCount) , ("skipped", fromMaybe "" . fmap show . skipped) , ("hostname", fromMaybe "" . hostname) , ("name", id . suiteName) , ("tests", show . testCount) , ("time", show . time) , ("timestamp", fromMaybe "" . timeStamp) , ("id", fromMaybe "" . runId) , ("package", fromMaybe "" . package) ] morphFlatTestCase :: [String] -> FinishedTest -> [Element] morphFlatTestCase path (RunTestGroup gname testList) = concatMap (morphFlatTestCase (gname:path)) testList morphFlatTestCase path (RunTest tName _ res) = [morphOneTestCase cName tName res] where cName | null path = "" | otherwise = intercalate "." (reverse path) morphNestedTestCase :: FinishedTest -> Element morphNestedTestCase (RunTestGroup gname testList) = unode "testsuite" (attrs, map morphNestedTestCase testList) where attrs = [ Attr (unqual "name") gname ] morphNestedTestCase (RunTest tName _ res) = morphOneTestCase "" tName res morphOneTestCase :: String -> TestName -> (String, Bool) -> Element morphOneTestCase cName tName (tout, pass) = case pass of True -> unode "testcase" caseAttrs False -> unode "testcase" (caseAttrs, unode "failure" (failAttrs, tout)) where caseAttrs = [ Attr (unqual "name") tName , Attr (unqual "classname") cName , Attr (unqual "time") "" ] failAttrs = [ Attr (unqual "message") "" , Attr (unqual "type") "" ]