chell 0.5.0.1 → 0.5.0.2
raw patch · 8 files changed
+885/−905 lines, 8 filesdep ~ansi-terminaldep ~basedep ~bytestringsetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: ansi-terminal, base, bytestring, options, patience, random, template-haskell, text, transformers
API changes (from Hackage documentation)
- Test.Chell: instance Test.Chell.IsText Data.ByteString.Internal.ByteString
+ Test.Chell: instance Test.Chell.IsText Data.ByteString.Internal.Type.ByteString
Files
- Setup.hs +0/−2
- Test/Chell.hs +338/−338
- Test/Chell/Main.hs +277/−279
- Test/Chell/Output.hs +54/−56
- Test/Chell/Types.hs +125/−153
- changelog.md +30/−9
- chell.cabal +28/−68
- readme.md +33/−0
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
Test/Chell.hs view
@@ -1,144 +1,137 @@ {-# 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+ ( -- * Main+ defaultMain, - -- ** Built-in assertions- , equal- , notEqual- , equalWithin- , just- , nothing- , left- , right- , throws- , throwsEq- , greater- , greaterEqual- , lesser- , lesserEqual- , sameItems- , equalItems- , IsText- , equalLines- , equalLinesWith+ -- * Test suites+ Suite,+ suite,+ suiteName,+ suiteTests, - -- * Custom test types- , Test- , test- , testName- , runTest+ -- ** Skipping some tests+ SuiteOrTest,+ skipIf,+ skipWhen, - -- ** Test results- , TestResult (..)+ -- * Basic testing library+ Assertions,+ assertions,+ IsAssertion,+ Assertion,+ assertionPassed,+ assertionFailed,+ assert,+ expect,+ die,+ trace,+ note,+ afterTest,+ requireLeft,+ requireRight, - -- *** Failures- , Failure- , failure- , failureLocation- , failureMessage+ -- ** Built-in assertions+ equal,+ notEqual,+ equalWithin,+ just,+ nothing,+ left,+ right,+ throws,+ throwsEq,+ greater,+ greaterEqual,+ lesser,+ lesserEqual,+ sameItems,+ equalItems,+ IsText,+ equalLines,+ equalLinesWith, - -- *** Failure locations- , Location- , location- , locationFile- , locationModule- , locationLine+ -- * Custom test types+ Test,+ test,+ testName,+ runTest, - -- ** Test options- , TestOptions- , defaultTestOptions- , testOptionSeed- , testOptionTimeout- ) where+ -- ** Test results+ TestResult (..), -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.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+ -- *** Failures+ Failure,+ failure,+ failureLocation,+ failureMessage, -import qualified Language.Haskell.TH as TH+ -- *** Failure locations+ Location,+ location,+ locationFile,+ locationModule,+ locationLine, -import qualified Patience+ -- ** Test options+ TestOptions,+ defaultTestOptions,+ testOptionSeed,+ testOptionTimeout,+ )+where -import Test.Chell.Main (defaultMain)-import Test.Chell.Types+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.@@ -156,68 +149,55 @@ assertionFailed = AssertionFailed -- | See 'assert' and 'expect'.-class IsAssertion a- where- runAssertion :: a -> IO Assertion+class IsAssertion a where+ runAssertion :: a -> IO Assertion -instance IsAssertion Assertion- where- runAssertion = return+instance IsAssertion Assertion where+ runAssertion = return -instance IsAssertion Bool- where- runAssertion x =- return- (- if x- then assertionPassed- else assertionFailed "boolean assertion failed"- )+instance IsAssertion Bool where+ runAssertion x =+ return+ ( if x+ then assertionPassed+ else assertionFailed "boolean assertion failed"+ ) -instance IsAssertion a => IsAssertion (IO a)- where- runAssertion x = x >>= runAssertion+instance IsAssertion a => IsAssertion (IO a) where+ runAssertion x = x >>= runAssertion type TestState = (IORef [(String, String)], IORef [IO ()], [Failure]) -- | See 'assertions'.-newtype Assertions a =- Assertions- { unAssertions :: TestState -> IO (Maybe a, TestState) }--instance Functor Assertions- where- fmap = liftM+newtype Assertions a = Assertions+ {unAssertions :: TestState -> IO (Maybe a, TestState)} -instance Control.Applicative.Applicative Assertions- where- pure = return- (<*>) = ap+instance Functor Assertions where+ fmap = liftM -instance Monad Assertions- where- return x =- Assertions (\s -> return (Just x, s))+instance Control.Applicative.Applicative Assertions where+ pure x = Assertions (\s -> pure (Just x, s))+ (<*>) = ap - 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 Monad Assertions where+ 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)- )+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. --@@ -229,57 +209,55 @@ -- @ assertions :: String -> Assertions a -> Test assertions name testm =- test name $ \opts ->- do- noteRef <- newIORef []- afterTestRef <- newIORef []+ test name $ \opts ->+ do+ noteRef <- newIORef []+ afterTestRef <- newIORef [] - let- getNotes = fmap reverse (readIORef noteRef)+ 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))+ 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)+ 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+ 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))+ 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. --@@ -287,15 +265,16 @@ -- 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) |]+ let qloc = liftLoc loc+ [|\msg -> dieAt $qloc ("die: " ++ msg)|] dieAt :: TH.Loc -> String -> Assertions a dieAt loc msg =@@ -311,22 +290,22 @@ -- 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 |]+ let qloc = liftLoc loc+ [|traceAt $qloc|] traceAt :: TH.Loc -> String -> Assertions () traceAt loc msg = liftIO $ do- let- file = TH.loc_filename loc+ let file = TH.loc_filename loc line = fst (TH.loc_start loc) putStr ("[" ++ file ++ ":" ++ show line ++ "] ") putStrLn msg@@ -336,19 +315,23 @@ -- debugging failing tests. note :: String -> String -> Assertions () note key value =- Assertions (\(notes, afterTestRef, fs) ->- do- modifyIORef notes ((key, value) :)- return (Just (), (notes, afterTestRef, fs)))+ 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)))+ 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.@@ -357,25 +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 |]+ 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 "")+ 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.@@ -384,29 +367,29 @@ -- 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 |]+ 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+ 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 |]+ [|TH.Loc filename package module_ start end|] where filename = TH.loc_filename loc package = TH.loc_package loc@@ -419,11 +402,11 @@ do result <- liftIO (runAssertion assertion) case result of- AssertionPassed -> return ()- AssertionFailed err ->- if fatal- then dieAt loc err- else addFailure (Just loc) err+ 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.@@ -435,15 +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 |]+ 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'.@@ -455,42 +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 |]+ 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)+ 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)+ 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 ::+ (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)+ 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@@ -499,9 +488,9 @@ -- | Assert that some value is @Nothing@. nothing :: Show a => Maybe a -> Assertion nothing x =- assertBool- (isNothing x)- ("nothing: received " ++ showsPrec 11 x "")+ assertBool+ (isNothing x)+ ("nothing: received " ++ showsPrec 11 x "") -- | Assert that some value is @Left@. left :: Show b => Either a b -> Assertion@@ -525,13 +514,17 @@ 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"+ 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@@ -542,110 +535,117 @@ 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"+ 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)+ 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)+ 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)+ 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)+ 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' ::+ (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 (:[])+ items = norm . foldMap (: []) checkDiff xs ys =- case checkItems (Patience.diff xs ys) of- (same, diff) -> assertBool same diff+ 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)))+ 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)+ 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+class IsText a where+ toLines :: a -> [a]+ unpack :: a -> String -instance IsText String- where- toLines = lines- unpack = id+instance IsText String where+ toLines = lines+ unpack = id -instance IsText Text- where- toLines = Data.Text.lines- unpack = Data.Text.unpack+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+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+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+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@@ -662,17 +662,17 @@ checkLinesDiff label = go where go xs ys =- case checkItems (Patience.diff xs ys) of- (same, diff) -> assertBool same diff+ 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)))+ 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)+ 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,82 +1,86 @@-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- }+data MainOptions = MainOptions+ { optVerbose :: Bool,+ optXmlReport :: String,+ optJsonReport :: String,+ optTextReport :: String,+ optSeed :: Maybe Int,+ optTimeout :: Maybe Int,+ optColor :: ColorMode+ } optionType_ColorMode :: OptionType ColorMode optionType_ColorMode = optionType "ColorMode" ColorModeAuto parseMode showMode where parseMode s =- case s of- "always" -> Right ColorModeAlways- "never" -> Right ColorModeNever- "auto" -> Right ColorModeAuto- _ -> Left (show s ++ " is not in {\"always\", \"never\", \"auto\"}.")+ 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."+ case mode of+ ColorModeAlways -> "always"+ ColorModeNever -> "never"+ ColorModeAuto -> "auto" - <*> defineOption optionType_ColorMode- (\o -> o- { optionLongFlags = ["color"]- , optionDefault = ColorModeAuto- , optionDescription = "Whether to enable color ('always', 'auto', or 'never')."- }- )+instance Options MainOptions where+ defineOptions =+ pure MainOptions+ <*> defineOption+ optionType_bool+ ( \o ->+ o+ { optionShortFlags = ['v'],+ optionLongFlags = ["verbose"],+ optionDefault = False,+ optionDescription = "Print more output."+ }+ )+ <*> simpleOption+ "xml-report"+ ""+ "Write a parsable report to a given path, in XML."+ <*> simpleOption+ "json-report"+ ""+ "Write a parsable report to a given path, in JSON."+ <*> simpleOption+ "text-report"+ ""+ "Write a human-readable report to a given path."+ <*> simpleOption+ "seed"+ Nothing+ "The seed used for random numbers in (for example) quickcheck."+ <*> simpleOption+ "timeout"+ Nothing+ "The maximum duration of a test, in milliseconds."+ <*> defineOption+ optionType_ColorMode+ ( \o ->+ o+ { optionLongFlags = ["color"],+ optionDefault = ColorModeAuto,+ optionDescription = "Whether to enable color ('always', 'auto', or 'never')."+ }+ ) -- | A simple default main function, which runs a list of tests and logs -- statistics to stdout.@@ -85,45 +89,43 @@ do -- validate/sanitize test options seed <-- case optSeed opts of- Just s -> return s- Nothing -> randomIO+ 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+ 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 allTests = concatMap suiteTests suites tests =- if null args- then allTests- else filter (matchesFilter args) allTests+ 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)+ 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 ->@@ -134,24 +136,22 @@ return (t, result) -- generate reports- let- reports = getReports opts+ 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)+ withBinaryFile path WriteMode $ \h ->+ do+ when (optVerbose opts) $+ putStrLn ("Writing " ++ fmt ++ " report to " ++ show path)+ hPutStr h (toText results) - let- stats = resultStatistics results+ let stats = resultStatistics results (_, _, failed, aborted) = stats putStrLn (formatResultStatistics stats) if failed == 0 && aborted == 0- then exitSuccess- else exitFailure+ then exitSuccess+ else exitFailure matchesFilter :: [String] -> Test -> Bool matchesFilter filters = check@@ -165,14 +165,14 @@ getReports opts = concat [xml, json, text] where xml = case optXmlReport opts of- "" -> []- path -> [(path, "XML", xmlReport)]+ "" -> []+ path -> [(path, "XML", xmlReport)] json = case optJsonReport opts of- "" -> []- path -> [(path, "JSON", jsonReport)]+ "" -> []+ path -> [(path, "JSON", jsonReport)] text = case optTextReport opts of- "" -> []- path -> [(path, "text", textReport)]+ "" -> []+ path -> [(path, "text", textReport)] jsonReport :: [(Test, TestResult)] -> String jsonReport results = Writer.execWriter writer@@ -186,68 +186,68 @@ 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 ->+ 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 "{\"test\": \""- tell (escapeJSON (testName t))- tell "\", \"result\": \"aborted\", \"abortion\": {\"message\": \""- tell (escapeJSON msg)- tell "\"}"- tellNotes notes+ 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 "}"- _ -> return ()+ 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]- )+ concatMap+ ( \c ->+ case c of+ '"' -> "\\\""+ '\\' -> "\\\\"+ _ | ord c <= 0x1F -> printf "\\u%04X" (ord c)+ _ -> [c]+ ) tellNotes notes = do@@ -264,12 +264,11 @@ commas xs block = State.evalStateT (commaState xs block) False commaState xs block = forM_ xs $ \x -> do- let- tell' = lift . Writer.tell+ let tell' = lift . Writer.tell needComma <- State.get if needComma- then tell' "\n, "- else tell' "\n "+ then tell' "\n, "+ else tell' "\n " State.put True lift (block x) @@ -309,22 +308,22 @@ 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"+ 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 ->@@ -340,16 +339,16 @@ _ -> return () escapeXML =- concatMap- (\c ->- case c of- '&' -> "&"- '<' -> "<"- '>' -> ">"- '"' -> """- '\'' -> "'"- _ -> [c]- )+ concatMap+ ( \c ->+ case c of+ '&' -> "&"+ '<' -> "<"+ '>' -> ">"+ '"' -> """+ '\'' -> "'"+ _ -> [c]+ ) tellNotes notes = forM_ notes $ \(key, value) -> do@@ -371,62 +370,62 @@ 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 ->+ 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- 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 ->+ case failureLocation f of+ Just loc ->+ do+ tell (locationFile loc)+ case locationLine loc of+ Just line -> do- tell (locationFile loc)- case locationLine loc of- Just line ->- do- tell ":"- tell (show line)- Nothing -> return ()- tell "\n"+ tell ":"+ tell (show line) 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"+ Nothing -> return ()+ tell (failureMessage f) tell "\n\n"- _ -> return ()+ 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@@ -436,37 +435,36 @@ tell "\n" formatResultStatistics :: (Integer, Integer, Integer, Integer) -> String-formatResultStatistics stats = Writer.execWriter writer where- writer =- do- let- (passed, skipped, failed, aborted) = stats+formatResultStatistics stats = Writer.execWriter writer+ where+ writer =+ do+ let (passed, skipped, failed, aborted) = stats - if failed == 0 && aborted == 0+ if failed == 0 && aborted == 0 then Writer.tell "PASS: " else Writer.tell "FAIL: " - let- putNum comma n what = Writer.tell $- if n == 1+ 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]+ 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")+ 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 ()+ 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,57 +1,55 @@ {-# 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 ()- }+data Output = Output+ { outputStart :: Test -> IO (),+ outputResult :: Test -> TestResult -> IO ()+ } plainOutput :: Bool -> Output plainOutput v = Output- { outputStart = plainOutputStart v- , outputResult = plainOutputResult v+ { outputStart = plainOutputStart v,+ outputResult = plainOutputResult v } plainOutputStart :: Bool -> Test -> IO () plainOutputStart v t =- when v $- do- putStr "[ RUN ] "- putStrLn (testName 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 ""+ when v $+ do+ putStr "[ PASS ] "+ putStrLn (testName t)+ putStrLn "" plainOutputResult v t TestSkipped =- when v $- do- putStr "[ SKIP ] "- putStrLn (testName t)- putStrLn ""+ when v $+ do+ putStr "[ SKIP ] "+ putStrLn (testName t)+ putStrLn "" plainOutputResult _ t (TestFailed notes fs) = do putStr "[ FAIL ] "@@ -154,30 +152,30 @@ printNotes :: [(String, String)] -> IO () printNotes notes =- unless (null notes) $- do- forM_ notes $ \(key, value) ->- do- putStr " note: "- putStr key- putStr "="- putStrLn value- putStrLn ""+ 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"+ 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,52 +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)+instance Show Test where+ showsPrec d (Test name _) = showParen (d > 10) (showString "Test " . shows name) -- | Define a test, with the given name and implementation. test :: String -> (TestOptions -> IO TestResult) -> Test@@ -58,11 +50,8 @@ -- | 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+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. --@@ -71,9 +60,8 @@ -- -- '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+ 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@@ -81,9 +69,9 @@ -- -- 'testOptionTimeout' is a field accessor, and can be used to update -- a 'TestOptions' value.- , testOptionTimeout :: Maybe Int- }- deriving (Show, Eq)+ testOptionTimeout :: Maybe Int+ }+ deriving (Show, Eq) -- | Default test options. --@@ -98,8 +86,8 @@ defaultTestOptions :: TestOptions defaultTestOptions = TestOptions- { testOptionSeed = 0- , testOptionTimeout = Nothing+ { testOptionSeed = 0,+ testOptionTimeout = Nothing } -- | The result of running a test.@@ -108,71 +96,60 @@ -- 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+ = -- | 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,+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-+ 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)+ failureMessage :: String+ }+ deriving (Show, Eq) -- | An empty 'Failure'; use the field accessors to populate this value. failure :: Failure failure = Failure Nothing "" -- | Contains details about a location in the test source file.-data Location =- Location- {- -- | A path to a source file, or empty if not provided.+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-+ 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-+ 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)+ locationLine :: Maybe Integer+ }+ deriving (Show, Eq) -- | An empty 'Location'; use the field accessors to populate this value. location :: Location@@ -183,52 +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+class SuiteOrTest a where+ skipIf_ :: Bool -> a -> a+ skipWhen_ :: IO Bool -> a -> a -instance SuiteOrTest Suite- where- skipIf_ skip s@(Suite name children) =- if skip- then Suite name (map (skipIf_ skip) children)- else s+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)+ 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+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- )+ 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_ @@ -236,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@@ -253,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 -- ]@@ -298,12 +272,12 @@ suiteTests = go "" where prefixed prefix str =- if null prefix- then str- else prefix ++ "." ++ str+ if null prefix+ then str+ else prefix ++ "." ++ str go prefix (Suite name children) =- concatMap (step (prefixed prefix name)) children+ concatMap (step (prefixed prefix name)) children step prefix (Test name io) = [Test (prefixed prefix name) io] @@ -315,29 +289,27 @@ 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 withTimeout =+ case testOptionTimeout opts of+ Just time -> timeout (time * 1000)+ Nothing -> fmap Just - let- hitTimeout = str+ 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)+ 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]
changelog.md view
@@ -1,14 +1,35 @@-# Release history for `chell`+## 0.5.0.2 -0.5.0.1 - 2021 Jan 14+Miscellaneous updates and cleanup - * Support up to GHC 9.2- * Tighten various version bounds+Published by: Chris Martin -0.5 - 2019 Feb 16+Date: 2023-07-11 - * Add support for `patience` 0.2- * Drop support for `patience` 0.1- * Add support for `ansi-terminal` 0.8+## 0.5.0.1 -0.4.0.2 - 2017 Dec 12+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,7 +1,7 @@ cabal-version: 3.0 name: chell-version: 0.5.0.1+version: 0.5.0.2 synopsis: A simple and intuitive library for automated testing. category: Testing@@ -10,82 +10,42 @@ license-file: license.txt author: John Millikin <john@john-millikin.com> maintainer: Chris Martin, Julie Moronuki-build-type: Simple -homepage: https://github.com/typeclasses/chell-bug-reports: https://github.com/typeclasses/chell/issues+homepage: https://github.com/typeclasses/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.-- An example test suite, which verifies the behavior of arithmetic 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- @--extra-source-files:- changelog.md+ 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 head- type: git- location: https://github.com/typeclasses/chell.git+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- default-language: Haskell2010- ghc-options: -Wall-- build-depends:- base >= 4.10 && < 4.17- , bytestring >= 0.10.8.2 && < 0.12- , options >= 1.2.1 && < 1.3- , patience >= 0.2 && < 0.4- , random >= 1.1 && < 1.3- , template-haskell >= 2.12 && < 2.19- , text >= 1.2.3 && < 1.2.6- , transformers >= 0.5.2 && < 0.6+ default-language: GHC2021+ ghc-options: -Wall - if flag(color-output) build-depends:- ansi-terminal >= 0.8 && < 0.12+ , 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+```