packages feed

test-framework 0.3.3 → 0.4.0

raw patch · 8 files changed

+115/−73 lines, 8 files

Files

Test/Framework.hs view
@@ -10,7 +10,7 @@         module Test.Framework.Seed     ) where -import Test.Framework.Core (Test, TestName, testGroup, plusTestOptions)+import Test.Framework.Core (Test, TestName, testGroup, plusTestOptions, buildTest, mutuallyExclusive) import Test.Framework.Options import Test.Framework.Runners.Console import Test.Framework.Runners.Options
Test/Framework/Core.hs view
@@ -1,9 +1,12 @@+{-# LANGUAGE UndecidableInstances #-} module Test.Framework.Core where  import Test.Framework.Improving import Test.Framework.Options +import Control.Concurrent.MVar + -- | Something like the result of a test: works in concert with 'Testlike'. -- The type parameters are the type that is used for progress reports and the -- type of the final output of the test respectively.@@ -32,13 +35,38 @@ -- -- For an example of how to use test-framework, please see -- <http://github.com/batterseapower/test-framework/raw/master/example/Test/Framework/Example.lhs>-data Test = forall i r t. Testlike i r t => Test TestName t -- ^ A single test of some particular type. -          | TestGroup TestName [Test]-          | PlusTestOptions TestOptions Test+data Test = forall i r t. Testlike i r t => Test TestName t -- ^ A single test of some particular type+          | TestGroup TestName [Test]                       -- ^ Assemble a number of tests into a cohesive group+          | PlusTestOptions TestOptions Test                -- ^ Add some options to child tests+          | BuildTest (IO Test)                             -- ^ Convenience for creating tests from an 'IO' action  -- | Assemble a number of tests into a cohesive group testGroup :: TestName -> [Test] -> Test testGroup = TestGroup +-- | Add some options to child tests plusTestOptions :: TestOptions -> Test -> Test plusTestOptions = PlusTestOptions++-- | Convenience for creating tests from an 'IO' action+buildTest :: IO Test -> Test+buildTest = BuildTest+++data MutuallyExcluded t = ME (MVar ()) t++-- This requires UndecidableInstances, but I think it can't be made inconsistent?+instance Testlike i r t => Testlike i r (MutuallyExcluded t) where+    runTest cto (ME mvar x) = withMVar mvar $ \() -> runTest cto x+    testTypeName ~(ME _ x) = testTypeName x++-- | Mark all tests in this portion of the tree as mutually exclusive, so only one runs at a time+{-# NOINLINE mutuallyExclusive #-}+mutuallyExclusive :: Test -> Test+mutuallyExclusive init_t = BuildTest $ do+    mvar <- newMVar ()+    let go (Test tn t)            = Test tn (ME mvar t)+        go (TestGroup tn ts)      = TestGroup tn (map go ts)+        go (PlusTestOptions to t) = PlusTestOptions to (go t)+        go (BuildTest build)      = BuildTest (fmap go build)+    return (go init_t)
Test/Framework/Runners/Console.hs view
@@ -1,5 +1,6 @@ module Test.Framework.Runners.Console (-        defaultMain, defaultMainWithArgs, defaultMainWithOpts+        defaultMain, defaultMainWithArgs, defaultMainWithOpts,+        interpretArgs, interpretArgsOrExit     ) where  import Test.Framework.Core@@ -65,9 +66,14 @@             "write a junit-xml summary of the output to FILE",         Option [] ["plain"]             (NoArg (mempty { ropt_plain_output = Just True }))-            "do not use any ANSI terminal features to display the test run"+            "do not use any ANSI terminal features to display the test run",+        Option [] ["hide-successes"]+            (NoArg (mempty { ropt_hide_successes = Just True }))+            "hide sucessful tests, and only show failures"     ] +-- | Parse the specified command line arguments into a 'RunnerOptions' and some remaining arguments,+-- or return a reason as to why we can't. interpretArgs :: [String] -> IO (Either String (RunnerOptions, [String])) interpretArgs args = do     prog_name <- getProgName@@ -77,17 +83,12 @@         (oas, n, []) | Just os <- sequence oas -> return $ Right (mconcat os, n)         (_, _, errs)                           -> return $ Left (concat errs ++ usageInfo usage_header optionsDescription) --defaultMain :: [Test] -> IO ()-defaultMain tests = do-    args <- getArgs-    defaultMainWithArgs tests args--defaultMainWithArgs :: [Test] -> [String] -> IO ()-defaultMainWithArgs tests args = do+-- | 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, [])    -> defaultMainWithOpts tests ropts+        Right (ropts, [])    -> return ropts         Right (_, leftovers) -> do             hPutStrLn stderr $ "Could not understand these extra arguments: " ++ unwords leftovers             exitWith (ExitFailure 1)@@ -95,6 +96,21 @@             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@@ -103,7 +119,7 @@     running_tests <- runTests ropts' tests          -- Show those test results to the user as we get them-    fin_tests <- showRunTestsTop (unK $ ropt_plain_output ropts') running_tests+    fin_tests <- showRunTestsTop (unK $ ropt_plain_output ropts') (unK $ ropt_hide_successes ropts') running_tests     let test_statistics' = gatherStatistics fin_tests          -- Output XML report (if requested)@@ -123,5 +139,6 @@             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_plain_output = K $ ropt_plain_output ro `orElse` False+            ropt_plain_output = K $ ropt_plain_output ro `orElse` False,+            ropt_hide_successes = K $ ropt_hide_successes ro `orElse` False         }
Test/Framework/Runners/Console/Run.hs view
@@ -21,13 +21,14 @@ import Data.Monoid  import Control.Arrow (second, (&&&))+import Control.Monad (unless)  -showRunTestsTop :: Bool -> [RunningTest] -> IO [FinishedTest]-showRunTestsTop isplain running_tests = (if isplain then id else hideCursorDuring) $ do+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 0 test_statistics running_tests+    (test_statistics', finished_tests) <- showRunTests isplain hide_successes 0 test_statistics running_tests          -- Show the final statistics     putStrLn ""@@ -38,17 +39,17 @@  -- 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 -> Int -> TestStatistics -> RunningTest -> IO (TestStatistics, FinishedTest)-showRunTest isplain indent_level test_statistics (RunTest name test_type (SomeImproving improving_result)) = do+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 indent_level name progress_bar improving_result+    (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 indent_level test_statistics (RunTestGroup name tests) = do+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 (indent_level + 2) test_statistics tests+    fmap (second $ RunTestGroup name) $ showRunTests isplain hide_successes (indent_level + 2) test_statistics tests -showRunTests :: Bool -> Int -> TestStatistics -> [RunningTest] -> IO (TestStatistics, [FinishedTest])-showRunTests isplain indent_level = mapAccumLM (showRunTest isplain indent_level)+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@@ -63,19 +64,20 @@     terminal_width = 79  -showImprovingTestResult :: TestResultlike i r => Bool -> Int -> String -> Doc -> (i :~> r) -> IO (String, Bool)-showImprovingTestResult isplain indent_level test_name progress_bar improving = do+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'-    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-    +    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
Test/Framework/Runners/Core.hs view
@@ -30,38 +30,28 @@          -> IO [RunningTest] runTests ropts tests = do     let test_patterns = unK $ ropt_test_patterns ropts-        tests' | null test_patterns = tests-               | otherwise          = filterTests test_patterns [] tests-    (run_tests, actions) <- runTests' (unK $ ropt_test_options ropts) tests'+        use_test path name = null test_patterns || any (`testPatternMatches` (path ++ [name])) test_patterns+    (run_tests, actions) <- runTests' use_test [] (unK $ ropt_test_options ropts) tests     _ <- executeOnPool (unK $ ropt_threads ropts) actions     return run_tests  -filterTests :: [TestPattern] -> [String] -> [Test] -> [Test]-filterTests patterns path = mapMaybe (filterTest patterns path)--filterTest :: [TestPattern] -> [String] -> Test -> Maybe Test-filterTest patterns path test@(Test name _)-  | any (`testPatternMatches` (path ++ [name])) patterns = Just test-  | otherwise                                            = Nothing-filterTest patterns path (TestGroup name tests)-  | null tests' = Nothing-  | otherwise   = Just (TestGroup name tests')-  where-    tests' = filterTests patterns (path ++ [name]) tests-filterTest patterns path (PlusTestOptions topts inner_test)-  = fmap (PlusTestOptions topts) (filterTest patterns path inner_test)---runTest' :: TestOptions -> Test -> IO (RunningTest, [IO ()])-runTest' topts (Test name testlike) = do+runTest' :: ([String] -> String -> Bool) -> [String]+         -> TestOptions -> Test -> IO (Maybe (RunningTest, [IO ()]))+runTest' use_test path topts (Test name testlike)+  | use_test path name = do     (result, action) <- runTest (completeTestOptions topts) testlike-    return (RunTest name (testTypeName testlike) (SomeImproving result), [action])-runTest' topts (TestGroup name tests) = fmap (onLeft (RunTestGroup name)) $ runTests' topts tests-runTest' topts (PlusTestOptions extra_topts test) = runTest' (topts `mappend` extra_topts) test+    return (Just (RunTest name (testTypeName testlike) (SomeImproving result), [action]))+  | otherwise = return Nothing+runTest' use_test path topts (TestGroup name tests) = do+    (results, actions) <- runTests' use_test (path ++ [name]) topts tests+    return $ if null results then Nothing else Just ((RunTestGroup name results), actions)+runTest' use_test path topts (PlusTestOptions extra_topts test) = runTest' use_test path (topts `mappend` extra_topts) test+runTest' use_test path topts (BuildTest build) = build >>= runTest' use_test path topts -runTests' :: TestOptions -> [Test] -> IO ([RunningTest], [IO ()])-runTests' topts = fmap (onRight concat . unzip) . mapM (runTest' topts)+runTests' :: ([String] -> String -> Bool) -> [String]+          -> TestOptions -> [Test] -> IO ([RunningTest], [IO ()])+runTests' use_test path topts = fmap (onRight concat . unzip . catMaybes) . mapM (runTest' use_test path topts)   completeTestOptions :: TestOptions -> CompleteTestOptions
Test/Framework/Runners/Options.hs view
@@ -14,7 +14,8 @@         ropt_test_options :: f TestOptions,         ropt_test_patterns :: f [TestPattern],         ropt_xml_output :: f (Maybe FilePath),-        ropt_plain_output :: f Bool+        ropt_plain_output :: f Bool,+        ropt_hide_successes :: f Bool     }  instance Monoid (RunnerOptions' Maybe) where@@ -23,7 +24,8 @@             ropt_test_options = Nothing,             ropt_test_patterns = Nothing,             ropt_xml_output = Nothing,-            ropt_plain_output = Nothing+            ropt_plain_output = Nothing,+            ropt_hide_successes = Nothing         }      mappend ro1 ro2 = RunnerOptions {@@ -31,5 +33,6 @@             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_plain_output = getLast (mappendBy (Last . ropt_plain_output) ro1 ro2)+            ropt_plain_output = getLast (mappendBy (Last . ropt_plain_output) ro1 ro2),+            ropt_hide_successes = getLast (mappendBy (Last . ropt_hide_successes) ro1 ro2)         }
Test/Framework/Utilities.hs view
@@ -1,7 +1,11 @@ module Test.Framework.Utilities where +import Control.Arrow (first, second)++import Data.Function (on) import Data.Maybe import Data.Monoid+import Data.List (intercalate)   newtype K a = K { unK :: a }@@ -17,16 +21,16 @@ listToMaybeLast = listToMaybe . reverse  mappendBy :: Monoid b => (a -> b) -> a -> a -> b-mappendBy f left right = (f left) `mappend` (f right)+mappendBy f = mappend `on` f  orElse :: Maybe a -> a -> a orElse = flip fromMaybe  onLeft :: (a -> c) -> (a, b) -> (c, b)-onLeft f (x, y) = (f x, y)+onLeft = first  onRight :: (b -> c) -> (a, b) -> (a, c)-onRight f (x, y) = (x, f y)+onRight = second  -- | Like 'unlines', but does not append a trailing newline if there -- is at least one line.  For example:@@ -42,9 +46,7 @@ -- This is closer to the behaviour of 'unwords', which does not append -- a trailing space. unlinesConcise :: [String] -> String-unlinesConcise []     = []-unlinesConcise [l]    = l-unlinesConcise (l:ls) = l ++ '\n' : unlinesConcise ls+unlinesConcise = intercalate "\n"  mapAccumLM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y]) mapAccumLM _ acc [] = return (acc, [])
test-framework.cabal view
@@ -1,5 +1,5 @@ Name:                test-framework-Version:             0.3.3+Version:             0.4.0 Cabal-Version:       >= 1.2.3 Category:            Testing Synopsis:            Framework for running and organising tests, with HUnit and QuickCheck support