chell 0.4.0.1 → 0.4.0.2

raw patch · 9 files changed

+1436/−1437 lines, 9 filesdep ~ansi-terminalPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ansi-terminal

API changes (from Hackage documentation)

Files

• Test/Chell.hs +562/−0
• Test/Chell/Main.hs +392/−0
• Test/Chell/Output.hs +159/−0
• Test/Chell/Types.hs +319/−0
• chell.cabal +4/−5
• lib/Test/Chell.hs +0/−562
• lib/Test/Chell/Main.hs +0/−392
• lib/Test/Chell/Output.hs +0/−159
• lib/Test/Chell/Types.hs +0/−319

@@ -0,0 +1,562 @@+{-# 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+--+--suite_Math :: Suite+--suite_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' [suite_Math]+-- @+--+-- >$ ghc --make chell-example.hs+-- >$ ./chell-example+-- >PASS: 2 tests run, 2 tests passed+module Test.Chell+	(+	+	-- * Main+	  defaultMain+	+	-- * Test suites+	, Suite+	, suite+	, suiteName+	, suiteTests+	+	-- ** Skipping some tests+	, SuiteOrTest+	, skipIf+	, skipWhen+	+	-- * Basic testing library+	, Assertions+	, assertions+	, IsAssertion+	, Assertion+	, assertionPassed+	, assertionFailed+	, assert+	, expect+	, die+	, trace+	, note+	, afterTest+	, requireLeft+	, requireRight+	+	-- ** Built-in assertions+	, equal+	, notEqual+	, equalWithin+	, just+	, nothing+	, left+	, right+	, throws+	, throwsEq+	, greater+	, greaterEqual+	, lesser+	, lesserEqual+	, sameItems+	, equalItems+	, IsText+	, equalLines+	, equalLinesWith+	+	-- * 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+	) where++import qualified Control.Applicative+import qualified Control.Exception+import           Control.Exception (Exception)+import           Control.Monad (ap, liftM)+import           Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Data.Algorithm.Patience as Patience+import qualified Data.ByteString.Char8+import qualified Data.ByteString.Lazy.Char8+import           Data.Foldable (Foldable, foldMap)+import           Data.List (foldl', intercalate, sort)+import           Data.Maybe (isJust, isNothing)+import           Data.IORef (IORef, newIORef, readIORef, modifyIORef)+import qualified Data.Text+import           Data.Text (Text)+import qualified Data.Text.Lazy++import qualified Language.Haskell.TH as TH++import           Test.Chell.Main (defaultMain)+import           Test.Chell.Types++-- | A single pass/fail assertion. Failed assertions include an explanatory+-- message.+data Assertion+	= AssertionPassed+	| AssertionFailed String+	deriving (Eq, Show)++-- | See 'Assertion'.+assertionPassed :: Assertion+assertionPassed = AssertionPassed++-- | See 'Assertion'.+assertionFailed :: String -> Assertion+assertionFailed = AssertionFailed++-- | See 'assert' and 'expect'.+class IsAssertion a where+	runAssertion :: a -> IO Assertion++instance IsAssertion Assertion where+	runAssertion = return++instance IsAssertion Bool where+	runAssertion x = return $ if x+		then assertionPassed+		else assertionFailed "boolean assertion failed"++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+	fmap = liftM++instance Control.Applicative.Applicative Assertions where+	pure = return+	(<*>) = ap++instance Monad Assertions where+	return x = Assertions (\s -> return (Just x, s))+	m >>= f = Assertions (\s -> do+		(maybe_a, s') <- unAssertions m s+		case maybe_a of+			Nothing -> return (Nothing, s')+			Just a -> unAssertions (f a) s')++instance MonadIO Assertions where+	liftIO io = Assertions (\s -> do+		x <- io+		return (Just x, s))++-- | Convert a sequence of pass/fail assertions into a runnable test.+--+-- @+-- test_Equality :: Test+-- test_Equality = assertions \"equality\" $ do+--     $assert (1 == 1)+--     $assert (equal 1 1)+-- @+assertions :: String -> Assertions a -> Test+assertions name testm = test name $ \opts -> do+	noteRef <- newIORef []+	afterTestRef <- newIORef []+	+	let getNotes = fmap reverse (readIORef noteRef)+	+	let getResult = do+		res <- unAssertions testm (noteRef, afterTestRef, [])+		case res of+			(_, (_, _, [])) -> do+				notes <- getNotes+				return (TestPassed notes)+			(_, (_, _, fs)) -> do+				notes <- getNotes+				return (TestFailed notes (reverse fs))+	+	Control.Exception.finally+		(handleJankyIO opts getResult getNotes)+		(runAfterTest afterTestRef)++runAfterTest :: IORef [IO ()] -> IO ()+runAfterTest ref = readIORef ref >>= loop where+	loop [] = return ()+	loop (io:ios) = Control.Exception.finally (loop ios) io++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 = TH.loc_filename th_loc+			, locationModule = TH.loc_module th_loc+			, locationLine = Just (toInteger (fst (TH.loc_start th_loc)))+			}+	let f = failure+		{ failureLocation = loc+		, failureMessage = msg+		}+	return (Just (), (notes, afterTestRef, f : fs))++-- | Cause a test to immediately fail, with a message.+--+-- 'die' is a Template Haskell macro, to retain the source-file location from+-- which it was used. Its effective type is:+--+-- @+-- $die :: 'String' -> 'Assertions' a+-- @+die :: TH.Q TH.Exp+die = do+	loc <- TH.location+	let qloc = liftLoc loc+	[| \msg -> dieAt $qloc ("die: " ++ msg) |]++dieAt :: TH.Loc -> String -> Assertions a+dieAt loc msg = do+	addFailure (Just loc) msg+	Assertions (\s -> return (Nothing, s))++-- | 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+	[| traceAt $qloc |]++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 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 aborted.+afterTest :: IO () -> Assertions ()+afterTest io = Assertions (\(notes, ref, fs) -> do+	modifyIORef ref (io :)+	return (Just (), (notes, ref, fs)))++-- | Require an 'Either' value to be 'Left', and return its contents. If+-- the value is 'Right', fail the test.+--+-- 'requireLeft' is a Template Haskell macro, to retain the source-file+-- location from which it was used. Its effective type is:+--+-- @+-- $requireLeft :: 'Show' b => 'Either' a b -> 'Assertions' a+-- @+requireLeft :: TH.Q TH.Exp+requireLeft = do+	loc <- TH.location+	let qloc = liftLoc loc+	[| requireLeftAt $qloc |]++requireLeftAt :: Show b => TH.Loc -> Either a b -> Assertions a+requireLeftAt loc val = case val of+	Left a -> return a+	Right b -> do+		let dummy = Right b `asTypeOf` Left ()+		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.+--+-- 'requireRight' is a Template Haskell macro, to retain the source-file+-- location from which it was used. Its effective type is:+--+-- @+-- $requireRight :: 'Show' a => 'Either' a b -> 'Assertions' b+-- @+requireRight :: TH.Q TH.Exp+requireRight = do+	loc <- TH.location+	let qloc = liftLoc loc+	[| requireRightAt $qloc |]++requireRightAt :: Show a => TH.Loc -> Either a b -> Assertions b+requireRightAt loc val = case val of+	Left a -> do+		let dummy = Left a `asTypeOf` Right ()+		dieAt loc ("requireRight: received " ++ showsPrec 11 dummy "")+	Right b -> return b++liftLoc :: TH.Loc -> TH.Q TH.Exp+liftLoc loc = [| TH.Loc filename package module_ start end |] where+	filename = TH.loc_filename loc+	package = TH.loc_package loc+	module_ = TH.loc_module loc+	start = TH.loc_start loc+	end = TH.loc_end loc++assertAt :: IsAssertion assertion => TH.Loc -> Bool -> assertion -> Assertions ()+assertAt loc fatal assertion = do+	result <- liftIO (runAssertion assertion)+	case result of+		AssertionPassed -> return ()+		AssertionFailed err -> if fatal+			then dieAt loc err+			else addFailure (Just loc) err++-- | 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+assert = do+	loc <- TH.location+	let qloc = liftLoc loc+	[| assertAt $qloc True |]++-- | 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+expect = do+	loc <- TH.location+	let qloc = liftLoc loc+	[| assertAt $qloc False |]++assertBool :: Bool -> String -> Assertion+assertBool True  _   = assertionPassed+assertBool False err = AssertionFailed err++-- | Assert that two values are equal.+equal :: (Show a, Eq a) => a -> a -> Assertion+equal x y = assertBool (x == y) ("equal: " ++ show x ++ " is not equal to " ++ show y)++-- | Assert that two values are not equal.+notEqual :: (Eq a, Show a) => a -> a -> Assertion+notEqual x y = assertBool (x /= y) ("notEqual: " ++ show x ++ " is equal to " ++ show y)++-- | Assert that two values are within some delta of each other.+equalWithin :: (Real a, Show a) => a -> a+                                -> a -- ^ delta+                                -> Assertion+equalWithin x y delta = assertBool +	((x - delta <= y) && (x + delta >= y))+	("equalWithin: " ++ show x ++ " is not within " ++ show delta ++ " of " ++ show y)++-- | Assert that some value is @Just@.+just :: Maybe a -> Assertion+just x = assertBool (isJust x) ("just: received Nothing")++-- | Assert that some value is @Nothing@.+nothing :: Show a => Maybe a -> Assertion+nothing x = assertBool (isNothing x) ("nothing: received " ++ showsPrec 11 x "")++-- | Assert that some value is @Left@.+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 :: 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 -> IO Assertion+throws p io = do+	either_exc <- Control.Exception.try io+	return $ case either_exc of+		Left exc -> if p exc+			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 -> IO Assertion+throwsEq expected io = do+	either_exc <- Control.Exception.try io+	return $ case either_exc of+		Left exc -> if exc == expected+			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+greater x y = assertBool (x > y) ("greater: " ++ show x ++ " is not greater than " ++ show y)++-- | Assert a value is greater than or equal to another.+greaterEqual :: (Ord a, Show a) => a -> a -> Assertion+greaterEqual x y = assertBool (x >= y) ("greaterEqual: " ++ show x ++ " is not greater than or equal to " ++ show y)++-- | Assert a value is less than another.+lesser :: (Ord a, Show a) => a -> a -> Assertion+lesser x y = assertBool (x < y) ("lesser: " ++ show x ++ " is not less than " ++ show y)++-- | Assert a value is less than or equal to another.+lesserEqual :: (Ord a, Show a) => a -> a -> Assertion+lesserEqual x y = assertBool (x <= y) ("lesserEqual: " ++ show x ++ " is not less than or equal to " ++ show y)++-- | Assert that two containers have the same items, in any order.+sameItems :: (Foldable container, Show item, Ord item) => container item -> container item -> Assertion+sameItems x y = equalDiff' "sameItems" sort x y++-- | Assert that two containers have the same items, in the same order.+equalItems :: (Foldable container, Show item, Ord item) => container item -> container item -> Assertion+equalItems x y = equalDiff' "equalItems" id x y++equalDiff' :: (Foldable container, Show item, Ord item)+           => String+           -> ([item]+           -> [item])+           -> container item+           -> container item+           -> Assertion+equalDiff' label norm x y = checkDiff (items x) (items y) where+	items = norm . foldMap (:[])+	checkDiff xs ys = case checkItems (Patience.diff xs ys) of+		(same, diff) -> assertBool same diff+	+	checkItems diffItems = case foldl' checkItem (True, []) diffItems of+		(same, diff) -> (same, errorMsg (intercalate "\n" (reverse diff)))+	+	checkItem (same, acc) item = case item of+		Patience.Old t -> (False, ("\t- " ++ show t) : acc)+		Patience.New t -> (False, ("\t+ " ++ show t) : acc)+		Patience.Both t _-> (same, ("\t  " ++ show t) : acc)+	+	errorMsg diff = label ++ ": items differ\n" ++ diff++-- | Class for types which can be treated as text; see 'equalLines'.+class IsText a where+	toLines :: a -> [a]+	unpack :: a -> String++instance IsText String where+	toLines = lines+	unpack = id++instance IsText Text where+	toLines = Data.Text.lines+	unpack = Data.Text.unpack++instance IsText Data.Text.Lazy.Text where+	toLines = Data.Text.Lazy.lines+	unpack = Data.Text.Lazy.unpack++-- | Uses @Data.ByteString.Char8@+instance IsText Data.ByteString.Char8.ByteString where+	toLines = Data.ByteString.Char8.lines+	unpack = Data.ByteString.Char8.unpack++-- | Uses @Data.ByteString.Lazy.Char8@+instance IsText Data.ByteString.Lazy.Char8.ByteString where+	toLines = Data.ByteString.Lazy.Char8.lines+	unpack = Data.ByteString.Lazy.Char8.unpack++-- | Assert that two pieces of text are equal. This uses a diff algorithm+-- 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 = 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) -> assertBool same diff+	+	checkItems diffItems = case foldl' checkItem (True, []) diffItems of+		(same, diff) -> (same, errorMsg (intercalate "\n" (reverse diff)))+	+	checkItem (same, acc) item = case item of+		Patience.Old t -> (False, ("\t- " ++ unpack t) : acc)+		Patience.New t -> (False, ("\t+ " ++ unpack t) : acc)+		Patience.Both t _-> (same, ("\t  " ++ unpack t) : acc)+	+	errorMsg diff = label ++ ": lines differ\n" ++ diff

@@ -0,0 +1,392 @@+module Test.Chell.Main+	( defaultMain+	) where++import           Control.Applicative+import           Control.Monad (forM, forM_, when)+import           Control.Monad.Trans.Class (lift)+import qualified Control.Monad.Trans.State as State+import qualified Control.Monad.Trans.Writer as Writer+import           Data.Char (ord)+import           Data.List (isPrefixOf)+import           System.Exit (exitSuccess, exitFailure)+import           System.IO (hPutStr, hPutStrLn, hIsTerminalDevice, stderr, stdout, withBinaryFile, IOMode(..))+import           System.Random (randomIO)+import           Text.Printf (printf)++import           Options++import           Test.Chell.Output+import           Test.Chell.Types++data MainOptions = MainOptions+	{ optVerbose :: Bool+	, optXmlReport :: String+	, optJsonReport :: String+	, optTextReport :: String+	, optSeed :: Maybe Int+	, optTimeout :: Maybe Int+	, optColor :: ColorMode+	}++optionType_ColorMode :: OptionType ColorMode+optionType_ColorMode = optionType "ColorMode" ColorModeAuto parseMode showMode where+	parseMode s = case s of+		"always" -> Right ColorModeAlways+		"never" -> Right ColorModeNever+		"auto" -> Right ColorModeAuto+		_ -> Left (show s ++ " is not in {\"always\", \"never\", \"auto\"}.")+	showMode mode = case mode of+		ColorModeAlways -> "always"+		ColorModeNever -> "never"+		ColorModeAuto -> "auto"++instance Options MainOptions where+	defineOptions = pure MainOptions+		<*> defineOption optionType_bool (\o -> o+			{ optionShortFlags = ['v']+			, optionLongFlags = ["verbose"]+			, optionDefault = False+			, optionDescription = "Print more output."+			})+		+		<*> simpleOption "xml-report" ""+		    "Write a parsable report to a given path, in XML."+		<*> simpleOption "json-report" ""+		    "Write a parsable report to a given path, in JSON."+		<*> simpleOption "text-report" ""+		    "Write a human-readable report to a given path."+		+		<*> simpleOption "seed" Nothing+		    "The seed used for random numbers in (for example) quickcheck."+		+		<*> simpleOption "timeout" Nothing+		    "The maximum duration of a test, in milliseconds."+		+		<*> defineOption optionType_ColorMode (\o -> o+			{ optionLongFlags = ["color"]+			, optionDefault = ColorModeAuto+			, optionDescription = "Whether to enable color ('always', 'auto', or 'never')."+			})++-- | A simple default main function, which runs a list of tests and logs+-- statistics to stdout.+defaultMain :: [Suite] -> IO ()+defaultMain suites = runCommand $ \opts args -> do+	-- validate/sanitize test options+	seed <- case optSeed opts of+		Just s -> return s+		Nothing -> randomIO+	timeout <- case optTimeout opts of+		Nothing -> return Nothing+		Just t -> if toInteger t * 1000 > toInteger (maxBound :: Int)+			then do+				hPutStrLn stderr "Test.Chell.defaultMain: Ignoring --timeout because it is too large."+				return Nothing+			else return (Just t)+	let testOptions = defaultTestOptions+		{ testOptionSeed = seed+		, testOptionTimeout = timeout+		}+	+	-- find which tests to run+	let allTests = concatMap suiteTests suites+	let tests = if null args+		then allTests+		else filter (matchesFilter args) allTests+	+	-- output mode+	output <- case optColor opts of+		ColorModeNever -> return (plainOutput (optVerbose opts))+		ColorModeAlways -> return (colorOutput (optVerbose opts))+		ColorModeAuto -> do+			isTerm <- hIsTerminalDevice stdout+			return $ if isTerm+				then colorOutput (optVerbose opts)+				else plainOutput (optVerbose opts)+	+	-- run tests+	results <- forM tests $ \t -> do+		outputStart output t+		result <- runTest t testOptions+		outputResult output t result+		return (t, result)+	+	-- generate reports+	let reports = getReports opts+	forM_ reports $ \(path, fmt, toText) ->+		withBinaryFile path WriteMode $ \h -> do+			when (optVerbose opts) $ do+				putStrLn ("Writing " ++ fmt ++ " report to " ++ show path)+			hPutStr h (toText results)+	+	let stats = resultStatistics results+	let (_, _, failed, aborted) = stats+	putStrLn (formatResultStatistics stats)+	+	if failed == 0 && aborted == 0+		then exitSuccess+		else exitFailure++matchesFilter :: [String] -> Test -> Bool+matchesFilter filters = check where+	check t = any (matchName (testName t)) filters+	matchName name f = f == name || isPrefixOf (f ++ ".") name++type Report = [(Test, TestResult)] -> String++getReports :: MainOptions -> [(String, String, Report)]+getReports opts = concat [xml, json, text] where+	xml = case optXmlReport opts of+		"" -> []+		path -> [(path, "XML", xmlReport)]+	json = case optJsonReport opts of+		"" -> []+		path -> [(path, "JSON", jsonReport)]+	text = case optTextReport opts of+		"" -> []+		path -> [(path, "text", textReport)]++jsonReport :: [(Test, TestResult)] -> String+jsonReport results = Writer.execWriter writer where+	tell = Writer.tell+	+	writer = do+		tell "{\"test-runs\": ["+		commas results tellResult+		tell "]}"+	+	tellResult (t, result) = case result of+		TestPassed notes -> do+			tell "{\"test\": \""+			tell (escapeJSON (testName t))+			tell "\", \"result\": \"passed\""+			tellNotes notes+			tell "}"+		TestSkipped -> do+			tell "{\"test\": \""+			tell (escapeJSON (testName t))+			tell "\", \"result\": \"skipped\"}"+		TestFailed notes fs -> do+			tell "{\"test\": \""+			tell (escapeJSON (testName t))+			tell "\", \"result\": \"failed\", \"failures\": ["+			commas fs $ \f -> do+				tell "{\"message\": \""+				tell (escapeJSON (failureMessage f))+				tell "\""+				case failureLocation f of+					Just loc -> do+						tell ", \"location\": {\"module\": \""+						tell (escapeJSON (locationModule loc))+						tell "\", \"file\": \""+						tell (escapeJSON (locationFile loc))+						case locationLine loc of+							Just line -> do+								tell "\", \"line\": "+								tell (show line)+							Nothing -> tell "\""+						tell "}"+					Nothing -> return ()+				tell "}"+			tell "]"+			tellNotes notes+			tell "}"+		TestAborted notes msg -> do+			tell "{\"test\": \""+			tell (escapeJSON (testName t))+			tell "\", \"result\": \"aborted\", \"abortion\": {\"message\": \""+			tell (escapeJSON msg)+			tell "\"}"+			tellNotes notes+			tell "}"+		_ -> return ()+	+	escapeJSON = concatMap (\c -> case c of+		'"' -> "\\\""+		'\\' -> "\\\\"+		_ | ord c <= 0x1F -> printf "\\u%04X" (ord c)+		_ -> [c])+	+	tellNotes notes = do+		tell ", \"notes\": ["+		commas notes $ \(key, value) -> do+			tell "{\"key\": \""+			tell (escapeJSON key)+			tell "\", \"value\": \""+			tell (escapeJSON value)+			tell "\"}"+		tell "]"+	+	commas xs block = State.evalStateT (commaState xs block) False+	commaState xs block = forM_ xs $ \x -> do+		let tell' = lift . Writer.tell+		needComma <- State.get+		if needComma+			then tell' "\n, "+			else tell' "\n  "+		State.put True+		lift (block x)++xmlReport :: [(Test, TestResult)] -> String+xmlReport results = Writer.execWriter writer where+	tell = Writer.tell+	+	writer = do+		tell "<?xml version=\"1.0\" encoding=\"utf8\"?>\n"+		tell "<report xmlns='urn:john-millikin:chell:report:1'>\n"+		mapM_ tellResult results+		tell "</report>"+	+	tellResult (t, result) = case result of+		TestPassed notes -> do+			tell "\t<test-run test='"+			tell (escapeXML (testName t))+			tell "' result='passed'>\n"+			tellNotes notes+			tell "\t</test-run>\n"+		TestSkipped -> do+			tell "\t<test-run test='"+			tell (escapeXML (testName t))+			tell "' result='skipped'/>\n"+		TestFailed notes fs -> do+			tell "\t<test-run test='"+			tell (escapeXML (testName t))+			tell "' result='failed'>\n"+			forM_ fs $ \f -> do+				tell "\t\t<failure message='"+				tell (escapeXML (failureMessage f))+				case failureLocation f of+					Just loc -> do+						tell "'>\n"+						tell "\t\t\t<location module='"+						tell (escapeXML (locationModule loc))+						tell "' file='"+						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"+			tellNotes notes+			tell "\t</test-run>\n"+		TestAborted notes msg -> do+			tell "\t<test-run test='"+			tell (escapeXML (testName t))+			tell "' result='aborted'>\n"+			tell "\t\t<abortion message='"+			tell (escapeXML msg)+			tell "'/>\n"+			tellNotes notes+			tell "\t</test-run>\n"+		_ -> return ()+	+	escapeXML = concatMap (\c -> case c of+		'&' -> "&amp;"+		'<' -> "&lt;"+		'>' -> "&gt;"+		'"' -> "&quot;"+		'\'' -> "&apos;"+		_ -> [c])+	+	tellNotes notes = forM_ notes $ \(key, value) -> do+		tell "\t\t<note key=\""+		tell (escapeXML key)+		tell "\" value=\""+		tell (escapeXML value)+		tell "\"/>\n"++textReport :: [(Test, TestResult)] -> String+textReport results = Writer.execWriter writer where+	tell = Writer.tell+	+	writer = do+		forM_ results tellResult+		let stats = resultStatistics results+		tell (formatResultStatistics stats)+	+	tellResult (t, result) = case result of+		TestPassed notes -> do+			tell (replicate 70 '=')+			tell "\n"+			tell "PASSED: "+			tell (testName t)+			tell "\n"+			tellNotes notes+			tell "\n\n"+		TestSkipped -> do+			tell (replicate 70 '=')+			tell "\n"+			tell "SKIPPED: "+			tell (testName t)+			tell "\n\n"+		TestFailed notes fs -> do+			tell (replicate 70 '=')+			tell "\n"+			tell "FAILED: "+			tell (testName t)+			tell "\n"+			tellNotes notes+			tell (replicate 70 '-')+			tell "\n"+			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 (failureMessage f)+				tell "\n\n"+		TestAborted notes msg -> do+			tell (replicate 70 '=')+			tell "\n"+			tell "ABORTED: "+			tell (testName t)+			tell "\n"+			tellNotes notes+			tell (replicate 70 '-')+			tell "\n"+			tell msg+			tell "\n\n"+		_ -> return ()+	+	tellNotes notes = forM_ notes $ \(key, value) -> do+		tell key+		tell "="+		tell value+		tell "\n"++formatResultStatistics :: (Integer, Integer, Integer, Integer) -> String+formatResultStatistics stats = Writer.execWriter writer where+	writer = do+		let (passed, skipped, failed, aborted) = stats+		if failed == 0 && aborted == 0+			then Writer.tell "PASS: "+			else Writer.tell "FAIL: "+		let putNum comma n what = Writer.tell $ if n == 1+			then comma ++ "1 test " ++ what+			else comma ++ show n ++ " tests " ++ what+		+		let total = sum [passed, skipped, failed, aborted]+		putNum "" total "run"+		(putNum ", " passed "passed")+		when (skipped > 0) (putNum ", " skipped "skipped")+		when (failed > 0) (putNum ", " failed "failed")+		when (aborted > 0) (putNum ", " aborted "aborted")++resultStatistics :: [(Test, TestResult)] -> (Integer, Integer, Integer, Integer)+resultStatistics results = State.execState state (0, 0, 0, 0) where+	state = forM_ results $ \(_, result) -> case result of+		TestPassed{} ->  State.modify (\(p, s, f, a) -> (p+1, s, f, a))+		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 ()

@@ -0,0 +1,159 @@+{-# LANGUAGE CPP #-}++module Test.Chell.Output+	( Output+	, outputStart+	, outputResult+	+	, ColorMode(..)+	+	, plainOutput+	, colorOutput+	) where++import           Control.Monad (forM_, unless, when)++#ifdef MIN_VERSION_ansi_terminal+import qualified System.Console.ANSI as AnsiTerminal+#endif++import           Test.Chell.Types++data Output = Output+	{ outputStart :: Test -> IO ()+	, outputResult :: Test -> TestResult -> IO ()+	}++plainOutput :: Bool -> Output+plainOutput v = Output+	{ outputStart = plainOutputStart v+	, outputResult = plainOutputResult v+	}++plainOutputStart :: Bool -> Test -> IO ()+plainOutputStart v t = when v $ do+	putStr "[ RUN   ] "+	putStrLn (testName t)++plainOutputResult :: Bool -> Test -> TestResult -> IO ()+plainOutputResult v t (TestPassed _) = when v $ do+	putStr "[ PASS  ] "+	putStrLn (testName t)+	putStrLn ""+plainOutputResult v t TestSkipped = when v $ do+	putStr "[ SKIP  ] "+	putStrLn (testName t)+	putStrLn ""+plainOutputResult _ t (TestFailed notes fs) = do+	putStr "[ FAIL  ] "+	putStrLn (testName t)+	printNotes notes+	printFailures fs+plainOutputResult _ t (TestAborted notes msg) = do+	putStr "[ ABORT ] "+	putStrLn (testName t)+	printNotes notes+	putStr "  "+	putStr msg+	putStrLn "\n"+plainOutputResult _ _ _ = return ()++data ColorMode+	= ColorModeAuto+	| ColorModeAlways+	| ColorModeNever+	deriving (Enum)++colorOutput :: Bool -> Output+#ifndef MIN_VERSION_ansi_terminal+colorOutput = plainOutput+#else+colorOutput v = Output+	{ outputStart = colorOutputStart v+	, outputResult = colorOutputResult v+	}++colorOutputStart :: Bool -> Test -> IO ()+colorOutputStart v t = when v $ do+	putStr "[ RUN   ] "+	putStrLn (testName t)++colorOutputResult :: Bool -> Test -> TestResult -> IO ()+colorOutputResult v t (TestPassed _) = when v $ do+	putStr "[ "+	AnsiTerminal.setSGR+		[ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Green+		]+	putStr "PASS"+	AnsiTerminal.setSGR+		[ AnsiTerminal.Reset+		]+	putStr "  ] "+	putStrLn (testName t)+	putStrLn ""+colorOutputResult v t TestSkipped = when v $ do+	putStr "[ "+	AnsiTerminal.setSGR+		[ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Yellow+		]+	putStr "SKIP"+	AnsiTerminal.setSGR+		[ AnsiTerminal.Reset+		]+	putStr "  ] "+	putStrLn (testName t)+	putStrLn ""+colorOutputResult _ t (TestFailed notes fs) = do+	putStr "[ "+	AnsiTerminal.setSGR+		[ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Red+		]+	putStr "FAIL"+	AnsiTerminal.setSGR+		[ AnsiTerminal.Reset+		]+	putStr "  ] "+	putStrLn (testName t)+	printNotes notes+	printFailures fs+colorOutputResult _ t (TestAborted notes msg) = do+	putStr "[ "+	AnsiTerminal.setSGR+		[ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Red+		]+	putStr "ABORT"+	AnsiTerminal.setSGR+		[ AnsiTerminal.Reset+		]+	putStr " ] "+	putStrLn (testName t)+	printNotes notes+	putStr "  "+	putStr msg+	putStrLn "\n"+colorOutputResult _ _ _ = return ()+#endif++printNotes :: [(String, String)] -> IO ()+printNotes notes = unless (null notes) $ do+	forM_ notes $ \(key, value) -> do+		putStr "  note: "+		putStr key+		putStr "="+		putStrLn value+	putStrLn ""++printFailures :: [Failure] -> IO ()+printFailures fs = forM_ fs $ \f -> do+	putStr "  "+	case failureLocation f of+		Just loc -> do+			putStr (locationFile loc)+			putStr ":"+			case locationLine loc of+				Just line -> putStrLn (show line)+				Nothing -> putStrLn ""+		Nothing -> return ()+	putStr "  "+	putStr (failureMessage f)+	putStrLn "\n"

@@ -0,0 +1,319 @@+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+	+	, SuiteOrTest+	, skipIf+	, skipWhen+	+	, runTest+	+	, handleJankyIO+	) where++import qualified Control.Exception+import           Control.Exception (SomeException, Handler(..), catches, throwIO)+import           System.Timeout (timeout)++-- | 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+	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+	{+	+	-- | Get the RNG seed for this test run. The seed is generated once, in+	-- 'defaultMain', and used for all tests. It is also logged to reports+	-- using a note.+	--+	-- 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+	-- this timeout will be aborted.+	--+	-- 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.+--+-- >$ ghci+-- >Prelude> import Test.Chell+-- >+-- >Test.Chell> testOptionSeed defaultTestOptions+-- >0+-- >+-- >Test.Chell> testOptionTimeout defaultTestOptions+-- >Nothing+defaultTestOptions :: TestOptions+defaultTestOptions = TestOptions+	{ testOptionSeed = 0+	, testOptionTimeout = Nothing+	}++-- | 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 named collection of tests.+--+-- Note: earlier versions of Chell permitted arbitrary nesting of test suites.+-- This feature proved too unwieldy, and was removed. A similar result can be+-- achieved with 'suiteTests'; see the documentation for 'suite'.+data Suite = Suite String [Test]+	deriving (Show)++class SuiteOrTest a where+	skipIf_ :: Bool -> a -> a+	skipWhen_ :: IO Bool -> a -> a++instance SuiteOrTest Suite where+	skipIf_ skip s@(Suite name children) = if skip+		then Suite name (map (skipIf_ skip) children)+		else s+	skipWhen_ p (Suite name children) = Suite name (map (skipWhen_ p) children)++instance SuiteOrTest Test where+	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)++-- | 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_++-- | Define a new 'Suite', with the given name and children.+--+-- Note: earlier versions of Chell permitted arbitrary nesting of test suites.+-- This feature proved too unwieldy, and was removed. A similar result can be+-- achieved with 'suiteTests':+--+-- @+--test_Addition :: Test+--test_Subtraction :: Test+--test_Show :: Test+--+--suite_Math :: Suite+--suite_Math = 'suite' \"math\"+--    [ test_Addition+--    , test_Subtraction+--    ]+--+--suite_Prelude :: Suite+--suite_Prelude = 'suite' \"prelude\"+--    (+--      [ test_Show+--      ]+--      ++ suiteTests suite_Math+--    )+-- @+suite :: String -> [Test] -> Suite+suite = Suite++-- | 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 (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 [(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 = str where+		str = "Test timed out after " ++ show time ++ " milliseconds"+		Just time = testOptionTimeout opts+	+	tried <- withTimeout (try getResult)+	case tried of+		Just (Right ret) -> return ret+		Nothing -> do+			notes <- getNotes+			return (TestAborted notes hitTimeout)+		Just (Left err) -> do+			notes <- getNotes+			return (TestAborted notes err)++try :: IO a -> IO (Either String a)+try io = catches (fmap Right io) [Handler handleAsync, Handler handleExc] where+	handleAsync :: Control.Exception.AsyncException -> IO a+	handleAsync = throwIO+	+	handleExc :: SomeException -> IO (Either String a)+	handleExc exc = return (Left ("Test aborted due to exception: " ++ show exc))

@@ -1,5 +1,5 @@ name: chell-version: 0.4.0.1+version: 0.4.0.2 license: MIT license-file: license.txt author: John Millikin <john@john-millikin.com>@@ -56,15 +56,14 @@ source-repository this   type: git   location: https://john-millikin.com/code/chell/-  tag: chell_0.4.0.1+  tag: chell_0.4.0.2  flag color-output   description: Enable colored output in test results   default: True  library-  hs-source-dirs: lib-  ghc-options: -Wall -O2+  ghc-options: -Wall    build-depends:       base >= 4.1 && < 5.0@@ -78,7 +77,7 @@    if flag(color-output)     build-depends:-        ansi-terminal >= 0.5 && < 0.7+        ansi-terminal >= 0.5 && < 0.8    exposed-modules:     Test.Chell

@@ -1,562 +0,0 @@-{-# 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------suite_Math :: Suite---suite_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' [suite_Math]--- @------ >$ ghc --make chell-example.hs--- >$ ./chell-example--- >PASS: 2 tests run, 2 tests passed-module Test.Chell-	(-	-	-- * Main-	  defaultMain-	-	-- * Test suites-	, Suite-	, suite-	, suiteName-	, suiteTests-	-	-- ** Skipping some tests-	, SuiteOrTest-	, skipIf-	, skipWhen-	-	-- * Basic testing library-	, Assertions-	, assertions-	, IsAssertion-	, Assertion-	, assertionPassed-	, assertionFailed-	, assert-	, expect-	, die-	, trace-	, note-	, afterTest-	, requireLeft-	, requireRight-	-	-- ** Built-in assertions-	, equal-	, notEqual-	, equalWithin-	, just-	, nothing-	, left-	, right-	, throws-	, throwsEq-	, greater-	, greaterEqual-	, lesser-	, lesserEqual-	, sameItems-	, equalItems-	, IsText-	, equalLines-	, equalLinesWith-	-	-- * 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-	) where--import qualified Control.Applicative-import qualified Control.Exception-import           Control.Exception (Exception)-import           Control.Monad (ap, liftM)-import           Control.Monad.IO.Class (MonadIO, liftIO)-import qualified Data.Algorithm.Patience as Patience-import qualified Data.ByteString.Char8-import qualified Data.ByteString.Lazy.Char8-import           Data.Foldable (Foldable, foldMap)-import           Data.List (foldl', intercalate, sort)-import           Data.Maybe (isJust, isNothing)-import           Data.IORef (IORef, newIORef, readIORef, modifyIORef)-import qualified Data.Text-import           Data.Text (Text)-import qualified Data.Text.Lazy--import qualified Language.Haskell.TH as TH--import           Test.Chell.Main (defaultMain)-import           Test.Chell.Types---- | A single pass/fail assertion. Failed assertions include an explanatory--- message.-data Assertion-	= AssertionPassed-	| AssertionFailed String-	deriving (Eq, Show)---- | See 'Assertion'.-assertionPassed :: Assertion-assertionPassed = AssertionPassed---- | See 'Assertion'.-assertionFailed :: String -> Assertion-assertionFailed = AssertionFailed---- | See 'assert' and 'expect'.-class IsAssertion a where-	runAssertion :: a -> IO Assertion--instance IsAssertion Assertion where-	runAssertion = return--instance IsAssertion Bool where-	runAssertion x = return $ if x-		then assertionPassed-		else assertionFailed "boolean assertion failed"--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-	fmap = liftM--instance Control.Applicative.Applicative Assertions where-	pure = return-	(<*>) = ap--instance Monad Assertions where-	return x = Assertions (\s -> return (Just x, s))-	m >>= f = Assertions (\s -> do-		(maybe_a, s') <- unAssertions m s-		case maybe_a of-			Nothing -> return (Nothing, s')-			Just a -> unAssertions (f a) s')--instance MonadIO Assertions where-	liftIO io = Assertions (\s -> do-		x <- io-		return (Just x, s))---- | Convert a sequence of pass/fail assertions into a runnable test.------ @--- test_Equality :: Test--- test_Equality = assertions \"equality\" $ do---     $assert (1 == 1)---     $assert (equal 1 1)--- @-assertions :: String -> Assertions a -> Test-assertions name testm = test name $ \opts -> do-	noteRef <- newIORef []-	afterTestRef <- newIORef []-	-	let getNotes = fmap reverse (readIORef noteRef)-	-	let getResult = do-		res <- unAssertions testm (noteRef, afterTestRef, [])-		case res of-			(_, (_, _, [])) -> do-				notes <- getNotes-				return (TestPassed notes)-			(_, (_, _, fs)) -> do-				notes <- getNotes-				return (TestFailed notes (reverse fs))-	-	Control.Exception.finally-		(handleJankyIO opts getResult getNotes)-		(runAfterTest afterTestRef)--runAfterTest :: IORef [IO ()] -> IO ()-runAfterTest ref = readIORef ref >>= loop where-	loop [] = return ()-	loop (io:ios) = Control.Exception.finally (loop ios) io--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 = TH.loc_filename th_loc-			, locationModule = TH.loc_module th_loc-			, locationLine = Just (toInteger (fst (TH.loc_start th_loc)))-			}-	let f = failure-		{ failureLocation = loc-		, failureMessage = msg-		}-	return (Just (), (notes, afterTestRef, f : fs))---- | Cause a test to immediately fail, with a message.------ 'die' is a Template Haskell macro, to retain the source-file location from--- which it was used. Its effective type is:------ @--- $die :: 'String' -> 'Assertions' a--- @-die :: TH.Q TH.Exp-die = do-	loc <- TH.location-	let qloc = liftLoc loc-	[| \msg -> dieAt $qloc ("die: " ++ msg) |]--dieAt :: TH.Loc -> String -> Assertions a-dieAt loc msg = do-	addFailure (Just loc) msg-	Assertions (\s -> return (Nothing, s))---- | 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-	[| traceAt $qloc |]--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 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 aborted.-afterTest :: IO () -> Assertions ()-afterTest io = Assertions (\(notes, ref, fs) -> do-	modifyIORef ref (io :)-	return (Just (), (notes, ref, fs)))---- | Require an 'Either' value to be 'Left', and return its contents. If--- the value is 'Right', fail the test.------ 'requireLeft' is a Template Haskell macro, to retain the source-file--- location from which it was used. Its effective type is:------ @--- $requireLeft :: 'Show' b => 'Either' a b -> 'Assertions' a--- @-requireLeft :: TH.Q TH.Exp-requireLeft = do-	loc <- TH.location-	let qloc = liftLoc loc-	[| requireLeftAt $qloc |]--requireLeftAt :: Show b => TH.Loc -> Either a b -> Assertions a-requireLeftAt loc val = case val of-	Left a -> return a-	Right b -> do-		let dummy = Right b `asTypeOf` Left ()-		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.------ 'requireRight' is a Template Haskell macro, to retain the source-file--- location from which it was used. Its effective type is:------ @--- $requireRight :: 'Show' a => 'Either' a b -> 'Assertions' b--- @-requireRight :: TH.Q TH.Exp-requireRight = do-	loc <- TH.location-	let qloc = liftLoc loc-	[| requireRightAt $qloc |]--requireRightAt :: Show a => TH.Loc -> Either a b -> Assertions b-requireRightAt loc val = case val of-	Left a -> do-		let dummy = Left a `asTypeOf` Right ()-		dieAt loc ("requireRight: received " ++ showsPrec 11 dummy "")-	Right b -> return b--liftLoc :: TH.Loc -> TH.Q TH.Exp-liftLoc loc = [| TH.Loc filename package module_ start end |] where-	filename = TH.loc_filename loc-	package = TH.loc_package loc-	module_ = TH.loc_module loc-	start = TH.loc_start loc-	end = TH.loc_end loc--assertAt :: IsAssertion assertion => TH.Loc -> Bool -> assertion -> Assertions ()-assertAt loc fatal assertion = do-	result <- liftIO (runAssertion assertion)-	case result of-		AssertionPassed -> return ()-		AssertionFailed err -> if fatal-			then dieAt loc err-			else addFailure (Just loc) err---- | 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-assert = do-	loc <- TH.location-	let qloc = liftLoc loc-	[| assertAt $qloc True |]---- | 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-expect = do-	loc <- TH.location-	let qloc = liftLoc loc-	[| assertAt $qloc False |]--assertBool :: Bool -> String -> Assertion-assertBool True  _   = assertionPassed-assertBool False err = AssertionFailed err---- | Assert that two values are equal.-equal :: (Show a, Eq a) => a -> a -> Assertion-equal x y = assertBool (x == y) ("equal: " ++ show x ++ " is not equal to " ++ show y)---- | Assert that two values are not equal.-notEqual :: (Eq a, Show a) => a -> a -> Assertion-notEqual x y = assertBool (x /= y) ("notEqual: " ++ show x ++ " is equal to " ++ show y)---- | Assert that two values are within some delta of each other.-equalWithin :: (Real a, Show a) => a -> a-                                -> a -- ^ delta-                                -> Assertion-equalWithin x y delta = assertBool -	((x - delta <= y) && (x + delta >= y))-	("equalWithin: " ++ show x ++ " is not within " ++ show delta ++ " of " ++ show y)---- | Assert that some value is @Just@.-just :: Maybe a -> Assertion-just x = assertBool (isJust x) ("just: received Nothing")---- | Assert that some value is @Nothing@.-nothing :: Show a => Maybe a -> Assertion-nothing x = assertBool (isNothing x) ("nothing: received " ++ showsPrec 11 x "")---- | Assert that some value is @Left@.-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 :: 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 -> IO Assertion-throws p io = do-	either_exc <- Control.Exception.try io-	return $ case either_exc of-		Left exc -> if p exc-			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 -> IO Assertion-throwsEq expected io = do-	either_exc <- Control.Exception.try io-	return $ case either_exc of-		Left exc -> if exc == expected-			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-greater x y = assertBool (x > y) ("greater: " ++ show x ++ " is not greater than " ++ show y)---- | Assert a value is greater than or equal to another.-greaterEqual :: (Ord a, Show a) => a -> a -> Assertion-greaterEqual x y = assertBool (x >= y) ("greaterEqual: " ++ show x ++ " is not greater than or equal to " ++ show y)---- | Assert a value is less than another.-lesser :: (Ord a, Show a) => a -> a -> Assertion-lesser x y = assertBool (x < y) ("lesser: " ++ show x ++ " is not less than " ++ show y)---- | Assert a value is less than or equal to another.-lesserEqual :: (Ord a, Show a) => a -> a -> Assertion-lesserEqual x y = assertBool (x <= y) ("lesserEqual: " ++ show x ++ " is not less than or equal to " ++ show y)---- | Assert that two containers have the same items, in any order.-sameItems :: (Foldable container, Show item, Ord item) => container item -> container item -> Assertion-sameItems x y = equalDiff' "sameItems" sort x y---- | Assert that two containers have the same items, in the same order.-equalItems :: (Foldable container, Show item, Ord item) => container item -> container item -> Assertion-equalItems x y = equalDiff' "equalItems" id x y--equalDiff' :: (Foldable container, Show item, Ord item)-           => String-           -> ([item]-           -> [item])-           -> container item-           -> container item-           -> Assertion-equalDiff' label norm x y = checkDiff (items x) (items y) where-	items = norm . foldMap (:[])-	checkDiff xs ys = case checkItems (Patience.diff xs ys) of-		(same, diff) -> assertBool same diff-	-	checkItems diffItems = case foldl' checkItem (True, []) diffItems of-		(same, diff) -> (same, errorMsg (intercalate "\n" (reverse diff)))-	-	checkItem (same, acc) item = case item of-		Patience.Old t -> (False, ("\t- " ++ show t) : acc)-		Patience.New t -> (False, ("\t+ " ++ show t) : acc)-		Patience.Both t _-> (same, ("\t  " ++ show t) : acc)-	-	errorMsg diff = label ++ ": items differ\n" ++ diff---- | Class for types which can be treated as text; see 'equalLines'.-class IsText a where-	toLines :: a -> [a]-	unpack :: a -> String--instance IsText String where-	toLines = lines-	unpack = id--instance IsText Text where-	toLines = Data.Text.lines-	unpack = Data.Text.unpack--instance IsText Data.Text.Lazy.Text where-	toLines = Data.Text.Lazy.lines-	unpack = Data.Text.Lazy.unpack---- | Uses @Data.ByteString.Char8@-instance IsText Data.ByteString.Char8.ByteString where-	toLines = Data.ByteString.Char8.lines-	unpack = Data.ByteString.Char8.unpack---- | Uses @Data.ByteString.Lazy.Char8@-instance IsText Data.ByteString.Lazy.Char8.ByteString where-	toLines = Data.ByteString.Lazy.Char8.lines-	unpack = Data.ByteString.Lazy.Char8.unpack---- | Assert that two pieces of text are equal. This uses a diff algorithm--- 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 = 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) -> assertBool same diff-	-	checkItems diffItems = case foldl' checkItem (True, []) diffItems of-		(same, diff) -> (same, errorMsg (intercalate "\n" (reverse diff)))-	-	checkItem (same, acc) item = case item of-		Patience.Old t -> (False, ("\t- " ++ unpack t) : acc)-		Patience.New t -> (False, ("\t+ " ++ unpack t) : acc)-		Patience.Both t _-> (same, ("\t  " ++ unpack t) : acc)-	-	errorMsg diff = label ++ ": lines differ\n" ++ diff

@@ -1,392 +0,0 @@-module Test.Chell.Main-	( defaultMain-	) where--import           Control.Applicative-import           Control.Monad (forM, forM_, when)-import           Control.Monad.Trans.Class (lift)-import qualified Control.Monad.Trans.State as State-import qualified Control.Monad.Trans.Writer as Writer-import           Data.Char (ord)-import           Data.List (isPrefixOf)-import           System.Exit (exitSuccess, exitFailure)-import           System.IO (hPutStr, hPutStrLn, hIsTerminalDevice, stderr, stdout, withBinaryFile, IOMode(..))-import           System.Random (randomIO)-import           Text.Printf (printf)--import           Options--import           Test.Chell.Output-import           Test.Chell.Types--data MainOptions = MainOptions-	{ optVerbose :: Bool-	, optXmlReport :: String-	, optJsonReport :: String-	, optTextReport :: String-	, optSeed :: Maybe Int-	, optTimeout :: Maybe Int-	, optColor :: ColorMode-	}--optionType_ColorMode :: OptionType ColorMode-optionType_ColorMode = optionType "ColorMode" ColorModeAuto parseMode showMode where-	parseMode s = case s of-		"always" -> Right ColorModeAlways-		"never" -> Right ColorModeNever-		"auto" -> Right ColorModeAuto-		_ -> Left (show s ++ " is not in {\"always\", \"never\", \"auto\"}.")-	showMode mode = case mode of-		ColorModeAlways -> "always"-		ColorModeNever -> "never"-		ColorModeAuto -> "auto"--instance Options MainOptions where-	defineOptions = pure MainOptions-		<*> defineOption optionType_bool (\o -> o-			{ optionShortFlags = ['v']-			, optionLongFlags = ["verbose"]-			, optionDefault = False-			, optionDescription = "Print more output."-			})-		-		<*> simpleOption "xml-report" ""-		    "Write a parsable report to a given path, in XML."-		<*> simpleOption "json-report" ""-		    "Write a parsable report to a given path, in JSON."-		<*> simpleOption "text-report" ""-		    "Write a human-readable report to a given path."-		-		<*> simpleOption "seed" Nothing-		    "The seed used for random numbers in (for example) quickcheck."-		-		<*> simpleOption "timeout" Nothing-		    "The maximum duration of a test, in milliseconds."-		-		<*> defineOption optionType_ColorMode (\o -> o-			{ optionLongFlags = ["color"]-			, optionDefault = ColorModeAuto-			, optionDescription = "Whether to enable color ('always', 'auto', or 'never')."-			})---- | A simple default main function, which runs a list of tests and logs--- statistics to stdout.-defaultMain :: [Suite] -> IO ()-defaultMain suites = runCommand $ \opts args -> do-	-- validate/sanitize test options-	seed <- case optSeed opts of-		Just s -> return s-		Nothing -> randomIO-	timeout <- case optTimeout opts of-		Nothing -> return Nothing-		Just t -> if toInteger t * 1000 > toInteger (maxBound :: Int)-			then do-				hPutStrLn stderr "Test.Chell.defaultMain: Ignoring --timeout because it is too large."-				return Nothing-			else return (Just t)-	let testOptions = defaultTestOptions-		{ testOptionSeed = seed-		, testOptionTimeout = timeout-		}-	-	-- find which tests to run-	let allTests = concatMap suiteTests suites-	let tests = if null args-		then allTests-		else filter (matchesFilter args) allTests-	-	-- output mode-	output <- case optColor opts of-		ColorModeNever -> return (plainOutput (optVerbose opts))-		ColorModeAlways -> return (colorOutput (optVerbose opts))-		ColorModeAuto -> do-			isTerm <- hIsTerminalDevice stdout-			return $ if isTerm-				then colorOutput (optVerbose opts)-				else plainOutput (optVerbose opts)-	-	-- run tests-	results <- forM tests $ \t -> do-		outputStart output t-		result <- runTest t testOptions-		outputResult output t result-		return (t, result)-	-	-- generate reports-	let reports = getReports opts-	forM_ reports $ \(path, fmt, toText) ->-		withBinaryFile path WriteMode $ \h -> do-			when (optVerbose opts) $ do-				putStrLn ("Writing " ++ fmt ++ " report to " ++ show path)-			hPutStr h (toText results)-	-	let stats = resultStatistics results-	let (_, _, failed, aborted) = stats-	putStrLn (formatResultStatistics stats)-	-	if failed == 0 && aborted == 0-		then exitSuccess-		else exitFailure--matchesFilter :: [String] -> Test -> Bool-matchesFilter filters = check where-	check t = any (matchName (testName t)) filters-	matchName name f = f == name || isPrefixOf (f ++ ".") name--type Report = [(Test, TestResult)] -> String--getReports :: MainOptions -> [(String, String, Report)]-getReports opts = concat [xml, json, text] where-	xml = case optXmlReport opts of-		"" -> []-		path -> [(path, "XML", xmlReport)]-	json = case optJsonReport opts of-		"" -> []-		path -> [(path, "JSON", jsonReport)]-	text = case optTextReport opts of-		"" -> []-		path -> [(path, "text", textReport)]--jsonReport :: [(Test, TestResult)] -> String-jsonReport results = Writer.execWriter writer where-	tell = Writer.tell-	-	writer = do-		tell "{\"test-runs\": ["-		commas results tellResult-		tell "]}"-	-	tellResult (t, result) = case result of-		TestPassed notes -> do-			tell "{\"test\": \""-			tell (escapeJSON (testName t))-			tell "\", \"result\": \"passed\""-			tellNotes notes-			tell "}"-		TestSkipped -> do-			tell "{\"test\": \""-			tell (escapeJSON (testName t))-			tell "\", \"result\": \"skipped\"}"-		TestFailed notes fs -> do-			tell "{\"test\": \""-			tell (escapeJSON (testName t))-			tell "\", \"result\": \"failed\", \"failures\": ["-			commas fs $ \f -> do-				tell "{\"message\": \""-				tell (escapeJSON (failureMessage f))-				tell "\""-				case failureLocation f of-					Just loc -> do-						tell ", \"location\": {\"module\": \""-						tell (escapeJSON (locationModule loc))-						tell "\", \"file\": \""-						tell (escapeJSON (locationFile loc))-						case locationLine loc of-							Just line -> do-								tell "\", \"line\": "-								tell (show line)-							Nothing -> tell "\""-						tell "}"-					Nothing -> return ()-				tell "}"-			tell "]"-			tellNotes notes-			tell "}"-		TestAborted notes msg -> do-			tell "{\"test\": \""-			tell (escapeJSON (testName t))-			tell "\", \"result\": \"aborted\", \"abortion\": {\"message\": \""-			tell (escapeJSON msg)-			tell "\"}"-			tellNotes notes-			tell "}"-		_ -> return ()-	-	escapeJSON = concatMap (\c -> case c of-		'"' -> "\\\""-		'\\' -> "\\\\"-		_ | ord c <= 0x1F -> printf "\\u%04X" (ord c)-		_ -> [c])-	-	tellNotes notes = do-		tell ", \"notes\": ["-		commas notes $ \(key, value) -> do-			tell "{\"key\": \""-			tell (escapeJSON key)-			tell "\", \"value\": \""-			tell (escapeJSON value)-			tell "\"}"-		tell "]"-	-	commas xs block = State.evalStateT (commaState xs block) False-	commaState xs block = forM_ xs $ \x -> do-		let tell' = lift . Writer.tell-		needComma <- State.get-		if needComma-			then tell' "\n, "-			else tell' "\n  "-		State.put True-		lift (block x)--xmlReport :: [(Test, TestResult)] -> String-xmlReport results = Writer.execWriter writer where-	tell = Writer.tell-	-	writer = do-		tell "<?xml version=\"1.0\" encoding=\"utf8\"?>\n"-		tell "<report xmlns='urn:john-millikin:chell:report:1'>\n"-		mapM_ tellResult results-		tell "</report>"-	-	tellResult (t, result) = case result of-		TestPassed notes -> do-			tell "\t<test-run test='"-			tell (escapeXML (testName t))-			tell "' result='passed'>\n"-			tellNotes notes-			tell "\t</test-run>\n"-		TestSkipped -> do-			tell "\t<test-run test='"-			tell (escapeXML (testName t))-			tell "' result='skipped'/>\n"-		TestFailed notes fs -> do-			tell "\t<test-run test='"-			tell (escapeXML (testName t))-			tell "' result='failed'>\n"-			forM_ fs $ \f -> do-				tell "\t\t<failure message='"-				tell (escapeXML (failureMessage f))-				case failureLocation f of-					Just loc -> do-						tell "'>\n"-						tell "\t\t\t<location module='"-						tell (escapeXML (locationModule loc))-						tell "' file='"-						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"-			tellNotes notes-			tell "\t</test-run>\n"-		TestAborted notes msg -> do-			tell "\t<test-run test='"-			tell (escapeXML (testName t))-			tell "' result='aborted'>\n"-			tell "\t\t<abortion message='"-			tell (escapeXML msg)-			tell "'/>\n"-			tellNotes notes-			tell "\t</test-run>\n"-		_ -> return ()-	-	escapeXML = concatMap (\c -> case c of-		'&' -> "&amp;"-		'<' -> "&lt;"-		'>' -> "&gt;"-		'"' -> "&quot;"-		'\'' -> "&apos;"-		_ -> [c])-	-	tellNotes notes = forM_ notes $ \(key, value) -> do-		tell "\t\t<note key=\""-		tell (escapeXML key)-		tell "\" value=\""-		tell (escapeXML value)-		tell "\"/>\n"--textReport :: [(Test, TestResult)] -> String-textReport results = Writer.execWriter writer where-	tell = Writer.tell-	-	writer = do-		forM_ results tellResult-		let stats = resultStatistics results-		tell (formatResultStatistics stats)-	-	tellResult (t, result) = case result of-		TestPassed notes -> do-			tell (replicate 70 '=')-			tell "\n"-			tell "PASSED: "-			tell (testName t)-			tell "\n"-			tellNotes notes-			tell "\n\n"-		TestSkipped -> do-			tell (replicate 70 '=')-			tell "\n"-			tell "SKIPPED: "-			tell (testName t)-			tell "\n\n"-		TestFailed notes fs -> do-			tell (replicate 70 '=')-			tell "\n"-			tell "FAILED: "-			tell (testName t)-			tell "\n"-			tellNotes notes-			tell (replicate 70 '-')-			tell "\n"-			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 (failureMessage f)-				tell "\n\n"-		TestAborted notes msg -> do-			tell (replicate 70 '=')-			tell "\n"-			tell "ABORTED: "-			tell (testName t)-			tell "\n"-			tellNotes notes-			tell (replicate 70 '-')-			tell "\n"-			tell msg-			tell "\n\n"-		_ -> return ()-	-	tellNotes notes = forM_ notes $ \(key, value) -> do-		tell key-		tell "="-		tell value-		tell "\n"--formatResultStatistics :: (Integer, Integer, Integer, Integer) -> String-formatResultStatistics stats = Writer.execWriter writer where-	writer = do-		let (passed, skipped, failed, aborted) = stats-		if failed == 0 && aborted == 0-			then Writer.tell "PASS: "-			else Writer.tell "FAIL: "-		let putNum comma n what = Writer.tell $ if n == 1-			then comma ++ "1 test " ++ what-			else comma ++ show n ++ " tests " ++ what-		-		let total = sum [passed, skipped, failed, aborted]-		putNum "" total "run"-		(putNum ", " passed "passed")-		when (skipped > 0) (putNum ", " skipped "skipped")-		when (failed > 0) (putNum ", " failed "failed")-		when (aborted > 0) (putNum ", " aborted "aborted")--resultStatistics :: [(Test, TestResult)] -> (Integer, Integer, Integer, Integer)-resultStatistics results = State.execState state (0, 0, 0, 0) where-	state = forM_ results $ \(_, result) -> case result of-		TestPassed{} ->  State.modify (\(p, s, f, a) -> (p+1, s, f, a))-		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,159 +0,0 @@-{-# LANGUAGE CPP #-}--module Test.Chell.Output-	( Output-	, outputStart-	, outputResult-	-	, ColorMode(..)-	-	, plainOutput-	, colorOutput-	) where--import           Control.Monad (forM_, unless, when)--#ifdef MIN_VERSION_ansi_terminal-import qualified System.Console.ANSI as AnsiTerminal-#endif--import           Test.Chell.Types--data Output = Output-	{ outputStart :: Test -> IO ()-	, outputResult :: Test -> TestResult -> IO ()-	}--plainOutput :: Bool -> Output-plainOutput v = Output-	{ outputStart = plainOutputStart v-	, outputResult = plainOutputResult v-	}--plainOutputStart :: Bool -> Test -> IO ()-plainOutputStart v t = when v $ do-	putStr "[ RUN   ] "-	putStrLn (testName t)--plainOutputResult :: Bool -> Test -> TestResult -> IO ()-plainOutputResult v t (TestPassed _) = when v $ do-	putStr "[ PASS  ] "-	putStrLn (testName t)-	putStrLn ""-plainOutputResult v t TestSkipped = when v $ do-	putStr "[ SKIP  ] "-	putStrLn (testName t)-	putStrLn ""-plainOutputResult _ t (TestFailed notes fs) = do-	putStr "[ FAIL  ] "-	putStrLn (testName t)-	printNotes notes-	printFailures fs-plainOutputResult _ t (TestAborted notes msg) = do-	putStr "[ ABORT ] "-	putStrLn (testName t)-	printNotes notes-	putStr "  "-	putStr msg-	putStrLn "\n"-plainOutputResult _ _ _ = return ()--data ColorMode-	= ColorModeAuto-	| ColorModeAlways-	| ColorModeNever-	deriving (Enum)--colorOutput :: Bool -> Output-#ifndef MIN_VERSION_ansi_terminal-colorOutput = plainOutput-#else-colorOutput v = Output-	{ outputStart = colorOutputStart v-	, outputResult = colorOutputResult v-	}--colorOutputStart :: Bool -> Test -> IO ()-colorOutputStart v t = when v $ do-	putStr "[ RUN   ] "-	putStrLn (testName t)--colorOutputResult :: Bool -> Test -> TestResult -> IO ()-colorOutputResult v t (TestPassed _) = when v $ do-	putStr "[ "-	AnsiTerminal.setSGR-		[ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Green-		]-	putStr "PASS"-	AnsiTerminal.setSGR-		[ AnsiTerminal.Reset-		]-	putStr "  ] "-	putStrLn (testName t)-	putStrLn ""-colorOutputResult v t TestSkipped = when v $ do-	putStr "[ "-	AnsiTerminal.setSGR-		[ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Yellow-		]-	putStr "SKIP"-	AnsiTerminal.setSGR-		[ AnsiTerminal.Reset-		]-	putStr "  ] "-	putStrLn (testName t)-	putStrLn ""-colorOutputResult _ t (TestFailed notes fs) = do-	putStr "[ "-	AnsiTerminal.setSGR-		[ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Red-		]-	putStr "FAIL"-	AnsiTerminal.setSGR-		[ AnsiTerminal.Reset-		]-	putStr "  ] "-	putStrLn (testName t)-	printNotes notes-	printFailures fs-colorOutputResult _ t (TestAborted notes msg) = do-	putStr "[ "-	AnsiTerminal.setSGR-		[ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Red-		]-	putStr "ABORT"-	AnsiTerminal.setSGR-		[ AnsiTerminal.Reset-		]-	putStr " ] "-	putStrLn (testName t)-	printNotes notes-	putStr "  "-	putStr msg-	putStrLn "\n"-colorOutputResult _ _ _ = return ()-#endif--printNotes :: [(String, String)] -> IO ()-printNotes notes = unless (null notes) $ do-	forM_ notes $ \(key, value) -> do-		putStr "  note: "-		putStr key-		putStr "="-		putStrLn value-	putStrLn ""--printFailures :: [Failure] -> IO ()-printFailures fs = forM_ fs $ \f -> do-	putStr "  "-	case failureLocation f of-		Just loc -> do-			putStr (locationFile loc)-			putStr ":"-			case locationLine loc of-				Just line -> putStrLn (show line)-				Nothing -> putStrLn ""-		Nothing -> return ()-	putStr "  "-	putStr (failureMessage f)-	putStrLn "\n"

@@ -1,319 +0,0 @@-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-	-	, SuiteOrTest-	, skipIf-	, skipWhen-	-	, runTest-	-	, handleJankyIO-	) where--import qualified Control.Exception-import           Control.Exception (SomeException, Handler(..), catches, throwIO)-import           System.Timeout (timeout)---- | 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-	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-	{-	-	-- | Get the RNG seed for this test run. The seed is generated once, in-	-- 'defaultMain', and used for all tests. It is also logged to reports-	-- using a note.-	---	-- 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-	-- this timeout will be aborted.-	---	-- 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.------ >$ ghci--- >Prelude> import Test.Chell--- >--- >Test.Chell> testOptionSeed defaultTestOptions--- >0--- >--- >Test.Chell> testOptionTimeout defaultTestOptions--- >Nothing-defaultTestOptions :: TestOptions-defaultTestOptions = TestOptions-	{ testOptionSeed = 0-	, testOptionTimeout = Nothing-	}---- | 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 named collection of tests.------ Note: earlier versions of Chell permitted arbitrary nesting of test suites.--- This feature proved too unwieldy, and was removed. A similar result can be--- achieved with 'suiteTests'; see the documentation for 'suite'.-data Suite = Suite String [Test]-	deriving (Show)--class SuiteOrTest a where-	skipIf_ :: Bool -> a -> a-	skipWhen_ :: IO Bool -> a -> a--instance SuiteOrTest Suite where-	skipIf_ skip s@(Suite name children) = if skip-		then Suite name (map (skipIf_ skip) children)-		else s-	skipWhen_ p (Suite name children) = Suite name (map (skipWhen_ p) children)--instance SuiteOrTest Test where-	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)---- | 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_---- | Define a new 'Suite', with the given name and children.------ Note: earlier versions of Chell permitted arbitrary nesting of test suites.--- This feature proved too unwieldy, and was removed. A similar result can be--- achieved with 'suiteTests':------ @---test_Addition :: Test---test_Subtraction :: Test---test_Show :: Test------suite_Math :: Suite---suite_Math = 'suite' \"math\"---    [ test_Addition---    , test_Subtraction---    ]------suite_Prelude :: Suite---suite_Prelude = 'suite' \"prelude\"---    (---      [ test_Show---      ]---      ++ suiteTests suite_Math---    )--- @-suite :: String -> [Test] -> Suite-suite = Suite---- | 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 (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 [(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 = str where-		str = "Test timed out after " ++ show time ++ " milliseconds"-		Just time = testOptionTimeout opts-	-	tried <- withTimeout (try getResult)-	case tried of-		Just (Right ret) -> return ret-		Nothing -> do-			notes <- getNotes-			return (TestAborted notes hitTimeout)-		Just (Left err) -> do-			notes <- getNotes-			return (TestAborted notes err)--try :: IO a -> IO (Either String a)-try io = catches (fmap Right io) [Handler handleAsync, Handler handleExc] where-	handleAsync :: Control.Exception.AsyncException -> IO a-	handleAsync = throwIO-	-	handleExc :: SomeException -> IO (Either String a)-	handleExc exc = return (Left ("Test aborted due to exception: " ++ show exc))