chell 0.2.2 → 0.2.3

raw patch · 4 files changed

+120/−48 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• chell.cabal +37/−3
• lib/Test/Chell.hs +50/−38
• lib/Test/Chell/Main.hs +3/−3
• lib/Test/Chell/Types.hs +30/−4

@@ -1,5 +1,5 @@ name: chell-version: 0.2.2+version: 0.2.3 license: MIT license-file: license.txt author: John Millikin <jmillikin@gmail.com>@@ -10,8 +10,42 @@ bug-reports: mailto:jmillikin@gmail.com homepage: https://john-millikin.com/software/chell/ -synopsis: A quiet test runner+synopsis: A simple and intuitive library for automated testing. description:+  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.+  .+  @+  &#x7b;-\# LANGUAGE OverloadedStrings \#-&#x7d;+  &#x7b;-\# LANGUAGE TemplateHaskell \#-&#x7d;+  .+  import Test.Chell+  .+  test_Math :: Suite+  test_Math = suite \"math\" [test_Addition, test_Subtraction]+  .+  test_Addition :: Suite+  test_Addition = assertions \"addition\" $ do+  &#x20;   $expect (equal (2 + 1) 3)+  &#x20;   $expect (equal (1 + 2) 3)+  .+  test_Subtraction :: Suite+  test_Subtraction = assertions \"subtraction\" $ do+  &#x20;   $expect (equal (2 - 1) 1)+  &#x20;   $expect (equal (1 - 2) (-1))+  .+  main :: IO ()+  main = defaultMain [test_Math]+  @+  .+  @+  $ ghc --make chell-example.hs+  $ ./chell-example+  PASS: 2 tests run, 2 tests passed+  @  source-repository head   type: bazaar@@ -20,7 +54,7 @@ source-repository this   type: bazaar   location: https://john-millikin.com/branches/chell/0.2/-  tag: chell_0.2.2+  tag: chell_0.2.3  library   hs-source-dirs: lib

@@ -25,11 +25,13 @@ 	, IsAssertion 	, Assertions 	, assertions+	, assertionsTest 	, assert 	, expect 	, Test.Chell.fail 	, trace 	, note+	, afterTest 	 	-- ** Assertions 	, equal@@ -56,6 +58,7 @@ 	, runTest 	 	, TestOptions+	, defaultTestOptions 	, testOptionSeed 	, testOptionTimeout 	, TestResult (..)@@ -85,21 +88,6 @@ 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. --@@ -153,7 +141,7 @@ 		then AssertionPassed 		else AssertionFailed "$assert: boolean assertion failed")) -type TestState = (IORef [(Text, Text)], [Failure])+type TestState = (IORef [(Text, Text)], IORef [IO ()], [Failure]) newtype Assertions a = Assertions { unAssertions :: TestState -> IO (Maybe a, TestState) }  instance Functor Assertions where@@ -185,26 +173,43 @@ --     $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+assertions name io = test (assertionsTest name io) +-- | Convert a sequence of pass/fail assertions into a runnable test.+--+-- This is easier to use than 'assertions' when the result is going to be+-- modified (eg, by a wrapper) before being used in a test suite.+--+-- Most users should use 'assertions' instead, to avoid the extra wrapping+-- step.+assertionsTest :: Text -> Assertions a -> Test+assertionsTest 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 -> Text -> Assertions ()-addFailure maybe_loc msg = Assertions $ \(notes, fs) -> do+addFailure maybe_loc msg = Assertions $ \(notes, afterTestRef, fs) -> do 	let loc = do 		th_loc <- maybe_loc 		return $ Location@@ -212,7 +217,7 @@ 			, locationModule = Data.Text.pack (TH.loc_module th_loc) 			, locationLine = toInteger (fst (TH.loc_start th_loc)) 			}-	return (Just (), (notes, Failure loc msg : fs))+	return (Just (), (notes, afterTestRef, Failure loc msg : fs))  die :: Assertions a die = Assertions (\s -> return (Nothing, s))@@ -238,10 +243,17 @@  -- | Attach metadata to a test run. This will be included in reports. note :: Text -> Text -> Assertions ()-note key value = Assertions (\(notes, fs) -> do+note key value = Assertions (\(notes, afterTestRef, fs) -> do 	modifyIORef notes ((key, value) :)-	return (Just (), (notes, fs)))+	return (Just (), (notes, afterTestRef, fs))) +-- | Register an IO action to be run after the test completes. This action+-- will run even if the test failed or threw an exception.+afterTest :: IO () -> Assertions ()+afterTest io = Assertions (\(notes, ref, fs) -> do+	modifyIORef ref (io :)+	return (Just (), (notes, ref, fs)))+ liftLoc :: TH.Loc -> TH.Q TH.Exp liftLoc loc = [| TH.Loc filename package module_ start end |] where 	filename = TH.loc_filename loc@@ -361,7 +373,7 @@  -- | 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)+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

@@ -120,9 +120,9 @@ 		Just s -> return s 		Nothing -> randomIO 	-	let testOptions = TestOptions-		{ testOptionSeed_ = seed-		, testOptionTimeout_ = getTimeoutOpt options+	let testOptions = defaultTestOptions+		{ testOptionSeed = seed+		, testOptionTimeout = getTimeoutOpt options 		} 	 	let verbose = elem OptionVerbose options

@@ -14,11 +14,37 @@ 	show (Test name _) = "<Test " ++ show name ++ ">"  data TestOptions = TestOptions-	{ testOptionSeed_ :: Int-	, testOptionTimeout_ :: Maybe Int+	{+	+	-- | 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 :: 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 :: Maybe Int 	} 	deriving (Show, Eq) +-- | Default test options.+--+-- @+--'testOptionSeed' defaultTestOptions = 0+--'testOptionTimeout' defaultTestOptions = Nothing+-- @+defaultTestOptions :: TestOptions+defaultTestOptions = TestOptions+	{ testOptionSeed = 0+	, testOptionTimeout = Nothing+	}+ -- | @testName (Test name _) = name@ testName :: Test -> Text testName (Test name _) = name@@ -30,13 +56,13 @@  handleJankyIO :: TestOptions -> IO TestResult -> IO [(Text, Text)] -> IO TestResult handleJankyIO opts getResult getNotes = do-	let withTimeout = case testOptionTimeout_ opts of+	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+		Just time = testOptionTimeout opts 	 	let errorExc :: SomeException -> Text 	    errorExc exc = Data.Text.pack ("Test aborted due to exception: " ++ show exc)