chell 0.4.0.2 → 0.5.0.2
raw patch · 8 files changed
Files
- Setup.hs +0/−2
- Test/Chell.hs +425/−309
- Test/Chell/Main.hs +443/−365
- Test/Chell/Output.hs +146/−124
- Test/Chell/Types.hs +181/−179
- changelog.md +35/−0
- chell.cabal +36/−73
- readme.md +33/−0
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
Test/Chell.hs view
@@ -1,150 +1,144 @@ {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-} -- | Chell is a simple and intuitive library for automated testing. It natively -- supports assertion-based testing, and can use companion libraries -- such as @chell-quickcheck@ to support more complex testing strategies. ----- An example test suite, which verifies the behavior of artithmetic operators.+-- An example test suite, which verifies the behavior of arithmetic operators. -- -- @---{-\# LANGUAGE TemplateHaskell \#-}+-- {-\# LANGUAGE TemplateHaskell \#-} -----import Test.Chell+-- import Test.Chell -----suite_Math :: Suite---suite_Math = 'suite' \"math\"+-- suite_Math :: Suite+-- suite_Math = 'suite' \"math\" -- [ test_Addition -- , test_Subtraction -- ] -----test_Addition :: Test---test_Addition = 'assertions' \"addition\" $ do+-- test_Addition :: Test+-- test_Addition = 'assertions' \"addition\" $ do -- $'expect' ('equal' (2 + 1) 3) -- $'expect' ('equal' (1 + 2) 3) -----test_Subtraction :: Test---test_Subtraction = 'assertions' \"subtraction\" $ do+-- test_Subtraction :: Test+-- test_Subtraction = 'assertions' \"subtraction\" $ do -- $'expect' ('equal' (2 - 1) 1) -- $'expect' ('equal' (1 - 2) (-1)) -----main :: IO ()---main = 'defaultMain' [suite_Math]+-- main :: IO ()+-- main = 'defaultMain' [suite_Math] -- @ -- -- >$ ghc --make chell-example.hs -- >$ ./chell-example -- >PASS: 2 tests run, 2 tests passed module Test.Chell- (- - -- * Main- defaultMain- - -- * Test suites- , Suite- , suite- , suiteName- , suiteTests- - -- ** Skipping some tests- , SuiteOrTest- , skipIf- , skipWhen- - -- * Basic testing library- , Assertions- , assertions- , IsAssertion- , Assertion- , assertionPassed- , assertionFailed- , assert- , expect- , die- , trace- , note- , afterTest- , requireLeft- , requireRight- - -- ** Built-in assertions- , equal- , notEqual- , equalWithin- , just- , nothing- , left- , right- , throws- , throwsEq- , greater- , greaterEqual- , lesser- , lesserEqual- , sameItems- , equalItems- , IsText- , equalLines- , equalLinesWith- - -- * Custom test types- , Test- , test- , testName- , runTest- - -- ** Test results- , TestResult (..)- - -- *** Failures- , Failure- , failure- , failureLocation- , failureMessage- - -- *** Failure locations- , Location- , location- , locationFile- , locationModule- , locationLine- - -- ** Test options- , TestOptions- , defaultTestOptions- , testOptionSeed- , testOptionTimeout- ) where+ ( -- * Main+ defaultMain, -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+ -- * Test suites+ Suite,+ suite,+ suiteName,+ suiteTests, -import qualified Language.Haskell.TH as TH+ -- ** Skipping some tests+ SuiteOrTest,+ skipIf,+ skipWhen, -import Test.Chell.Main (defaultMain)-import Test.Chell.Types+ -- * Basic testing library+ Assertions,+ assertions,+ IsAssertion,+ Assertion,+ assertionPassed,+ assertionFailed,+ assert,+ expect,+ die,+ trace,+ note,+ afterTest,+ requireLeft,+ requireRight, + -- ** Built-in assertions+ equal,+ notEqual,+ equalWithin,+ just,+ nothing,+ left,+ right,+ throws,+ throwsEq,+ greater,+ greaterEqual,+ lesser,+ lesserEqual,+ sameItems,+ equalItems,+ IsText,+ equalLines,+ equalLinesWith,++ -- * Custom test types+ Test,+ test,+ testName,+ runTest,++ -- ** Test results+ TestResult (..),++ -- *** Failures+ Failure,+ failure,+ failureLocation,+ failureMessage,++ -- *** Failure locations+ Location,+ location,+ locationFile,+ locationModule,+ locationLine,++ -- ** Test options+ TestOptions,+ defaultTestOptions,+ testOptionSeed,+ testOptionTimeout,+ )+where++import Control.Applicative qualified+import Control.Exception (Exception)+import Control.Exception qualified+import Control.Monad (ap, liftM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.ByteString.Char8 qualified+import Data.ByteString.Lazy.Char8 qualified+import Data.IORef (IORef, modifyIORef, newIORef, readIORef)+import Data.List (foldl', intercalate, sort)+import Data.Maybe (isJust, isNothing)+import Data.Text (Text)+import Data.Text qualified+import Data.Text.Lazy qualified+import Language.Haskell.TH qualified as TH+import Patience qualified+import Test.Chell.Main (defaultMain)+import Test.Chell.Types+ -- | A single pass/fail assertion. Failed assertions include an explanatory -- message. data Assertion- = AssertionPassed- | AssertionFailed String- deriving (Eq, Show)+ = AssertionPassed+ | AssertionFailed String+ deriving (Eq, Show) -- | See 'Assertion'. assertionPassed :: Assertion@@ -156,43 +150,54 @@ -- | See 'assert' and 'expect'. class IsAssertion a where- runAssertion :: a -> IO Assertion+ runAssertion :: a -> IO Assertion instance IsAssertion Assertion where- runAssertion = return+ runAssertion = return instance IsAssertion Bool where- runAssertion x = return $ if x- then assertionPassed- else assertionFailed "boolean assertion failed"+ runAssertion x =+ return+ ( if x+ then assertionPassed+ else assertionFailed "boolean assertion failed"+ ) instance IsAssertion a => IsAssertion (IO a) where- runAssertion x = x >>= runAssertion+ runAssertion x = x >>= runAssertion type TestState = (IORef [(String, String)], IORef [IO ()], [Failure]) -- | See 'assertions'.-newtype Assertions a = Assertions { unAssertions :: TestState -> IO (Maybe a, TestState) }+newtype Assertions a = Assertions+ {unAssertions :: TestState -> IO (Maybe a, TestState)} instance Functor Assertions where- fmap = liftM+ fmap = liftM instance Control.Applicative.Applicative Assertions where- pure = return- (<*>) = ap+ pure x = Assertions (\s -> pure (Just x, s))+ (<*>) = 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')+ 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))+ liftIO io =+ Assertions+ ( \s ->+ do+ x <- io+ return (Just x, s)+ ) -- | Convert a sequence of pass/fail assertions into a runnable test. --@@ -203,45 +208,56 @@ -- $assert (equal 1 1) -- @ assertions :: String -> Assertions a -> Test-assertions name testm = test name $ \opts -> do- noteRef <- newIORef []- afterTestRef <- newIORef []- - let getNotes = fmap reverse (readIORef noteRef)- - let getResult = do- res <- unAssertions testm (noteRef, afterTestRef, [])- case res of- (_, (_, _, [])) -> do- notes <- getNotes- return (TestPassed notes)- (_, (_, _, fs)) -> do- notes <- getNotes- return (TestFailed notes (reverse fs))- - Control.Exception.finally- (handleJankyIO opts getResult getNotes)- (runAfterTest afterTestRef)+assertions name testm =+ test name $ \opts ->+ do+ noteRef <- newIORef []+ afterTestRef <- newIORef [] + let getNotes = fmap reverse (readIORef noteRef)++ let getResult =+ do+ res <- unAssertions testm (noteRef, afterTestRef, [])+ case res of+ (_, (_, _, [])) ->+ do+ notes <- getNotes+ return (TestPassed notes)+ (_, (_, _, fs)) ->+ do+ notes <- getNotes+ return (TestFailed notes (reverse fs))++ Control.Exception.finally+ (handleJankyIO opts getResult getNotes)+ (runAfterTest afterTestRef)+ runAfterTest :: IORef [IO ()] -> IO ()-runAfterTest ref = readIORef ref >>= loop where- loop [] = return ()- loop (io:ios) = Control.Exception.finally (loop ios) io+runAfterTest ref = readIORef ref >>= loop+ where+ loop [] = return ()+ loop (io : ios) = Control.Exception.finally (loop ios) io addFailure :: Maybe TH.Loc -> String -> Assertions ()-addFailure maybe_loc msg = Assertions $ \(notes, afterTestRef, fs) -> do- let loc = do- th_loc <- maybe_loc- return $ location- { locationFile = TH.loc_filename th_loc- , locationModule = TH.loc_module th_loc- , locationLine = Just (toInteger (fst (TH.loc_start th_loc)))- }- let f = failure- { failureLocation = loc- , failureMessage = msg- }- return (Just (), (notes, afterTestRef, f : fs))+addFailure maybe_loc msg =+ Assertions $ \(notes, afterTestRef, fs) ->+ do+ let loc =+ do+ th_loc <- maybe_loc+ return $+ location+ { locationFile = TH.loc_filename th_loc,+ locationModule = TH.loc_module th_loc,+ locationLine = Just (toInteger (fst (TH.loc_start th_loc)))+ }+ let f =+ failure+ { failureLocation = loc,+ failureMessage = msg+ }+ return (Just (), (notes, afterTestRef, f : fs)) -- | Cause a test to immediately fail, with a message. --@@ -249,18 +265,22 @@ -- which it was used. Its effective type is: -- -- @+ -- $die :: 'String' -> 'Assertions' a -- @+ die :: TH.Q TH.Exp-die = do- loc <- TH.location- let qloc = liftLoc loc- [| \msg -> dieAt $qloc ("die: " ++ msg) |]+die =+ do+ loc <- TH.location+ let qloc = liftLoc loc+ [|\msg -> dieAt $qloc ("die: " ++ msg)|] dieAt :: TH.Loc -> String -> Assertions a-dieAt loc msg = do- addFailure (Just loc) msg- Assertions (\s -> return (Nothing, s))+dieAt loc msg =+ do+ addFailure (Just loc) msg+ Assertions (\s -> return (Nothing, s)) -- | Print a message from within a test. This is just a helper for debugging, -- so you don't have to import @Debug.Trace@. Messages will be prefixed with@@ -270,35 +290,48 @@ -- from which it was used. Its effective type is: -- -- @+ -- $trace :: 'String' -> 'Assertions' () -- @+ trace :: TH.Q TH.Exp-trace = do- loc <- TH.location- let qloc = liftLoc loc- [| traceAt $qloc |]+trace =+ do+ loc <- TH.location+ let qloc = liftLoc loc+ [|traceAt $qloc|] traceAt :: TH.Loc -> String -> Assertions ()-traceAt loc msg = liftIO $ do- let file = TH.loc_filename loc- let line = fst (TH.loc_start loc)- putStr ("[" ++ file ++ ":" ++ show line ++ "] ")- putStrLn msg+traceAt loc msg =+ liftIO $+ do+ let file = TH.loc_filename loc+ line = fst (TH.loc_start loc)+ putStr ("[" ++ file ++ ":" ++ show line ++ "] ")+ putStrLn msg -- | Attach a note to a test run. Notes will be printed to stdout and -- included in reports, even if the test fails or aborts. Notes are useful for -- debugging failing tests. note :: String -> String -> Assertions ()-note key value = Assertions (\(notes, afterTestRef, fs) -> do- modifyIORef notes ((key, value) :)- return (Just (), (notes, afterTestRef, fs)))+note key value =+ Assertions+ ( \(notes, afterTestRef, fs) ->+ do+ modifyIORef notes ((key, value) :)+ return (Just (), (notes, afterTestRef, fs))+ ) -- | Register an IO action to be run after the test completes. This action -- will run even if the test failed or aborted. afterTest :: IO () -> Assertions ()-afterTest io = Assertions (\(notes, ref, fs) -> do- modifyIORef ref (io :)- return (Just (), (notes, ref, fs)))+afterTest io =+ Assertions+ ( \(notes, ref, fs) ->+ do+ modifyIORef ref (io :)+ return (Just (), (notes, ref, fs))+ ) -- | Require an 'Either' value to be 'Left', and return its contents. If -- the value is 'Right', fail the test.@@ -307,20 +340,25 @@ -- location from which it was used. Its effective type is: -- -- @+ -- $requireLeft :: 'Show' b => 'Either' a b -> 'Assertions' a -- @+ requireLeft :: TH.Q TH.Exp-requireLeft = do- loc <- TH.location- let qloc = liftLoc loc- [| requireLeftAt $qloc |]+requireLeft =+ do+ loc <- TH.location+ let qloc = liftLoc loc+ [|requireLeftAt $qloc|] requireLeftAt :: Show b => TH.Loc -> Either a b -> Assertions a-requireLeftAt loc val = case val of- Left a -> return a- Right b -> do- let dummy = Right b `asTypeOf` Left ()- dieAt loc ("requireLeft: received " ++ showsPrec 11 dummy "")+requireLeftAt loc val =+ case val of+ Left a -> return a+ Right b ->+ do+ let dummy = Right b `asTypeOf` Left ()+ dieAt loc ("requireLeft: received " ++ showsPrec 11 dummy "") -- | Require an 'Either' value to be 'Right', and return its contents. If -- the value is 'Left', fail the test.@@ -329,37 +367,46 @@ -- location from which it was used. Its effective type is: -- -- @+ -- $requireRight :: 'Show' a => 'Either' a b -> 'Assertions' b -- @+ requireRight :: TH.Q TH.Exp-requireRight = do- loc <- TH.location- let qloc = liftLoc loc- [| requireRightAt $qloc |]+requireRight =+ do+ loc <- TH.location+ let qloc = liftLoc loc+ [|requireRightAt $qloc|] requireRightAt :: Show a => TH.Loc -> Either a b -> Assertions b-requireRightAt loc val = case val of- Left a -> do- let dummy = Left a `asTypeOf` Right ()- dieAt loc ("requireRight: received " ++ showsPrec 11 dummy "")- Right b -> return b+requireRightAt loc val =+ case val of+ Left a ->+ do+ let dummy = Left a `asTypeOf` Right ()+ dieAt loc ("requireRight: received " ++ showsPrec 11 dummy "")+ Right b -> return b liftLoc :: TH.Loc -> TH.Q TH.Exp-liftLoc loc = [| TH.Loc filename package module_ start end |] where- filename = TH.loc_filename loc- package = TH.loc_package loc- module_ = TH.loc_module loc- start = TH.loc_start loc- end = TH.loc_end loc+liftLoc loc =+ [|TH.Loc filename package module_ start end|]+ where+ filename = TH.loc_filename loc+ package = TH.loc_package loc+ module_ = TH.loc_module loc+ start = TH.loc_start loc+ end = TH.loc_end loc assertAt :: IsAssertion assertion => TH.Loc -> Bool -> assertion -> Assertions ()-assertAt loc fatal assertion = do- result <- liftIO (runAssertion assertion)- case result of- AssertionPassed -> return ()- AssertionFailed err -> if fatal- then dieAt loc err- else addFailure (Just loc) err+assertAt loc fatal assertion =+ do+ result <- liftIO (runAssertion assertion)+ case result of+ AssertionPassed -> return ()+ AssertionFailed err ->+ if fatal+ then dieAt loc err+ else addFailure (Just loc) err -- | Check an assertion. If the assertion fails, the test will immediately -- fail.@@ -371,13 +418,16 @@ -- from which it was used. Its effective type is: -- -- @+ -- $assert :: 'IsAssertion' assertion => assertion -> 'Assertions' () -- @+ assert :: TH.Q TH.Exp-assert = do- loc <- TH.location- let qloc = liftLoc loc- [| assertAt $qloc True |]+assert =+ do+ loc <- TH.location+ let qloc = liftLoc loc+ [|assertAt $qloc True|] -- | Check an assertion. If the assertion fails, the test will continue to -- run until it finishes, a call to 'assert' fails, or the test runs 'die'.@@ -389,33 +439,47 @@ -- from which it was used. Its effective type is: -- -- @+ -- $expect :: 'IsAssertion' assertion => assertion -> 'Assertions' () -- @+ expect :: TH.Q TH.Exp-expect = do- loc <- TH.location- let qloc = liftLoc loc- [| assertAt $qloc False |]+expect =+ do+ loc <- TH.location+ let qloc = liftLoc loc+ [|assertAt $qloc False|] assertBool :: Bool -> String -> Assertion-assertBool True _ = assertionPassed+assertBool True _ = assertionPassed assertBool False err = AssertionFailed err -- | Assert that two values are equal. equal :: (Show a, Eq a) => a -> a -> Assertion-equal x y = assertBool (x == y) ("equal: " ++ show x ++ " is not equal to " ++ show y)+equal x y =+ assertBool+ (x == y)+ ("equal: " ++ show x ++ " is not equal to " ++ show y) -- | Assert that two values are not equal. notEqual :: (Eq a, Show a) => a -> a -> Assertion-notEqual x y = assertBool (x /= y) ("notEqual: " ++ show x ++ " is equal to " ++ show y)+notEqual x y =+ assertBool+ (x /= y)+ ("notEqual: " ++ show x ++ " is equal to " ++ show y) -- | Assert that two values are within some delta of each other.-equalWithin :: (Real a, Show a) => a -> a- -> a -- ^ delta- -> Assertion-equalWithin x y delta = assertBool - ((x - delta <= y) && (x + delta >= y))- ("equalWithin: " ++ show x ++ " is not within " ++ show delta ++ " of " ++ show y)+equalWithin ::+ (Real a, Show a) =>+ a ->+ a ->+ -- | delta+ a ->+ Assertion+equalWithin x y delta =+ assertBool+ ((x - delta <= y) && (x + delta >= y))+ ("equalWithin: " ++ show x ++ " is not within " ++ show delta ++ " of " ++ show y) -- | Assert that some value is @Just@. just :: Maybe a -> Assertion@@ -423,117 +487,165 @@ -- | Assert that some value is @Nothing@. nothing :: Show a => Maybe a -> Assertion-nothing x = assertBool (isNothing x) ("nothing: received " ++ showsPrec 11 x "")+nothing x =+ assertBool+ (isNothing x)+ ("nothing: received " ++ showsPrec 11 x "") -- | Assert that some value is @Left@. left :: Show b => Either a b -> Assertion left (Left _) = assertionPassed-left (Right b) = assertionFailed ("left: received " ++ showsPrec 11 dummy "") where- dummy = Right b `asTypeOf` Left ()+left (Right b) = assertionFailed ("left: received " ++ showsPrec 11 dummy "")+ where+ dummy = Right b `asTypeOf` Left () -- | Assert that some value is @Right@. right :: Show a => Either a b -> Assertion right (Right _) = assertionPassed-right (Left a) = assertionFailed ("right: received " ++ showsPrec 11 dummy "") where- dummy = Left a `asTypeOf` Right ()+right (Left a) = assertionFailed ("right: received " ++ showsPrec 11 dummy "")+ where+ dummy = Left a `asTypeOf` Right () -- | Assert that some computation throws an exception matching the provided -- predicate. This is mostly useful for exception types which do not have an -- instance for @Eq@, such as @'Control.Exception.ErrorCall'@. throws :: Exception err => (err -> Bool) -> IO a -> IO Assertion-throws p io = do- either_exc <- Control.Exception.try io- return $ case either_exc of- Left exc -> if p exc- then assertionPassed- else assertionFailed ("throws: exception " ++ show exc ++ " did not match predicate")- Right _ -> assertionFailed "throws: no exception thrown"+throws p io =+ do+ either_exc <- Control.Exception.try io+ return $+ case either_exc of+ Left exc ->+ if p exc+ then assertionPassed+ else+ assertionFailed+ ( "throws: exception "+ ++ show exc+ ++ " did not match predicate"+ )+ Right _ -> assertionFailed "throws: no exception thrown" -- | Assert that some computation throws an exception equal to the given -- exception. This is better than just checking that the correct type was -- thrown, because the test can also verify the exception contains the correct -- information. throwsEq :: (Eq err, Exception err, Show err) => err -> IO a -> IO Assertion-throwsEq expected io = do- either_exc <- Control.Exception.try io- return $ case either_exc of- Left exc -> if exc == expected- then assertionPassed- else assertionFailed ("throwsEq: exception " ++ show exc ++ " is not equal to " ++ show expected)- Right _ -> assertionFailed "throwsEq: no exception thrown"+throwsEq expected io =+ do+ either_exc <- Control.Exception.try io+ return $+ case either_exc of+ Left exc ->+ if exc == expected+ then assertionPassed+ else+ assertionFailed+ ( "throwsEq: exception "+ ++ show exc+ ++ " is not equal to "+ ++ show expected+ )+ Right _ -> assertionFailed "throwsEq: no exception thrown" -- | Assert a value is greater than another. greater :: (Ord a, Show a) => a -> a -> Assertion-greater x y = assertBool (x > y) ("greater: " ++ show x ++ " is not greater than " ++ show y)+greater x y =+ assertBool+ (x > y)+ ("greater: " ++ show x ++ " is not greater than " ++ show y) -- | Assert a value is greater than or equal to another. greaterEqual :: (Ord a, Show a) => a -> a -> Assertion-greaterEqual x y = assertBool (x >= y) ("greaterEqual: " ++ show x ++ " is not greater than or equal to " ++ show y)+greaterEqual x y =+ assertBool+ (x >= y)+ ("greaterEqual: " ++ show x ++ " is not greater than or equal to " ++ show y) -- | Assert a value is less than another. lesser :: (Ord a, Show a) => a -> a -> Assertion-lesser x y = assertBool (x < y) ("lesser: " ++ show x ++ " is not less than " ++ show y)+lesser x y =+ assertBool+ (x < y)+ ("lesser: " ++ show x ++ " is not less than " ++ show y) -- | Assert a value is less than or equal to another. lesserEqual :: (Ord a, Show a) => a -> a -> Assertion-lesserEqual x y = assertBool (x <= y) ("lesserEqual: " ++ show x ++ " is not less than or equal to " ++ show y)+lesserEqual x y =+ assertBool+ (x <= y)+ ("lesserEqual: " ++ show x ++ " is not less than or equal to " ++ show y) -- | Assert that two containers have the same items, in any order.-sameItems :: (Foldable container, Show item, Ord item) => container item -> container item -> Assertion+sameItems ::+ (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 ::+ (Foldable container, Show item, Ord item) =>+ container item ->+ container item ->+ Assertion equalItems x y = equalDiff' "equalItems" id x y -equalDiff' :: (Foldable container, Show item, Ord item)- => String- -> ([item]- -> [item])- -> container item- -> container item- -> Assertion-equalDiff' label norm x y = checkDiff (items x) (items y) where- items = norm . foldMap (:[])- checkDiff xs ys = case checkItems (Patience.diff xs ys) of- (same, diff) -> assertBool same diff- - checkItems diffItems = case foldl' checkItem (True, []) diffItems of- (same, diff) -> (same, errorMsg (intercalate "\n" (reverse diff)))- - checkItem (same, acc) item = case item of- Patience.Old t -> (False, ("\t- " ++ show t) : acc)- Patience.New t -> (False, ("\t+ " ++ show t) : acc)- Patience.Both t _-> (same, ("\t " ++ show t) : acc)- - errorMsg diff = label ++ ": items differ\n" ++ diff+equalDiff' ::+ (Foldable container, Show item, Ord item) =>+ String ->+ ( [item] ->+ [item]+ ) ->+ container item ->+ container item ->+ Assertion+equalDiff' label norm x y = checkDiff (items x) (items y)+ where+ items = norm . foldMap (: [])+ checkDiff xs ys =+ case checkItems (Patience.diff xs ys) of+ (same, diff) -> assertBool same diff + checkItems diffItems =+ case foldl' checkItem (True, []) diffItems of+ (same, diff) -> (same, errorMsg (intercalate "\n" (reverse diff)))++ checkItem (same, acc) item =+ case item of+ Patience.Old t -> (False, ("\t- " ++ show t) : acc)+ Patience.New t -> (False, ("\t+ " ++ show t) : acc)+ Patience.Both t _ -> (same, ("\t " ++ show t) : acc)++ errorMsg diff = label ++ ": items differ\n" ++ diff+ -- | Class for types which can be treated as text; see 'equalLines'. class IsText a where- toLines :: a -> [a]- unpack :: a -> String+ toLines :: a -> [a]+ unpack :: a -> String instance IsText String where- toLines = lines- unpack = id+ toLines = lines+ unpack = id instance IsText Text where- toLines = Data.Text.lines- unpack = Data.Text.unpack+ 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+ 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+ 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+ 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@@ -547,16 +659,20 @@ equalLinesWith toStringLines x y = checkLinesDiff "equalLinesWith" (toStringLines x) (toStringLines y) checkLinesDiff :: (Ord a, IsText a) => String -> [a] -> [a] -> Assertion-checkLinesDiff label = go where- go xs ys = case checkItems (Patience.diff xs ys) of- (same, diff) -> assertBool same diff- - checkItems diffItems = case foldl' checkItem (True, []) diffItems of- (same, diff) -> (same, errorMsg (intercalate "\n" (reverse diff)))- - checkItem (same, acc) item = case item of- Patience.Old t -> (False, ("\t- " ++ unpack t) : acc)- Patience.New t -> (False, ("\t+ " ++ unpack t) : acc)- Patience.Both t _-> (same, ("\t " ++ unpack t) : acc)- - errorMsg diff = label ++ ": lines differ\n" ++ diff+checkLinesDiff label = go+ where+ go xs ys =+ case checkItems (Patience.diff xs ys) of+ (same, diff) -> assertBool same diff++ checkItems diffItems =+ case foldl' checkItem (True, []) diffItems of+ (same, diff) -> (same, errorMsg (intercalate "\n" (reverse diff)))++ checkItem (same, acc) item =+ case item of+ Patience.Old t -> (False, ("\t- " ++ unpack t) : acc)+ Patience.New t -> (False, ("\t+ " ++ unpack t) : acc)+ Patience.Both t _ -> (same, ("\t " ++ unpack t) : acc)++ errorMsg diff = label ++ ": lines differ\n" ++ diff
Test/Chell/Main.hs view
@@ -1,392 +1,470 @@-module Test.Chell.Main- ( defaultMain- ) where--import Control.Applicative-import Control.Monad (forM, forM_, when)-import Control.Monad.Trans.Class (lift)-import qualified Control.Monad.Trans.State as State-import qualified Control.Monad.Trans.Writer as Writer-import Data.Char (ord)-import Data.List (isPrefixOf)-import System.Exit (exitSuccess, exitFailure)-import System.IO (hPutStr, hPutStrLn, hIsTerminalDevice, stderr, stdout, withBinaryFile, IOMode(..))-import System.Random (randomIO)-import Text.Printf (printf)--import Options+module Test.Chell.Main (defaultMain) where -import Test.Chell.Output-import Test.Chell.Types+import Control.Monad (forM, forM_, when)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State qualified as State+import Control.Monad.Trans.Writer qualified as Writer+import Data.Char (ord)+import Data.List (isPrefixOf)+import Options+import System.Exit (exitFailure, exitSuccess)+import System.IO (IOMode (..), hIsTerminalDevice, hPutStr, hPutStrLn, stderr, stdout, withBinaryFile)+import System.Random (randomIO)+import Test.Chell.Output+import Test.Chell.Types+import Text.Printf (printf) data MainOptions = MainOptions- { optVerbose :: Bool- , optXmlReport :: String- , optJsonReport :: String- , optTextReport :: String- , optSeed :: Maybe Int- , optTimeout :: Maybe Int- , optColor :: ColorMode- }+ { optVerbose :: Bool,+ optXmlReport :: String,+ optJsonReport :: String,+ optTextReport :: String,+ optSeed :: Maybe Int,+ optTimeout :: Maybe Int,+ optColor :: ColorMode+ } optionType_ColorMode :: OptionType ColorMode-optionType_ColorMode = optionType "ColorMode" ColorModeAuto parseMode showMode where- parseMode s = case s of- "always" -> Right ColorModeAlways- "never" -> Right ColorModeNever- "auto" -> Right ColorModeAuto- _ -> Left (show s ++ " is not in {\"always\", \"never\", \"auto\"}.")- showMode mode = case mode of- ColorModeAlways -> "always"- ColorModeNever -> "never"- ColorModeAuto -> "auto"+optionType_ColorMode = optionType "ColorMode" ColorModeAuto parseMode showMode+ where+ parseMode s =+ case s of+ "always" -> Right ColorModeAlways+ "never" -> Right ColorModeNever+ "auto" -> Right ColorModeAuto+ _ -> Left (show s ++ " is not in {\"always\", \"never\", \"auto\"}.")+ showMode mode =+ case mode of+ ColorModeAlways -> "always"+ ColorModeNever -> "never"+ ColorModeAuto -> "auto" instance Options MainOptions where- defineOptions = pure MainOptions- <*> defineOption optionType_bool (\o -> o- { optionShortFlags = ['v']- , optionLongFlags = ["verbose"]- , optionDefault = False- , optionDescription = "Print more output."- })- - <*> simpleOption "xml-report" ""- "Write a parsable report to a given path, in XML."- <*> simpleOption "json-report" ""- "Write a parsable report to a given path, in JSON."- <*> simpleOption "text-report" ""- "Write a human-readable report to a given path."- - <*> simpleOption "seed" Nothing- "The seed used for random numbers in (for example) quickcheck."- - <*> simpleOption "timeout" Nothing- "The maximum duration of a test, in milliseconds."- - <*> defineOption optionType_ColorMode (\o -> o- { optionLongFlags = ["color"]- , optionDefault = ColorModeAuto- , optionDescription = "Whether to enable color ('always', 'auto', or 'never')."- })+ defineOptions =+ pure MainOptions+ <*> defineOption+ optionType_bool+ ( \o ->+ o+ { optionShortFlags = ['v'],+ optionLongFlags = ["verbose"],+ optionDefault = False,+ optionDescription = "Print more output."+ }+ )+ <*> simpleOption+ "xml-report"+ ""+ "Write a parsable report to a given path, in XML."+ <*> simpleOption+ "json-report"+ ""+ "Write a parsable report to a given path, in JSON."+ <*> simpleOption+ "text-report"+ ""+ "Write a human-readable report to a given path."+ <*> simpleOption+ "seed"+ Nothing+ "The seed used for random numbers in (for example) quickcheck."+ <*> simpleOption+ "timeout"+ Nothing+ "The maximum duration of a test, in milliseconds."+ <*> defineOption+ optionType_ColorMode+ ( \o ->+ o+ { optionLongFlags = ["color"],+ optionDefault = ColorModeAuto,+ optionDescription = "Whether to enable color ('always', 'auto', or 'never')."+ }+ ) -- | A simple default main function, which runs a list of tests and logs -- statistics to stdout. defaultMain :: [Suite] -> IO ()-defaultMain suites = runCommand $ \opts args -> do- -- validate/sanitize test options- seed <- case optSeed opts of- Just s -> return s- Nothing -> randomIO- timeout <- case optTimeout opts of- Nothing -> return Nothing- Just t -> if toInteger t * 1000 > toInteger (maxBound :: Int)- then do- hPutStrLn stderr "Test.Chell.defaultMain: Ignoring --timeout because it is too large."- return Nothing- else return (Just t)- let testOptions = defaultTestOptions- { testOptionSeed = seed- , testOptionTimeout = timeout- }- - -- find which tests to run- let allTests = concatMap suiteTests suites- let tests = if null args- then allTests- else filter (matchesFilter args) allTests- - -- output mode- output <- case optColor opts of- ColorModeNever -> return (plainOutput (optVerbose opts))- ColorModeAlways -> return (colorOutput (optVerbose opts))- ColorModeAuto -> do- isTerm <- hIsTerminalDevice stdout- return $ if isTerm- then colorOutput (optVerbose opts)- else plainOutput (optVerbose opts)- - -- run tests- results <- forM tests $ \t -> do- outputStart output t- result <- runTest t testOptions- outputResult output t result- return (t, result)- - -- generate reports- let reports = getReports opts- forM_ reports $ \(path, fmt, toText) ->- withBinaryFile path WriteMode $ \h -> do- when (optVerbose opts) $ do- putStrLn ("Writing " ++ fmt ++ " report to " ++ show path)- hPutStr h (toText results)- - let stats = resultStatistics results- let (_, _, failed, aborted) = stats- putStrLn (formatResultStatistics stats)- - if failed == 0 && aborted == 0- then exitSuccess- else exitFailure+defaultMain suites = runCommand $ \opts args ->+ do+ -- validate/sanitize test options+ seed <-+ case optSeed opts of+ Just s -> return s+ Nothing -> randomIO+ timeout <-+ case optTimeout opts of+ Nothing -> return Nothing+ Just t ->+ if toInteger t * 1000 > toInteger (maxBound :: Int)+ then do+ hPutStrLn stderr "Test.Chell.defaultMain: Ignoring --timeout because it is too large."+ return Nothing+ else return (Just t)+ let testOptions =+ defaultTestOptions+ { testOptionSeed = seed,+ testOptionTimeout = timeout+ } + -- find which tests to run+ let allTests = concatMap suiteTests suites+ tests =+ if null args+ then allTests+ else filter (matchesFilter args) allTests++ -- output mode+ output <-+ case optColor opts of+ ColorModeNever -> return (plainOutput (optVerbose opts))+ ColorModeAlways -> return (colorOutput (optVerbose opts))+ ColorModeAuto ->+ do+ isTerm <- hIsTerminalDevice stdout+ return $+ if isTerm+ then colorOutput (optVerbose opts)+ else plainOutput (optVerbose opts)++ -- run tests+ results <- forM tests $ \t ->+ do+ outputStart output t+ result <- runTest t testOptions+ outputResult output t result+ return (t, result)++ -- generate reports+ let reports = getReports opts++ forM_ reports $ \(path, fmt, toText) ->+ withBinaryFile path WriteMode $ \h ->+ do+ when (optVerbose opts) $+ putStrLn ("Writing " ++ fmt ++ " report to " ++ show path)+ hPutStr h (toText results)++ let stats = resultStatistics results+ (_, _, failed, aborted) = stats+ putStrLn (formatResultStatistics stats)++ if failed == 0 && aborted == 0+ then exitSuccess+ else exitFailure+ matchesFilter :: [String] -> Test -> Bool-matchesFilter filters = check where- check t = any (matchName (testName t)) filters- matchName name f = f == name || isPrefixOf (f ++ ".") name+matchesFilter filters = check+ where+ check t = any (matchName (testName t)) filters+ matchName name f = f == name || isPrefixOf (f ++ ".") name type Report = [(Test, TestResult)] -> String getReports :: MainOptions -> [(String, String, Report)]-getReports opts = concat [xml, json, text] where- xml = case optXmlReport opts of- "" -> []- path -> [(path, "XML", xmlReport)]- json = case optJsonReport opts of- "" -> []- path -> [(path, "JSON", jsonReport)]- text = case optTextReport opts of- "" -> []- path -> [(path, "text", textReport)]+getReports opts = concat [xml, json, text]+ where+ xml = case optXmlReport opts of+ "" -> []+ path -> [(path, "XML", xmlReport)]+ json = case optJsonReport opts of+ "" -> []+ path -> [(path, "JSON", jsonReport)]+ text = case optTextReport opts of+ "" -> []+ path -> [(path, "text", textReport)] jsonReport :: [(Test, TestResult)] -> String-jsonReport results = Writer.execWriter writer where- tell = Writer.tell- - writer = do- tell "{\"test-runs\": ["- commas results tellResult- tell "]}"- - tellResult (t, result) = case result of- TestPassed notes -> do- tell "{\"test\": \""- tell (escapeJSON (testName t))- tell "\", \"result\": \"passed\""- tellNotes notes- tell "}"- TestSkipped -> do- tell "{\"test\": \""- tell (escapeJSON (testName t))- tell "\", \"result\": \"skipped\"}"- TestFailed notes fs -> do- tell "{\"test\": \""- tell (escapeJSON (testName t))- tell "\", \"result\": \"failed\", \"failures\": ["- commas fs $ \f -> do- tell "{\"message\": \""- tell (escapeJSON (failureMessage f))- tell "\""- case failureLocation f of- Just loc -> do- tell ", \"location\": {\"module\": \""- tell (escapeJSON (locationModule loc))- tell "\", \"file\": \""- tell (escapeJSON (locationFile loc))- case locationLine loc of- Just line -> do- tell "\", \"line\": "- tell (show line)- Nothing -> tell "\""- tell "}"- Nothing -> return ()- tell "}"- tell "]"- tellNotes notes- tell "}"- TestAborted notes msg -> do- tell "{\"test\": \""- tell (escapeJSON (testName t))- tell "\", \"result\": \"aborted\", \"abortion\": {\"message\": \""- tell (escapeJSON msg)- tell "\"}"- tellNotes notes- tell "}"- _ -> return ()- - escapeJSON = concatMap (\c -> case c of- '"' -> "\\\""- '\\' -> "\\\\"- _ | ord c <= 0x1F -> printf "\\u%04X" (ord c)- _ -> [c])- - tellNotes notes = do- tell ", \"notes\": ["- commas notes $ \(key, value) -> do- tell "{\"key\": \""- tell (escapeJSON key)- tell "\", \"value\": \""- tell (escapeJSON value)- tell "\"}"- tell "]"- - commas xs block = State.evalStateT (commaState xs block) False- commaState xs block = forM_ xs $ \x -> do- let tell' = lift . Writer.tell- needComma <- State.get- if needComma- then tell' "\n, "- else tell' "\n "- State.put True- lift (block x)+jsonReport results = Writer.execWriter writer+ where+ tell = Writer.tell + writer =+ do+ tell "{\"test-runs\": ["+ commas results tellResult+ tell "]}"++ tellResult (t, result) =+ case result of+ TestPassed notes ->+ do+ tell "{\"test\": \""+ tell (escapeJSON (testName t))+ tell "\", \"result\": \"passed\""+ tellNotes notes+ tell "}"+ TestSkipped ->+ do+ tell "{\"test\": \""+ tell (escapeJSON (testName t))+ tell "\", \"result\": \"skipped\"}"+ TestFailed notes fs ->+ do+ tell "{\"test\": \""+ tell (escapeJSON (testName t))+ tell "\", \"result\": \"failed\", \"failures\": ["+ commas fs $ \f ->+ do+ tell "{\"message\": \""+ tell (escapeJSON (failureMessage f))+ tell "\""+ case failureLocation f of+ Just loc ->+ do+ tell ", \"location\": {\"module\": \""+ tell (escapeJSON (locationModule loc))+ tell "\", \"file\": \""+ tell (escapeJSON (locationFile loc))+ case locationLine loc of+ Just line ->+ do+ tell "\", \"line\": "+ tell (show line)+ Nothing -> tell "\""+ tell "}"+ Nothing -> return ()+ tell "}"+ tell "]"+ tellNotes notes+ tell "}"+ TestAborted notes msg ->+ do+ tell "{\"test\": \""+ tell (escapeJSON (testName t))+ tell "\", \"result\": \"aborted\", \"abortion\": {\"message\": \""+ tell (escapeJSON msg)+ tell "\"}"+ tellNotes notes+ tell "}"+ _ -> return ()++ escapeJSON =+ concatMap+ ( \c ->+ case c of+ '"' -> "\\\""+ '\\' -> "\\\\"+ _ | ord c <= 0x1F -> printf "\\u%04X" (ord c)+ _ -> [c]+ )++ tellNotes notes =+ do+ tell ", \"notes\": ["+ commas notes $ \(key, value) ->+ do+ tell "{\"key\": \""+ tell (escapeJSON key)+ tell "\", \"value\": \""+ tell (escapeJSON value)+ tell "\"}"+ tell "]"++ commas xs block = State.evalStateT (commaState xs block) False+ commaState xs block = forM_ xs $ \x ->+ do+ let tell' = lift . Writer.tell+ needComma <- State.get+ if needComma+ then tell' "\n, "+ else tell' "\n "+ State.put True+ lift (block x)+ xmlReport :: [(Test, TestResult)] -> String-xmlReport results = Writer.execWriter writer where- tell = Writer.tell- - writer = do- tell "<?xml version=\"1.0\" encoding=\"utf8\"?>\n"- tell "<report xmlns='urn:john-millikin:chell:report:1'>\n"- mapM_ tellResult results- tell "</report>"- - tellResult (t, result) = case result of- TestPassed notes -> do- tell "\t<test-run test='"- tell (escapeXML (testName t))- tell "' result='passed'>\n"- tellNotes notes- tell "\t</test-run>\n"- TestSkipped -> do- tell "\t<test-run test='"- tell (escapeXML (testName t))- tell "' result='skipped'/>\n"- TestFailed notes fs -> do- tell "\t<test-run test='"- tell (escapeXML (testName t))- tell "' result='failed'>\n"- forM_ fs $ \f -> do- tell "\t\t<failure message='"- tell (escapeXML (failureMessage f))- case failureLocation f of- Just loc -> do- tell "'>\n"- tell "\t\t\t<location module='"- tell (escapeXML (locationModule loc))- tell "' file='"- tell (escapeXML (locationFile loc))- case locationLine loc of- Just line -> do- tell "' line='"- tell (show line)- Nothing -> return ()- tell "'/>\n"- tell "\t\t</failure>\n"- Nothing -> tell "'/>\n"- tellNotes notes- tell "\t</test-run>\n"- TestAborted notes msg -> do- tell "\t<test-run test='"- tell (escapeXML (testName t))- tell "' result='aborted'>\n"- tell "\t\t<abortion message='"- tell (escapeXML msg)- tell "'/>\n"- tellNotes notes- tell "\t</test-run>\n"- _ -> return ()- - escapeXML = concatMap (\c -> case c of- '&' -> "&"- '<' -> "<"- '>' -> ">"- '"' -> """- '\'' -> "'"- _ -> [c])- - tellNotes notes = forM_ notes $ \(key, value) -> do- tell "\t\t<note key=\""- tell (escapeXML key)- tell "\" value=\""- tell (escapeXML value)- tell "\"/>\n"+xmlReport results = Writer.execWriter writer+ where+ tell = Writer.tell + writer =+ do+ tell "<?xml version=\"1.0\" encoding=\"utf8\"?>\n"+ tell "<report xmlns='urn:john-millikin:chell:report:1'>\n"+ mapM_ tellResult results+ tell "</report>"++ tellResult (t, result) =+ case result of+ TestPassed notes ->+ do+ tell "\t<test-run test='"+ tell (escapeXML (testName t))+ tell "' result='passed'>\n"+ tellNotes notes+ tell "\t</test-run>\n"+ TestSkipped ->+ do+ tell "\t<test-run test='"+ tell (escapeXML (testName t))+ tell "' result='skipped'/>\n"+ TestFailed notes fs ->+ do+ tell "\t<test-run test='"+ tell (escapeXML (testName t))+ tell "' result='failed'>\n"+ forM_ fs $ \f ->+ do+ tell "\t\t<failure message='"+ tell (escapeXML (failureMessage f))+ case failureLocation f of+ Just loc ->+ do+ tell "'>\n"+ tell "\t\t\t<location module='"+ tell (escapeXML (locationModule loc))+ tell "' file='"+ tell (escapeXML (locationFile loc))+ case locationLine loc of+ Just line ->+ do+ tell "' line='"+ tell (show line)+ Nothing -> return ()+ tell "'/>\n"+ tell "\t\t</failure>\n"+ Nothing -> tell "'/>\n"+ tellNotes notes+ tell "\t</test-run>\n"+ TestAborted notes msg ->+ do+ tell "\t<test-run test='"+ tell (escapeXML (testName t))+ tell "' result='aborted'>\n"+ tell "\t\t<abortion message='"+ tell (escapeXML msg)+ tell "'/>\n"+ tellNotes notes+ tell "\t</test-run>\n"+ _ -> return ()++ escapeXML =+ concatMap+ ( \c ->+ case c of+ '&' -> "&"+ '<' -> "<"+ '>' -> ">"+ '"' -> """+ '\'' -> "'"+ _ -> [c]+ )++ tellNotes notes = forM_ notes $ \(key, value) ->+ do+ tell "\t\t<note key=\""+ tell (escapeXML key)+ tell "\" value=\""+ tell (escapeXML value)+ tell "\"/>\n"+ textReport :: [(Test, TestResult)] -> String-textReport results = Writer.execWriter writer where- tell = Writer.tell- - writer = do- forM_ results tellResult- let stats = resultStatistics results- tell (formatResultStatistics stats)- - tellResult (t, result) = case result of- TestPassed notes -> do- tell (replicate 70 '=')- tell "\n"- tell "PASSED: "- tell (testName t)- tell "\n"- tellNotes notes- tell "\n\n"- TestSkipped -> do- tell (replicate 70 '=')- tell "\n"- tell "SKIPPED: "- tell (testName t)- tell "\n\n"- TestFailed notes fs -> do- tell (replicate 70 '=')- tell "\n"- tell "FAILED: "- tell (testName t)- tell "\n"- tellNotes notes- tell (replicate 70 '-')- tell "\n"- forM_ fs $ \f -> do- case failureLocation f of- Just loc -> do- tell (locationFile loc)- case locationLine loc of- Just line -> do- tell ":"- tell (show line)- Nothing -> return ()- tell "\n"- Nothing -> return ()- tell (failureMessage f)- tell "\n\n"- TestAborted notes msg -> do- tell (replicate 70 '=')- tell "\n"- tell "ABORTED: "- tell (testName t)- tell "\n"- tellNotes notes- tell (replicate 70 '-')- tell "\n"- tell msg- tell "\n\n"- _ -> return ()- - tellNotes notes = forM_ notes $ \(key, value) -> do- tell key- tell "="- tell value- tell "\n"+textReport results = Writer.execWriter writer+ where+ tell = Writer.tell + writer =+ do+ forM_ results tellResult+ let stats = resultStatistics results+ tell (formatResultStatistics stats)++ tellResult (t, result) =+ case result of+ TestPassed notes ->+ do+ tell (replicate 70 '=')+ tell "\n"+ tell "PASSED: "+ tell (testName t)+ tell "\n"+ tellNotes notes+ tell "\n\n"+ TestSkipped ->+ do+ tell (replicate 70 '=')+ tell "\n"+ tell "SKIPPED: "+ tell (testName t)+ tell "\n\n"+ TestFailed notes fs ->+ do+ tell (replicate 70 '=')+ tell "\n"+ tell "FAILED: "+ tell (testName t)+ tell "\n"+ tellNotes notes+ tell (replicate 70 '-')+ tell "\n"+ forM_ fs $ \f ->+ do+ case failureLocation f of+ Just loc ->+ do+ tell (locationFile loc)+ case locationLine loc of+ Just line ->+ do+ tell ":"+ tell (show line)+ Nothing -> return ()+ tell "\n"+ Nothing -> return ()+ tell (failureMessage f)+ tell "\n\n"+ TestAborted notes msg ->+ do+ tell (replicate 70 '=')+ tell "\n"+ tell "ABORTED: "+ tell (testName t)+ tell "\n"+ tellNotes notes+ tell (replicate 70 '-')+ tell "\n"+ tell msg+ tell "\n\n"+ _ -> return ()++ tellNotes notes = forM_ notes $ \(key, value) ->+ do+ tell key+ tell "="+ tell value+ tell "\n"+ formatResultStatistics :: (Integer, Integer, Integer, Integer) -> String-formatResultStatistics stats = Writer.execWriter writer where- writer = do- let (passed, skipped, failed, aborted) = stats- if failed == 0 && aborted == 0- then Writer.tell "PASS: "- else Writer.tell "FAIL: "- let putNum comma n what = Writer.tell $ if n == 1- then comma ++ "1 test " ++ what- else comma ++ show n ++ " tests " ++ what- - let total = sum [passed, skipped, failed, aborted]- putNum "" total "run"- (putNum ", " passed "passed")- when (skipped > 0) (putNum ", " skipped "skipped")- when (failed > 0) (putNum ", " failed "failed")- when (aborted > 0) (putNum ", " aborted "aborted")+formatResultStatistics stats = Writer.execWriter writer+ where+ writer =+ do+ let (passed, skipped, failed, aborted) = stats + if failed == 0 && aborted == 0+ then Writer.tell "PASS: "+ else Writer.tell "FAIL: "++ let putNum comma n what =+ Writer.tell $+ if n == 1+ then comma ++ "1 test " ++ what+ else comma ++ show n ++ " tests " ++ what++ let total = sum [passed, skipped, failed, aborted]++ putNum "" total "run"+ (putNum ", " passed "passed")+ when (skipped > 0) (putNum ", " skipped "skipped")+ when (failed > 0) (putNum ", " failed "failed")+ when (aborted > 0) (putNum ", " aborted "aborted")+ resultStatistics :: [(Test, TestResult)] -> (Integer, Integer, Integer, Integer)-resultStatistics results = State.execState state (0, 0, 0, 0) where- state = forM_ results $ \(_, result) -> case result of- TestPassed{} -> State.modify (\(p, s, f, a) -> (p+1, s, f, a))- TestSkipped{} -> State.modify (\(p, s, f, a) -> (p, s+1, f, a))- TestFailed{} -> State.modify (\(p, s, f, a) -> (p, s, f+1, a))- TestAborted{} -> State.modify (\(p, s, f, a) -> (p, s, f, a+1))- _ -> return ()+resultStatistics results = State.execState state (0, 0, 0, 0)+ where+ state = forM_ results $ \(_, result) -> case result of+ TestPassed {} -> State.modify (\(p, s, f, a) -> (p + 1, s, f, a))+ TestSkipped {} -> State.modify (\(p, s, f, a) -> (p, s + 1, f, a))+ TestFailed {} -> State.modify (\(p, s, f, a) -> (p, s, f + 1, a))+ TestAborted {} -> State.modify (\(p, s, f, a) -> (p, s, f, a + 1))+ _ -> return ()
Test/Chell/Output.hs view
@@ -1,159 +1,181 @@ {-# LANGUAGE CPP #-} module Test.Chell.Output- ( Output- , outputStart- , outputResult- - , ColorMode(..)- - , plainOutput- , colorOutput- ) where+ ( Output,+ outputStart,+ outputResult,+ ColorMode (..),+ plainOutput,+ colorOutput,+ )+where -import Control.Monad (forM_, unless, when)+import Control.Monad (forM_, unless, when) #ifdef MIN_VERSION_ansi_terminal import qualified System.Console.ANSI as AnsiTerminal #endif -import Test.Chell.Types+import Test.Chell.Types data Output = Output- { outputStart :: Test -> IO ()- , outputResult :: Test -> TestResult -> IO ()- }+ { outputStart :: Test -> IO (),+ outputResult :: Test -> TestResult -> IO ()+ } plainOutput :: Bool -> Output-plainOutput v = Output- { outputStart = plainOutputStart v- , outputResult = plainOutputResult v- }+plainOutput v =+ Output+ { outputStart = plainOutputStart v,+ outputResult = plainOutputResult v+ } plainOutputStart :: Bool -> Test -> IO ()-plainOutputStart v t = when v $ do- putStr "[ RUN ] "- putStrLn (testName t)+plainOutputStart v t =+ when v $+ do+ putStr "[ RUN ] "+ putStrLn (testName t) plainOutputResult :: Bool -> Test -> TestResult -> IO ()-plainOutputResult v t (TestPassed _) = when v $ do- putStr "[ PASS ] "- putStrLn (testName t)- putStrLn ""-plainOutputResult v t TestSkipped = when v $ do- putStr "[ SKIP ] "- putStrLn (testName t)- putStrLn ""-plainOutputResult _ t (TestFailed notes fs) = do- putStr "[ FAIL ] "- putStrLn (testName t)- printNotes notes- printFailures fs-plainOutputResult _ t (TestAborted notes msg) = do- putStr "[ ABORT ] "- putStrLn (testName t)- printNotes notes- putStr " "- putStr msg- putStrLn "\n"+plainOutputResult v t (TestPassed _) =+ when v $+ do+ putStr "[ PASS ] "+ putStrLn (testName t)+ putStrLn ""+plainOutputResult v t TestSkipped =+ when v $+ do+ putStr "[ SKIP ] "+ putStrLn (testName t)+ putStrLn ""+plainOutputResult _ t (TestFailed notes fs) =+ do+ putStr "[ FAIL ] "+ putStrLn (testName t)+ printNotes notes+ printFailures fs+plainOutputResult _ t (TestAborted notes msg) =+ do+ putStr "[ ABORT ] "+ putStrLn (testName t)+ printNotes notes+ putStr " "+ putStr msg+ putStrLn "\n" plainOutputResult _ _ _ = return () data ColorMode- = ColorModeAuto- | ColorModeAlways- | ColorModeNever- deriving (Enum)+ = ColorModeAuto+ | ColorModeAlways+ | ColorModeNever+ deriving (Enum) colorOutput :: Bool -> Output #ifndef MIN_VERSION_ansi_terminal colorOutput = plainOutput #else-colorOutput v = Output- { outputStart = colorOutputStart v- , outputResult = colorOutputResult v- }+colorOutput v =+ Output+ { outputStart = colorOutputStart v+ , outputResult = colorOutputResult v+ } colorOutputStart :: Bool -> Test -> IO ()-colorOutputStart v t = when v $ do- putStr "[ RUN ] "- putStrLn (testName t)+colorOutputStart v t = when v $+ do+ putStr "[ RUN ] "+ putStrLn (testName t) colorOutputResult :: Bool -> Test -> TestResult -> IO ()-colorOutputResult v t (TestPassed _) = when v $ do- putStr "[ "- AnsiTerminal.setSGR- [ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Green- ]- putStr "PASS"- AnsiTerminal.setSGR- [ AnsiTerminal.Reset- ]- putStr " ] "- putStrLn (testName t)- putStrLn ""-colorOutputResult v t TestSkipped = when v $ do- putStr "[ "- AnsiTerminal.setSGR- [ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Yellow- ]- putStr "SKIP"- AnsiTerminal.setSGR- [ AnsiTerminal.Reset- ]- putStr " ] "- putStrLn (testName t)- putStrLn ""-colorOutputResult _ t (TestFailed notes fs) = do- putStr "[ "- AnsiTerminal.setSGR- [ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Red- ]- putStr "FAIL"- AnsiTerminal.setSGR- [ AnsiTerminal.Reset- ]- putStr " ] "- putStrLn (testName t)- printNotes notes- printFailures fs-colorOutputResult _ t (TestAborted notes msg) = do- putStr "[ "- AnsiTerminal.setSGR- [ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Red- ]- putStr "ABORT"- AnsiTerminal.setSGR- [ AnsiTerminal.Reset- ]- putStr " ] "- putStrLn (testName t)- printNotes notes- putStr " "- putStr msg- putStrLn "\n"+colorOutputResult v t (TestPassed _) =+ when v $+ do+ putStr "[ "+ AnsiTerminal.setSGR+ [ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Green+ ]+ putStr "PASS"+ AnsiTerminal.setSGR+ [ AnsiTerminal.Reset+ ]+ putStr " ] "+ putStrLn (testName t)+ putStrLn ""+colorOutputResult v t TestSkipped =+ when v $+ do+ putStr "[ "+ AnsiTerminal.setSGR+ [ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Yellow+ ]+ putStr "SKIP"+ AnsiTerminal.setSGR+ [ AnsiTerminal.Reset+ ]+ putStr " ] "+ putStrLn (testName t)+ putStrLn ""+colorOutputResult _ t (TestFailed notes fs) =+ do+ putStr "[ "+ AnsiTerminal.setSGR+ [ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Red+ ]+ putStr "FAIL"+ AnsiTerminal.setSGR+ [ AnsiTerminal.Reset+ ]+ putStr " ] "+ putStrLn (testName t)+ printNotes notes+ printFailures fs+colorOutputResult _ t (TestAborted notes msg) =+ do+ putStr "[ "+ AnsiTerminal.setSGR+ [ AnsiTerminal.SetColor AnsiTerminal.Foreground AnsiTerminal.Vivid AnsiTerminal.Red+ ]+ putStr "ABORT"+ AnsiTerminal.setSGR+ [ AnsiTerminal.Reset+ ]+ putStr " ] "+ putStrLn (testName t)+ printNotes notes+ putStr " "+ putStr msg+ putStrLn "\n" colorOutputResult _ _ _ = return () #endif printNotes :: [(String, String)] -> IO ()-printNotes notes = unless (null notes) $ do- forM_ notes $ \(key, value) -> do- putStr " note: "- putStr key- putStr "="- putStrLn value- putStrLn ""+printNotes notes =+ unless (null notes) $+ do+ forM_ notes $ \(key, value) ->+ do+ putStr " note: "+ putStr key+ putStr "="+ putStrLn value+ putStrLn "" printFailures :: [Failure] -> IO ()-printFailures fs = forM_ fs $ \f -> do- putStr " "- case failureLocation f of- Just loc -> do- putStr (locationFile loc)- putStr ":"- case locationLine loc of- Just line -> putStrLn (show line)- Nothing -> putStrLn ""- Nothing -> return ()- putStr " "- putStr (failureMessage f)- putStrLn "\n"+printFailures fs =+ forM_ fs $ \f ->+ do+ putStr " "+ case failureLocation f of+ Just loc ->+ do+ putStr (locationFile loc)+ putStr ":"+ case locationLine loc of+ Just line -> putStrLn (show line)+ Nothing -> putStrLn ""+ Nothing -> return ()+ putStr " "+ putStr (failureMessage f)+ putStrLn "\n"
Test/Chell/Types.hs view
@@ -1,50 +1,44 @@ module Test.Chell.Types- ( Test- , test- , testName- - , TestOptions- , defaultTestOptions- , testOptionSeed- , testOptionTimeout- - , TestResult(TestPassed, TestSkipped, TestFailed, TestAborted)- - , Failure- , failure- , failureLocation- , failureMessage- - , Location- , location- , locationFile- , locationModule- , locationLine- - , Suite- , suite- , suiteName- , suiteTests- - , SuiteOrTest- , skipIf- , skipWhen- - , runTest- - , handleJankyIO- ) where+ ( Test,+ test,+ testName,+ TestOptions,+ defaultTestOptions,+ testOptionSeed,+ testOptionTimeout,+ TestResult (TestPassed, TestSkipped, TestFailed, TestAborted),+ Failure,+ failure,+ failureLocation,+ failureMessage,+ Location,+ location,+ locationFile,+ locationModule,+ locationLine,+ Suite,+ suite,+ suiteName,+ suiteTests,+ SuiteOrTest,+ skipIf,+ skipWhen,+ runTest,+ handleJankyIO,+ )+where -import qualified Control.Exception-import Control.Exception (SomeException, Handler(..), catches, throwIO)-import System.Timeout (timeout)+import Control.Exception (Handler (..), SomeException, catches, throwIO)+import Control.Exception qualified+import System.Timeout (timeout) -- | A 'Test' is, essentially, an IO action that returns a 'TestResult'. Tests -- are aggregated into suites (see 'Suite').-data Test = Test String (TestOptions -> IO TestResult)+data Test+ = Test String (TestOptions -> IO TestResult) instance Show Test where- showsPrec d (Test name _) = showParen (d > 10) (showString "Test " . shows name)+ showsPrec d (Test name _) = showParen (d > 10) (showString "Test " . shows name) -- | Define a test, with the given name and implementation. test :: String -> (TestOptions -> IO TestResult) -> Test@@ -57,30 +51,27 @@ -- | Test options are passed to each test, and control details about how the -- test should be run. data TestOptions = TestOptions- {- - -- | Get the RNG seed for this test run. The seed is generated once, in- -- 'defaultMain', and used for all tests. It is also logged to reports- -- using a note.- --- -- When using 'defaultMain', users may specify a seed using the- -- @--seed@ command-line option.- --- -- 'testOptionSeed' is a field accessor, and can be used to update- -- a 'TestOptions' value.- testOptionSeed :: Int- - -- | An optional timeout, in millseconds. Tests which run longer than- -- this timeout will be aborted.- --- -- When using 'defaultMain', users may specify a timeout using the- -- @--timeout@ command-line option.- --- -- 'testOptionTimeout' is a field accessor, and can be used to update- -- a 'TestOptions' value.- , testOptionTimeout :: Maybe Int- }- deriving (Show, Eq)+ { -- | Get the RNG seed for this test run. The seed is generated once, in+ -- 'defaultMain', and used for all tests. It is also logged to reports+ -- using a note.+ --+ -- When using 'defaultMain', users may specify a seed using the+ -- @--seed@ command-line option.+ --+ -- 'testOptionSeed' is a field accessor, and can be used to update+ -- a 'TestOptions' value.+ testOptionSeed :: Int,+ -- | An optional timeout, in milliseconds. Tests which run longer than+ -- this timeout will be aborted.+ --+ -- When using 'defaultMain', users may specify a timeout using the+ -- @--timeout@ command-line option.+ --+ -- 'testOptionTimeout' is a field accessor, and can be used to update+ -- a 'TestOptions' value.+ testOptionTimeout :: Maybe Int+ }+ deriving (Show, Eq) -- | Default test options. --@@ -93,10 +84,11 @@ -- >Test.Chell> testOptionTimeout defaultTestOptions -- >Nothing defaultTestOptions :: TestOptions-defaultTestOptions = TestOptions- { testOptionSeed = 0- , testOptionTimeout = Nothing- }+defaultTestOptions =+ TestOptions+ { testOptionSeed = 0,+ testOptionTimeout = Nothing+ } -- | The result of running a test. --@@ -104,42 +96,36 @@ -- who pattern-match against the 'TestResult' constructors should include a -- default case. If no default case is provided, a warning will be issued. data TestResult- -- | The test passed, and generated the given notes.- = TestPassed [(String, String)]- - -- | The test did not run, because it was skipped with 'skipIf'- -- or 'skipWhen'.- | TestSkipped- - -- | The test failed, generating the given notes and failures.- | TestFailed [(String, String)] [Failure]- - -- | The test aborted with an error message, and generated the given- -- notes.- | TestAborted [(String, String)] String- - -- Not exported; used to generate GHC warnings for users who don't- -- provide a default case.- | TestResultCaseMustHaveDefault- deriving (Show, Eq)+ = -- | The test passed, and generated the given notes.+ TestPassed [(String, String)]+ | -- | The test did not run, because it was skipped with 'skipIf'+ -- or 'skipWhen'.+ TestSkipped+ | -- | The test failed, generating the given notes and failures.+ TestFailed [(String, String)] [Failure]+ | -- | The test aborted with an error message, and generated the given+ -- notes.+ TestAborted [(String, String)] String+ | -- Not exported; used to generate GHC warnings for users who don't+ -- provide a default case.+ TestResultCaseMustHaveDefault+ deriving (Show, Eq) -- | Contains details about a test failure. data Failure = Failure- {- -- | If given, the location of the failing assertion, expectation,- -- etc.- --- -- 'failureLocation' is a field accessor, and can be used to update- -- a 'Failure' value.- failureLocation :: Maybe Location- - -- | If given, a message which explains why the test failed.- --- -- 'failureMessage' is a field accessor, and can be used to update- -- a 'Failure' value.- , failureMessage :: String- }- deriving (Show, Eq)+ { -- | If given, the location of the failing assertion, expectation,+ -- etc.+ --+ -- 'failureLocation' is a field accessor, and can be used to update+ -- a 'Failure' value.+ failureLocation :: Maybe Location,+ -- | If given, a message which explains why the test failed.+ --+ -- 'failureMessage' is a field accessor, and can be used to update+ -- a 'Failure' value.+ failureMessage :: String+ }+ deriving (Show, Eq) -- | An empty 'Failure'; use the field accessors to populate this value. failure :: Failure@@ -147,26 +133,23 @@ -- | Contains details about a location in the test source file. data Location = Location- {- -- | A path to a source file, or empty if not provided.- --- -- 'locationFile' is a field accessor, and can be used to update- -- a 'Location' value.- locationFile :: String- - -- | A Haskell module name, or empty if not provided.- --- -- 'locationModule' is a field accessor, and can be used to update- -- a 'Location' value.- , locationModule :: String- - -- | A line number, or Nothing if not provided.- --- -- 'locationLine' is a field accessor, and can be used to update- -- a 'Location' value.- , locationLine :: Maybe Integer- }- deriving (Show, Eq)+ { -- | A path to a source file, or empty if not provided.+ --+ -- 'locationFile' is a field accessor, and can be used to update+ -- a 'Location' value.+ locationFile :: String,+ -- | A Haskell module name, or empty if not provided.+ --+ -- 'locationModule' is a field accessor, and can be used to update+ -- a 'Location' value.+ locationModule :: String,+ -- | A line number, or Nothing if not provided.+ --+ -- 'locationLine' is a field accessor, and can be used to update+ -- a 'Location' value.+ locationLine :: Maybe Integer+ }+ deriving (Show, Eq) -- | An empty 'Location'; use the field accessors to populate this value. location :: Location@@ -177,39 +160,49 @@ -- Note: earlier versions of Chell permitted arbitrary nesting of test suites. -- This feature proved too unwieldy, and was removed. A similar result can be -- achieved with 'suiteTests'; see the documentation for 'suite'.-data Suite = Suite String [Test]- deriving (Show)+data Suite+ = Suite String [Test]+ deriving (Show) class SuiteOrTest a where- skipIf_ :: Bool -> a -> a- skipWhen_ :: IO Bool -> a -> a+ skipIf_ :: Bool -> a -> a+ skipWhen_ :: IO Bool -> a -> a instance SuiteOrTest Suite where- skipIf_ skip s@(Suite name children) = if skip- then Suite name (map (skipIf_ skip) children)- else s- skipWhen_ p (Suite name children) = Suite name (map (skipWhen_ p) children)+ skipIf_ skip s@(Suite name children) =+ if skip+ then Suite name (map (skipIf_ skip) children)+ else s + skipWhen_ p (Suite name children) =+ Suite name (map (skipWhen_ p) children)+ instance SuiteOrTest Test where- skipIf_ skip t@(Test name _) = if skip- then Test name (\_ -> return TestSkipped)- else t- skipWhen_ p (Test name io) = Test name (\opts -> do- skip <- p- if skip then return TestSkipped else io opts)+ skipIf_ skip t@(Test name _) =+ if skip+ then Test name (\_ -> return TestSkipped)+ else t + skipWhen_ p (Test name io) =+ Test+ name+ ( \opts ->+ do+ skip <- p+ if skip then return TestSkipped else io opts+ )+ -- | Conditionally skip tests. Use this to avoid commenting out tests -- which are currently broken, or do not work on the current platform. -- -- @---tests :: Suite---tests = 'suite' \"tests\"+-- tests :: Suite+-- tests = 'suite' \"tests\" -- [ test_Foo -- , 'skipIf' builtOnUnix test_WindowsSpecific -- , test_Bar -- ] -- @--- skipIf :: SuiteOrTest a => Bool -> a -> a skipIf = skipIf_ @@ -217,8 +210,8 @@ -- predicate is checked before each test is started. -- -- @---tests :: Suite---tests = 'suite' \"tests\"+-- tests :: Suite+-- tests = 'suite' \"tests\" -- [ test_Foo -- , 'skipWhen' noNetwork test_PingGoogle -- , test_Bar@@ -234,18 +227,18 @@ -- achieved with 'suiteTests': -- -- @---test_Addition :: Test---test_Subtraction :: Test---test_Show :: Test+-- test_Addition :: Test+-- test_Subtraction :: Test+-- test_Show :: Test -----suite_Math :: Suite---suite_Math = 'suite' \"math\"+-- suite_Math :: Suite+-- suite_Math = 'suite' \"math\" -- [ test_Addition -- , test_Subtraction -- ] -----suite_Prelude :: Suite---suite_Prelude = 'suite' \"prelude\"+-- suite_Prelude :: Suite+-- suite_Prelude = 'suite' \"prelude\" -- ( -- [ test_Show -- ]@@ -276,44 +269,53 @@ -- >*Main> suiteTests tests_Math -- >[Test "math.addition",Test "math.subtraction"] suiteTests :: Suite -> [Test]-suiteTests = go "" where- prefixed prefix str = if null prefix- then str- else prefix ++ "." ++ str- - go prefix (Suite name children) = concatMap (step (prefixed prefix name)) children- - step prefix (Test name io) = [Test (prefixed prefix name) io]+suiteTests = go ""+ where+ prefixed prefix str =+ if null prefix+ then str+ else prefix ++ "." ++ str + go prefix (Suite name children) =+ concatMap (step (prefixed prefix name)) children++ step prefix (Test name io) = [Test (prefixed prefix name) io]+ -- | Run a test, wrapped in error handlers. This will return 'TestAborted' if -- the test throws an exception or times out. runTest :: Test -> TestOptions -> IO TestResult runTest (Test _ io) options = handleJankyIO options (io options) (return []) handleJankyIO :: TestOptions -> IO TestResult -> IO [(String, String)] -> IO TestResult-handleJankyIO opts getResult getNotes = do- let withTimeout = case testOptionTimeout opts of- Just time -> timeout (time * 1000)- Nothing -> fmap Just- - let hitTimeout = str where- str = "Test timed out after " ++ show time ++ " milliseconds"- Just time = testOptionTimeout opts- - tried <- withTimeout (try getResult)- case tried of- Just (Right ret) -> return ret- Nothing -> do- notes <- getNotes- return (TestAborted notes hitTimeout)- Just (Left err) -> do- notes <- getNotes- return (TestAborted notes err)+handleJankyIO opts getResult getNotes =+ do+ let withTimeout =+ case testOptionTimeout opts of+ Just time -> timeout (time * 1000)+ Nothing -> fmap Just + let hitTimeout = str+ where+ str = "Test timed out after " ++ show time ++ " milliseconds"+ Just time = testOptionTimeout opts++ tried <- withTimeout (try getResult)+ case tried of+ Just (Right ret) -> return ret+ Nothing ->+ do+ notes <- getNotes+ return (TestAborted notes hitTimeout)+ Just (Left err) ->+ do+ notes <- getNotes+ return (TestAborted notes err)+ try :: IO a -> IO (Either String a)-try io = catches (fmap Right io) [Handler handleAsync, Handler handleExc] where- handleAsync :: Control.Exception.AsyncException -> IO a- handleAsync = throwIO- - handleExc :: SomeException -> IO (Either String a)- handleExc exc = return (Left ("Test aborted due to exception: " ++ show exc))+try io = catches (fmap Right io) [Handler handleAsync, Handler handleExc]+ where+ handleAsync :: Control.Exception.AsyncException -> IO a+ handleAsync = throwIO++ handleExc :: SomeException -> IO (Either String a)+ handleExc exc = return (Left ("Test aborted due to exception: " ++ show exc))
+ changelog.md view
@@ -0,0 +1,35 @@+## 0.5.0.2++Miscellaneous updates and cleanup++Published by: Chris Martin++Date: 2023-07-11++## 0.5.0.1++Support up to GHC 9.2++Tighten various version bounds++Published by: Chris Martin++Date: 2021-01-14++## 0.5++Add support for `patience` 0.2++Drop support for `patience` 0.1++Add support for `ansi-terminal` 0.8++Published by: Chris Martin++Date: 2019-02-16++## 0.4.0.2++Published by: John Millikin++Date: 2017-12-12
chell.cabal view
@@ -1,88 +1,51 @@+cabal-version: 3.0+ name: chell-version: 0.4.0.2+version: 0.5.0.2++synopsis: A simple and intuitive library for automated testing.+category: Testing+ license: MIT license-file: license.txt author: John Millikin <john@john-millikin.com>-maintainer: John Millikin <john@john-millikin.com>-build-type: Simple-cabal-version: >= 1.6-category: Testing-bug-reports: mailto:jmillikin@gmail.com-homepage: https://john-millikin.com/software/chell/+maintainer: Chris Martin, Julie Moronuki -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.- .- @- {-\# LANGUAGE TemplateHaskell \#-}- .- import Test.Chell- .- tests_Math :: Suite- tests_Math = suite \"math\"-   [ test_Addition-   , test_Subtraction-   ]- .- test_Addition :: Test- test_Addition = assertions \"addition\" $ do-   $expect (equal (2 + 1) 3)-   $expect (equal (1 + 2) 3)- .- test_Subtraction :: Test- test_Subtraction = assertions \"subtraction\" $ do-   $expect (equal (2 - 1) 1)-   $expect (equal (1 - 2) (-1))- .- main :: IO ()- main = defaultMain [tests_Math]- @- .- @- $ ghc --make chell-example.hs- $ ./chell-example- PASS: 2 tests run, 2 tests passed- @+homepage: https://github.com/typeclasses/chell -source-repository head- type: git- location: https://john-millikin.com/code/chell/+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. -source-repository this- type: git- location: https://john-millikin.com/code/chell/- tag: chell_0.4.0.2+extra-source-files: *.md flag color-output- description: Enable colored output in test results- default: True+ description: Enable colored output in test results+ default: True library- ghc-options: -Wall-- build-depends:- base >= 4.1 && < 5.0- , bytestring >= 0.9- , options >= 1.0 && < 2.0- , patience >= 0.1 && < 0.2- , random >= 1.0- , template-haskell >= 2.3- , text- , transformers >= 0.2+ default-language: GHC2021+ ghc-options: -Wall - if flag(color-output) build-depends:- ansi-terminal >= 0.5 && < 0.8+ , base ^>= 4.16 || ^>= 4.17 || ^>= 4.18+ , bytestring ^>= 0.11.4 || ^>= 0.12+ , options ^>= 1.2.1+ , patience ^>= 0.3+ , random ^>= 1.2.1+ , template-haskell ^>=2.18 || ^>= 2.19 || ^>= 2.20+ , text ^>= 1.2.5 || ^>= 2.0+ , transformers ^>= 0.5.6 || ^>= 0.6 - exposed-modules:- Test.Chell+ if flag(color-output)+ build-depends:+ , ansi-terminal ^>= 1.0 - other-modules:- Test.Chell.Main- Test.Chell.Output- Test.Chell.Types+ exposed-modules:+ Test.Chell++ other-modules:+ Test.Chell.Main+ Test.Chell.Output+ Test.Chell.Types
+ readme.md view
@@ -0,0 +1,33 @@+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 arithmetic operators.++```haskell+{-# LANGUAGE TemplateHaskell #-}++import Test.Chell++tests_Math :: Suite+tests_Math = suite "math" [test_Addition, test_Subtraction]++test_Addition :: Test+test_Addition = assertions "addition" $ do+ $expect (equal (2 + 1) 3)+ $expect (equal (1 + 2) 3)++test_Subtraction :: Test+test_Subtraction = assertions "subtraction" $ do+ $expect (equal (2 - 1) 1)+ $expect (equal (1 - 2) (-1))++main :: IO ()+main = defaultMain [tests_Math]+```++```+$ ghc --make chell-example.hs+$ ./chell-example+PASS: 2 tests run, 2 tests passed+```