chell 0.1.3 → 0.2

raw patch · 7 files changed

+993/−989 lines, 7 filesdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

- Test.Chell: assertions :: Text -> Assertions a -> Test

+ Test.Chell: assertions :: Text -> Assertions a -> Suite

- Test.Chell: skipIf :: Bool -> Test -> Test

+ Test.Chell: skipIf :: Bool -> Suite -> Suite

- Test.Chell: skipWhen :: IO Bool -> Test -> Test

+ Test.Chell: skipWhen :: IO Bool -> Suite -> Suite

Files

chell.cabal +11/−9
lib/Test/Chell.hs +447/−0
lib/Test/Chell/Main.hs +435/−0
lib/Test/Chell/Types.hs +100/−0
src/Test/Chell.hs +0/−445
src/Test/Chell/Main.hs +0/−435
src/Test/Chell/Types.hs +0/−100

chell.cabal view

@@ -1,35 +1,37 @@ name: chell-version: 0.1.3-synopsis: Quiet test runner+version: 0.2 license: MIT license-file: license.txt author: John Millikin <jmillikin@gmail.com>+maintainer: John Millikin <jmillikin@gmail.com> build-type: Simple cabal-version: >= 1.6 category: Testing bug-reports: mailto:jmillikin@gmail.com homepage: https://john-millikin.com/software/chell/-tested-with: GHC==6.12.1 +synopsis: A quiet test runner+description:+ source-repository head   type: bazaar-  location: https://john-millikin.com/branches/chell/0.1/+  location: https://john-millikin.com/software/chell/  source-repository this   type: bazaar-  location: https://john-millikin.com/branches/chell/0.1/-  tag: chell_0.1.3+  location: https://john-millikin.com/software/chell/+  tag: chell_0.2  library-  ghc-options: -Wall-  hs-source-dirs: src+  hs-source-dirs: lib+  ghc-options: -Wall -O2    build-depends:       base >= 4 && < 5     , bytestring >= 0.9 && < 0.10     , patience >= 0.1 && < 0.2     , random-    , template-haskell >= 2.3 && < 2.8+    , template-haskell >= 2.3 && < 2.7     , text >= 0.7     , transformers >= 0.2 && < 0.3

+ lib/Test/Chell.hs view

@@ -0,0 +1,447 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module Test.Chell+	(+	+	-- * Main+	  defaultMain+	+	-- * Test suites+	, Suite+	, suite+	, suiteName+	, suiteTests+	, test+	, skipIf+	, skipWhen+	+	-- * Basic testing library+	-- $doc-basic-testing+	, Assertion (..)+	, AssertionResult (..)+	, IsAssertion+	, Assertions+	, assertions+	, assert+	, expect+	, Test.Chell.fail+	, trace+	, note+	+	-- ** Assertions+	, equal+	, notEqual+	, equalWithin+	, just+	, nothing+	, left+	, right+	, throws+	, throwsEq+	, greater+	, greaterEqual+	, lesser+	, lesserEqual+	, sameItems+	, equalItems+	, IsText+	, equalLines+	+	-- * Constructing tests+	, Test (..)+	, testName+	, runTest+	+	, TestOptions+	, testOptionSeed+	, testOptionTimeout+	, TestResult (..)+	, Failure (..)+	, Location (..)+	) where++import qualified Control.Applicative+import qualified Control.Exception+import           Control.Exception (Exception)+import           Control.Monad (ap, liftM, when)+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 Data.Text.IO++import qualified Language.Haskell.TH as TH++import           Test.Chell.Main (defaultMain)+import           Test.Chell.Types++-- | 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.+--+-- Users may specify a seed using the @--seed@ command-line option.+testOptionSeed :: TestOptions -> Int+testOptionSeed = testOptionSeed_++-- | An optional timeout, in millseconds. Tests which run longer than this+-- timeout will be aborted.+--+-- Users may specify a timeout using the @--timeout@ command-line option.+testOptionTimeout :: TestOptions -> Maybe Int+testOptionTimeout = testOptionTimeout_++-- | 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.++newtype Assertion = Assertion (IO AssertionResult)++data AssertionResult+	= AssertionPassed+	| AssertionFailed Text++class IsAssertion a where+	toAssertion :: a -> Assertion++instance IsAssertion Assertion where+	toAssertion = id++instance IsAssertion Bool where+	toAssertion x = Assertion (return (if x+		then AssertionPassed+		else AssertionFailed "$assert: boolean assertion failed"))++type TestState = (IORef [(Text, Text)], [Failure])+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 :: Suite+-- test_Equality = assertions \"equality\" $ do+--     $assert (1 == 1)+--     $assert (equal 1 1)+-- @+assertions :: Text -> Assertions a -> Suite+assertions name testm = test (Test name io) where+	io opts = do+		noteRef <- newIORef []+		+		let getNotes = fmap reverse (readIORef noteRef)+		+		let getResult = do+			res <- unAssertions testm (noteRef, [])+			case res of+				(_, (_, [])) -> do+					notes <- getNotes+					return (TestPassed notes)+				(_, (_, fs)) -> do+					notes <- getNotes+					return (TestFailed notes (reverse fs))+		+		handleJankyIO opts getResult getNotes++addFailure :: Maybe TH.Loc -> Text -> Assertions ()+addFailure maybe_loc msg = Assertions $ \(notes, 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 (Just (), (notes, Failure loc msg : fs))++die :: Assertions a+die = Assertions (\s -> return (Nothing, s))++-- | Cause a test to immediately fail, with a message.+--+-- 'Test.Chell.fail' is a Template Haskell macro, to retain the source-file+-- location from which it was used. Its effective type is:+--+-- @+-- $fail :: 'Text' -> 'Assertions' a+-- @+fail :: TH.Q TH.Exp -- :: Text -> Assertions a+fail = do+	loc <- TH.location+	let qloc = liftLoc loc+	[| \msg -> addFailure (Just $qloc) msg >> die |]++-- | 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)++-- | Attach metadata to a test run. This will be included in reports.+note :: Text -> Text -> Assertions ()+note key value = Assertions (\(notes, fs) -> do+	modifyIORef notes ((key, value) :)+	return (Just (), (notes, fs)))++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+	let Assertion io = toAssertion assertion+	result <- liftIO io+	case result of+		AssertionPassed -> return ()+		AssertionFailed err -> do+			addFailure (Just loc) err+			when fatal die++-- | Run an 'Assertion'. If the assertion fails, the test will immediately+-- fail.+--+-- '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 = 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).+--+-- '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 = 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)))++-- | Assert that two values are equal.+equal :: (Show a, Eq a) => a -> a -> Assertion+equal x y = pure (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 = pure (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 = pure+	((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 = pure (isJust x) ("just: received Nothing")++-- | Assert that some value is @Nothing@.+nothing :: Maybe a -> Assertion+nothing x = pure (isNothing x) ("nothing: received Just")++-- | 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++-- | 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++-- | 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+	either_exc <- Control.Exception.try io+	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"))))++-- | 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+	either_exc <- Control.Exception.try io+	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"))))++-- | Assert a value is greater than another.+greater :: (Ord a, Show a) => a -> a -> Assertion+greater x y = pure (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 = pure (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 = pure (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 = pure (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) -> pure 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.+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 = checkDiff (toLines x) (toLines y) where+	checkDiff xs ys = case checkItems (Patience.diff xs ys) of+		(same, diff) -> pure 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 = "equalLines: lines differ\n" ++ diff

+ lib/Test/Chell/Main.hs view

@@ -0,0 +1,435 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Chell.Main+	( defaultMain+	) where++import           Control.Monad (forM, forM_, unless, when)+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 qualified System.Console.GetOpt as GetOpt+import           System.Environment (getArgs, getProgName)+import           System.Exit (exitSuccess, exitFailure)+import qualified System.IO as IO+import           System.Random (randomIO)+import           Text.Printf (printf)++import           Test.Chell.Types++data Option+	= OptionHelp+	| OptionVerbose+	| OptionXmlReport FilePath+	| OptionJsonReport FilePath+	| OptionTextReport FilePath+	| OptionSeed Int+	| OptionTimeout Int+	deriving (Show, Eq)++optionInfo :: [GetOpt.OptDescr Option]+optionInfo =+	[ GetOpt.Option ['h'] ["help"]+	  (GetOpt.NoArg OptionHelp)+	  "show this help"+	+	, GetOpt.Option ['v'] ["verbose"]+	  (GetOpt.NoArg OptionVerbose)+	  "print more output"+	+	, GetOpt.Option [] ["xml-report"]+	  (GetOpt.ReqArg OptionXmlReport "PATH")+	  "write a parsable report to a file, in XML"+	+	, GetOpt.Option [] ["json-report"]+	  (GetOpt.ReqArg OptionJsonReport "PATH")+	  "write a parsable report to a file, in JSON"+	+	, GetOpt.Option [] ["text-report"]+	  (GetOpt.ReqArg OptionTextReport "PATH")+	  "write a human-readable report"+	+	, GetOpt.Option [] ["seed"]+	  (GetOpt.ReqArg (\s -> case parseInt s of+	   	Just x -> OptionSeed x+	   	Nothing -> error ("Failed to parse --seed value " ++ show s)) "SEED")+	  "the seed used for random numbers in (for example) quickcheck"+	+	, GetOpt.Option [] ["timeout"]+	  (GetOpt.ReqArg (\s -> case parseTimeout s of+	  	Just x -> OptionTimeout x+	  	Nothing -> error ("Failed to parse --timeout value " ++ show s)) "TIMEOUT")+	  "the maximum duration of a test, in milliseconds"+	+	]++parseInt :: String -> Maybe Int+parseInt s = case [x | (x, "") <- reads s] of+	[x] -> Just x+	_ -> Nothing++parseTimeout :: String -> Maybe Int+parseTimeout s = do+	msec <- parseInt s+	if (toInteger msec) * 1000 > toInteger (maxBound :: Int)+		then Nothing+		else return msec++getSeedOpt :: [Option] -> Maybe Int+getSeedOpt [] = Nothing+getSeedOpt ((OptionSeed s) : _) = Just s+getSeedOpt (_:os) = getSeedOpt os++getTimeoutOpt :: [Option] -> Maybe Int+getTimeoutOpt [] = Nothing+getTimeoutOpt ((OptionTimeout s) : _) = Just s+getTimeoutOpt (_:os) = getTimeoutOpt os++usage :: String -> String+usage name = "Usage: " ++ name ++ " [OPTION...]"++-- | A simple default main function, which runs a list of tests and logs+-- statistics to stderr.+defaultMain :: [Suite] -> IO ()+defaultMain suites = do+	args <- getArgs+	let (options, filters, optionErrors) = GetOpt.getOpt GetOpt.Permute optionInfo args+	unless (null optionErrors) $ do+		name <- getProgName+		IO.hPutStrLn IO.stderr (concat optionErrors)+		IO.hPutStrLn IO.stderr (GetOpt.usageInfo (usage name) optionInfo)+		exitFailure+	+	when (OptionHelp `elem` options) $ do+		name <- getProgName+		putStrLn (GetOpt.usageInfo (usage name) optionInfo)+		exitSuccess+	+	let allTests = concatMap suiteTests suites+	let tests = if null filters+		then allTests+		else filter (matchesFilter filters) allTests+	+	seed <- case getSeedOpt options of+		Just s -> return s+		Nothing -> randomIO+	+	let testOptions = TestOptions+		{ testOptionSeed_ = seed+		, testOptionTimeout_ = getTimeoutOpt options+		}+	+	let verbose = elem OptionVerbose options+	results <- forM tests $ \t -> do+		result <- runTest t testOptions+		printResult verbose t result+		return (t, result)+	+	let reports = getReports options+	forM_ reports $ \(path, fmt, toText) ->+		IO.withBinaryFile path IO.WriteMode $ \h -> do+			let text = toText results+			let bytes = Data.Text.Encoding.encodeUtf8 text+			when verbose $ do+				putStrLn ("Writing " ++ fmt ++ " report to " ++ show path)+			Data.ByteString.hPut h bytes+	+	let stats = resultStatistics results+	let (_, _, failed, aborted) = stats+	Data.Text.IO.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+	check t = any (matchName (testName t)) filters+	matchName name f = f == name || Data.Text.isPrefixOf (Data.Text.append f ".") name++printResult :: Bool -> Test -> TestResult -> IO ()+printResult verbose t result = case result of+	TestPassed _ -> when verbose $ do+		Data.Text.IO.putStr (testName t)+		putStrLn ": PASS"+	TestSkipped -> when verbose $ do+		Data.Text.IO.putStr (testName t)+		putStrLn ": SKIPPED"+	TestFailed notes fs -> do+		putStrLn (replicate 70 '=')+		Data.Text.IO.putStr (testName t)+		putStrLn ": FAILED"+		forM_ notes $ \(key, value) -> do+			putStr "\t"+			Data.Text.IO.putStr key+			putStr "="+			Data.Text.IO.putStrLn value+		putStrLn (replicate 70 '=')+		forM_ fs $ \(Failure loc msg) -> do+			case loc of+				Just loc' -> do+					Data.Text.IO.putStr (locationFile loc')+					putStr ":"+					putStrLn (show (locationLine loc'))+				Nothing -> return ()+			Data.Text.IO.putStr msg+			putStr "\n\n"+	TestAborted notes msg -> do+		putStrLn (replicate 70 '=')+		Data.Text.IO.putStr (testName t)+		putStrLn ": ABORTED"+		forM_ notes $ \(key, value) -> do+			putStr "\t"+			Data.Text.IO.putStr key+			putStr "="+			Data.Text.IO.putStrLn value+		putStrLn (replicate 70 '=')+		Data.Text.IO.putStr msg+		putStr "\n\n"++type Report = [(Test, TestResult)] -> Text++getReports :: [Option] -> [(FilePath, String, Report)]+getReports = concatMap step where+	step (OptionXmlReport path) = [(path, "XML", xmlReport)]+	step (OptionJsonReport path) = [(path, "JSON", jsonReport)]+	step (OptionTextReport path) = [(path, "text", textReport)]+	step _  = []++jsonReport :: [(Test, TestResult)] -> Text+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 $ \(Failure loc msg) -> do+				tell "{\"message\": \""+				tell (escapeJSON msg)+				tell "\""+				case loc of+					Just loc' -> do+						tell ", \"location\": {\"module\": \""+						tell (escapeJSON (locationModule loc'))+						tell "\", \"file\": \""+						tell (escapeJSON (locationFile loc'))+						tell "\", \"line\": "+						tell (pack (show (locationLine loc')))+						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 "}"+	+	escapeJSON = Data.Text.concatMap (\c -> case c of+		'"' -> "\\\""+		'\\' -> "\\\\"+		_ | ord c <= 0x1F -> pack (printf "\\u%04X" (ord c))+		_ -> Data.Text.singleton 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)] -> Text+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 $ \(Failure loc msg) -> do+				tell "\t\t<failure message='"+				tell (escapeXML msg)+				case loc of+					Just loc' -> do+						tell "'>\n"+						tell "\t\t\t<location module='"+						tell (escapeXML (locationModule loc'))+						tell "' file='"+						tell (escapeXML (locationFile loc'))+						tell "' line='"+						tell (pack (show (locationLine loc')))+						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"+	+	escapeXML = Data.Text.concatMap (\c -> case c of+		'&' -> "&amp;"+		'<' -> "&lt;"+		'>' -> "&gt;"+		'"' -> "&quot;"+		'\'' -> "&apos;"+		_ -> Data.Text.singleton 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)] -> Text+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 (Data.Text.replicate 70 "=")+			tell "\n"+			tell "PASSED: "+			tell (testName t)+			tell "\n"+			tellNotes notes+			tell "\n\n"+		TestSkipped -> do+			tell (Data.Text.replicate 70 "=")+			tell "\n"+			tell "SKIPPED: "+			tell (testName t)+			tell "\n\n"+		TestFailed notes fs -> do+			tell (Data.Text.replicate 70 "=")+			tell "\n"+			tell "FAILED: "+			tell (testName t)+			tell "\n"+			tellNotes notes+			tell (Data.Text.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')))+						tell "\n"+					Nothing -> return ()+				tell msg+				tell "\n\n"+		TestAborted notes msg -> do+			tell (Data.Text.replicate 70 "=")+			tell "\n"+			tell "ABORTED: "+			tell (testName t)+			tell "\n"+			tellNotes notes+			tell (Data.Text.replicate 70 "-")+			tell "\n"+			tell msg+			tell "\n\n"+	+	tellNotes notes = forM_ notes $ \(key, value) -> do+		tell key+		tell "="+		tell value+		tell "\n"++formatResultStatistics :: (Integer, Integer, Integer, Integer) -> Text+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 pack (comma ++ "1 test " ++ what)+			else pack (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))

+ lib/Test/Chell/Types.hs view

@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Chell.Types where++import qualified Control.Exception+import           Control.Exception (SomeException)+import qualified Data.Text+import           Data.Text (Text)+import           System.Timeout (timeout)++data Test = Test Text (TestOptions -> IO TestResult)++instance Show Test where+	show (Test name _) = "<Test " ++ show name ++ ">"++data TestOptions = TestOptions+	{ testOptionSeed_ :: Int+	, testOptionTimeout_ :: Maybe Int+	}+	deriving (Show, Eq)++-- | @testName (Test name _) = name@+testName :: Test -> Text+testName (Test name _) = name++-- | 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 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+		str = "Test timed out after " ++ show time ++ " milliseconds"+		Just time = testOptionTimeout_ opts+	+	let errorExc :: SomeException -> Text+	    errorExc exc = Data.Text.pack ("Test aborted due to exception: " ++ show exc)+	+	tried <- withTimeout (Control.Exception.try getResult)+	case tried of+		Just (Right ret) -> return ret+		Nothing -> do+			notes <- getNotes+			return (TestAborted notes hitTimeout)+		Just (Left exc) -> do+			notes <- getNotes+			return (TestAborted notes (errorExc 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)++-- | 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]

− src/Test/Chell.hs

@@ -1,445 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}--module Test.Chell-	(-	-	-- * Main-	  defaultMain-	-	-- * Test suites-	, Suite-	, suite-	, suiteName-	, suiteTests-	, test-	, skipIf-	, skipWhen-	-	-- * Basic testing library-	-- $doc-basic-testing-	, Assertion (..)-	, AssertionResult (..)-	, IsAssertion-	, Assertions-	, assertions-	, assert-	, expect-	, Test.Chell.fail-	, trace-	, note-	-	-- ** Assertions-	, equal-	, notEqual-	, equalWithin-	, just-	, nothing-	, left-	, right-	, throws-	, throwsEq-	, greater-	, greaterEqual-	, lesser-	, lesserEqual-	, sameItems-	, equalItems-	, IsText-	, equalLines-	-	-- * Constructing tests-	, Test (..)-	, testName-	, runTest-	-	, TestOptions-	, testOptionSeed-	, testOptionTimeout-	, TestResult (..)-	, Failure (..)-	, Location (..)-	) where--import qualified Control.Applicative-import qualified Control.Exception-import           Control.Exception (Exception)-import           Control.Monad (ap, liftM, when)-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 Data.Text.IO--import qualified Language.Haskell.TH as TH--import           Test.Chell.Main (defaultMain)-import           Test.Chell.Types---- | 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.------ Users may specify a seed using the @--seed@ command-line option.-testOptionSeed :: TestOptions -> Int-testOptionSeed = testOptionSeed_---- | An optional timeout, in millseconds. Tests which run longer than this--- timeout will be aborted.------ Users may specify a timeout using the @--timeout@ command-line option.-testOptionTimeout :: TestOptions -> Maybe Int-testOptionTimeout = testOptionTimeout_---- | Conditionally skip a test. Use this to avoid commenting out tests--- which are currently broken, or do not work on the current platform.------ @---tests = 'suite' \"tests\"---    [ 'test' ('skipIf' builtOnUnix test_WindowsSpecific)---    ]--- @----skipIf :: Bool -> Test -> Test-skipIf skip t@(Test name _) = if skip-	then Test name (\_ -> return TestSkipped)-	else t---- | Conditionally skip a test, depending on the result of a runtime check.------ @---tests = 'suite' \"tests\"---    [ 'test' ('skipWhen' noNetwork test_PingGoogle)---    ]--- @-skipWhen :: IO Bool -> Test -> Test-skipWhen p (Test name io) = Test name $ \options -> do-	skipThis <- p-	if skipThis-		then return TestSkipped-		else io options---- $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.--newtype Assertion = Assertion (IO AssertionResult)--data AssertionResult-	= AssertionPassed-	| AssertionFailed Text--class IsAssertion a where-	toAssertion :: a -> Assertion--instance IsAssertion Assertion where-	toAssertion = id--instance IsAssertion Bool where-	toAssertion x = Assertion (return (if x-		then AssertionPassed-		else AssertionFailed "$assert: boolean assertion failed"))--type TestState = (IORef [(Text, Text)], [Failure])-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 :: Text -> Assertions a -> Test-assertions name testm = Test name io where-	io opts = do-		noteRef <- newIORef []-		-		let getNotes = fmap reverse (readIORef noteRef)-		-		let getResult = do-			res <- unAssertions testm (noteRef, [])-			case res of-				(_, (_, [])) -> do-					notes <- getNotes-					return (TestPassed notes)-				(_, (_, fs)) -> do-					notes <- getNotes-					return (TestFailed notes (reverse fs))-		-		handleJankyIO opts getResult getNotes--addFailure :: Maybe TH.Loc -> Text -> Assertions ()-addFailure maybe_loc msg = Assertions $ \(notes, 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 (Just (), (notes, Failure loc msg : fs))--die :: Assertions a-die = Assertions (\s -> return (Nothing, s))---- | Cause a test to immediately fail, with a message.------ 'Test.Chell.fail' is a Template Haskell macro, to retain the source-file--- location from which it was used. Its effective type is:------ @--- $fail :: 'Text' -> 'Assertions' a--- @-fail :: TH.Q TH.Exp -- :: Text -> Assertions a-fail = do-	loc <- TH.location-	let qloc = liftLoc loc-	[| \msg -> addFailure (Just $qloc) msg >> die |]---- | 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)---- | Attach metadata to a test run. This will be included in reports.-note :: Text -> Text -> Assertions ()-note key value = Assertions (\(notes, fs) -> do-	modifyIORef notes ((key, value) :)-	return (Just (), (notes, fs)))--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-	let Assertion io = toAssertion assertion-	result <- liftIO io-	case result of-		AssertionPassed -> return ()-		AssertionFailed err -> do-			addFailure (Just loc) err-			when fatal die---- | Run an 'Assertion'. If the assertion fails, the test will immediately--- fail.------ '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 = 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).------ '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 = 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)))---- | Assert that two values are equal.-equal :: (Show a, Eq a) => a -> a -> Assertion-equal x y = pure (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 = pure (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 = pure-	((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 = pure (isJust x) ("just: received Nothing")---- | Assert that some value is @Nothing@.-nothing :: Maybe a -> Assertion-nothing x = pure (isNothing x) ("nothing: received Just")---- | 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---- | 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---- | 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-	either_exc <- Control.Exception.try io-	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"))))---- | 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-	either_exc <- Control.Exception.try io-	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"))))---- | Assert a value is greater than another.-greater :: (Ord a, Show a) => a -> a -> Assertion-greater x y = pure (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 = pure (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 = pure (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 = pure (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) -> pure 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.-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 = checkDiff (toLines x) (toLines y) where-	checkDiff xs ys = case checkItems (Patience.diff xs ys) of-		(same, diff) -> pure 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 = "equalLines: lines differ\n" ++ diff

− src/Test/Chell/Main.hs

@@ -1,435 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Test.Chell.Main-	( defaultMain-	) where--import           Control.Monad (forM, forM_, unless, when)-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 qualified System.Console.GetOpt as GetOpt-import           System.Environment (getArgs, getProgName)-import           System.Exit (exitSuccess, exitFailure)-import qualified System.IO as IO-import           System.Random (randomIO)-import           Text.Printf (printf)--import           Test.Chell.Types--data Option-	= OptionHelp-	| OptionVerbose-	| OptionXmlReport FilePath-	| OptionJsonReport FilePath-	| OptionTextReport FilePath-	| OptionSeed Int-	| OptionTimeout Int-	deriving (Show, Eq)--optionInfo :: [GetOpt.OptDescr Option]-optionInfo =-	[ GetOpt.Option ['h'] ["help"]-	  (GetOpt.NoArg OptionHelp)-	  "show this help"-	-	, GetOpt.Option ['v'] ["verbose"]-	  (GetOpt.NoArg OptionVerbose)-	  "print more output"-	-	, GetOpt.Option [] ["xml-report"]-	  (GetOpt.ReqArg OptionXmlReport "PATH")-	  "write a parsable report to a file, in XML"-	-	, GetOpt.Option [] ["json-report"]-	  (GetOpt.ReqArg OptionJsonReport "PATH")-	  "write a parsable report to a file, in JSON"-	-	, GetOpt.Option [] ["text-report"]-	  (GetOpt.ReqArg OptionTextReport "PATH")-	  "write a human-readable report"-	-	, GetOpt.Option [] ["seed"]-	  (GetOpt.ReqArg (\s -> case parseInt s of-	   	Just x -> OptionSeed x-	   	Nothing -> error ("Failed to parse --seed value " ++ show s)) "SEED")-	  "the seed used for random numbers in (for example) quickcheck"-	-	, GetOpt.Option [] ["timeout"]-	  (GetOpt.ReqArg (\s -> case parseTimeout s of-	  	Just x -> OptionTimeout x-	  	Nothing -> error ("Failed to parse --timeout value " ++ show s)) "TIMEOUT")-	  "the maximum duration of a test, in milliseconds"-	-	]--parseInt :: String -> Maybe Int-parseInt s = case [x | (x, "") <- reads s] of-	[x] -> Just x-	_ -> Nothing--parseTimeout :: String -> Maybe Int-parseTimeout s = do-	msec <- parseInt s-	if (toInteger msec) * 1000 > toInteger (maxBound :: Int)-		then Nothing-		else return msec--getSeedOpt :: [Option] -> Maybe Int-getSeedOpt [] = Nothing-getSeedOpt ((OptionSeed s) : _) = Just s-getSeedOpt (_:os) = getSeedOpt os--getTimeoutOpt :: [Option] -> Maybe Int-getTimeoutOpt [] = Nothing-getTimeoutOpt ((OptionTimeout s) : _) = Just s-getTimeoutOpt (_:os) = getTimeoutOpt os--usage :: String -> String-usage name = "Usage: " ++ name ++ " [OPTION...]"---- | A simple default main function, which runs a list of tests and logs--- statistics to stderr.-defaultMain :: [Suite] -> IO ()-defaultMain suites = do-	args <- getArgs-	let (options, filters, optionErrors) = GetOpt.getOpt GetOpt.Permute optionInfo args-	unless (null optionErrors) $ do-		name <- getProgName-		IO.hPutStrLn IO.stderr (concat optionErrors)-		IO.hPutStrLn IO.stderr (GetOpt.usageInfo (usage name) optionInfo)-		exitFailure-	-	when (OptionHelp `elem` options) $ do-		name <- getProgName-		putStrLn (GetOpt.usageInfo (usage name) optionInfo)-		exitSuccess-	-	let allTests = concatMap suiteTests suites-	let tests = if null filters-		then allTests-		else filter (matchesFilter filters) allTests-	-	seed <- case getSeedOpt options of-		Just s -> return s-		Nothing -> randomIO-	-	let testOptions = TestOptions-		{ testOptionSeed_ = seed-		, testOptionTimeout_ = getTimeoutOpt options-		}-	-	let verbose = elem OptionVerbose options-	results <- forM tests $ \t -> do-		result <- runTest t testOptions-		printResult verbose t result-		return (t, result)-	-	let reports = getReports options-	forM_ reports $ \(path, fmt, toText) ->-		IO.withBinaryFile path IO.WriteMode $ \h -> do-			let text = toText results-			let bytes = Data.Text.Encoding.encodeUtf8 text-			when verbose $ do-				putStrLn ("Writing " ++ fmt ++ " report to " ++ show path)-			Data.ByteString.hPut h bytes-	-	let stats = resultStatistics results-	let (_, _, failed, aborted) = stats-	Data.Text.IO.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-	check t = any (matchName (testName t)) filters-	matchName name f = f == name || Data.Text.isPrefixOf (Data.Text.append f ".") name--printResult :: Bool -> Test -> TestResult -> IO ()-printResult verbose t result = case result of-	TestPassed _ -> when verbose $ do-		Data.Text.IO.putStr (testName t)-		putStrLn ": PASS"-	TestSkipped -> when verbose $ do-		Data.Text.IO.putStr (testName t)-		putStrLn ": SKIPPED"-	TestFailed notes fs -> do-		putStrLn (replicate 70 '=')-		Data.Text.IO.putStr (testName t)-		putStrLn ": FAILED"-		forM_ notes $ \(key, value) -> do-			putStr "\t"-			Data.Text.IO.putStr key-			putStr "="-			Data.Text.IO.putStrLn value-		putStrLn (replicate 70 '=')-		forM_ fs $ \(Failure loc msg) -> do-			case loc of-				Just loc' -> do-					Data.Text.IO.putStr (locationFile loc')-					putStr ":"-					putStrLn (show (locationLine loc'))-				Nothing -> return ()-			Data.Text.IO.putStr msg-			putStr "\n\n"-	TestAborted notes msg -> do-		putStrLn (replicate 70 '=')-		Data.Text.IO.putStr (testName t)-		putStrLn ": ABORTED"-		forM_ notes $ \(key, value) -> do-			putStr "\t"-			Data.Text.IO.putStr key-			putStr "="-			Data.Text.IO.putStrLn value-		putStrLn (replicate 70 '=')-		Data.Text.IO.putStr msg-		putStr "\n\n"--type Report = [(Test, TestResult)] -> Text--getReports :: [Option] -> [(FilePath, String, Report)]-getReports = concatMap step where-	step (OptionXmlReport path) = [(path, "XML", xmlReport)]-	step (OptionJsonReport path) = [(path, "JSON", jsonReport)]-	step (OptionTextReport path) = [(path, "text", textReport)]-	step _  = []--jsonReport :: [(Test, TestResult)] -> Text-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 $ \(Failure loc msg) -> do-				tell "{\"message\": \""-				tell (escapeJSON msg)-				tell "\""-				case loc of-					Just loc' -> do-						tell ", \"location\": {\"module\": \""-						tell (escapeJSON (locationModule loc'))-						tell "\", \"file\": \""-						tell (escapeJSON (locationFile loc'))-						tell "\", \"line\": "-						tell (pack (show (locationLine loc')))-						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 "}"-	-	escapeJSON = Data.Text.concatMap (\c -> case c of-		'"' -> "\\\""-		'\\' -> "\\\\"-		_ | ord c <= 0x1F -> pack (printf "\\u%04X" (ord c))-		_ -> Data.Text.singleton 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)] -> Text-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 $ \(Failure loc msg) -> do-				tell "\t\t<failure message='"-				tell (escapeXML msg)-				case loc of-					Just loc' -> do-						tell "'>\n"-						tell "\t\t\t<location module='"-						tell (escapeXML (locationModule loc'))-						tell "' file='"-						tell (escapeXML (locationFile loc'))-						tell "' line='"-						tell (pack (show (locationLine loc')))-						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"-	-	escapeXML = Data.Text.concatMap (\c -> case c of-		'&' -> "&amp;"-		'<' -> "&lt;"-		'>' -> "&gt;"-		'"' -> "&quot;"-		'\'' -> "&apos;"-		_ -> Data.Text.singleton 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)] -> Text-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 (Data.Text.replicate 70 "=")-			tell "\n"-			tell "PASSED: "-			tell (testName t)-			tell "\n"-			tellNotes notes-			tell "\n\n"-		TestSkipped -> do-			tell (Data.Text.replicate 70 "=")-			tell "\n"-			tell "SKIPPED: "-			tell (testName t)-			tell "\n\n"-		TestFailed notes fs -> do-			tell (Data.Text.replicate 70 "=")-			tell "\n"-			tell "FAILED: "-			tell (testName t)-			tell "\n"-			tellNotes notes-			tell (Data.Text.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')))-						tell "\n"-					Nothing -> return ()-				tell msg-				tell "\n\n"-		TestAborted notes msg -> do-			tell (Data.Text.replicate 70 "=")-			tell "\n"-			tell "ABORTED: "-			tell (testName t)-			tell "\n"-			tellNotes notes-			tell (Data.Text.replicate 70 "-")-			tell "\n"-			tell msg-			tell "\n\n"-	-	tellNotes notes = forM_ notes $ \(key, value) -> do-		tell key-		tell "="-		tell value-		tell "\n"--formatResultStatistics :: (Integer, Integer, Integer, Integer) -> Text-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 pack (comma ++ "1 test " ++ what)-			else pack (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))

− src/Test/Chell/Types.hs

@@ -1,100 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Test.Chell.Types where--import qualified Control.Exception-import           Control.Exception (SomeException)-import qualified Data.Text-import           Data.Text (Text)-import           System.Timeout (timeout)--data Test = Test Text (TestOptions -> IO TestResult)--instance Show Test where-	show (Test name _) = "<Test " ++ show name ++ ">"--data TestOptions = TestOptions-	{ testOptionSeed_ :: Int-	, testOptionTimeout_ :: Maybe Int-	}-	deriving (Show, Eq)---- | @testName (Test name _) = name@-testName :: Test -> Text-testName (Test name _) = name---- | 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 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-		str = "Test timed out after " ++ show time ++ " milliseconds"-		Just time = testOptionTimeout_ opts-	-	let errorExc :: SomeException -> Text-	    errorExc exc = Data.Text.pack ("Test aborted due to exception: " ++ show exc)-	-	tried <- withTimeout (Control.Exception.try getResult)-	case tried of-		Just (Right ret) -> return ret-		Nothing -> do-			notes <- getNotes-			return (TestAborted notes hitTimeout)-		Just (Left exc) -> do-			notes <- getNotes-			return (TestAborted notes (errorExc 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)---- | 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]