packages feed

chell (empty) → 0.1

raw patch · 6 files changed

+1021/−0 lines, 6 filesdep +basedep +bytestringdep +patiencesetup-changed

Dependencies added: base, bytestring, patience, random, template-haskell, text, transformers

Files

+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ chell.cabal view
@@ -0,0 +1,36 @@+name: chell+version: 0.1+synopsis: Quiet test runner+license: MIT+license-file: license.txt+author: 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++source-repository head+  type: bazaar+  location: https://john-millikin.com/software/chell/++library+  ghc-options: -Wall+  hs-source-dirs: src++  build-depends:+      base >= 4 && < 5+    , bytestring >= 0.9 && < 0.10+    , patience >= 0.1 && < 0.2+    , random+    , template-haskell >= 2.3 && < 2.6+    , text >= 0.7+    , transformers >= 0.2 && < 0.3++  exposed-modules:+    Test.Chell++  other-modules:+    Test.Chell.Main+    Test.Chell.Types
+ license.txt view
@@ -0,0 +1,22 @@+Copyright (c) 2011 John Millikin++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ src/Test/Chell.hs view
@@ -0,0 +1,426 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}++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+	, 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)+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 -> Bool -> Text -> Assertions ()+addFailure maybe_loc fatal 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 ( if fatal then Nothing else Just ()+	       , (notes, Failure loc msg : fs))++-- | Cause a test to immediately fail, with a message.+--+-- 'fail' is a Template Haskell macro, to retain the source-file location+-- from which it was used. Its effective type is:+--+-- @+-- $fail :: 'Text' -> 'Assertions' ()+-- @+fail :: TH.Q TH.Exp -- :: Text -> Assertions ()+fail = do+	loc <- TH.location+	let qloc = liftLoc loc+	[| addFailure (Just $qloc) True |]++-- | 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 -> addFailure (Just loc) fatal err++-- | 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 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 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))
+ src/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]