chell 0.2.5 → 0.3

raw patch · 5 files changed

+573/−316 lines, 5 filesdep ~textPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: text

API changes (from Hackage documentation)

Files

• chell.cabal +12/−11
• lib/Test/Chell.hs +179/−145
• lib/Test/Chell/Main.hs +69/−63
• lib/Test/Chell/Output.hs +37/−24
• lib/Test/Chell/Types.hs +276/−73

@@ -1,5 +1,5 @@ name: chell-version: 0.2.5+version: 0.3 license: MIT license-file: license.txt author: John Millikin <jmillikin@gmail.com>@@ -19,26 +19,27 @@   An example test suite, which verifies the behavior of artithmetic operators.   .   @-  &#x7b;-\# LANGUAGE OverloadedStrings \#-&#x7d;   &#x7b;-\# LANGUAGE TemplateHaskell \#-&#x7d;   .   import Test.Chell   .-  test_Math :: Suite-  test_Math = suite \"math\" [test_Addition, test_Subtraction]+  tests_Math :: Suite+  tests_Math = suite \"math\"+  &#x20;   test_Addition+  &#x20;   test_Subtraction   .-  test_Addition :: Suite+  test_Addition :: Test   test_Addition = assertions \"addition\" $ do   &#x20;   $expect (equal (2 + 1) 3)   &#x20;   $expect (equal (1 + 2) 3)   .-  test_Subtraction :: Suite+  test_Subtraction :: Test   test_Subtraction = assertions \"subtraction\" $ do   &#x20;   $expect (equal (2 - 1) 1)   &#x20;   $expect (equal (1 - 2) (-1))   .   main :: IO ()-  main = defaultMain [test_Math]+  main = defaultMain [tests_Math]   @   .   @@@ -49,12 +50,12 @@  source-repository head   type: bazaar-  location: https://john-millikin.com/branches/chell/0.2/+  location: https://john-millikin.com/branches/chell/0.3/  source-repository this   type: bazaar-  location: https://john-millikin.com/branches/chell/0.2/-  tag: chell_0.2.5+  location: https://john-millikin.com/branches/chell/0.3/+  tag: chell_0.3  flag color-output   description: Enable colored output in test results@@ -72,7 +73,7 @@     , random >= 1.0     , system-filepath >= 0.4 && < 0.5     , template-haskell >= 2.3-    , text >= 0.7+    , text     , transformers >= 0.2    if flag(color-output)

@@ -1,8 +1,40 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} +-- | Chell is a simple and intuitive library for automated testing. It natively+-- supports assertion-based testing, and can use companion libraries+-- such as @chell-quickcheck@ to support more complex testing strategies.+--+-- An example test suite, which verifies the behavior of artithmetic operators.+--+-- @+--{-\# LANGUAGE TemplateHaskell \#-}+--+--import Test.Chell+--+--tests_Math :: Suite+--tests_Math = 'suite' \"math\"+--    test_Addition+--    test_Subtraction+--+--test_Addition :: Test+--test_Addition = 'assertions' \"addition\" $ do+--    $'expect' ('equal' (2 + 1) 3)+--    $'expect' ('equal' (1 + 2) 3)+--+--test_Subtraction :: Test+--test_Subtraction = 'assertions' \"subtraction\" $ do+--    $'expect' ('equal' (2 - 1) 1)+--    $'expect' ('equal' (1 - 2) (-1))+--+--main :: IO ()+--main = 'defaultMain' [tests_Math]+-- @+--+-- >$ ghc --make chell-example.hs+-- >$ ./chell-example+-- >PASS: 2 tests run, 2 tests passed module Test.Chell 	( 	@@ -11,21 +43,25 @@ 	 	-- * Test suites 	, Suite-	, suite 	, suiteName 	, suiteTests-	, test+	+	-- ** Building test suites+	, BuildSuite+	, SuiteOrTest+	, suite+	+	-- ** Skipping some tests 	, skipIf 	, skipWhen 	 	-- * Basic testing library-	-- $doc-basic-testing-	, Assertion (..)-	, AssertionResult (..)-	, IsAssertion 	, Assertions 	, assertions-	, assertionsTest+	, IsAssertion+	, Assertion+	, assertionPassed+	, assertionFailed 	, assert 	, expect 	, die@@ -35,7 +71,7 @@ 	, requireLeft 	, requireRight 	-	-- ** Assertions+	-- ** Built-in assertions 	, equal 	, notEqual 	, equalWithin@@ -53,26 +89,37 @@ 	, equalItems 	, IsText 	, equalLines+	, equalLinesWith 	-	-- * Constructing tests-	, Test (..)+	-- * Custom test types+	, Test+	, test 	, testName 	, runTest 	+	-- ** Test results+	, TestResult (..)+	+	-- *** Failures+	, Failure+	, failure+	, failureLocation+	, failureMessage+	+	-- *** Failure locations+	, Location+	, location+	, locationFile+	, locationModule+	, locationLine+	+	-- ** Test options 	, TestOptions 	, defaultTestOptions 	, testOptionSeed 	, testOptionTimeout-	, TestResult (..)-	, Failure (..)-	, Location (..)-	-	-- * Deprecated-	, fail 	) where -import           Prelude hiding (fail)- import qualified Control.Applicative import qualified Control.Exception import           Control.Exception (Exception)@@ -88,67 +135,45 @@ import qualified Data.Text import           Data.Text (Text) import qualified Data.Text.Lazy-import qualified Data.Text.IO  import qualified Language.Haskell.TH as TH  import           Test.Chell.Main (defaultMain) import           Test.Chell.Types --- | Conditionally skip tests. Use this to avoid commenting out tests--- which are currently broken, or do not work on the current platform.------ @---tests = 'suite' \"tests\"---    [ 'skipIf' builtOnUnix test_WindowsSpecific---    ]--- @----skipIf :: Bool -> Suite -> Suite-skipIf skip = if skip then step else id where-	step (SuiteTest (Test name _)) = SuiteTest-		(Test name (\_ -> return TestSkipped))-	step (Suite name suites) = Suite name (map step suites)---- | Conditionally skip tests, depending on the result of a runtime check. The--- predicate is checked before each test is started.------ @---tests = 'suite' \"tests\"---    [ 'skipWhen' noNetwork test_PingGoogle---    ]--- @-skipWhen :: IO Bool -> Suite -> Suite-skipWhen p = step where-	step (SuiteTest (Test name io)) = SuiteTest (Test name (\opts -> do-		skip <- p-		if skip then return TestSkipped else io opts))-	step (Suite name suites) = Suite name (map step suites)---- $doc-basic-testing------ This library includes a few basic JUnit-style assertions, for use in--- simple test suites where depending on a separate test framework is too--- much trouble.+-- | A single pass/fail assertion. Failed assertions include an explanatory+-- message.+data Assertion+	= AssertionPassed+	| AssertionFailed String+	deriving (Eq, Show) -newtype Assertion = Assertion (IO AssertionResult)+-- | See 'Assertion'.+assertionPassed :: Assertion+assertionPassed = AssertionPassed -data AssertionResult-	= AssertionPassed-	| AssertionFailed Text+-- | See 'Assertion'.+assertionFailed :: String -> Assertion+assertionFailed = AssertionFailed +-- | See 'assert' and 'expect'. class IsAssertion a where-	toAssertion :: a -> Assertion+	runAssertion :: a -> IO Assertion  instance IsAssertion Assertion where-	toAssertion = id+	runAssertion = return  instance IsAssertion Bool where-	toAssertion x = Assertion (return (if x-		then AssertionPassed-		else AssertionFailed "$assert: boolean assertion failed"))+	runAssertion x = return $ if x+		then assertionPassed+		else assertionFailed "boolean assertion failed" -type TestState = (IORef [(Text, Text)], IORef [IO ()], [Failure])+instance IsAssertion a => IsAssertion (IO a) where+	runAssertion x = x >>= runAssertion++type TestState = (IORef [(String, String)], IORef [IO ()], [Failure])++-- | See 'assertions'. newtype Assertions a = Assertions { unAssertions :: TestState -> IO (Maybe a, TestState) }  instance Functor Assertions where@@ -174,25 +199,13 @@ -- | Convert a sequence of pass/fail assertions into a runnable test. -- -- @--- test_Equality :: Suite+-- test_Equality :: Test -- test_Equality = assertions \"equality\" $ do --     $assert (1 == 1) --     $assert (equal 1 1) -- @-assertions :: Text -> Assertions a -> Suite-assertions name io = test (assertionsTest name io)---- | Convert a sequence of pass/fail assertions into a runnable test.------ This is easier to use than 'assertions' when the result is going to be--- modified (eg, by a wrapper) before being used in a test suite.------ Most users should use 'assertions' instead, to avoid the extra wrapping--- step.------ Since: 0.2.3-assertionsTest :: Text -> Assertions a -> Test-assertionsTest name testm = Test name $ \opts -> do+assertions :: String -> Assertions a -> Test+assertions name testm = test name $ \opts -> do 	noteRef <- newIORef [] 	afterTestRef <- newIORef [] 	@@ -217,16 +230,20 @@ 	loop [] = return () 	loop (io:ios) = Control.Exception.finally (loop ios) io -addFailure :: Maybe TH.Loc -> Text -> Assertions ()+addFailure :: Maybe TH.Loc -> String -> Assertions () addFailure maybe_loc msg = Assertions $ \(notes, afterTestRef, fs) -> do 	let loc = do 		th_loc <- maybe_loc-		return $ Location-			{ locationFile = Data.Text.pack (TH.loc_filename th_loc)-			, locationModule = Data.Text.pack (TH.loc_module th_loc)-			, locationLine = toInteger (fst (TH.loc_start th_loc))+		return $ location+			{ locationFile = TH.loc_filename th_loc+			, locationModule = TH.loc_module th_loc+			, locationLine = Just (toInteger (fst (TH.loc_start th_loc))) 			}-	return (Just (), (notes, afterTestRef, Failure loc msg : fs))+	let f = failure+		{ failureLocation = loc+		, failureMessage = msg+		}+	return (Just (), (notes, afterTestRef, f : fs))  -- | Cause a test to immediately fail, with a message. --@@ -236,42 +253,50 @@ -- @ -- $die :: 'String' -> 'Assertions' a -- @------ Since: 0.2.4 die :: TH.Q TH.Exp die = do 	loc <- TH.location 	let qloc = liftLoc loc-	[| \msg -> dieAt $qloc (Data.Text.pack ("die: " ++ msg)) |]+	[| \msg -> dieAt $qloc ("die: " ++ msg) |] -dieAt :: TH.Loc -> Text -> Assertions a+dieAt :: TH.Loc -> String -> Assertions a dieAt loc msg = do 	addFailure (Just loc) msg 	Assertions (\s -> return (Nothing, s)) -{-# DEPRECATED fail "Test.Chell.fail is deprecated; use Test.Chell.die instead." #-}--- | Deprecated in 0.2.4: use 'die' instead.-fail :: TH.Q TH.Exp -- :: Text -> Assertions a-fail = do+-- | Print a message from within a test. This is just a helper for debugging,+-- so you don't have to import @Debug.Trace@. Messages will be prefixed with+-- the filename and line number where @$trace@ was called.+--+-- 'trace' is a Template Haskell macro, to retain the source-file location+-- from which it was used. Its effective type is:+--+-- @+-- $trace :: 'String' -> 'Assertions' ()+-- @+trace :: TH.Q TH.Exp+trace = do 	loc <- TH.location 	let qloc = liftLoc loc-	[| dieAt $qloc |]+	[| traceAt $qloc |] --- | Print a message from within a test. This is just a helper for debugging,--- so you don't have to import @Debug.Trace@.-trace :: Text -> Assertions ()-trace msg = liftIO (Data.Text.IO.putStrLn msg)+traceAt :: TH.Loc -> String -> Assertions ()+traceAt loc msg = liftIO $ do+	let file = TH.loc_filename loc+	let line = fst (TH.loc_start loc)+	putStr ("[" ++ file ++ ":" ++ show line ++ "] ")+	putStrLn msg --- | Attach metadata to a test run. This will be included in reports.-note :: Text -> Text -> Assertions ()+-- | Attach a note to a test run. Notes will be printed to stdout and+-- included in reports, even if the test fails or aborts. Notes are useful for+-- debugging failing tests.+note :: String -> String -> Assertions () note key value = Assertions (\(notes, afterTestRef, fs) -> do 	modifyIORef notes ((key, value) :) 	return (Just (), (notes, afterTestRef, fs)))  -- | Register an IO action to be run after the test completes. This action--- will run even if the test failed or threw an exception.------ Since: 0.2.3+-- will run even if the test failed or aborted. afterTest :: IO () -> Assertions () afterTest io = Assertions (\(notes, ref, fs) -> do 	modifyIORef ref (io :)@@ -286,8 +311,6 @@ -- @ -- $requireLeft :: 'Show' b => 'Either' a b -> 'Assertions' a -- @------ Since: 0.2.4 requireLeft :: TH.Q TH.Exp requireLeft = do 	loc <- TH.location@@ -299,7 +322,7 @@ 	Left a -> return a 	Right b -> do 		let dummy = Right b `asTypeOf` Left ()-		dieAt loc (Data.Text.pack ("requireLeft: received " ++ showsPrec 11 dummy ""))+		dieAt loc ("requireLeft: received " ++ showsPrec 11 dummy "")  -- | Require an 'Either' value to be 'Right', and return its contents. If -- the value is 'Left', fail the test.@@ -310,8 +333,6 @@ -- @ -- $requireRight :: 'Show' a => 'Either' a b -> 'Assertions' b -- @------ Since: 0.2.4 requireRight :: TH.Q TH.Exp requireRight = do 	loc <- TH.location@@ -322,7 +343,7 @@ requireRightAt loc val = case val of 	Left a -> do 		let dummy = Left a `asTypeOf` Right ()-		dieAt loc (Data.Text.pack ("requireRight: received " ++ showsPrec 11 dummy ""))+		dieAt loc ("requireRight: received " ++ showsPrec 11 dummy "") 	Right b -> return b  liftLoc :: TH.Loc -> TH.Q TH.Exp@@ -335,47 +356,52 @@  assertAt :: IsAssertion assertion => TH.Loc -> Bool -> assertion -> Assertions () assertAt loc fatal assertion = do-	let Assertion io = toAssertion assertion-	result <- liftIO io+	result <- liftIO (runAssertion assertion) 	case result of 		AssertionPassed -> return () 		AssertionFailed err -> if fatal 			then dieAt loc err 			else addFailure (Just loc) err --- | Run an 'Assertion'. If the assertion fails, the test will immediately+-- | Check an assertion. If the assertion fails, the test will immediately -- fail. --+-- The assertion to check can be a boolean value, an 'Assertion', or an IO+-- action returning one of the above.+-- -- 'assert' is a Template Haskell macro, to retain the source-file location -- from which it was used. Its effective type is: -- -- @ -- $assert :: 'IsAssertion' assertion => assertion -> 'Assertions' () -- @-assert :: TH.Q TH.Exp -- :: IsAssertion assertion => assertion -> Assertions ()+assert :: TH.Q TH.Exp assert = do 	loc <- TH.location 	let qloc = liftLoc loc 	[| assertAt $qloc True |] --- | Run an 'Assertion'. If the assertion fails, the test will continue to--- run until it finishes (or until an 'assert' fails).+-- | Check an assertion. If the assertion fails, the test will continue to+-- run until it finishes, a call to 'assert' fails, or the test runs 'die'. --+-- The assertion to check can be a boolean value, an 'Assertion', or an IO+-- action returning one of the above.+-- -- 'expect' is a Template Haskell macro, to retain the source-file location -- from which it was used. Its effective type is: -- -- @ -- $expect :: 'IsAssertion' assertion => assertion -> 'Assertions' () -- @-expect :: TH.Q TH.Exp -- :: IsAssertion assertion => assertion -> Assertions ()+expect :: TH.Q TH.Exp expect = do 	loc <- TH.location 	let qloc = liftLoc loc 	[| assertAt $qloc False |]  pure :: Bool -> String -> Assertion-pure True _ = Assertion (return AssertionPassed)-pure False err = Assertion (return (AssertionFailed (Data.Text.pack err)))+pure True  _   = assertionPassed+pure False err = AssertionFailed err  -- | Assert that two values are equal. equal :: (Show a, Eq a) => a -> a -> Assertion@@ -398,45 +424,45 @@ just x = pure (isJust x) ("just: received Nothing")  -- | Assert that some value is @Nothing@.-nothing :: Maybe a -> Assertion-nothing x = pure (isNothing x) ("nothing: received Just")+nothing :: Show a => Maybe a -> Assertion+nothing x = pure (isNothing x) ("nothing: received " ++ showsPrec 11 x "")  -- | Assert that some value is @Left@.-left :: Either a b -> Assertion-left x = pure (isLeft x) ("left: received Right") where-	isLeft (Left _) = True-	isLeft (Right _) = False+left :: Show b => Either a b -> Assertion+left (Left _) = assertionPassed+left (Right b) = assertionFailed ("left: received " ++ showsPrec 11 dummy "") where+	dummy = Right b `asTypeOf` Left ()  -- | Assert that some value is @Right@.-right :: Either a b -> Assertion-right x = pure (isRight x) ("right: received Left") where-	isRight (Left _) = False-	isRight (Right _) = True+right :: Show a => Either a b -> Assertion+right (Right _) = assertionPassed+right (Left a) = assertionFailed ("right: received " ++ showsPrec 11 dummy "") where+	dummy = Left a `asTypeOf` Right ()  -- | Assert that some computation throws an exception matching the provided -- predicate. This is mostly useful for exception types which do not have an -- instance for @Eq@, such as @'Control.Exception.ErrorCall'@.-throws :: Exception err => (err -> Bool) -> IO a -> Assertion-throws p io = Assertion (do+throws :: Exception err => (err -> Bool) -> IO a -> IO Assertion+throws p io = do 	either_exc <- Control.Exception.try io-	return (case either_exc of+	return $ case either_exc of 		Left exc -> if p exc-			then AssertionPassed-			else AssertionFailed (Data.Text.pack ("throws: exception " ++ show exc ++ " did not match predicate"))-		Right _ -> AssertionFailed (Data.Text.pack ("throws: no exception thrown"))))+			then assertionPassed+			else assertionFailed ("throws: exception " ++ show exc ++ " did not match predicate")+		Right _ -> assertionFailed "throws: no exception thrown"  -- | Assert that some computation throws an exception equal to the given -- exception. This is better than just checking that the correct type was -- thrown, because the test can also verify the exception contains the correct -- information.-throwsEq :: (Eq err, Exception err, Show err) => err -> IO a -> Assertion-throwsEq expected io = Assertion (do+throwsEq :: (Eq err, Exception err, Show err) => err -> IO a -> IO Assertion+throwsEq expected io = do 	either_exc <- Control.Exception.try io-	return (case either_exc of+	return $ case either_exc of 		Left exc -> if exc == expected-			then AssertionPassed-			else AssertionFailed (Data.Text.pack ("throwsEq: exception " ++ show exc ++ " is not equal to " ++ show expected))-		Right _ -> AssertionFailed (Data.Text.pack ("throwsEq: no exception thrown"))))+			then assertionPassed+			else assertionFailed ("throwsEq: exception " ++ show exc ++ " is not equal to " ++ show expected)+		Right _ -> assertionFailed "throwsEq: no exception thrown"  -- | Assert a value is greater than another. greater :: (Ord a, Show a) => a -> a -> Assertion@@ -484,7 +510,7 @@ 	 	errorMsg diff = label ++ ": items differ\n" ++ diff --- | Class for types which can be treated as text.+-- | Class for types which can be treated as text; see 'equalLines'. class IsText a where 	toLines :: a -> [a] 	unpack :: a -> String@@ -515,8 +541,16 @@ -- to check line-by-line, so the error message will be easier to read on -- large inputs. equalLines :: (Ord a, IsText a) => a -> a -> Assertion-equalLines x y = checkDiff (toLines x) (toLines y) where-	checkDiff xs ys = case checkItems (Patience.diff xs ys) of+equalLines x y = checkLinesDiff "equalLines" (toLines x) (toLines y)++-- | Variant of 'equalLines' which allows a user-specified line-splitting+-- predicate.+equalLinesWith :: Ord a => (a -> [String]) -> a -> a -> Assertion+equalLinesWith toStringLines x y = checkLinesDiff "equalLinesWith" (toStringLines x) (toStringLines y)++checkLinesDiff :: (Ord a, IsText a) => String -> [a] -> [a] -> Assertion+checkLinesDiff label = go where+	go xs ys = case checkItems (Patience.diff xs ys) of 		(same, diff) -> pure same diff 	 	checkItems diffItems = case foldl' checkItem (True, []) diffItems of@@ -527,4 +561,4 @@ 		Patience.New t -> (False, ("\t+ " ++ unpack t) : acc) 		Patience.Both t _-> (same, ("\t  " ++ unpack t) : acc) 	-	errorMsg diff = "equalLines: lines differ\n" ++ diff+	errorMsg diff = label ++ ": lines differ\n" ++ diff

@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}  module Test.Chell.Main@@ -9,14 +8,10 @@ import           Control.Monad.Trans.Class (lift) import qualified Control.Monad.Trans.State as State import qualified Control.Monad.Trans.Writer as Writer-import qualified Data.ByteString import           Data.Char (ord)-import qualified Data.Text-import           Data.Text (Text, pack)-import qualified Data.Text.Encoding-import qualified Data.Text.IO+import           Data.List (isPrefixOf) import           System.Exit (exitSuccess, exitFailure)-import qualified System.IO as IO+import           System.IO (hPutStr, hPutStrLn, hIsTerminalDevice, stderr, stdout, withBinaryFile, IOMode(..)) import           System.Random (randomIO) import           Text.Printf (printf) @@ -35,11 +30,11 @@ 		, optionDescription = "Print more output" 		}) 	-	pathOption "optXmlReport" "xml-report" ""+	pathOption "optXmlReport" "xml-report" Path.empty 		"Write a parsable report to a given path, in XML."-	pathOption "optJsonReport" "json-report" ""+	pathOption "optJsonReport" "json-report" Path.empty 		"Write a parsable report to a given path, in JSON."-	pathOption "optTextReport" "text-report" ""+	pathOption "optTextReport" "text-report" Path.empty 		"Write a human-readable report to a given path." 	 	option "optSeed" (\o -> o@@ -65,10 +60,11 @@ 			] 		, optionDefault = "auto" 		, optionDescription = "Whether to enable color ('always', 'auto', or 'never')."-		}))+		})+	)  -- | A simple default main function, which runs a list of tests and logs--- statistics to stderr.+-- statistics to stdout. defaultMain :: [Suite] -> IO () defaultMain suites = runCommand $ \opts args -> do 	-- validate/sanitize test options@@ -79,7 +75,7 @@ 		Nothing -> return Nothing 		Just t -> if toInteger t * 1000 > toInteger (maxBound :: Int) 			then do-				IO.hPutStrLn IO.stderr "Test.Chell.defaultMain: Ignoring --timeout because it is too large."+				hPutStrLn stderr "Test.Chell.defaultMain: Ignoring --timeout because it is too large." 				return Nothing 			else return (Just t) 	let testOptions = defaultTestOptions@@ -98,7 +94,7 @@ 		ColorModeNever -> return (plainOutput (optVerbose opts)) 		ColorModeAlways -> return (colorOutput (optVerbose opts)) 		ColorModeAuto -> do-			isTerm <- IO.hIsTerminalDevice IO.stdout+			isTerm <- hIsTerminalDevice stdout 			return $ if isTerm 				then colorOutput (optVerbose opts) 				else plainOutput (optVerbose opts)@@ -113,28 +109,25 @@ 	-- generate reports 	let reports = getReports opts 	forM_ reports $ \(path, fmt, toText) ->-		IO.withBinaryFile path IO.WriteMode $ \h -> do-			let text = toText results-			let bytes = Data.Text.Encoding.encodeUtf8 text+		withBinaryFile path WriteMode $ \h -> do 			when (optVerbose opts) $ do 				putStrLn ("Writing " ++ fmt ++ " report to " ++ show path)-			Data.ByteString.hPut h bytes+			hPutStr h (toText results) 	 	let stats = resultStatistics results 	let (_, _, failed, aborted) = stats-	Data.Text.IO.putStrLn (formatResultStatistics stats)+	putStrLn (formatResultStatistics stats) 	 	if failed == 0 && aborted == 0 		then exitSuccess 		else exitFailure  matchesFilter :: [String] -> Test -> Bool-matchesFilter strFilters = check where-	filters = map Data.Text.pack strFilters+matchesFilter filters = check where 	check t = any (matchName (testName t)) filters-	matchName name f = f == name || Data.Text.isPrefixOf (Data.Text.append f ".") name+	matchName name f = f == name || isPrefixOf (f ++ ".") name -type Report = [(Test, TestResult)] -> Text+type Report = [(Test, TestResult)] -> String  getReports :: MainOptions -> [(String, String, Report)] getReports opts = concat [xml, json, text] where@@ -148,7 +141,7 @@ 		p | Path.null p -> [] 		p -> [(Path.encodeString p, "text", textReport)] -jsonReport :: [(Test, TestResult)] -> Text+jsonReport :: [(Test, TestResult)] -> String jsonReport results = Writer.execWriter writer where 	tell = Writer.tell 	@@ -172,18 +165,21 @@ 			tell "{\"test\": \"" 			tell (escapeJSON (testName t)) 			tell "\", \"result\": \"failed\", \"failures\": ["-			commas fs $ \(Failure loc msg) -> do+			commas fs $ \f -> do 				tell "{\"message\": \""-				tell (escapeJSON msg)+				tell (escapeJSON (failureMessage f)) 				tell "\""-				case loc of-					Just loc' -> do+				case failureLocation f of+					Just loc -> do 						tell ", \"location\": {\"module\": \""-						tell (escapeJSON (locationModule loc'))+						tell (escapeJSON (locationModule loc)) 						tell "\", \"file\": \""-						tell (escapeJSON (locationFile loc'))-						tell "\", \"line\": "-						tell (pack (show (locationLine loc')))+						tell (escapeJSON (locationFile loc))+						case locationLine loc of+							Just line -> do+								tell "\", \"line\": "+								tell (show line)+							Nothing -> tell "\"" 						tell "}" 					Nothing -> return () 				tell "}"@@ -198,12 +194,13 @@ 			tell "\"}" 			tellNotes notes 			tell "}"+		_ -> return () 	-	escapeJSON = Data.Text.concatMap (\c -> case c of+	escapeJSON = concatMap (\c -> case c of 		'"' -> "\\\"" 		'\\' -> "\\\\"-		_ | ord c <= 0x1F -> pack (printf "\\u%04X" (ord c))-		_ -> Data.Text.singleton c)+		_ | ord c <= 0x1F -> printf "\\u%04X" (ord c)+		_ -> [c]) 	 	tellNotes notes = do 		tell ", \"notes\": ["@@ -225,7 +222,7 @@ 		State.put True 		lift (block x) -xmlReport :: [(Test, TestResult)] -> Text+xmlReport :: [(Test, TestResult)] -> String xmlReport results = Writer.execWriter writer where 	tell = Writer.tell 	@@ -250,18 +247,21 @@ 			tell "\t<test-run test='" 			tell (escapeXML (testName t)) 			tell "' result='failed'>\n"-			forM_ fs $ \(Failure loc msg) -> do+			forM_ fs $ \f -> do 				tell "\t\t<failure message='"-				tell (escapeXML msg)-				case loc of-					Just loc' -> do+				tell (escapeXML (failureMessage f))+				case failureLocation f of+					Just loc -> do 						tell "'>\n" 						tell "\t\t\t<location module='"-						tell (escapeXML (locationModule loc'))+						tell (escapeXML (locationModule loc)) 						tell "' file='"-						tell (escapeXML (locationFile loc'))-						tell "' line='"-						tell (pack (show (locationLine loc')))+						tell (escapeXML (locationFile loc))+						case locationLine loc of+							Just line -> do+								tell "' line='"+								tell (show line)+							Nothing -> return () 						tell "'/>\n" 						tell "\t\t</failure>\n" 					Nothing -> tell "'/>\n"@@ -276,14 +276,15 @@ 			tell "'/>\n" 			tellNotes notes 			tell "\t</test-run>\n"+		_ -> return () 	-	escapeXML = Data.Text.concatMap (\c -> case c of+	escapeXML = concatMap (\c -> case c of 		'&' -> "&amp;" 		'<' -> "&lt;" 		'>' -> "&gt;" 		'"' -> "&quot;" 		'\'' -> "&apos;"-		_ -> Data.Text.singleton c)+		_ -> [c]) 	 	tellNotes notes = forM_ notes $ \(key, value) -> do 		tell "\t\t<note key=\""@@ -292,7 +293,7 @@ 		tell (escapeXML value) 		tell "\"/>\n" -textReport :: [(Test, TestResult)] -> Text+textReport :: [(Test, TestResult)] -> String textReport results = Writer.execWriter writer where 	tell = Writer.tell 	@@ -303,7 +304,7 @@ 	 	tellResult (t, result) = case result of 		TestPassed notes -> do-			tell (Data.Text.replicate 70 "=")+			tell (replicate 70 '=') 			tell "\n" 			tell "PASSED: " 			tell (testName t)@@ -311,41 +312,45 @@ 			tellNotes notes 			tell "\n\n" 		TestSkipped -> do-			tell (Data.Text.replicate 70 "=")+			tell (replicate 70 '=') 			tell "\n" 			tell "SKIPPED: " 			tell (testName t) 			tell "\n\n" 		TestFailed notes fs -> do-			tell (Data.Text.replicate 70 "=")+			tell (replicate 70 '=') 			tell "\n" 			tell "FAILED: " 			tell (testName t) 			tell "\n" 			tellNotes notes-			tell (Data.Text.replicate 70 "-")+			tell (replicate 70 '-') 			tell "\n"-			forM_ fs $ \(Failure loc msg) -> do-				case loc of-					Just loc' -> do-						tell (locationFile loc')-						tell ":"-						tell (pack (show (locationLine loc')))+			forM_ fs $ \f -> do+				case failureLocation f of+					Just loc -> do+						tell (locationFile loc)+						case locationLine loc of+							Just line -> do+								tell ":"+								tell (show line)+							Nothing -> return () 						tell "\n" 					Nothing -> return ()-				tell msg+				tell (failureMessage f) 				tell "\n\n" 		TestAborted notes msg -> do-			tell (Data.Text.replicate 70 "=")+			tell (replicate 70 '=') 			tell "\n" 			tell "ABORTED: " 			tell (testName t) 			tell "\n" 			tellNotes notes-			tell (Data.Text.replicate 70 "-")+			tell (replicate 70 '-') 			tell "\n" 			tell msg 			tell "\n\n"+		_ -> return () 	 	tellNotes notes = forM_ notes $ \(key, value) -> do 		tell key@@ -353,7 +358,7 @@ 		tell value 		tell "\n" -formatResultStatistics :: (Integer, Integer, Integer, Integer) -> Text+formatResultStatistics :: (Integer, Integer, Integer, Integer) -> String formatResultStatistics stats = Writer.execWriter writer where 	writer = do 		let (passed, skipped, failed, aborted) = stats@@ -361,8 +366,8 @@ 			then Writer.tell "PASS: " 			else Writer.tell "FAIL: " 		let putNum comma n what = Writer.tell $ if n == 1-			then pack (comma ++ "1 test " ++ what)-			else pack (comma ++ show n ++ " tests " ++ what)+			then comma ++ "1 test " ++ what+			else comma ++ show n ++ " tests " ++ what 		 		let total = sum [passed, skipped, failed, aborted] 		putNum "" total "run"@@ -378,3 +383,4 @@ 		TestSkipped{} -> State.modify (\(p, s, f, a) -> (p, s+1, f, a)) 		TestFailed{} ->  State.modify (\(p, s, f, a) -> (p, s, f+1, a)) 		TestAborted{} -> State.modify (\(p, s, f, a) -> (p, s, f, a+1))+		_ -> return ()

@@ -1,14 +1,17 @@ {-# LANGUAGE CPP #-}  module Test.Chell.Output-	( Output(..)+	( Output+	, outputStart+	, outputResult+	+	, ColorMode(..)+	 	, plainOutput 	, colorOutput 	) where  import           Control.Monad (forM_, unless, when)-import           Data.Text (Text)-import qualified Data.Text.IO  #ifdef MIN_VERSION_ansi_terminal import qualified System.Console.ANSI as AnsiTerminal@@ -30,30 +33,37 @@ plainOutputStart :: Bool -> Test -> IO () plainOutputStart v t = when v $ do 	putStr "[ RUN   ] "-	Data.Text.IO.putStrLn (testName t)+	putStrLn (testName t)  plainOutputResult :: Bool -> Test -> TestResult -> IO () plainOutputResult v t (TestPassed _) = when v $ do 	putStr "[ PASS  ] "-	Data.Text.IO.putStrLn (testName t)+	putStrLn (testName t) 	putStrLn "" plainOutputResult v t TestSkipped = when v $ do 	putStr "[ SKIP  ] "-	Data.Text.IO.putStrLn (testName t)+	putStrLn (testName t) 	putStrLn "" plainOutputResult _ t (TestFailed notes fs) = do 	putStr "[ FAIL  ] "-	Data.Text.IO.putStrLn (testName t)+	putStrLn (testName t) 	printNotes notes 	printFailures fs plainOutputResult _ t (TestAborted notes msg) = do 	putStr "[ ABORT ] "-	Data.Text.IO.putStrLn (testName t)+	putStrLn (testName t) 	printNotes notes 	putStr "  "-	Data.Text.IO.putStr msg+	putStr msg 	putStrLn "\n"+plainOutputResult _ _ _ = return () +data ColorMode+	= ColorModeAuto+	| ColorModeAlways+	| ColorModeNever+	deriving (Enum)+ colorOutput :: Bool -> Output #ifndef MIN_VERSION_ansi_terminal colorOutput = plainOutput@@ -66,7 +76,7 @@ colorOutputStart :: Bool -> Test -> IO () colorOutputStart v t = when v $ do 	putStr "[ RUN   ] "-	Data.Text.IO.putStrLn (testName t)+	putStrLn (testName t)  colorOutputResult :: Bool -> Test -> TestResult -> IO () colorOutputResult v t (TestPassed _) = when v $ do@@ -79,7 +89,7 @@ 		[ AnsiTerminal.Reset 		] 	putStr "  ] "-	Data.Text.IO.putStrLn (testName t)+	putStrLn (testName t) 	putStrLn "" colorOutputResult v t TestSkipped = when v $ do 	putStr "[ "@@ -91,7 +101,7 @@ 		[ AnsiTerminal.Reset 		] 	putStr "  ] "-	Data.Text.IO.putStrLn (testName t)+	putStrLn (testName t) 	putStrLn "" colorOutputResult _ t (TestFailed notes fs) = do 	putStr "[ "@@ -103,7 +113,7 @@ 		[ AnsiTerminal.Reset 		] 	putStr "  ] "-	Data.Text.IO.putStrLn (testName t)+	putStrLn (testName t) 	printNotes notes 	printFailures fs colorOutputResult _ t (TestAborted notes msg) = do@@ -116,31 +126,34 @@ 		[ AnsiTerminal.Reset 		] 	putStr " ] "-	Data.Text.IO.putStrLn (testName t)+	putStrLn (testName t) 	printNotes notes 	putStr "  "-	Data.Text.IO.putStr msg+	putStr msg 	putStrLn "\n"+colorOutputResult _ _ _ = return () #endif -printNotes :: [(Text, Text)] -> IO ()+printNotes :: [(String, String)] -> IO () printNotes notes = unless (null notes) $ do 	forM_ notes $ \(key, value) -> do 		putStr "  note: "-		Data.Text.IO.putStr key+		putStr key 		putStr "="-		Data.Text.IO.putStrLn value+		putStrLn value 	putStrLn ""  printFailures :: [Failure] -> IO ()-printFailures fs = forM_ fs $ \(Failure loc msg) -> do+printFailures fs = forM_ fs $ \f -> do 	putStr "  "-	case loc of-		Just loc' -> do-			Data.Text.IO.putStr (locationFile loc')+	case failureLocation f of+		Just loc -> do+			putStr (locationFile loc) 			putStr ":"-			putStrLn (show (locationLine loc'))+			case locationLine loc of+				Just line -> putStrLn (show line)+				Nothing -> putStrLn "" 		Nothing -> return () 	putStr "  "-	Data.Text.IO.putStr msg+	putStr (failureMessage f) 	putStrLn "\n"

@@ -1,18 +1,62 @@-{-# LANGUAGE OverloadedStrings #-}--module Test.Chell.Types where+module Test.Chell.Types+	( Test+	, test+	, testName+	+	, TestOptions+	, defaultTestOptions+	, testOptionSeed+	, testOptionTimeout+	+	, TestResult(TestPassed, TestSkipped, TestFailed, TestAborted)+	+	, Failure+	, failure+	, failureLocation+	, failureMessage+	+	, Location+	, location+	, locationFile+	, locationModule+	, locationLine+	+	, Suite+	, suite+	, suiteName+	, suiteTests+	+	, BuildSuite+	, SuiteOrTest+	, skipIf+	, skipWhen+	+	, runTest+	+	, handleJankyIO+	) where  import qualified Control.Exception import           Control.Exception (SomeException, Handler(..), catches, throwIO)-import qualified Data.Text-import           Data.Text (Text) import           System.Timeout (timeout) -data Test = Test Text (TestOptions -> IO TestResult)+-- | A 'Test' is, essentially, an IO action that returns a 'TestResult'. Tests+-- are aggregated into suites (see 'Suite').+data Test = Test String (TestOptions -> IO TestResult)  instance Show Test where-	show (Test name _) = "<Test " ++ show name ++ ">"+	showsPrec d (Test name _) = showParen (d > 10) (showString "Test " . shows name) +-- | Define a test, with the given name and implementation.+test :: String -> (TestOptions -> IO TestResult) -> Test+test = Test++-- | Get the name a test was given when it was defined; see 'test'.+testName :: Test -> String+testName (Test name _) = name++-- | Test options are passed to each test, and control details about how the+-- test should be run. data TestOptions = TestOptions 	{ 	@@ -22,6 +66,9 @@ 	-- 	-- When using 'defaultMain', users may specify a seed using the 	-- @--seed@ command-line option.+	--+	-- 'testOptionSeed' is a field accessor, and can be used to update+	-- a 'TestOptions' value. 	  testOptionSeed :: Int 	 	-- | An optional timeout, in millseconds. Tests which run longer than@@ -29,40 +76,250 @@ 	-- 	-- When using 'defaultMain', users may specify a timeout using the 	-- @--timeout@ command-line option.+	--+	-- 'testOptionTimeout' is a field accessor, and can be used to update+	-- a 'TestOptions' value. 	, testOptionTimeout :: Maybe Int 	} 	deriving (Show, Eq)  -- | Default test options. ----- @---'testOptionSeed' defaultTestOptions = 0---'testOptionTimeout' defaultTestOptions = Nothing--- @------ Since: 0.2.3+-- >$ ghci+-- >Prelude> import Test.Chell+-- >+-- >Test.Chell> testOptionSeed defaultTestOptions+-- >0+-- >+-- >Test.Chell> testOptionTimeout defaultTestOptions+-- >Nothing defaultTestOptions :: TestOptions defaultTestOptions = TestOptions 	{ testOptionSeed = 0 	, testOptionTimeout = Nothing 	} --- | @testName (Test name _) = name@-testName :: Test -> Text-testName (Test name _) = name+-- | The result of running a test.+--+-- To support future extensions to the testing API, any users of this module+-- who pattern-match against the 'TestResult' constructors should include a+-- default case. If no default case is provided, a warning will be issued.+data TestResult+	-- | The test passed, and generated the given notes.+	= TestPassed [(String, String)]+	+	-- | The test did not run, because it was skipped with 'skipIf'+	-- or 'skipWhen'.+	| TestSkipped+	+	-- | The test failed, generating the given notes and failures.+	| TestFailed [(String, String)] [Failure]+	+	-- | The test aborted with an error message, and generated the given+	-- notes.+	| TestAborted [(String, String)] String+	+	-- Not exported; used to generate GHC warnings for users who don't+	-- provide a default case.+	| TestResultCaseMustHaveDefault+	deriving (Show, Eq) +-- | Contains details about a test failure.+data Failure = Failure+	{+	-- | If given, the location of the failing assertion, expectation,+	-- etc.+	--+	-- 'failureLocation' is a field accessor, and can be used to update+	-- a 'Failure' value.+	  failureLocation :: Maybe Location+	+	-- | If given, a message which explains why the test failed.+	--+	-- 'failureMessage' is a field accessor, and can be used to update+	-- a 'Failure' value.+	, failureMessage :: String+	}+	deriving (Show, Eq)++-- | An empty 'Failure'; use the field accessors to populate this value.+failure :: Failure+failure = Failure Nothing ""++-- | Contains details about a location in the test source file.+data Location = Location+	{+	-- | A path to a source file, or empty if not provided.+	--+	-- 'locationFile' is a field accessor, and can be used to update+	-- a 'Location' value.+	  locationFile :: String+	+	-- | A Haskell module name, or empty if not provided.+	--+	-- 'locationModule' is a field accessor, and can be used to update+	-- a 'Location' value.+	, locationModule :: String+	+	-- | A line number, or Nothing if not provided.+	--+	-- 'locationLine' is a field accessor, and can be used to update+	-- a 'Location' value.+	, locationLine :: Maybe Integer+	}+	deriving (Show, Eq)++-- | An empty 'Location'; use the field accessors to populate this value.+location :: Location+location = Location "" "" Nothing++-- | A suite is a node in a hierarchy of tests, similar to a directory in the+-- filesystem. Each suite has a name and a list of children, which are either+-- suites or tests.+data Suite = Suite String [SOT]+	deriving (Show)++data SOT+	= SOT_Suite Suite+	| SOT_Test Test++instance Show SOT where+	showsPrec d (SOT_Test t) = showsPrec d t+	showsPrec d (SOT_Suite s) = showsPrec d s++-- | See 'suite'.+class BuildSuite a where+	addChildren :: Suite -> a++instance BuildSuite Suite where+	addChildren (Suite name cs) = Suite name (reverse cs)++-- | See 'suite'.+class SuiteOrTest a where+	toSOT :: a -> SOT+	skipIf_ :: Bool -> a -> a+	skipWhen_ :: IO Bool -> a -> a++instance SuiteOrTest Suite where+	toSOT = SOT_Suite+	skipIf_ skip s@(Suite name children) = if skip+		then Suite name (map skipSOT children)+		else s+	skipWhen_ p (Suite name children) = Suite name (map (skipWhenSOT p) children)++instance SuiteOrTest Test where+	toSOT = SOT_Test+	skipIf_ skip t@(Test name _) = if skip+		then Test name (\_ -> return TestSkipped)+		else t+	skipWhen_ p (Test name io) = Test name (\opts -> do+		skip <- p+		if skip then return TestSkipped else io opts)++skipSOT :: SOT -> SOT+skipSOT (SOT_Test (Test name _)) = SOT_Test (Test name (\_ -> return TestSkipped))+skipSOT (SOT_Suite (Suite name cs)) = SOT_Suite (Suite name (map skipSOT cs))++skipWhenSOT :: IO Bool -> SOT -> SOT+skipWhenSOT p (SOT_Suite s) = SOT_Suite (skipWhen_ p s)+skipWhenSOT p (SOT_Test t) = SOT_Test (skipWhen_ p t)++-- | Conditionally skip tests. Use this to avoid commenting out tests+-- which are currently broken, or do not work on the current platform.+--+-- @+--tests :: Suite+--tests = 'suite' \"tests\"+--    test_Foo+--    ('skipIf' builtOnUnix test_WindowsSpecific)+--    test_Bar+-- @+--+skipIf :: SuiteOrTest a => Bool -> a -> a+skipIf = skipIf_++-- | Conditionally skip tests, depending on the result of a runtime check. The+-- predicate is checked before each test is started.+--+-- @+--tests :: Suite+--tests = 'suite' \"tests\"+--    test_Foo+--    ('skipWhen' noNetwork test_PingGoogle)+--    test_Bar+-- @+skipWhen :: SuiteOrTest a => IO Bool -> a -> a+skipWhen = skipWhen_++instance (SuiteOrTest t, BuildSuite s) => BuildSuite (t -> s) where+	addChildren (Suite name cs) = \b -> addChildren (Suite name (toSOT b : cs))++-- | Define a new 'Suite', with the given name and children.+--+-- The type of this function allows any number of children to be added,+-- without requiring them to be homogenous types.+--+-- @+--test_Addition :: Test+--test_Subtraction :: Test+--test_Show :: Test+--+--tests_Math :: Suite+--tests_Math = 'suite' \"math\"+--    test_Addition+--    test_Subtraction+--+--tests_Prelude :: Suite+--tests_Prelude = 'suite' \"prelude\"+--    tests_Math+--    test_Show+-- @+suite :: BuildSuite a => String -> a+suite name = addChildren (Suite name [])++-- | Get a suite's name. Suite names may be any string, but are typically+-- plain ASCII so users can easily type them on the command line.+--+-- >$ ghci chell-example.hs+-- >Ok, modules loaded: Main.+-- >+-- >*Main> suiteName tests_Math+-- >"math"+suiteName :: Suite -> String+suiteName (Suite name _) = name++-- | Get the full list of tests contained within this 'Suite'. Each test is+-- given its full name within the test hierarchy, where names are separated+-- by periods.+--+-- >$ ghci chell-example.hs+-- >Ok, modules loaded: Main.+-- >+-- >*Main> suiteTests tests_Math+-- >[Test "math.addition",Test "math.subtraction"]+suiteTests :: Suite -> [Test]+suiteTests = go "" where+	prefixed prefix str = if null prefix+		then str+		else prefix ++ "." ++ str+	+	go prefix (Suite name children) = concatMap (step (prefixed prefix name)) children+	+	step prefix (SOT_Suite s) = go prefix s+	step prefix (SOT_Test (Test name io)) = [Test (prefixed prefix name) io]+ -- | Run a test, wrapped in error handlers. This will return 'TestAborted' if -- the test throws an exception or times out. runTest :: Test -> TestOptions -> IO TestResult runTest (Test _ io) options = handleJankyIO options (io options) (return []) -handleJankyIO :: TestOptions -> IO TestResult -> IO [(Text, Text)] -> IO TestResult+handleJankyIO :: TestOptions -> IO TestResult -> IO [(String, String)] -> IO TestResult handleJankyIO opts getResult getNotes = do 	let withTimeout = case testOptionTimeout opts of 		Just time -> timeout (time * 1000) 		Nothing -> fmap Just 	-	let hitTimeout = Data.Text.pack str where+	let hitTimeout = str where 		str = "Test timed out after " ++ show time ++ " milliseconds" 		Just time = testOptionTimeout opts 	@@ -74,7 +331,7 @@ 			return (TestAborted notes hitTimeout) 		Just (Left err) -> do 			notes <- getNotes-			return (TestAborted notes (Data.Text.pack err))+			return (TestAborted notes err)  try :: IO a -> IO (Either String a) try io = catches (fmap Right io) [Handler handleAsync, Handler handleExc] where@@ -83,57 +340,3 @@ 	 	handleExc :: SomeException -> IO (Either String a) 	handleExc exc = return (Left ("Test aborted due to exception: " ++ show exc))--data TestResult-	= TestPassed [(Text, Text)]-	| TestSkipped-	| TestFailed [(Text, Text)] [Failure]-	| TestAborted [(Text, Text)] Text-	deriving (Show, Eq)--data Failure = Failure (Maybe Location) Text-	deriving (Show, Eq)--data Location = Location-	{ locationFile :: Text-	, locationModule :: Text-	, locationLine :: Integer-	}-	deriving (Show, Eq)--data ColorMode-	= ColorModeAuto-	| ColorModeAlways-	| ColorModeNever-	deriving (Enum)---- | A tree of 'Test's; use the 'test' and 'suite' helper functions to build--- up a 'Suite'.-data Suite = Suite Text [Suite]-           | SuiteTest Test--instance Show Suite where-	show s = "<Suite " ++ show (suiteName s) ++ ">"--test :: Test -> Suite-test = SuiteTest--suite :: Text -> [Suite] -> Suite-suite = Suite--suiteName :: Suite -> Text-suiteName (Suite name _) = name-suiteName (SuiteTest t) = testName t---- | The full list of 'Test's contained within this 'Suite'. Each 'Test'--- is returned with its name modified to include the name of its parent--- 'Suite's.-suiteTests :: Suite -> [Test]-suiteTests = loop "" where-	loop prefix s = let-		name = if Data.Text.null prefix-			then suiteName s-			else Data.Text.concat [prefix, ".", suiteName s]-		in case s of-			Suite _ suites -> concatMap (loop name) suites-			SuiteTest (Test _ io) -> [Test name io]