packages feed

test-framework 0.3.0 → 0.3.1

raw patch · 5 files changed

+79/−53 lines, 5 filesdep ~ansi-wl-pprint

Dependency ranges changed: ansi-wl-pprint

Files

Test/Framework/Improving.hs view
@@ -1,5 +1,5 @@ module Test.Framework.Improving (-        (:~>)(..), +        (:~>)(..), bimapImproving, improvingLast, consumeImproving,         ImprovingIO, yieldImprovement, runImprovingIO, liftIO,         timeoutImprovingIO, maybeTimeoutImprovingIO     ) where@@ -16,6 +16,18 @@ 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 }
Test/Framework/Runners/Console.hs view
@@ -16,6 +16,7 @@ import System.Console.GetOpt import System.Environment import System.Exit+import System.IO  import Data.Monoid @@ -60,8 +61,11 @@             (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"]-            (OptArg (\t -> mempty { ropt_xml_output = Just (Just t) }) "FILE")-            "Set the output format to junit-xml, and (optionally) writes to FILE instead of STDOUT"+            (ReqArg (\t -> mempty { ropt_xml_output = Just (Just t) }) "FILE")+            "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"     ]  interpretArgs :: [String] -> IO (Either String (RunnerOptions, [String]))@@ -85,10 +89,10 @@     case interpreted_args of         Right (ropts, [])    -> defaultMainWithOpts tests ropts         Right (_, leftovers) -> do-            putStrLn $ "Could not understand these extra arguments: " ++ unwords leftovers+            hPutStrLn stderr $ "Could not understand these extra arguments: " ++ unwords leftovers             exitWith (ExitFailure 1)         Left error_message   -> do-            putStrLn error_message+            hPutStrLn stderr error_message             exitWith (ExitFailure 1)  defaultMainWithOpts :: [Test] -> RunnerOptions -> IO ()@@ -99,12 +103,12 @@     running_tests <- runTests ropts' tests          -- Show those test results to the user as we get them-    fin_tests <- showRunTestsTop running_tests+    fin_tests <- showRunTestsTop (unK $ ropt_plain_output ropts') running_tests     let test_statistics' = gatherStatistics fin_tests          -- Output XML report (if requested)     case ropt_xml_output ropts' of-        K (Just mb_file) -> XML.produceReport test_statistics' fin_tests >>= maybe putStrLn writeFile mb_file+        K (Just file) -> XML.produceReport test_statistics' fin_tests >>= writeFile file         _ -> return ()          -- Set the error code depending on whether the tests succeded or not@@ -118,5 +122,6 @@             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_output = K $ ropt_xml_output ro `orElse` Nothing,+            ropt_plain_output = K $ ropt_plain_output ro `orElse` False         }
Test/Framework/Runners/Console/Run.hs view
@@ -20,35 +20,35 @@  import Data.Monoid -import Control.Arrow (second)+import Control.Arrow (second, (&&&))  -showRunTestsTop :: [RunningTest] -> IO [FinishedTest]-showRunTestsTop running_tests = hideCursorDuring $ do+showRunTestsTop :: Bool -> [RunningTest] -> IO [FinishedTest]+showRunTestsTop isplain running_tests = 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 0 test_statistics running_tests+    (test_statistics', finished_tests) <- showRunTests isplain 0 test_statistics running_tests          -- Show the final statistics     putStrLn ""-    putDoc $ showFinalTestStatistics test_statistics'+    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 :: Int -> TestStatistics -> RunningTest -> IO (TestStatistics, FinishedTest)-showRunTest indent_level test_statistics (RunTest name test_type (SomeImproving improving_result)) = do+showRunTest :: Bool -> Int -> TestStatistics -> RunningTest -> IO (TestStatistics, FinishedTest)+showRunTest isplain indent_level test_statistics (RunTest name test_type (SomeImproving improving_result)) = do     let progress_bar = testStatisticsProgressBar test_statistics-    (property_text, property_suceeded) <- showImprovingTestResult (return ()) indent_level name progress_bar improving_result+    (property_text, property_suceeded) <- showImprovingTestResult isplain 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 indent_level test_statistics (RunTestGroup name tests) = do+showRunTest isplain indent_level test_statistics (RunTestGroup name tests) = do     putDoc $ (indent indent_level (text name <> char ':')) <> linebreak-    fmap (second $ RunTestGroup name) $ showRunTests (indent_level + 2) test_statistics tests+    fmap (second $ RunTestGroup name) $ showRunTests isplain (indent_level + 2) test_statistics tests -showRunTests :: Int -> TestStatistics -> [RunningTest] -> IO (TestStatistics, [FinishedTest])-showRunTests indent_level = mapAccumLM (showRunTest indent_level)+showRunTests :: Bool -> Int -> TestStatistics -> [RunningTest] -> IO (TestStatistics, [FinishedTest])+showRunTests isplain indent_level = mapAccumLM (showRunTest isplain indent_level)   testStatisticsProgressBar :: TestStatistics -> Doc@@ -63,45 +63,53 @@     terminal_width = 79  -consumeImprovingThing :: (a :~> b) -> [(a :~> b)]-consumeImprovingThing improving@(Finished _)       = [improving]-consumeImprovingThing improving@(Improving _ rest) = improving : consumeImprovingThing rest-+showImprovingTestResult :: TestResultlike i r => Bool -> Int -> String -> Doc -> (i :~> r) -> IO (String, Bool)+showImprovingTestResult isplain 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+    +    return (result, success)+  where+    improving' = bimapImproving show (show &&& testSucceeded) improving -showImprovingTestResult :: TestResultlike i r => IO () -> Int -> String -> Doc -> (i :~> r) -> IO (String, Bool)-showImprovingTestResult erase indent_level test_name progress_bar improving = do+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 (consumeImprovingThing improving)+    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!-            showImprovingTestResult erase indent_level test_name progress_bar improving+            showImprovingTestResultProgress erase indent_level test_name progress_bar improving         Just improving' -> do -- Display that new improving value to the user-            showImprovingTestResult' erase indent_level test_name progress_bar improving'+            showImprovingTestResultProgress' erase indent_level test_name progress_bar improving' -showImprovingTestResult' :: TestResultlike i r => IO () -> Int -> String -> Doc -> (i :~> r) -> IO (String, Bool)-showImprovingTestResult' erase indent_level test_name _ (Finished result) = do+showImprovingTestResultProgress' :: IO () -> Int -> String -> Doc -> (String :~> (String, Bool)) -> IO (String, Bool)+showImprovingTestResultProgress' erase _ _ _ (Finished result) = do     erase-    -- Output the final test status and a trailing newline-    putTestHeader indent_level test_name result_doc     -- 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-    -- Output any extra information that may be required, e.g. to show failure reason-    putDoc extra_doc-    return (show result, success)-  where-    success = testSucceeded result-    (result_doc, extra_doc) | success   = (brackets $ colorPass (text (show result)), empty)-                            | otherwise = (brackets (colorFail (text "Failed")), text (show result) <> linebreak)-showImprovingTestResult' erase indent_level test_name progress_bar (Improving intermediate rest) = do+    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_str))+    putTestHeader indent_level test_name (brackets (text intermediate))     putDoc progress_bar     hFlush stdout-    showImprovingTestResult (cursorUpLine 1 >> clearLine) indent_level test_name progress_bar rest-  where  -    intermediate_str = show intermediate+    showImprovingTestResultProgress (cursorUpLine 1 >> clearLine) indent_level test_name progress_bar rest++possiblyPlain :: Bool -> Doc -> Doc+possiblyPlain True  = plain+possiblyPlain False = id  putTestHeader :: Int -> String -> Doc -> IO () putTestHeader indent_level test_name result = putDoc $ (indent indent_level (text test_name <> char ':' <+> result)) <> linebreak
Test/Framework/Runners/Options.hs view
@@ -13,7 +13,8 @@         ropt_threads :: f Int,         ropt_test_options :: f TestOptions,         ropt_test_patterns :: f [TestPattern],-        ropt_xml_output :: f (Maybe (Maybe FilePath))+        ropt_xml_output :: f (Maybe FilePath),+        ropt_plain_output :: f Bool     }  instance Monoid (RunnerOptions' Maybe) where@@ -21,12 +22,14 @@             ropt_threads = Nothing,             ropt_test_options = Nothing,             ropt_test_patterns = Nothing,-            ropt_xml_output = Nothing+            ropt_xml_output = Nothing,+            ropt_plain_output = 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_output = mappendBy ropt_xml_output ro1 ro2,+            ropt_plain_output = getLast (mappendBy (Last . ropt_plain_output) ro1 ro2)         }
test-framework.cabal view
@@ -1,5 +1,5 @@ Name:                test-framework-Version:             0.3.0+Version:             0.3.1 Cabal-Version:       >= 1.2.3 Category:            Testing Synopsis:            Framework for running and organising tests, with HUnit and QuickCheck support@@ -48,7 +48,7 @@                                 Test.Framework.Runners.XML                                 Test.Framework.Utilities         -        Build-Depends:          ansi-terminal >= 0.4.0, ansi-wl-pprint >= 0.4.0,+        Build-Depends:          ansi-terminal >= 0.4.0, ansi-wl-pprint >= 0.5.1,                                 regex-posix >= 0.72, extensible-exceptions >= 0.1.1,                                 old-locale >= 1.0, time >= 1.1.4,                                 xml >= 1.3.5, hostname >= 1.0@@ -66,7 +66,6 @@                                 TypeOperators                                 FunctionalDependencies                                 MultiParamTypeClasses-                                ForeignFunctionInterface                  Ghc-Options:            -Wall         @@ -80,7 +79,7 @@                 Buildable:              False         else                 Build-Depends:          HUnit >= 1.2, QuickCheck >= 2.1.0.3,-                                        ansi-terminal >= 0.4.0, ansi-wl-pprint >= 0.4.0,+                                        ansi-terminal >= 0.4.0, ansi-wl-pprint >= 0.5.1,                                         regex-posix >= 0.72, extensible-exceptions >= 0.1.1,                                         old-locale >= 1.0, time >= 1.1.4,                                         xml >= 1.3.5, hostname >= 1.0,@@ -99,7 +98,6 @@                                         TypeOperators                                         FunctionalDependencies                                         MultiParamTypeClasses-                                        ForeignFunctionInterface                          Cpp-Options:            -DTEST